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

      SUBROUTINE GALCDF(X,AK,TAU,IADEDF,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE GENERALIZED ASYMMETRIC LAPLACE
C              DISTRIBUTION WITH SHAPE PARAMETERS AK AND LAMBDA.
C              THIS DISTRIBUTION IS DEFINED FOR ALL X AND HAS
C              THE PROBABILITY DENSITY FUNCTION
C                 GALPDF(X,K,TAU) = C1*C2*C3        X <> 0
C              WITH
C                 C1 = SQRT(2/PI)*EXP((SQRT(2)/2)*((1/K)-K)*X)/
C                      GAMMA(TAU)
C                 C2 = ((SQRT(2)*ABS(X)/(K+(1/K))**(TAU-0.5)
C                 C3 = K(TAU-0.5)((SQRT(2)/2)*((1/K)+K)*ABS(X))
C              WHERE K(LAMBDA) IS THE MODIFIED BESSEL FUNCTION
C              OF THE THIRD KIND.
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                     --AK     = THE FIRST SHAPE PARAMETER
C                     --TAU    = 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 CDF FOR THE GENERALIZED ASYMMETRIC
C             LAPLACE DISTRIBUTION WITH SHAPE PARAMETERS DAK AND DTAU.
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--KOTZ, KOZUBOWSKI, AND PODGORSKI, "THE LAPLACE
C                 DISTRIBUTION AND GENERALIZATIONS: A REVISIT WITH
C                 APPLICATIONS TO COMMUNICATIONS, ECONOMICS,
C                 ENGINEERING, AND FINANCE", BIRKHAUSER, 2001,
C                 PP. 189.
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 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004.8
C     ORIGINAL VERSION--AUGUST    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)
C
      DOUBLE PRECISION AK
      DOUBLE PRECISION TAU
      DOUBLE PRECISION X
      DOUBLE PRECISION CDF
      DOUBLE PRECISION EPSABS
      DOUBLE PRECISION EPSREL
      DOUBLE PRECISION DCDF
      DOUBLE PRECISION DX
      DOUBLE PRECISION ABSERR
      DOUBLE PRECISION WORK(LENW)
C
      DOUBLE PRECISION GALFUN
      EXTERNAL GALFUN
C
      CHARACTER*4 IADEDF
      CHARACTER*4 IADED2
C
      DOUBLE PRECISION DAK
      DOUBLE PRECISION DTAU
      COMMON/GALCOM/DAK,DTAU
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
      IADED2=IADEDF
C
      IF(IADEDF.EQ.'K')THEN
        IF(AK.LE.0.0)THEN
          WRITE(ICOUT,5)
    5     FORMAT('***** ERROR: VALUE OF FIRST SHAPE PARAMETER (K) ',
     1           'IN THE GALCDF ROUTINE IS NON-POSITIVE.')
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,48)AK
   48     FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7,',')
          CALL DPWRST('XXX','WRIT')
          GOTO9000
        ENDIF
      ELSE
        AK=SQRT(2.0)/(AK + SQRT(2.0 + AK*AK))
      ENDIF
C
      IF(TAU.LE.0.0)THEN
        WRITE(ICOUT,15)
   15   FORMAT('***** ERROR--THE SECOND SHAPE PARAMETER (TAU) IN ',
     1         'THE GALCDF ROUTINE IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,48)TAU
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
C               ************************************
C               **  STEP 1--                      **
C               **  COMPUTE THE DENSITY FUNCTION  **
C               ************************************
C
      IADEDF='K'
      INF=-1
      EPSABS=0.0D0
      EPSREL=1.0D-7
      IER=0
      CDF=0.0D0
C
      DX=DBLE(X)
      DTAU=DBLE(TAU)
      DAK=DBLE(AK)
C
      IFLAG=0
      IF(DX.LT.0.0D0)THEN
        IFLAG=1
        INF=1
      ENDIF
C
      CALL DQAGI(GALFUN,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 GALCDF--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,113)
  113   FORMAT('      MAXIMUM AKMBER 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 GALCDF--')
        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 GALCDF--')
        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 GALCDF--')
        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 GALCDF--')
        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 GALCDF--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,163)
  163   FORMAT('      INVALID INPUT TO THE INTEGRATION ROUTINE.')
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
 9000 CONTINUE
      IADEDF=IADED2
      RETURN
      END
      DOUBLE PRECISION FUNCTION GALFUN(DX)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE GENERALIZED ASYMMETRIC LAPLACE
C              DISTRIBUTION WITH SHAPE PARAMETERS AK AND TAU.
C              THIS DISTRIBUTION IS DEFINED
C              FOR ALL X AND HAS THE PROBABILITY DENSITY FUNCTION
C                 GALPDF(X,K,TAU) = C1*C2*C3        X <> 0
C              WITH
C                 C1 = SQRT(2/PI)*EXP((SQRT(2)/2)*((1/K)-K)*X)/
C                      GAMMA(TAU)
C                 C2 = ((SQRT(2)*ABS(X)/(K+(1/K))**(TAU-0.5)
C                 C3 = K(TAU-0.5)((SQRT(2)/2)*((1/K)+K)*ABS(X))
C              WHERE K(LAMBDA) IS THE MODIFIED BESSEL FUNCTION
C              OF THE THIRD KIND.
C              BUT DEFINE AS FUNCTION TO BE USED FOR INTEGRATION
C              CODE CALLED BY GALCDF.  ALSO, 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--GALFUN  = THE DOUBLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE PDF FOR THE GENERALIZED ASYMMETRIC
C             LAPLACE DISTRIBUTION WITH SHAPE PARAMETERS AK AND TAU.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--GALPDF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--KOTZ, KOZUBOWSKI, AND PODGORSKI, "THE LAPLACE
C                 DISTRIBUTION AND GENERALIZATIONS: A REVISIT WITH
C                 APPLICATIONS TO COMMUNICATIONS, ECONOMICS,
C                 ENGINEERING, AND FINANCE", BIRKHAUSER, 2001,
C                 PP. 189.
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 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004.7
C     ORIGINAL VERSION--JULY      2004.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DTERM2
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DAK
      DOUBLE PRECISION DTAU
      COMMON/GALCOM/DAK,DTAU
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOST.INC'
      INCLUDE 'DPCOP2.INC'
C
C-----DATA STATEMENTS-------------------------------------------------
C
C-----START POINT-----------------------------------------------------
C
C               ************************************
C               **  STEP 1--                      **
C               **  COMPUTE THE DENSITY FUNCTION  **
C               ************************************
C
      CALL GALPDF(DX,DAK,DTAU,IADEDF,DTERM2)
      GALFUN=DTERM2
C
      RETURN
      END
      DOUBLE PRECISION FUNCTION GALFU2(DX)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE GENERALIZED ASYMMETRIC LAPLACE
C              DISTRIBUTION WITH SHAPE PARAMETERS K AND TAU.
C              THIS DISTRIBUTION IS DEFINED FOR ALL REAL X.
C     INPUT  ARGUMENTS--DX      = THE DOUBLE PRECISION VALUE AT
C                                 WHICH THE CUMULATIVE DISTRIBUTION
C                                 FUNCTION IS TO BE EVALUATED.
C     OUTPUT ARGUMENTS--GALFU2  = THE DOUBLE PRECISION CUMULATIVE
C                                 DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE FOR THE GENERALIZED ASYMMETRIC LAPLACE
C             DISTRIBUTION WITH SHAPE PARAMETERS K AND TAU.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--GALCDF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--KOTZ, KOZUBOWSKI, AND PODGORSKI, "THE LAPLACE
C                 DISTRIBUTION AND GENERALIZATIONS: A REVISIT WITH
C                 APPLICATIONS TO COMMUNICATIONS, ECONOMICS,
C                 ENGINEERING, AND FINANCE", BIRKHAUSER, 2001,
C                 PP. 189.
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 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004.8
C     ORIGINAL VERSION--AUGUST    2004.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOST.INC'
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DCDF
C
      DOUBLE PRECISION DP
      COMMON/GA2COM/DP
C
      DOUBLE PRECISION DK
      DOUBLE PRECISION DTAU
      COMMON/GALCOM/DK,DTAU
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----DATA STATEMENTS-------------------------------------------------
C
C-----START POINT-----------------------------------------------------
C
C               ************************************
C               **  STEP 1--                      **
C               **  COMPUTE THE CDF     FUNCTION  **
C               ************************************
C
      CALL GALCDF(DX,DK,DTAU,IADEDF,DCDF)
      GALFU2=DP - DCDF
C
      RETURN
      END
      SUBROUTINE GALPDF(X,AK,TAU,IADEDF,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE GENERALIZED ASYMMETRIC LAPLACE
C              DISTRIBUTION.  THIS IS ALSO KNOWN AS THE BESSEL
C              K-FUNCTION DISTRIBUTION.  IT HAS SHAPE PARAMETERS
C              K AND TAU (IF TAU = 1, THIS REDUCES TO THE ASYMMETRIC
C              LAPLACE DISTRIBUTION, IF K = 1, THIS IS A SYMMETRIC
C              DISTRIBUTIONS).  THIS DISTRIBUTION IS DEFINED
C              FOR ALL X AND HAS THE PROBABILITY DENSITY FUNCTION
C                 GALPDF(X,K,TAU) = C1*C2*C3        X <> 0
C              WITH
C                 C1 = SQRT(2/PI)*EXP((SQRT(2)/2)*((1/K)-K)*X)/
C                      GAMMA(TAU)
C                 C2 = ((SQRT(2)*ABS(X)/(K+(1/K))**(TAU-0.5)
C                 C3 = K(TAU-0.5)((SQRT(2)/2)*((1/K)+K)*ABS(X))
C              WHERE K(LAMBDA) IS THE MODIFIED BESSEL FUNCTION
C              OF THE THIRD KIND.
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                               X SHOULD BE NON-NEGATIVE.
C                     --AK    = THE FIRST SHAPE PARAMETER
C                     --TAU   = THE SECOND 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 ASYMMETRIC LAPLACE DISTRIBUTION
C             WITH SHAPE PARAMETER = K.
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--KOTZ, KOZUBOWSKI, AND PODGORSKI, "THE LAPLACE
C                 DISTRIBUTION AND GENERALIZATIONS: A REVISIT WITH
C                 APPLICATIONS TO COMMUNICATIONS, ECONOMICS,
C                 ENGINEERING, AND FINANCE", BIRKHAUSER, 2001,
C                 PP. 189.
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 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004.6
C     ORIGINAL VERSION--JUNE      2004.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION X
      DOUBLE PRECISION AK
      DOUBLE PRECISION TAU
      DOUBLE PRECISION DX
      DOUBLE PRECISION DK
      DOUBLE PRECISION DTAU
      DOUBLE PRECISION PDF
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
      DOUBLE PRECISION DTERM4
      DOUBLE PRECISION DC1
      DOUBLE PRECISION DC2
      DOUBLE PRECISION DC3
      DOUBLE PRECISION DC4
      DOUBLE PRECISION DC5
      DOUBLE PRECISION DC6
      DOUBLE PRECISION DPI
      DOUBLE PRECISION DEPS
      DOUBLE PRECISION DSAVE
      DOUBLE PRECISION DGAMMA
      EXTERNAL DGAMMA
C
      DOUBLE PRECISION DTEMP1(10)
C
      CHARACTER*4 IADEDF
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----DATA STATEMENTS-------------------------------------------------
C
      DATA DPI / 3.14159265358979D+00/
      DATA DEPS /0.00000001D0/
C
C-----START POINT-----------------------------------------------------
C
C               *****************************************
C               **  STEP 1--                           **
C               **  CHECK FOR VALID PARAMETERS         **
C               *****************************************
C
      PDF=0.0
      DSAVE=0.0D0
      IF(IADEDF.EQ.'K')THEN
        IF(AK.LE.0.0)THEN
          WRITE(ICOUT,5)
    5     FORMAT('***** ERROR: VALUE OF FIRST SHAPE PARAMETER (K) ',
     1           'IN GALPDF ROUTINE IS NON-POSITIVE.')
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,48)AK
   48     FORMAT('      VALUE OF ARGUMENT IS: ',G15.7,'.')
          CALL DPWRST('XXX','WRIT')
          GOTO9000
        ENDIF
      ELSE
        AK=SQRT(2.0)/(AK + SQRT(2.0 + AK*AK))
      ENDIF
C
      IF(TAU.LE.0.0D0)THEN
        WRITE(ICOUT,6)
    6   FORMAT('***** ERROR: VALUE OF SHAPE PARAMETER (TAU) IN ',
     1         'GALPDF ROUTINE IS NEGATIVE.')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,48)TAU
        CALL DPWRST('XXX','WRIT')
        PDF=0.0D0
        GOTO9000
      ENDIF
C
      DX=X
      DK=AK
      DTAU=TAU
C
C               *****************************************
C               **  STEP 2--                           **
C               **  COMPUTE THE DENSITY FUNCTION.  FOR **
C               **  BETTER NUMERICAL STABILITY,        **
C               **  COMPUTE LOGARIGHMS.                **
C               *****************************************
C
C
      IF(X.EQ.0.0D0)THEN
        DX=DEPS
        IPASS=1
      ENDIF
C
 1000 CONTINUE
C
C  COMPUTE BESSEL FUNCTION FIRST.  IF THIS IS 0, SET PDF TO
C  0 AND RETURN.
C
      DC5=(DSQRT(2.0D0)/2.0D0)*(DK + (1.0D0/DK))
      DC6=DTAU - 0.5D0
      IF(DC6.LT.0.0D0)DC6=-DC6
      IARG1=1
      ISCALE=1
      CALL DBESK(DC5*DABS(DX),DC6,ISCALE,IARG1,DTEMP1,NZERO)
      DTERM3=DTEMP1(IARG1)
      IF(DTERM3.LE.0.0D0)THEN
        PDF=0.0D0
        GOTO9000
      ENDIF
      DTERM3=DLOG(DTEMP1(IARG1))
C
      DC1=DSQRT(2.0D0/DPI)/DGAMMA(DTAU)
      DC2=(DSQRT(2.0D0)/2.0D0)*((1.0D0/DK) - DK)
      DTERM1=DLOG(DC1) + DC2*DX
      DC3=DSQRT(2.0D0)/(DK + (1.0D0/DK))
      DC4=DTAU - 0.5D0
      DTERM2=DC4*DLOG(DC3*DABS(DX))
C
      DTERM4=DTERM1+DTERM2+DTERM3
      PDF=DEXP(DTERM4)
C
      IF(X.EQ.0.0D0)THEN
        IF(IPASS.EQ.1)THEN
          DSAVE=PDF
          IPASS=2
          DX=-DEPS
          GOTO1000
        ELSEIF(IPASS.EQ.2)THEN
          PDF=(PDF+DSAVE)/2.0D0
        ENDIF
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE GALPPF(P,AK,TAU,IADEDF,PPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE GENERALIZED ASYMMETRIC LAPLACE
C              DISTRIBUTION.  IT HAS SHAPE PARAMETERS AK AND TAU.
C              THIS DISTRIBUTION IS DEFINED FOR ALL REAL
C              X AND HAS THE PROBABILITY DENSITY FUNCTION
C
C                 GALPDF(X,K,TAU) = C1*C2*C3        X <> 0
C              WITH
C                 C1 = SQRT(2/PI)*EXP((SQRT(2)/2)*((1/K)-K)*X)/
C                      GAMMA(TAU)
C                 C2 = ((SQRT(2)*ABS(X)/(K+(1/K))**(TAU-0.5)
C                 C3 = K(TAU-0.5)((SQRT(2)/2)*((1/K)+K)*ABS(X))
C              WHERE K(LAMBDA) IS THE MODIFIED BESSEL FUNCTION
C              OF THE THIRD KIND.
C              THE PERCENT POINT FUNCTION IS COMPUTED BY NUMERICALLY
C              INVERTING THE GENERALIZED ASYMMETRIC LAPLACE CUMULATIVE
C              DISTRIBUTION FUNCTION (WHICH IN TURN IS COMPUTED BY
C              NUMERICAL INTEGRATION OF THE PROBABILITYT DENSITY.
C
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                     --AK      = THE FIRST SHAPE PARAMETER
C                     --TAU     = THE SECOND SHAPE PARAMETER
C     OUTPUT ARGUMENTS--PPF     = THE DOUBLE PRECISION PERCENT POINT
C                                 FUNCTION VALUE.
C     OUTPUT--THE DOUBEL PRECISION PERCENT POINT FUNCTION
C             VALUE PPF FOR THE GENERALIZED ASYMMETRIC LAPLACE
C             DISTRIBUTION WITH SHAPE PARAMETERS = AK AND TAU.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--DFZERO.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--KOTZ, KOZUBOWSKI, AND PODGORSKI, "THE LAPLACE
C                 DISTRIBUTION AND GENERALIZATIONS: A REVISIT WITH
C                 APPLICATIONS TO COMMUNICATIONS, ECONOMICS,
C                 ENGINEERING, AND FINANCE", BIRKHAUSER, 2001,
C                 PP. 189.
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 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004.8
C     ORIGINAL VERSION--AUGUST    2004.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION P
      DOUBLE PRECISION AK
      DOUBLE PRECISION TAU
      DOUBLE PRECISION PPF
C
      DOUBLE PRECISION DMEAN
      DOUBLE PRECISION DSD
      DOUBLE PRECISION DU
      DOUBLE PRECISION PTEMPL
      DOUBLE PRECISION PTEMPU
C
      DOUBLE PRECISION XUP
      DOUBLE PRECISION XUP2
      DOUBLE PRECISION XLOW
      DOUBLE PRECISION RE
      DOUBLE PRECISION AE
C
      DOUBLE PRECISION GALFU2
      EXTERNAL GALFU2
C
      DOUBLE PRECISION DP
      COMMON/GA2COM/DP
C
      DOUBLE PRECISION DAK
      DOUBLE PRECISION DTAU
      COMMON/GALCOM/DAK,DTAU
C
      CHARACTER*4 IADEDF
      CHARACTER*4 IADED2
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C               *****************************************
C               **  STEP 1--                           **
C               **  CHECK FOR VALID PARAMETERS         **
C               *****************************************
C
      PPF=0.0D0
      IADED2=IADEDF
C
      IF(IADEDF.EQ.'K')THEN
        IF(AK.LE.0.0)THEN
          WRITE(ICOUT,5)
    5     FORMAT('***** ERROR: VALUE OF FIRST SHAPE PARAMETER (K) ',
     1           'IN GALPPF ROUTINE IS NON-POSITIVE.')
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,48)AK
   48     FORMAT('      VALUE OF ARGUMENT IS: ',G15.7,'.')
          CALL DPWRST('XXX','WRIT')
          GOTO9000
        ENDIF
      ELSE
        AK=SQRT(2.0)/(AK + SQRT(2.0 + AK*AK))
      ENDIF
C
      IF(P.LE.0.0D0 .OR. P.GE.1.0D0)THEN
        WRITE(ICOUT,4)
    4   FORMAT('***** ERROR: VALUE OF INPUT ARGUMENT (P) IN ',
     1         'GALPPF ROUTINE')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,14)
   14   FORMAT('      IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL.')
        WRITE(ICOUT,48)P
        CALL DPWRST('XXX','WRIT')
        CALL DPWRST('XXX','WRIT')
        GOTO9000
      ELSEIF(TAU.LE.0.0)THEN
        WRITE(ICOUT,6)
    6   FORMAT('***** ERROR: VALUE OF SHAPE PARAMETER (TAU) IN ',
     1         'GALPPF ROUTINE IS NON-POSITIVE.')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,48)TAU
        CALL DPWRST('XXX','WRIT')
        GOTO9000
      ENDIF
C
C               *****************************************
C               **  STEP 2--                           **
C               **  COMPUTE THE PERCENT POINT FUNCTION.**
C               *****************************************
C
C  STEP 1: FIND BRACKETING INTERVAL.  THIS DISTRIBUTION IS UNBOUNDED
C          IN BOTH DIRECTIONS.  BASIC ALGORITHM IS:
C
C          1) MEAN = TAU*(1/SQRT(2))*((1/K) - K)
C             SD   = SQRT(TAU*(U**2 + 1))
C
C             WHERE U = (1/SQRT(2))*((1/K) - K)
C
C          2) START WITH -MEAN AND +MEAN AS THE STARTING LOWER AND
C             UPPER BRACKETS.
C
C          3) INCREMENT IN INTERVALS OF 1 STANDARD DEVIATION.
C
      IADED2=IADEDF
      IADEDF='K'
C
      DAK=AK
      DTAU=TAU
      DU=(1.0D0/SQRT(2.0D0))*((1.0D0/DAK) - DAK)
      DMEAN=DTAU*DU
      DSD=DSQRT(DTAU*(DU**2 + 1.0D0))
C
      XLOW=-REAL(DMEAN)
      XUP2=REAL(DMEAN)
      CALL GALCDF(XLOW,AK,TAU,IADEDF,PTEMPL)
      CALL GALCDF(XUP2,AK,TAU,IADEDF,PTEMPU)
C
      MAXIT=1000
      NIT=0
C
  200 CONTINUE
        IF(NIT.GT.MAXIT)THEN
          PPF=0.0
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,131)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,133)
          CALL DPWRST('XXX','BUG ')
          GOTO9000
        ENDIF
        CALL GALCDF(XLOW,AK,TAU,IADEDF,PTEMPL)
        CALL GALCDF(XUP2,AK,TAU,IADEDF,PTEMPU)
        IF(PTEMPL.LE.P .AND. P.LE.PTEMPU)THEN
          XUP=XUP2
          GOTO300
        ELSEIF(P.GT.PTEMPU)THEN
          XLOW=XUP2
          XUP2=XUP2 + REAL(DSD)
          NIT=NIT+1
          GOTO200
        ELSEIF(P.LT.PTEMPL)THEN
          XUP2=XLOW
          XLOW=XLOW - REAL(DSD)
          NIT=NIT+1
          GOTO200
        ENDIF
C
  300 CONTINUE
      AE=1.D-7
      RE=1.D-7
      DP=P
      CALL DFZERO(GALFU2,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 GALPPF--')
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 GALPPF--')
        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 GALPPF--')
        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 GALPPF--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,143)
  143   FORMAT('      MAXIMUM ITERATIONS EXCEEDED.')
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
 9000 CONTINUE
      IADEDF=IADED2
      RETURN
      END
      SUBROUTINE GALRAN(N,AK,TAU,IADEDF,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE GENERALIZED ASYMMETRIC DOUBLE EXPONENTIAL
C              (LAPLACE) DISTRIBUTION WITH SHAPE PARAMETERS = AK AND
C              TAU.  THIS DISTRIBUTION IS DEFINED
C              FOR ALL X AND HAS THE PROBABILITY DENSITY FUNCTION
C                 GALPDF(X,K,TAU) = C1*C2*C3        X <> 0
C              WITH
C                 C1 = SQRT(2/PI)*EXP((SQRT(2)/2)*((1/K)-K)*X)/
C                      GAMMA(TAU)
C                 C2 = ((SQRT(2)*ABS(X)/(K+(1/K))**(TAU-0.5)
C                 C3 = K(TAU-0.5)((SQRT(2)/2)*((1/K)+K)*ABS(X))
C              WHERE K(LAMBDA) IS THE MODIFIED BESSEL FUNCTION
C              OF THE THIRD KIND.
C
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --AK     = THE FIRST SHAPE (PARAMETER) FOR THE
C                                GENERALIZED ASYMMETRIC DOUBLE
C                                EXPONENTIAL DISTRIBUTION.
C                     --TAU    = THE SECOND SHAPE (PARAMETER) FOR THE
C                                GENERALIZED ASYMMETRIC DOUBLE
C                                EXPONENTIAL 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 GENERALIZED ASYMMETRIC DOUBLE EXPONENTIAL
C             DISTRIBUTION WITH SHAPE PARAMETERS = AK AND TAU.
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                 --AK AND TAU MUST BE POSITIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN, NORRAN, GAMRAN.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--KOTZ, KOZUBOWSKI, AND PODGORSKI, "THE LAPLACE
C                 DISTRIBUTION AND GENERALIZATIONS: A REVISIT WITH
C                 APPLICATIONS TO COMMUNICATIONS, ECONOMICS,
C                 ENGINEERING, AND FINANCE", BIRKHAUSR, 2001,
C                 PP. 179-192.
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-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.6
C     ORIGINAL VERSION--JUNE      2004.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
      DIMENSION Y(2)
C
      CHARACTER*4 IADEDF
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
      IF(IADEDF.EQ.'K')THEN
        IF(AK.LE.0.0)THEN
          WRITE(ICOUT,15)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,48)AK
          CALL DPWRST('XXX','WRIT')
          GOTO9999
        ENDIF
      ELSE
        AK=SQRT(2.0)/(AK + SQRT(2.0 + AK*AK))
      ENDIF
      IF(AK.LE.0.0)THEN
        WRITE(ICOUT,25)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,48)TAU
        CALL DPWRST('XXX','WRIT')
        GOTO9999
      ENDIF
   15 FORMAT('***** ERROR: VALUE OF SHAPE PARAMETER (K) IS ',
     1       'NON-POSITIVE.')
   25 FORMAT('***** ERROR: VALUE OF SHAPE PARAMETER (TAU) IS ',
     1       'NON-POSITIVE.')
C
    5 FORMAT('***** ERROR--FOR THE GENERALIZED ASYMMETRIC DOUBLE ',
     1       'EXPONENTIAL DISTRIBUTION,')
    6 FORMAT('       THE REQUESTED NUMBER OF RANDOM NUMBERS WAS ',
     1      'NON-POSITIVE.')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,'.')
   48 FORMAT('      VALUE OF ARGUMENT IS: ',G15.7)
C
C     ALGORITHM FROM PAGE 183 OF KOTZ, ET. AL.:
C
C        Y =  (1/SQRT(2))*((1/K)*G1 - K*G2)
C
C     WHERE G1 AND G2 ARE INDEPENDENT GAMMA RANDOM VARIABLES WITH
C     SHAPE PARAMETER TAU.
C
      NTEMP=2
      C=(1.0/SQRT(2.0))
      DO100I=1,N
        CALL GAMRAN(NTEMP,TAU,ISEED,Y)
        G1=Y(1)
        G2=Y(2)
        APPF=C*((1.0/AK)*G1 - AK*G2)
        X(I)=APPF
  100 CONTINUE
C
 9999 CONTINUE
      RETURN
      END
      DOUBLE PRECISION FUNCTION gam1(a)
C     ------------------------------------------------------------------
C     COMPUTATION OF 1/GAMMA(A+1) - 1  FOR -0.5 .LE. A .LE. 1.5
C     ------------------------------------------------------------------
C     .. Scalar Arguments ..
      DOUBLE PRECISION a
C     ..
C     .. Local Scalars ..
      DOUBLE PRECISION bot,d,s1,s2,t,top,w
C     ..
C     .. Local Arrays ..
      DOUBLE PRECISION p(7),q(5),r(9)
C     ..
C     .. Data statements ..
C     -------------------
C     -------------------
C     -------------------
C     -------------------
      DATA p(1)/.577215664901533D+00/,p(2)/-.409078193005776D+00/,
     +     p(3)/-.230975380857675D+00/,p(4)/.597275330452234D-01/,
     +     p(5)/.766968181649490D-02/,p(6)/-.514889771323592D-02/,
     +     p(7)/.589597428611429D-03/
      DATA q(1)/.100000000000000D+01/,q(2)/.427569613095214D+00/,
     +     q(3)/.158451672430138D+00/,q(4)/.261132021441447D-01/,
     +     q(5)/.423244297896961D-02/
      DATA r(1)/-.422784335098468D+00/,r(2)/-.771330383816272D+00/,
     +     r(3)/-.244757765222226D+00/,r(4)/.118378989872749D+00/,
     +     r(5)/.930357293360349D-03/,r(6)/-.118290993445146D-01/,
     +     r(7)/.223047661158249D-02/,r(8)/.266505979058923D-03/,
     +     r(9)/-.132674909766242D-03/
      DATA s1/.273076135303957D+00/,s2/.559398236957378D-01/
C     ..
C     .. Executable Statements ..
C     -------------------
      t = a
      d = a - 0.5D0
      IF (d.GT.0.0D0) t = d - 0.5D0
CCCCC IF (t) 40,10,20
      IF(t.lt.0.0d0)THEN
        top = (((((((r(9)*t+r(8))*t+r(7))*t+r(6))*t+r(5))*t+
     1        r(4))*t+r(3))*t+r(2))*t + r(1)
        bot = (s2*t+s1)*t + 1.0D0
        w = top/bot
        IF (d.GT.0.0D0) THEN
           gam1 = t*w/a
        ELSE
          gam1 = a* ((w+0.5D0)+0.5D0)
        ENDIF
      ELSEIF(t.gt.0.0d0)THEN
        top = (((((p(7)*t+p(6))*t+p(5))*t+p(4))*t+p(3))*t+p(2))*t
     1        + p(1)
        bot = (((q(5)*t+q(4))*t+q(3))*t+q(2))*t + 1.0D0
        w = top/bot
        IF (d.GT.0.0D0) THEN
           gam1 = (t/a)* ((w-0.5D0)-0.5D0)
        ELSE
          gam1 = a*w
        ENDIF
      ELSE
        gam1 = 0.0D0
      ENDIF
C
      RETURN
      END
      SUBROUTINE GAMEST(X,NOBS,SCALE,GAMMA,IERROR)
C
C  COMPUTE MLES FOR SHAPE PARAMETER (GAMMA) AND SCALE
C  PARAMETER (SCALE).
C
      DIMENSION X(*)
C
      DOUBLE PRECISION GAMFUN
      EXTERNAL GAMFUN
C
      DOUBLE PRECISION DLOGGM
      COMMON/GAMCOM/DLOGGM
C
      DOUBLE PRECISION AE
      DOUBLE PRECISION RE
      DOUBLE PRECISION DXSTRT
      DOUBLE PRECISION DXLOW
      DOUBLE PRECISION DXUP
      DOUBLE PRECISION XLOWSV
      DOUBLE PRECISION XUPSV
C
      CHARACTER*4 IBUGA3
      CHARACTER*4 IWRITE
      CHARACTER*4 IERROR
C
      INCLUDE 'DPCOP2.INC'
C
C  FOR STARTING VALUE, USE THE METHOD OF MOMENT ESTIMATORS
C
C    GAMMAHAT = (XBAR/XSD)**2
C    SCALE    = XSD**2/XBAR
C
      IERROR='NO'
      IBUGA3='OFF'
      IWRITE='OFF'
      CALL MEAN(X,NOBS,IWRITE,XMEAN,IBUGA3,IERROR)
      CALL SD(X,NOBS,IWRITE,XSD,IBUGA3,IERROR)
      GAMMMO=(XMEAN/XSD)**2
      SCALMO=XSD**2/XMEAN
      CALL GEOMEA(X,NOBS,IWRITE,XGEOM,IBUGA3,IERROR)
C
      IERROR='NO'
      AN=REAL(NOBS)
C
C  ESTIMATES FOR 2-PARAMETER MODEL.  USE DFZER2 TO FIND ROOT OF
C  THE LIKELIHOOD EQUATION.
C
      DLOGGM=DLOG(DBLE(XMEAN)/DBLE(XGEOM))
      DXSTRT=DBLE(GAMMMO)
      AE=2.0*0.000001D0*DXSTRT
      RE=AE
      IFLAG=0
      DXLOW=DXSTRT/2.0D0
      DXUP=2.0D0*DXSTRT
      ITBRAC=0
 4105 CONTINUE
      XLOWSV=DXLOW
      XUPSV=DXUP
      CALL DFZERO(GAMFUN,DXLOW,DXUP,DXSTRT,RE,AE,IFLAG)
C
      IF(IFLAG.EQ.4 .AND. ITBRAC.LE.100)THEN
        DXLOW=XLOWSV/2.0D0
        DXUP=2.0D0*XUPSV
        ITBRAC=ITBRAC+1
        GOTO4105
      ENDIF
C
  999 FORMAT(1X)
      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)
CC111   FORMAT('***** WARNING FROM GAMMA MAXIMUM ',
CCCCC1         'LIKELIHOOD--')
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   WRITE(ICOUT,113)
CC113   FORMAT('      ESTIMATE OF GAMMA 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,121)
  121   FORMAT('***** WARNING FROM GAMMA MAXIMUM LIKELIHOOD--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,123)
  123   FORMAT('      ESTIMATE OF GAMMA 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 GAMMA MAXIMUM LIKELIHOOD--')
        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 GAMMA MAXIMUM LIKELIHOOD--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,143)
  143   FORMAT('      MAXIMUM ITERATIONS EXCEEDED.')
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      GAMMA=REAL(DXLOW)
      SCALE=XMEAN/GAMMA
C
      RETURN
      END
      DOUBLE PRECISION FUNCTION gamln(a)
C-----------------------------------------------------------------------
C            EVALUATION OF LN(GAMMA(A)) FOR POSITIVE A
C-----------------------------------------------------------------------
C     WRITTEN BY ALFRED H. MORRIS
C          NAVAL SURFACE WARFARE CENTER
C          DAHLGREN, VIRGINIA
C--------------------------
C     D = 0.5*(LN(2*PI) - 1)
C--------------------------
C     .. Scalar Arguments ..
      DOUBLE PRECISION a
C     ..
C     .. Local Scalars ..
      DOUBLE PRECISION c0,c1,c2,c3,c4,c5,d,t,w
      INTEGER i,n
C     ..
C     .. External Functions ..
      DOUBLE PRECISION gamln1
      EXTERNAL gamln1
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC dlog
C     ..
C     .. Data statements ..
C--------------------------
      DATA d/.418938533204673D0/
      DATA c0/.833333333333333D-01/,c1/-.277777777760991D-02/,
     +     c2/.793650666825390D-03/,c3/-.595202931351870D-03/,
     +     c4/.837308034031215D-03/,c5/-.165322962780713D-02/
C     ..
C     .. Executable Statements ..
C-----------------------------------------------------------------------
      IF (a.GT.0.8D0) GO TO 10
      gamln = gamln1(a) - dlog(a)
      RETURN

   10 IF (a.GT.2.25D0) GO TO 20
      t = (a-0.5D0) - 0.5D0
      gamln = gamln1(t)
      RETURN
C
   20 IF (a.GE.10.0D0) GO TO 40
      n = int(a - 1.25D0)
      t = a
      w = 1.0D0
      DO 30 i = 1,n
          t = t - 1.0D0
          w = t*w
   30 CONTINUE
      gamln = gamln1(t-1.0D0) + dlog(w)
      RETURN
C
   40 t = (1.0D0/a)**2
      w = (((((c5*t+c4)*t+c3)*t+c2)*t+c1)*t+c0)/a
      gamln = (d+w) + (a-0.5D0)* (dlog(a)-1.0D0)
      END
      DOUBLE PRECISION FUNCTION gamln1(a)
C-----------------------------------------------------------------------
C     EVALUATION OF LN(GAMMA(1 + A)) FOR -0.2 .LE. A .LE. 1.25
C-----------------------------------------------------------------------
C     .. Scalar Arguments ..
      DOUBLE PRECISION a
C     ..
C     .. Local Scalars ..
      DOUBLE PRECISION p0,p1,p2,p3,p4,p5,p6,q1,q2,q3,q4,q5,q6,r0,r1,r2,
     +                 r3,r4,r5,s1,s2,s3,s4,s5,w,x
C     ..
C     .. Data statements ..
C----------------------
      DATA p0/.577215664901533D+00/,p1/.844203922187225D+00/,
     +     p2/-.168860593646662D+00/,p3/-.780427615533591D+00/,
     +     p4/-.402055799310489D+00/,p5/-.673562214325671D-01/,
     +     p6/-.271935708322958D-02/
      DATA q1/.288743195473681D+01/,q2/.312755088914843D+01/,
     +     q3/.156875193295039D+01/,q4/.361951990101499D+00/,
     +     q5/.325038868253937D-01/,q6/.667465618796164D-03/
      DATA r0/.422784335098467D+00/,r1/.848044614534529D+00/,
     +     r2/.565221050691933D+00/,r3/.156513060486551D+00/,
     +     r4/.170502484022650D-01/,r5/.497958207639485D-03/
      DATA s1/.124313399877507D+01/,s2/.548042109832463D+00/,
     +     s3/.101552187439830D+00/,s4/.713309612391000D-02/,
     +     s5/.116165475989616D-03/
C     ..
C     .. Executable Statements ..
C----------------------
      IF (a.GE.0.6D0) GO TO 10
      w = ((((((p6*a+p5)*a+p4)*a+p3)*a+p2)*a+p1)*a+p0)/
     +    ((((((q6*a+q5)*a+q4)*a+q3)*a+q2)*a+q1)*a+1.0D0)
      gamln1 = -a*w
      RETURN
C
   10 x = (a-0.5D0) - 0.5D0
      w = (((((r5*x+r4)*x+r3)*x+r2)*x+r1)*x+r0)/
     +    (((((s5*x+s4)*x+s3)*x+s2)*x+s1)*x+1.0D0)
      gamln1 = x*w
      RETURN

      END
      double precision function gammds (y, p, ifault)
c-----------------------------------------------------------------------
c  Name:       GAMMDS
c
c  Purpose:    Cumulative distribution for the gamma distribution.
c
c  Usage:      PGAMMA (Q, ALPHA,IFAULT)
c
c  Arguments:
c     Q      - Value at which the distribution is desired.  (Input)
c     ALPHA  - Parameter in the gamma distribution.  (Input)
c     IFAULT - Error indicator.  (Output)
c               IFAULT  DEFINITION
c                 0     No error
c                 1     An argument is misspecified.
c                 2     A numerical error has occurred.
c     PGAMMA - The cdf for the gamma distribution with parameter alpha
c              evaluated at Q.  (Output)
c-----------------------------------------------------------------------
c
c       Algorithm AS 147 APPL. Statist. (1980) VOL. 29, P. 113
c
c       Computes the incomplete gamma integral for positive
c       parameters Y, P using and infinite series.
c
c                                  SPECIFICATIONS FOR ARGUMENTS
      integer    ifault
      double precision y, p
c                                  SPECIFICATIONS FOR LOCAL VARIABLES
      integer    ifail
      double precision a, c, f
c                                  SPECIFICATIONS FOR SAVE VARIABLES
      double precision e, one, zero
      save       e, one, zero
c                                  SPECIFICATIONS FOR INTRINSICS
      intrinsic  dlog, dexp
ccccc double precision dlog, dexp
c                                  SPECIFICATIONS FOR FUNCTIONS
      external   alogam
      double precision alogam
      double precision zexp, zlog
c
      data e, zero, one/1.0d-6, 0.0d0, 1.0d0/
c
      zexp(a) = dexp(a)
      zlog(a) = dlog(a)
c
c       Checks for the admissibility of arguments and value of F
c
      ifault = 1
      gammds = zero
      if (y.le.zero .or. p.le.zero) return
      ifault = 2
c
c       ALOGAM is natural log of gamma function
c       no need to test ifail as an error is impossible
c
      f = zexp(p*zlog(y)-alogam(p+one,ifail)-y)
      if (f .eq. zero) return
      ifault = 0
c
c       Series begins
c
      c      = one
      gammds = one
      a      = p
   10 a = a + one
      c      = c*y/a
      gammds = gammds + c
      if (c/gammds .gt. e) go to 10
      gammds = gammds*f
      return
      end
      SUBROUTINE GAMLIM(XMIN,XMAX)
C***BEGIN PROLOGUE  GAMLIM
C***DATE WRITTEN   770401   (YYMMDD)
C***REVISION DATE  820801   (YYMMDD)
C***CATEGORY NO.  C7A,R2
C***KEYWORDS  GAMMA FUNCTION,LIMITS,SPECIAL FUNCTION
C***AUTHOR  FULLERTON, W., (LANL)
C***PURPOSE  Computes the minimum and maximum bounds for X in GAMMA(X).
C***DESCRIPTION
C
C Calculate the minimum and maximum legal bounds for X in GAMMA(X).
C XMIN and XMAX are not the only bounds, but they are the only non-
C trivial ones to calculate.
C
C             Output Arguments --
C XMIN   minimum legal value of X in GAMMA(X).  Any smaller value of
C        X might result in underflow.
C XMAX   maximum legal value of X in GAMMA(X).  Any larger value will
C        cause overflow.
C***REFERENCES  (NONE)
C***ROUTINES CALLED  R1MACH,XERROR
C***END PROLOGUE  GAMLIM
C***FIRST EXECUTABLE STATEMENT  GAMLIM
C
      INCLUDE 'DPCOMC.INC'
      INCLUDE 'DPCOP2.INC'
C
      ALNSML = LOG(R1MACH(1))
      XMIN = -ALNSML
      DO 10 I=1,10
        XOLD = XMIN
        XLN = LOG(XMIN)
        XMIN = XMIN - XMIN*((XMIN+0.5)*XLN - XMIN - 0.2258 + ALNSML)
     1    / (XMIN*XLN + 0.5)
        IF (ABS(XMIN-XOLD).LT.0.005) GO TO 20
 10   CONTINUE
CCCCC CALL XERROR ( 'GAMLIM  UNABLE TO FIND XMIN', 27, 1, 2)
      WRITE(ICOUT,11)
      CALL DPWRST('XXX','BUG ')
   11 FORMAT('***** ERROR FROM GAMLIM: UNABLE TO FIND ',
     1       'XMIN')
C
 20   XMIN = -XMIN + 0.01
C
      ALNBIG = LOG(R1MACH(2))
      XMAX = ALNBIG
      DO 30 I=1,10
        XOLD = XMAX
        XLN = LOG(XMAX)
        XMAX = XMAX - XMAX*((XMAX-0.5)*XLN - XMAX + 0.9189 - ALNBIG)
     1    / (XMAX*XLN - 0.5)
        IF (ABS(XMAX-XOLD).LT.0.005) GO TO 40
 30   CONTINUE
CCCCC CALL XERROR ( 'GAMLIM  UNABLE TO FIND XMAX', 27, 2, 2)
      WRITE(ICOUT,31)
      CALL DPWRST('XXX','BUG ')
   31 FORMAT('***** ERROR FROM GAMLIM: UNABLE TO FIND ',
     1       'XMAX')
C
 40   XMAX = XMAX - 0.01
      XMIN = AMAX1 (XMIN, -XMAX+1.)
C
      RETURN
      END
      SUBROUTINE GAMMAF(X,G)
C
C     THIS PROGRAM CALCULATES THE GAMMA FUNCTION
C     THE INPUT IS SINGLE PRECISION X
C     THE OUTPUT IS SINGLE PRECISION G
C     ALL INTERNAL OPERATIONS ARE DONE IN DOUBLE 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-921-3651
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--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 FIRST  INPUT ARGUMENT ',
     1'TO THE GAMMAF 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)
      G=DEXP(A+B)/DEN
C
      RETURN
      END
      SUBROUTINE GAMCDF(X,GAMMA,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE GAMMA
C              DISTRIBUTION WITH SINGLE PRECISION
C              TAIL LENGTH PARAMETER = GAMMA.
C              THE GAMMA DISTRIBUTION USED
C              HEREIN HAS MEAN = GAMMA
C              AND STANDARD DEVIATION = SQRT(GAMMA).
C              THIS DISTRIBUTION IS DEFINED FOR ALL POSITIVE X,
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C              F(X) = (1/CONSTANT) * (X**(GAMMA-1)) * EXP(-X)
C              WHERE THE CONSTANT = THE GAMMA FUNCTION EVALUATED
C              AT THE VALUE GAMMA.
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                     --GAMMA  = THE SINGLE PRECISION VALUE
C                                OF THE TAIL LENGTH 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 GAMMA 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                 --X SHOULD BE POSITIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--DEXP, DLOG.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN.
C     ACCURACY--(ON THE UNIVAC 1108, EXEC 8 SYSTEM AT NBS)
C               COMPARED TO THE KNOWN GAMMA = 1 (EXPONENTIAL)
C               RESULTS, AGREEMENT WAS HAD OUT TO 7 SIGNIFICANT
C               DIGITS FOR ALL TESTED X.
C               THE TESTED X VALUES COVERED THE ENTIRE
C               RANGE OF THE DISTRIBUTION--FROM THE 0.00001
C               PERCENT POINT UP TO THE 99.99999 PERCENT POINT
C               OF THE DISTRIBUTION.
C     REFERENCES--WILK, GNANADESIKAN, AND HUYETT, 'PROBABILITY
C                 PLOTS FOR THE GAMMA DISTRIBUTION',
C                 TECHNOMETRICS, 1962, PAGES 1-15,
C                 ESPECIALLY PAGES 3-5.
C               --NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY APPLIED MATHEMATICS
C                 SERIES 55, 1964, PAGE 257, FORMULA 6.1.41.
C               --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1970, PAGES 166-206.
C               --HASTINGS AND PEACOCK, STATISTICAL
C                 DISTRIBUTIONS--A HANDBOOK FOR
C                 STUDENTS AND PRACTITIONERS, 1975,
C                 PAGES 68-73.
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
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX,DGAMMA,AI,TERM,SUM,CUT1,CUT2,CUTOFF,T
      DOUBLE PRECISION Z,Z2,Z3,Z4,Z5,DEN,A,B,C,D,G
      DOUBLE PRECISION DEXP,DLOG
      DIMENSION D(10)
      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
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      CDF=0.0
      IF(X.LE.0.0)THEN
CCCCC   WRITE(ICOUT,4)
CCCC4   FORMAT('***** WARNING--THE FIRST ARGUMENT TO GAMCDF IS ',
CCCCC1         'NON-POSITIVE.')
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   WRITE(ICOUT,46)X
CCCCC   CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(GAMMA.LE.0.0)THEN
        WRITE(ICOUT,15)
   15   FORMAT('***** ERROR--THE SECOND ARGUMENT TO GAMCDF IS ',
     1         'NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)GAMMA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
C
C-----START POINT-----------------------------------------------------
C
      DX=X
      DGAMMA=GAMMA
      MAXIT=10000
C
C     COMPUTE THE GAMMA FUNCTION USING THE ALGORITHM IN THE
C     NBS APPLIED MATHEMATICS SERIES REFERENCE.
C
      Z=DGAMMA
      DEN=1.0D0
  300 IF(Z.GE.10.0D0)GOTO400
      DEN=DEN*Z
      Z=Z+1
      GOTO300
  400 Z2=Z*Z
      Z3=Z*Z2
      Z4=Z2*Z2
      Z5=Z2*Z3
      A=(Z-0.5D0)*DLOG(Z)-Z+C
      B=D(1)/Z+D(2)/Z3+D(3)/Z5+D(4)/(Z2*Z5)+D(5)/(Z4*Z5)+
     1D(6)/(Z*Z5*Z5)+D(7)/(Z3*Z5*Z5)+D(8)/(Z5*Z5*Z5)+D(9)/(Z2*Z5*Z5*Z5)
      G=DEXP(A+B)/DEN
C
C     COMPUTE T-SUB-Q AS DEFINED ON PAGE 4 OF THE WILK, GNANADESIKAN,
C     AND HUYETT REFERENCE
C
      SUM=1.0D0/DGAMMA
      TERM=1.0D0/DGAMMA
      CUT1=DX-DGAMMA
      CUT2=DX*10000000000.0D0
      DO200I=1,MAXIT
      AI=I
      TERM=DX*TERM/(DGAMMA+AI)
      SUM=SUM+TERM
      CUTOFF=CUT1+(CUT2*TERM/SUM)
      IF(AI.GT.CUTOFF)GOTO250
  200 CONTINUE
      WRITE(ICOUT,205)MAXIT
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,206)X
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,207)GAMMA
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,208)
      CALL DPWRST('XXX','BUG ')
      CDF=1.0
      GOTO9000
C
  250 T=SUM
      CDF=(DX**DGAMMA)*(DEXP(-DX))*T/G
C
CC204 FORMAT('*****ERROR IN INTERNAL OPERATIONS IN THE GAMCDF ,')
  205 FORMAT('     SUBROUTINE--THE NUMBER OF ITERATIONS EXCEEDS ',I7)
  206 FORMAT('     THE INPUT VALUE OF X     IS ',G15.7)
  207 FORMAT('     THE INPUT VALUE OF GAMMA IS ',G15.7)
  208 FORMAT('     THE OUTPUT VALUE OF CDF HAS BEEN SET TO 1.0')
C
 9000 CONTINUE
      RETURN
      END
      DOUBLE PRECISION FUNCTION GAMFUN (GHAT)
C
C     PURPOSE--THIS ROUTINE IS USED IN FINDING THE MAXIMUM LIKELIHOOD
C              ESTIMATE OF GAMMA FOR THE 2-PARAMETER GAMMA
C              MODEL FOR FULL SAMPLE DATA (NO CENSORING).  THIS
C              FUNCTION FINDS THE ROOT OF THE EQUATION:
C
C                 LOG(GHAT) - DIGAMMA(GHAT) - LOG(G)
C
C              WITH
C
C                 G        = GEOMETRIC MEAN OF THE DATA
C                 GHAT     = POINT ESTIMATE OF GAMMA (THIS IS THE
C                            PARAMETER WE ARE ITERATING OVER)
C
C              NOTE THAT THE LOG(G) TERM DOES NOT DEPEND ON GHAT,
C              SO THIS IS A CONSTANT.  FOR EFFICIENCY, SAVE THIS AS
C              A CONSTANT IN A COMMON BLOCK.
C
C              CALLED BY DFZERO ROUTINE FOR FINDING THE ROOT OF A
C              FUNCTION.
C     EXAMPLE--GAMMA MAXIMUM LIKELIHOOD Y
C     REFERENCE--KARL BURY, "STATISTICAL DISTRIBUTIONS IN
C                ENGINEERING", CAMBRIDGE UNIVERSITY PRESS,
C                1999, CHAPTER 13.
C              --JOHNSON, KOTZ, AND BALAKRISNAN, "CONTINUOUS
C                UNIVARIATE DISTRIBUTIONS--VOLUME 1", SECOND EDITION,
C                WILEY, 1994, CHAPTER 17.
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 GHAT
C
      DOUBLE PRECISION DLOGGM
      COMMON/GAMCOM/DLOGGM
C
      DOUBLE PRECISION DPSI
      EXTERNAL DPSI
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C  COMPUTE SOME SUMS
C
      DTERM1=DLOG(GHAT)
      DTERM2=DPSI(GHAT)
C
      GAMFUN=DTERM1 - DTERM2 - DLOGGM
C
      RETURN
      END
      DOUBLE PRECISION FUNCTION GAMFU2 (DA)
C
C     PURPOSE--THIS ROUTINE IS USED IN FINDING THE LIKELIHOOD RATIO
C              BASED CONFIDECE INTERVAL FOR THE 2-PARAMETER GAMMA
C              MODEL (FULL SAMPLE).  THIS FUNCTION FINDS THE ROOT
C              OF THE EQUATION:
C
C                 2*LL(S,G) - 2*LL(xbar/a,a) - CHSPPF(alpha,1)
C
C              WITH
C
C                 LL(S,G) = -N*LN(GAMMA(G)) - N*G*LN(S) +
C                          N*(G-1)*LN(G) - N*XBAR/S
C                 S        = POINT ESTIMATE OF SCALE PARAMETER
C                 G        = POINT ESTIMATE OF SHAPE PARAMETER
C                 GAMMA    = GAMMA FUNCTION
C                 A        = PARAMETER WE ARE FINDING ROOT FOR
C
C              NOTE THAT QUANTITIES THAT DO NOT DEPEND ON A ARE
C              COMPUTED ONCE IN DPMLG1 AND PASSED VIA COMMON BLOCK.
C
C              CALLED BY DFZERO ROUTINE FOR FINDING THE ROOT OF A
C              FUNCTION.
C
C     EXAMPLE--GAMMA MAXIMUM LIKELIHOOD Y
C     REFERENCE--KARL BURY, "STATISTICAL DISTRIBUTIONS IN ENGINEERING",
C                CAMBRIDGE UNIVERSITY PRESS, 1999, CHAPTER 13 (SEE
C                EXAMPLE 13.3).
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 DA
C
      DOUBLE PRECISION DK
      DOUBLE PRECISION DXBAR
      DOUBLE PRECISION DGMEAN
      DOUBLE PRECISION DSCALE
      DOUBLE PRECISION DG
      COMMON/GAMCO2/DK,DXBAR,DGMEAN,DSCALE,DG,N
C
      DOUBLE PRECISION DLNGAM
      EXTERNAL DLNGAM
C
      DOUBLE PRECISION DN
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C
C  COMPUTE LL(S,G)
C
      DN=DBLE(N)
      DTERM1=-DN*DLNGAM(DG) - DN*DG*DLOG(DSCALE) +
     1       DN*(DG-1.0D0)*DLOG(DGMEAN) - DN*DXBAR/DSCALE
C
C  COMPUTE LL(XBAR/A,A)
C
      DTERM2=-DN*DLNGAM(DA) - DN*DA*DLOG(DXBAR/DA) +
     1       DN*(DA-1.0D0)*DLOG(DGMEAN) - DN*DXBAR/(DXBAR/DA)
C
      GAMFU2=2.0*DTERM1 - 2.0D0*DTERM2 - DK
C
      RETURN
      END
      DOUBLE PRECISION FUNCTION GAMFU3 (DB,DX)
C
C     PURPOSE--THIS ROUTINE IS USED IN FINDING THE LIKELIHOOD RATIO
C              BASED CONFIDENCE INTERVAL FOR THE SCALE PARAMETER OF A
C              2-PARAMETER GAMMA MODEL (FULL SAMPLE).  THIS FUNCTION
C              FINDS THE ROOT OF THE EQUATION:
C
C                 2*LL(S,G) - 2*LL(b,G(b)) - CHSPPF(alpha,1)
C
C              WITH
C
C                 LL(S,G) = -N*LN(GAMMA(G)) - N*G*LN(S) +
C                          N*(G-1)*LN(G) - N*XBAR/S
C                 S        = POINT ESTIMATE OF SCALE PARAMETER
C                 G        = POINT ESTIMATE OF SHAPE PARAMETER
C                 B        = CURRENT GUESS FOR SCALE PARAMETER
C                 G(B)     = ML ESTIMATE OF GAMMA GIVEN VALUE OF
C                            SCALE
C
C              NOTE THAT QUANTITIES THAT DO NOT DEPEND ON B ARE
C              COMPUTED ONCE IN DPMLG1 AND PASSED VIA COMMON BLOCK.
C
C              GIVEN A VALUE FOR THE SCALE PARAMETER (DB), WE NEED
C              TO CALL A ROOT FINDING ROUTINE TO DETERMINE THE VALUE
C              OF THE SHAPE PARAMETER (A).  THIS IS THE ROOT OF THE
C              EQUATION:
C
C                 LN(SCALEHAT) + DIGAMMA(GHAT) - LN(GEOMETRIC MEAN)
C
C              CALLED BY DFZER2 ROUTINE FOR FINDING THE ROOT OF A
C              FUNCTION.  DFZER2 IS MODIFIED VERSION OF DFZERO THAT
C              PASSES ALONG THE DATA ARRAY.
C
C     EXAMPLE--GAMMA MAXIMUM LIKELIHOOD Y
C     REFERENCE--KARL BURY, "STATISTICAL DISTRIBUTIONS IN ENGINEERING",
C                CAMBRIDGE UNIVERSITY PRESS, 1999, CHAPTER 13 (SEE
C                EXAMPLE 13.3).
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 DB
      DOUBLE PRECISION DX(*)
C
      INTEGER N
      DOUBLE PRECISION DK
      DOUBLE PRECISION DXBAR
      DOUBLE PRECISION DGMEAN
      DOUBLE PRECISION DSCALE
      DOUBLE PRECISION DG
      COMMON/GAMCO2/DK,DXBAR,DGMEAN,DSCALE,DG,N
C
      DOUBLE PRECISION DBTEMP
      DOUBLE PRECISION DGMEA2
      COMMON/GAMCO4/DBTEMP,DGMEA2,N2
C
      DOUBLE PRECISION AE
      DOUBLE PRECISION RE
      DOUBLE PRECISION XLOW
      DOUBLE PRECISION XUP
      DOUBLE PRECISION XSTRT
      DOUBLE PRECISION DA
      DOUBLE PRECISION DN
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
C
      DOUBLE PRECISION DLNGAM
      EXTERNAL DLNGAM
      DOUBLE PRECISION GAMFU4
      EXTERNAL GAMFU4
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
      DBTEMP=DB
      DGMEA2=DGMEAN
      AE=1.D-7
      RE=1.D-7
      XSTRT=DG
      XLOW=XSTRT/5.0D0
      XUP=XSTRT*5.0D0
      CALL DFZER3(GAMFU4,XLOW,XUP,XSTRT,RE,AE,IFLAG,DX)
      DA=XLOW
C
C  COMPUTE LL(S,G)
C
      DN=DBLE(N)
      DTERM1=-DN*DLNGAM(DG) - DN*DG*DLOG(DSCALE) +
     1       DN*(DG-1.0D0)*DLOG(DGMEAN) - DN*DXBAR/DSCALE
C
C  COMPUTE LL(B,A)
C
      DTERM2=-DN*DLNGAM(DA) - DN*DA*DLOG(DB) +
     1       DN*(DA-1.0D0)*DLOG(DGMEAN) - DN*DXBAR/DB
C
      GAMFU3=2.0*DTERM1 - 2.0D0*DTERM2 - DK
C
      RETURN
      END
      DOUBLE PRECISION FUNCTION GAMFU4 (DA,DX)
C
C     PURPOSE--THIS ROUTINE IS USED IN FINDING THE LIKELIHOOD RATIO
C              BASED CONFIDENCE INTERVAL FOR THE SCALE PARAMETER OF
C              THE 2-PARAMETER GAMMA MODEL (FULL SAMPLE).
C              SPECIFICALLY, IT IS USED TO DETERMINE AN ESTIMATE
C              OF THE SHAPE PARAMETER GIVEN A VALUE OF THE SCALE
C              PARAMETER.  IT FINDS THE ROOT OF THE FOLLOWING
C              EQUATION:
C
C                 LN(BHAT) + DIGAMMA(AHAT) - LN(GEOMETRIC MEAN)
C
C              WITH A DENOTING THE SHAPE PARAMETER, B THE SCALE
C              PARAMETER, AND THE ROOT IS WITH RESPECT TO A.
C
C              CALLED BY DFZER3 ROUTINE FOR FINDING THE ROOT OF A
C              FUNCTION.  DFZER3 IS MODIFIED VERSION OF DFZERO THAT
C              PASSES ALONG THE DATA ARRAY.
C
C     EXAMPLE--GAMMA MAXIMUM LIKELIHOOD Y
C     REFERENCE--KARL BURY, "STATISTICAL DISTRIBUTIONS IN ENGINEERING",
C                CAMBRIDGE UNIVERSITY PRESS, 1999, CHAPTER 13 (SEE
C                EXAMPLE 13.3).
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--2004/11
C     ORIGINAL VERSION--NOVEMBER   2004.
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DA
      DOUBLE PRECISION DX(*)
C
      DOUBLE PRECISION DGMEAN
      DOUBLE PRECISION DB
      COMMON/GAMCO4/DB,DGMEAN,N
C
      DOUBLE PRECISION DPSI
      EXTERNAL DPSI
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOBE.INC'
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      IF(ISUBG4.EQ.'MFU4')THEN
        WRITE(ICOUT,52)DA,DX(1)
   52   FORMAT('DA,DX(1) = ',2G15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      GAMFU4=DLOG(DB) + DPSI(DA) - DLOG(DGMEAN)
C
      RETURN
      END
      DOUBLE PRECISION FUNCTION GAMFU5(UHAT,DX)
C
C     PURPOSE--THIS ROUTINE IS USED IN FINDING THE MAXIMUM LIKELIHOOD
C              ESTIMATE FOR THE LOCATION PARAMETER FOR THE
C              3-PARAMETER GAMMA MODEL (FULL SAMPLE).  IT FINDS THE
C              ROOT OF THE FOLLOWING EQUATION:
C
C                 DIGAMMA({1 - 1/((XBAR - UHAT)*S1(UHAT))}**(-1)) +
C                 LOG(XBAR - UHAT - 1/S1(UHAT)) - S2(UAT) = 0
C
C              WHERE
C
C                 UHAT     = ESTIMATE OF LOCATION PARAMETER
C                 S1(UHAT) = SUM[i=1 to N][1/(X(i) - UHAT)]/N
C                 S2(UHAT) = SUM[i=1 to N][LOG(X(i) - UHAT)]/N
C                 XBAR     = MEAN OF X
C
C              CALLED BY DFZER2 ROUTINE FOR FINDING THE ROOT OF A
C              FUNCTION.
C
C     EXAMPLE--GAMMA MAXIMUM LIKELIHOOD Y
C     REFERENCE--KARL BURY, "STATISTICAL DISTRIBUTIONS IN ENGINEERING",
C                CAMBRIDGE UNIVERSITY PRESS, 1999, CHAPTER 13.
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 UHAT
      DOUBLE PRECISION DX(*)
C
      DOUBLE PRECISION DMEAN
      DOUBLE PRECISION DSUM1
      COMMON/GAMCO3/DMEAN,DSUM1,N
C
      DOUBLE PRECISION DPSI
      EXTERNAL DPSI
C
      DOUBLE PRECISION DN
      DOUBLE PRECISION DSUM2
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      DN=DBLE(N)
      DSUM1=0.0D0
      DSUM2=0.0D0
      DO100I=1,N
        DTERM1=DX(I) - UHAT
        DSUM1=DSUM1 + (1.0D0/DTERM1)
        DSUM2=DSUM2 + DLOG(DTERM1)
  100 CONTINUE
      DSUM1=DSUM1/DN
      DSUM2=DSUM2/DN
      DTERM1=1.0D0 - 1.0D0/((DMEAN - UHAT)*DSUM1)
      DTERM2=DPSI(1.0D0/DTERM1)
      DTERM3=DLOG(DMEAN - UHAT - (1.0D0/DSUM1))
C
      GAMFU5=DTERM2 + DTERM3 - DSUM2
C
      RETURN
      END
      SUBROUTINE GAMFU7(X,DLOC,DMEAN,N,
     1                  RHO,DB,FOUT,
     1                  ISUBRO,IBUGA3,IERROR)
C
C     PURPOSE--THIS ROUTINE IS USED IN FINDING THE MAXIMUM LIKELIHOOD
C              ESTIMATE OF THE LOCATION PARAMETER FOR THE 3-PARAMETER
C              GAMMA MODEL FOR FULL SAMPLE DATA (NO CENSORING).
C     REFERENCE-COHEN AND WHITTEN (1988), "PARAMETER ESTIMATION IN
C               RELIABILITY AND LIFE SPAN MODELS", MARCEL DEKKER, INC.,
C               PP. 365-367.
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 X(*)
      DOUBLE PRECISION DLOC
      DOUBLE PRECISION DMEAN
      DOUBLE PRECISION RHO
      DOUBLE PRECISION DB
      DOUBLE PRECISION FOUT
C
      CHARACTER*4 ISUBRO
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DSUM2
      DOUBLE PRECISION DX
      DOUBLE PRECISION DA
      DOUBLE PRECISION DN
C
      DOUBLE PRECISION DPSI
      EXTERNAL DPSI
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C  COMPUTE SOME SUMS
C
      IERROR='NO'
C
      DSUM1=0.0D0
      DSUM2=0.0D0
      DN=DBLE(N)
C
      DO100I=1,N
        DX=X(I) - DLOC
        DSUM1=DSUM1 + 1.0D0/DX
        DSUM2=DLOG(DX) + DSUM2
  100 CONTINUE
C
      DA=(DMEAN-DLOC)*DSUM1
      RHO=-DA/(DN-DA)
      DB=(DMEAN-DLOC)/RHO
      FOUT=DPSI(RHO) + DLOG(DB) - (DSUM2/DN)
C
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'MFU7')THEN
        WRITE(ICOUT,115)DN,DSUM1,DSUM2,DA,RHO,DB,FOUT
  115   FORMAT('DN,DSUM1,DSUM2,DA,RHO,DB,FOUT = ',7G15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      RETURN
      END
      REAL FUNCTION GAMFU8(GHAT)
C
C     PURPOSE--THIS ROUTINE IS USED IN FINDING CONFIDENCE LIMITS
C              FOR PERCENTILES OF THE GAMMA DISTRIBUTION (BASED ON
C              MAXIMUM LIKELIHOOD ESTIMATION).  THIS FUNCTION
C              COMPUTES THE DERIVATIVE OF THE GAMMA PERCENT POINT
C              FUNCTION WITH RESPECT TO THE SHAPE PARAMETER.
C
C              CALLED BY DIFF ROUTINE FOR FINDING THE DERIVATIVE
C              OF A FUNCTION.
C     EXAMPLE--GAMMA MAXIMUM LIKELIHOOD Y
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                 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
      REAL GHAT
C
      COMMON/GAMCO8/P,SCALE
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      CALL GAMPPF(P,GHAT,APPF)
      GAMFU8=SCALE*APPF
C
      RETURN
      END
      REAL FUNCTION GAMFU9(SCALE)
C
C     PURPOSE--THIS ROUTINE IS USED IN FINDING CONFIDENCE LIMITS
C              FOR PERCENTILES OF THE GAMMA DISTRIBUTION (BASED ON
C              MAXIMUM LIKELIHOOD ESTIMATION).  THIS FUNCTION
C              COMPUTES THE DERIVATIVE OF THE GAMMA PERCENT POINT
C              FUNCTION WITH RESPECT TO THE SCALE PARAMETER.
C
C              CALLED BY DIFF ROUTINE FOR FINDING THE DERIVATIVE
C              OF A FUNCTION.
C     EXAMPLE--GAMMA MAXIMUM LIKELIHOOD Y
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                 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
      COMMON/GAMCO9/P,GHAT
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      CALL GAMPPF(P,GHAT,APPF)
      GAMFU9=SCALE*APPF
C
      RETURN
      END
C===================================================== GAMIND.FOR
      DOUBLE PRECISION FUNCTION GAMIND(X,ALPHA,G)
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  THE INCOMPLETE GAMMA INTEGRAL
C
C  BASED ON ALGORITHM AS239, APPL. STATIST. (1988) VOL.37 NO.3
C
C  PARAMETERS OF ROUTINE:
C  X      * INPUT* ARGUMENT OF FUNCTION (UPPER LIMIT OF INTEGRATION)
C  ALPHA  * INPUT* SHAPE PARAMETER
C  G      * INPUT* LOG(GAMMA(ALPHA)). MUST BE SUPPLIED BY THE PROGRAM,
C                  E.G. AS DLGAMA(ALPHA).
C
C  OTHER ROUTINES USED: DERF
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      INCLUDE 'DPCOP2.INC'
C
      DATA ZERO/0D0/,HALF/0.5D0/,ONE/1D0/,TWO/2D0/,THREE/3D0/,X13/13D0/,
     *  X36/36D0/,X42/42D0/,X119/119D0/,X1620/1620D0/,X38880/38880D0/,
     *  RTHALF/0.70710 67811 86547 524D0/
C
C         EPS,MAXIT CONTROL THE TEST FOR CONVERGENCE OF THE SERIES AND
C           CONTINUED-FRACTION EXPANSIONS.
C         OFL IS A LARGE NUMBER, USED TO RESCALE THE CONTINUED FRACTION.
C         UFL IS SUCH THAT EXP(UFL) IS JUST .GT. ZERO.
C         AHILL CONTROLS THE SWITCH TO HILL'S APPROXIMATION.
C
      DATA EPS/1D-12/,MAXIT/100000/,OFL/1D30/,UFL/-180D0/,AHILL/1D4/
C
      GAMIND=ZERO
      IF(ALPHA.LE.ZERO)THEN
        WRITE(ICOUT,7000)
 7000   FORMAT('***** ERROR FROM ROUTINE GAMIND:',
     *         ' SHAPE PARAMETER IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,7002)ALPHA
 7002   FORMAT('      THE VALUE OF THE ARGUMENT IS ',G15.7)
        CALL DPWRST('XXX','BUG ')
        GOTO 9000
      ENDIF
C
      IF(X.LT.ZERO)THEN
        WRITE(ICOUT,7010)
 7010   FORMAT('***** ERROR FROM ROUTINE GAMIND:',
     *         ' ARGUMENT OF FUNCTION IS NEGATIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,7002)X
        CALL DPWRST('XXX','BUG ')
        GOTO 9000
      ENDIF
C
      IF(X.EQ.ZERO)GOTO9000
C
      IF(ALPHA.GT.AHILL)GOTO 100
      IF(X.GT.ONE.AND.X.GE.ALPHA)GOTO 50
C
C         SERIES EXPANSION
C
      SUM=ONE
      TERM=ONE
      A=ALPHA
      DO 10 IT=1,MAXIT
      A=A+ONE
      TERM=TERM*X/A
      SUM=SUM+TERM
      IF(TERM.LE.EPS)GOTO 20
   10 CONTINUE
C
      WRITE(ICOUT,7020)
 7020 FORMAT('**** WARNING FROM ROUTINE GAMIND:',
     *       ' ITERATION HAS NOT CONVERGED. RESULT MAY BE UNRELIABLE.')
      CALL DPWRST('XXX','BUG ')
C
   20 ARG=ALPHA*DLOG(X)-X-G+DLOG(SUM/ALPHA)
      GAMIND=ZERO
      IF(ARG.GE.UFL)GAMIND=DEXP(ARG)
      GOTO9000
C
C         CONTINUED-FRACTION EXPANSION
C
   50 CONTINUE
      A=ONE-ALPHA
      B=A+X+ONE
      TERM=ZERO
      PN1=ONE
      PN2=X
      PN3=X+ONE
      PN4=X*B
      RATIO=PN3/PN4
      DO 70 IT=1,MAXIT
      A=A+ONE
      B=B+TWO
      TERM=TERM+ONE
      AN=A*TERM
      PN5=B*PN3-AN*PN1
      PN6=B*PN4-AN*PN2
      IF(PN6.EQ.ZERO)GOTO 60
      RN=PN5/PN6
      DIFF=DABS(RATIO-RN)
      IF(DIFF.LE.EPS.AND.DIFF.LE.EPS*RN)GOTO 80
      RATIO=RN
   60 PN1=PN3
      PN2=PN4
      PN3=PN5
      PN4=PN6
      IF(DABS(PN5).LT.OFL)GOTO 70
      PN1=PN1/OFL
      PN2=PN2/OFL
      PN3=PN3/OFL
      PN4=PN4/OFL
   70 CONTINUE
C
      WRITE(ICOUT,7020)
      CALL DPWRST('XXX','BUG ')
C
   80 ARG=ALPHA*DLOG(X)-X-G+DLOG(RATIO)
      GAMIND=ONE
      IF(ARG.GE.UFL)GAMIND=ONE-DEXP(ARG)
      GOTO9000
C
C         ALPHA IS LARGE: USE HILL'S APPROXIMATION (N.L. JOHNSON AND
C         S. KOTZ, 1970, 'CONTINUOUS UNIVARIATE DISTRIBUTIONS 1', P.180)
C
C         THE 'DO 110' LOOP CALCULATES 2*(X-ALPHA-ALPHA*DLOG(X/ALPHA)),
C         USING POWER-SERIES EXPANSION TO AVOID ROUNDING ERROR
C
  100 CONTINUE
      R=ONE/DSQRT(ALPHA)
      Z=(X-ALPHA)*R
      TERM=Z*Z
      SUM=HALF*TERM
      DO 110 I=1,12
      TERM=-TERM*Z*R
      SUM=SUM+TERM/(I+TWO)
      IF(DABS(TERM).LT.EPS)GOTO 120
  110 CONTINUE
  120 WW=TWO*SUM
      W=DSQRT(WW)
      IF(X.LT.ALPHA)W=-W
      H1=ONE/THREE
      H2=-W/X36
      H3=(-WW+X13)/X1620
      H4=(X42*WW+X119)*W/X38880
      Z=(((H4*R+H3)*R+H2)*R+H1)*R+W
      GAMIND=HALF+HALF*DERFDP(Z*RTHALF)
      GOTO9000
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE GAMLI1(Y,N,ICASPL,IGAMFL,ALOC,SCALE,SHAPE,
     1                  ALIK,AIC,AICC,BIC,
     1                  ISUBRO,IBUGA3,IERROR)
C
C     PURPOSE--THIS ROUTINE COMPUTES THE LIKELIHOOD FUNCTION FOR
C              THE GAMMA (OR INVERTED GAMMA) 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     REFERENCE--KARL BURY, "STATISTICAL DISTRIBUTIONS IN ENGINEERING",
C                CAMBRIDGE UNIVERSITY PRESS, 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
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 ICASPL
      CHARACTER*4 IGAMFL
      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 DG
      DOUBLE PRECISION DN
      DOUBLE PRECISION DNP
      DOUBLE PRECISION DLIK
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DSUM2
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM3
      DOUBLE PRECISION DLGADP
C
      EXTERNAL DLGADP
C
C---------------------------------------------------------------------
C
      DIMENSION Y(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='GAML'
      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.'MLI1')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,51)
   51   FORMAT('**** AT THE BEGINNING OF GAMLI1--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,52)IBUGA3,ISUBRO,IGAMFL
   52   FORMAT('IBUGA3,ISUBRO,IGAMFL = ',2(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
C               ******************************************
C               **  STEP 1--                            **
C               **  COMPUTE LIKELIHOOD FUNCTION         **
C               ******************************************
C
      ISTEPN='1'
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'MLI1')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IERFLG=0
      IERROR='NO'
      IWRITE='OFF'
      IF(ICASPL.NE.'3GAM')ALOC=0.0
C
C     LOG-LIKELIHOOD FUNCTION IS:
C
C     -N*(LOGGAMMA(SHAPE) - N*SHAPE*LOG(SCALE)) +
C     (SHAPE-1)*SUM[i=1 to n][LOG(X(i) - LOC] -
C     SUM[i=1 to n][X(i) - LOC]/SCALE
C
      DN=DBLE(N)
      DS=DBLE(SCALE)
      DU=DBLE(ALOC)
      DG=DBLE(SHAPE)
C
      DTERM1=-DN*DLGADP(DG) - DN*DG*DLOG(DS)
      DSUM1=0.0D0
      DSUM2=0.0D0
C
      DO1010I=1,N
        DX=DBLE(Y(I)) - DU
        DSUM1=DSUM1 + DLOG(DX)
        DSUM2=DSUM2 + DX
 1010 CONTINUE
C
      DLIK=DTERM1 + (DG-1.0D0)*DSUM1 - DSUM2/DS
      ALIK=REAL(DLIK)
      DNP=2.0D0
      IF(ICASPL.EQ.'3GAM')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.'MLI1')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9011)
 9011   FORMAT('**** AT THE END OF GAMLI1--')
        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 GAMML1(Y,N,IGAMFL,
     1                  TEMP1,DTEMP1,
     1                  XMEAN,XSD,XVAR,XMIN,XMAX,XGEOM,
     1                  ZMEAN,ZSD,ZGEOM,
     1                  SCALML,SCALSE,SHAPML,SHAPSE,COVSE,
     1                  SCALMO,SHAPMO,
     1                  SCALYE,SHAPYE,SCYEBC,SHYEBC,
     1                  ISUBRO,IBUGA3,IERROR)
C
C     PURPOSE--THIS ROUTINE COMPUTES THE MAXIMUM LIKELIHOOD ESTIMATES
C              FOR THE 2-PARAMETER GAMMA 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 (DPMLG1 WILL GENERATE THE OUTPUT
C              FOR THE GAMMA MLE COMMAND).
C
C     REFERENCE--KARL BURY, "STATISTICAL DISTRIBUTIONS IN
C                ENGINEERING", CAMBRIDGE UNIVERSITY PRESS,
C                1999, CHAPTER 13.
C              --JOHNSON, KOTZ, AND BALAKRISNAN, "CONTINUOUS
C                UNIVARIATE DISTRIBUTIONS--VOLUME 1", SECOND EDITION,
C                WILEY, 1994, CHAPTER xx.
C              --YE AND CHEN (2017), "CLOSED-FORM ESTIMATORS FOR THE
C                GAMMA DISTRIBUTION DERIVED FROM LIKELIHOOD
C                EQUATIONS", THE AMERICAN STATISTICIAN, VOL. 71,
C                NO. 2, PP. 177-181.
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(*)
      DOUBLE PRECISION DTEMP1(*)
C
      CHARACTER*4 ICASE
      CHARACTER*4 IGAMFL
      CHARACTER*4 ISUBRO
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      DOUBLE PRECISION DN
      DOUBLE PRECISION DG
      DOUBLE PRECISION DS
      DOUBLE PRECISION DX
      DOUBLE PRECISION DXLOG
      DOUBLE PRECISION DXSTRT
      DOUBLE PRECISION DXLOW
      DOUBLE PRECISION DXUP
      DOUBLE PRECISION XLOWSV
      DOUBLE PRECISION XUPSV
      DOUBLE PRECISION AE
      DOUBLE PRECISION RE
      DOUBLE PRECISION DANS(10)
      DOUBLE PRECISION TRIGAM
      DOUBLE PRECISION DTRM11
      DOUBLE PRECISION DTRM12
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DSUM2
      DOUBLE PRECISION DSUM3
      DOUBLE PRECISION DNUM
      DOUBLE PRECISION DENOM
      DOUBLE PRECISION DSCALE
      DOUBLE PRECISION DSHAPE
C
      DOUBLE PRECISION GAMFUN
      EXTERNAL GAMFUN
      DOUBLE PRECISION DLOGGM
      COMMON/GAMCOM/DLOGGM
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='GAMM'
      ISUBN2='L1  '
      IERROR='NO'
      IWRITE='OFF'
C
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'MML1')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,51)
   51   FORMAT('**** AT THE BEGINNING OF GAMML1--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,52)IBUGA3,ISUBRO,ICASE,IGAMFL
   52   FORMAT('IBUGA3,ISUBRO,ICASE,IGAMFL = ',3(A4,2X),A4)
        CALL DPWRST('XXX','WRIT')
        DO56I=1,MIN(N,100)
          WRITE(ICOUT,57)I,Y(I),TEMP1(I),DTEMP1(I)
   57     FORMAT('I,Y(I),TEMP1(I),DTEMP1(I) = ',I8,3G15.7)
          CALL DPWRST('XXX','WRIT')
   56   CONTINUE
      ENDIF
C
C               ******************************************
C               **  STEP 1--                            **
C               **  CARRY OUT CALCULATIONS              **
C               **  FOR GAMMA MLE ESTIMATE              **
C               ******************************************
C
      ISTEPN='1'
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'MML1')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IDIST='GAMMA'
      IF(IGAMFL.EQ.'IGAM')IDIST='INVERTED GAMMA'
C
      IFLAG=2
      CALL SUMRAW(Y,N,IDIST,IFLAG,
     1            ZMEAN,ZVAR,ZSD,ZMIN,ZMAX,
     1            ISUBRO,IBUGA3,IERROR)
      CALL GEOMEA(Y,N,IWRITE,ZGEOM,IBUGA3,IERROR)
C
      IF(IGAMFL.EQ.'IGAM')THEN
        DO1118I=1,N
          Y(I)=1.0/Y(I)
 1118   CONTINUE
        CALL MEAN(Y,N,IWRITE,ZMEAN,IBUGA3,IERROR)
        CALL SD(Y,N,IWRITE,ZSD,IBUGA3,IERROR)
        CALL GEOMEA(Y,N,IWRITE,ZGEOM,IBUGA3,IERROR)
      ENDIF
      XMEAN=ZMEAN
      XSD=ZSD
      XGEOM=ZGEOM
C
      SHAPML=CPUMIN
      SHAPMO=CPUMIN
      SHAPSE=CPUMIN
      SHAMSE=CPUMIN
      SCALML=CPUMIN
      SCALSE=CPUMIN
      COVSE=CPUMIN
C
C     FOR THE SHAPE PARAMETER, SOLVE THE EQUATION:
C
C         LOG(GAMMAHAT) - PHI(GAMMAHAT) - LOG(XBAR/G) = 0
C
C     WITH G DENOTING THE GEOMETRIC MEAN (PRODUCT[i=1 to n][X(i)**(1/N)]
C
C     THEN
C
C        SCALE = XBAR/GAMMAHAT
C
C     FOR STARTING VALUE, USE THE METHOD OF MOMENT ESTIMATORS
C
C        GAMMAHAT = (XBAR/XSD)**2
C        SCALE    = XSD**2/XBAR
C
C     THE YE AND CHEN ESTIMATES ARE:
C
C        SHAPE = N*SUM[X(i)]/
C                N*SUM[X(i)*LOG(X(i)) - SUM[LOG(X(i)*SUM[X(i)]
C        SCALE = (1/N**2)*(N*SUM[X(i)*LOG(X(i)) -
C                SUM[LOG(X(i))*SUM[X(i)])
C
C     THE BIAS CORRECTION TERMS ARE
C
C         SHAPE' = ((N-1)/(N+2))*SHAPE
C         SCALE' = ((N-1)/(N+2))*SHAPE
C
      AN=REAL(N)
      SHAPMO=(XMEAN/XSD)**2
      SCALMO=XSD**2/XMEAN
C
C     YE AND CHEN METHOD
C
      DSUM1=0.0D0
      DSUM2=0.0D0
      DSUM3=0.0D0
      DN=DBLE(N)
      DO100I=1,N
        DX=DBLE(Y(I))
        DXLOG=DBLE(DLOG(DX))
        DSUM1=DSUM1 + DX
        DSUM2=DSUM2 + DXLOG
        DSUM3=DSUM3 + DX*DXLOG
  100 CONTINUE
      DNUM=DN*DSUM1
      DENOM=DN*DSUM3 - DSUM2*DSUM1
      DSHAPE=DNUM/DENOM
      DSCALE=(1.0D0/DN**2)*(DN*DSUM3 - DSUM2*DSUM1)
      SCALYE=REAL(DSCALE)
      SCYEBC=REAL((DN-1.0D0)*DSCALE/(DN+2.0D0))
      SHAPYE=REAL(DSHAPE)
      SHYEBC=REAL((DN/(DN-1.0D0))*DSHAPE)
C
C     ESTIMATES FOR 2-PARAMETER MODEL.  USE DFZER2 TO FIND ROOT OF
C     THE LIKELIHOOD EQUATION.
C
      DLOGGM=DLOG(DBLE(XMEAN)/DBLE(XGEOM))
      DXSTRT=DBLE(SHAPMO)
      AE=2.0*0.000001D0*DXSTRT
      RE=AE
      IFLAG=0
      DXLOW=DXSTRT/2.0D0
      DXUP=2.0D0*DXSTRT
      ITBRAC=0
 2205 CONTINUE
      XLOWSV=DXLOW
      XUPSV=DXUP
      CALL DFZERO(GAMFUN,DXLOW,DXUP,DXSTRT,RE,AE,IFLAG)
C
      IF(IFLAG.EQ.4 .AND. ITBRAC.LE.100)THEN
        DXLOW=XLOWSV/2.0D0
        DXUP=2.0D0*XUPSV
        ITBRAC=ITBRAC+1
        GOTO2205
      ENDIF
C
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,2111)
C2111   FORMAT('***** WARNING FROM GAMMA MAXIMUM LIKELIHOOD--')
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   WRITE(ICOUT,2113)
C2113   FORMAT('      ESTIMATE OF SIGMA 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,2121)
 2121   FORMAT('***** WARNING FROM GAMMA MAXIMUM LIKELIHOOD--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,2123)
 2123   FORMAT('      ESTIMATE OF SHAPE PARAMETER MAY BE NEAR ',
     1         'A SINGULAR POINT.')
        CALL DPWRST('XXX','BUG ')
      ELSEIF(IFLAG.EQ.4)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,2131)
 2131   FORMAT('***** ERROR FROM GAMMA MAXIMUM LIKELIHOOD--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,2133)
 2133   FORMAT('      APPROPRIATE BRACKETING INTERVAL NOT FOUND.')
        CALL DPWRST('XXX','BUG ')
      ELSEIF(IFLAG.EQ.5)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,2141)
 2141   FORMAT('***** WARNING FROM GAMMA MAXIMUM LIKELIHOOD--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,2143)
 2143   FORMAT('      MAXIMUM ITERATIONS EXCEEDED.')
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      SHAPML=REAL(DXLOW)
      SCALML=XMEAN/SHAPML
      IF(IGAMFL.EQ.'IGAM')SCALML=1.0/SCALML
C
C     COMPUTE STANDARD ERRORS (CAN BASE ON EITHER THE NORMAL BIASED
C     ESTIMATORS OR THE BIAS CORRECTED ESTIMATORS)
C
C     NOTE THAT DPSIFN COMPUTES THE SCALED PSI DERIVATIVE FUNCTION:
C
C        (-1)**(K+1)/GAMMA(K+1)
C
C     FOR TRIGAMMA, K=1 AND THE SCALING FACTOR REDUCES TO 1.
C
      SHAPML=REAL(DXLOW)
      SCALML=XMEAN/SHAPML
      IF(IGAMFL.EQ.'IGAM')THEN
        SCALML=1.0/SCALML
      ENDIF
C
      DN=DBLE(N)
      DG=DBLE(SHAPML)
      DS=DBLE(SCALML)
      KODE=1
      NTEMP=1
      M=1
      NZ=0
      CALL DPSIFN(DG,NTEMP,KODE,M,DANS,NZ,IERR)
      TRIGAM=DANS(1)
      IF(IERR.EQ.1)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,3101)IDIST
 3101   FORMAT('***** ERROR FROM ',A14,' MAXIMUM LIKELIHOOD--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,3103)
 3103   FORMAT('      UNABLE TO COMPUTE TRIGAMMA FUNCTION.')
        CALL DPWRST('XXX','WRIT')
        IERROR='YES'
        GOTO9000
      ELSEIF(IERR.EQ.2)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,3101)IDIST
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,3105)
 3105   FORMAT('      OVERFLOW IN COMPUTING THE TRIGAMMA FUNCTION.')
        CALL DPWRST('XXX','WRIT')
        IERROR='YES'
        GOTO9000
      ELSEIF(IERR.EQ.3)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,3101)IDIST
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,3107)
 3107   FORMAT('      OVERFLOW IN COMPUTING THE TRIGAMMA FUNCTION.')
        CALL DPWRST('XXX','WRIT')
        IERROR='YES'
        GOTO9000
      ENDIF
C
      DTRM11=DN*(DG*TRIGAM-1.0D0)
      DTRM12=DS**2*TRIGAM
      SCALSE=REAL(DSQRT(DTRM12/DTRM11))
      SHAPSE=REAL(DSQRT(DG/DTRM11))
      COVSE=REAL(-DS/DTRM11)
C
 9000 CONTINUE
C
      XMEAN=ZMEAN
      XSD=ZSD
      XVAR=ZVAR
      XMIN=ZMIN
      XMAX=ZMAX
      XGEOM=ZGEOM
C
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'MML1')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9011)
 9011   FORMAT('**** AT THE END OF GAMML1--')
        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,9015)N,XMEAN,XSD,XMIN,XMAX
 9015   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')
        WRITE(ICOUT,9018)SHAPMO,SCALMO,SHAPYE,SCALYE
 9018   FORMAT('SHAPMO,SCALMO,SHAPYE,SCALYE =  ',4G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9019)SHAPBC,SHABSE,COVSE,COVBSE
 9019   FORMAT('SHAPBC,SHABSE,COVSE,COVBSE =  ',4G15.7)
        CALL DPWRST('XXX','WRIT')
      ENDIF
C
      RETURN
      END
      SUBROUTINE GAMML2(Y,TAG,N,IGAMFL,MAXNXT,
     1                  ICASE,IDIST,
     1                  TEMP1,XTEMP,YSAVE,DTEMP1,ITEMP,
     1                  XMEANF,XSDF,XVARF,XMINF,XMAXF,XGEOMF,
     1                  XMEANC,XSDC,XVARC,XMINC,XMAXC,XGEOMC,
     1                  SCALMO,SHAPMO,
     1                  SCALML,SCALSE,SHAPML,SHAPSE,COVSE,
     1                  IRSAV,ISE,
     1                  ISUBRO,IBUGA3,IERROR)
C
C     PURPOSE--THIS ROUTINE COMPUTES THE MAXIMUM LIKELIHOOD ESTIMATES
C              FOR THE 2-PARAMETER GAMMA 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 (DPMLG2 WILL GENERATE THE OUTPUT
C              FOR THE GAMMA MLE COMMAND).
C
C     REFERENCE--KARL BURY, "STATISTICAL DISTRIBUTIONS IN
C                ENGINEERING", CAMBRIDGE UNIVERSITY PRESS,
C                1999, CHAPTER 13.
C              --JOHNSON, KOTZ, AND BALAKRISNAN, "CONTINUOUS
C                UNIVARIATE DISTRIBUTIONS--VOLUME 1", SECOND EDITION,
C                WILEY, 1994, CHAPTER xx.
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 DPMLG2)
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DIMENSION Y(*)
      DIMENSION TAG(*)
      DIMENSION TEMP1(*)
      DIMENSION XTEMP(*)
      DIMENSION YSAVE(*)
      DOUBLE PRECISION DTEMP1(*)
      INTEGER ITEMP(*)
C
      CHARACTER*4 ICASE
      CHARACTER*40 IDIST
      CHARACTER*4 IGAMFL
      CHARACTER*4 ISUBRO
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
      CHARACTER*4 IWRITE
C
      EXTERNAL GC1FUN
      DOUBLE PRECISION J1FUN
      DOUBLE PRECISION J2FUN
      DOUBLE PRECISION DGAMMA
      DOUBLE PRECISION DGAMI
      DOUBLE PRECISION DPSI
      EXTERNAL J1FUN
      EXTERNAL J2FUN
      EXTERNAL DGAMMA
      EXTERNAL DGAMI
      EXTERNAL DPSI
C
      DOUBLE PRECISION XBAR
      DOUBLE PRECISION DGEOME
      INTEGER IN
      INTEGER IR
      COMMON/GC1COM/XBAR,DGEOME,IN,IR
C
      INTEGER LIMIT
      INTEGER LENW
      PARAMETER(LIMIT=200)
      PARAMETER(LENW=4*LIMIT)
      INTEGER NEVAL
      INTEGER IER
      INTEGER LAST
      INTEGER IWORK(LIMIT)
      DOUBLE PRECISION EPSABS
      DOUBLE PRECISION EPSREL
      DOUBLE PRECISION DLOW
      DOUBLE PRECISION ABSERR
      DOUBLE PRECISION WORK(LENW)
C
      DOUBLE PRECISION DA
      COMMON/J1COM/DA
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 DX
      DOUBLE PRECISION DG
      DOUBLE PRECISION DGAM
      DOUBLE PRECISION DS
      DOUBLE PRECISION DP
      DOUBLE PRECISION DTJ
      DOUBLE PRECISION DJ1
      DOUBLE PRECISION DJ2
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DSUM2
      DOUBLE PRECISION DSUM3
      DOUBLE PRECISION DSUM4
      DOUBLE PRECISION DSUM5
      DOUBLE PRECISION DANS(10)
      DOUBLE PRECISION TRIGAM
      DOUBLE PRECISION DTERM1
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 ISTEPN
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='GAMM'
      ISUBN2='L2  '
      IERROR='NO'
C
      TRIGAM=0.0D0
C
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'MML2')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,51)
   51   FORMAT('**** AT THE BEGINNING OF GAMML2--')
        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 GAMMA MLE ESTIMATE              **
C               ******************************************
C
      ISTEPN='1'
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'MML2')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IDIST='GAMMA'
      IF(IGAMFL.EQ.'ON')IDIST='INVERTED GAMMA'
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 GEOMEA(Y,IR,IWRITE,XGEOMF,IBUGA3,IERROR)
C
      IF(IGAMFL.EQ.'IGAM')THEN
        DO1118I=1,N
          Y(I)=1.0/Y(I)
 1118   CONTINUE
        CALL MEAN(Y,N,IWRITE,ZMEANF,IBUGA3,IERROR)
        CALL SD(Y,N,IWRITE,ZSDF,IBUGA3,IERROR)
      ENDIF
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
        IF(IGAMFL.EQ.'IGAM')THEN
          YSAVE(I)=1.0/Y(I)
        ELSE
          YSAVE(I)=Y(I)
        ENDIF
 2126 CONTINUE
      IM=N-IR
C
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'MML2')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)IDIST(1:14)
 2131   FORMAT('***** WARNING FROM ',A14,' 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)IDIST(1:14)
 2137   FORMAT('      ',A14,' 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
      ENDIF
C
C               ************************************
C               **  STEP 41--                     **
C               **  CARRY OUT CALCULATIONS        **
C               **  FOR GAMMA MLE                 **
C               **  ESTIMATE (TIME CENSORED CASE) **
C               ************************************
C
C  THE MAXIMUM LIKELIHOOD EQUATIONS FOR THE CENSORED CASE ARE:
C
C      R*XBAR/SHAT - R*GHAT + SUM[i=1 to M]
C        [Z(j)**GHAT*EXP(Z(j)/(GAMMA(GHAT) - G(Z(j),GHAT))] = 0
C
C      R*LOG(GEOMEAN/SHAT)  - N*DIGAMMA(GHAT) + SUM[i=1 to M]
C        [(GAMMA(GHAT)*DIGAMMA(GHAT) J(Z(j),GHAT))/
C        (GAMMA(GHAT) - G(Z(j),GHAT))] = 0
C
C      WHERE
C
C
C         XBAR = MEAN OF FAILURE DATA
C         GEOMEAN  = GEOMETRIC MEAN OF FAILURE DATA
C         R        = NUMBER OF FAILURES
C         M        = NUMBER OF CENSORING TIMES
C         SHAT     = FVEC(1) = CURRENT ESTIMATE OF SCALE PARAMETER
C         GHAT     = FVEC(2) = CURRENT ESTIMATE OF SHAPE PARAMETER
C         Z(j)     = jth CENSORING TIME
C         GAMMA    = GAMMA FUNCTION
C         DIGAMMA  = DIGAMMA FUNCTION
C         G(x,a)   = INCOMPLETE GAMMA FUNCTION
C         J(X,a)   = INTEGRAL[0 to x][t**(A-1)*LOG(t)*EXP(-t)]dt
C
C  THESE ARE SOLVED USING THE DNSQE ROUTINE.
C
C
      ISTEPN='41'
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'MML2')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IERROR='NO'
      IWRITE='OFF'
      AN=REAL(N)
C
C  COMPUTE STATISTICS FOR FAILURE ONLY DATA
C
      IF(IGAMFL.EQ.'IGAM')THEN
        CALL MEAN(Y,IR,IWRITE,ZMEAN,IBUGA3,IERROR)
        CALL SD(Y,IR,IWRITE,ZSD,IBUGA3,IERROR)
        CALL MINIM(Y,IR,IWRITE,ZMIN,IBUGA3,IERROR)
        CALL MAXIM(Y,IR,IWRITE,ZMAX,IBUGA3,IERROR)
        CALL GEOMEA(Y,IR,IWRITE,ZGEOM,IBUGA3,IERROR)
        XMEANC=ZMEAN
        XSDC=ZSD
        XVARC=SQRT(XSDC)
        XMINC=ZMIN
        XMAXC=ZMAX
        XGEOMC=ZGEOM
        ZCOEFV=ZSD/ZMEAN
        CALL MEAN(YSAVE,IR,IWRITE,XMEAN,IBUGA3,IERROR)
        CALL SD(YSAVE,IR,IWRITE,XSD,IBUGA3,IERROR)
        CALL MINIM(YSAVE,IR,IWRITE,XMIN,IBUGA3,IERROR)
        CALL GEOMEA(YSAVE,IR,IWRITE,XGEOM,IBUGA3,IERROR)
        XCOEFV=XSD/XMEAN
      ELSE
        CALL MEAN(Y,IR,IWRITE,XMEAN,IBUGA3,IERROR)
        CALL SD(Y,IR,IWRITE,XSD,IBUGA3,IERROR)
        CALL MINIM(Y,IR,IWRITE,XMIN,IBUGA3,IERROR)
        CALL MAXIM(Y,IR,IWRITE,XMAX,IBUGA3,IERROR)
        CALL GEOMEA(Y,IR,IWRITE,XGEOM,IBUGA3,IERROR)
        XCOEFV=XSD/XMEAN
        XMEANC=XMEAN
        XSDC=XSD
        XVARC=SQRT(XSDC)
        XMINC=XMIN
        XMAXC=XMAX
        XGEOMC=XGEOM
      ENDIF
C
C  USE MOMENT ESTIMATES OF FAILURE DATA AS STARTING VALUES FOR
C  EQUATION SOLVER.
C
      IF(IGAMFL.EQ.'IGAM')THEN
        SHAPMO=(ZMEAN/ZSD)**2
        SCALMO=ZSD**2/ZMEAN
        XPAR(2)=DBLE(SCALMO)
        SCALMO=1.0/SCALMO
        XBAR=DBLE(ZMEAN)
        DGEOME=DBLE(ZGEOM)
      ELSE
        SHAPMO=(XMEAN/XSD)**2
        SCALMO=XSD**2/XMEAN
        XBAR=DBLE(XMEAN)
        DGEOME=DBLE(XGEOM)
        XPAR(2)=DBLE(SCALMO)
      ENDIF
C
      XPAR(1)=DBLE(SHAPMO)
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(GC1FUN,JAC,IOPT,NVAR,XPAR,FVEC,TOL,NPRINT,INFO,
     1           DTEMP1,MAXNXT,Y(IR+1),IM)
C
      SHAPML=REAL(XPAR(1))
      SCALML=REAL(XPAR(2))
      IF(IGAMFL.EQ.'IGAM')THEN
        SCALML=1.0/SCALML
      ENDIF
C
C  COMPUTE STANDARD ERRORS.
C
C  NOTE THAT DPSIFN COMPUTES THE SCALED PSI DERIVATIVE FUNCTION:
C
C     (-1)**(K+1)/GAMMA(K+1)
C
C  FOR TRIGAMMA, K=1 AND THE SCALING FACTOR REDUCES TO 1.
C
      ISE=1
      DN=DBLE(N)
      DG=DBLE(SHAPML)
      DS=DBLE(SCALML)
      DSUM1=0.0D0
      DSUM2=0.0D0
      DSUM3=0.0D0
      DSUM4=0.0D0
      DSUM5=0.0D0
      IF(IM.GT.0)THEN
        KODE=1
        NTEMP=1
        MTEMP=1
        NZ=0
C
        EPSABS=1.0D-7
        EPSREL=1.0D-7
        IER=0
        IKEY=3
        DLOW=0.0D0
        DA=DBLE(SHAPML)
        DGAM=DGAMMA(DG)
        DP=DPSI(DG)
        CALL DPSIFN(DG,NTEMP,KODE,MTEMP,DANS,NZ,IERR)
        TRIGAM=DANS(1)
        IF(IERR.EQ.1)THEN
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,4201)IDIST(1:14)
 4201     FORMAT('***** ERROR FROM ',A14,' (CENSORED CASE) MAXIMUM ',
     1           'LIKELIHOOD--')
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,4203)
 4203     FORMAT('      UNABLE TO COMPUTE TRIGAMMA FUNCTION.')
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,4209)
 4209     FORMAT('      PARAMETER STANDARD ERRORS AND CONFIDENCE ',
     1           'WILL NOT BE COMPUTED.')
          CALL DPWRST('XXX','WRIT')
          ISE=0
          GOTO4999
        ELSEIF(IERR.EQ.2)THEN
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,4201)IDIST
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,4205)
 4205     FORMAT('      OVERFLOW IN COMPUTING THE TRIGAMMA ',
     1           'FUNCTION.')
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,4209)
          CALL DPWRST('XXX','WRIT')
          ISE=0
          GOTO4999
        ELSEIF(IERR.EQ.3)THEN
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,4201)IDIST
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,4207)
 4207     FORMAT('      OVERFLOW IN COMPUTING THE TRIGAMMA ',
     1           'FUNCTION.')
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,4209)
          CALL DPWRST('XXX','WRIT')
          ISE=0
          GOTO4999
        ENDIF
C
        DO4310I=IR+1,N
C
          DX=DBLE(Y(I)/SCALML)
          DTERM1=DGAM - DGAMI(DG,DX)
          DTJ=DX**DG*DEXP(-DX)/DTERM1
C
          DJ1=0.0D0
          CALL DQAG(J1FUN,DLOW,DX,EPSABS,EPSREL,IKEY,DJ1,
     1              ABSERR,NEVAL,
     1              IER,LIMIT,LENW,LAST,IWORK,WORK)
          DJ2=0.0D0
          CALL DQAG(J2FUN,DLOW,DX,EPSABS,EPSREL,IKEY,DJ2,
     1              ABSERR,NEVAL,
     1              IER,LIMIT,LENW,LAST,IWORK,WORK)
C
          DSUM1=DSUM1 + DTJ*(DX-DTJ)
          DSUM2=DSUM2 + DTJ*DLOG(DX)
          DSUM3=DSUM3 + DTJ*(DGAM*DP - DJ1)/DTERM1
          DSUM4=DSUM4 + (DGAM*(DP**2 + TRIGAM) - DJ2)/DTERM1
          DSUM5=DSUM5 + ((DGAM*DP - DJ1)/DTERM1)**2
C
 4310   CONTINUE
      ENDIF
      IF(ISE.EQ.0)GOTO4999
C
      DTERM1=(-DR/DS**2)*((XBAR/DS)*(DG-1.0D0) - DG**2) - DSUM1/(DS**2)
      FISH(1,1)=REAL(DTERM1)
      DTERM1=DN*TRIGAM - DSUM4 + DSUM5
      FISH(2,2)=REAL(DTERM1)
      DTERM1=(1.0D0/DS)*(DR - DSUM2 + DSUM3)
      FISH(2,1)=REAL(DTERM1)
      FISH(1,2)=FISH(2,1)
C
      NDIM=2
      CALL SGECO(FISH,NDIM,NDIM,ITEMP,RCOND,XTEMP)
      IJOB=1
      CALL SGEDI(FISH,NDIM,NDIM,ITEMP,XTEMP,XTEMP(MAXNXT/2),IJOB)
      DO4410J=1,NDIM
        DO4415I=1,NDIM
          COV(I,J)=FISH(I,J)
 4415   CONTINUE
 4410 CONTINUE
C
      SCALSE=0.0
      SHAPSE=0.0
      IF(COV(1,1).GE.0.0)SCALSE=SQRT(COV(1,1))
      IF(COV(2,2).GE.0.0)SHAPSE=SQRT(COV(2,2))
      COVSE=COV(2,1)
C
 4999 CONTINUE
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'MML2')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9011)
 9011   FORMAT('**** AT THE END OF GAMML2--')
        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 GAMML3(Y,N,DTEMP1,
     1                  XMEAN,XSD,XVAR,XMIN,XMAX,XSKEW,
     1                  ALOCML,SCALML,SHAPML,
     1                  ISUBRO,IBUGA3,IERROR)
C
C     PURPOSE--THIS ROUTINE COMPUTES THE MAXIMUM LIKELIHOOD ESTIMATES
C              FOR THE 3-PARAMETER GAMMA DISTRIBUTION FOR THE RAW DATA
C              CASE (I.E., NO CENSORING AND NO GROUPING).
C
C              THIS METHOD IS BASED ON THE CODE GIVEN ON PP. 365-367 OF
C              COHEN AND WHITTEN.
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 GAMMA 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 6, APPENDIX.
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 TL
      DOUBLE PRECISION TU
      DOUBLE PRECISION T
      DOUBLE PRECISION FL
      DOUBLE PRECISION FU
      DOUBLE PRECISION F
      DOUBLE PRECISION BOUND
      DOUBLE PRECISION STEP
      DOUBLE PRECISION EPS
      DOUBLE PRECISION DB
      DOUBLE PRECISION RHO
C
      DOUBLE PRECISION V(6)
C
      CHARACTER*4 IWRITE
      CHARACTER*40 IDIST
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 ISTEPN
      CHARACTER*4 IMETH
C
      DOUBLE PRECISION DMEAN
      DOUBLE PRECISION DSUM1
      COMMON/GAMCO3/DMEAN,DSUM1,IN
      DOUBLE PRECISION GAMFU5
      EXTERNAL GAMFU5
C
      DOUBLE PRECISION DXSTRT
      DOUBLE PRECISION DAE
      DOUBLE PRECISION DRE
      DOUBLE PRECISION DXLOW
      DOUBLE PRECISION DXUP
      DOUBLE PRECISION DTERM1
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     TWO METHODS CODED:
C
C         1. METHOD GIVEN BY COHEN AND WHITTEN
C
C         2. METHOD GIVEN BY BURY
C
      ISUBN1='GAMM'
      ISUBN2='L3  '
      IDIST='GAMMA'
      IWRITE='OFF'
      IERROR='NO'
      IMETH='BURY'
C
      ALOCML=CPUMIN
      SCALML=CPUMIN
      SHAPML=CPUMIN
      V(1)=CPUMIN
      V(2)=CPUMIN
      V(3)=CPUMIN
C
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'MML3')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,51)
   51   FORMAT('**** AT THE BEGINNING OF GAMML3--')
        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 GAMMA MLE ESTIMATE              **
C               ******************************************
C
      ISTEPN='1'
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'MML3')
     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 GAMMA 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
      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
      DO210I=1,N
        DTEMP1(I)=DBLE(Y(I))
  210 CONTINUE
C
      IN=N
      DMEAN=DBLE(XMEAN)
C
C     STEP 1: SOLVE EQUATION IN GAMFU7 TO ESTIMATE THE LOCATION
C             PARAMETER.
C
C             FIRST NEED TO FIND A BRACKETING INTERVAL.  USE
C             MINIMUM VALUE AS UPPER LIMIT.  DESCEND IN SMALL
C             INCREMENTS UNTIL "MEAN - 60*SD".  IF NO BRACKETING
C             INTERVAL FOUND AT THAT POINT, THEN NO ML SOLUTION.
C
      IF(IMETH.EQ.'COHE')THEN
        EPS=0.1D-08
        BOUND=DBLE(XMEAN) - 25.0D0*DBLE(XSD)
        STEP=DBLE(XSD)/100.0D0
        TU=DBLE(XMIN) - EPS
        CALL GAMFU7(DTEMP1,TU,DBLE(XMEAN),N,
     1              RHO,DB,FU,
     1              ISUBRO,IBUGA3,IERROR)
C
        IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'MML3')THEN
          WRITE(ICOUT,211)TU,RHO,DB,FU
  211     FORMAT('INITIAL GAMFU7: TU,RHO,DB,FU = ',4G15.7)
          CALL DPWRST('XXX','WRIT')
        ENDIF
C
C     LOCATE A LOWER BOUND FOR THE LOCATION
C
        TL=TU
        FL=FU
C
 300    CONTINUE
        IF(FL/FU.GT.0.0D0)THEN
          TL=TL-STEP
          IF(TL.GT.BOUND)THEN
            CALL GAMFU7(DTEMP1,TL,DBLE(XMEAN),N,
     1                  RHO,DB,FL,
     1                  ISUBRO,IBUGA3,IERROR)
C
            IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'MML3')THEN
              WRITE(ICOUT,301)TL,RHO,DB,FL
  301         FORMAT('BRACKETING GAMFU7: TL,RHO,DB,FL = ',4G15.7)
              CALL DPWRST('XXX','WRIT')
           ENDIF
C
          ELSE
            WRITE(ICOUT,999)
            CALL DPWRST('XXX','WRIT')
            WRITE(ICOUT,111)
            CALL DPWRST('XXX','WRIT')
            WRITE(ICOUT,292)
  292       FORMAT('      UNABLE TO FIND A BRACKETING INTERVAL FOR ',
     1             'THE LOCATION PARAMETER.')
            CALL DPWRST('XXX','WRIT')
            IERROR='YES'
            GOTO9000
          ENDIF
C
          GOTO300
        ELSE
          IF(TL.LT.BOUND)THEN
            WRITE(ICOUT,999)
            CALL DPWRST('XXX','WRIT')
            WRITE(ICOUT,111)
            CALL DPWRST('XXX','WRIT')
            WRITE(ICOUT,292)
            CALL DPWRST('XXX','WRIT')
            IERROR='YES'
          ELSE
C
C         USE BINARY SEARCH TO FIND ESTIMATE OF LOCATION PARAMETER
C
            T=(TL+TU)/2.0D0
  400       CONTINUE
            CALL GAMFU7(DTEMP1,T,DBLE(XMEAN),N,
     1                  RHO,DB,F,
     1                  ISUBRO,IBUGA3,IERROR)
C
            IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'MML3')THEN
              WRITE(ICOUT,401)T,RHO,DB,F
  401         FORMAT('BINARY SEARCH GAMFU7: T,RHO,DB,F = ',4G15.7)
              CALL DPWRST('XXX','WRIT')
            ENDIF
C
            V(1)=T
            V(2)=DB
            V(3)=RHO
            V(4)=V(3)*V(2) + T
            V(5)=V(2)*DSQRT(V(3))
            V(6)=2.0D0/DSQRT(RHO)
            IF(DABS(TL-T).GT.EPS)THEN
              IF(F*FL.LT.0.0D0)THEN
                TU=T
              ELSE
                TL=T
                FL=F
              ENDIF
              T=(TL+TU)/2.0D0
              GOTO400
            ENDIF
          ENDIF
        ENDIF
C
        ALOCML=REAL(V(1))
        SCALML=REAL(V(2))
        SHAPML=REAL(V(3))
C
      ELSEIF(IMETH.EQ.'BURY')THEN
C
C       METHOD GIVEN ON PAGES 220-221 OF BURY.
C
C       STEP 1: USE DFZER2 TO SOLVE FOR LOCATION PARAMETER.
C               STARTING VALUE PASSED IN (DPMLG3 WILL USE THE
C               MODIFIED MOMENTS ESTIMATOR AS THE STARTING
C               VALUE).
C
CCCCC   DXSTRT=DBLE(ALOCSV)
        STEP=DBLE(XSD)/100.0D0
        BOUND=DBLE(XMEAN) - 25.0D0*DBLE(XSD)
C
C       FIND BRACKETING INTERVAL FIRST
C
        DXUP=DBLE(XMIN) - STEP
        FU=GAMFU5(DXUP,DTEMP1)
        DXLOW=DXUP - STEP
        FL=GAMFU5(DXLOW,DTEMP1)
2105    CONTINUE
        IF(FU*FL.GT.0.0D0)THEN
          DXLOW=DXLOW - STEP
          IF(DXLOW.LT.BOUND)THEN
            WRITE(ICOUT,999)
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,2131)
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,2133)
            CALL DPWRST('XXX','BUG ')
            GOTO9000
          ENDIF
          FL=GAMFU5(DXLOW,DTEMP1)
          GOTO2105
        ENDIF
C
        IFLAG=0
        DXSTRT=(DXLOW + DXUP)/2.0D0
        DAE=2.0*0.000001D0*DXSTRT
        DRE=DAE
C
        CALL DFZER2(GAMFU5,DXLOW,DXUP,DXSTRT,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,2111)
C2111     FORMAT('***** WARNING FROM GAMMA MAXIMUM LIKELIHOOD--')
CCCCC     CALL DPWRST('XXX','BUG ')
CCCCC     WRITE(ICOUT,2113)
C2113     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,2121)
 2121     FORMAT('***** WARNING FROM GAMMA MAXIMUM LIKELIHOOD--')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,2123)
 2123     FORMAT('      ESTIMATE OF SHAPE PARAMETER MAY BE NEAR ',
     1           'A SINGULAR POINT.')
          CALL DPWRST('XXX','BUG ')
        ELSEIF(IFLAG.EQ.4)THEN
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,2131)
 2131     FORMAT('***** ERROR FROM GAMMA MAXIMUM LIKELIHOOD--')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,2133)
 2133     FORMAT('      APPROPRIATE BRACKETING INTERVAL NOT FOUND.')
          CALL DPWRST('XXX','BUG ')
        ELSEIF(IFLAG.EQ.5)THEN
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,2121)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,2143)
 2143     FORMAT('      MAXIMUM ITERATIONS EXCEEDED.')
          CALL DPWRST('XXX','BUG ')
        ENDIF
C
        ALOCML=REAL(DXLOW)
C
C       STEP 2: COMPUTE ESTIMATES FOR SHAPE AND SCALE
C
        DTERM1=1.0D0 - (1.0D0/((DMEAN - DXLOW)*DSUM1))
        SHAPML=REAL(1.0D0/DTERM1)
        SCALML=(XMEAN-ALOCML)/SHAPML
C
      ENDIF
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'MML3')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9011)
 9011   FORMAT('**** AT THE END OF GAMML3--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9013)ALOCML,SCALML,SHAPML
 9013   FORMAT('ALOCML,SCALML,SHAPML = ',3G15.7)
        CALL DPWRST('XXX','WRIT')
      ENDIF
C
      RETURN
      END
      SUBROUTINE GAMML5(ALOC,SCALE,SHAPE,X,N,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 GAMMA DISTRIBUTION.
C
C              IF SHAPE > 2, THE EXPECTED INFORMATION MATRIX IS
C              OBTAINED FROM THE FOLLOWING QUANTITIES:
C
C                 I(1,1) = N/(SCALE**2*(SHAPE-2)
C                 I(1,2) = n/SCALE**2
C                 I(1,3) = n/(SCALE*(SHAPE-1))
C                 I(2,2) = N*SHAPE/SCALE**2
C                 I(2,3) = N/SCALE
C                 I(3,3) = N*TRIGAMMA(SHAPE)
C
C              IF 1 < SHAPE <= 2, THEN THE LOCAL INFORMATION MATRIX
C              CAN BE USED.  FOR THIS CASE, USE
C
C                 I(1,1) = (SHAPE-1)*SUM[i=1 to N][1/(X(i) - LOC)**2]
C
C              THE PARAMETER VARIANCE-COVARIANCE MATRIX IS THE
C              INVERSE OF THE INFORMATION MATRIX.
C
C     REFERENCE--KARL BURY, "STATISTICAL DISTRIBUTIONS IN
C                ENGINEERING", CAMBRIDGE UNIVERSITY PRESS,
C                1999, CHAPTER 13, P. 212.
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/4
C     ORIGINAL VERSION--APRIL     2014
C
      REAL X(*)
      REAL XTEMP(*)
      REAL FISH(3,3)
      REAL COV(3,3)
C
      INTEGER ITEMP(*)
C
      CHARACTER*4 ISUBRO
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      DOUBLE PRECISION DN
      DOUBLE PRECISION DLOC
      DOUBLE PRECISION DSCALE
      DOUBLE PRECISION DSHAPE
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DX
C
      DOUBLE PRECISION TRIGAM
      EXTERNAL TRIGAM
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='GAMM'
      ISUBN2='L5  '
      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 GAMML5--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,52)IBUGA3,ISUBRO,N
   52   FORMAT('IBUGA3,ISUBRO,N = ',2(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
          FISH(I,J)=CPUMIN
          COV(I,J)=CPUMIN
  103   CONTINUE
  101 CONTINUE
C
      DN=REAL(N)
      DLOC=DBLE(ALOC)
      DSCALE=DBLE(SCALE)
      DSHAPE=DBLE(SHAPE)
C
      IF(SHAPE.GT.2.0)THEN
        FISH(1,1)=DN/(DSCALE**2*(DSHAPE-2.0D0))
      ELSEIF(SHAPE.GT.1.0)THEN
        DSUM1=0.0D0
        DO110I=1,N
          DX=(DBLE(X(I)) - DLOC)**2
          DSUM1=DSUM1 + 1.0D0/DX
  110   CONTINUE
        FISH(1,1)=(DSHAPE - 1.0D0)*DSUM1
      ELSE
        GOTO9000
      ENDIF
      FISH(1,2)=REAL(DN/DSCALE**2)
      FISH(1,3)=REAL(DN/(DSCALE*(DSHAPE - 1.0D0)))
      FISH(2,2)=REAL(DN*DSHAPE/DSCALE**2)
      FISH(2,3)=REAL(DN/DSCALE)
      FISH(2,3)=REAL(DN/DSCALE)
      FISH(3,3)=REAL(DN*TRIGAM(DSHAPE,IFAULT))
      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
 9000 CONTINUE
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'AML5')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9011)
 9011   FORMAT('**** AT THE END OF GAMML5--')
        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 GAMML8(Y,N,IGAMFL,P3GAMI,IOPFLG,
     1                  TEMP1,DTEMP1,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 GAMMA
C              DISTRIBUTION.  THIS CAN BE USEFUL AS THE STANDARD
C              MAXIMUM LIKELIHOOD 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 GAMMA ML METHODS.
C
C                    D. COMPUTE THE LOG-LIKELIHOOD OF THE 3-PARAMETER
C                       GAMMA 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(*)
      DOUBLE PRECISION DTEMP1(*)
C
      CHARACTER*4 ICASAN
      CHARACTER*4 IGAMFL
      CHARACTER*4 IOPFLG
      CHARACTER*4 ISUBRO
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 IWRITE
      CHARACTER*4 IOP
      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='GAMM'
      ISUBN2='L8  '
      IWRITE='OFF'
      IERROR='NO'
C
      EPS=0.1E-5
C
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'MML8')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,51)
   51   FORMAT('**** AT THE BEGINNING OF GAMML8--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,52)IBUGA3,ISUBRO,IGAMFL,N
   52   FORMAT('IBUGA3,ISUBRO,IGAMFL,N = ',3(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.'MML8')
     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.'MML8')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IDIST='GAMMA'
      ICASAN='GAMM'
      IGAMFL='GAMM'
C
      IF(N.LE.4)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,111)
  111   FORMAT('***** ERROR IN GAMMA 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)
          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 GAMML1(Y,N,IGAMFL,
     1            TEMP1,DTEMP1,
     1            XMEAN,XSD,XVAR,XMIN,XMAX,XGEOM,
     1            ZMEAN,ZSD,ZGEOM,
     1            SCALML,SCALSE,SHAPML,SHAPSE,COVSE,
     1            SCALMO,SHAPMO,
     1            SCALYE,SHAPYE,SCYEBC,SHYEBC,
     1            ISUBRO,IBUGA3,IERROR)
      YMIN=P3GAMI
      IF(YMIN.GE.XMIN)YMIN=0.0
      ALOCML=YMIN
      CALL GAMLI1(Y,N,ICASAN,IGAMFL,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.'MML8')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
      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 GAMML1(Y2,N,IGAMFL,
     1              TEMP1,DTEMP1,
     1              XMEANT,XSDT,XVART,XMINT,XMAXT,XGEOMT,
     1              ZMEANT,ZSDT,ZGEOMT,
     1              SCALMT,SCALSE,SHAPMT,SHAPSE,COVSE,
     1              SCALMO,SHAPMO,
     1              SCALYE,SHAPYE,SCYEBC,SHYEBC,
     1              ISUBRO,IBUGA3,IERROR)
        CALL GAMLI1(Y,N,ICASAN,IGAMFL,ALOCMT,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       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.'MML8')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9011)
 9011   FORMAT('**** AT THE END OF GAMML8--')
        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 GAMMO1(XMEAN,XSD,XMIN,XSKEW,N,PSTAMV,
     1                  ALOCMO,SCALMO,SHAPMO,
     1                  ALOCMM,SCALMM,SHAPMM,
     1                  ISUBRO,IBUGA3,IERROR)
C
C     PURPOSE--THIS ROUTINE COMPUTES MOMENT ESTIMATES FOR THE 3-PARAMETER
C              GAMMA 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. 363-364.
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(6)
      DOUBLE PRECISION VMMOM(6)
      DOUBLE PRECISION RHO
      DOUBLE PRECISION RHOL
      DOUBLE PRECISION RHOU
      DOUBLE PRECISION FL
      DOUBLE PRECISION FU
      DOUBLE PRECISION F
      DOUBLE PRECISION EPS
      DOUBLE PRECISION DN
      DOUBLE PRECISION Z
      DOUBLE PRECISION Z1
      DOUBLE PRECISION DCDF
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='GAMM'
      ISUBN2='O1  '
      IERROR='NO'
C
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'MMO1')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,51)
   51   FORMAT('**** AT THE BEGINNING OF GAMMO1--')
        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 GAMMA MOMENT ESTIMATE       **
C               ******************************************
C
      ISTEPN='1'
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'MMO1')
     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)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
      EPS=0.1D-7
C
      ALOCMO=CPUMIN
      SCALMO=CPUMIN
      SHAPMO=CPUMIN
C
      ALOCMM=CPUMIN
      SCALMM=CPUMIN
      UHATMM=CPUMIN
C
      VMMOM(1)=CPUMIN
      VMMOM(2)=CPUMIN
      VMMOM(3)=CPUMIN
      VMMOM(4)=CPUMIN
      VMMOM(5)=CPUMIN
      VMMOM(6)=CPUMIN
      VMOM(1)=CPUMIN
      VMOM(2)=CPUMIN
      VMOM(3)=CPUMIN
      VMOM(4)=CPUMIN
      VMOM(5)=CPUMIN
      VMOM(6)=CPUMIN
      AMOM(1)=CPUMIN
      AMOM(2)=CPUMIN
      AMOM(3)=CPUMIN
C
C               ******************************************
C               **  STEP 2--                            **
C               **  MOMENT ESTIMATES                    **
C               ******************************************
C
      ISTEPN='2'
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'MMO1')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
C     IN CODE BELOW:
C
C        VMOM(1) = ESTIMATE OF LOCATION
C        VMOM(2) = ESTIMATE OF SCALE
C        VMOM(3) = ESTIMATE OF SHAPE (SIGMA)
C        VMOM(4) = ESTIMATE OF MEAN
C                = LOC + SHAPE*SCALE
C        VMOM(5) = ESTIMATE OF STANDARD DEVIATION
C                = SHAPE*SCALE**2
C        VMOM(6) = THIRD STANDARD MOMENT, A3
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)
C
      VMOM(1)=AMOM(1) - (2.0D0*AMOM(2)/AMOM(3))
      VMOM(2)=AMOM(2)*AMOM(3)/2.0D0
      VMOM(3)=4.0D0/AMOM(3)**2
      VMOM(4)=VMOM(2)*VMOM(3) + VMOM(1)
      VMOM(5)=VMOM(2)*DSQRT(VMOM(3))
      VMOM(6)=AMOM(3)
C
      ALOCMO=REAL(VMOM(1))
      SCALMO=REAL(VMOM(2))
      SHAPMO=REAL(VMOM(3))
C
C     IN CODE BELOW:
C
C        VMMOM(1) = ESTIMATE OF LOCATION
C        VMMOM(2) = ESTIMATE OF SCALE
C        VMMOM(3) = ESTIMATE OF SHAPE (SIGMA)
C        VMMOM(4) = ESTIMATE OF MEAN
C                 = LOC + SHAPE*SCALE
C        VMMOM(5) = ESTIMATE OF STANDARD DEVIATION
C                 = SHAPE*SCALE**2
C        VMMOM(6) = THIRD STANDARD MOMENT, A3
C
C     COMPUTE MODIFIED MOMENT ESTIMATORS USING CODE FOUND ON
C     PP. 363-364 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)
C
C     FIND THE STANDARDIZED FIRST ORDER STATISTIC
C
      Z=(DBLE(XMIN) - AMOM(1))/AMOM(2)
C
C     SET UPPER BOUND ON SHAPE TO 1600 (LOWER BOUND ON SKEWNESS IS 0.05)
C
CCCCC RHOU=1600.D0
      RHOU=200.D0
      RHOL=((AMOM(1) - DBLE(XMIN))/AMOM(2))**2
C
C     CALCULATE FUNCTION AT UPPER BOUND, A3U, AND SCALE Z1 SO THAT Z1 > 0
C
      Z1=(Z + DSQRT(RHOU))*DSQRT(RHOU)
      CALL GAMCDF(REAL(Z1),REAL(RHOU),CDF)
      DCDF=DBLE(CDF)
      FU=DCDF - (1.0D0/(DN+1.0D0))
      Z1=(Z + DSQRT(RHOL))*DSQRT(RHOL)
      CALL GAMCDF(REAL(Z1),REAL(RHOL),CDF)
      DCDF=DBLE(CDF)
      FL=DCDF - (1.0D0/(DN+1.0D0))
C
      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
        RHO=(RHOL+RHOU)/2.0D0
        F=FL
300     CONTINUE
        IF(DABS(RHO-RHOL).GT.EPS)THEN
          Z1=(Z + DSQRT(RHO))*DSQRT(RHO)
          CALL GAMCDF(REAL(Z1),REAL(RHO),CDF)
          DCDF=DBLE(CDF)
          F=DCDF - (1.0D0/(DN+1.0D0))
          IF(F*FL.LT.0.0D0)THEN
            RHOU=RHO
          ELSE
            RHOL=RHO
            FL=F
          ENDIF
          RHO=(RHOL+RHOU)/2.0D0
          GOTO300
        ELSE
          VMMOM(1)=AMOM(1) - AMOM(2)*DSQRT(RHO)
          VMMOM(2)=AMOM(2)/DSQRT(RHO)
          VMMOM(3)=RHO
          VMMOM(4)=VMMOM(3)*VMMOM(2) + VMMOM(1)
          VMMOM(5)=VMMOM(2)*DSQRT(VMMOM(3))
          VMMOM(6)=2.0D0/DSQRT(VMMOM(3))
        ENDIF
      ENDIF
C
      ALOCMM=VMMOM(1)
      SCALMM=VMMOM(2)
      SHAPMM=VMMOM(3)
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'MMO1')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9011)
 9011   FORMAT('**** AT THE END OF GAMMO1--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9012)ALOCMO,SCALMO,SHAPMO
 9012   FORMAT('ALOCMO,SCALMO,SHAPMO = ',3G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9013)ALOCMM,SCALMM,SHAPMM
 9013   FORMAT('ALOCMM,SCALMM,SHAPMM = ',3G15.7)
        CALL DPWRST('XXX','WRIT')
      ENDIF
C
      RETURN
      END
      SUBROUTINE GAMPDF(X,GAMMA,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE GAMMA
C              DISTRIBUTION WITH SINGLE PRECISION
C              TAIL LENGTH PARAMETER = GAMMA.
C              THE GAMMA DISTRIBUTION USED
C              HEREIN HAS MEAN = GAMMA
C              AND STANDARD DEVIATION = SQRT(GAMMA).
C              THIS DISTRIBUTION IS DEFINED FOR ALL POSITIVE X,
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C              F(X) = (1/CONSTANT) * (X**(GAMMA-1)) * EXP(-X)
C              WHERE THE CONSTANT = THE GAMMA FUNCTION EVALUATED
C              AT THE VALUE GAMMA.
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                     --GAMMA  = THE SINGLE PRECISION VALUE
C                                OF THE TAIL LENGTH PARAMETER.
C                                GAMMA SHOULD BE POSITIVE.
C     OUTPUT ARGUMENTS--PDF    = THE SINGLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--GAMMA SHOULD BE POSITIVE.
C                 --X SHOULD BE POSITIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--DEXP, DLOG.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN.
C     REFERENCES--WILK, GNANADESIKAN, AND HUYETT, 'PROBABILITY
C                 PLOTS FOR THE GAMMA DISTRIBUTION',
C                 TECHNOMETRICS, 1962, PAGES 1-15,
C                 ESPECIALLY PAGES 3-5.
C               --NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY APPLIED MATHEMATICS
C                 SERIES 55, 1964, PAGE 257, FORMULA 6.1.41.
C               --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1970, PAGES 166-206.
C               --HASTINGS AND PEACOCK, STATISTICAL
C                 DISTRIBUTIONS--A HANDBOOK FOR
C                 STUDENTS AND PRACTITIONERS, 1975,
C                 PAGES 68-73.
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 1994.
C     UPDATED         --JANUARY   1996.  HANDLE X=0 AS SPECIAL CASE
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
CCCCC JANUARY 1996.  ADD FOLLOWING LINE.
      INCLUDE 'DPCOMC.INC'
      INCLUDE 'DPCOP2.INC'
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX,DGAMMA,DLNGAM,DPDF
      DOUBLE PRECISION DTERM1, DTERM2, DTERM3, DTERM4, DTERM5
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      PDF=0.0
      IF(X.LE.0.0)THEN
        WRITE(ICOUT,4)
    4   FORMAT('***** WARNING--THE FIRST ARGUMENT TO GAMPDF IS ',
     1         'NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ELSEIF(GAMMA.LE.0.0)THEN
        WRITE(ICOUT,15)
   15   FORMAT('***** ERROR--THE SECOND ARGUMENT TO GAMPDF IS ',
     1         'NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)GAMMA
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
C
C-----START POINT-----------------------------------------------------
C
      DX=DBLE(X)
      DGAMMA=DBLE(GAMMA)
C
CCCCC JANUARY 1996.  TRREAT X = 0 AS SPECIAL CASE.
      IF(ABS(DX).LE.D1MACH(1))THEN
        IF(DGAMMA.EQ.1.0D0)THEN
          PDF=1.0
          GOTO9999
        ELSEIF(DGAMMA.LT.1.0D0)THEN
          DX=1.0D-10
        ELSE
          DX=D1MACH(1)
        ENDIF
      ENDIF
C
C     COMPUTE THE GAMMA FUNCTION USING THE ALGORITHM IN THE
C     NBS APPLIED MATHEMATICS SERIES REFERENCE.
C
      DTERM1=(DGAMMA-1.0D0)*DLOG(DX)
      DTERM2=-DX
      DTERM3=DLOG(1.0D0)
      DTERM4=DLNGAM(DGAMMA)
      DTERM5=DTERM1+DTERM2-DTERM3-DTERM4
      IF(DTERM5.LT.-80.D0)THEN
        PDF=0.0
      ELSEIF(DTERM5.GT.65.D0)THEN
        WRITE(ICOUT,105)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)GAMMA
        CALL DPWRST('XXX','BUG ')
        PDF=EXP(65.0)
      ELSE
        DPDF=DEXP(DTERM5)
        PDF=REAL(DPDF)
      ENDIF
  105 FORMAT('****** WARNING--OVERFLOW IN GAMPDF ROUTINE.  PDF VALUE ',
     1'SET TO EXP(65)')
CCCCC   WRITE(ICOUT,25)
CCCCC   CALL DPWRST('XXX','BUG ')
C
CCC25 FORMAT('***** WARNING--UNDERFLOW IN CALCULATION OF GAMMA PDF.',
CCCCC1       '  PDF SET TO ZERO. *****')
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE GAMPPF(P,GAMMA,PPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE GAMMA DISTRIBUTION
C              WITH SINGLE PRECISION
C              TAIL LENGTH PARAMETER = GAMMA.
C              THE GAMMA DISTRIBUTION USED
C              HEREIN HAS MEAN = GAMMA
C              AND STANDARD DEVIATION = SQRT(GAMMA).
C              THIS DISTRIBUTION IS DEFINED FOR ALL POSITIVE X,
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C              F(X) = (1/CONSTANT) * (X**(GAMMA-1)) * EXP(-X)
C              WHERE THE CONSTANT = THE GAMMA FUNCTION EVALUATED
C              AT THE VALUE 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 (EXCLUSIVELY)
C                                AND 1.0 (EXCLUSIVELY))
C                                AT WHICH THE PERCENT POINT
C                                FUNCTION IS TO BE EVALUATED.
C                     --GAMMA  = THE SINGLE PRECISION VALUE OF THE
C                                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 GAMMA 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 (EXCLUSIVELY)
C                   AND 1.0 (EXCLUSIVELY).
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--DEXP, DLOG.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     ACCURACY--(ON THE UNIVAC 1108, EXEC 8 SYSTEM AT NBS)
C               COMPARED TO THE KNOWN GAMMA = 1 (EXPONENTIAL)
C               RESULTS, AGREEMENT WAS HAD OUT TO 6 SIGNIFICANT
C               DIGITS FOR ALL TESTED P IN THE RANGE P = .001 TO
C               P = .999.  FOR P = .95 AND SMALLER, THE AGREEMENT
C               WAS EVEN BETTER--7 SIGNIFICANT DIGITS.
C               (NOTE THAT THE TABULATED VALUES GIVEN IN THE WILK,
C               GNANADESIKAN, AND HUYETT REFERENCE BELOW, PAGE 20,
C               ARE IN ERROR FOR AT LEAST THE GAMMA = 1 CASE--
C               THE WORST DETECTED ERROR WAS AGREEMENT TO ONLY 3
C               SIGNIFICANT DIGITS (IN THEIR 8 SIGNIFICANT DIGIT TABLE)
C               FOR P = .999.)
C     REFERENCES--WILK, GNANADESIKAN, AND HUYETT, 'PROBABILITY
C                 PLOTS FOR THE GAMMA DISTRIBUTION',
C                 TECHNOMETRICS, 1962, PAGES 1-15,
C                 ESPECIALLY PAGES 3-5.
C               --NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY APPLIED MATHEMATICS
C                 SERIES 55, 1964, PAGE 257, FORMULA 6.1.41.
C               --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1970, PAGES 166-206.
C               --HASTINGS AND PEACOCK, STATISTICAL
C                 DISTRIBUTIONS--A HANDBOOK FOR
C                 STUDENTS AND PRACTITIONERS, 1975,
C                 PAGES 68-73.
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-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1966)
C     VERSION NUMBER--82/7
C     ORIGINAL VERSION--NOVEMBER  1974.
C     UPDATED         --SEPTEMBER 1975.
C     UPDATED         --NOVEMBER  1975.
C     UPDATED         --DECEMBER  1981.
C     UPDATED         --MAY       1982.
C     UPDATED         --JUNE      1987.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DP,DGAMMA
CCCCC DOUBLE PRECISION Z,Z2,Z3,Z4,Z5,DEN,A,B,C,D,G
      DOUBLE PRECISION Z,Z2,DEN,A,B,C,D
      DOUBLE PRECISION XMIN0,XMIN,AI,XMAX,DX,PCALC,XMID
      DOUBLE PRECISION XLOWER,XUPPER,XDEL
      DOUBLE PRECISION SUM,TERM,CUT1,CUT2,AJ,CUTOFF,T
      DOUBLE PRECISION DLG,DLT,DLX,DLPCAL
      DOUBLE PRECISION DLP,DLGAMM,DLXMI0
      DOUBLE PRECISION Z2INV
      DOUBLE PRECISION DEXP,DLOG
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
      XMID=0.0
      XLOWER=0.0
      XUPPER=0.0
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      PPF=0.0
      IF(P.LE.0.0.OR.P.GE.1.0)THEN
        WRITE(ICOUT,1)
    1   FORMAT('***** ERROR--THE FIRST ARGUMENT TO GAMPPF IS OUTSIDE ',
     1         'THE ALLOWABLE (0,1) INTERVAL')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)P
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(GAMMA.LE.0.0)THEN
        WRITE(ICOUT,15)
   15   FORMAT('***** ERROR--THE SECOND ARGUMENT TO GAMMPPF IS ',
     1         'NON-POSITIVE')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)GAMMA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
C
      DP=P
      DGAMMA=GAMMA
      MAXIT=10000
C
C     COMPUTE THE GAMMA FUNCTION USING THE ALGORITHM IN THE
C     NBS APPLIED MATHEMATICS SERIES REFERENCE.
C     THIS GAMMA FUNCTION NEED BE CALCULATED ONLY ONCE.
C     IT IS USED IN THE CALCULATION OF THE CDF BASED ON
C     THE TENTATIVE VALUE OF THE PPF IN THE ITERATION.
C
      Z=DGAMMA
      DEN=1.0D0
  150 IF(Z.GE.10.0D0)GOTO160
      DEN=DEN*Z
      Z=Z+1.0D0
      GOTO150
  160 Z2=Z*Z
CCCCC Z3=Z*Z2
CCCCC Z4=Z2*Z2
CCCCC Z5=Z2*Z3
      A=(Z-0.5D0)*DLOG(Z)-Z+C
CCCCC B=D(1)/Z+D(2)/Z3+D(3)/Z5+D(4)/(Z2*Z5)+D(5)/(Z4*Z5)+
CCCCC1D(6)/(Z*Z5*Z5)+D(7)/(Z3*Z5*Z5)+D(8)/(Z5*Z5*Z5)+D(9)/(Z2*Z5*Z5*Z5)
      Z2INV=1.0D0/Z2
      B=D(9)
      B=Z2INV*B+D(8)
      B=Z2INV*B+D(7)
      B=Z2INV*B+D(6)
      B=Z2INV*B+D(5)
      B=Z2INV*B+D(4)
      B=Z2INV*B+D(3)
      B=Z2INV*B+D(2)
      B=Z2INV*B+D(1)
      B=(1.0D0/Z)*B
CCCCC G=DEXP(A+B)/DEN
      DLG=(A+B)-DLOG(DEN)
CCCCC WRITE(ICOUT,277)Z,B,DEN,DLG
CC277 FORMAT('Z,B,DEN,DLG = ',4E15.7)
CCCCC CALL DPWRST('XXX','BUG ')
C
C     DETERMINE LOWER AND UPPER LIMITS ON THE DESIRED 100P
C     PERCENT POINT.
C
      ILOOP=1
CCCCC WRITE(ICOUT,377)DP,DGAMMA
CC377 FORMAT('DP,DGAMMA = ',2D15.7)
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC XMIN0=(DP*DGAMMA*G)**(1.0D0/DGAMMA)
      DLP=DLOG(DP)
      DLGAMM=DLOG(DGAMMA)
      DLXMI0=(1.0D0/DGAMMA)*(DLP+DLGAMM+DLG)
      XMIN0=DEXP(DLXMI0)
CCCCC WRITE(ICOUT,378)XMIN0
CC378 FORMAT('XMIN0 = ',E15.7)
CCCCC CALL DPWRST('XXX','BUG ')
      XMIN=XMIN0
      ICOUNT=1
  350 AI=ICOUNT
      XMAX=AI*XMIN0
      DX=XMAX
      GOTO1000
  360 IF(PCALC.GE.DP)GOTO370
      XMIN=XMAX
      ICOUNT=ICOUNT+1
      IF(ICOUNT.LE.30000)GOTO350
  370 XMID=(XMIN+XMAX)/2.0D0
C
C     NOW ITERATE BY BISECTION UNTIL THE DESIRED ACCURACY IS ACHIEVED.
C
      ILOOP=2
      XLOWER=XMIN
      XUPPER=XMAX
      ICOUNT=0
  550 DX=XMID
      GOTO1000
  560 IF(PCALC.EQ.DP)GOTO570
      IF(PCALC.GT.DP)GOTO580
      XLOWER=XMID
      XMID=(XMID+XUPPER)/2.0D0
      GOTO590
  580 XUPPER=XMID
      XMID=(XMID+XLOWER)/2.0D0
  590 XDEL=XMID-XLOWER
      IF(XDEL.LT.0.0D0)XDEL=-XDEL
      ICOUNT=ICOUNT+1
      IF(XDEL.LT.0.0000000001D0.OR.ICOUNT.GT.100)GOTO570
      GOTO550
  570 PPF=XMID
      GOTO9000
C
C********************************************************************
C     THIS SECTION BELOW IS LOGICALLY SEPARATE FROM THE ABOVE.
C     THIS SECTION COMPUTES A CDF VALUE FOR ANY GIVEN TENTATIVE
C     PERCENT POINT X VALUE AS DEFINED IN EITHER OF THE 2
C     ITERATION LOOPS IN THE ABOVE CODE.
C
C     COMPUTE T-SUB-Q AS DEFINED ON PAGE 4 OF THE WILK, GNANADESIKAN,
C     AND HUYETT REFERENCE
C
 1000 SUM=1.0D0/DGAMMA
      TERM=1.0D0/DGAMMA
      CUT1=DX-DGAMMA
      CUT2=DX*10000000000.0D0
      DO700J=1,MAXIT
      AJ=J
      TERM=DX*TERM/(DGAMMA+AJ)
      SUM=SUM+TERM
      CUTOFF=CUT1+(CUT2*TERM/SUM)
      IF(AJ.GT.CUTOFF)GOTO750
  700 CONTINUE
      WRITE(ICOUT,705)MAXIT
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,706)P
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,707)GAMMA
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,708)
      CALL DPWRST('XXX','BUG ')
      PPF=0.0
      GOTO9000
C
  750 T=SUM
CCCCC WRITE(ICOUT,777)T,DX
CC777 FORMAT('T,DX = ',2E15.7)
CCCCC CALL DPWRST('XXX','BUG ')
      DLT=DLOG(T)
      DLX=DLOG(DX)
CCCCC WRITE(ICOUT,778)DX,DGAMMA,T,DLT,G,DLG
CC778 FORMAT('DX,DGAMMA,T,DLT,G,DLG = ',6D15.7)
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC PCALC=(DX**DGAMMA)*(DEXP(-DX))*T/G
      DLPCAL=DGAMMA*DLX-DX+DLT-DLG
      PCALC=DEXP(DLPCAL)
      IF(ILOOP.EQ.1)GOTO360
      GOTO560
C
  705 FORMAT('*****ERROR IN INTERNAL OPERATIONS IN THE GAMPPF ',
     1'SUBROUTINE--THE NUMBER OF ITERATIONS EXCEEDS ',I7)
  706 FORMAT(33H     THE INPUT VALUE OF P     IS ,E15.8)
  707 FORMAT(33H     THE INPUT VALUE OF GAMMA IS ,E15.8)
  708 FORMAT(48H     THE OUTPUT VALUE OF PPF HAS BEEN SET TO 0.0)
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE GAMRAN(N,GAMMA,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE GAMMA DISTRIBUTION
C              WITH TAIL LENGTH PARAMETER VALUE = GAMMA.
C              THE PROTOTYPE GAMMA DISTRIBUTION USED
C              HEREIN HAS MEAN = GAMMA
C              AND STANDARD DEVIATION = SQRT(GAMMA).
C              THIS DISTRIBUTION IS DEFINED FOR ALL POSITIVE X,
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C              F(X) = (1/CONSTANT) * (X**(GAMMA-1)) * EXP(-X)
C              WHERE THE CONSTANT = THE GAMMA FUNCTION EVALUATED
C              AT THE 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                                GAMMA SHOULD BE LARGER
C                                THAN 1/3 (ALGORITHMIC RESTRICTION).
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 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                 --GAMMA SHOULD BE LARGER
C                   THAN 1/3 (ALGORITHMIC RESTRICTION).
C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN, NORRAN.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--SQRT, EXP.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--GREENWOOD, 'A FAST GENERATOR FOR
C                 GAMMA-DISTRIBUTED RANDOM VARIABLES',
C                 COMPSTAT 1974, PROCEEDINGS IN
C                 COMPUTATIONAL STATISTICS, VIENNA,
C                 SEPTEMBER, 1974, PAGES 19-27.
C               --TOCHER, THE ART OF SIMULATION,
C                 1963, PAGES 24-27.
C               --HAMMERSLEY AND HANDSCOMB, MONTE CARLO METHODS,
C                 1964, PAGES 36-37.
C               --WILK, GNANADESIKAN, AND HUYETT, 'PROBABILITY
C                 PLOTS FOR THE GAMMA DISTRIBUTION',
C                 TECHNOMETRICS, 1962, PAGES 1-15.
C               --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1970, PAGES 166-206.
C               --HASTINGS AND PEACOCK, STATISTICAL
C                 DISTRIBUTIONS--A HANDBOOK FOR
C                 STUDENTS AND PRACTITIONERS, 1975,
C                 PAGES 68-73.
C               --NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY APPLIED MATHEMATICS
C                 SERIES 55, 1964, PAGE 952.
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-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1966)
C     VERSION NUMBER--82/7
C     ORIGINAL VERSION--NOVEMBER  1975.
C     UPDATED         --FEBRUARY  1976.
C     UPDATED         --JUNE      1978.
C     UPDATED         --DECEMBER  1981.
C     UPDATED         --MARCH     1982.
C     UPDATED         --MAY       1982.
C     UPDATED         --MAY       2003. REPLACE WITH CALL TO
C                                       AHRENS-DIETER CODE
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
CCCCC DIMENSION XN(2)
CCCCC DIMENSION U(2)
C
      COMMON/SGAMM/AA,AAA
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----DATA STATEMENTS-------------------------------------------------
C
CCCCC DATA ATHIRD/0.3333333/
CCCCC DATA SQRT3 /1.73205081/
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 GAMRAN 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
      ELSEIF(GAMMA.LE.0.0)THEN
        WRITE(ICOUT,15)
   15   FORMAT('***** ERROR--THE SECOND ARGUMENT TO GAMRAN IS ',
     1         'NON-POSITIVE')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)GAMMA
   46   FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7,'.')
        CALL DPWRST('XXX','BUG ')
        GOTO9000
CCCCC ELSEIF(GAMMA.LE.0.33333333)THEN
CCCCC   WRITE(ICOUT,16)
CCC16   FORMAT('***** ERROR--THE SECOND ARGUMENT TO GAMRAN ',
CCCCC1         'IS SMALLER THAN OR EQUAL TO 0.3333333')
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   WRITE(ICOUT,17)
CCC17   FORMAT('      (ALGORITHMIC RESTIRCTION)')
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   WRITE(ICOUT,46)GAMMA
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   GOTO9000
      ENDIF
C
C     GENERATE N GAMMA DISTRIBUTION RANDOM NUMBERS
C     USING GREENWOOD'S REJECTION ALGORITHM--
C     1) GENERATE A NORMAL RANDOM NUMBER;
C     2) TRANSFORM THE NORMAL VARIATE TO AN APPROXIMATE
C        GAMMA VARIATE USING THE WILSON-HILFERTY
C        APPROXIMATION (SEE THE JOHNSON AND KOTZ
C        REFERENCE, PAGE 176);
C     3) FORM THE REJECTION FUNCTION VALUE, BASED
C        ON THE PROBABILITY DENSITY FUNCTION VALUE
C        OF THE ACTUAL DISTRIBUTION OF THE PSEUDO-GAMMA
C        VARIATE, AND THE PROBABILITY DENSITY FUNCTION VALUE
C        OF A TRUE GAMMA VARIATE.
C     4) GENERATE A UNIFORM RANDOM NUMBER;
C     5) IF THE UNIFORM RANDOM NUMBER IS LESS THAN
C        THE REJECTION FUNCTION VALUE, THEN ACCEPT
C        THE PSEUDO-RANDOM NUMBER AS A GAMMA VARIATE;
C        IF THE UNIFORM RANDOM NUMBER IS LARGER THAN
C        THE REJECTION FUNCTION VALUE, THEN REJECT
C        THE PSEUDO-RANDOM NUMBER AS A GAMMA VARIATE.
C
C  MAY 2003: THIS ALGORITHM DOESN'T WORK FOR GAMMA < 1/3.
C            REPLACE WITH THE POPULAR AHRENS-DIETER CODE FOR
C            GAMMA RANDOM NUMBERS.
C
CCCCC A1=1.0/(9.0*GAMMA)
CCCCC B1=SQRT(A1)
CCCCC XN0=-SQRT3+B1
CCCCC XG0=GAMMA*(1.0-A1+B1*XN0)**3
CCCCC DO100I=1,N
CC150 CALL NORRAN(1,ISEED,XN)
CCCCC XG=GAMMA*(1.0-A1+B1*XN(1))**3
CCCCC IF(XG.LT.0.0)GOTO150
CCCCC TERM=(XG/XG0)**(GAMMA-ATHIRD)
CCCCC ARG=0.5*XN(1)*XN(1)-XG-0.5*XN0*XN0+XG0
CCCCC FUNCT=TERM*EXP(ARG)
CCCCC CALL UNIRAN(1,ISEED,U)
CCCCC IF(U(1).LE.FUNCT)GOTO170
CCCCC GOTO150
CC170 X(I)=XG
CC100 CONTINUE
C
      DO100I=1,N
        ATEMP=SGAMMA(ISEED,GAMMA)
        X(I)=ATEMP
  100 CONTINUE
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE GATHER(N,A,B,IINDEX,MAXOBV,ISUBRO,IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COLLECTS ELEMENTS FROM ARRAY B
C              BASED ON THE INDEX ELEMENTS IN ARRAY INDEX AND
C              STORES THEM CONTIGUOUSLY IN ARRAY A.
C     INPUT  ARGUMENTS--IINDEX = THE INTEGER VECTOR THAT SPECIFIES
C                                THE ELEMENTS OF B THAT WILL BE
C                                EXTRACTED.
C                       B      = A SINGLE PRECISION VECTOR FROM WHIC
C                                DATA VALUES WILL BE EXTRACTED.
C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
C                                TO BE EXTRACTED.
C     OUTPUT ARGUMENTS--A      = THE OUTPUT ARRAY THAT WILL CONTAIN
C                                N ELEMENTS.
C     OUTPUT--THE COMPUTED SINGLE PRECISION ARRAY A.
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--2008.11
C     ORIGINAL VERSION--NOVEMBER  2008.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C
      INTEGER N
      INTEGER IINDEX(*)
      REAL A(*)
      REAL B(*)
C
      CHARACTER*4 ISUBRO
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'THER')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,51)
   51   FORMAT('***** AT THE BEGINNING OF GATHER--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,52)IBUGA3,ISUBRO,N
   52   FORMAT('IBUGA3,ISUBRO,N = ',A4,2X,A4,2X,I8)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,53)N
   53   FORMAT('N = ',I8)
        CALL DPWRST('XXX','BUG ')
        IF(N.GT.0)THEN
          DO55I=1,N
            WRITE(ICOUT,56)I,IINDEX(I),B(I)
   56       FORMAT('I,IINDX(I),B(I) = ',I8,2X,I8,G15.7)
            CALL DPWRST('XXX','BUG ')
   55     CONTINUE
        ENDIF
      ENDIF
C
      DO 1010 I = 1,N
         ITEMP=IINDEX(I)
         IF(ITEMP.GE.1 .AND. ITEMP.LE.MAXOBV)THEN
           A(I) = B(ITEMP)
         ELSE
           WRITE(ICOUT,1011)
 1011      FORMAT('***** ERROR IN GATHER OPERATION--')
           CALL DPWRST('XXX','BUG ')
           WRITE(ICOUT,1013)I
 1013      FORMAT('      FOR ROW ',I8,' THE INDEX VALUE IS OUTSIDE THE')
           CALL DPWRST('XXX','BUG ')
           WRITE(ICOUT,1015)MAXOBV
 1015      FORMAT('      THE INTERVAL (1,',I10,').')
           CALL DPWRST('XXX','BUG ')
           IERROR='YES'
           GOTO9000
         ENDIF
 1010 CONTINUE
C
 9000 CONTINUE
C
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'THER')THEN
        WRITE(ICOUT,9051)
 9051   FORMAT('***** AT THE BEGINNING OF GATHER--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9053)N
 9053   FORMAT('N = ',I8)
        CALL DPWRST('XXX','BUG ')
        IF(N.GT.0)THEN
          DO9055I=1,N
            WRITE(ICOUT,9056)I,A(I)
 9056       FORMAT('I,A(I) = ',I8,2X,G15.7)
            CALL DPWRST('XXX','BUG ')
 9055     CONTINUE
        ENDIF
      ENDIF
C
      RETURN
      END
      SUBROUTINE GC1FUN (NPAR, XPAR, FVEC, IFLAG, ZDATA, M)
C
C     PURPOSE--THIS ROUTINE COMPUTES THE FUNCTIONS FOR THE
C              GAMMA MAXIMUM LIKELIHOOD EQUATIONS FOR THE CENSORING
C              CASE (FROM PP. 217-218 OF BURY).
C
C      R*XBAR/SHAT - R*GHAT + SUM[i=1 to M]
C        [Z(j)**GHAT*EXP(Z(j)/(GAMMA(GHAT) - G(Z(j),GHAT))] = 0
C
C      R*LOG(GEOMEAN/SHAT)  - N*DIGAMMA(GHAT) + SUM[i=1 to M]
C        [(GAMMA(GHAT)*DIGAMMA(GHAT) J(Z(j),GHAT))/
C        (GAMMA(GHAT) - G(Z(j),GHAT))] = 0
C
C      WHERE
C
C
C         XBAR = MEAN OF FAILURE DATA
C         GEOMEAN  = GEOMETRIC MEAN OF FAILURE DATA
C         R        = NUMBER OF FAILURES
C         M        = NUMBER OF CENSORING TIMES
C         SHAT     = FVEC(1) = CURRENT ESTIMATE OF SCALE PARAMETER
C         GHAT     = FVEC(2) = CURRENT ESTIMATE OF SHAPE PARAMETER
C         Z(j)     = jth CENSORING TIME
C         GAMMA    = GAMMA FUNCTION
C         DIGAMMA  = DIGAMMA FUNCTION
C         G(x,a)   = INCOMPLETE GAMMA FUNCTION
C         J(X,a)   = INTEGRAL[0 to x][t**(A-1)*LOG(t)*EXP(-t)]dt
C
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--GAMMA MAXIMUM LIKELIHOOD Y X
C     REFERENCE--KARL BURY, (1999). "STATISTICAL DISTRIBUTIONS IN
C                ENGINEERING", CAMBRIDGE UNIVERSITY PRESS,
C                PP. 217-218.
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 M
      DOUBLE PRECISION XPAR(*)
      DOUBLE PRECISION FVEC(*)
      REAL ZDATA(*)
C
      DOUBLE PRECISION DN
      DOUBLE PRECISION DR
      DOUBLE PRECISION DX
      DOUBLE PRECISION GHAT
      DOUBLE PRECISION SHAT
      DOUBLE PRECISION DGI
      DOUBLE PRECISION DP
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DSUM2
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
      DOUBLE PRECISION DTERM4
      DOUBLE PRECISION DTERM5
      DOUBLE PRECISION DTERM6
C
      INTEGER LIMIT
      INTEGER LENW
      PARAMETER(LIMIT=200)
      PARAMETER(LENW=4*LIMIT)
      INTEGER NEVAL
      INTEGER IER
      INTEGER LAST
      INTEGER IWORK(LIMIT)
      DOUBLE PRECISION EPSABS
      DOUBLE PRECISION EPSREL
      DOUBLE PRECISION DLOW
      DOUBLE PRECISION ABSERR
      DOUBLE PRECISION WORK(LENW)
C
      DOUBLE PRECISION XBAR
      DOUBLE PRECISION GEOMEA
      INTEGER N
      INTEGER R
      COMMON/GC1COM/XBAR,GEOMEA,N,R
C
      DOUBLE PRECISION DA
      COMMON/J1COM/DA
C
      DOUBLE PRECISION DGAMMA
      DOUBLE PRECISION DGAMI
      DOUBLE PRECISION DPSI
      DOUBLE PRECISION J1FUN
      EXTERNAL DGAMMA
      EXTERNAL DGAMI
      EXTERNAL DPSI
      EXTERNAL J1FUN
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      NPAR=2
      IFLAG=0
C
      DN=DBLE(N)
      DR=DBLE(R)
      GHAT=XPAR(1)
      SHAT=XPAR(2)
      DG=DGAMMA(GHAT)
      DP=DPSI(GHAT)
      DA=GHAT
C
      DTERM1=DR*XBAR/SHAT - DR*GHAT
      DTERM2=DR*DLOG(GEOMEA/SHAT) - DN*DP
      DSUM1=0.0D0
      DSUM2=0.0D0
C
      EPSABS=1.0D-7
      EPSREL=1.0D-7
      IER=0
      IKEY=3
      DLOW=0.0D0
C
      IF(M.GT.0)THEN
        DO100I=1,M
          DX=DBLE(ZDATA(I))/SHAT
          DGI=DGAMI(GHAT,DX)
          DTERM3=DX**GHAT*DEXP(-DX)
          DTERM6=0.0D0
          CALL DQAG(J1FUN,DLOW,DX,EPSABS,EPSREL,IKEY,DTERM6,
     1              ABSERR,NEVAL,
     1              IER,LIMIT,LENW,LAST,IWORK,WORK)
          DTERM4=DG*DP - DTERM6
          DTERM5=DG - DGI
          DSUM1=DSUM1 + DTERM3/DTERM5
          DSUM2=DSUM2 + DTERM4/DTERM5
  100   CONTINUE
      ENDIF
C
      FVEC(1) = DTERM1 + DSUM1
      FVEC(2) = DTERM2 + DSUM2
C
      RETURN
      END
      subroutine gci1(ngrp, ni, xi, obsi, conf, nrun, mean,
     1                llmt, ulmt,segci,
     1                esi, thold, emu,
     1                ierror)
c
c     Note: This routine performs a consensus means analysis
c           based on generalized confidence interval approach.
c           This is documented in:
c
c           Hari K. Iyer, C. M. Wang, and Thomas Matthew,
c           "Models and Confidence Intervals for True Values
c           in Interlaboratory Trials", Journal of the
c           American Statistical Association, Volume 99,
c           No. 468, pp. 1060-1071.
c
c           Modified for Dataplot 3/2006.
c
c           1) I/O modified to use DPWRST
c           2) Compute standard deviation of EMU as estimate of
c              standard error
c           3) Pass THOLD, EMU, ESI as arguments
c
      implicit none
c
c  parameters:
c
c    input:
c     ngrp - number of groups (labs)
c     ni   - vector of size ngrp containing the sample size of each lab
c     xi   - vector of size ngrp containing the mean of each lab
c     obsi - vector of size ngrp containing the variance of each lab
c     conf - nominal confidence coefficient, e.g., 0.95
c     nrun - number of Monte Carlo samples to be used, e.g., 10000
c
c    output:
c     mean - mean of the simulated distribution of the GPQ
c     llmt - lower confidence limit
c     ulmt - upper confidence limit
c
      integer ngrp, nrun, ni(ngrp)
      integer njunk
      double precision  obsi(ngrp), xi(ngrp)
      double precision conf, mean, llmt, ulmt
c
      integer iseed
      double precision thold(ngrp)
      real    atemp
      real    atemp2(1)
      double precision esi(ngrp)
      double precision xbar, esa, emu(nrun), sesi, zval
      double precision lbd, ubd, errabs, tmp, segci
c
      double precision zeroin
c
      integer kk
      double precision aa, ybar, cc, bb(100), yy(100)
      common /cmn1/ kk
      common /cmn2/ aa, ybar, cc, bb, yy
c
      integer j, m, ilb, iub
c
      external ff
      double precision  ff
c
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      INCLUDE 'DPCOP2.INC'
C
      iseed = 1234579
      esa=0.0d0
c
      ilb = int(real(nrun) * ((1.0d0 - conf)/2.0)) + 1
      iub = int(real(nrun) * ((1.0d0 + conf)/2.0))
c
      kk = ngrp
      errabs = 0.001d0
c
      ybar = 0.0
      do 10 m = 1, ngrp
         yy(m) = xi(m)
         ybar = ybar + xi(m)
   10 continue
      ybar = ybar/real(ngrp)
c
c  for each set of observed \bar{x}_i and S_i^2
c
      mean = 0.0d0
c
      do 20 j = 1, nrun
c
c  generate chi-square deviates to calculate
c  esi(*) = \hat{\sigma}_i^2 = (n_i - 1)*S_i^2/\chi^2
c
         njunk=1
         do 30 m = 1, ngrp
            atemp = real(abs(ni(m)) - 1)
            call chsran(njunk, atemp, iseed, atemp2)
            thold(m)=atemp2(1)
            esi(m) = (abs(ni(m)) - 1) * obsi(m)/thold(m)
            bb(m) = esi(m)/abs(ni(m))
   30    continue
         atemp = real(ngrp - 1)
         call chsran(njunk, atemp, iseed, atemp2)
         thold(1)=atemp2(1)
         cc = thold(1)
c
c  calculate the max of quadratic form, if it is less than cc
c  set esa to zero, else call zeroin (bi-section method) to
c  find the solution of esa = \sigma_a^2
c
         call maxofq
c
         ubd = 99999.9d0
         if (cc .ge. aa) then
            esa = 0.0d0
         else
            if (ff(ubd) .lt. 0.0d0) then
               lbd = 0.0d0
               ierror='NO'
               esa = zeroin(lbd, ubd, ff, errabs,ierror)
               if(ierror.eq.'YES')GOTO9000
            end if
         end if
c
c  form emu(*) = \hat{\mu}
c
         call norran(1, iseed, atemp2)
         thold(1)=atemp2(1)
         zval = thold(1)
         xbar = 0.0d0
         sesi = 0.0d0
         do 40 m = 1, ngrp
            tmp = esa + bb(m)
            sesi = sesi + 1.0d0/tmp
            xbar = xbar + xi(m)/tmp
   40    continue
         xbar = xbar/sesi
         emu(j) = xbar - zval/sqrt(sesi)
c
         mean = mean + emu(j)
c
   20 continue
c
      mean = mean/real(nrun)
c
c  sort emu(*) to find appropriate percentiles as
c  the confidence limits
c
      call ssort(emu, emu, nrun, 1)
      llmt = emu(ilb)
      ulmt = emu(iub)
      iwrite='OFF'
      ibuga3='OFF'
      call sddp(emu,nrun,iwrite,segci,ibuga3,ierror)
c
 9000 continue
      return
      end
      SUBROUTINE GCHAR(CHR,X,Y,SZ,IBUGG3,ISUBRO,IERROR)
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
C---------------------------------------------------------------------
C
      CHARACTER CHR(15)*1
C
      CHARACTER*4 IBUGG3
      CHARACTER*4 ISUBRO
      CHARACTER*4 IERROR
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'CHAR')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,1011)CHR,X,Y,SZ
 1011   FORMAT('FROM GCHAR--CHR,X,Y,SZ = ',4F10.5)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      IERROR='NO'
C
      RETURN
      END
      SUBROUTINE GDER(MEW, THETA, RL, MRL, LM, IDER, RD, PD)
C
C        ALGORITHM AS 189.4 APPL. STATIST. (1983) VOL.32, NO.2
C
C        GENERAL DERIVATIVE SUBROUTINE
C
      DOUBLE PRECISION MEW, THETA, PD(IDER), A, B, C, D
      INTEGER RL(MRL,3), LM(3), RD(2,IDER)
C
      MLM = LM(3)
      KK = IDER-1
      DO 5 I = 1,IDER
        PD(I) = 0.0D0
    5 CONTINUE
      DO 45 I = 1,MLM
        C = DBLE(I-1)
        A = C*THETA
        DO 40 J = 1,3
          IF(I.GT.LM(J)) GOTO 40
          GOTO (10,15,20) J
   10     D = MEW+A
          GOTO 25
   15     D = 1.0D0-MEW+A
          GOTO 25
   20     D = 1.0D0+A
   25     B = DBLE(RL(I,J))/D**KK
          IF(J.EQ.3) GOTO 35
          DO 30 K = 1,IDER
            PD(K) = PD(K)+DBLE(RD(J,K))*B
            B = B*C
   30     CONTINUE
          GOTO 40
   35     D = -DBLE(RD(1,1))*B*C**KK
          PD(IDER) = PD(IDER)+D
   40   CONTINUE
   45 CONTINUE
      RETURN
      END
      SUBROUTINE GEECDF(X,GAMMA,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE GEOMETRIC EXTREME EXPONENTIAL
C              DISTRIBUTION WITH SINGLE PRECISION
C              TAIL LENGTH PARAMETER = GAMMA.
C              THE GEOMETRIC EXTREME EXPONENTIAL DISTRIBUTION USED
C              HEREIN IS DEFINED FOR ALL X >= 0
C              AND HAS THE CUMULATIVE DISTRIBUTION FUNCTION
C              F(X) = 1 - GAMMA/[EXP(X) + GAMMA - 1]      GAMMA > 0
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
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 GEOMETRIC EXTREME
C             EXPONENTIAL DISTRIBUTION
C             WITH TAIL LENGTH 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, LOG.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--"CAN DATA RECOGNOZE ITS PARENT DISTRIBUTION?",
C                 MARSHALL, MEZA, OLKIN, JOURNAL OF COMPUTATIONAL
C                 AND GRAPHICAL STATISTICS, SEPTEMBER, 2001,
C                 PP. 555-580.
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--2001.11
C     ORIGINAL VERSION--NOVEMBER  2001.
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DGAMMA
      DOUBLE PRECISION DCDF
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      CDF=0.0
      IF(X.LT.0.0)THEN
CCCCC   WRITE(ICOUT,5)
CCCC5   FORMAT('***** ERROR--THE FIRST ARGUMENT TO GEECDF IS NEGATIVE.')
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   WRITE(ICOUT,46)X
CCCCC   CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(GAMMA.LE.0.0)THEN
        WRITE(ICOUT,15)
   15   FORMAT('***** ERROR--THE SECOND ARGUMENT TO GEECDF IS ',
     1         'NON-POSITIVE')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)GAMMA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
C
      DGAMMA=DBLE(GAMMA)
      DX=DBLE(X)
      DCDF=1.0D0 - DGAMMA/(EXP(DX) + DGAMMA - 1.0D0)
      CDF=REAL(DCDF)
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE GEECHA(X,GAMMA,HAZ)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE HAZARD
C              FUNCTION VALUE FOR THE GEOMETRIC EXTREME EXPONENTIAL
C              DISTRIBUTION WITH SINGLE PRECISION
C              TAIL LENGTH PARAMETER = GAMMA.
C              THE GEOMETRIC EXTREME EXPONENTIAL DISTRIBUTION USED
C              HEREIN IS DEFINED FOR ALL X >= 0
C              AND HAS THE CUMULATIVE HAZARD FUNCTION
C              H(X) = -LOG(1-GEECDF(X)),    GAMMA > 0
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE CUMULATIVE HAZARD
C                                FUNCTION IS TO BE EVALUATED.
C                     --GAMMA  = THE SHAPE PARAMETER
C                                GAMMA 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 PDF FOR THE GEOMETRIC EXTREME
C             EXPONENTIAL DISTRIBUTION
C             WITH TAIL LENGTH 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, LOG.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--"CAN DATA RECOGNOZE ITS PARENT DISTRIBUTION?",
C                 MARSHALL, MEZA, OLKIN, JOURNAL OF COMPUTATIONAL
C                 AND GRAPHICAL STATISTICS, SEPTEMBER, 2001,
C                 PP. 555-580.
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--2001.11
C     ORIGINAL VERSION--NOVEMBER  2001.
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DGAMMA
      DOUBLE PRECISION DCDF
      DOUBLE PRECISION DHAZ
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      HAZ=0.0
      IF(X.LT.0.0)THEN
        WRITE(ICOUT,5)
    5   FORMAT('***** ERROR--THE FIRST ARGUMENT TO GEECHA IS NEGATIVE')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(GAMMA.LE.0.0)THEN
        WRITE(ICOUT,15)
   15   FORMAT('***** ERROR--THE SECOND ARGUMENT TO GEECHA IS ',
     1         'NON-POSITIVE')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)GAMMA
   46   FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
        CALL DPWRST('XXX','BUG ')
        HAZ=0.0
        GOTO9000
      ENDIF
C
      DGAMMA=DBLE(GAMMA)
      DX=DBLE(X)
      DCDF=DGAMMA/(EXP(DX) + DGAMMA - 1.0D0)
      DHAZ=-LOG(DCDF)
      HAZ=REAL(DHAZ)
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE GEEFUN (N, X, FVEC, IFLAG, XDATA, NOBS)
C
C     PURPOSE--THIS ROUTINE COMPUTES THE FUNCTIONS FOR THE
C              GENERALIZED EXTREME EXPONENTIAL MAXIMUM LIKELIHOOD
C              EQUATIONS.
C
C              N/G - 2*SUM[i=1 to N][EXP(-L*X(i)/(1-(1-G)*EXP(-L*X(i)))]
C
C              N/L - SUM[i=1 to n][X(i)] -
C                    2*SUM[i=1 to N][(1-G)*X(i)*EXP(-L*X(i))/
C                    (1 - (1-G)*EXP(-L*X(i)))]
C
C              WITH G AND L DENOTING THE SHAPE PARAMETER GAMMA AND
C              SCALE PARAMETER LAMBDA RESPECTIVELY.  NOTE THAT L
C              IS ACTUALLY (1/SCALE).
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--GENERALIZED EXTREME EXPONENTIAL MAXIMUM LIKELIHOOD Y
C     REFERENCE--"CAN DATA RECOGNIZE ITS PARENT DISTRIBUTION?",
C                MARSHALL, MEZA, AND OLKIN, JOURNAL OF COMPUTATIONAL
C                AND GRAPHICAL STATISTICS, SEPTEMBER, 2001,
C                PP. 555-580.
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/3
C     ORIGINAL VERSION--MARCH     2004.
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION X(*)
      DOUBLE PRECISION FVEC(*)
      REAL XDATA(*)
C
      DOUBLE PRECISION DN
      DOUBLE PRECISION DX
      DOUBLE PRECISION DG
      DOUBLE PRECISION DGC
      DOUBLE PRECISION DL
      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
      DG=X(1)
      DGC=1.0D0-DG
      DL=X(2)
      DN=DBLE(NOBS)
C
      DSUM1=0.0D0
      DSUM2=0.0D0
      DSUM3=0.0D0
C
      DO200I=1,NOBS
        DX=DBLE(XDATA(I))
        DTERM1=DEXP(-DL*DX)
        DTERM2=1.0D0 - DGC*DEXP(-DL*DX)
        DSUM1=DSUM1 + DTERM1/DTERM2
        DTERM1=DGC*DX*DEXP(-DL*DX)
        DTERM2=1.0D0 - DGC*DEXP(-DL*DX)
        DSUM2=DSUM2 + DTERM1/DTERM2
        DSUM3=DSUM3 + DX
  200 CONTINUE
C
      FVEC(1)=(DN/DG) - 2.0D0*DSUM1
      FVEC(2)=(DN/DL) - DSUM3 - 2.0D0*DSUM2
C
      RETURN
      END
      SUBROUTINE GEEML1(Y,N,MAXNXT,
     1                  TEMP1,TEMP2,DISPAR,DTEMP1,
     1                  XMEAN,XSD,XVAR,XMIN,XMAX,
     1                  SCALSV,SHAPSV,SCALML,SHAPML,
     1                  ISUBRO,IBUGA3,IERROR)
C
C     PURPOSE--THIS ROUTINE COMPUTES THE MAXIMUM LIKELIHOOD ESTIMATES
C              FOR THE 2-PARAMETER GEOMETRIC EXTREME EXPONENTIAL
C              DISTRIBUTION FOR THE RAW DATA CASE (I.E., NO CENSORING
C              AND NO GROUPING).  THIS ROUTINE RETURNS ONLY THE POINT
C              ESTIMATES (CONFIDENCE INTERVALS WILL BE COMPUTED IN A
C              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 (DPMLGX WILL GENERATE THE OUTPUT
C              FOR THE GEOMETRIC EXTREME EXPONENTIAL MLE COMMAND).
C
C              THE MLE ESTIMATES ARE THE SOLUTION TO THE FOLLOWING
C              TWO SIMULTANEOUS NON-LINEAR EQUATIONS:
C
C              N/G - 2*SUM[i=1 to N][EXP(-L*X(i)/(1-(1-G)*EXP(-L*X(i)))]
C
C              N/L - SUM[i=1 to n][X(i)] -
C                    2*SUM[i=1 to N][(1-G)*X(i)*EXP(-L*X(i))/
C                    (1 - (1-G)*EXP(-L*X(i)))]
C
C              WITH G AND L DENOTING THE SHAPE PARAMETER GAMMA AND
C              SCALE PARAMETER LAMBDA RESPECTIVELY.  NOTE THAT L
C              IS ACTUALLY (1/SCALE).
C
C     REFERENCE--"CAN DATA RECOGNIZE ITS PARENT DISTRIBUTION?",
C                MARSHALL, MEZA, AND OLKIN, JOURNAL OF COMPUTATIONAL
C                AND GRAPHICAL STATISTICS, SEPTEMBER, 2001,
C                PP. 555-580.
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 DPMLE1)
C     UPDATED         --FEBRUARY  2010. LAMBDA IS ACTUALLY (1/SCALE)
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DIMENSION Y(*)
      DIMENSION TEMP1(*)
      DIMENSION TEMP2(*)
      DIMENSION DISPAR(*)
      DOUBLE PRECISION DTEMP1(*)
C
      DOUBLE PRECISION TOL
      DOUBLE PRECISION XPAR(2)
      DOUBLE PRECISION FVEC(2)
      DIMENSION DISPA2(1)
C
      INTEGER IPPCAP(2)
C
      EXTERNAL GEEFUN
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
      CHARACTER*4 IADEDF
      CHARACTER*4 IGEPDF
      CHARACTER*4 IMAKDF
      CHARACTER*4 IBEIDF
      CHARACTER*4 ILGADF
      CHARACTER*4 ISKNDF
      CHARACTER*4 IGLDDF
      CHARACTER*4 IBGEDF
      CHARACTER*4 IGETDF
      CHARACTER*4 ICONDF
      CHARACTER*4 IGOMDF
      CHARACTER*4 IKATDF
      CHARACTER*4 IGIGDF
      CHARACTER*4 IGEODF
      CHARACTER*4 ICASPL
      CHARACTER*4 ICASP2
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='GEEM'
      ISUBN2='L1  '
      IERROR='NO'
C
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'EML1')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,51)
   51   FORMAT('**** AT THE BEGINNING OF GEEML1--')
        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 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      ISTEPN='1'
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'EML1')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
C               *****************************************************
C               **  STEP 2--                                       **
C               **  CARRY OUT CALCULATIONS                         **
C               **  FOR GEOMETRIC EXTREME EXPONENTIAL MLE ESTIMATE **
C               *****************************************************
C
      ISTEPN='2'
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'EML1')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IDIST='GEOMETRIC EXTREME EXPONENTIAL'
C
      IFLAG=2
      CALL SUMRAW(Y,N,IDIST,IFLAG,
     1            XMEAN,XVAR,XSD,XMIN,XMAX,
     1            ISUBRO,IBUGA3,IERROR)
C
      SHAPML=CPUMIN
      SCALML=CPUMIN
      IF(IERROR.EQ.'YES')GOTO9000
C
      IF(SHAPSV.GT.0.0 .AND. SCALSV.GT.0.0)THEN
        XPAR(1)=DBLE(SHAPSV)
        XPAR(2)=DBLE(1.0/SCALSV)
      ELSE
C
C       IF NO STARTING VALUES SPECIFIED, COMPUTE STARTING
C       VALUES BASED ON PPCC METHOD.
C
        CALL UNIMED(N,TEMP1)
        CALL SORT(Y,N,Y)
        ICASP2='GEEX'
        ICASPL='PPCC'
        IPPCAP(1)=100
        IPPCAP(2)=1
C
C       OBTAIN LOWER/UPPER LIMITS FOR SHAPE PARAMETER
C
        CALL EXTPA2(ICASP2,IDIST,A,B,
     1              SHAP11,SHAP12,SHAP21,SHAP22,
     1              SHAPE1,SHAPE2,SHAPE3,SHAPE4,SHAPE5,
     1              IADEDF,IGEPDF,IMAKDF,IBEIDF,
     1              ILGADF,ISKNDF,IGLDDF,IBGEDF,
     1              IGETDF,ICONDF,IGOMDF,IKATDF,
     1              IGIGDF,IGEODF,
     1              ISUBRO,IBUGA3,IERROR)
C
C       CREATE ARRAY FOR THE CANDIDATE VALUES OF SHAPE PARAMETER
C
        NUMSHA=1
        CALL DPPPC7(ICASPL,ICASP2,IPPCAP,
     1              SHAP11,SHAP12,SHAP21,SHAP22,
     1              SHAPE1,SHAPE2,SHAPE3,SHAPE4,
     1              XMIN,XMAX,A,B,
     1              DISPAR,DISPA2,NUMDIS,NUMSHA,
     1              IADEDF,IGEPDF,IMAKDF,IBEIDF,
     1              ILGADF,ISKNDF,IGLDDF,IBGEDF,IGETDF,
     1              ICONDF,IGOMDF,IKATDF,IGIGDF,IGEODF,
     1              IBUGA3,ISUBRO,IERROR)
C
        CORRMX=-1.0
        IWRITE='OFF'
        DO1010IDIS=1,NUMDIS
          SHAPE=DISPAR(IDIS)
          DO1020I=1,N
            CALL GEEPPF(TEMP1(I),SHAPE,TEMP2(I))
 1020     CONTINUE
          CALL CORR(Y,TEMP2,N,IWRITE,CC,IBUGA3,IERROR)
          IF(CC.GT.CORRMX)THEN
            SHAPE1=SHAPE
            CALL LINFI2(Y,TEMP2,N,PPA0,PPA1,ISUBRO,IBUGA3,IERROR)
            CORRMX=CC
          ENDIF
 1010   CONTINUE
        XPAR(1)=DBLE(SHAPE1)
        XPAR(2)=DBLE(1.0/PPA1)
      ENDIF
C
      IOPT=2
      TOL=1.0D-6
      NVAR=2
      NPRINT=-1
      INFO=0
      LWA=MAXNXT
      CALL DNSQE(GEEFUN,JAC,IOPT,NVAR,XPAR,FVEC,TOL,NPRINT,INFO,
     1           DTEMP1,MAXNXT,Y,N)
C
      SHAPML=REAL(XPAR(1))
      SCALML=1.0/REAL(XPAR(2))
      IF(SHAPML.LE.0.0)IERROR='YES'
      IF(SCALML.LE.0.0)IERROR='YES'
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'EML1')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9011)
 9011   FORMAT('**** AT THE END OF GEEML1--')
        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)SHAPSV,SCALSV,SHAPML,SCALML
 9017   FORMAT('SHAPSV,SCALSV,SHAPML,SCALML =  ',4G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9019)XPAR(1),XPAR(2)
 9019   FORMAT('XPAR(1),XPAR(2) =  ',2G15.7)
        CALL DPWRST('XXX','WRIT')
      ENDIF
C
      RETURN
      END
      SUBROUTINE GEEPDF(X,GAMMA,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE GEOMETRIC EXTREME EXPONENTIAL
C              DISTRIBUTION WITH SINGLE PRECISION
C              TAIL LENGTH PARAMETER = GAMMA.
C              THE GEOMETRIC EXTREME EXPONENTIAL DISTRIBUTION USED
C              HEREIN IS DEFINED FOR ALL X >= 0
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C              F(X) = GAMMA*EXP(X)/[(EXP(X)+GAMMA-1)**2]  GAMMA > 0
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 GEOMETRIC EXTREME
C             EXPONENTIAL DISTRIBUTION
C             WITH TAIL LENGTH 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, LOG.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--"CAN DATA RECOGNOZE ITS PARENT DISTRIBUTION?",
C                 MARSHALL, MEZA, OLKIN, JOURNAL OF COMPUTATIONAL
C                 AND GRAPHICAL STATISTICS, SEPTEMBER, 2001,
C                 PP. 555-580.
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--2001.11
C     ORIGINAL VERSION--NOVEMBER  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(X.LT.0.0)THEN
        WRITE(ICOUT,5)
    5   FORMAT('***** FATAL ERROR--THE FIRST INPUT ARGUMENT TO THE ',
     1         'GEEPDF SUBROUTINE IS NEGATIVE')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9000
      ENDIF
C
      IF(GAMMA.LE.0.0)THEN
        WRITE(ICOUT,15)
   15   FORMAT('***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE ',
     1         'GEEPDF 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
      DGAMMA=DBLE(GAMMA)
      DX=DBLE(X)
      DPDF=LOG(DGAMMA) + DX - 2.0D0*LOG(EXP(DX)+DGAMMA-1.0D0)
      IF(DPDF.LT.-36.0D0)THEN
        PDF=0.0
      ELSEIF(DPDF.GT.36.0D0)THEN
        WRITE(ICOUT,25)
   25   FORMAT('***** FATAL ERROR--GEEPDF ROUTINE OVERFLOWS FOR')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,26)X,GAMMA
   26   FORMAT('      X = ',E15.7,'  GAMMA = ',E15.7)
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
      ELSE
        DPDF=EXP(DPDF)
        PDF=REAL(DPDF)
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE GEEHAZ(X,GAMMA,HAZ)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE HAZARD
C              FUNCTION VALUE FOR THE GEOMETRIC EXTREME EXPONENTIAL
C              DISTRIBUTION WITH SINGLE PRECISION
C              TAIL LENGTH PARAMETER = GAMMA.
C              THE GEOMETRIC EXTREME EXPONENTIAL DISTRIBUTION USED
C              HEREIN IS DEFINED FOR ALL X >= 0
C              AND HAS THE HAZARD FUNCTION
C              H(X) = GEEPDF(X)/(1-GEECDF(X)),    GAMMA > 0
C                   = EXP(X)/[EXP(X)+GAMMA-1)]    GAMMA > 0
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE HAZARD
C                                FUNCTION IS TO BE EVALUATED.
C                     --GAMMA  = THE SHAPE PARAMETER
C                                GAMMA 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 GEOMETRIC EXTREME
C             EXPONENTIAL DISTRIBUTION
C             WITH TAIL LENGTH 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, LOG.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--"CAN DATA RECOGNOZE ITS PARENT DISTRIBUTION?",
C                 MARSHALL, MEZA, OLKIN, JOURNAL OF COMPUTATIONAL
C                 AND GRAPHICAL STATISTICS, SEPTEMBER, 2001,
C                 PP. 555-580.
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--2001.11
C     ORIGINAL VERSION--NOVEMBER  2001.
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DGAMMA
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DHAZ
C
C-----COMMON---------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      HAZ=0.0
      IF(X.LT.0.0)THEN
        WRITE(ICOUT,5)
    5   FORMAT('***** ERROR--THE FIRST ARGUMENT TO GEEHAZ IS NEGATIVE')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(GAMMA.LE.0.0)THEN
        WRITE(ICOUT,15)
   15   FORMAT('***** ERROR--THE SECOND ARGUMENT TO GEEHAZ IS ',
     1         'NON-POSITIVE')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)GAMMA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
C
      DGAMMA=DBLE(GAMMA)
      DX=DBLE(X)
      DTERM1=EXP(DX)
      DTERM2=DTERM1+DGAMMA-1.0D0
      IF(DTERM2.NE.0.0D0)THEN
        DHAZ=DTERM1/DTERM2
        HAZ=REAL(DHAZ)
      ELSE
        HAZ=0.0
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE GEEPPF(P,GAMMA,PPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE GEOMETRIC EXTREME EXPONENTIAL
C              DISTRIBUTION WITH SINGLE PRECISION
C              TAIL LENGTH PARAMETER = GAMMA.
C              THE GEOMETRIC EXTREME EXPONENTIAL DISTRIBUTION USED
C              HEREIN IS DEFINED FOR ALL 0 <= P < 1.
C              AND HAS THE PERCENT POINT FUNCTION
C              G(P) = LOG[GAMMA/(1-P) + 1 - GAMMA],    GAMMA > 0
C     INPUT  ARGUMENTS--P      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE PERCENT POINT
C                                FUNCTION IS TO BE EVALUATED.
C                     --GAMMA  = THE SHAPE 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
C             FUNCTION VALUE PPF FOR THE GEOMETRIC EXTREME
C             EXPONENTIAL DISTRIBUTION
C             WITH TAIL LENGTH 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--LOG.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--"CAN DATA RECOGNOZE ITS PARENT DISTRIBUTION?",
C                 MARSHALL, MEZA, OLKIN, JOURNAL OF COMPUTATIONAL
C                 AND GRAPHICAL STATISTICS, SEPTEMBER, 2001,
C                 PP. 555-580.
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--2001.11
C     ORIGINAL VERSION--NOVEMBER  2001.
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
      IF(P.LT.0.0.OR.P.GE.1.0)THEN
        WRITE(ICOUT,5)
    5   FORMAT('***** ERROR--THE FIRST ARGUMENT TO GEEPPF IS OUTSIDE ',
     1         'THE ALLOWABLE (0,1] INTERVAL.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)P
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(GAMMA.LE.0.0)THEN
        WRITE(ICOUT,15)
   15   FORMAT('***** ERROR--THE SECOND ARGUMENT TO GEEPPF IS ',
     1         'NON-POSITIVE')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)GAMMA
   46   FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
      DGAMMA=DBLE(GAMMA)
      DP=DBLE(P)
      DPPF=LOG(DGAMMA/(1.0D0-DP) + 1.0D0 - DGAMMA)
      PPF=REAL(DPPF)
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE GEERAN(N,GAMMA,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE GEOMETRIC EXTREME EXPONENTIAL 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 GEOMETRIC EXTREME EXPONENTIAL 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--"CAN DATA RECOGNOZE ITS PARENT DISTRIBUTION?",
C                 MARSHALL, MEZA, OLKIN, JOURNAL OF COMPUTATIONAL
C                 AND GRAPHICAL STATISTICS, SEPTEMBER, 2001,
C                 PP. 555-580.
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--2001.11
C     ORIGINAL VERSION--NOVEMBER  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
      ELSEIF(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 FIRST ARGUMENT TO GEERAN IS ',
     1       'NON-POSITIVE')
   15 FORMAT('***** ERROR--THE SECOND ARGUMENT TO GEERAN IS ',
     1       '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 GEOMETRIC EXTREME EXPONENTIAL DISTRIBUTION RANDOM
C     NUMBERS USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD.
C
      DO100I=1,N
        CALL GEEPPF(X(I),GAMMA,XTEMP)
        X(I)=XTEMP
  100 CONTINUE
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE GENARI(Y1,Y2,Y3,Y4,N1,N3,IACASE,IWRITE,
     1                  Y5,Y6,N5,N6,SCAL3,ITYP3,
     1                  IBUGA3,ISUBRO,IERROR)
C
C     PURPOSE--CARRY OUT (DEX) GENERATOR ARITHMETIC OPERATIONS
C              OF THE REAL DATA IN Y1 AND Y3.
C
C     OPERATIONS--ADDITION
C                 SUBTRACTION
C                 MULTIPLICATION
C
C     INPUT  ARGUMENTS--Y1 (REAL PART)       Y2 (IMAGINARY PART)
C                     --Y3 (REAL PART)       Y4 (IMAGINARY PART)
C     OUTPUT ARGUMENTS--Y5 (REAL PART)       Y6 (IMAGINARY PART)
C
C     NOTE--IT IS NOT PERMISSIBLE TO HAVE THE OUTPUT VECTORS Y5(.) AND Y6(.)
C           BEING IDENTICAL TO THE INPUT VECTORS Y1(.) AND Y2(.), OR
C           Y3(.) AND Y4(.).
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-921-3651
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/12
C     ORIGINAL VERSION--DECEMBER  1989.
C     UPDATED         --JUNE      1990. TEMPORARY ARRAYS TO GARBAGE
C                                       COMMON
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
      DIMENSION Y1(*)
      DIMENSION Y2(*)
      DIMENSION Y3(*)
      DIMENSION Y4(*)
      DIMENSION Y5(*)
      DIMENSION Y6(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='GENA'
      ISUBN2='RI  '
      IERROR='NO'
C
      SCAL3=(-999.0)
      ITYP3='VECT'
C
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'NARI')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,51)
   51   FORMAT('***** AT THE BEGINNING OF GENARI--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,52)IBUGA3,ISUBRO,IACASE,IWRITE
   52   FORMAT('IBUGA3,ISUBRO,IACASE,IWRITE = ',3(A4,2X),A4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,53)N1,N3
   53   FORMAT('N1,N3 = ',2I8)
        CALL DPWRST('XXX','BUG ')
        DO55I=1,N1
          WRITE(ICOUT,56)I,Y1(I),Y2(I)
   56     FORMAT('I,Y1(I),Y2(I) = ',I8,2G15.7)
          CALL DPWRST('XXX','BUG ')
   55   CONTINUE
        DO65I=1,N3
          WRITE(ICOUT,66)I,Y3(I),Y4(I)
   66     FORMAT('I,Y3(I),Y4(I) = ',I8,2G15.7)
          CALL DPWRST('XXX','BUG ')
   65   CONTINUE
      ENDIF
C
C               **************************************************
C               **  CARRY OUT (DEX) GENERATOR ARITHMETIC OPERATIONS  **
C               **************************************************
C
C               ********************************************
C               **  STEP 11--                             **
C               **  CHECK NUMBER OF INPUT OBSERVATIONS.   **
C               ********************************************
C
      IF(N1.LT.1)GOTO1100
      IF(N3.LT.1)GOTO1100
      GOTO1190
C
 1100 CONTINUE
      IERROR='YES'
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1151)
 1151 FORMAT('***** ERROR IN GENERATOR ARITHMETIC--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1152)
 1152 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS IN THE VARIABLE ',
     1       'FOR WHICH')
      CALL DPWRST('XXX','BUG ')
      IF(IACASE.EQ.'GEAD')THEN
        WRITE(ICOUT,1161)
 1161   FORMAT('      THE (DEX) GENERATOR ADDITION IS TO BE COMPTED')
      ELSEIF(IACASE.EQ.'GESU')THEN
        WRITE(ICOUT,1162)
 1162   FORMAT('      THE (DEX) GENERATOR SUBTRACTION IS TO BE ',
     1         'COMPUTED')
      ELSEIF(IACASE.EQ.'GEMU')THEN
        WRITE(ICOUT,1163)
 1163   FORMAT('      THE (DEX) GENERATOR MULTIPLICATION IS TO BE ',
     1         'COMPUTED')
      ENDIF
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1181)
 1181 FORMAT('      MUST BE 1 OR LARGER.  SUCH WAS NOT THE CASE HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1183)N1,N3
 1183 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS HERE = ',2I8,'.')
      CALL DPWRST('XXX','BUG ')
      GOTO9000
C
 1190 CONTINUE
C
C               *********************************
C               **  STEP 12--                  **
C               **  BRANCH TO THE PROPER CASE  **
C               *********************************
C
      IF(IACASE.EQ.'GEAD')THEN
        GOTO2300
      ELSEIF(IACASE.EQ.'GESU')THEN
        GOTO2300
      ELSEIF(IACASE.EQ.'GEMU')THEN
        GOTO2300
      ELSE
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,1211)
 1211   FORMAT('***** INTERNAL ERROR IN GENARI--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,1212)
 1212   FORMAT('      IACASE NOT EQUAL TO GEAD, GESU, OR GEMU')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,1215)
 1215   FORMAT('      IACASE = ',A4)
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        GOTO9000
      ENDIF
C
 2300 CONTINUE
      N5TEMP=0
      L=0
C
      DO2310J=1,N1
        Y1J=Y1(J)
        DO2320K=1,N3
          IF(Y3(K).EQ.Y1J)GOTO2310
 2320   CONTINUE
        L=L+1
        Y5(L)=Y1J
 2310 CONTINUE
C
      DO2330J=1,N3
        Y3J=Y3(J)
        DO2340K=1,N1
          IF(Y1(K).EQ.Y3J)GOTO2330
 2340   CONTINUE
        L=L+1
        Y5(L)=Y3J
 2330 CONTINUE
C
      N5TEMP=L
C
      IF(N5TEMP.LE.0)GOTO2359
      DO2350J=1,N5TEMP
        JP1=J+1
        IF(JP1.GT.N5TEMP)GOTO2359
        DO2360K=JP1,N5TEMP
          IF(Y5(K).GT.Y5(J))GOTO2360
          HOLD=Y5(J)
          Y5(J)=Y5(K)
          Y5(K)=HOLD
 2360   CONTINUE
 2350 CONTINUE
 2359 CONTINUE
C
      ITYP3='VECT'
      N5=N5TEMP
      N6=N5
      GOTO9000
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
C
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'NARI')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END       OF GENARI--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9017)IERROR,N1,N3,N5,N6
 9017   FORMAT('IERROR,N1,N3,N5,N6 = ',A4,2X,4I8)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9018)SCAL3,ITYP3
 9018   FORMAT('SCAL3,ITYP3 = ',G15.7,2X,A4)
        CALL DPWRST('XXX','BUG ')
        IF(ITYP3.NE.'SCAL')THEN
          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),Y4(I)
 9032       FORMAT('I,Y3(I),Y4(I) = ',I8,2E13.5)
            CALL DPWRST('XXX','BUG ')
 9031     CONTINUE
          DO9041I=1,N5
            WRITE(ICOUT,9042)I,Y5(I),Y6(I)
 9042       FORMAT('I,Y5(I),Y6(I) = ',I8,2G15.7)
            CALL DPWRST('XXX','BUG ')
 9041     CONTINUE
        ENDIF
      ENDIF
C
      RETURN
      END
      SUBROUTINE GEOCDF(X,P,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE AT THE DOUBLE PRECISION VALUE X FOR THE
C              GEOMETRIC DISTRIBUTION WITH DOUBLE PRECISION 'BERNOULLI
C              PROBABILITY' PARAMETER = P.  THE GEOMETRIC DISTRIBUTION
C              USED HEREIN HAS MEAN = (1-P)/P AND STANDARD DEVIATION
C              = SQRT((1-P)/(P*P))).  THIS DISTRIBUTION IS DEFINED FOR
C              ALL NON-NEGATIVE INTEGER X--X = 0, 1, 2, ... .  THIS
C              DISTRIBUTION HAS THE PROBABILITY MASS FUNCTION
C
C                 p(X;P) = P * (1-P)**X.
C
C              THE GEOMETRIC DISTRIBUTION IS THE DISTRIBUTION OF THE
C              NUMBER OF FAILURES BEFORE OBTAINING 1 SUCCESS IN AN
C              INDEFINITE SEQUENCE OF BERNOULLI (0,1) TRIALS WHERE THE
C              PROBABILITY OF SUCCESS IN A SINGLE TRIAL = P.
C     INPUT  ARGUMENTS--X      = THE DOUBLE PRECISION VALUE AT WHICH
C                                THE CUMULATIVE DISTRIBUTION FUNCTION
C                                IS TO BE EVALUATED.  X SHOULD BE
C                                NON-NEGATIVE AND INTEGRAL-VALUED.
C                     --P      = THE DOUBLE PRECISION VALUE OF THE
C                                'BERNOULLI PROBABILITY' PARAMETER FOR
C                                THE GEOMETRIC DISTRIBUTION.  P SHOULD
C                                BE BETWEEN 0.0 (EXCLUSIVELY) AND
C                                1.0 (INCLUSIVELY).
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 GEOMETRIC DISTRIBUTION WITH
C             'BERNOULLI PROBABILITY' PARAMETER = P.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE NON-NEGATIVE AND INTEGRAL-VALUED.
C                 --P SHOULD BE BETWEEN 0.0 (EXCLUSIVELY)
C                   AND 1.0 (EXCLUSIVELY).
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN.
C     REFERENCES--FELLER, AN INTRODUCTION TO PROBABILITY
C                 THEORY AND ITS APPLICATIONS, VOLUME 1,
C                 EDITION 2, 1957, PAGES 155-157, 210.
C               --NATIONAL BUREAU OF STANDARDS APPLIED MATHEMATICS
C                 SERIES 55, 1964, PAGE 929.
C               --CATHERINE LOADER (2000), "FAST AND ACCURATE COMPUTATION
C                 OF BINOMIAL PROBABILITIES", BELL LABS?
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         --MARCH     2009.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      EXTERNAL DLNREL
C
      INCLUDE 'DPCOP2.INC'
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      CDF=0.0D0
      IF(P.LE.0.0D0 .OR. P.GT.1.0D0)THEN
        WRITE(ICOUT,11)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)P
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(X.LT.0.0D0)THEN
        WRITE(ICOUT,3)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
    3 FORMAT('***** WARNING--THE FIRST ARGUMENT TO GEOPDF IS NEGATIVE')
   11 FORMAT('***** ERROR--THE SECOND ARGUMENT TO GEOPDF IS OUTSIDE ',
     1       'THE ALLOWABLE (0,1) INTERVAL')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
C
C-----START POINT-----------------------------------------------------
C
      INTX=INT(X+0.00001D0)
      DX=DBLE(INTX)
      IF(P.EQ.1.0D0)THEN
        CDF=1.0D0
      ELSE
        DTERM1=DLNREL(-P)*(DX+1.0D0)
        CDF=-EXPM1(DTERM1)
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE GE2CDF(X,P,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE AT THE SINGLE PRECISION VALUE X
C              FOR THE GEOMETRIC DISTRIBUTION
C              WITH SINGLE PRECISION
C              'BERNOULLI PROBABILITY' PARAMETER = P.
C              THIS USES AN ALTERNATE DEFINITION THAN GEOPDF
C              (THE VERSION HERE IS USED IN THE DIGITAL LIBRARY OF
C              MATHEMATICAL FUNCTIONS).
C              THE GEOMETRIC DISTRIBUTION USED HEREIN
C              HEREIN HAS MEAN = 1/P
C              AND STANDARD DEVIATION = SQRT((1-P)/(P*P))).
C              THIS DISTRIBUTION IS DEFINED FOR
C              ALL POSITIVE INTEGER X--X = 1, 2, ... .
C              THIS DISTRIBUTION HAS THE PROBABILITY FUNCTION
C              F(X) = P * (1-P)**X.
C              THE GEOMETRIC DISTRIBUTION IS THE
C              DISTRIBUTION OF THE NUMBER OF TRIALS UP TO AND
C              INCLUDING THE FIRST SUCCESS IN AN
C              INDEFINITE SEQUENCE OF BERNOULLI (0,1)
C              TRIALS WHERE THE PROBABILITY OF SUCCESS
C              IN A SINGLE TRIAL = P.
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 AND
C                                INTEGRAL-VALUED.
C                     --P      = THE SINGLE PRECISION VALUE
C                                OF THE 'BERNOULLI PROBABILITY'
C                                PARAMETER FOR THE GEOMETRIC
C                                DISTRIBUTION.
C                                P SHOULD BE BETWEEN
C                                0.0 (EXCLUSIVELY) AND
C                                1.0 (EXCLUSIVELY).
C     OUTPUT ARGUMENTS--CDF    = THE SINGLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE CDF
C             FOR THE GEOMETRIC DISTRIBUTION
C             WITH 'BERNOULLI PROBABILITY' PARAMETER = P.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE NON-NEGATIVE AND INTEGRAL-VALUED.
C                 --P SHOULD BE BETWEEN 0.0 (EXCLUSIVELY)
C                   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     COMMENT--NOTE THAT EVEN THOUGH THE INPUT
C              TO THIS CUMULATIVE
C              DISTRIBUTION FUNCTION SUBROUTINE
C              FOR THIS DISCRETE DISTRIBUTION
C              SHOULD (UNDER NORMAL CIRCUMSTANCES) BE A
C              DISCRETE INTEGER VALUE,
C              THE INPUT VARIABLE X IS SINGLE
C              PRECISION IN MODE.
C              X HAS BEEN SPECIFIED AS SINGLE
C              PRECISION SO AS TO CONFORM WITH THE DATAPAC
C              CONVENTION THAT ALL INPUT ****DATA****
C              (AS OPPOSED TO SAMPLE SIZE, FOR EXAMPLE)
C              VARIABLES TO 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--FELLER, AN INTRODUCTION TO PROBABILITY
C                 THEORY AND ITS APPLICATIONS, VOLUME 1,
C                 EDITION 2, 1957, PAGES 155-157, 210.
C               --NATIONAL BUREAU OF STANDARDS APPLIED MATHEMATICS
C                 SERIES 55, 1964, PAGE 929.
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     ORIGINAL VERSION--MARCH     2004.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C
      INCLUDE 'DPCOP2.INC'
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      CDF=0.0D0
C
C-----START POINT-----------------------------------------------------
C
      X2=X-1.0D0
      CALL GEOCDF(X2,P,CDF)
C
      RETURN
      END
      SUBROUTINE GEOMEA(X,N,IWRITE,XGEOM,IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE
C              SAMPLE GEOMETRIC MEAN, XGEOM,
C              OF THE DATA IN THE INPUT VECTOR X.
C              THE SAMPLE XGEOM = (PRODUCT OF THE OBSERVATIONS)**(1/N)
C                               = EXP((SUM OF LOG OF OBSERVATIONS)/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--XGEOM  = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED SAMPLE GEOMETRIC MEAN.
C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
C             SAMPLE GEOMETRIC 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--LOG, EXP.
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     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 GEOMEA--')
      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 GEOMETRIC 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 GEOMEA--')
      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 GEOMEA 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
      XGEOM=X(1)
      GOTO9000
  129 CONTINUE
C
C               ***********************************
C               **  STEP 2--                     **
C               **  COMPUTE THE GEOMETRIC MEAN.  **
C               ***********************************
C
      DN=N
      DSUM=0.0D0
      DO200I=1,N
      IF(X(I).LE.0.0)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,211)
  211   FORMAT('***** ERROR FROM GEOMEA')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,213)
  213   FORMAT('      NON-POSITIVE NUMBER ENCOUNTERED.  MEAN SET ',
     1         'TO ZERO.')
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        XGEOM=0.0
        GOTO9000
      ENDIF
      DX=DBLE(X(I))
      DSUM=DSUM+DLOG(DX)
  200 CONTINUE
      DSUM=DSUM/DN
      DSUM=DEXP(DSUM)
      XGEOM=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,XGEOM
  811 FORMAT('THE GEOMETRIC 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 GEOMEA--')
      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)XGEOM
 9015 FORMAT('XGEOM = ',E15.7)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE GEOSD(X,N,IWRITE,XGEOSD,IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE
C              SAMPLE GEOMETRIC STANDARD DEVIATION, XGEOSD,
C              OF THE DATA IN THE INPUT VECTOR X.
C                XGSD = EXP(SD(LOG(Y)))
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--XGEOSD  = THE SINGLE PRECISION VALUE OF THE
C                                 COMPUTED SAMPLE GEOMETRIC STANDARD
C                                 DEVIATION.
C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
C             SAMPLE GEOMETRIC STANDARD DEVIATION
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--LOG, EXP.
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     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 DSUM1
      DOUBLE PRECISION DMEAN
      DOUBLE PRECISION DSD
C
      DIMENSION X(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='GEOS'
      ISUBN2='D   '
      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 GEOSD--')
      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 GEOMETRIC STANDARD DEVIATION  **
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 GEOSD--')
      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 GEOSD 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
C               *************************************************
C               **  STEP 2--                                   **
C               **  COMPUTE THE GEOMETRIC STANDARD DEVIATION.  **
C               *************************************************
C
      DN=DBLE(N)
      DSUM1=0.0D0
C
      DO200I=1,N
        IF(X(I).LE.0.0)THEN
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,211)
  211     FORMAT('***** ERROR FROM GEOSD')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,213)
  213     FORMAT('      NON-POSITIVE NUMBER ENCOUNTERED.  SD SET ',
     1           'TO ZERO.')
          CALL DPWRST('XXX','BUG ')
          IERROR='YES'
          XGEOSD=0.0
          GOTO9000
        ENDIF
        DX=DBLE(X(I))
        DSUM1=DSUM1+DLOG(DX)
  200 CONTINUE
      DMEAN=DSUM1/DN
      DSUM1=0.0D0
      DO300I=1,N
        DX=DLOG(DBLE(X(I)))
        DSUM1=DSUM1 + (DX-DMEAN)**2
  300 CONTINUE
      DSD=DSQRT(DSUM1/(DN-1.0D0))
      XGEOSD=
     1  REAL(DEXP(DSD))
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,XGEOSD
  811 FORMAT('THE GEOMETRIC STANDARD DEVIATION 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 GEOSD--')
      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)XGEOSD
 9015 FORMAT('XGEOSD = ',E15.7)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE GEOPDF(X,P,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY MASS
C              FUNCTION VALUE AT THE DOUBLE PRECISION VALUE X
C              FOR THE GEOMETRIC DISTRIBUTION WITH DOUBLE PRECISION
C              'BERNOULLI PROBABILITY' PARAMETER = P.  THE GEOMETRIC
C              DISTRIBUTION USED HEREIN HAS MEAN = (1-P)/P AND
C              STANDARD DEVIATION = SQRT((1-P)/(P*P))).  THIS
C              DISTRIBUTION IS DEFINED FOR ALL NON-NEGATIVE INTEGER
C              X--X = 0, 1, 2, ... .  THIS DISTRIBUTION HAS THE
C              PROBABILITY MASS FUNCTION
C
C                 p(X;P) = P * (1-P)**X.
C
C              THE GEOMETRIC DISTRIBUTION IS THE DISTRIBUTION OF THE
C              NUMBER OF FAILURES BEFORE OBTAINING 1 SUCCESS IN AN
C              INDEFINITE SEQUENCE OF BERNOULLI (0,1) TRIALS WHERE THE
C              PROBABILITY OF SUCCESS IN A SINGLE TRIAL = P.
C     INPUT  ARGUMENTS--X      = THE DOUBLE PRECISION VALUE AT WHICH
C                                THE PROBABILITY MASS FUNCTION IS TO
C                                BE EVALUATED.  X SHOULD BE NON-NEGATIVE
C                                AND INTEGRAL-VALUED.
C                     --P      = THE DOUBLE PRECISION VALUE OF THE
C                                'BERNOULLI PROBABILITY' PARAMETER FOR
C                                THE GEOMETRIC DISTRIBUTION.  P SHOULD
C                                BE BETWEEN 0.0 (EXCLUSIVELY) AND
C                                1.0 (INCLUSIVELY).
C     OUTPUT ARGUMENTS--PDF    = THE DOUBLE PRECISION PROBABILITY
C                                MASS FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION PROBABILITY MASS FUNCTION VALUE PDF
C             FOR THE GEOMETRIC DISTRIBUTION WITH 'BERNOULLI
C             PROBABILITY' PARAMETER = P.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE NON-NEGATIVE AND INTEGRAL-VALUED.
C                 --P SHOULD BE BETWEEN 0.0 (EXCLUSIVELY)
C                   AND 1.0 (INCLUSIVELY).
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN.
C     REFERENCES--FELLER, AN INTRODUCTION TO PROBABILITY
C                 THEORY AND ITS APPLICATIONS, VOLUME 1,
C                 EDITION 2, 1957, PAGES 155-157, 210.
C               --NATIONAL BUREAU OF STANDARDS APPLIED MATHEMATICS
C                 SERIES 55, 1964, PAGE 929.
C               --CATHERINE LOADER (2000), "FAST AND ACCURATE COMPUTATION
C                 OF BINOMIAL PROBABILITIES", BELL LABS?
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         --MARCH     2009. USE CATHERINE LOADER BINOMIAL
C                                       PDF ALGORITHM
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      INCLUDE 'DPCOP2.INC'
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      PDF=0.0D0
      IF(P.LE.0.0D0 .OR. P.GT.1.0D0)THEN
        WRITE(ICOUT,11)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)P
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(X.LT.0.0D0)THEN
        WRITE(ICOUT,3)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
    3 FORMAT('***** ERROR--THE FIRST ARGUMENT TO GEOPDF IS NEGATIVE')
   11 FORMAT('***** ERROR--THE SECOND ARGUMENT TO GEOPDF 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.EQ.0.0D0)THEN
        PDF=0.0D0
      ELSE
        INTX=INT(X+0.00001D0)
        DX=DBLE(INTX) + 1.0D0
        DQ=1.0D0 - P
        DN=0.0D00
        ILOG=0
        CALL BINRAW(DN,P,DQ,DX,DTERM1,ILOG)
        PDF=P*DTERM1
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE GE2PDF(X,P,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY MASS
C              FUNCTION VALUE AT THE DOUBLE PRECISION VALUE X
C              FOR THE GEOMETRIC DISTRIBUTION WITH DOUBLE PRECISION
C              'BERNOULLI PROBABILITY' PARAMETER = P.  THE GEOMETRIC
C              DISTRIBUTION USED HEREIN HAS MEAN = 1/P AND
C              STANDARD DEVIATION = SQRT((1-P)/(P*P))).  THIS
C              DISTRIBUTION IS DEFINED FOR ALL POSITIVE INTEGER
C              X--X = 1, 2, ... .  THIS DISTRIBUTION HAS THE
C              PROBABILITY MASS FUNCTION
C
C                 p(X;P) = P * (1-P)**(X-1).
C
C              THE GEOMETRIC DISTRIBUTION IS THE DISTRIBUTION OF THE
C              NUMBER OF FAILURES UP TO AND INCLUDING THE FIRST SUCCESS
C              IN AN INDEFINITE SEQUENCE OF BERNOULLI (0,1) TRIALS WHERE
C              THE PROBABILITY OF SUCCESS IN A SINGLE TRIAL = P.
C     INPUT  ARGUMENTS--X      = THE DOUBLE PRECISION VALUE AT WHICH
C                                THE PROBABILITY MASS FUNCTION IS TO
C                                BE EVALUATED.  X SHOULD BE POSITIVE
C                                AND INTEGRAL-VALUED.
C                     --P      = THE DOUBLE PRECISION VALUE OF THE
C                                'BERNOULLI PROBABILITY' PARAMETER FOR
C                                THE GEOMETRIC DISTRIBUTION.  P SHOULD
C                                BE BETWEEN 0.0 (EXCLUSIVELY) AND
C                                1.0 (INCLUSIVELY).
C     OUTPUT ARGUMENTS--PDF    = THE DOUBLE PRECISION PROBABILITY
C                                MASS FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION PROBABILITY MASS FUNCTION VALUE PDF
C             FOR THE GEOMETRIC DISTRIBUTION WITH 'BERNOULLI
C             PROBABILITY' PARAMETER = P.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE NON-NEGATIVE AND INTEGRAL-VALUED.
C                 --P SHOULD BE BETWEEN 0.0 (EXCLUSIVELY)
C                   AND 1.0 (INCLUSIVELY).
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN.
C     REFERENCES--FELLER, AN INTRODUCTION TO PROBABILITY
C                 THEORY AND ITS APPLICATIONS, VOLUME 1,
C                 EDITION 2, 1957, PAGES 155-157, 210.
C               --NATIONAL BUREAU OF STANDARDS APPLIED MATHEMATICS
C                 SERIES 55, 1964, PAGE 929.
C               --CATHERINE LOADER (2000), "FAST AND ACCURATE COMPUTATION
C                 OF BINOMIAL PROBABILITIES", BELL LABS?
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         --MARCH     2009. USE CATHERINE LOADER BINOMIAL
C                                       PDF ALGORITHM
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      INCLUDE 'DPCOP2.INC'
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      PDF=0.0D0
      IF(P.LE.0.0D0 .OR. P.GT.1.0D0)THEN
        WRITE(ICOUT,11)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)P
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(X.LT.1.0D0)THEN
        WRITE(ICOUT,3)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
    3 FORMAT('***** ERROR--THE FIRST ARGUMENT TO GE2PDF IS ',
     1       'NON-POSITIVE')
   11 FORMAT('***** ERROR--THE SECOND ARGUMENT TO GE2PDF 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.EQ.0.0D0)THEN
        PDF=0.0D0
      ELSE
        INTX=INT(X+0.00001D0)
CCCCC   DX=DBLE(INTX) - 1.0D0
        DX=DBLE(INTX)
        DQ=1.0D0 - P
        DN=0.0D00
        ILOG=0
        CALL BINRAW(DN,P,DQ,DX,DTERM1,ILOG)
        PDF=P*DTERM1
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE GEOPPF(P,PPAR,PPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT FUNCTION
C              VALUE FOR THE GEOMETRIC DISTRIBUTION WITH DOUBLE
C              PRECISION 'BERNOULLI PROBABILITY' PARAMETER = PPAR.
C              THE GEOMETRIC DISTRIBUTION USED HEREIN HAS MEAN =
C              (1-PPAR)/PPAR AND STANDARD DEVIATION =
C              SQRT((1-PPAR)/(PPAR*PPAR))).  THIS DISTRIBUTION IS
C              DEFINED FOR ALL NON-NEGATIVE INTEGER X--X = 0, 1, 2, ...
C              THIS DISTRIBUTION HAS THE PROBABILITY FUNCTION
C
C                 p(X;PPAR) = PPAR * (1-PPAR)**X
C
C              THE GEOMETRIC DISTRIBUTION IS THE DISTRIBUTION OF THE
C              NUMBER OF FAILURES BEFORE OBTAINING 1 SUCCESS IN AN
C              INDEFINITE SEQUENCE OF BERNOULLI (0,1) TRIALS WHERE THE
C              PROBABILITY OF SUCCESS IN A SINGLE TRIAL = PPAR.
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 DOUBLE PRECISION VALUE (BETWEEN
C                                0.0 (INCLUSIVELY) AND 1.0 (EXCLUSIVELY))
C                                AT WHICH THE PERCENT POINT FUNCTION IS
C                                TO BE EVALUATED.
C                     --PPAR   = THE DOUBLE PRECISION VALUE OF THE
C                                'BERNOULLI PROBABILITY' PARAMETER FOR
C                                THE GEOMETRIC DISTRIBUTION.  PPAR
C                                SHOULD BE BETWEEN 0.0 (EXCLUSIVELY)
C                                AND 1.0 (INCLUSIVELY).
C     OUTPUT ARGUMENTS--PPF    = THE DOUBLE PRECISION PERCENT POINT
C                                FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION PERCENT POINT FUNCTION VALUE PPF
C             FOR THE GEOMETRIC DISTRIBUTION WITH 'BERNOULLI
C             PROBABILITY' PARAMETER VALUE = PPAR.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--PPAR SHOULD BE BETWEEN 0.0 (EXCLUSIVELY)
C                   AND 1.0 (INCLUSIVELY).
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--FELLER, AN INTRODUCTION TO PROBABILITY
C                 THEORY AND ITS APPLICATIONS, VOLUME 1,
C                 EDITION 2, 1957, PAGES 155-157, 210.
C               --NATIONAL BUREAU OF STANDARDS APPLIED MATHEMATICS
C                 SERIES 55, 1964, PAGE 929.
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-921-3651
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  1975.
C     UPDATED         --DECEMBER  1981.
C     UPDATED         --MAY       1982.
C     UPDATED         --MARCH     2009. USE DOUBLE PRECISION
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      PPF=0.0D0
      IF(P.LT.0.0D0 .OR. P.GE.1.0D0)THEN
        WRITE(ICOUT,1)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)P
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(PPAR.LE.0.0D0 .OR. PPAR.GT.1.0D0)THEN
        WRITE(ICOUT,11)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)PPAR
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
    1 FORMAT('***** ERROR--THE FIRST ARGUMENT TO GEOPPF IS OUTSIDE ',
     1       'THE ALLOWABLE (0,1) INTERVAL')
   11 FORMAT('***** ERROR--THE SECOND ARGUMENT TO GEOPPF IS OUTSIDE ',
     1       'THE ALLOWABLE (0,1) INTERVAL')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
C
      IF(P.EQ.0.0D0)THEN
        PPF=0.0D0
      ELSEIF(PPAR.EQ.1.0D0)THEN
        PPF=0.0D0
      ELSE
C
        ARG1=1.0D0-P
        ARG2=1.0D0-PPAR
        ANUM=LOG(ARG1)
        ADEN=LOG(ARG2)
        RATIO=ANUM/ADEN
        IRATIO=INT(RATIO)
        PPF=REAL(IRATIO)
        ARATIO=REAL(IRATIO)
        IF(ARATIO.EQ.RATIO)PPF=REAL(IRATIO-1)
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE GEORAN(N,P,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE GEOMETRIC DISTRIBUTION
C              WITH SINGLE PRECISION 'BERNOULLI PROBABILITY'
C              PARAMETER = P.
C              THE GEOMETRIC DISTRIBUTION USED
C              HEREIN HAS MEAN = (1-P)/P
C              AND STANDARD DEVIATION = SQRT((1-P)/(P*P))).
C              THIS DISTRIBUTION IS DEFINED FOR
C              ALL NON-NEGATIVE INTEGER X--X = 0, 1, 2, ... .
C              THIS DISTRIBUTION HAS THE PROBABILITY FUNCTION
C              F(X) = P * (1-P)**X.
C              THE GEOMETRIC DISTRIBUTION IS THE
C              DISTRIBUTION OF THE NUMBER OF FAILURES
C              BEFORE OBTAINING 1 SUCCESS IN AN
C              INDEFINITE SEQUENCE OF BERNOULLI (0,1)
C              TRIALS WHERE THE PROBABILITY OF SUCCESS
C              IN A SINGLE TRIAL = P.
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 'BERNOULLI PROBABILITY'
C                                PARAMETER FOR THE GEOMETRIC
C                                DISTRIBUTION.
C                                P SHOULD BE BETWEEN
C                                0.0 (EXCLUSIVELY) AND
C                                1.0 (EXCLUSIVELY).
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 GEOMETRIC DISTRIBUTION
C             WITH 'BERNOULLI PROBABILITY' PARAMETER = P.
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                 --P SHOULD BE BETWEEN 0.0 (EXCLUSIVELY)
C                   AND 1.0 (EXCLUSIVELY).
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     COMMENT--NOTE THAT EVEN THOUGH THE OUTPUT
C              FROM THIS DISCRETE RANDOM NUMBER
C              GENERATOR MUST NECESSARILY BE A
C              SEQUENCE OF ***INTEGER*** VALUES,
C              THE OUTPUT VECTOR X IS SINGLE
C              PRECISION IN MODE.
C              X HAS BEEN SPECIFIED AS SINGLE
C              PRECISION SO AS TO CONFORM WITH THE DATAPAC
C              CONVENTION THAT ALL OUTPUT VECTORS 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--TOCHER, THE ART OF SIMULATION,
C                 1963, PAGES 14-15.
C               --HAMMERSLEY AND HANDSCOMB, MONTE CARLO METHODS,
C                 1964, PAGE 36.
C               --FELLER, AN INTRODUCTION TO PROBABILITY
C                 THEORY AND ITS APPLICATIONS, VOLUME 1,
C                 EDITION 2, 1957, PAGES 155-157, 210.
C               --NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY APPLIED MATHEMATICS
C                 SERIES 55, 1964, PAGE 929.
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-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1966)
C     VERSION NUMBER--82/7
C     ORIGINAL VERSION--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---------------------------------------------------------------------
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 GEOMETRIC ',
     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 ')
        GOTO9000
      ELSEIF(P.LE.0.0.OR.P.GE.1.0)THEN
        WRITE(ICOUT,11)
   11   FORMAT('***** ERROR--THE PROBABILITY OF SUCCESS PARAMETER ',
     1         'FOR THE GEOMETRIC DISTRIBUTION')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,12)
   12   FORMAT('      IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)P
   46   FORMAT('***** THE VALUE OF THE ARGUMENT IS ',F10.5)
        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 GEOMETRIC RANDOM NUMBERS
C     USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD.
C
      DO100I=1,N
        IF(X(I).EQ.0.0)GOTO100
        ARG1=1.0-X(I)
        ARG2=1.0-P
        ANUM=LOG(ARG1)
        ADEN=LOG(ARG2)
        RATIO=ANUM/ADEN
        IRATIO=INT(RATIO)
        X(I)=REAL(IRATIO)
        ARATIO=REAL(IRATIO)
        IF(ARATIO.EQ.RATIO)X(I)=REAL(IRATIO-1)
  100 CONTINUE
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE GE2RAN(N,P,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE GEOMETRIC DISTRIBUTION
C              WITH SINGLE PRECISION 'BERNOULLI PROBABILITY'
C              PARAMETER = P.
C              THIS USES AN ALTERNATE DEFINITION THAN GEOPDF
C              (THE VERSION HERE IS USED IN THE DIGITAL LIBRARY OF
C              MATHEMATICAL FUNCTIONS).
C              THE GEOMETRIC DISTRIBUTION USED HEREIN
C              HEREIN HAS MEAN = 1/P
C              AND STANDARD DEVIATION = SQRT((1-P)/(P*P))).
C              THIS DISTRIBUTION IS DEFINED FOR
C              ALL POSITIVE INTEGER X--X = 1, 2, ... .
C              THIS DISTRIBUTION HAS THE PROBABILITY FUNCTION
C              F(X) = P * (1-P)**(X-1).
C              NOTE THAT THIS ALTERNATE DEFINITION IS ESENTIALLY
C              THE DEFAULT DEFINITION SHIFTED 1 TO THE RIGHT.
C              SO FOR RANDOM NUMBERS, JUST USE THE ALGORITHM FOR
C              THE DEFAULT DEFINITION AND ADD 1.
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 'BERNOULLI PROBABILITY'
C                                PARAMETER FOR THE GEOMETRIC
C                                DISTRIBUTION.
C                                P SHOULD BE BETWEEN
C                                0.0 (EXCLUSIVELY) AND
C                                1.0 (EXCLUSIVELY).
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 GEOMETRIC DISTRIBUTION
C             WITH 'BERNOULLI PROBABILITY' PARAMETER = P.
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                 --P SHOULD BE BETWEEN 0.0 (EXCLUSIVELY)
C                   AND 1.0 (EXCLUSIVELY).
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     COMMENT--NOTE THAT EVEN THOUGH THE OUTPUT
C              FROM THIS DISCRETE RANDOM NUMBER
C              GENERATOR MUST NECESSARILY BE A
C              SEQUENCE OF ***INTEGER*** VALUES,
C              THE OUTPUT VECTOR X IS SINGLE
C              PRECISION IN MODE.
C              X HAS BEEN SPECIFIED AS SINGLE
C              PRECISION SO AS TO CONFORM WITH THE DATAPAC
C              CONVENTION THAT ALL OUTPUT VECTORS 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--TOCHER, THE ART OF SIMULATION,
C                 1963, PAGES 14-15.
C               --HAMMERSLEY AND HANDSCOMB, MONTE CARLO METHODS,
C                 1964, PAGE 36.
C               --FELLER, AN INTRODUCTION TO PROBABILITY
C                 THEORY AND ITS APPLICATIONS, VOLUME 1,
C                 EDITION 2, 1957, PAGES 155-157, 210.
C               --NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY APPLIED MATHEMATICS
C                 SERIES 55, 1964, PAGE 929.
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-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1966)
C     VERSION NUMBER--82/7
C     ORIGINAL VERSION--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)THEN
        WRITE(ICOUT, 5)
    5   FORMAT('***** ERROR--THE REQUESTED NUMBER OF GEOMETRIC ',
     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 ')
        GOTO9000
      ELSEIF(P.LE.0.0.OR.P.GE.1.0)THEN
        WRITE(ICOUT,11)
   11   FORMAT('***** ERROR--THE PROBABILITY OF SUCCESS PARAMETER ',
     1         'FOR THE GEOMETRIC DISTRIBUTION')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,12)
   12   FORMAT('      IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)P
   46   FORMAT('***** THE VALUE OF THE ARGUMENT 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 GEOMETRIC RANDOM NUMBERS
C     USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD.
C
      DO100I=1,N
        IF(X(I).EQ.0.0)GOTO100
        ARG1=1.0-X(I)
        ARG2=1.0-P
        ANUM=LOG(ARG1)
        ADEN=LOG(ARG2)
        RATIO=ANUM/ADEN
        IRATIO=INT(RATIO)
        X(I)=REAL(IRATIO)
        ARATIO=REAL(IRATIO)
        IF(ARATIO.EQ.RATIO)X(I)=REAL(IRATIO-1)
        X(I)=X(I)+1.0
  100 CONTINUE
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE GENER (W, N, WPRIME, NPRIME, INDEX, R)
C
C        ALGORITHM AS 304.6 APPL.STATIST. (1996), VOL.45, NO.3
C
C        Computes an array of sums of the various R-combinations of
C        the elements of W
C
C        DATAPLOT NOTE: UTILITY ROUTINE USED BY FISHER TWO SAMPLE
C                       RANDOMIZATION TEST
C
      INTEGER N, NPRIME, R, INDEX(R)
      REAL W(N), WPRIME(NPRIME)
C
      INTEGER I, J
      DOUBLE PRECISION SUM
      LOGICAL INIT
C
      EXTERNAL NEXT
C
      INIT = .TRUE.
C
      DO 20 I = 1, NPRIME
         CALL NEXT(INDEX, R, N, INIT)
         SUM = 0.0D0
         DO 10 J = 1, R
            SUM = SUM + DBLE(W(INDEX(J)))
   10    CONTINUE
         WPRIME(I) = REAL(SUM)
   20 CONTINUE
C
      RETURN
      END
      SUBROUTINE GEPCDF(X,GAMMA,MINMAX,IGEPDF,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE GENERALIZED PARETO
C              DISTRIBUTION WITH SINGLE PRECISION
C              SHAPE LENGTH PARAMETER = GAMMA.
C
C              THE GENERALIZED PARETO DENSITY FOR THE MAXIMUM
C              CASE HAS THE CUMULATIVE DISTRIBUTION FUNCTION
C
C              F(X;GAMMA) = 1 - [1+GAMMA*X]**(-1/GAMMA)
C                           IF GAMMA < 0: X >= 0
C                           IF GAMMA > 0: 0 <= X < 1/GAMMA
C
C                         = 1 - EXP(-X)
C                           X >= 0, GAMMA = 0
C
C              SOME SOURCES (E.G., JOHNSON, KOTZ, AND BALAKRISHNAN
C              AND CASTILLO, HADI, BALAKRISHNAN, AND SARABIA)
C              USE THE PARAMETERIZATION GAMMA=-GAMMA:
C
C              F(X;GAMMA) = 1 - [1-GAMMA*X]**(1/GAMMA)
C                           IF GAMMA < 0: 0 <= X < -1/GAMMA
C                           IF GAMMA > 0: X >= 0
C
C                         = 1 - EXP(-X)
C                           X >= 0, GAMMA = 0
C
C              THE GENERALIZED PARETO DENSITY FOR THE MINIMUM
C              CASE HAS THE PROBABILITY DENSITY FUNCTION
C
C              F(X;GAMMA) = [1-GAMMA*X]**(-(1/GAMMA))
C                           IF GAMMA < 0: 0 <= X < 1/GAMMA
C                           IF GAMMA > 0: X >= 0
C
C                         = EXP(X)
C                           X <= 0, GAMMA = 0
C
C              IN THE ALTERNATE PARAMETERIZATION
C
C              F(X;GAMMA) = [1+GAMMA*X]**(1/GAMMA)
C                           IF GAMMA < 0: X >= 0
C                           IF GAMMA > 0: 0 <= X < 1/GAMMA
C
C                         = EXP(X)
C                           X <= 0, GAMMA = 0
C
C
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE
C                                AT WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C                     --GAMMA  = THE SINGLE PRECISION VALUE
C                                OF THE TAIL LENGTH PARAMETER.
C                                GAMMA CAN BE NEATIVE, 0, OR POSITIVE.
C                     --MINMAX = INTEGER VALUE, CURRENTLY NOT USED.
C     OUTPUT ARGUMENTS--CDF    = THE SINGLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION FUNCTION .
C             VALUE CDF FOR THE GENERALIZED PARETO 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                 --X SHOULD BE POSITIVE
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTIUOUS UNIVARIATE
C                 DISTRIBUTIONS--VOLUME 1", SECOND EDITION, PP. 614-620.
C               --CASTILLO, HADI, BALAKRISHNAN, AND SARABIA (2005),
C                 "EXTREME VALUES AND RELATED MODELS WITH APPLICATIONS
C                 IN ENGINEERING AND SCIENCE", WILEY, PP. 65-66.
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     VERSION NUMBER--93/12
C     ORIGINAL VERSION--DECEMBER  1993.
C     UPDATED         --DECEMBER  1994  CHECK FOR NEGATIVE X
C     UPDATED         --JANUARY   1995  CHECK FOR OUT OF RANGE X
C     UPDATED         --JUNE      2004  ALTERNATE DEFINITION FOR
C                                       GENERAPLIZED PARETO (USES
C                                       DIFFERENT SIGN)
C     UPDATED         --JANUARY   2008  SUPPORT MINIMUM CASE
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IGEPDF
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DG
      DOUBLE PRECISION DCDF
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
C
C     COMPUTE THE CDF VALUE
C
C
C     MAXIMUM CASE
C
      IF(MINMAX.EQ.2 .OR. MINMAX.EQ.0)THEN
C
C       1) GAMMA = 0 CASE IS SAME FOR BOTH PARAMETERIZATIONS
C       2) X >= 0                 FOR BOTH PARAMETERIZATIONS
C
        IF(X.LT.0.0)THEN
          CDF=0.0
          GOTO9000
        ENDIF
C
        IF(GAMMA.EQ.0.0)THEN
          CDF=1.0 - EXP(-X)
          GOTO9000
        ENDIF
C
        IF(IGEPDF.EQ.'JOHN')THEN
          IF(X.GE.1.0/GAMMA .AND. GAMMA.GT.0.0)THEN
            CDF=1.0
            GOTO9000
          ENDIF
        ELSE
          IF(X.GE.-1.0/GAMMA .AND. GAMMA.LT.0.0)THEN
            CDF=1.0
            GOTO9000
          ENDIF
        ENDIF
C
C       COMPUTE THE CDF VALUE
C
        DX=DBLE(X)
        DG=DBLE(GAMMA)
C
        IF(IGEPDF.EQ.'JOHN')THEN
          DCDF=1.0D0-((1.0D0-DG*DX)**(1.0D0/DG))
        ELSE
          DCDF=1.0D0-((1.0D0+DG*DX)**(-1.0D0/DG))
        ENDIF
        CDF=REAL(DCDF)
C
C     NOW DO THE MINIMUM CASE
C
      ELSE
C
C       1) GAMMA = 0 CASE IS SAME FOR BOTH PARAMETERIZATIONS
C       2) X <= 0                 FOR BOTH PARAMETERIZATIONS
C
        IF(X.GE.0.0)THEN
          CDF=1.0
          GOTO9000
        ENDIF
C
        IF(GAMMA.EQ.0.0)THEN
          CDF=EXP(X)
          GOTO9000
        ENDIF
C
        IF(IGEPDF.EQ.'JOHN')THEN
          IF(X.LE.-1.0/GAMMA .AND. GAMMA.GT.0.0)THEN
            CDF=0.0
            GOTO9000
          ENDIF
        ELSE
          IF(X.LE.1.0/GAMMA .AND. GAMMA.LT.0.0)THEN
            CDF=0.0
            GOTO9000
          ENDIF
        ENDIF
C
C       COMPUTE THE CDF VALUE
C
        DX=DBLE(X)
        DG=DBLE(GAMMA)
C
        IF(IGEPDF.EQ.'JOHN')THEN
          DCDF=(1.0D0+DG*DX)**(1.0D0/DG)
        ELSE
          DCDF=(1.0D0-DG*DX)**(-(1.0D0/DG))
        ENDIF
        CDF=REAL(DCDF)
C
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE GEPCHA(X,GAMMA,MINMAX,IGEPDF,HAZ)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE HAZARD
C              FUNCTION VALUE FOR THE GENERALIZED PARETO
C              DENSITY WITH SINGLE PRECISION
C              SHAPE LENGTH PARAMETER = GAMMA.
C              THE GENERALIZED PARETO DENSITY USED
C              HEREIN IS DEFINED FOR ALL POSITIVE X,
C              AND HAS THE CUMULATIVE HAZARD FUNCTION
C                H(X) = -LOG[(1-GAMMA*X)**(1/GAMMA)]
C              JOHNSON, KOTZ, AND BALAKRISHNANA REVERSE THE SIGN OF THE
C              SHAPE PARAMETER:
C                H(X) = -LOG[(1+GAMMA*X)**(-1/GAMMA)]
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION POSITIVE VALUE AT
C                                WHICH THE HAZARD FUNCTION IS TO BE
C                                EVALUATED.
C                     --GAMMA  = THE SINGLE PRECISION VALUE
C                                OF THE TAIL LENGTH PARAMETER.
C                                GAMMA CAN BE NEG., 0, OR POS.
C                     --MINMAX = THE INTEGER VALUE, NOT CURRENTLY USED
C                     --IGEPDF = CHARACTER VALUE SPECIFYING WHETHER
C                                EMIL SIMIU OR JOHNSON AND KOTZ DEFINITION
C                                SHOULD BE USED.
C     OUTPUT ARGUMENTS--HAZ    = THE SINGLE PRECISION
C                                CUMULATIVE HAZARD FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION CUMULATIVE HAZARD FUNCTION .
C             VALUE HAZ FOR THE GENERALIZED PARETO DENSITY
C             WITH TAIL LENGTH PARAMETER VALUE = GAMMA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--GAMMA MAY BE NEGATIVE, 0, OR POSITIVE
C                 --X SHOULD BE POSITIVE
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--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTIUOUS UNIVARIATE
C                 DISTRIBUTIONS--VOLUME 1", SECOND EDITION, PP. 614-620.
C               --CASTILLO, HADI, BALAKRISHNAN, AND SARABIA (2005),
C                 "EXTREME VALUES AND RELATED MODELS WITH APPLICATIONS
C                 IN ENGINEERING AND SCIENCE", WILEY, PP. 65-66.
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     VERSION NUMBER--98/4
C     ORIGINAL VERSION--APRIL     1998.
C     UPDATED         --JUNE      2004  ALTERNATE DEFINITION FOR
C                                       GENERAPLIZED PARETO (USES
C                                       DIFFERENT SIGN)
C     UPDATED         --JANUARY   2008  SUPPORT MINIMUM CASE
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      INCLUDE 'DPCOMC.INC'
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IGEPDF
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DG
      DOUBLE PRECISION DHAZ
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
C     MAXIMUM CASE
C
      IF(MINMAX.EQ.2 .OR. MINMAX.EQ.0)THEN
C
C       1) GAMMA = 0 CASE IS SAME FOR BOTH PARAMETERIZATIONS
C       2) X >= 0                 FOR BOTH PARAMETERIZATIONS
C
        IF(X.LT.0.0)THEN
          WRITE(ICOUT,1)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,46)X
          CALL DPWRST('XXX','BUG ')
          HAZ=0.0
          GOTO9000
        ENDIF
    1   FORMAT('***** ERROR--THE FIRST ARGUMENT TO GEPCHAZ IS ',
     1         'NEGATIVE.')
C
        IF(GAMMA.EQ.0.0)THEN
          HAZ=X
          GOTO9000
        ENDIF
C
        IF(IGEPDF.EQ.'JOHN')THEN
          IF(X.GT.1.0/GAMMA .AND. GAMMA.GT.0.0)THEN
            WRITE(ICOUT,3)
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,47)X
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,48)GAMMA
            CALL DPWRST('XXX','BUG ')
            HAZ=0.0
            GOTO9000
          ENDIF
        ELSE
          IF(X.GT.-1.0/GAMMA .AND. GAMMA.LT.0.0)THEN
            WRITE(ICOUT,2)
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,47)X
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,48)GAMMA
            CALL DPWRST('XXX','BUG ')
            HAZ=0.0
            GOTO9000
          ENDIF
        ENDIF
C
    2   FORMAT('***** ERROR--FROM GEPCHAZ: X >= -1/GAMMA.')
    3   FORMAT('***** ERROR--FROM GEPCHAZ: X >= 1/GAMMA.')
   46   FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
   47   FORMAT('***** THE VALUE OF X IS     ',G15.7)
   48   FORMAT('***** THE VALUE OF GAMMA IS ',G15.7)
C
C       COMPUTE THE HAZ VALUE
C
        DX=DBLE(X)
        DG=DBLE(GAMMA)
C
        IF(IGEPDF.EQ.'JOHN')THEN
          DHAZ=-DLOG((1.0D0-DG*DX)**(1.0D0/DG))
        ELSE
          DHAZ=-DLOG((1.0D0+DG*DX)**(-1.0D0/DG))
        ENDIF
        HAZ=REAL(DHAZ)
C
C     NOW DO THE MINIMUM CASE
C
      ELSE
C
C       1) GAMMA = 0 CASE IS SAME FOR BOTH PARAMETERIZATIONS
C       2) X <= 0                 FOR BOTH PARAMETERIZATIONS
C
        IF(X.GT.0.0)THEN
          WRITE(ICOUT,11)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,46)X
          CALL DPWRST('XXX','BUG ')
          HAZ=0.0
          GOTO9000
        ENDIF
   11   FORMAT('***** ERROR--THE FIRST ARGUMENT TO GEPHAZ IS ',
     1         'POSITIVE.')
C
        IF(GAMMA.EQ.0.0)THEN
          HAZ=1.0
          GOTO9000
        ENDIF
C
        IF(IGEPDF.EQ.'JOHN')THEN
          IF(X.LE.-1.0/GAMMA .AND. GAMMA.GT.0.0)THEN
            WRITE(ICOUT,13)
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,47)X
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,48)GAMMA
            CALL DPWRST('XXX','BUG ')
            HAZ=0.0
            GOTO9000
          ENDIF
        ELSE
          IF(X.LE.1.0/GAMMA .AND. GAMMA.LT.0.0)THEN
            WRITE(ICOUT,12)
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,47)X
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,48)GAMMA
            CALL DPWRST('XXX','BUG ')
            HAZ=0.0
            GOTO9000
          ENDIF
        ENDIF
C
   12   FORMAT('***** ERROR--FROM GEPHAZ: X <= 1/GAMMA.')
   13   FORMAT('***** ERROR--FROM GEPHAZ: X <= -1/GAMMA.')
C
C       COMPUTE THE HAZ VALUE
C
        CALL GEPCDF(X,GAMMA,MINMAX,IGEPDF,CDF)
        XTEMP1=1.0 - CDF
        IF(XTEMP1.NE.0.0)THEN
          HAZ=-LOG(XTEMP1)
        ELSE
          HAZ=0.0
          WRITE(ICOUT,22)
          CALL DPWRST('XXX','BUG ')
        ENDIF
   22   FORMAT('***** ERROR FROM GEPCHAZ: HAZARD VALUE OVERFLOWS.')
C
      ENDIF
C



 9000 CONTINUE
      RETURN
      END
      SUBROUTINE GEPHAZ(X,GAMMA,MINMAX,IGEPDF,HAZ)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE HAZARD
C              FUNCTION VALUE FOR THE GENERALIZED PARETO
C              DENSITY WITH SINGLE PRECISION
C              SHAPE LENGTH PARAMETER = GAMMA.
C              THE GENERALIZED PARETO DENSITY USED
C              HEREIN IS DEFINED FOR ALL POSITIVE X,
C              AND HAS THE HAZARD FUNCTION
C                 H(X) = 1/(1+GAMMA*X)
C              JOHNSON, KOTZ, AND BALARKRISHNAN REVERSE THE SIGN:
C                 H(X) = 1/(1-GAMMA*X)
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION POSITIVE VALUE
C                                AT WHICH THE HAZARD
C                                FUNCTION IS TO BE EVALUATED.
C                     --GAMMA  = THE SINGLE PRECISION VALUE
C                                OF THE TAIL LENGTH PARAMETER.
C                                GAMMA CAN BE NEG., 0, OR POS.
C                     --MINMAX = THE INTEGER VALUE, NOT CURRENTLY USED
C                     --IGEPDF = CHARACTER VALUE SPECIFYING WHETHER
C                                EMIL SIMIU OR JOHNSON AND KOTZ DEFINITION
C                                SHOULD BE USED.
C     OUTPUT ARGUMENTS--HAZ    = THE SINGLE PRECISION
C                                HAZARD FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION HAZARD FUNCTION .
C             VALUE HAZ FOR THE GENERALIZED PARETO DENSITY
C             WITH TAIL LENGTH PARAMETER VALUE = GAMMA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--GAMMA MAY BE NEGATIVE, 0, OR POSITIVE
C                 --X SHOULD BE POSITIVE
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTIUOUS UNIVARIATE
C                 DISTRIBUTIONS--VOLUME 1", SECOND EDITION, PP. 614-620.
C               --CASTILLO, HADI, BALAKRISHNAN, AND SARABIA (2005),
C                 "EXTREME VALUES AND RELATED MODELS WITH APPLICATIONS
C                 IN ENGINEERING AND SCIENCE", WILEY, PP. 65-66.
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     VERSION NUMBER--98/4
C     ORIGINAL VERSION--APRIL     1998.
C     UPDATED         --JUNE      2004  ALTERNATE DEFINITION FOR
C                                       GENERAPLIZED PARETO (USES
C                                       DIFFERENT SIGN)
C     UPDATED         --JANUARY   2008  SUPPORT MINIMUM CASE
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IGEPDF
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DG
      DOUBLE PRECISION DHAZ
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
C     COMPUTE THE HAZ VALUE
C
C     MAXIMUM CASE
C
      IF(MINMAX.EQ.2 .OR. MINMAX.EQ.0)THEN
C
C       1) GAMMA = 0 CASE IS SAME FOR BOTH PARAMETERIZATIONS
C       2) X >= 0                 FOR BOTH PARAMETERIZATIONS
C
        IF(X.LT.0.0)THEN
          WRITE(ICOUT,1)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,46)X
          CALL DPWRST('XXX','BUG ')
          HAZ=0.0
          GOTO9000
        ENDIF
    1   FORMAT('***** ERROR--THE FIRST ARGUMENT TO GEPHAZ IS ',
     1         'NEGATIVE.')
C
        IF(GAMMA.EQ.0.0)THEN
          HAZ=1.0
          GOTO9000
        ENDIF
C
        IF(IGEPDF.EQ.'JOHN')THEN
          IF(X.GT.1.0/GAMMA .AND. GAMMA.GT.0.0)THEN
            WRITE(ICOUT,3)
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,47)X
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,48)GAMMA
            CALL DPWRST('XXX','BUG ')
            HAZ=0.0
            GOTO9000
          ENDIF
        ELSE
          IF(X.GT.-1.0/GAMMA .AND. GAMMA.LT.0.0)THEN
            WRITE(ICOUT,2)
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,47)X
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,48)GAMMA
            CALL DPWRST('XXX','BUG ')
            HAZ=0.0
            GOTO9000
          ENDIF
        ENDIF
C
    2   FORMAT('***** ERROR--FROM GEPHAZ: X >= -1/GAMMA.')
    3   FORMAT('***** ERROR--FROM GEPHAZ: X >= 1/GAMMA.')
   46   FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
   47   FORMAT('***** THE VALUE OF X IS     ',G15.7)
   48   FORMAT('***** THE VALUE OF GAMMA IS ',G15.7)
C
C       COMPUTE THE HAZ VALUE
C
        DX=DBLE(X)
        DG=DBLE(GAMMA)
C
        IF(IGEPDF.EQ.'JOHN')THEN
          DHAZ=1.0D0/(1.0D0 - DG*DX)
        ELSE
          DHAZ=1.0D0/(1.0D0 + DG*DX)
        ENDIF
        HAZ=REAL(DHAZ)
C
C     NOW DO THE MINIMUM CASE
C
      ELSE
C
C       1) GAMMA = 0 CASE IS SAME FOR BOTH PARAMETERIZATIONS
C       2) X <= 0                 FOR BOTH PARAMETERIZATIONS
C
        IF(X.GT.0.0)THEN
          WRITE(ICOUT,11)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,46)X
          CALL DPWRST('XXX','BUG ')
          HAZ=0.0
          GOTO9000
        ENDIF
   11   FORMAT('***** ERROR--THE FIRST ARGUMENT TO GEPHAZ IS ',
     1         'POSITIVE.')
C
        IF(GAMMA.EQ.0.0)THEN
          HAZ=1.0
          GOTO9000
        ENDIF
C
        IF(IGEPDF.EQ.'JOHN')THEN
          IF(X.LE.-1.0/GAMMA .AND. GAMMA.GT.0.0)THEN
            WRITE(ICOUT,13)
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,47)X
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,48)GAMMA
            CALL DPWRST('XXX','BUG ')
            HAZ=0.0
            GOTO9000
          ENDIF
        ELSE
          IF(X.LE.1.0/GAMMA .AND. GAMMA.LT.0.0)THEN
            WRITE(ICOUT,12)
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,47)X
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,48)GAMMA
            CALL DPWRST('XXX','BUG ')
            HAZ=0.0
            GOTO9000
          ENDIF
        ENDIF
C
   12   FORMAT('***** ERROR--FROM GEPHAZ: X <= 1/GAMMA.')
   13   FORMAT('***** ERROR--FROM GEPHAZ: X <= -1/GAMMA.')
C
C       COMPUTE THE HAZ VALUE
C
        CALL GEPPDF(X,GAMMA,MINMAX,IGEPDF,PDF)
        CALL GEPCDF(X,GAMMA,MINMAX,IGEPDF,CDF)
        XTEMP1=1.0 - CDF
        IF(XTEMP1.NE.0.0)THEN
          HAZ=PDF/XTEMP1
        ELSE
          HAZ=0.0
          WRITE(ICOUT,22)
          CALL DPWRST('XXX','BUG ')
        ENDIF
   22   FORMAT('***** ERROR FROM GEPHAZ: HAZARD VALUE OVERFLOWS.')
C
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE GEPLI1(Y,N,MINMAX,IGEPDF,ALOC,SCALE,SHAPE,
     1                  ALIK,AIC,AICC,BIC,
     1                  ISUBRO,IBUGA3,IERROR)
C
C     PURPOSE--THIS ROUTINE COMPUTES THE LIKELIHOOD FUNCTION FOR THE
C              GENERALIZED PARETO DISTRIBUTION.  THIS IS FOR THE
C              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     REFERENCE--CASTILLO, HADI, BALAKRISHNAN, SARABIA, "EXTREME
C                VALUE AND RELATED MODELS WITH APPLICATIONS IN
C                ENGINEERING AND SCIENCE", WILEY, 2005.
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/07
C     ORIGINAL VERSION--JULY      2010.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IGEPDF
      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 DS
      DOUBLE PRECISION DU
      DOUBLE PRECISION DG
      DOUBLE PRECISION DN
      DOUBLE PRECISION DNP
      DOUBLE PRECISION DLIK
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
C
C---------------------------------------------------------------------
C
      DIMENSION Y(*)
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='GEPL'
      ISUBN2='I1  '
      IERROR='NO'
C
      SHAPE=CPUMIN
      SHAPSV=CPUMIN
      ALIK=CPUMIN
      AIC=CPUMIN
      AICC=CPUMIN
      BIC=CPUMIN
C
      IF(IGEPDF.EQ.'SIMI')THEN
        SHAPSV=SHAPE
        SHAPE=-SHAPE
      ENDIF
C
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'PLI1')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,51)
   51   FORMAT('**** AT THE BEGINNING OF GEPLI1--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,52)IBUGA3,ISUBRO,N,ALOC,SCALE,SHAPE
   52   FORMAT('IBUGA3,ISUBRO,N,ALOC,SCALE,SHAPE = ',2(A4,2X),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.'PLI1')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IERFLG=0
      IERROR='NO'
      IWRITE='OFF'
C
C     FOR THE MAXIMUM CASE, THE LOG-LIKELIHOOD FUNCTION IS
C     (U = LOCATION, S = SCALE, G = SHAPE):
C
C        -N*LOG(S) + ((1/G - 1)*SUM[i=1 to N][LOG(1 - G*(X(i)-U)/S)]
C
C     WHEN G = 0, THIS SIMPLIFIES TO
C
C        -N*LOG(S) + (1/G)*SUM[i=1 to N][X(i) - U]
C
C     FOR THE MINIMUM CASE, JUST TAKE X(I) = -X(I) AND USE ABOVE FORMULA.
C
      DN=DBLE(N)
      DS=DBLE(SCALE)
      DU=DBLE(ALOC)
      DG=DBLE(SHAPE)
      IF(MINMAX.EQ.1)THEN
        DO100I=1,N
          Y(I)=-Y(I)
  100   CONTINUE
      ENDIF
C
      DTERM1=-DN*DLOG(DS)
      DSUM1=0.0D0
      IF(SHAPE.NE.0.0)THEN
        DTERM2=(1.0D0/DG) - 1.0D0
        DO1010I=1,N
          DX=(DBLE(Y(I)) - DU)/DS
          IF(1.0D0 - DG*DX.LE.0.0D0)THEN
            IERROR='YES'
            GOTO9000
          ENDIF
          DSUM1=DSUM1 + DLOG(1.0D0 - DG*DX)
 1010   CONTINUE
        DLIK=DTERM1 + DTERM2*DSUM1
      ELSE
        DO1020I=1,N
          DX=(DBLE(Y(I)) - DU)/DS
          DSUM1=DSUM1 + DX
 1020   CONTINUE
        DLIK=DTERM1 - DSUM1
      ENDIF
C
      ALIK=REAL(DLIK)
      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
C     FOR MINIMUM CASE, CONVERT Y BACK TO ORIGINAL VALUES
C
      IF(MINMAX.EQ.1)THEN
        DO8010I=1,N
          Y(I)=-Y(I)
 8010   CONTINUE
      ENDIF
C
 9000 CONTINUE
C
      IF(IGEPDF.EQ.'SIMI')THEN
        SHAPE=SHAPSV
      ENDIF
C
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'PLI1')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9011)
 9011   FORMAT('**** AT THE END OF GEPLI1--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9013)DSUM1,DSUM2,DTERM1,DTERM2,DTERM3
 9013   FORMAT('DSUM1,DSUM2,DTERM1,DTERM2,DTERM3 = ',5G15.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 GEPML1(Y,N,MAXNXT,MINMAX,ICASPL,IGEPDF,IGEPSV,IDFTTY,
     1                  GAMMSV,SCALSV,ISEED,THRESH,
     1                  TEMP1,TEMP2,TEMP3,TEMP4,TEMP5,YTEMP,
     1                  DTEMP1,XMOM,NMOM,
     1                  XMEAN,XSD,XVAR,XMIN,XMAX,
     1                  ALOCMO,SCALMO,SHAPMO,
     1                  ALOCLM,SCALLM,SHAPLM,
     1                  ALOCEP,SCALEP,SHAPEP,
     1                  ALOCML,SCALML,SHAPML,MLFLAG,
     1                  NUSE,ZMEAN,ZVAR,ZSD,ALOC,
     1                  VARMM1,VARMM2,COVMOM,
     1                  VARML1,VARML2,COVML,
     1                  ISUBRO,IBUGA3,IERROR)
C
C     PURPOSE--THIS ROUTINE COMPUTES THE MAXIMUM LIKELIHOOD ESTIMATES
C              FOR THE 3-PARAMETER GENERALIZED PARETO DISTRIBUTION FOR
C              THE RAW DATA CASE (I.E., NO CENSORING AND NO GROUPING).
C              THIS 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 (DPMLGP WILL GENERATE THE OUTPUT
C              FOR THE GENERALIZED PARETO MLE COMMAND).
C
C              THE FOLLOWING METHODS ARE SUPPORTED:
C
C                  1) MOMENTS
C                  2) L-MOMENTS
C                  3) ELEMENTAL PERCENTILES
C                  4) MAXIMUM LIKELIHOOD
C
C               NOTE THAT MOMENT, L-MOMENT AND MAXIMUM LIKELIHOOD ARE
C               ONLY SUPOORTED FOR CERTAIN RANGES OF THE SHAPE PARAMETER.
C               ELEMENTAL PERCENTILES DOES NOT HAVE THIS RESTRICTION.
C
C               FOR CERTAIN PROCEDURES (E.G., BOOTSTRAP OR
C               BEST DISTRIBUTIONAL FIT) WE MAY WANT TO RESTRICT
C               FITTING TO THE ELEMENTAL PERCENTILES METHOD SINCE
C               THIS SHOULD RETURN A VALID VALUE REGARDLESS OF THE
C               VALUE OF THE SHAPE PARAMETER.
C
C     REFERENCE--JOHNSON, KOTZ, AND BALAKRISHNAN.  "CONTINUOUS
C                UNIVARIATE DISTRIBUTIONS, VOLUME I", SECOND
C                EDITION, WILEY, 1994, PP. 614-619.
C              --CASTILLO, HADI, BALAKRISHNAN, SARABIA, "EXTREME
C                VALUE AND RELATED MODELS WITH APPLICATIONS IN
C                ENGINEERING AND SCIENCE", WILEY, 2005.
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/07
C     ORIGINAL VERSION--JULY      2010. EXTRACTED AS A SEPARATE
C                                       SUBROUTINE (FROM DPMLGP)
C     UPDATED         --APRIL     2011. IDFTTY TO SUPPRESS MOMENT
C                                       OR ML METHODS
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DIMENSION Y(*)
      DIMENSION TEMP1(*)
      DIMENSION TEMP2(*)
      DIMENSION TEMP3(*)
      DIMENSION TEMP4(*)
      DIMENSION TEMP5(*)
      DIMENSION YTEMP(*)
      DOUBLE PRECISION DTEMP1(*)
      DOUBLE PRECISION XMOM(*)
      DOUBLE PRECISION XPAR(3)
      DOUBLE PRECISION FVEC(2)
      DOUBLE PRECISION TOL
      DOUBLE PRECISION G
      DOUBLE PRECISION T3
C
      CHARACTER*4 IGEPDF
      CHARACTER*4 IGEPSV
      CHARACTER*4 IDFTTY
      CHARACTER*4 ICASPL
      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
      EXTERNAL GPAFUN
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='GEPM'
      ISUBN2='L1  '
      IERROR='NO'
      IWRITE='OFF'
C
      AN=REAL(N)
      ALOCMO=CPUMIN
      SCALMO=CPUMIN
      SHAPMO=CPUMIN
      ALOCLM=CPUMIN
      SCALLM=CPUMIN
      SHAPLM=CPUMIN
      ALOCEP=CPUMIN
      SCALEP=CPUMIN
      SHAPEP=CPUMIN
      ALOCML=CPUMIN
      SCALMO=CPUMIN
      SHAPML=CPUMIN
      VARML1=CPUMIN
      VARML2=CPUMIN
      COVML=CPUMIN
      VARMM1=CPUMIN
      VARMM2=CPUMIN
      COVMOM=CPUMIN
      IFRST=0
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 GEPML1--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,52)IBUGA3,ISUBRO,ICASPL,IGEPDF,IDFTTY,MINMAX
   52   FORMAT('IBUGA3,ISUBRO,ICASPL,IGEPDF,IDFTTY,MINMAX = ',
     1         5(A4,2X),I5)
        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.'PML1')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(MINMAX.NE.1)THEN
        DO1145I=1,N
          IF(Y(I).LE.0.0)THEN
            WRITE(ICOUT,999)
            CALL DPWRST('XXX','WRIT')
            WRITE(ICOUT,1111)
            CALL DPWRST('XXX','WRIT')
            WRITE(ICOUT,1148)I,Y(I)
 1148       FORMAT('      ROW ',I8,' IS NON-POSITIVE (VALUE = ',
     1             G15.7,')')
            CALL DPWRST('XXX','WRIT')
            IERROR='YES'
            GOTO9000
          ENDIF
 1145   CONTINUE
      ELSE
        DO1155I=1,N
          IF(Y(I).GE.0.0)THEN
            WRITE(ICOUT,999)
            CALL DPWRST('XXX','WRIT')
            WRITE(ICOUT,1111)
            CALL DPWRST('XXX','WRIT')
            WRITE(ICOUT,1158)I,Y(I)
 1158       FORMAT('      ROW ',I8,' IS NON-NEGATIVE (VALUE = ',
     1             G15.7,')')
            CALL DPWRST('XXX','WRIT')
            IERROR='YES'
            GOTO9000
          ENDIF
 1155   CONTINUE
      ENDIF
C
C               **************************************************
C               **  STEP 2--                                   **
C               **  CARRY OUT CALCULATIONS                     **
C               **  FOR GENERALIZED PARETO MLE ESTIMATE        **
C               *************************************************
C
      ISTEPN='2'
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'PML1')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IDIST='GENERALIZED PARETO'
      IFLAG=0
      CALL SUMRAW(Y,N,IDIST,IFLAG,
     1            XMEAN,XVAR,XSD,XMIN,XMAX,
     1            ISUBRO,IBUGA3,IERROR)
C
      IF(MINMAX.EQ.1)THEN
        DO2002I=1,N
          Y(I)=-Y(I)
 2002   CONTINUE
      ENDIF
      CALL SORT(Y,N,Y)
      XMIN2=Y(1)
C
C     NOTE: L-MOMENTS WILL ESTIMATE THE THRESHOLD PARAMETER, SO
C           GENERATE THIS FIRST.  THE OTHER ESTIMATES ESTIMATE
C           ONLY SHAPE/SCALE PARAMETER, SO SUBTRACT OFF THE
C           L-MOMENT LOCATION ESTIMATE.
C
C           ALTERNATIVELY, THE USER CAN SPECIFY A THRESHOLD.
C           IF THE L-MOMENT ESTIMATE APPEARS TO BE INVALID
C           AND NO USER SPECIFIED THRESHOLD IS GIVEN, THEN
C           SUBTRACT THE DATA MINIMUM (PLUS AN EPSILON) FROM
C           THE DATA.
C
      NMOM=3
      DO2110I=1,N
        DTEMP1(I)=DBLE(Y(I))
 2110 CONTINUE
      CALL SAMLMU(DTEMP1,N,XMOM,NMOM)
      T3=XMOM(3)
      IF(XMOM(2).LE.0.0D0 .OR. DABS(T3).GE.1.0D0)THEN
        CONTINUE
      ELSE
        G=(1.0D0-3.0D0*T3)/(1.0D0+T3)
        SHAPLM=REAL(G)
        SCALLM=REAL((1.0D0+G)*(2.0D0+G)*XMOM(2))
        ALOCLM=REAL(XMOM(1)-DBLE(SCALLM)/(1.0D0+G))
        IF(IGEPDF.EQ.'SIMI')SHAPLM=-SHAPLM
      ENDIF
C
C     EXTRACT POINTS ABOVE THE THRESHOLD.  MOMENT AND ML ESTIMATORS
C     ARE CURRENTLY BASED ON 2-PARAMETER CASE, SO USE THIS
C     THRESHOLD AS LOCATION ESTIMATE IN THESE CASES.
C
C        1) IF USER-SPECIFIED VALUE GIVEN, USE THAT
C        2) IF NO THRESHOLD SPECIFIED, THEN
C           A) IF L-MOMENTS ESTIMATES ARE VALID, USE THE L-MOMENT
C              ESTIMATE OF LOCATION.  IF THIS IS >= DATA MINIMUM,
C              THEN USE OPTION B.
C           B) IF L-MOMENTS ESTIMATES ARE NOT VALID, USE THE
C              DATA MINIMUM (MINUS AN EPSILON)
C
      IF(THRESH.EQ.CPUMIN)THEN
        IF(ALOCLM.NE.CPUMIN .AND. ABS(SHAPLM).LE.0.6 .AND.
     1     ALOCLM.LT.XMIN2) THEN
          ALOC=ALOCLM
        ELSE
          EPS=XMIN2*0.0001
          ALOC=XMIN2 - EPS
        ENDIF
        NUSE=N
        DO2005I=1,N
          YTEMP(I)=Y(I) - ALOC
 2005   CONTINUE
      ELSE
        ALOC=THRESH
        IFIRST=N+1
        DO2010I=1,N
          IF(Y(I).GT.THRESH)THEN
            IFRST=I
            GOTO2019
          ENDIF
 2010   CONTINUE
 2019   CONTINUE
C
        NUSE=N-IFRST+1
        IF(NUSE.LT.3)THEN
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,1111)
 1111     FORMAT('****** ERROR IN GENERALIZED PARETO ',
     1           'MAXIMUM LIKELIHOOD--')
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,2021)
 2021     FORMAT('      LESS THAN 3 POINTS ARE ABOVE THE THRESHOLD.')
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,2023)THRESH
 2023     FORMAT('      THRESHOLD          = ',G15.7)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,2024)Y(1)
 2024     FORMAT('      MINIMUM DATA POINT = ',G15.7)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,2025)Y(N)
 2025     FORMAT('      MAXIMUM DATA POINT = ',G15.7)
          CALL DPWRST('XXX','WRIT')
          IERROR='YES'
          GOTO9000
        ELSE
          ICNT=0
          DO2030I=IFRST,N
            ICNT=ICNT+1
            YTEMP(ICNT)=Y(I)
 2030     CONTINUE
        ENDIF
      ENDIF
C
      ITEMP=2
      NSAMP=20*NUSE
      IF(NSAMP.GT.5000)NSAMP=5000
      CALL DPEPM2(YTEMP,NUSE,ICASPL,MAXNXT,MINMAX,IGEPDF,
     1            ISEED,NSAMP,
     1            TEMP1,TEMP2,TEMP3,TEMP4,TEMP5,
     1            ALOCDM,SCALEP,SHAPEP,
     1            IBUGA3,ISUBRO,IERROR)
      ALOCEP=ALOC
C
      IF(IDFTTY.EQ.'EPER')GOTO9000
C
C     MOMENT ESTIMATES (BASED ON POINTS ABOVE THRESHOLD)
C
      CALL MEAN(YTEMP,NUSE,IWRITE,ZMEAN,IBUGA3,IERROR)
      CALL VAR(YTEMP,NUSE,IWRITE,ZVAR,IBUGA3,IERROR)
      ZSD=SQRT(ZVAR)
C
      SHAPMO=0.5*(ZMEAN*ZMEAN/ZVAR - 1.0)
      SCALMO=0.5*ZMEAN*(ZMEAN*ZMEAN/ZVAR + 1.0)
      ALOCMO=ALOC
      IF(IGEPDF.EQ.'SIMI')SHAPMO=-SHAPMO
C
C     MAXIMUM LIKELIHOOD ESTIMATES (BASED ON POINTS ABOVE THRESHOLD)
C
      IF(IGEPSV.EQ.'EPER')THEN
        XPAR(1)=DBLE(SHAPEP)
        XPAR(2)=DBLE(SCALEP)
      ELSEIF(IGEPSV.EQ.'LMOM')THEN
        XPAR(1)=DBLE(SHAPLM)
        XPAR(2)=DBLE(SCALLM)
      ELSEIF(IGEPSV.EQ.'MOME')THEN
        XPAR(1)=DBLE(SHAPMO)
        XPAR(2)=DBLE(SCALMO)
      ELSEIF(IGEPSV.EQ.'USER')THEN
        XPAR(1)=DBLE(GAMMSV)
        XPAR(2)=DBLE(SCALSV)
      ELSE
        XPAR(1)=DBLE(SHAPEP)
        XPAR(2)=DBLE(SCALEP)
      ENDIF
      DO2111I=1,MAXNXT
        DTEMP1(I)=0.0D0
 2111 CONTINUE
C
      IOPT=2
      TOL=1.0D-5
      NVAR=2
      NPRINT=-1
      INFO=0
      LWA=MAXNXT
      CALL DNSQE(GPAFUN,JAC,IOPT,NVAR,XPAR,FVEC,TOL,NPRINT,INFO,
     1           DTEMP1,MAXNXT,YTEMP,NUSE)
C
      ALOCML=ALOC
      SHAPML=REAL(XPAR(1))
      SCALML=REAL(XPAR(2))
      MLFLAG=0
      IF(INFO.EQ.0)MLFLAG=1
      IF(INFO.EQ.2)MLFLAG=1
      IF(INFO.EQ.4)MLFLAG=1
C
      IF(SHAPMO.GT.-0.25)THEN
        AC1=(1.0+SHAPMO)**2/
     1      ((1.0+2.0*SHAPMO)*(1.0+3.0*SHAPMO)*(1.0+4.0*SHAPMO))
        AC1=AC1/REAL(N)
        VARMM2=2.0*SCALMO**2*(1.0+6.0*SHAPMO+12.0*SHAPMO**2)
        VARMM2=AC1*VARMM2
        VARMM1=(1.0+2.0*SHAPMO)**2*(1.0+SHAPMO+6.0*SHAPMO**2)
        VARMM1=AC1*VARMM1
        COVMOM=AC1*SCALMO*
     1         (1.0+2.0*SHAPMO)*(1.0+4.0*SHAPMO+12.0*SHAPMO**2)
      ELSE
        VARMM1=CPUMIN
        VARMM2=CPUMIN
        COVMOM=CPUMIN
      ENDIF
C
      IF(MLFLAG.EQ.0)THEN
        AN=REAL(N)
        VARML1=(1.0-SHAPML)**2/AN
        VARML2=2.0*SCALML**2*(1.0-SHAPML)/AN
        COVML=SCALML*(1.0-SHAPML)/AN
        IF(IGEPDF.NE.'SIMI')SHAPML=-SHAPML
      ENDIF
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 GEPML1--')
        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,9016)ALOCMO,SCALMO,SHAPMO
 9016   FORMAT('ALOCMO,SCALMO,SHAPMO =  ',3G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9017)ALOCLM,SCALLM,SHAPLM
 9017   FORMAT('ALOCLM,SCALLM,SHAPLM =  ',3G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9018)ALOCEP,SCALEP,SHAPEP
 9018   FORMAT('ALOCLM,SCALLM,SHAPLM =  ',3G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9019)ALOCML,SCALML,SHAPML
 9019   FORMAT('ALOCML,SCALML,SHAPML =  ',3G15.7)
        CALL DPWRST('XXX','WRIT')
      ENDIF
C
      RETURN
      END
      SUBROUTINE GEPPDF(X,GAMMA,MINMAX,IGEPDF,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE GENERALIZED PARETO
C              DENSITY WITH SINGLE PRECISION
C              SHAPE LENGTH PARAMETER = GAMMA.
C
C              THE GENERALIZED PARETO DENSITY FOR THE MAXIMUM
C              CASE HAS THE PROBABILITY DENSITY FUNCTION
C
C              f(X;GAMMA) = (1+GAMMA*X)**(-(1/GAMMA)-1)
C                           IF GAMMA < 0: X >= 0
C                           IF GAMMA > 0: 0 <= X < 1/GAMMA
C
C                         = EXP(-X)
C                           X >= 0, GAMMA = 0
C
C              SOME SOURCES (E.G., JOHNSON, KOTZ, AND BALAKRISHNAN
C              AND CASTILLO, HADI, BALAKRISHNAN, AND SARABIA)
C              USE THE PARAMETERIZATION GAMMA=-GAMMA:
C
C              f(X;GAMMA) = (1-GAMMA*X)**((1/GAMMA)-1)
C                           IF GAMMA < 0: 0 <= X < -1/GAMMA
C                           IF GAMMA > 0: X >= 0
C
C                         = EXP(-X)
C                           X >= 0, GAMMA = 0
C
C              THE GENERALIZED PARETO DENSITY FOR THE MINIMUM
C              CASE HAS THE PROBABILITY DENSITY FUNCTION
C
C              f(X;GAMMA) = (1-GAMMA*X)**(-(1/GAMMA)-1)
C                           IF GAMMA < 0: 1/GAMMA < X <= 0
C                           IF GAMMA > 0: X <= 0
C
C                         = EXP(X)
C                           X <= 0, GAMMA = 0
C
C              IN THE ALTERNATE PARAMETERIZATION
C
C              f(X;GAMMA) = (1+GAMMA*X)**((1/GAMMA)-1)
C                           IF GAMMA < 0: X <= 0
C                           IF GAMMA > 0: -1/GAMMA < X <= 0
C
C                         = EXP(X)
C                           X <= 0, GAMMA = 0
C
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE
C                                (BETWEEN ...
C                                AND ... (EXCLUSIVELY))
C                                AT WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                     --GAMMA  = THE SINGLE PRECISION VALUE
C                                OF THE TAIL LENGTH PARAMETER.
C                                GAMMA CAN BE NEGATIVE 0, OR POSITIVE.
C                     --MINMAX = SPECIFY WHETHER THE MINIMUM OR
C                                MAXIMUM CASE IS USED
C                     --IGEPDF = CHARACTER VALUE SPECIFYING WHETHER
C                                EMIL SIMIU OR JOHNSON AND KOTZ DEFINITION
C                                SHOULD BE USED.
C     OUTPUT ARGUMENTS--PDF    = THE SINGLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY FUNCTION .
C             VALUE PDF FOR THE GENERALIZED PARETO DENSITY
C             WITH TAIL LENGTH PARAMETER VALUE = GAMMA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--GAMMA MAY BE NEGATIVE, 0, OR POSITIVE
C                 --X SHOULD BE BETWEEN 0 (EXCLUSIVELY)
C                   AND INFINITY OR (1/-GAMMA) (EXCLUSIVELY).
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTIUOUS UNIVARIATE
C                 DISTRIBUTIONS--VOLUME 1", SECOND EDITION, PP. 614-620.
C               --CASTILLO, HADI, BALAKRISHNAN, AND SARABIA (2005),
C                 "EXTREME VALUES AND RELATED MODELS WITH APPLICATIONS
C                 IN ENGINEERING AND SCIENCE", WILEY, PP. 65-66.
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--93/12
C     ORIGINAL VERSION--DECEMBER  1993.
C     UPDATED         --DECEMBER  1994  CHECK FOR NEGATIVE X
C     UPDATED         --JANUARY   1995  CHECK FOR OUT OF RANGE X
C     UPDATED         --JUNE      2004  ALTERNATE DEFINITION FOR
C                                       GENERAPLIZED PARETO (USES
C                                       DIFFERENT SIGN)
C     UPDATED         --JANUARY   2008  SUPPORT MINIMUM CASE
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IGEPDF
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DG
      DOUBLE PRECISION DPDF
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
C     MAXIMUM CASE
C
      IF(MINMAX.EQ.2 .OR. MINMAX.EQ.0)THEN
C
C       1) GAMMA = 0 CASE IS SAME FOR BOTH PARAMETERIZATIONS
C       2) X >= 0                 FOR BOTH PARAMETERIZATIONS
C
        IF(X.LT.0.0)THEN
          WRITE(ICOUT,1)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,46)X
          CALL DPWRST('XXX','BUG ')
          PDF=0.0
          GOTO9000
        ENDIF
    1   FORMAT('***** ERROR--THE FIRST ARGUMENT TO GEPPDF IS ',
     1         'NEGATIVE.')
C
        IF(GAMMA.EQ.0.0)THEN
          PDF=EXP(-X)
          GOTO9000
        ENDIF
C
        IF(IGEPDF.EQ.'JOHN')THEN
          IF(X.GT.1.0/GAMMA .AND. GAMMA.GT.0.0)THEN
            WRITE(ICOUT,3)
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,47)X
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,48)GAMMA
            CALL DPWRST('XXX','BUG ')
            PDF=0.0
            GOTO9000
          ENDIF
        ELSE
          IF(X.GT.-1.0/GAMMA .AND. GAMMA.LT.0.0)THEN
            WRITE(ICOUT,2)
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,47)X
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,48)GAMMA
            CALL DPWRST('XXX','BUG ')
            PDF=0.0
            GOTO9000
          ENDIF
        ENDIF
C
    2   FORMAT('***** ERROR--FROM GEPPDF: X >= -1/GAMMA.')
    3   FORMAT('***** ERROR--FROM GEPPDF: X >= 1/GAMMA.')
   46   FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
   47   FORMAT('***** THE VALUE OF X IS     ',G15.7)
   48   FORMAT('***** THE VALUE OF GAMMA IS ',G15.7)
C
C       COMPUTE THE PDF VALUE
C
        DX=DBLE(X)
        DG=DBLE(GAMMA)
C
        IF(IGEPDF.EQ.'JOHN')THEN
          DPDF=(1.0D0-DG*DX)**((1.0D0/DG)-1.0D0)
        ELSE
          DPDF=(1.0D0+DG*DX)**(-(1.0D0/DG)-1.0D0)
        ENDIF
        PDF=REAL(DPDF)
C
C     NOW DO THE MINIMUM CASE
C
      ELSE
C
C       1) GAMMA = 0 CASE IS SAME FOR BOTH PARAMETERIZATIONS
C       2) X <= 0                 FOR BOTH PARAMETERIZATIONS
C
        IF(X.GT.0.0)THEN
          WRITE(ICOUT,11)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,46)X
          CALL DPWRST('XXX','BUG ')
          PDF=0.0
          GOTO9000
        ENDIF
   11   FORMAT('***** ERROR--THE FIRST ARGUMENT TO GEPPDF IS ',
     1         'POSITIVE.')
C
        IF(GAMMA.EQ.0.0)THEN
          PDF=EXP(X)
          GOTO9000
        ENDIF
C
        IF(IGEPDF.EQ.'JOHN')THEN
          IF(X.LE.-1.0/GAMMA .AND. GAMMA.GT.0.0)THEN
            WRITE(ICOUT,13)
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,47)X
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,48)GAMMA
            CALL DPWRST('XXX','BUG ')
            PDF=0.0
            GOTO9000
          ENDIF
        ELSE
          IF(X.LE.1.0/GAMMA .AND. GAMMA.LT.0.0)THEN
            WRITE(ICOUT,12)
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,47)X
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,48)GAMMA
            CALL DPWRST('XXX','BUG ')
            PDF=0.0
            GOTO9000
          ENDIF
        ENDIF
C
   12   FORMAT('***** ERROR--FROM GEPPDF: X <= 1/GAMMA.')
   13   FORMAT('***** ERROR--FROM GEPPDF: X <= -1/GAMMA.')
C
C       COMPUTE THE PDF VALUE
C
        DX=DBLE(X)
        DG=DBLE(GAMMA)
C
        IF(IGEPDF.EQ.'JOHN')THEN
          DPDF=(1.0D0+DG*DX)**((1.0D0/DG)-1.0D0)
        ELSE
          DPDF=(1.0D0-DG*DX)**(-(1.0D0/DG)-1.0D0)
        ENDIF
        PDF=REAL(DPDF)
C
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE GEPPPF(P,GAMMA,MINMAX,IGEPDF,PPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE GENERALIZED PARETO
C              DISTRIBUTION WITH SINGLE PRECISION
C              SHAPE LENGTH PARAMETER = GAMMA.
C              THE GENERALIZED PARETO DENSITY FOR THE MAXIMUM
C              CASE HAS THE PERCENT POINT FUNCTION
C
C              G(P;GAMMA) = (-1/GAMMA)*(1.0 - (1-P)**(-GAMMA)))
C                           IF GAMMA < 0: 0 <= P < 1
C                           IF GAMMA > 0: 0 <= P <= 1
C
C                         = -LOG(1-P)
C                           0 < P <= 1, GAMMA = 0
C
C              SOME SOURCES (E.G., JOHNSON, KOTZ, AND BALAKRISHNAN
C              AND CASTILLO, HADI, BALAKRISHNAN, AND SARABIA)
C              USE THE PARAMETERIZATION GAMMA=-GAMMA:
C
C              G(P;GAMMA) = (1/GAMMA)*(1.0 - (1-P)**GAMMA))
C                           IF GAMMA < 0: 0 <= P <= 1
C                           IF GAMMA > 0: 0 <= P < 1
C
C                         = -LOG(1-P)
C                           0 < P <= 1, GAMMA = 0
C
C              THE GENERALIZED PARETO DENSITY FOR THE MINIMUM
C              CASE HAS THE PROBABILITY DENSITY FUNCTION
C
C              G(P;GAMMA) = (-1/GAMMA)*(P**(-GAMMA) - 1)
C                           IF GAMMA < 0: 0 <= P <= 1
C                           IF GAMMA > 0: 0 <  P <= 1
C
C                         = LOG(P)
C                           0 < P <= 1, GAMMA = 0
C
C              IN THE ALTERNATE PARAMETERIZATION
C
C              G(P;GAMMA) = (1/GAMMA)*(P**GAMMA - 1)
C                           IF GAMMA < 0: 0 <  P <= 1
C                           IF GAMMA > 0: 0 <= P <= 1
C
C                         = LOG(P)
C                           0 < P <= 1, GAMMA = 0
C
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                     --GAMMA  = THE SINGLE PRECISION VALUE
C                                OF THE TAIL LENGTH PARAMETER.
C                                GAMMA CAN BE NEGATIVE, 0, OR POSITIVE.
C                     --MINMAX = THE INTEGER VALUE, NOT CURRENTLY USED
C                     --IGEPDF = CHARACTER VALUE SPECIFYING WHETHER
C                                EMIL SIMIU OR JOHNSON AND KOTZ DEFINITION
C                                SHOULD BE USED.
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 GENERALIZED PARETO DISTRIBUTION
C             WITH TAIL LENGTH PARAMETER VALUE = GAMMA.
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--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--LOG.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTIUOUS UNIVARIATE
C                 DISTRIBUTIONS--VOLUME 1", SECOND EDITION, PP. 614-620.
C               --CASTILLO, HADI, BALAKRISHNAN, AND SARABIA (2005),
C                 "EXTREME VALUES AND RELATED MODELS WITH APPLICATIONS
C                 IN ENGINEERING AND SCIENCE", WILEY, PP. 65-66.
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     VERSION NUMBER--93/12
C     ORIGINAL VERSION--DECEMBER  1993.
C     UPDATED         --JUNE      2004  ALTERNATE DEFINITION FOR
C                                       GENERAPLIZED PARETO (USES
C                                       DIFFERENT SIGN)
C     UPDATED         --JANUARY   2008  SUPPORT MINIMUM CASE
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IGEPDF
C
      DOUBLE PRECISION DP
      DOUBLE PRECISION DG
      DOUBLE PRECISION DPPF
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      DP=DBLE(P)
      DG=DBLE(GAMMA)
      IF(GAMMA.EQ.0.0)THEN
        DPPF=(-DLOG(1.0D0-DP))
      ELSE
         IF(IGEPDF.EQ.'JOHN')THEN
            DPPF=(-1.0D0/DG)*(((1.0D0-DP)**DG)-1.0D0)
         ELSE
            DPPF=(1.0D0/DG)*(((1.0D0-DP)**(-DG))-1.0D0)
         ENDIF
      ENDIF
      PPF=REAL(DPPF)
C
C     MAXIMUM CASE
C
      IF(MINMAX.EQ.2 .OR. MINMAX.EQ.0)THEN
C
C       1) GAMMA = 0 CASE IS SAME FOR BOTH PARAMETERIZATIONS
C
        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
          GOTO9000
        ENDIF
    1   FORMAT('***** ERROR--THE FIRST ARGUMENT TO GEPPPF IS ',
     1         'OUTSIDE THE ALLOWABLE (0,1) INTERVAL.')
C
        IF(GAMMA.EQ.0.0)THEN
          IF(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
          DPPF=-DLOG(1.0D0 - DBLE(P))
          PPF=REAL(DPPF)
          GOTO9000
        ENDIF
C
        IF(IGEPDF.EQ.'JOHN')THEN
          IF(P.GE.1.0 .AND. GAMMA.LT.0.0)THEN
            WRITE(ICOUT,1)
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,46)P
            CALL DPWRST('XXX','BUG ')
            PPF=0.0
            GOTO9000
          ENDIF
        ELSE
          IF(P.GE.1.0 .AND. GAMMA.GT.0.0)THEN
            WRITE(ICOUT,1)
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,46)P
            CALL DPWRST('XXX','BUG ')
            PPF=0.0
            GOTO9000
          ENDIF
        ENDIF
C
   46   FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
C
C       COMPUTE THE PPF VALUE
C
        DP=DBLE(P)
        DG=DBLE(GAMMA)
C
        IF(IGEPDF.EQ.'JOHN')THEN
          DPPF=(1.0D0/DG)*(1.0D0 - (1.0D0 - DP)**DG)
        ELSE
          DPPF=(-1.0D0/DG)*(1.0D0 - (1.0D0 - DP)**(-DG))
        ENDIF
        PPF=REAL(DPPF)
C
C     NOW DO THE MINIMUM CASE
C
      ELSE
C
C       1) GAMMA = 0 CASE IS SAME FOR BOTH PARAMETERIZATIONS
C
        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
          GOTO9000
        ENDIF
C
        IF(GAMMA.EQ.0.0)THEN
          IF(P.LE.0.0)THEN
            WRITE(ICOUT,1)
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,46)P
            CALL DPWRST('XXX','BUG ')
            PPF=0.0
            GOTO9000
          ENDIF
          DPPF=DLOG(DBLE(P))
          PPF=REAL(DPPF)
          GOTO9000
        ENDIF
C
        IF(IGEPDF.EQ.'JOHN')THEN
          IF(P.LE.0.0 .AND. GAMMA.LT.0.0)THEN
            WRITE(ICOUT,1)
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,46)P
            CALL DPWRST('XXX','BUG ')
            PPF=0.0
            GOTO9000
          ENDIF
        ELSE
          IF(P.LE.0.0 .AND. GAMMA.GT.0.0)THEN
            WRITE(ICOUT,1)
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,46)P
            CALL DPWRST('XXX','BUG ')
            PPF=0.0
            GOTO9000
          ENDIF
        ENDIF
C
C       COMPUTE THE PPF VALUE
C
        DP=DBLE(P)
        DG=DBLE(GAMMA)
C
        IF(IGEPDF.EQ.'JOHN')THEN
          DPPF=(1.0D0/DG)*(DP**DG - 1.0D0)
        ELSE
          DPPF=(-1.0D0/DG)*(DP**(-DG) - 1.0D0)
        ENDIF
        PPF=REAL(DPPF)
C
      ENDIF
C


C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE GEDPPF(DP,DG,MINMAX,IGEPDF,DPPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE GENERALIZED PARETO
C              DISTRIBUTION WITH DOUBLE PRECISION
C              SHAPE LENGTH PARAMETER = GAMMA.
C              THE GENERALIZED PARETO DISTRIBUTION USED
C              HEREIN IS DEFINED FOR ALL POSITIVE X,
C              AND HAS THE PERCENT POINT FUNCTION
C                 G(P) = (1/GAMMA)*(((1-P)**(-GAMMA))-1.0)
C              JOHNSON, KOTZ, AND BALAKRISHNAN REVERSE THE SIGN:
C                 G(P) = (-1/GAMMA)*(((1-P)**GAMMA)-1.0)
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
C              THIS VERSION IS A DOUBLE PRECISION VERSION.
C
C     INPUT  ARGUMENTS--P      = THE DOUBLE 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                     --GAMMA  = THE DOUBLE PRECISION VALUE
C                                OF THE TAIL LENGTH PARAMETER.
C                                GAMMA CAN BE NEGATIVE, 0, OR POSITIVE.
C                     --MINMAX = THE INTEGER VALUE, NOT CURRENTLY USED
C                     --IGEPDF = CHARACTER VALUE SPECIFYING WHETHER
C                                EMIL SIMIU OR JOHNSON AND KOTZ DEFINITION
C                                SHOULD BE USED.
C     OUTPUT ARGUMENTS--PPF    = THE DOUBLE PRECISION PERCENT
C                                POINT FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION PERCENT POINT FUNCTION .
C             VALUE PPF FOR THE GENERALIZED PARETO DISTRIBUTION
C             WITH TAIL LENGTH PARAMETER VALUE = GAMMA.
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--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--LOG.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTIUOUS UNIVARIATE
C                 DISTRIBUTIONS--VOLUME 1", SECOND EDITION, PP. 614-620.
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     VERSION NUMBER--2005/5
C     ORIGINAL VERSION--MAY       2005.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IGEPDF
C
      DOUBLE PRECISION DP
      DOUBLE PRECISION DG
      DOUBLE PRECISION DPPF
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOBE.INC'
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(ISUBG4.EQ.'DPPF')THEN
        WRITE(ICOUT,52)IGEPDF,MINMAX,DP,DG
   52   FORMAT('IGEPDF,MINMAX,DP,DG = ',A4,2X,I5,2G15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      IF(DP.LE.0.0D0.OR.DP.GE.1.0D0)THEN
        WRITE(ICOUT,1)
    1   FORMAT('***** ERROR--THE FIRST ARGUMENT TO ',
     1         'GEDPPF IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)DP
   46   FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7,'.')
        CALL DPWRST('XXX','BUG ')
        DPPF=0.0D0
        GOTO9000
      ENDIF
C
      IF(DG.EQ.0.0D0)THEN
        DPPF=(-DLOG(1.0D0-DP))
      ELSE
         IF(IGEPDF.EQ.'JOHN')THEN
            DPPF=(-1.0D0/DG)*(((1.0D0-DP)**DG)-1.0D0)
         ELSE
            DPPF=(1.0D0/DG)*(((1.0D0-DP)**(-DG))-1.0D0)
         ENDIF
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE GE2PPF(P,PPAR,PPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT FUNCTION
C              VALUE FOR THE GEOMETRIC DISTRIBUTION WITH DOUBLE
C              PRECISION 'BERNOULLI PROBABILITY' PARAMETER = PPAR.
C              THIS VERSION USES AN ALTERNATIVE DEFINITION
C              USED IN THE DIGITAL LIBRARY OF MATHEMATICAL FUNCTIONS.
C              THE GEOMETRIC DISTRIBUTION USED HEREIN HAS MEAN = 1/PPAR
C              AND STANDARD DEVIATION = SQRT((1-PPAR)/(PPAR*PPAR))).
C              THIS DISTRIBUTION IS DEFINED FOR ALL POSITIVE INTEGER
C              X--X = 1, 2, ... .
C              THIS DISTRIBUTION HAS THE PROBABILITY FUNCTION
C
C                 p(X;PPAR) = PPAR * (1-PPAR)**(X-1).
C
C              THE GEOMETRIC DISTRIBUTION IS THE DISTRIBUTION OF THE
C              NUMBER OF FAILURES BEFORE OBTAINING 1 SUCCESS IN AN
C              INDEFINITE SEQUENCE OF BERNOULLI (0,1) TRIALS WHERE THE
C              PROBABILITY OF SUCCESS IN A SINGLE TRIAL = PPAR.
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 DOUBLE PRECISION VALUE (BETWEEN
C                                0.0 (INCLUSIVELY) AND 1.0 (EXCLUSIVELY))
C                                AT WHICH THE PERCENT POINT FUNCTION IS
C                                TO BE EVALUATED.
C                     --PPAR   = THE DOUBLE PRECISION VALUE OF THE
C                                'BERNOULLI PROBABILITY' PARAMETER FOR
C                                THE GEOMETRIC DISTRIBUTION.  PPAR
C                                SHOULD BE BETWEEN 0.0 (EXCLUSIVELY)
C                                AND 1.0 (INCLUSIVELY).
C     OUTPUT ARGUMENTS--PPF    = THE DOUBLE PRECISION PERCENT POINT
C                                FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION PERCENT POINT FUNCTION VALUE PPF
C             FOR THE GEOMETRIC DISTRIBUTION WITH 'BERNOULLI
C             PROBABILITY' PARAMETER VALUE = PPAR.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--PPAR SHOULD BE BETWEEN 0.0 (EXCLUSIVELY)
C                   AND 1.0 (INCLUSIVELY).
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--FELLER, AN INTRODUCTION TO PROBABILITY
C                 THEORY AND ITS APPLICATIONS, VOLUME 1,
C                 EDITION 2, 1957, PAGES 155-157, 210.
C               --NATIONAL BUREAU OF STANDARDS APPLIED MATHEMATICS
C                 SERIES 55, 1964, PAGE 929.
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-921-3651
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  1975.
C     UPDATED         --DECEMBER  1981.
C     UPDATED         --MAY       1982.
C     UPDATED         --MARCH     2009. USE DOUBLE PRECISION
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      PPF=0.0D0
      IF(P.LT.0.0D0 .OR. P.GE.1.0D0)THEN
        WRITE(ICOUT,1)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)P
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(PPAR.LE.0.0D0 .OR. PPAR.GT.1.0D0)THEN
        WRITE(ICOUT,11)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)PPAR
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
    1 FORMAT('***** ERROR--THE FIRST ARGUMENT TO GEOPPF IS OUTSIDE ',
     1       'THE ALLOWABLE (0,1) INTERVAL')
   11 FORMAT('***** ERROR--THE SECOND ARGUMENT TO GEOPPF IS OUTSIDE ',
     1       'THE ALLOWABLE (0,1) INTERVAL')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
C
      IF(P.EQ.0.0D0)THEN
        PPF=1.0D0
      ELSEIF(PPAR.EQ.1.0D0)THEN
        PPF=1.0D0
      ELSE
C
        ARG1=1.0D0-P
        ARG2=1.0D0-PPAR
        ANUM=LOG(ARG1)
        ADEN=LOG(ARG2)
        RATIO=ANUM/ADEN
        IRATIO=INT(RATIO+0.99999D0)
        PPF=REAL(IRATIO)
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE GEPRAN(N,GAMMA,MINMAX,IGEPDF,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE GENERALIZED PARETO 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                     --MINMAX = THE INTEGER VALUE
C                                IDENTIFYING THE
C                                CHOSEN GEN. PARETO DISTRIBUTION.
C                                1 = MIN, 2 = MAX.
C                     --IGEPDF = CHARACTER VALUE SPECIFYING WHETHER
C                                EMIL SIMIU OR JOHNSON AND KOTZ DEFINITION
C                                SHOULD BE USED.
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 GENERALIZED PARETO 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--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTIUOUS UNIVARIATE
C                 DISTRIBUTIONS--VOLUME 1", SECOND EDITION, PP. 614-620.
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     VERSION NUMBER--93/12
C     ORIGINAL VERSION--DECEMBER  1993.
C     UPDATED         --JUNE      2004  ALTERNATE DEFINITION FOR
C                                       GENERAPLIZED PARETO (USES
C                                       DIFFERENT SIGN)
C     UPDATED         --JANUARY   2008  TO SUPPORT MINIMUM CASE, JUST
C                                       CALL GEPPPF INSTEAD OF
C                                       COMPUTING PPF INLINE
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
C
CCCCC DOUBLE PRECISION DP
CCCCC DOUBLE PRECISION DG
CCCCC DOUBLE PRECISION DPPF
C
      CHARACTER*4 IGEPDF
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)THEN
C
        WRITE(ICOUT,5)
    5   FORMAT('***** ERROR--FOR THE GENERALIZED PARETO DISTRIBUTION, ',
     1         'THE REQUESTED NUMBER OF RANDOM NUMBERS')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,6)
    6   FORMAT('      IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
   47   FORMAT('***** THE REQUESTED NUMBER OF RANDOM NUMBERS IS ',I8)
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
C     GENERATE N UNIFORM (0,1) RANDOM NUMBERS;
C
C     NOTE THAT GAMMA = 0 REDUCES TO AN EXPONENTIAL, SO HANDLE THAT CASE
C     SEPARATELY.  ALSO, JOHNSON, KOTZ, AND BALAKRISHNAN PARAMETERIZE
C     WITH THE SIGN OF THE SHAPE PARAMETER REVERSED.  HANDLE THAT CASE
C     SEPARATELY.
C
CCCCC IF(GAMMA.EQ.0.0)THEN
CCCCC   CALL EXPRAN(N,ISEED,X)
CCCCC ELSE
CCCCC   CALL UNIRAN(N,ISEED,X)
C
C       GENERATE N GENERALIZED PARETO DISTRIBUTION RANDOM NUMBERS
C       USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD.
C
CCCCC   DG=DBLE(GAMMA)
C
CCCCC   IF(IGEPDF.EQ.'JOHN')THEN
CCCCC     DO100I=1,N
CCCCC       DP=DBLE(X(I))
CCCCC       DPPF=(-1.0D0/DG)*(((1.0D0-DP)**DG)-1.0D0)
CCCCC       X(I)=REAL(DPPF)
CC100     CONTINUE
CCCCC   ELSE
CCCCC     DO200I=1,N
CCCCC       DP=DBLE(X(I))
CCCCC       DPPF=(1.0D0/DG)*(((1.0D0-DP)**(-DG))-1.0D0)
CCCCC       X(I)=REAL(DPPF)
CC200     CONTINUE
CCCCC   ENDIF
CCCCC ENDIF
C
      CALL UNIRAN(N,ISEED,X)
C
      DO100I=1,N
        PTEMP=X(I)
        CALL GEPPPF(PTEMP,GAMMA,MINMAX,IGEPDF,PPF)
        X(I)=PPF
  100 CONTINUE
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE GETCDF(DX,DSHAPE,DBETA,IGETDF,DCDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE GEETA DISTRIBUTION WITH SHAPE
C              PARAMETERS THETA AND BETA.  THIS DISTRIBUTION IS
C              DEFINED FOR ALL INTEGER X >= 1.
C
C              THE PROBABILITY MASS FUNCTION IS:
C              p(X;THETA,BETA)=
C                  (BETA*X-1  X)*THETA**(X-1)*(1-THETA)**(BETA*X-X)/
C                  (BETA*X-1)
C                  X = 1, 2, 3, ,...
C                  0 < THETA < 1; 1 <= BETA < 1/THETA
C
C              THE MEAN AND VARIANCE ARE:
C
C                  MU = (1-THETA)/(1-THETA*BETA)
C                  SIGMA**2 = (BETA-1)*THETA*(1-THETA)/
C                             (1-THETA*BETA)**3
C
C              THIS DISTRIBUTION IS SOMETIMES PARAMETERIZED USING
C              THE MEAN (MU) INSTEAD OF THETA.  THIS RESULTS IN
C              THE PROBABILITY MASS FUNCTION:
C              p(X;MU,BETA)=
C                  (BETA*X-1  X)*((MU-1)/(BETA*MU-1))**(X-1)*
C                  (MU*(BETA-1)/(BETA*MU-1))**(BETA*X-X)/(BETA*X-1)
C                  X = 1, 2, 3, ,...
C                  MU >= 1; BETA > 1
C              THE PROBABILITY MASS FUNCTION IS ALSO GIVEN AS
C              p(X;MU,BETA)=
C                  (BETA*X-1  X)*((MU-1)/(BETA*MU-MU))**(X-1)*
C                  (MU*(BETA-1)/(BETA*MU-1))**(BETA*X-1)/(BETA*X-1)
C
C              THE CUMULATIVE DISTRIBUTION IS COMPUTED USING THE
C              FOLLOWING RECURRENCE RELATION:
C
C              F(1;MU,BETA) = ((BETA-1)*MU/(BETA*MU-1))**(BETA-1)
C              F(2;MU,BETA) = ((MU-1)/MU)*
C                             ((BETA-1)*MU/(BETA*MU-1))**(2*BETA-1)
C              F(X=k+1;MU,BETA) = PROD[i=1 to k][1 + BETA/(BETA*k-1)]*
C                                 ((MU-1)/MU)*
C                                 ((BETA-1)*MU/(BETA*MU-1))**BETA*
C                                 P(X=k;MU,BETA)
C
C              NOTE: THIS RECCURENCE RELATION DOES NOT SEEM TO
C                    RETURN ACCURATE RESULTS.  SO UNTIL THIS IS
C                    RESOLVED, JUST USE BRUTE FORCE AND CALL THE
C                    PDF FUNCTION.
C
C     INPUT  ARGUMENTS--DX     = THE DOUBLE PRECISION VALUE AT
C                                WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C                                DX SHOULD BE A NON-NEGATIVE INTEGER.
C                     --DSHAPE = THE FIRST SHAPE PARAMETER
C                                (EITHER THETA OR MU)
C                     --DBETA  = THE SECOND SHAPE PARAMETER
C     OUTPUT ARGUMENTS--DCDF   = THE DOUBLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION CUMULATIVE DISTRIBUTION FUNCTION
C             VALUE DCDF FOR THE GEETA DISTRIBUTION WITH SHAPE
C             PARAMETERS THETA (OR MU) AND BETA
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--DX SHOULD BE A POSITIVE INTEGER
C                 --0 < THETA < 1; 1 < BETA < 1/THETA
C                 --MU >= 1; BETA > 1
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--CONSUL (1990), "GEETA DISTRIBUTION AND ITS
C                 PROPERTIES", COMMUNICATIONS IN STATISTICS--
C                 THEORY AND METHODS, 19, PP. 3051-3068.
C               --CONSUL AND FAMOYE (2006), "LAGRANGIAN PROBABILITY
C                 DISTRIBUTIONS", BIRKHAUSER, CHAPTER 8.
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/7
C     ORIGINAL VERSION--JULY      2006.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DSHAPE
      DOUBLE PRECISION DBETA
      DOUBLE PRECISION DCDF
C
      DOUBLE PRECISION DTHETA
      DOUBLE PRECISION DMU
      DOUBLE PRECISION DPDF
C
      CHARACTER*4 IGETDF
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(IGETDF.EQ.'THET')THEN
        DTHETA=DSHAPE
      ELSE
        DMU=DSHAPE
      ENDIF
C
      IX=INT(DX+0.5D0)
      IF(IX.LT.1)THEN
        WRITE(ICOUT,4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)DX
        CALL DPWRST('XXX','BUG ')
        DCDF=0.0D0
        GOTO9000
      ENDIF
    4 FORMAT('***** ERROR--THE FIRST ARGUMENT TO GETCDF IS LESS ',
     1'THAN 1')
C
      IF(IGETDF.EQ.'THET')THEN
        IF(DTHETA.LE.0.0D0 .OR. DTHETA.GE.1.0D0)THEN
          WRITE(ICOUT,15)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,46)DTHETA
          CALL DPWRST('XXX','BUG ')
          DCDF=0.0
          GOTO9000
        ENDIF
   15   FORMAT('***** ERROR--THE SECOND ARGUMENT TO GETCDF IS NOT ',
     1         'IN THE INTERVAL (0,1)')
C
        IF(DBETA.LT.1.0D0 .OR. DBETA.GE.1.0D0/DTHETA)THEN
          WRITE(ICOUT,25)1.0D0/DTHETA
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,46)DBETA
          CALL DPWRST('XXX','BUG ')
          DCDF=0.0
          GOTO9000
        ENDIF
   25   FORMAT('***** ERROR--THE THIRD ARGUMENT TO GETCDF IS NOT ',
     1         'IN THE INTERVAL (1,',G15.7,')')
      ELSE
        IF(DMU.LT.1.0D0)THEN
          WRITE(ICOUT,35)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,46)DMU
          CALL DPWRST('XXX','BUG ')
          DCDF=0.0
          GOTO9000
        ENDIF
   35   FORMAT('***** ERROR--THE SECOND ARGUMENT TO GETCDF IS ',
     1         'LESS THAN 1')
C
        IF(DBETA.LE.1.0D0)THEN
          WRITE(ICOUT,38)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,46)DBETA
          CALL DPWRST('XXX','BUG ')
          DCDF=0.0
          GOTO9000
        ENDIF
   38   FORMAT('***** ERROR--THE THIRD ARGUMENT TO GETCDF IS ',
     1         'LESS THAN OR EQUAL TO 1')
      ENDIF
C
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
C
CCCCC USE PDF FUNCTION UNTIL WE GET RECURRENCE RELATION RESOLVED.
C
      IF(IGETDF.EQ.'THET')THEN
        IF(DBETA.LE.1.0D0)THEN
          DCDF=1.0D0
        ELSE
          DCDF=0.0D0
          DO100I=IX,1,-1
            CALL GETPDF(DBLE(I),DTHETA,DBETA,IGETDF,DPDF)
            DCDF=DCDF + DPDF
  100     CONTINUE
        ENDIF
      ELSE
        IF(DMU.LE.1.0D0)THEN
          DCDF=1.0D0
        ELSE
          DCDF=0.0D0
          DO200I=IX,1,-1
            CALL GETPDF(DBLE(I),DMU,DBETA,IGETDF,DPDF)
            DCDF=DCDF + DPDF
  200     CONTINUE
        ENDIF
      ENDIF
C
CCCCC IF(IGETDF.EQ.'THET')THEN
CCCCC   DTHETA=DBLE(THETA)
CCCCC   DMU=(1.0D0 - DTHETA)/(1.0D0 - DTHETA*DBETA)
CCCCC ELSE
CCCCC   DMU=DBLE(MU)
CCCCC ENDIF
C
CCCCC DCDF=((DBETA-1.0D0)*DMU/(DBETA*DMU-1.0D0))**(DBETA-1.0D0)
CCCCC IF(IX.LE.1)THEN
CCCCC   CDF=REAL(DCDF)
CCCCC   GOTO9000
CCCCC ENDIF
CCCCC DPDF=((DMU-1.0D0)/DMU)*
CCCCC1     ((DBETA-1.0D0)*DMU/(DBETA*DMU-1.0D0))**(2.0D0*DBETA-1.0D0)
CCCCC DCDF=DCDF+DPDF
CCCCC IF(IX.LE.2)THEN
CCCCC   CDF=REAL(DCDF)
CCCCC   GOTO9000
CCCCC ENDIF
CCCCC DPDFSV=DPDF
C
CCCCC DTERM1=DLOG(DMU-1.0D0) - DLOG(DMU)
CCCCC DTERM2=DBETA*(DLOG(DBETA-1.0D0)+DLOG(DMU)-DLOG(DBETA*DMU-1.0D0))
CCCCC DO100I=3,IX
CCCCC   K=I-1
CCCCC   DX=DBLE(I)
CCCCC   DSUM=0.0D0
CCCCC   DO200J=1,K
CCCCC     DSUM=DSUM+DLOG(1.0D0+DBETA/(DBETA*DBLE(K)-DBLE(J)))
CC200   CONTINUE
CCCCC   IF(DPDFSV.GT.0.0D0)THEN
CCCCC     DTERM3=DLOG(DPDFSV)
CCCCC     DPDF=DEXP(DTERM3 + DSUM + DTERM1 + DTERM2)
CCCCC   ELSE
CCCCC     CDF=REAL(DCDF)
CCCCC     GOTO9000
CCCCC   ENDIF
CCCCC   DCDF=DCDF + DPDF
CCCCC   DPDFSV=DPDF
CC100 CONTINUE
C
 9000 CONTINUE
      RETURN
      END
      DOUBLE PRECISION FUNCTION GETFUN(DBETA)
C
C     PURPOSE--THIS ROUTINE COMPUTES THE FUNCTIONS FOR THE
C              GEETA MEAN AND ONES FREQUENCY EQUATION.
C
C              THE MEAN AND ONES FREQUENCY ESTIMATE OF MU IS:
C
C                  MUHAT = XBAR
C
C              THE ESTIMATE OF BETA IS THEN THE SOLUTION OF THE
C              EQUATION
C
C                 ((BETA-1)*XBAR/(BETA*XBAR-1))**(BETA-1) - (N1/N) = 0
C
C              CALLED BY DFZERO ROUTINE FOR SOLVING A NONLINEAR
C              UNIVARIATE EQUATION.
C     EXAMPLE--GEETA MAXIMUM LIKELIHOOD Y
C     REFERENCES--CONSUL AND FAMOYE (2006), "LAGRANGIAN PROBABILITY
C                 DISTRIBUTIONS", BIRKHAUSER, CHAPTER 8.
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 DBETA
C
      DOUBLE PRECISION XBAR
      DOUBLE PRECISION S2
      DOUBLE PRECISION F1FREQ
      COMMON/GETCOM/XBAR,S2,F1FREQ,MAXROW,N
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      GETFUN=((DBETA-1.0D0)*XBAR/(DBETA*XBAR-1.0D0))**(DBETA-1.0D0) -
     1       F1FREQ
C
      RETURN
      END
      SUBROUTINE GETFU2(N,XPAR,FVEC,IFLAG,Y,K)
C
C     PURPOSE--THIS ROUTINE COMPUTES THE FUNCTIONS FOR THE
C              GEETA MAXIMUM LIKELIHOOD EQUATION.
C
C              THE MAXIMUM LIKELIHOOD FREQUENCY ESTIMATE OF MU IS:
C
C                  MUHAT = XBAR
C
C              THE ESTIMATE OF BETA IS THEN THE SOLUTION OF THE
C              EQUATION
C
C                 ((BETA-1)*XBAR/(BETA*XBAR-1))**(BETA-1) -
C                 (1/(N*XBAR))*
C                 SUM[X=2 to k][SUM[i=2 to k][X*N(x)/(BETA*X-1)]] = 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--GEETA MAXIMUM LIKELIHOOD Y
C     REFERENCES--CONSUL AND FAMOYE (2006), "LAGRANGIAN PROBABILITY
C                 DISTRIBUTIONS", BIRKHAUSER, CHAPTER 8.
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 DBETA
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DN
      DOUBLE PRECISION DX
      DOUBLE PRECISION DX2
      DOUBLE PRECISION DFREQ
C
      DOUBLE PRECISION XBAR
      DOUBLE PRECISION S2
      DOUBLE PRECISION F1FREQ
      COMMON/GETCOM/XBAR,S2,F1FREQ,MAXROW,NTOT
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      N=2
      IFLAG=0
C
      DBETA=XPAR(1)
      DN=DBLE(NTOT)
      IINDX=MAXROW/2
C
      DTERM1=(DBETA - 1.0D0)*XBAR/(DBETA*XBAR - 1.0D0)
      DTERM2=1.0D0/(DN*XBAR)
C
      DSUM1=0.0D0
      DO100I=2,K
        DX=DBLE(Y(IINDX+I))
        DFREQ=Y(I)
        DO200J=2,I
          DX2=DBLE(Y(IINDX+J))
          DSUM1=DSUM1 + DX*DFREQ/(DBETA*DX - DX2)
  200   CONTINUE
  100 CONTINUE
C
      DTERM3=DTERM2*DSUM1
      FVEC(1)=DEXP(-DTERM3) - DTERM1
C
      RETURN
      END
      SUBROUTINE GETPDF(DX,DSHAPE,DBETA,IGETDF,DPDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY MASS
C              FUNCTION VALUE FOR THE GEETA DISTRIBUTION WITH SHAPE
C              PARAMETERS THETA AND BETA.  THIS DISTRIBUTION IS
C              DEFINED FOR ALL INTEGER X >= 1.
C
C              THE PROBABILITY MASS FUNCTION IS:
C              p(X;THETA,BETA)=
C                  (BETA*X-1  X)*THETA**(X-1)*(1-THETA)**(BETA*X-X)/
C                  (BETA*X-1)
C                  X = 1, 2, 3, ,...
C                  0 < THETA < 1; 1 <= BETA < 1/THETA
C
C              THE MEAN AND VARIANCE ARE:
C
C                  MU = (1-THETA)/(1-THETA*BETA)
C                  SIGMA**2 = (BETA-1)*THETA*(1-THETA)/
C                             (1-THETA*BETA)**3
C
C              THIS DISTRIBUTION IS SOMETIMES PARAMETERIZED USING
C              THE MEAN (MU) INSTEAD OF THETA.  THIS RESULTS IN
C              THE PROBABILITY MASS FUNCTION:
C              p(X;MU,BETA)=
C                  (BETA*X-1  X)*((MU-1)/(BETA*MU-1))**(X-1)*
C                  (MU*(BETA-1)/(BETA*MU-1))**(BETA*X-X)/(BETA*X-1)
C                  X = 1, 2, 3, ,...
C                  MU >= 1; BETA > 1
C              THE PROBABILITY MASS FUNCTION IS ALSO GIVEN AS
C              p(X;MU,BETA)=
C                  (BETA*X-1  X)*((MU-1)/(BETA*MU-MU))**(X-1)*
C                  (MU*(BETA-1)/(BETA*MU-1))**(BETA*X-1)/(BETA*X-1)
C
C     INPUT  ARGUMENTS--DX     = 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                     --DSHAPE = THE FIRST SHAPE PARAMETER
C                                (EITHER THETA OR MU)
C                     --DBETA  = THE SECOND SHAPE PARAMETER
C     OUTPUT ARGUMENTS--DPDF   = THE DOUBLE PRECISION PROBABILITY MASS
C                                FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION PROBABILITY MASS FUNCTION VALUE
C             PDF FOR THE GEETA
C             DISTRIBUTION WITH SHAPE PARAMETERS THETA AND BETA
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE A POSITIVE INTEGER
C                 --0 < THETA < 1; 1 < BETA < 1/THETA
C                 --MU >= 1; BETA > 1
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--CONSUL (1990), "GEETA DISTRIBUTION AND ITS
C                 PROPERTIES", COMMUNICATIONS IN STATISTICS--
C                 THEORY AND METHODS, 19, PP. 3051-3068.
C               --CONSUL AND FAMOYE (2006), "LAGRANGIAN PROBABILITY
C                 DISTRIBUTIONS", BIRKHAUSER, CHAPTER 8.
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/7
C     ORIGINAL VERSION--JULY      2006.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DSHAPE
      DOUBLE PRECISION DBETA
      DOUBLE PRECISION DPDF
C
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
      DOUBLE PRECISION DTERM4
      DOUBLE PRECISION DTERM5
      DOUBLE PRECISION DTHETA
      DOUBLE PRECISION DMU
      DOUBLE PRECISION DLNGAM
C
      CHARACTER*4 IGETDF
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(IGETDF.EQ.'THET')THEN
        DTHETA=DSHAPE
      ELSE
        DMU=DSHAPE
      ENDIF
C
      IX=INT(DX+0.5D0)
      IF(IX.LT.1)THEN
        WRITE(ICOUT,4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)DX
        CALL DPWRST('XXX','BUG ')
        DPDF=0.0D0
        GOTO9000
      ENDIF
    4 FORMAT('***** ERROR--THE FIRST ARGUMENT TO GETPDF IS LESS ',
     1'THAN 1')
C
      IF(IGETDF.EQ.'THET')THEN
        IF(DTHETA.LE.0.0D0 .OR. DTHETA.GE.1.0D0)THEN
          WRITE(ICOUT,15)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,46)DTHETA
          CALL DPWRST('XXX','BUG ')
          DPDF=0.0
          GOTO9000
        ENDIF
   15   FORMAT('***** ERROR--THE SECOND ARGUMENT TO GETPDF IS NOT ',
     1         'IN THE INTERVAL (0,1)')
C
        IF(DBETA.LT.1.0D0 .OR. DBETA.GE.1.0D0/DTHETA)THEN
          WRITE(ICOUT,25)1.0D0/DTHETA
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,46)DBETA
          CALL DPWRST('XXX','BUG ')
          DPDF=0.0
          GOTO9000
        ENDIF
   25   FORMAT('***** ERROR--THE THIRD ARGUMENT TO GETPDF IS NOT ',
     1         'IN THE INTERVAL (1,',G15.7,')')
      ELSE
        IF(DMU.LT.1.0D0)THEN
          WRITE(ICOUT,35)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,46)DMU
          CALL DPWRST('XXX','BUG ')
          DPDF=0.0
          GOTO9000
        ENDIF
   35   FORMAT('***** ERROR--THE SECOND ARGUMENT TO GETPDF IS ',
     1         'LESS THAN 1')
C
        IF(DBETA.LE.1.0D0)THEN
          WRITE(ICOUT,38)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,46)DBETA
          CALL DPWRST('XXX','BUG ')
          DPDF=0.0
          GOTO9000
        ENDIF
   38   FORMAT('***** ERROR--THE THIRD ARGUMENT TO GETPDF IS ',
     1         'LESS THAN OR EQUAL TO 1')
      ENDIF
C
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
C
      DX=DBLE(IX)
C
      IF(IGETDF.EQ.'THET')THEN
        IF(DBETA.LE.1.0D0)THEN
          IF(IX.EQ.1)THEN
            DPDF=1.0D0
          ELSE
            DPDF=0.0D0
          ENDIF
        ELSE
          DTERM1=DLNGAM(DBETA*DX) + (DX-1.0D0)*DLOG(DTHETA) +
     1           (DBETA*DX-DX)*DLOG(1.0D0 - DTHETA)
          DTERM2=DLNGAM(DX+1.0D0) + DLOG(DBETA*DX-1.0D0)
          DTERM3=DLNGAM(DBETA*DX-DX)
          DTERM4=DTERM1 - DTERM2 - DTERM3
          DPDF=DEXP(DTERM4)
        ENDIF
      ELSE
        IF(DMU.LE.1.0D0)THEN
          IF(IX.EQ.1)THEN
            DPDF=1.0D0
          ELSE
            DPDF=0.0D0
          ENDIF
        ELSE
          DTERM1=-DLOG(DBETA*DX - 1.0D0)
          DTERM2=DLNGAM(DBETA*DX) - DLNGAM(DX+1.0D0) -
     1           DLNGAM(DBETA*DX-DX)
          DTERM3=(DX-1.0D0)*(DLOG(DMU-1.0D0) - DLOG(DMU) -
     1           DLOG(DBETA-1.0D0))
          DTERM4=(DBETA*DX-1.0D0)*(DLOG(DBETA*DMU - DMU) -
     1           DLOG(DBETA*DMU - 1.0D0))
          DTERM5=DTERM1 + DTERM2 + DTERM3+ DTERM4
          DPDF=DEXP(DTERM5)
        ENDIF
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE GETPPF(DP,DSHAPE,DBETA,IGETDF,DPPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE GEETA DISTRIBUTION WITH SHAPE
C              PARAMETERS THETA AND BETA.  THIS DISTRIBUTION IS
C              DEFINED FOR ALL INTEGER X >= 1.
C
C              THE PROBABILITY MASS FUNCTION IS:
C              p(X;THETA,BETA)=
C                  (BETA*X-1  X)*THETA**(X-1)*(1-THETA)**(BETA*X-X)/
C                  (BETA*X-1)
C                  X = 1, 2, 3, ,...
C                  0 < THETA < 1; 1 <= BETA < 1/THETA
C
C              THE MEAN AND VARIANCE ARE:
C
C                  MU = (1-THETA)/(1-THETA*BETA)
C                  SIGMA**2 = (BETA-1)*THETA*(1-THETA)/
C                             (1-THETA*BETA)**3
C
C              THIS DISTRIBUTION IS SOMETIMES PARAMETERIZED USING
C              THE MEAN (MU) INSTEAD OF THETA.  THIS RESULTS IN
C              THE PROBABILITY MASS FUNCTION:
C              p(X;MU,BETA)=
C                  (BETA*X-1  X)*((MU-1)/(BETA*MU-1))**(X-1)*
C                  (MU*(BETA-1)/(BETA*MU-1))**(BETA*X-X)/(BETA*X-1)
C                  X = 1, 2, 3, ,...
C                  MU >= 1; BETA > 1
C              THE PROBABILITY MASS FUNCTION IS ALSO GIVEN AS
C              p(X;MU,BETA)=
C                  (BETA*X-1  X)*((MU-1)/(BETA*MU-MU))**(X-1)*
C                  (MU*(BETA-1)/(BETA*MU-1))**(BETA*X-1)/(BETA*X-1)
C
C
C              THE CUMULATIVE DISTRIBUTION FUNCTION IS COMPUTED
C              BY SUMMING THE PROBABILITY MASS FUNCTION.  THE
C              PERCENT POINT FUNCTION IS COMPUTED BY COMPUTING THE
C              CUMULATIVE DISTRIBUTION UNTIL THE APPROPRIATE
C              PROBABILITY IS REACHED.
C
C     INPUT  ARGUMENTS--DP     = THE DOUBLE PRECISION VALUE AT
C                                WHICH THE PERCENT POINT
C                                FUNCTION IS TO BE EVALUATED.
C                     --DSHAPE = THE FIRST SHAPE PARAMETER
C                                (EITHER THETA OR MU)
C                     --DBETA  = THE SECOND SHAPE PARAMETER
C     OUTPUT ARGUMENTS--DPPF   = THE DOUBLE PRECISION PERCENT POINT
C                                FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION PERCENT POINT FUNCTION
C             VALUE DCDF FOR THE GEETA DISTRIBUTION WITH SHAPE
C             PARAMETERS THETA (OR MU) AND BETA
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--0 <= DP < 1
C                 --0 < THETA < 1; 1 < BETA < 1/THETA
C                 --MU >= 1; BETA > 1
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--CONSUL (1990), "GEETA DISTRIBUTION AND ITS
C                 PROPERTIES", COMMUNICATIONS IN STATISTICS--
C                 THEORY AND METHODS, 19, PP. 3051-3068.
C               --CONSUL AND FAMOYE (2006), "LAGRANGIAN PROBABILITY
C                 DISTRIBUTIONS", BIRKHAUSER, CHAPTER 8.
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/7
C     ORIGINAL VERSION--JULY      2006.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DP
      DOUBLE PRECISION DSHAPE
      DOUBLE PRECISION DBETA
      DOUBLE PRECISION DPPF
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DTHETA
      DOUBLE PRECISION DMU
      DOUBLE PRECISION DCDF
      DOUBLE PRECISION DPDF
      DOUBLE PRECISION DEPS
C
      CHARACTER*4 IGETDF
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOMC.INC'
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(IGETDF.EQ.'THET')THEN
        DTHETA=DSHAPE
      ELSE
        DMU=DSHAPE
      ENDIF
C
      IF(DP.LT.0.0D0 .OR. DP.GE.1.0D0)THEN
        WRITE(ICOUT,4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)DP
        CALL DPWRST('XXX','BUG ')
        DPPF=0.0D0
        GOTO9000
      ENDIF
    4 FORMAT('***** ERROR--THE FIRST ARGUMENT TO GETPPF IS OUTSIDE ',
     1'THE (0,1] INTERVAL')
C
      IF(IGETDF.EQ.'THET')THEN
        IF(DTHETA.LE.0.0D0 .OR. DTHETA.GE.1.0D0)THEN
          WRITE(ICOUT,15)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,46)DTHETA
          CALL DPWRST('XXX','BUG ')
          DPPF=0.0
          GOTO9000
        ENDIF
   15   FORMAT('***** ERROR--THE SECOND ARGUMENT TO GETPPF IS NOT ',
     1         'IN THE INTERVAL (0,1)')
C
        IF(DBETA.LT.1.0D0 .OR. DBETA.GE.1.0D0/DTHETA)THEN
          WRITE(ICOUT,25)1.0D0/DTHETA
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,46)DBETA
          CALL DPWRST('XXX','BUG ')
          DPPF=0.0
          GOTO9000
        ENDIF
   25   FORMAT('***** ERROR--THE THIRD ARGUMENT TO GETPPF IS NOT ',
     1         'IN THE INTERVAL (1,',G15.7,')')
      ELSE
        IF(DMU.LT.1.0D0)THEN
          WRITE(ICOUT,35)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,46)DMU
          CALL DPWRST('XXX','BUG ')
          DPPF=0.0
          GOTO9000
        ENDIF
   35   FORMAT('***** ERROR--THE SECOND ARGUMENT TO GETPPF IS ',
     1         'LESS THAN 1')
C
        IF(DBETA.LE.1.0D0)THEN
          WRITE(ICOUT,38)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,46)DBETA
          CALL DPWRST('XXX','BUG ')
          DPPF=0.0
          GOTO9000
        ENDIF
   38   FORMAT('***** ERROR--THE THIRD ARGUMENT TO GETPPF IS ',
     1         'LESS THAN OR EQUAL TO 1')
      ENDIF
C
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
C
CCCCC USE PDF FUNCTION UNTIL WE GET RECURRENCE RELATION RESOLVED.
C
      IF(IGETDF.EQ.'THET')THEN
        IF(DBETA.LE.1.0D0)THEN
          DPPF=1.0D0
        ELSE
          I=0
          DCDF=0.0D0
          DEPS=1.0D-7
  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 ')
            DPPF=0.0D0
            GOTO9000
          ENDIF
          DX=DBLE(I)
          CALL GETPDF(DX,DTHETA,DBETA,IGETDF,DPDF)
          DCDF=DCDF + DPDF
          IF(DCDF.GE.DP-DEPS)THEN
            DPPF=DX
            GOTO9000
          ENDIF
          GOTO100
        ENDIF
      ELSE
        IF(DMU.LE.1.0D0)THEN
          DPPF=1.0D0
        ELSE
          I=0
          DCDF=0.0D0
          DEPS=1.0D-7
  200     CONTINUE
          I=I+1
          IF(DBLE(I).GE.DBLE(I1MACH(9)))THEN
            WRITE(ICOUT,55)
            CALL DPWRST('XXX','BUG ')
            DPPF=0.0D0
            GOTO9000
          ENDIF
          DX=DBLE(I)
          CALL GETPDF(DX,DMU,DBETA,IGETDF,DPDF)
          DCDF=DCDF + DPDF
          IF(DCDF.GE.DP-DEPS)THEN
            DPPF=DX
            GOTO9000
          ENDIF
          GOTO200
        ENDIF
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE GETRAN(N,SHAPE,BETA,IGETDF,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE GEETA DISTRIBUTION WITH SHAPE PARAMETERS
C              THETA OR MU AND BETA.
C
C              THE PROBABILITY MASS FUNCTION IS:
C              p(X;THETA,BETA)=
C                  (BETA*X-1  X)*THETA**(X-1)*(1-THETA)**(BETA*X-X)/
C                  (BETA*X-1)
C                  X = 1, 2, 3, ,...
C                  0 < THETA < 1; 1 <= BETA < 1/THETA
C
C              THE MEAN AND VARIANCE ARE:
C
C                  MU = (1-THETA)/(1-THETA*BETA)
C                  SIGMA**2 = (BETA-1)*THETA*(1-THETA)/
C                             (1-THETA*BETA)**3
C
C              THIS DISTRIBUTION IS SOMETIMES PARAMETERIZED USING
C              THE MEAN (MU) INSTEAD OF THETA.  THIS RESULTS IN
C              THE PROBABILITY MASS FUNCTION:
C              p(X;MU,BETA)=
C                  (BETA*X-1  X)*((MU-1)/(BETA*MU-1))**(X-1)*
C                  (MU*(BETA-1)/(BETA*MU-1))**(BETA*X-X)/(BETA*X-1)
C                  X = 1, 2, 3, ,...
C                  MU >= 1; BETA > 1
C              THE PROBABILITY MASS FUNCTION IS ALSO GIVEN AS
C              p(X;MU,BETA)=
C                  (BETA*X-1  X)*((MU-1)/(BETA*MU-MU))**(X-1)*
C                  (MU*(BETA-1)/(BETA*MU-1))**(BETA*X-1)/(BETA*X-1)
C
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --SHAPE  = 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--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 GEETA DISTRIBUTION
C             WITH SHAPE PARAMETERS THETA (OR MU) 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                 --0 < THETA < 1, 1 < BETA < 1/THETA
C                   MU >= 1; BETA > 1
C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN, GETPPF
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--CONSUL (1990), "GEETA DISTRIBUTION AND ITS
C                 PROPERTIES", COMMUNICATIONS IN STATISTICS--
C                 THEORY AND METHODS, 19, PP. 3051-3068.
C               --CONSUL AND FAMOYE (2006), "LAGRANGIAN PROBABILITY
C                 DISTRIBUTIONS", BIRKHAUSER, CHAPTER 8.
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/7
C     ORIGINAL VERSION--JULY      2006.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
C
      CHARACTER*4 IGETDF
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)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
    5 FORMAT('***** ERROR--THE REQUESTED NUMBER OF GEETA RANDOM ',
     1       'NUMBERS IS NON-POSITIVE')
C
      IF(IGETDF.EQ.'THET')THEN
        THETA=SHAPE
        IF(THETA.LE.0.0 .OR. THETA.GE.1.0)THEN
          WRITE(ICOUT,15)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,16)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,46)THETA
          CALL DPWRST('XXX','BUG ')
          GOTO9000
        ENDIF
   15   FORMAT('***** ERROR--THE THETA PARAMETER FOR THE GEETA')
   16   FORMAT('      RANDOM NUMBERS IS OUTSIDE THE (0,1) INTERVAL')
C
        IF(BETA.LE.1.0 .OR. BETA.GE.1.0/THETA)THEN
          WRITE(ICOUT,25)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,26)1.0/THETA
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,46)BETA
          CALL DPWRST('XXX','BUG ')
          GOTO9000
        ENDIF
   25   FORMAT('***** ERROR--THE BETA PARAMETER FOR THE GEETA')
   26   FORMAT('      RANDOM NUMBERS IS OUTSIDE THE (1,',G15.7,') ',
     1         'INTERVAL')
      ELSE
        AMU=SHAPE
        IF(AMU.LT.1.0)THEN
          WRITE(ICOUT,35)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,36)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,46)AMU
          CALL DPWRST('XXX','BUG ')
          GOTO9000
        ENDIF
   35   FORMAT('***** ERROR--THE MU PARAMETER FOR THE GEETA')
   36   FORMAT('      RANDOM NUMBERS IS LESS THAN 1')
C
        IF(BETA.LE.1.0)THEN
          WRITE(ICOUT,38)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,39)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,46)BETA
          CALL DPWRST('XXX','BUG ')
          GOTO9000
        ENDIF
   38   FORMAT('***** ERROR--THE BETA PARAMETER FOR THE GEETA')
   39   FORMAT('      RANDOM NUMBERS IS LESS THAN OR EQUAL TO 1')
      ENDIF
C
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8)
C
C     GENERATE N GEETA DISTRIBUTION RANDOM NUMBERS USING THE
C     INVERSION METHOD.
C
      CALL UNIRAN(N,ISEED,X)
      DO100I=1,N
        XTEMP=X(I)
        CALL GETPPF(DBLE(XTEMP),DBLE(SHAPE),DBLE(BETA),IGETDF,DPPF)
        X(I)=REAL(DPPF)
  100 CONTINUE
C
 9000 CONTINUE
C
      RETURN
      END
      SUBROUTINE GEVCDF(X,GAMMA,MINMAX,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE GENERALIZED EXTREME VALUE
C              DISTRIBUTION WITH SINGLE PRECISION
C              SHAPE PARAMETER = GAMMA.
C              THERE ARE TWO GENERALIZED EXTREME VALUE FAMALIES:
C              ONE BASED ON THE MAXIMUM ORDER STATISTIC (THE MOST
C              COMMONLY USED, SPECIFIED BY MINMAX=2) AND THE OTHER
C              BASED ON THE MINIMUM ORDER STATISTIC (SPECIFIED BY
C              SET MINMAX = 1).
C
C              THE CUMUALTIVE DISTRIBUTION FUNCTION FOR THE MAXIMUM
C              CASE OF THE GENERALIZED EXTREME VALUE DISTRIBUTION IS:
C              F(X,G) = EXP(-EXP(-X))                          G = 0
C                     = EXP(-(1 - GAMMA*X)**(1/GAMMA)]         G <> 0
C                                     1 - GAMMA*X >= 0
C
C              THE CUMULATIVE DISTRIBUTION FUNCTION FOR THE MINIMUM CASE
C              OF THE GENERALIZED EXTREME VALUE DISTRIBUTION IS:
C              F(X,G) = 1 - EXP(-EXP(X))                       G = 0
C                     = 1 - EXP(-(1 + GAMMA*X)**(1/GAMMA)]     G <> 0
C                                     1 + GAMMA*X >= 0
C
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE
C                                AT WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C                     --GAMMA  = THE SINGLE PRECISION VALUE
C                                OF THE 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 GENERALIZED EXTREME VALUE
C             DISTRIBUTION WITH SHAPE PARAMETER VALUE = GAMMA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--RANGE OF X DEPENDS ON SIGN OF GAMMA
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, PAGES 75-76
C               --CASTILLO, HADI, BALAKRISHNAN, AND SARABIA,
C                 "EXTREME VALUE AND RELATED MODELS WITH APPLICATIONS
C                 IN ENGINEERING AND SCIENCE", WILEY, 2005, PP. 64-65.
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     UPDATED         --MAY       2005. SUPPORT FOR MINIMUM CASE
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX, DG
      DOUBLE PRECISION DCDF
      DOUBLE PRECISION DTERM1
C
      INCLUDE 'DPCOP2.INC'
C
C---------------------------------------------------------------------
C
C     MAY 2005.  HANDLE MIN AND MAX CASES SEPARATELY.
C
C     MAXIMUM CASE
C
      IF(MINMAX.EQ.2 .OR. MINMAX.EQ.0)THEN
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
        IF(GAMMA.GT.0.0)THEN
          IF(X.GE.(1.0/GAMMA))THEN
            CDF=1.0
            GOTO9999
          ENDIF
        ELSEIF(GAMMA.LT.0.0)THEN
          IF(X.LE.(1.0/GAMMA))THEN
            CDF=0.0
            GOTO9999
          ENDIF
        ENDIF
C
        DX=DBLE(X)
        DG=DBLE(GAMMA)
        DCDF=0.0D0
C
        IF(GAMMA.EQ.0.0)THEN
          IF(DX.GE.40.D0)THEN
            DCDF=1.0D0
          ELSEIF(DX.LE.-40.D0)THEN
            DCDF=0.0D0
          ELSE
            DTERM1=-DEXP(-DX)
            IF(DTERM1.GE.0.0D0)THEN
              DCDF=1.0D0
            ELSE
              DCDF=DEXP(DTERM1)
            ENDIF
          ENDIF
        ELSE
          IF(GAMMA.GT.0.0.AND.X.EQ.1.0/GAMMA)THEN
            DCDF=1.0D0
          ELSEIF(GAMMA.LT.0.0.AND.X.EQ.1.0/GAMMA)THEN
            DCDF=0.0D0
          ELSE
            DTERM1=-(1.D0-DX*DG)**(1.D0/DG)
            IF(DTERM1.LT.-40.0D0)THEN
              DCDF=0.0D0
            ELSEIF(DTERM1.GE.0.0D0)THEN
              DCDF=1.0D0
            ELSE
              DCDF=DEXP(DTERM1)
            ENDIF
          END IF
        END IF
        CDF=REAL(DCDF)
      ELSE
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
        IF(GAMMA.GT.0.0)THEN
          IF(X.LE.(-1.0/GAMMA))THEN
            CDF=0.0
            GOTO9999
          ENDIF
        ELSEIF(GAMMA.LT.0.0)THEN
          IF(X.GE.(-1.0/GAMMA))THEN
            CDF=1.0
            GOTO9999
          ENDIF
        ENDIF
C
        DX=DBLE(X)
        DG=DBLE(GAMMA)
        DCDF=0.D0
C
        IF(GAMMA.EQ.0.0)THEN
          DTERM1=DEXP(DX)
          DCDF=1.0D0 - DEXP(-DTERM1)
        ELSE
          IF(GAMMA.GT.0.0.AND.X.EQ.-1.0/GAMMA)THEN
            DCDF=0.0D0
          ELSEIF(GAMMA.LT.0.0.AND.X.EQ.-1.0/GAMMA)THEN
            DCDF=1.0D0
          ELSE
            DTERM1=-(1.D0+DX*DG)**(1.D0/DG)
            DCDF=1.0D0 - DEXP(DTERM1)
          END IF
        END IF
        CDF=REAL(DCDF)
      ENDIF
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE GEVCHA(X,GAMMA,MINMAX,CHAZ)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE HAZARD
C              FUNCTION VALUE FOR THE GENERALIZED EXTREME VALUE
C              DISTRIBUTION WITH SINGLE PRECISION
C              SHAPE PARAMETER = GAMMA.
C              THERE ARE TWO GENERALIZED EXTREME VALUE FAMALIES:
C              ONE BASED ON THE MAXIMUM ORDER STATISTIC (THE MOST
C              COMMONLY USED, SPECIFIED BY MINMAX=2) AND THE OTHER
C              BASED ON THE MINIMUM ORDER STATISTIC (SPECIFIED BY
C              SET MINMAX = 1).
C
C              THE CUMUALTIVE DISTRIBUTION FUNCTION FOR THE MAXIMUM
C              CASE OF THE GENERALIZED EXTREME VALUE DISTRIBUTION IS:
C              F(X,G) = EXP(-EXP(-X))                          G = 0
C                     = EXP(-(1 - GAMMA*X)**(1/GAMMA)]         G <> 0
C                                     1 - GAMMA*X >= 0
C
C              THE CUMULATIVE DISTRIBUTION FUNCTION FOR THE MINIMUM CASE
C              OF THE GENERALIZED EXTREME VALUE DISTRIBUTION IS:
C              F(X,G) = 1 - EXP(-EXP(X))                       G = 0
C                     = 1 - EXP(-(1 + GAMMA*X)**(1/GAMMA)]     G <> 0
C                                     1 + GAMMA*X >= 0
C
C              THE CUMULATIVE HAZARD IS THEN
C
C              H(X,G) = -LOG(1 - F(X,G))
C
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE
C                                AT WHICH THE CUMULATIVE HAZARD
C                                FUNCTION IS TO BE EVALUATED.
C                     --GAMMA  = THE SINGLE PRECISION VALUE
C                                OF THE SHAPE PARAMETER.
C                     --MINMAX = THE INTEGER VALUE THAT SPECIES
C                                THE MINIMUM/MAXIMUM CASE.
C     OUTPUT ARGUMENTS--CHAZ   = THE SINGLE PRECISION CUMULATIVE
C                                HAZARD FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION CUMULATIVE HAZARD
C             FUNCTION VALUE CDF FOR THE GENERALIZED EXTREME VALUE
C             DISTRIBUTION WITH SHAPE PARAMETER VALUE = GAMMA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--RANGE OF X DEPENDS ON SIGN OF GAMMA
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, PAGES 75-76
C               --CASTILLO, HADI, BALAKRISHNAN, AND SARABIA,
C                 "EXTREME VALUE AND RELATED MODELS WITH APPLICATIONS
C                 IN ENGINEERING AND SCIENCE", WILEY, 2005, PP. 64-65.
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--MAY       2005.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DG
      DOUBLE PRECISION DCDF
      DOUBLE PRECISION DCHAZ
      DOUBLE PRECISION DTERM1
C
      INCLUDE 'DPCOP2.INC'
C
C---------------------------------------------------------------------
C
C     MAY 2005.  HANDLE MIN AND MAX CASES SEPARATELY.
C
    4 FORMAT('****** ERROR FROM GEVCHAZ--THE CDF VALUE IS 1 WHICH ',
     1       'RESULTS IN AN UNDEFINED CUMULATIVE HAZARD.')
   46 FORMAT('****** THE VALUE OF THE INPUT ARGUMENT IS  ',G15.7)
   47 FORMAT('****** THE VALUE OF THE SHAPE PARAMETER IS ',G15.7)
C
C     MAXIMUM CASE
C
      IF(MINMAX.EQ.2 .OR. MINMAX.EQ.0)THEN
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
        IF(GAMMA.GT.0.0)THEN
          IF(X.GE.(1.0/GAMMA))THEN
            CHAZ=0.0
            WRITE(ICOUT,4)
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,46)X
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,47)GAMMA
            CALL DPWRST('XXX','BUG ')
            GOTO9999
          ENDIF
        ELSEIF(GAMMA.LT.0.0)THEN
          IF(X.LE.(1.0/GAMMA))THEN
            CHAZ=0.0
            GOTO9999
          ENDIF
        ENDIF
C
        DX=DBLE(X)
        DG=DBLE(GAMMA)
        DCDF=0.0D0
        DCHAZ=0.0D0
C
        IF(GAMMA.EQ.0.0)THEN
          DTERM1=-DEXP(-DX)
          DCDF=DEXP(DTERM1)
          IF(DCDF.GE.1.0D0)THEN
            CHAZ=0.0
            WRITE(ICOUT,4)
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,46)X
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,47)GAMMA
            CALL DPWRST('XXX','BUG ')
            GOTO9999
          ELSE
            DCHAZ=-DLOG(1.0D0 - DCDF)
          ENDIF
        ELSE
          DTERM1=-(1.D0-DX*DG)**(1.D0/DG)
          DCDF=DEXP(DTERM1)
          IF(DCDF.GE.1.0D0)THEN
            CHAZ=0.0
            WRITE(ICOUT,4)
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,46)X
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,47)GAMMA
            CALL DPWRST('XXX','BUG ')
            GOTO9999
          ELSE
            DCHAZ=-DLOG(1.0D0 - DCDF)
          ENDIF
        ENDIF
      ELSE
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
        IF(GAMMA.GT.0.0)THEN
          IF(X.LE.(-1.0/GAMMA))THEN
            CHAZ=0.0
            GOTO9999
          ENDIF
        ELSEIF(GAMMA.LT.0.0)THEN
          IF(X.GE.(-1.0/GAMMA))THEN
            CHAZ=0.0
            WRITE(ICOUT,4)
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,46)X
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,47)GAMMA
            CALL DPWRST('XXX','BUG ')
            GOTO9999
          ENDIF
        ENDIF
C
        DX=DBLE(X)
        DG=DBLE(GAMMA)
        DCHAZ=0.D0
C
        IF(GAMMA.EQ.0.0)THEN
          DCHAZ=DEXP(DX)
        ELSE
          DCHAZ=(1.D0+DX*DG)**(1.D0/DG)
        END IF
      ENDIF
      CHAZ=REAL(DCHAZ)
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE GEVHAZ(X,GAMMA,MINMAX,HAZ)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE HAZARD
C              FUNCTION VALUE FOR THE GENERALIZED EXTREME VALUE
C              DISTRIBUTION WITH SINGLE PRECISION
C              SHAPE PARAMETER = GAMMA.
C              THERE ARE TWO GENERALIZED EXTREME VALUE FAMALIES:
C              ONE BASED ON THE MAXIMUM ORDER STATISTIC (THE MOST
C              COMMONLY USED, SPECIFIED BY MINMAX=2) AND THE OTHER
C              BASED ON THE MINIMUM ORDER STATISTIC (SPECIFIED BY
C              SET MINMAX = 1).
C
C              THE HAZARD IS DEFINED AS
C
C              H(X,G) = f(X,G)/(1 - F(X,G))
C
C              WHERE f AND F ARE THE PROBABILITY DENSITY AND
C              CUMULATIVE DISTRIBUTION FUNCTIONS, RESPECTIVELY.
C
C              FOR THE MAXIMUM CASE, THIS ROUTINE CALLS GEVPDF AND
C              GEVCDF AND THEN USES THE ABOVE FORMULA.  FOR THE
C              MINIMUM CASE, THE HAZARD FUNCTION REDUCES TO:
C
C              H(X,G) = (1 + G*X)**((1/G)-1)              G <> 0
C              H(X,G) = EXP(X)                            G = 0
C
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE
C                                AT WHICH THE HAZARD FUNCTION IS TO
C                                BE EVALUATED.
C                     --GAMMA  = THE SINGLE PRECISION VALUE
C                                OF THE SHAPE PARAMETER.
C                     --MINMAX = THE INTEGER VALUE THAT SPECIFIES
C                                THE MINIMUM/MAXIMUM CASE
C     OUTPUT ARGUMENTS--HAZ    = THE SINGLE PRECISION HAZARD
C                                FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION HAZARD FUNCTION VALUE HAZ FOR THE
C             GENERALIZED EXTREME VALUE DISTRIBUTION WITH
C             SHAPE PARAMETER VALUE = GAMMA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--RANGE OF X DEPENDS ON SIGN OF GAMMA
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, PAGES 75-76
C               --CASTILLO, HADI, BALAKRISHNAN, AND SARABIA,
C                 "EXTREME VALUE AND RELATED MODELS WITH APPLICATIONS
C                 IN ENGINEERING AND SCIENCE", WILEY, 2005, PP. 64-65.
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--MAY       2005.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DG
      DOUBLE PRECISION DHAZ
C
      INCLUDE 'DPCOP2.INC'
C
C---------------------------------------------------------------------
C
C     MAY 2005.  HANDLE MIN AND MAX CASES SEPARATELY.
C
C     MAXIMUM CASE
C
      IF(MINMAX.EQ.2 .OR. MINMAX.EQ.0)THEN
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
        IF(GAMMA.GT.0.0)THEN
          IF(X.GT.(1.0/GAMMA))THEN
            WRITE(ICOUT,4)
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,46)X
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,47)GAMMA
            CALL DPWRST('XXX','BUG ')
            HAZ=0.0
            GOTO9999
          ENDIF
        ELSEIF(GAMMA.LT.0.0)THEN
          IF(X.LT.(1.0/GAMMA))THEN
            WRITE(ICOUT,14)
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,46)X
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,47)GAMMA
            CALL DPWRST('XXX','BUG ')
            HAZ=0.0
            GOTO9999
          ENDIF
        ENDIF
    4   FORMAT('***** ERROR--THE FIRST  INPUT ARGUMENT TO GEVHAZ ',
     1         'IS GREATER THAN 1/GAMMA.')
   14   FORMAT('***** ERROR--THE FIRST  INPUT ARGUMENT TO GEVHAZ ',
     1         'IS LESS THAN 1/GAMMA.')
   16   FORMAT('***** ERROR--FOR THE GEVHAZ FUNCTION, THE ',
     1         'CDF IS EQUAL TO 1.')
   46   FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
   47   FORMAT('***** THE VALUE OF GAMMA IS ',G15.7)
C
        CALL GEVCDF(X,GAMMA,MINMAX,CDF)
        IF(CDF.GE.1.0)THEN
          WRITE(ICOUT,16)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,46)X
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,47)GAMMA
          CALL DPWRST('XXX','BUG ')
          HAZ=0.0
          GOTO9999
        ENDIF
        CALL GEVPDF(X,GAMMA,MINMAX,PDF)
        HAZ=PDF/(1.0 - CDF)
      ELSE
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
        IF(GAMMA.GT.0.0)THEN
          IF(X.LE.(-1.0/GAMMA))THEN
            WRITE(ICOUT,24)
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,46)X
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,47)GAMMA
            CALL DPWRST('XXX','BUG ')
            HAZ=0.0
            GOTO9999
          ENDIF
        ELSEIF(GAMMA.LT.0.0)THEN
          IF(X.GE.(-1.0/GAMMA))THEN
            WRITE(ICOUT,34)
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,46)X
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,47)GAMMA
            CALL DPWRST('XXX','BUG ')
            HAZ=0.0
            GOTO9999
          ENDIF
        ENDIF
   24   FORMAT('***** ERROR--THE FIRST  INPUT ARGUMENT TO GEVHAZ ',
     1         'IS LESS THAN -1/GAMMA.')
   34   FORMAT('***** ERROR--THE FIRST  INPUT ARGUMENT TO GEVHAZ ',
     1         'IS GREATER THAN -1/GAMMA.')
C
        DX=DBLE(X)
        DG=DBLE(GAMMA)
        DHAZ=0.D0
C
        IF(GAMMA.EQ.0.0)THEN
          DHAZ=DEXP(DX)
        ELSE
          DHAZ=(1.0D0+DX*DG)**((1.D0/DG)-1.0)
        END IF
        HAZ=REAL(DHAZ)
      ENDIF
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE GEVLI1(Y,N,MINMAX,ALOC,SCALE,SHAPE,
     1                  ALIK,AIC,AICC,BIC,
     1                  ISUBRO,IBUGA3,IERROR)
C
C     PURPOSE--THIS ROUTINE COMPUTES THE LIKELIHOOD FUNCTION FOR THE
C              GENERALIZED EXTREME VALUE DISTRIBUTION.  THIS IS FOR THE
C              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     REFERENCE--CASTILLO, HADI, BALAKRISHNAN, SARABIA, "EXTREME
C                VALUE AND RELATED MODELS WITH APPLICATIONS IN
C                ENGINEERING AND SCIENCE", WILEY, 2005.
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/07
C     ORIGINAL VERSION--JULY      2010.
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 DZ
      DOUBLE PRECISION DS
      DOUBLE PRECISION DU
      DOUBLE PRECISION DG
      DOUBLE PRECISION DN
      DOUBLE PRECISION DNP
      DOUBLE PRECISION DLIK
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DSUM2
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
C
C---------------------------------------------------------------------
C
      DIMENSION Y(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='WEIL'
      ISUBN2='I1  '
      IERROR='NO'
C
      ALIK=CPUMIN
      AIC=CPUMIN
      AICC=CPUMIN
      BIC=CPUMIN
C
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'VLI1')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,51)
   51   FORMAT('**** AT THE BEGINNING OF GEVLI1--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,52)IBUGA3,ISUBRO,N,ALOC,SCALE,SHAPE
   52   FORMAT('IBUGA3,ISUBRO,N,ALOC,SCALE,SHAPE = ',2(A4,2X),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.'VLI1')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IERFLG=0
      IERROR='NO'
      IWRITE='OFF'
C
C     FOR THE MAXIMUM CASE, THE LOG-LIKELIHOOD FUNCTION IS
C     (U = LOCATION, S = SCALE, G = SHAPE):
C
C        -N*LOG(S) - (1- G)*SUM[i=1 to N][Z(i)] - SUM[i=1 to N][EXP(-Z(i))]
C
C     WHERE
C
C        Z(i) = (1/G)*LOG(1 - G*(X(i) - U)/S)
C
C     FOR THE MINIMUM CASE, JUST TAKE X(I) = -X(I) AND USE ABOVE FORMULA.
C
C     IF SHAPE = 0, THEN LOG-LIKELIHOOD REDUCES TO
C
C        -N*LOG(S) - SUM[i=1 to N][(X(i)-U)/S] - SUM[i=1 to N][EXP(-(X(i)-U)/S)]
C
      DN=DBLE(N)
      DS=DBLE(SCALE)
      DU=DBLE(ALOC)
      DG=DBLE(SHAPE)
      IF(MINMAX.EQ.1)THEN
        DO100I=1,N
          Y(I)=-Y(I)
  100   CONTINUE
      ENDIF
C
      DTERM1=-DN*DLOG(DS)
      DTERM2=1.0D0 - DG
      DSUM1=0.0D0
      DSUM2=0.0D0
      IF(SHAPE.EQ.0.0)THEN
        DO1010I=1,N
          DX=DBLE((Y(I) - DU)/DS)
          DSUM1=DSUM1 + DX
          DSUM2=DSUM2 + DEXP(-DX)
 1010   CONTINUE
        DLIK=DTERM1 - DSUM1 - DSUM2
      ELSE
        DO1020I=1,N
          DX=DBLE(Y(I))
          DTERM3=1.0D0 - DG*(DX - DU)/DS
          IF(DTERM3.LE.0.0D0)THEN
            IERROR='YES'
            GOTO9000
          ENDIF
          DZ=-(1.0D0/DG)*DLOG(1.0D0 - DG*(DX - DU)/DS)
          DSUM1=DSUM1 + DZ
          DSUM2=DSUM2 + DEXP(-DZ)
 1020   CONTINUE
        DLIK=DTERM1 - DTERM2*DSUM1 - DSUM2
      ENDIF
C
      ALIK=REAL(DLIK)
      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
C     FOR MINIMUM CASE, CONVERT Y BACK TO ORIGINAL VALUES
C
      IF(MINMAX.EQ.1)THEN
        DO8010I=1,N
          Y(I)=-Y(I)
 8010   CONTINUE
      ENDIF
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'VLI1')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9011)
 9011   FORMAT('**** AT THE END OF GEVLI1--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9013)DSUM1,DSUM2,DTERM1,DTERM2,DTERM3
 9013   FORMAT('DSUM1,DSUM2,DTERM1,DTERM2,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 GEVML1(Y,N,MAXNXT,MINMAX,ICASPL,MLFLAG,IGEPDF,
     1                  ISEED,IDFTTY,IGEVML,
     1                  TEMP1,TEMP2,TEMP3,TEMP4,TEMP5,
     1                  DTEMP1,XMOM,NMOM,VARCOV,
     1                  XMEAN,XSD,XVAR,XMIN,XMAX,
     1                  ALOCLM,SCALLM,SHAPLM,
     1                  ALOCEP,SCALEP,SHAPEP,
     1                  ALOCML,SCALML,SHAPML,
     1                  ISUBRO,IBUGA3,IERROR)
C
C     PURPOSE--THIS ROUTINE COMPUTES THE MAXIMUM LIKELIHOOD ESTIMATES
C              FOR THE 3-PARAMETER GENERALIZED EXTREME VALUE
C              DISTRIBUTION FOR THE RAW DATA CASE (I.E., NO CENSORING
C              AND NO GROUPING).  THIS ROUTINE RETURNS ONLY THE POINT
C              ESTIMATES (CONFIDENCE INTERVALS WILL BE COMPUTED IN A
C              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 (DPMLW1 WILL GENERATE THE OUTPUT
C              FOR THE GENERALIZED EXTREME VALUE MLE COMMAND).
C
C              THE FOLLOWING METHODS ARE SUPPORTED:
C
C                  1) L-MOMENTS
C                  2) ELEMENTAL PERCENTILES
C                  3) MAXIMUM LIKELIHOOD
C
C               NOTE THAT L-MOMENT AND MAXIMUM LIKELIHOOD ARE ONLY
C               SUPOORTED FOR CERTAIN RANGES OF THE SHAPE PARAMETER.
C               ELEMENTAL PERCENTILES DOES NOT HAVE THIS RESTRICTION.
C
C               CURRENTLY HAVING SOME ISSUES GETTING THE ML CODE
C               TO WORK.
C
C     REFERENCE--JOHNSON, KOTZ, AND BALAKRISHNAN.  "CONTINUOUS
C                UNIVARIATE DISTRIBUTIONS, VOLUME I", SECOND
C                EDITION, WILEY, 1994, PP. 614-619.
C              --HOSKING, ALGORITHM AS215   APPL. STATIST. (1985)
C                VOL. 34, NO. 3, Modifications in AS R76 (1989)
C                have been incorporated.
C              --CASTILLO, HADI, BALAKRISHNAN, SARABIA, "EXTREME
C                VALUE AND RELATED MODELS WITH APPLICATIONS IN
C                ENGINEERING AND SCIENCE", WILEY, 2005.
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/07
C     ORIGINAL VERSION--JULY      2010. EXTRACTED AS A SEPARATE
C                                       SUBROUTINE (FROM DPMLGV)
C     UPDATED         --APRIL     2011. IDFTTY TO SUPPRESS MOMENT
C                                       OR ML METHODS
C     UPDATED         --OCTOBER   2014. IGEVML SWITCH
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DIMENSION Y(*)
      DIMENSION TEMP1(*)
      DIMENSION TEMP2(*)
      DIMENSION TEMP3(*)
      DIMENSION TEMP4(*)
      DIMENSION TEMP5(*)
      DOUBLE PRECISION DTEMP1(*)
      DOUBLE PRECISION XMOM(*)
      DOUBLE PRECISION XPAR(3)
      DOUBLE PRECISION VARCOV(*)
C
      CHARACTER*4 IGEPDF
      CHARACTER*4 IDFTTY
      CHARACTER*4 IGEVML
      CHARACTER*4 ICASPL
      CHARACTER*4 ISUBRO
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      LOGICAL MLFLAG
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='GEVM'
      ISUBN2='L1  '
      IERROR='NO'
      IWRITE='OFF'
C
      AN=REAL(N)
      ALOCLM=CPUMIN
      SCALLM=CPUMIN
      SHAPLM=CPUMIN
      ALOCEP=CPUMIN
      SCALEP=CPUMIN
      SHAPEP=CPUMIN
      ALOCML=CPUMIN
      SCALMO=CPUMIN
      SHAPML=CPUMIN
C
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'VML1')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,51)
   51   FORMAT('**** AT THE BEGINNING OF GEVML1--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,52)IBUGA3,ISUBRO,ICASPL,MINMAX
   52   FORMAT('IBUGA3,ISUBRO,ICASPL,MINMAX = ',3(A4,2X),I5)
        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 GENERALIZED EXTREME VALUE MLE ESTIMATE **
C               *************************************************
C
      ISTEPN='2'
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'VML1')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IDIST='GENERALIZED EXTREME VALUE'
      IFLAG=0
      CALL SUMRAW(Y,N,IDIST,IFLAG,
     1            XMEAN,XVAR,XSD,XMIN,XMAX,
     1            ISUBRO,IBUGA3,IERROR)
C
      IF(MINMAX.EQ.1)THEN
        DO2002I=1,N
          Y(I)=-Y(I)
 2002   CONTINUE
      ENDIF
      CALL SORT(Y,N,Y)
C
C     COMPUTE L-MOMENT ESTIMATORS
C
      NMOM=3
      DO2110I=1,N
        DTEMP1(I)=DBLE(Y(I))
 2110 CONTINUE
      CALL SAMLMU(DTEMP1,N,XMOM,NMOM)
      CALL GEVPEL(XMOM,XPAR)
      ALOCLM=REAL(XPAR(1))
      SCALLM=REAL(XPAR(2))
      SHAPLM=REAL(XPAR(3))
C
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'VML1')THEN
        WRITE(ICOUT,2012)ALOCLM,SCALLM,SHAPLM
 2012   FORMAT('ALOCLM,SCALLM,SHAPLM = ',3G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,52)IBUGA3,ISUBRO,MINMAX
      ENDIF
C
      ITEMP=2
      NSAMP=20*N
      IF(NSAMP.GT.5000)NSAMP=5000
      CALL DPEPM2(Y,N,ICASPL,MAXNXT,MINMAX,IGEPDF,
     1            ISEED,NSAMP,
     1            TEMP1,TEMP2,TEMP3,TEMP4,TEMP5,
     1            ALOCEP,SCALEP,SHAPEP,
     1            IBUGA3,ISUBRO,IERROR)
C
      IF(IDFTTY.EQ.'EPER')GOTO9000
C
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'VML1')THEN
        WRITE(ICOUT,2022)ALOCEP,SCALEP,SHAPEP
 2022   FORMAT('ALOCEP,SCALEP,SHAPEP = ',3G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,52)IBUGA3,ISUBRO,MINMAX
      ENDIF
C
      IF(SHAPLM.NE.CPUMIN)THEN
        XPAR(1)=DBLE(ALOCLM)
        XPAR(2)=DBLE(SCALLM)
        XPAR(3)=DBLE(SHAPLM)
      ELSE
        XPAR(1)=DBLE(ALOCEP)
        XPAR(2)=DBLE(SCALEP)
        XPAR(3)=DBLE(SHAPEP)
      ENDIF
C
C     NOTE: ONLY ATTEMP MLE IF L-MOMENT ESTIMATES IN THE
C           RANGE -0.5 TO 0.5.
C
C     NOTE: OUR EXPERIENCE WITH THE HOSKING ROUTINE IS THAT THE
C           ML ESTIMATES ARE NOT VERY STABLE.  SO SUPPRESS
C           UNLESS THE IGEVML SWITCH IS EXPLICITLY TURNED ON.
C
      IF(IGEVML.EQ.'OFF')GOTO9000
C
      IF(MLFLAG .AND. SHAPLM.GE.-0.5 .AND. SHAPLM.LE.0.5)THEN
        MONIT=0
CCCCC   MONIT=1
        IFAULT=0
        DO2130I=1,N
          DTEMP1(I)=DBLE(Y(I))
 2130   CONTINUE
C
        CALL MLEGEV(DTEMP1,N,XPAR,VARCOV,MONIT,IFAULT)
C
C       RETURN ML VALUES EVEN IF ERROR RETURNED FROM FIT
C       PROCEDURE
C
CCCCC   IF(IFAULT.EQ.0)THEN
          SHAPML=REAL(XPAR(3))
          SCALML=REAL(XPAR(2))
          ALOCML=REAL(XPAR(1))
CCCCC   ENDIF
C
        IF(IFAULT.EQ.1)THEN
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,1111)
 1111     FORMAT('****** ERROR IN GENERALIZED EXTREME VALUE ',
     1           'MAXIMUM LIKELIHOOD--')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,1013)N
 1013     FORMAT('      EXTREME VALUE REQUIRES N > 2.  N = ',I8)
          CALL DPWRST('XXX','BUG ')
          IERROR='YES'
        ELSEIF(IFAULT.EQ.2)THEN
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,1111)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,1023)
 1023     FORMAT('      MAXIMUM NUMBER OF ITERATIONS EXCEEDED.')
          CALL DPWRST('XXX','BUG ')
CCCCC     IERROR='YES'
        ELSEIF(IFAULT.EQ.3)THEN
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,1111)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,1033)
 1033     FORMAT('      MAXIMUM NUMBER OF EVALUATIONS FOR LOG ',
     1           'LIKELIHOOD EXCEEDED.')
          CALL DPWRST('XXX','BUG ')
          IERROR='YES'
        ELSEIF(IFAULT.EQ.4)THEN
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,1111)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,1043)
 1043     FORMAT('      MAXIMUM NUMBER OF STEP LENGTH REDUCTIONS ',
     1           'EXCEEDED.')
          CALL DPWRST('XXX','BUG ')
          IERROR='YES'
        ENDIF
      ENDIF
C
C     FOR MINIMUM CASE, NEED TO REVERSE SIGN OF LOCATION
C     ESTIMATE.  ALSO, CONVERT Y BACK TO ORIGINAL DATA.
C
      IF(MINMAX.EQ.1)THEN
        IF(ALOCLM.NE.CPUMIN)ALOCLM=-ALOCLM
        IF(ALOCEP.NE.CPUMIN)ALOCEP=-ALOCEP
        IF(ALOCML.NE.CPUMIN)ALOCML=-ALOCML
        DO8010I=1,N
          Y(I)=-Y(I)
 8010   CONTINUE
      ENDIF
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'VML1')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9011)
 9011   FORMAT('**** AT THE END OF GEVML1--')
        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)ALOCLM,SCALLM,SHAPLM
 9017   FORMAT('ALOCLM,SCALLM,SHAPLM =  ',3G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9018)ALOCEP,SCALEP,SHAPEP
 9018   FORMAT('ALOCEP,SCALEP,SHAPEP =  ',3G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9019)ALOCML,SCALML,SHAPML
 9019   FORMAT('ALOCML,SCALML,SHAPML =  ',3G15.7)
        CALL DPWRST('XXX','WRIT')
      ENDIF
C
      RETURN
      END
      SUBROUTINE GEVPDF(X,GAMMA,MINMAX,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE GENERALIZED EXTREME VALUE
C              DISTRIBUTION WITH SINGLE PRECISION
C              SHAPE PARAMETER = GAMMA.
C              THERE ARE TWO GENERALIZED EXTREME VALUE FAMALIES:
C              ONE BASED ON THE MAXIMUM ORDER STATISTIC (THE MOST
C              COMMONLY USED, SPECIFIED BY MINMAX=2) AND THE OTHER
C              BASED ON THE MINIMUM ORDER STATISTIC (SPECIFIED BY
C              SET MINMAX = 1).
C
C              THE PROBABILITY DENSITY FUNCTION FOR THE MAXIMUM CASE
C              OF THE GENERALIZED EXTREME VALUE DISTRIBUTION IS:
C              F(X,G) = EXP(-EXP(-X))*EXP(-X)        G = 0
C                     = EXP(-(1-G*X)**(1/G))*(1-G*X)**((1/G)-1) G<>0
C                                     X<=1/G   FOR G > 0
C                                     X>=1/G   FOR G < 0
C
C              THE PROBABILITY DENSITY FUNCTION FOR THE MINIMUM CASE
C              OF THE GENERALIZED EXTREME VALUE DISTRIBUTION IS:
C              F(X,G) = EXP(-EXP(X))*EXP(X)        G = 0
C                     = EXP(-(1+G*X)**(1/G))*(1+G*X)**((1/G)-1) G<>0
C                                     X>=1/G   FOR G > 0
C                                     X<=1/G   FOR G < 0
C
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE
C                                AT WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                     --GAMMA  = THE SINGLE PRECISION VALUE
C                                OF THE 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 GENERALIZED EXTREME VALUE
C             DISTRIBUTION WITH SHAPE PARAMETER VALUE = GAMMA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--RANGE OF X DEPENDS ON SIGN OF GAMMA
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, PAGES 75-76
C               --CASTILLO, HADI, BALAKRISHNAN, AND SARABIA,
C                 "EXTREME VALUE AND RELATED MODELS WITH APPLICATIONS
C                 IN ENGINEERING AND SCIENCE", WILEY, 2005, PP. 64-65.
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         --MAY       2005. SUPPORT FOR MINIMUM CASE
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX, DG
      DOUBLE PRECISION DPDF
      DOUBLE PRECISION DTERM1, DTERM2, DTERM3
C
      INCLUDE 'DPCOP2.INC'
C
C---------------------------------------------------------------------
C
C
C     MAY 2005.  HANDLE MIN AND MAX CASES SEPARATELY.
C
C     MAXIMUM CASE
C
      IF(MINMAX.EQ.2 .OR. MINMAX.EQ.0)THEN
C
C       CHECK THE INPUT ARGUMENTS FOR ERRORS
C
        IF(GAMMA.GT.0.0)THEN
          IF(X.GT.(1.0/GAMMA))THEN
            WRITE(ICOUT,4)
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,46)X
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,47)GAMMA
            CALL DPWRST('XXX','BUG ')
            PDF=0.0
            GOTO9999
          ENDIF
        ELSEIF(GAMMA.LT.0.0)THEN
          IF(X.LT.(1.0/GAMMA))THEN
            WRITE(ICOUT,14)
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,46)X
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,47)GAMMA
            CALL DPWRST('XXX','BUG ')
            PDF=0.0
            GOTO9999
          ENDIF
        ENDIF
    4   FORMAT('***** ERROR--THE FIRST  INPUT ARGUMENT TO GEVPDF ',
     1         'IS GREATER THAN 1/GAMMA.')
   14   FORMAT('***** ERROR--THE FIRST  INPUT ARGUMENT TO GEVPDF ',
     1         'IS LESS THAN 1/GAMMA.')
   46   FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
   47   FORMAT('***** THE VALUE OF GAMMA IS ',G15.7)
C
        DX=DBLE(X)
        DG=DBLE(GAMMA)
C
        IF(GAMMA.EQ.0.0)THEN
          DTERM1=-DX
          IF(ABS(DTERM1).GE.500.D0)THEN
            PDF=0.0
          ELSE
            DTERM2=-DEXP(-DX) - DX
            DPDF=0.D0
            IF(DABS(DTERM2).LE.500.D0)DPDF=DEXP(DTERM2)
            PDF=REAL(DPDF)
          ENDIF
        ELSE
          DTERM1=-(1.D0-DX*DG)**(1.D0/DG)
          DTERM2=((1.D0/DG)-1.D0)*DLOG(1.D0-DX*DG)
          DTERM3=DTERM1+DTERM2
          DPDF=0.D0
          IF(DABS(DTERM3).LE.500.D0)DPDF=DEXP(DTERM3)
          PDF=REAL(DPDF)
        END IF
C
C  MINIMUM CASE
C
      ELSE
C
C       CHECK THE INPUT ARGUMENTS FOR ERRORS
C
        IF(GAMMA.GT.0.0)THEN
          IF(X.LT.(-1.0/GAMMA))THEN
            WRITE(ICOUT,24)
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,46)X
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,47)GAMMA
            CALL DPWRST('XXX','BUG ')
            PDF=0.0
            GOTO9999
          ENDIF
        ELSEIF(GAMMA.LT.0.0)THEN
          IF(X.GT.(-1.0/GAMMA))THEN
            WRITE(ICOUT,34)
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,46)X
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,47)GAMMA
            CALL DPWRST('XXX','BUG ')
            PDF=0.0
            GOTO9999
          ENDIF
        ENDIF
   24   FORMAT('***** ERROR--THE FIRST  INPUT ARGUMENT TO GEVPDF ',
     1         'IS LESS THAN -1/GAMMA.')
   34   FORMAT('***** ERROR--THE FIRST  INPUT ARGUMENT TO GEVPDF ',
     1         'IS GREATER THAN -1/GAMMA.')
C
        DX=DBLE(X)
        DG=DBLE(GAMMA)
C
        IF(GAMMA.EQ.0.0)THEN
          DTERM1=-DX
          IF(ABS(DTERM1).GE.500.D0)THEN
            PDF=0.0
          ELSE
            DTERM2=-DEXP(DX) + DX
            DPDF=0.D0
            IF(DABS(DTERM2).LE.500.D0)DPDF=DEXP(DTERM2)
            PDF=REAL(DPDF)
          ENDIF
        ELSE
          DTERM1=-(1.D0+DX*DG)**(1.D0/DG)
          DTERM2=((1.D0/DG)-1.D0)*DLOG(1.D0+DX*DG)
          DTERM3=DTERM1+DTERM2
          DPDF=0.D0
          IF(DABS(DTERM3).LE.500.D0)DPDF=DEXP(DTERM3)
          PDF=REAL(DPDF)
        END IF
      ENDIF
C
 9999 CONTINUE
      RETURN
      END
C===================================================== PELGEV.FOR
      SUBROUTINE GEVPEL(XMOM,PARA)
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  PARAMETER ESTIMATION VIA L-MOMENTS FOR THE GENERALIZED EXTREME-VALUE
C  DISTRIBUTION
C
C  PARAMETERS OF ROUTINE:
C  XMOM   * INPUT* ARRAY OF LENGTH 3. CONTAINS THE L-MOMENTS LAMBDA-1,
C                  LAMBDA-2, TAU-3.
C  PARA   *OUTPUT* ARRAY OF LENGTH 3. ON EXIT, CONTAINS THE PARAMETERS
C                  IN THE ORDER XI, ALPHA, K (LOCATION, SCALE, SHAPE).
C
C  OTHER ROUTINES USED: DLGAMA (RENAMED TO: DLGADP)
C
C  METHOD: FOR  -0.8 LE TAU3 LT 1,  K IS APPROXIMATED BY RATIONAL
C  FUNCTIONS AS IN DONALDSON (1996, COMMUN. STATIST. SIMUL. COMPUT.).
C  IF TAU3 IS OUTSIDE THIS RANGE, NEWTON-RAPHSON ITERATION IS USED.
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DOUBLE PRECISION XMOM(3),PARA(3)
      DOUBLE PRECISION DLNGAM
      EXTERNAL DLNGAM
C
      INCLUDE 'DPCOP2.INC'
C
      DATA ZERO/0D0/,HALF/0.5D0/,ONE/1D0/,TWO/2D0/,THREE/3D0/
      DATA P8/0.8D0/,P97/0.97D0/
C
C         SMALL IS USED TO TEST WHETHER K IS EFFECTIVELY ZERO
C         EPS,MAXIT CONTROL THE TEST FOR CONVERGENCE OF N-R ITERATION
C
      DATA SMALL/1D-5/,EPS/1D-6/,MAXIT/20/
C
C         EU IS EULER'S CONSTANT
C         DL2 IS LOG(2), DL3 IS LOG(3)
C
      DATA EU/0.57721566D0/,DL2/0.69314718D0/,DL3/1.0986123D0/
C
C         COEFFICIENTS OF RATIONAL-FUNCTION APPROXIMATIONS FOR K
C
      DATA A0,A1,A2/ 0.28377530D0,-1.21096399D0,-2.50728214D0/
      DATA A3,A4   /-1.13455566D0,-0.07138022D0/
      DATA B1,B2,B3/ 2.06189696D0, 1.31912239D0, 0.25077104D0/
      DATA C1,C2,C3/ 1.59921491D0,-0.48832213D0, 0.01573152D0/
      DATA D1,D2   /-0.64363929D0, 0.08985247D0/
C
      T3=XMOM(3)
      IF(XMOM(2).LE.ZERO)THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,7000)
 7000   FORMAT('****** ERROR IN GENERALIZED EXTREME VALUE L-MOMENTS')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,7003)
 7003   FORMAT('       L-MOMENTS INVALID.')
        CALL DPWRST('XXX','BUG ')
        PARA(1)=CPUMIN
        PARA(2)=CPUMIN
        PARA(3)=CPUMIN
        GOTO9000
      ELSEIF(DABS(T3).GE.ONE)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,7000)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,7003)
        CALL DPWRST('XXX','BUG ')
        PARA(1)=CPUMIN
        PARA(2)=CPUMIN
        PARA(3)=CPUMIN
        GOTO9000
      ENDIF
C
C
      PARA(1)=0.0D0
      PARA(2)=1.0D0
      PARA(3)=0.0D0
      IF(T3.LE.ZERO)GOTO 10
C
C         RATIONAL-FUNCTION APPROXIMATION FOR TAU3 BETWEEN 0 AND 1
C
      Z=ONE-T3
      G=(-ONE+Z*(C1+Z*(C2+Z*C3)))/(ONE+Z*(D1+Z*D2))
      IF(DABS(G).LT.SMALL)GOTO 50
      GOTO 40
C
C         RATIONAL-FUNCTION APPROXIMATION FOR TAU3 BETWEEN -0.8 AND 0
C
   10 CONTINUE
      G=(A0+T3*(A1+T3*(A2+T3*(A3+T3*A4))))/(ONE+T3*(B1+T3*(B2+T3*B3)))
      IF(T3.GE.-P8)GOTO 40
C
C         NEWTON-RAPHSON ITERATION FOR TAU3 LESS THAN -0.8
C
      IF(T3.LE.-P97)G=ONE-DLOG(ONE+T3)/DL2
      T0=(T3+THREE)*HALF
      DO 20 IT=1,MAXIT
        X2=TWO**(-G)
        X3=THREE**(-G)
        XX2=ONE-X2
        XX3=ONE-X3
        T=XX3/XX2
        DERIV=(XX2*X3*DL3-XX3*X2*DL2)/(XX2*XX2)
        GOLD=G
        G=G-(T-T0)/DERIV
        IF(DABS(G-GOLD).LE.EPS*G)GOTO 30
   20 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,7000)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,7010)
 7010 FORMAT('****** WARNING FROM GENERALIZED EXTREME VALUE ',
     1      'L-MOMENTS')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,7013)
 7013 FORMAT('       ITERATION HAS NOT CONVERGED.  RESULTS MAY ',
     1       'BE UNRELIABLE.')
      CALL DPWRST('XXX','BUG ')
   30 CONTINUE
C
C         ESTIMATE ALPHA,XI
C
   40 CONTINUE
      PARA(3)=G
CCCCC GAM=DEXP(DLGAMA(ONE+G))
      GAM=DEXP(DLNGAM(ONE+G))
      PARA(2)=XMOM(2)*G/(GAM*(ONE-TWO**(-G)))
      PARA(1)=XMOM(1)-PARA(2)*(ONE-GAM)/G
      GOTO9000
C
C         ESTIMATED K EFFECTIVELY ZERO
C
   50 CONTINUE
      PARA(3)=ZERO
      PARA(2)=XMOM(2)/DL2
      PARA(1)=XMOM(1)-EU*PARA(2)
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE GEVPPF(P,GAMMA,MINMAX,PPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE GENERALIZED EXTREME VALUE
C              DISTRIBUTION WITH SINGLE PRECISION
C              SHAPE PARAMETER = GAMMA.
C              THERE ARE TWO GENERALIZED EXTREME VALUE FAMALIES:
C              ONE BASED ON THE MAXIMUM ORDER STATISTIC (THE MOST
C              COMMONLY USED, SPECIFIED BY MINMAX=2) AND THE OTHER
C              BASED ON THE MINIMUM ORDER STATISTIC (SPECIFIED BY
C              SET MINMAX = 1).
C
C              THE PERCENT POINT FUNCTION FOR THE MAXIMUM CASE
C              OF THE GENERALIZED EXTREME VALUE DISTRIBUTION IS:
C              G(P,G) = -LOG(-(LOG(P)))               G = 0
C                     = (1 - (-LOG(P)**G)/G           G <> 0
C
C              THE PERCENT POINT FUNCTION FOR THE MINIMUM CASE
C              OF THE GENERALIZED EXTREME VALUE DISTRIBUTION IS:
C              G(P,G) = LOG(-(LOG(1-P)))              G = 0
C                     = -(1 - (-LOG(1-P)**G)/G        G <> 0
C
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                     --GAMMA  = THE SINGLE PRECISION VALUE
C                                OF THE TAIL LENGTH PARAMETER.
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 GENERALIZED EXTREME VALUE DISTRIBUTION
C             WITH TAIL LENGTH PARAMETER VALUE = GAMMA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--GAMMA CAN HAVE ANY VALUE
C                 --P SHOULD BE BETWEEN 0.0 AND 1.0.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--LOG.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--2, 1994, PAGES 75-76
C               --CASTILLO, HADI, BALAKRISHNAN, AND SARABIA,
C                 "EXTREME VALUE AND RELATED MODELS WITH APPLICATIONS
C                 IN ENGINEERING AND SCIENCE", WILEY, 2005, PP. 64-65.
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         --MAY       2005. SUPPORT FOR MINIMUM CASE
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DPPF
      DOUBLE PRECISION DP
      DOUBLE PRECISION DG
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(GAMMA.EQ.0.0)THEN
        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
      ENDIF
C
      IF(MINMAX.EQ.2 .OR. MINMAX.EQ.0)THEN
        IF(GAMMA.GT.0.0)THEN
          IF(P.LE.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
        ELSE
          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
        ENDIF
      ELSE
        IF(GAMMA.GT.0.0)THEN
          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
        ELSE
          IF(P.LE.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
      ENDIF
C
    1 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO GEVPPF ',
     1'IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
C
      DP=DBLE(P)
      DG=DBLE(GAMMA)
      DPPF=0.0D0
C
      IF(MINMAX.EQ.2 .OR. MINMAX.EQ.0)THEN
        IF(GAMMA.EQ.0.0)THEN
           DPPF=-DLOG(-DLOG(DP))
        ELSE IF(GAMMA.GT.0.0.AND.P.EQ.1.0)THEN
           DPPF=1.0D0/DG
        ELSE IF(GAMMA.LT.0.0.AND.P.EQ.0.0)THEN
           DPPF=1.0D0/DG
        ELSE
           DPPF=(1.0D0 - (-DLOG(DP))**DG)/DG
        ENDIF
      ELSE
        IF(GAMMA.EQ.0.0)THEN
           DPPF=DLOG(-DLOG(1.0D0 - DP))
        ELSE IF(GAMMA.GT.0.0.AND.P.EQ.0.0)THEN
           DPPF=-1.0D0/DG
        ELSE IF(GAMMA.LT.0.0.AND.P.EQ.1.0)THEN
           DPPF=-1.0D0/DG
        ELSE
           DPPF=-(1.0D0 - (-DLOG(1.0D0 - DP))**DG)/DG
        ENDIF
      ENDIF
C
      PPF=REAL(DPPF)
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE GEVRAN(N,GAMMA,MINMAX,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE GENERALIZED EXTREME VALUE DISTRIBUTION
C              WITH TAIL LENGTH PARAMETER VALUE = GAMMA.
C              THERE ARE TWO GENERALIZED EXTREME VALUE FAMALIES:
C              ONE BASED ON THE MAXIMUM ORDER STATISTIC (THE MOST
C              COMMONLY USED, SPECIFIED BY MINMAX=2) AND THE OTHER
C              BASED ON THE MINIMUM ORDER STATISTIC (SPECIFIED BY
C              SET MINMAX = 1).
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                     --MINMAX = THE INTEGER VALUE WHICH SPECIFIES
C                                WHETHER THE MAXIMUM OR THE MINIMUM
C                                FAMILY IS BEING 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 GENERALIZED EXTREME VALUE 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     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--CASTILLO, HADI, BALAKRISHNAN, AND SARABIA,
C                 "EXTREME VALUE AND RELATED MODELS WITH APPLICATIONS
C                 IN ENGINEERING AND SCIENCE", WILEY, 2005, PP. 64-65.
C               --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--2, 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 (1977)
C     VERSION NUMBER--2001.10
C     ORIGINAL VERSION--OCTOBER   2001.
C     UPDATED         --MAY       2005. SUPPORT FOR MINIMUM CASE
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
    5 FORMAT('***** ERROR--THE NUMBER OF REQUESTED GENERALIZED ',
     1       'EXTREME VALUE')
    6 FORMAT('      RANDOM NUMBERS WAS NOT 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 GENERALIZED EXTREME VALUE DISTRIBUTION RANDOM NUMBERS
C     USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD.
C
      DO100I=1,N
        CALL GEVPPF(X(I),GAMMA,MINMAX,XTEMP)
        X(I)=XTEMP
  100 CONTINUE
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE GEXCDF(X,ALAM1,ALAM12,S,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE GENERALIZED EXPONENTIAL
C              DISTRIBUTION
C              THIS DISTRIBUTION IS DEFINED FOR ALL NON-NEGATIVE X,
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C              F(X) = (L1+L12*(1-EXP(-S*X)))*
C                     EXP[-L1*X-L12*X+(L12/S)*(1-EXP(-S*X))]
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C                     --ALAM1  = POSITIVE SHAPE PARAMETER
C                     --ALAM12 = POSITIVE SHAPE PARAMETER
C                     --S      = POSITIVE 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.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE NON-NEGATIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--DEXP, DLOG.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN.
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 2ND. ED., 1994, PAGES 555.
C               --RYU, "AN EXTENSION OF MARSHALL AND OLKIN'S BIVARIATE
C                 EXPONENTIAL DISTRIBUTION", JOURNAL OF THE AMERICAN
C                 STATISTICAL ASSOCIATION, 1993, PP. 1458-1465.
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--FEBRUARY  1996.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX, DLAM1, DLAM12, DS, DCDF
      DOUBLE PRECISION DTERM1
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,46)X
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9999
      ENDIF
      IF(ALAM1.LE.0.0)THEN
        WRITE(ICOUT,14)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9999
      ENDIF
      IF(ALAM12.LE.0.0)THEN
        WRITE(ICOUT,24)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9999
      ENDIF
      IF(S.LE.0.0)THEN
        WRITE(ICOUT,34)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9999
      ENDIF
    4 FORMAT('***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT ',
     1'TO THE GEXCDF SUBROUTINE IS NEGATIVE')
   14 FORMAT('***** FATAL DIAGNOSTIC--THE SECOND INPUT ARGUMENT ',
     1'TO THE GEXCDF SUBROUTINE IS NON-POSITIVE')
   24 FORMAT('***** FATAL DIAGNOSTIC--THE THIRD INPUT ARGUMENT ',
     1'TO THE GEXCDF SUBROUTINE IS NON-POSITIVE')
   34 FORMAT('***** FATAL DIAGNOSTIC--THE FOURTH INPUT ARGUMENT ',
     1'TO THE GEXCDF SUBROUTINE IS NON-POSITIVE')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
C-----START POINT-----------------------------------------------------
C
      DX=DBLE(X)
      DLAM1=DBLE(ALAM1)
      DLAM12=DBLE(ALAM12)
      DS=DBLE(S)
C
      IF(X.LE.0.0)THEN
        CDF=0.0
        GOTO9999
      ENDIF
C
      DTERM1=-DLAM1*X - DLAM12*DX + (DLAM12/DS)*(1.0D0-DEXP(-DS*DX))
      IF(DTERM1.LE.-65.0D0)THEN
        CDF=1.0
      ELSEIF(DTERM1.GE.65.D0)THEN
        CDF=1.0
        WRITE(ICOUT,101)X
        CALL DPWRST('XXX','BUG ')
      ELSE
        DCDF=1.0D0-DEXP(DTERM1)
        CDF=SNGL(DCDF)
      ENDIF
  101 FORMAT('***** FATAL DIAGNOSTIC--OVERFLOW IN GEXCDF ROUTINE ',
     1'FOR X = ',E15.7)
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE GEXPDF(X,ALAM1,ALAM12,S,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE GENERALIZED EXPONENTIAL
C              DISTRIBUTION
C              THIS DISTRIBUTION IS DEFINED FOR ALL NON-NEGATIVE X,
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C              F(X) = (L1+L12*(1-EXP(-S*X)))*
C                     EXP[-L1*X-L12*X+(L12/S)*(1-EXP(-S*X))]
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                     --ALAM1  = POSITIVE SHAPE PARAMETER
C                     --ALAM12 = POSITIVE SHAPE PARAMETER
C                     --S      = 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.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE NON-NEGATIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--DEXP, DLOG.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN.
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 2ND. ED., 1994, PAGES 555.
C               --RYU, "AN EXTENSION OF MARSHALL AND OLKIN'S BIVARIATE
C                 EXPONENTIAL DISTRIBUTION", JOURNAL OF THE AMERICAN
C                 STATISTICAL ASSOCIATION, 1993, PP. 1458-1465.
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--FEBRUARY  1996.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX, DLAM1, DLAM12, DS, DPDF
      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,46)X
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ENDIF
      IF(ALAM1.LE.0.0)THEN
        WRITE(ICOUT,14)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ENDIF
      IF(ALAM12.LE.0.0)THEN
        WRITE(ICOUT,24)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ENDIF
      IF(S.LE.0.0)THEN
        WRITE(ICOUT,34)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ENDIF
    4 FORMAT('***** FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT ',
     1'TO THE GEXPDF SUBROUTINE IS NEGATIVE')
   14 FORMAT('***** FATAL DIAGNOSTIC--THE SECOND INPUT ARGUMENT ',
     1'TO THE GEXPDF SUBROUTINE IS NON-POSITIVE')
   24 FORMAT('***** FATAL DIAGNOSTIC--THE THIRD INPUT ARGUMENT ',
     1'TO THE GEXPDF SUBROUTINE IS NON-POSITIVE')
   34 FORMAT('***** FATAL DIAGNOSTIC--THE FOURTH INPUT ARGUMENT ',
     1'TO THE GEXPDF SUBROUTINE IS NON-POSITIVE')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
C-----START POINT-----------------------------------------------------
C
      DX=DBLE(X)
      DLAM1=DBLE(ALAM1)
      DLAM12=DBLE(ALAM12)
      DS=DBLE(S)
C
      DTERM1=DLOG(DLAM1 + DLAM12*(1.0D0-DEXP(-DS*DX)))
      DTERM2=-DLAM1*X - DLAM12*DX + (DLAM12/DS)*(1.0D0-DEXP(-DS*DX))
      DTERM3=DTERM1+DTERM2
      IF(DTERM3.LE.-80.0D0)THEN
        PDF=0.0
        GOTO9999
      ELSEIF(DTERM3.GE.80.D0)THEN
        PDF=0.0
        WRITE(ICOUT,101)X
        CALL DPWRST('XXX','BUG ')
      ELSE
        DPDF=DEXP(DTERM3)
        PDF=SNGL(DPDF)
      ENDIF
  101 FORMAT('***** FATAL DIAGNOSTIC--OVERFLOW IN GEXPDF ROUTINE ',
     1'FOR X = ',E15.7)
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE GEXPPF(P,ALAM1,ALAM2,S,PPF)
C
C     PURPOSE         --PERCENT POINT FUNCTION FOR THE GENERALIZED
C                       EXPONENTIAL DISTRIBUTION.  USES A BISECTION
C                       METHOD.
C     INPUT  ARGUMENTS--P      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE PERCENT POINT
C                                FUNCTION IS TO BE EVALUATED.
C                     --ALAM1  = POSITIVE SHAPE PARAMETER
C                     --ALAM12 = POSITIVE SHAPE PARAMETER
C                     --S      = POSITIVE SHAPE PARAMETER
C     OUTPUT ARGUMENTS--PPF    = THE SINGLE PRECISION PERCENT POINT
C                                FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PERCENT POINT FUNCTION VALUE PPF
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE NON-NEGATIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--GEXCDF.
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, 2ND. ED., 1994, PAGES 555.
C               --RYU, "AN EXTENSION OF MARSHALL AND OLKIN'S BIVARIATE
C                 EXPONENTIAL DISTRIBUTION", JOURNAL OF THE AMERICAN
C                 STATISTICAL ASSOCIATION, 1993, PP. 1458-1465.
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--96/2
C     ORIGINAL VERSION--FEBRUARY  1996.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
      DATA EPS /0.0001/
      DATA SIG /1.0E-5/
      DATA ZERO /0./
      DATA MAXIT /50000/
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(ALAM1.LE.0.0)THEN
        WRITE(ICOUT,11)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ALAM1
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
        GOTO9999
      ENDIF
      IF(ALAM2.LE.0.0)THEN
        WRITE(ICOUT,12)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ALAM2
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
        GOTO9999
      ENDIF
      IF(S.LE.0.0)THEN
        WRITE(ICOUT,35)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)S
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
        GOTO9999
      ENDIF
C
    1 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ',
     1' GEXPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL')
   11 FORMAT('***** FATAL ERROR--THE 2ND INPUT ARGUMENT TO THE ',
     1' GEXPPF SUBROUTINE IS NON-POSITIVE.')
   12 FORMAT('***** FATAL ERROR--THE THIRD INPUT ARGUMENT TO THE ',
     1' GEXPPF SUBROUTINE IS NON-POSITIVE.')
   35 FORMAT('***** FATAL ERROR--THE FOURTH INPUT ARGUMENT TO THE ',
     1' GEXPPF SUBROUTINE IS NEGATIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
C  FIND BRACKETING INTERVAL.  USE 0.
C  AS INITIAL GUESS, INCREMENTS OF 10 AROUND IT.
C  AFTER SUCCESSFULLY FIND BRACKETING INTERVAL, THEN SWITCH TO
C  MORE EFFICIENT BISECTION METHOD.
C
      XINC=10.0
      XL=0.0
      ICOUNT=0
      MAXCNT=100000
C
   91 CONTINUE
      XR=XL+XINC
      IF(XL.LE.0.0)XL=0.0
      IF(XR.LE.0.0)XR=XL+1.0
      CALL GEXCDF(XL,ALAM1,ALAM2,S,CDFL)
      CALL GEXCDF(XR,ALAM1,ALAM2,S,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('***** FATAL ERROR--GEXPPF UNABLE TO FIND 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 GEXCDF(X,ALAM1,ALAM2,S,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
      IF(ABS(FCS).GT.EPS)THEN
        WRITE(ICOUT,130)
        CALL DPWRST('XXX','BUG ')
      ENDIF
  130 FORMAT('***** FATAL ERROR--GEXPPF ROUTINE DID NOT CONVERGE. ***')
      GOTO9999
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE GEXRAN(N,ALAM1,ALAM12,S,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE GENERALIZED EXPONENTIAL DISTRIBUTION
C              WITH SHAPE PARAMETERS = LAMBDA1, LAMBDA12, S.
C              THIS DISTRIBUTION IS DEFINED FOR ALL NON-NEGATIVE X,
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C              F(X) = (L1+L12*(1-EXP(-S*X)))*
C                     EXP[-L1*X-L12*X+(L12/S)*(1-EXP(-S*X))]
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --ALAM1  = THE SINGLE PRECISION VALUE OF THE
C                                LAMBDA1 SHAPE PARAMETER.
C                                ANU SHOULD BE A POSITIVE INTEGER.
C                     --ALAM12 = THE SINGLE PRECISION VALUE OF THE
C                                LAMBDA12 SHAPE PARAMETER.
C                     --S      = THE SINGLE PRECISION VALUE OF THE
C                                S 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 GENERALIZED EXPONENTIAL DISTRIBUTION
C             WITH SHAPE PARAMETER VALUES = ALAM1, ALAM12, AND S.
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                 --ANU 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 (1966)
C     VERSION NUMBER--2003.7
C     ORIGINAL VERSION--JULY      2003.
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 ')
        GOTO9999
      ENDIF
    5 FORMAT('***** FATAL ERROR--THE REQUESTED NUMBER OF GENERALIZED ',
     1       'EXPONENTIAL RANDOM NUMBERS IS NON-POSITIVE.')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8)
C
      IF(ALAM1.LE.0)THEN
        WRITE(ICOUT,15)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,16)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ALAM1
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ENDIF
   15 FORMAT('***** FATAL ERROR--THE FIRST SHAPE PARAMETER (LAMBDA1)')
   16 FORMAT('      FOR THE  GENERALIZED EXPONENTIAL RANDOM NUMBERS ',
     1       'IS NON-POSITIVE')
      IF(ALAM12.LE.0)THEN
        WRITE(ICOUT,25)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,26)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ALAM12
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ENDIF
   25 FORMAT('***** FATAL ERROR--THE SECOND SHAPE PARAMETER ',
     1      '(LAMBDA12) ')
   26 FORMAT('      FOR THE  GENERALIZED EXPONENTIAL RANDOM NUMBERS ',
     1       'IS NON-POSITIVE')
      IF(S.LE.0)THEN
        WRITE(ICOUT,35)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,36)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)S
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ENDIF
   35 FORMAT('***** FATAL ERROR--THE THIRD SHAPE PARAMETER (S) ')
   36 FORMAT('      FOR THE  GENERALIZED EXPONENTIAL RANDOM NUMBERS ',
     1       'IS NON-POSITIVE')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
C     GENERATE N UNIFORM (0,1) RANDOM NUMBERS;
C
      CALL UNIRAN(N,ISEED,X)
C
C     GENERATE N GENERALIZED EXPONENTIAL DISTRIBUTION RANDOM
C     NUMBERS USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD.
C
      DO100I=1,N
        CALL GEXPPF(X(I),ALAM1,ALAM12,S,XTEMP)
        X(I)=XTEMP
  100 CONTINUE
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE GGDCDF(X,ALPHA,C,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE GENERALIZED GAMMA DISTRIBUTION
C              WITH POSITIVE SHAPE PARAMETERS ALPHA AND C.
C              THIS DISTRIBUTION IS DEFINED FOR ALL NON-NEGATIVE 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,ALPAH,C) = GAMMAIP(X**C,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                     --C      = 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 GENERALIZED GAMMA DISTRIBUTION
C             WITH DEGREES OF FREEDOM PARAMETER = ANU.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE NON-NEGATIVE.
C                 --NU SHOULD BE A POSITIVE INTEGER VARIABLE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NORCDF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--DSQRT, DEXP.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1994, PAGE 417.
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--95/4
C     ORIGINAL VERSION--APRIL     1995.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX, DALPHA, DC
      DOUBLE PRECISION DTERM1
      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.LT.0.0)THEN
        WRITE(ICOUT,4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9999
      ENDIF
      IF(ALPHA.LE.0)THEN
        WRITE(ICOUT,15)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ALPHA
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9999
      ENDIF
      IF(C.EQ.0)THEN
        WRITE(ICOUT,16)
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9999
      ENDIF
    4 FORMAT('***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT ',
     1'TO THE GGDCDF SUBROUTINE IS NEGATIVE *****')
   15 FORMAT('***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE ',
     1'GGDCDF SUBROUTINE IS NON-POSITIVE *****')
   16 FORMAT('***** FATAL ERROR--THE THIRD INPUT ARGUMENT TO THE ',
     1'GGDCDF SUBROUTINE IS ZERO *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
      IF(X.LE.R1MACH(1))THEN
        CDF=0.0
        RETURN
      ENDIF
C
      DX=DBLE(X)
      DALPHA=DBLE(ALPHA)
      DC=DBLE(C)
C
      DTERM1=DX**DC
      DCDF=DGAMIP(DALPHA,DTERM1)
      IF(C.LT.0)DCDF=1.0D0-DCDF
      CDF=REAL(DCDF)
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE GG2CDF(DX,DALPHA,DC,DCDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE GENERALIZED GAMMA DISTRIBUTION
C              WITH POSITIVE SHAPE PARAMETERS ALPHA AND C.
C              THIS DISTRIBUTION IS DEFINED FOR ALL NON-NEGATIVE 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,ALPAH,C) = GAMMAIP(X**C,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                     --C      = 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 GENERALIZED GAMMA DISTRIBUTION
C             WITH DEGREES OF FREEDOM PARAMETER = ANU.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE NON-NEGATIVE.
C                 --NU SHOULD BE A POSITIVE INTEGER VARIABLE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NORCDF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--DSQRT, DEXP.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1994, PAGE 417.
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--95/4
C     ORIGINAL VERSION--APRIL     1995.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX, DALPHA, DC
      DOUBLE PRECISION DTERM1
      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(DX.LT.0.0D0)THEN
        WRITE(ICOUT,4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)DX
        CALL DPWRST('XXX','BUG ')
        DCDF=0.0
        GOTO9999
      ENDIF
      IF(DALPHA.LE.0.0D0)THEN
        WRITE(ICOUT,15)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)DALPHA
        CALL DPWRST('XXX','BUG ')
        DCDF=0.0D0
        GOTO9999
      ENDIF
      IF(DC.EQ.0.0D0)THEN
        WRITE(ICOUT,16)
        CALL DPWRST('XXX','BUG ')
        DCDF=0.0D0
        GOTO9999
      ENDIF
    4 FORMAT('***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT ',
     1'TO THE GGDCDF SUBROUTINE IS NEGATIVE *****')
   15 FORMAT('***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE ',
     1'GGDCDF SUBROUTINE IS NON-POSITIVE *****')
   16 FORMAT('***** FATAL ERROR--THE THIRD INPUT ARGUMENT TO THE ',
     1'GGDCDF SUBROUTINE IS ZERO *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',D15.8,' *****')
C
      IF(DX.LE.D1MACH(1))THEN
        DCDF=0.0D0
        RETURN
      ENDIF
C
      DTERM1=DX**DC
      DCDF=DGAMIP(DALPHA,DTERM1)
      IF(DC.LT.0.0D0)DCDF=1.0D0-DCDF
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE GGDCHA(X,ALPHA,C,HAZ)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE HAZARD
C              FUNCTION VALUE FOR THE GENERALIZED GAMMA DISTRIBUTION
C              WITH POSITIVE SHAPE PARAMETERS ALPHA AND C.
C              THIS DISTRIBUTION IS DEFINED FOR ALL NON-NEGATIVE X.
C              THE PDF FOR THE STANDARD FORM OF THE DISTRIBUTION IS
C                  F(X,ALPAH,C) = C*X**(C*ALPHA-1)*EXP(-(X**C))/
C                                   GAMMA(ALPHA)
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE CUMULATIVE HAZARD
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE NON-NEGATIVE.
C                     --ALPHA  = A POSITIVE SHAPE PARAMETER
C                     --C      = A SHAPE PARAMETER
C     OUTPUT ARGUMENTS--PDF    = THE SINGLE PRECISION CUMULATIVE HAZARD
C                                FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION HAZARD
C             FUNCTION VALUE PDF FOR THE GENERALIZED GAMMA DISTRIBUTION
C             WITH SHAPE PARAMETERS C AND ALPHA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE NON-NEGATIVE.
C                 --ALPHA AND C SHOULD BE POSITIVE NUMBERS.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1994, PAGE 388.
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--98/4
C     ORIGINAL VERSION--APRIL     1998.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX, DALPHA, DC
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DCDF
      DOUBLE PRECISION DGAMIP
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.LT.0.0)THEN
        WRITE(ICOUT,4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        HAZ=0.0
        GOTO9999
      ENDIF
      IF(ALPHA.LE.0)THEN
        WRITE(ICOUT,15)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ALPHA
        CALL DPWRST('XXX','BUG ')
        HAZ=0.0
        GOTO9999
      ENDIF
      IF(C.EQ.0)THEN
        WRITE(ICOUT,16)
        CALL DPWRST('XXX','BUG ')
        HAZ=0.0
        GOTO9999
      ENDIF
    4 FORMAT('***** FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT ',
     1'TO THE GGDHAZ SUBROUTINE IS NEGATIVE *****')
   15 FORMAT('***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE ',
     1'GGDHAZ SUBROUTINE IS NON-POSITIVE *****')
   16 FORMAT('***** FATAL ERROR--THE THIRD INPUT ARGUMENT TO THE ',
     1'GGDHAZ SUBROUTINE IS ZERO *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
      IF(X.LE.R1MACH(1))THEN
        DCDF=0.0D0
      ELSE
C
        DX=DBLE(X)
        DALPHA=DBLE(ALPHA)
        DC=DBLE(C)
        DTERM1=DX**DC
        DCDF=DGAMIP(DALPHA,DTERM1)
        IF(C.LT.0)DCDF=1.0D0-DCDF
      ENDIF
      DCDF=1.0D0-DCDF
      IF(DCDF.NE.0.0D0)THEN
        HAZ=REAL(-DLOG(DCDF))
      ELSE
        WRITE(ICOUT,9969)X
        CALL DPWRST('XXX','BUG ')
        HAZ=0.0
      ENDIF
 9969 FORMAT('*****WARNING: FOR ARGUMENT = ',F15.7,' CDF TERM ',
     1'ESSENTIALLY 1, VALUE SET TO 0')
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE GGDHAZ(X,ALPHA,C,HAZ)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE HAZARD
C              FUNCTION VALUE FOR THE GENERALIZED GAMMA DISTRIBUTION
C              WITH POSITIVE SHAPE PARAMETERS ALPHA AND C.
C              THIS DISTRIBUTION IS DEFINED FOR ALL NON-NEGATIVE X.
C              THE PDF FOR THE STANDARD FORM OF THE DISTRIBUTION IS
C                  F(X,ALPAH,C) = C*X**(C*ALPHA-1)*EXP(-(X**C))/
C                                   GAMMA(ALPHA)
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE HAZARD
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE NON-NEGATIVE.
C                     --ALPHA  = A POSITIVE SHAPE PARAMETER
C                     --C      = A SHAPE PARAMETER
C     OUTPUT ARGUMENTS--PDF    = THE SINGLE PRECISION HAZARD
C                                FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION HAZARD
C             FUNCTION VALUE PDF FOR THE GENERALIZED GAMMA DISTRIBUTION
C             WITH SHAPE PARAMETERS C AND ALPHA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE NON-NEGATIVE.
C                 --ALPHA AND C SHOULD BE POSITIVE NUMBERS.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1994, PAGE 388.
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--98/4
C     ORIGINAL VERSION--APRIL     1998.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX, DALPHA, DC
      DOUBLE PRECISION DCDF
      DOUBLE PRECISION DGAMIP
      DOUBLE PRECISION DTERM1, DTERM2, DTERM3, DTERM4, DTERM5
      DOUBLE PRECISION DPDF
      DOUBLE PRECISION DLNGAM
      DOUBLE PRECISION DUL
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.LT.0.0)THEN
        WRITE(ICOUT,4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        HAZ=0.0
        GOTO9999
      ENDIF
      IF(ALPHA.LE.0)THEN
        WRITE(ICOUT,15)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ALPHA
        CALL DPWRST('XXX','BUG ')
        HAZ=0.0
        GOTO9999
      ENDIF
      IF(C.EQ.0)THEN
        WRITE(ICOUT,16)
        CALL DPWRST('XXX','BUG ')
        HAZ=0.0
        GOTO9999
      ENDIF
    4 FORMAT('***** FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT ',
     1'TO THE GGDHAZ SUBROUTINE IS NEGATIVE *****')
   15 FORMAT('***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE ',
     1'GGDHAZ SUBROUTINE IS NON-POSITIVE *****')
   16 FORMAT('***** FATAL ERROR--THE THIRD INPUT ARGUMENT TO THE ',
     1'GGDHAZ SUBROUTINE IS ZERO *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
      IF(X.LE.R1MACH(1))THEN
        DCDF=0.0D0
      ELSE
C
        DX=DBLE(X)
        DALPHA=DBLE(ALPHA)
        DC=DBLE(C)
        DTERM1=DX**DC
        DCDF=DGAMIP(DALPHA,DTERM1)
        IF(C.LT.0)DCDF=1.0D0-DCDF
      ENDIF
      DCDF=1.0D0-DCDF
      IF(DCDF.NE.0.0D0)THEN
        IF(X.LE.R1MACH(1))THEN
          DPDF=0.0D0
        ELSE
C
          DX=DBLE(X)
          DALPHA=DBLE(ALPHA)
          DC=DBLE(C)
C
          DUL=D1MACH(2)
          IF(C.GE.1.0)THEN
            IF(DX.GT.DUL**(1.0D0/DC))THEN
              WRITE(ICOUT,106)
              CALL DPWRST('XXX','BUG ')
              WRITE(ICOUT,46)X
              CALL DPWRST('XXX','BUG ')
              DPDF=0.0
            ENDIF
          ELSEIF(C.GT.0.0.AND.C.LT.1.0)THEN
            IF(DX.GT.DUL**DC)THEN
              WRITE(ICOUT,106)
              CALL DPWRST('XXX','BUG ')
              WRITE(ICOUT,46)X
              CALL DPWRST('XXX','BUG ')
              DPDF=0.0
            ENDIF
          ELSE
            CONTINUE
          ENDIF
  106 FORMAT('***** FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT ',
     1'TO THE GGDPDF SUBROUTINE GENERATES AN INVALID VALUE *****')
C
          DTERM1=DLOG(DABS(DC))
          DTERM2=(DC*DALPHA-1.0D0)*DLOG(DX)
          DTERM3=-(DX**DC)
          DTERM4=DLNGAM(DALPHA)
          DTERM5=DTERM1+DTERM2+DTERM3-DTERM4
          DPDF=0.0D0
          IF(DTERM5.GE.-80.0D0)DPDF=DEXP(DTERM5)
        ENDIF
        HAZ=REAL(DPDF/DCDF)
      ELSE
        WRITE(ICOUT,9969)X
        CALL DPWRST('XXX','BUG ')
        HAZ=0.0
      ENDIF
 9969 FORMAT('*****WARNING: FOR ARGUMENT = ',F15.7,' CDF TERM ',
     1'ESSENTIALLY 1, VALUE SET TO 0')
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE GGDFUN (N, X, FVEC, IFLAG, XDATA, NOBS)
C
C     PURPOSE--THIS ROUTINE COMPUTES THE FUNCTIONS FOR THE
C              GENERALIZED GAMMA MOMENT EQUATIONS.
C
C              A*(GAMMA(K+1/C))**2 - GAMMA(K+2/C)*GAMMA(K) = 0
C
C              XBAR - GAMMA(K+1/C)/(ALPHA*GAMMA(K)) = 0
C
C              SUM[i=1 to n][X(i)**C] - N*K/(ALPHA**C)
C
C              WHERE
C
C
C              ALPHA = 1/SCALE
C              C, K  = SHAPE PARAMETERS
C              A = {N*XBAR**2 + (N-1)*S**2}/{N*XBAR**2 - S**2)
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--GENERALIZED GAMMA MAXIMUM LIKELIHOOD Y
C     REFERENCE--HWANG AND HUANG (2006), "ON NEW MOMENT ESTIMATION
C                OF PARAMETERS OF THE GENERALIZED GAMMA DISTRIBUTION
C                USING IT'S CHARACTERIZATION", TAIWANESE JOURNAL OF
C                MATHEMATICS, VOL.10, NO. 4, PP. 1083-1093.
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/1
C     ORIGINAL VERSION--JANUARY   2007.
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION X(*)
      DOUBLE PRECISION FVEC(*)
      REAL XDATA(*)
C
      DOUBLE PRECISION DN
      DOUBLE PRECISION DX
      DOUBLE PRECISION DC
      DOUBLE PRECISION DK
      DOUBLE PRECISION DALPHA
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
      DOUBLE PRECISION DTERM4
      DOUBLE PRECISION DTERM5
C
      DOUBLE PRECISION DLNGAM
      EXTERNAL DLNGAM
      DOUBLE PRECISION DGAMMA
      EXTERNAL DGAMMA
C
      DOUBLE PRECISION XBAR
      DOUBLE PRECISION S2
      DOUBLE PRECISION DA
      COMMON/GGDCOM/XBAR,S2,DA
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C  COMPUTE SOME SUMS
C
      N=2
      IFLAG=0
C
      DC=X(1)
      DK=X(2)
      DALPHA=X(3)
      DN=DBLE(NOBS)
C
      DSUM1=0.0D0
C
      DO200I=1,NOBS
        DX=DBLE(XDATA(I))
        DSUM1=DSUM1 + DX**DC
  200 CONTINUE
C
      DTERM1=DLNGAM(DK)
      DTERM2=DLNGAM(DK + 1.0D0/DC)
      DTERM3=DLNGAM(DK + 2.0D0/DC)
C
      DTERM4=DLOG(DA) + 2.0D0*DTERM2
      DTERM5=DTERM3 + DTERM1
      FVEC(1)=DEXP(DTERM4) - DEXP(DTERM5)
      FVEC(2)=XBAR - DEXP(DTERM2 - DLOG(DALPHA) - DTERM1)
      FVEC(3)=DSUM1 - (DN*DK)/(DALPHA**DC)
C
CCCCC FVEC(1)=DA*DGAMMA(DK+1.0D0/DC)**2 -
CCCCC1        DGAMMA(DK+2.0D0/DC)*DGAMMA(DK)
CCCCC FVEC(2)=XBAR - DGAMMA(DK+1.0D0/DC)/(DALPHA*DGAMMA(DK))
CCCCC FVEC(3)=DSUM1 - (DN*DK)/(DALPHA**DC)
CCCCC print *,'fvec(1)=',fvec(1)
CCCCC print *,'fvec(2)=',fvec(2)
CCCCC print *,'fvec(3)=',fvec(3)
C
      RETURN
      END
      SUBROUTINE GGDPDF(X,ALPHA,C,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE GENERALIZED GAMMA DISTRIBUTION
C              WITH POSITIVE SHAPE PARAMETERS ALPHA AND C.
C              THIS DISTRIBUTION IS DEFINED FOR ALL NON-NEGATIVE X.
C              THE PDF FOR THE STANDARD FORM OF THE DISTRIBUTION IS
C                  F(X,ALPAH,C) = C*X**(C*ALPHA-1)*EXP(-(X**C))/
C                                   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                     --C      = 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 GENERALIZED GAMMA DISTRIBUTION
C             WITH SHAPE PARAMETERS C AND ALPHA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE NON-NEGATIVE.
C                 --ALPHA AND C SHOULD BE POSITIVE NUMBERS.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1994, PAGE 388.
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--95/4
C     ORIGINAL VERSION--APRIL     1995.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX, DALPHA, DC
      DOUBLE PRECISION DTERM1, DTERM2, DTERM3, DTERM4, DTERM5
      DOUBLE PRECISION DPDF
      DOUBLE PRECISION DLNGAM
      DOUBLE PRECISION DUL
C
C---------------------------------------------------------------------
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.LT.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
      IF(C.EQ.0)THEN
        WRITE(ICOUT,16)
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ENDIF
    4 FORMAT('***** FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT ',
     1'TO THE GGDPDF SUBROUTINE IS NEGATIVE *****')
   15 FORMAT('***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE ',
     1'GGDPDF SUBROUTINE IS NON-POSITIVE *****')
   16 FORMAT('***** FATAL ERROR--THE THIRD INPUT ARGUMENT TO THE ',
     1'GGDPDF SUBROUTINE IS ZERO *****')
   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)
      DC=DBLE(C)
C
      DUL=D1MACH(2)
      IF(C.GE.1.0)THEN
        IF(DX.GT.DUL**(1.0D0/DC))THEN
          WRITE(ICOUT,106)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,46)X
          CALL DPWRST('XXX','BUG ')
          PDF=0.0
          GOTO9999
        ENDIF
      ELSEIF(C.GT.0.0.AND.C.LT.1.0)THEN
        IF(DX.GT.DUL**DC)THEN
          WRITE(ICOUT,106)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,46)X
          CALL DPWRST('XXX','BUG ')
          PDF=0.0
          GOTO9999
        ENDIF
      ELSE
        CONTINUE
      ENDIF
  106 FORMAT('***** FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT ',
     1'TO THE GGDPDF SUBROUTINE GENERATES AN INVALID VALUE *****')
C
      DTERM1=DLOG(DABS(DC))
      DTERM2=(DC*DALPHA-1.0D0)*DLOG(DX)
      DTERM3=-(DX**DC)
      DTERM4=DLNGAM(DALPHA)
      DTERM5=DTERM1+DTERM2+DTERM3-DTERM4
      DPDF=0.0D0
      IF(DTERM5.GE.-80.0D0)DPDF=DEXP(DTERM5)
      PDF=REAL(DPDF)
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE GGDPPF(P,ALPHA,C,PPF)
C
C     PURPOSE   --PERCENT POINT FUNCTION FOR THE GENERALIZED 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/4
C     ORIGINAL VERSION--APRIL     1995.
C     UPDATED         --MARCH     2004. MAKE DOUBLE PRECISION
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DP
      DOUBLE PRECISION DC
      DOUBLE PRECISION DALPHA
      DOUBLE PRECISION EPS
      DOUBLE PRECISION SIG
      DOUBLE PRECISION ZERO
      DOUBLE PRECISION DMEAN
      DOUBLE PRECISION DSD
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      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 DLNGAM
C
      INCLUDE 'DPCOP2.INC'
C
      DATA EPS /0.0001D0/
      DATA SIG /1.0D-5/
      DATA ZERO /0.0D0/
      DATA MAXIT /3000/
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      PPF=0.0
      DMEAN=0.0D0
C
      IF(P.LT.0.0.OR.P.GE.1.0)THEN
        WRITE(ICOUT,1)
    1   FORMAT('***** ERROR--THE FIRST ARGUMENT TO GGDPPF ',
     1         'IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)P
   46   FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7,'.')
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ELSEIF(ALPHA.LE.0)THEN
        WRITE(ICOUT,15)
   15   FORMAT('***** ERROR--THE SECOND ARGUMENT TO GGDPPF ',
     1         'IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ALPHA
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ELSEIF(C.EQ.0)THEN
        WRITE(ICOUT,16)
   16   FORMAT('***** ERROR--THE THIRD ARGUMENT TO GGDPPF ',
     1         'IS ZERO.')
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
C
      IF(P.EQ.0.)THEN
        PPF=0.
        GOTO9999
      ENDIF
C
C  FIND BRACKETING INTERVAL.
C
      DP=DBLE(P)
      DALPHA=DBLE(ALPHA)
      DC=DBLE(C)
C
      XL=0.0D0
      IF(DC.LE.0.0D0)THEN
        XINC=5.0
        XR=XL+XINC
      ELSE
        DMEAN=DEXP(DLNGAM(DALPHA+1.0D0/DC) - DLNGAM(DALPHA))
        XR=DMEAN
        DTERM1=DEXP(DLNGAM(DALPHA+2.0D0/DC) - DLNGAM(DALPHA))
        DTERM2=2.0D0*(DLNGAM(DALPHA+1.0D0/DC) - DLNGAM(DALPHA))
        DSD=DTERM1 - DEXP(DTERM2)
        DSD=DSQRT(DSD)
        XINC=DSD
      ENDIF
      ICOUNT=0
      MAXCNT=10000
C
   91 CONTINUE
      IF(XL.LE.0.0D0)XL=0.0D0
      IF(XR.LE.0.0D0)XR=XL+DMEAN
      CALL GG2CDF(XL,DALPHA,DC,CDFL)
      CALL GG2CDF(XR,DALPHA,DC,CDFR)
      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('***** FATAL ERROR--GGDPPF 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
      CALL GG2CDF(X,DALPHA,DC,DCDF)
      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('***** FATAL ERROR--GGDPPF ROUTINE DID NOT CONVERGE. ***')
      GOTO9999
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE GGDRAN(N,ALPHA,C,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE GENERALIZED GAMMA DISTRIBUTION
C              WITH SHAPE PARAMETERS GAMMA AND C.
C              THIS DISTRIBUTION IS DEFINED FOR ALL POSITIVE X,
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C              F(X) = C*X**(ALPHA*C-1)*EXP((-X)**C)/GAMMA(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                                FIRST SHAPE PARAMETER.
C                                ALPHA SHOULD BE POSITIVE.
C                     --C      = THE SINGLE PRECISION VALUE OF THE
C                                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 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                 --ALPHA SHOULD BE POSITIVE.
C                 --C NOT EQUAL TO 0.
C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN
C     FORTRAN LIBRARY SUBROUTINES NEEDED--EXP.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JAMES E. GENTLE (2003). 'RANDOM NUMBER GENERATION
C                 AND MONTE CARLO METHODS', SPRINGER-VERLANG.
C                 USE HIS SUGGESTED METHOD OF OBTANING A GAMMA
C                 RANDOM VARIABLE AND EXPONENTIATING.
C               --"NON-UNIFORM RANDOM VARIATE GENERATION",
C                 LUC DEVROYE, SPRINGER-VERLAG, 1986, P. 423.
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--2003/9
C     ORIGINAL VERSION--SEPTEMBER 2003.
C     FIXED           --APRIL     2004. EXPONENTIATE BY (1/C), NOT C.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
C
CCCCC DIMENSION XN(2)
CCCCC DIMENSION U(2)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----DATA STATEMENTS-------------------------------------------------
C
CCCCC DATA ATHIRD/0.3333333/
CCCCC DATA SQRT3 /1.73205081/
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 GENERALIZED ',
     1         'GAMMA 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(ALPHA.LE.0)THEN
        WRITE(ICOUT,15)
   15   FORMAT('***** ERROR--THE ALPHA SHAPE PARAMETER FOR THE ',
     1         'GENERALIZED GAMMA RANDOM NUMBERS IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ALPHA
   46   FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7,'.')
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ELSEIF(C.EQ.0)THEN
        WRITE(ICOUT,16)
   16   FORMAT('***** ERROR--THE C SHAPE PARAMETER FOR THE ',
     1         'GENERALIZED GAMMA RANDOM NUMBERS IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)C
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
C
C     GENERATE N GAMMA DISTRIBUTION RANDOM NUMBERS
C     USING AHRENS-DIETER METHOD AND THEN EXPONENTIATE BY (1/C).
C
      CALL UNIRAN(N,ISEED,X)
      DO100I=1,N
        ATEMP=SGAMMA(ISEED,ALPHA)
        X(I)=ATEMP**(1.0/C)
CCCCC   ATEMP=X(I)
CCCCC   CALL GGDPPF(ATEMP,ALPHA,C,APPF)
CCCCC   X(I)=APPF
  100 CONTINUE
C
 9999 CONTINUE
C
      RETURN
      END
      FUNCTION GFUNCT(X,NOBS,BETA,XGM)
C
C COMPUTE G FUNCTION USED IN ESTIMATING THE SHAPE PARAMETER (BETA)
C   XGM IS THE GEOMETRIC MEAN OF THE X'S USED IN ESTIMATING ALPHA
C
      DIMENSION X(*)
C
      RN=FLOAT(NOBS)
C
      ALPHA=FNALPH(X,NOBS,BETA,XGM)
      SUMYZ=0.0
      DO 10 I=1,NOBS
           SUMYZ=SUMYZ+LOG(X(I))*((X(I)/ALPHA)**BETA-1.)
   10 CONTINUE
C
      GFUNCT=(SUMYZ/RN)-1.0/BETA
C
      RETURN
      END
      SUBROUTINE GHCDF(X,G,H,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE G-H DISTRIBUTION
C              WITH SHAPE PARAMETERS G AND H.
C              THIS DISTRIBUTION IS DEFINED FOR ALL X AND THE
C              CUMULATIVE DISTRIBUTION FUNCTION IS COMPUTED BY
C              NUMERICALLY INVERTING THE PPF FUNCTION.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C                     --G      = THE SKEWNESS SHAPE PARAMETER
C                     --H      = THE KURTOSIS 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--FZERO.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--HOAGLIN, 'SUMMARIZING SHAPES NUMERICALLY: THE
C                 G-AND-H DISTRIBUTION", IN "EXPLORING DATA TABLES,
C                 TRENDS AND SHAPES", HOAGLIN, MOSTELLER, TUKEY,
C                 WILEY, 1985.
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 CDF
      REAL G
      REAL H
      REAL PLOW
      REAL PUP
      REAL XLOW
      REAL XUP
C
      REAL GHFU2
      EXTERNAL GHFU2
C
      REAL X2
      COMMON/GH2COM/X2
C
      REAL G2
      REAL H2
      COMMON/GHCOM/G2,H2
C
      DOUBLE PRECISION DP
      DOUBLE PRECISION DPPF
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      CDF=0.0
      XUP=0.0
      XLOW=0.0
      IF(H.LT.0.0)THEN
        WRITE(ICOUT, 7)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,48)H
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
    7 FORMAT('***** ERROR--THE THIRD (H) INPUT ARGUMENT TO THE ',
     1'GHCDF SUBROUTINE IS NEGATIVE *****')
   48 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',F15.7,' *****')
C
C  IF G AND H BOTH ZERO, USE NORCDF.
C
      IF(G.EQ.0.0 .AND. H.EQ.0.0)THEN
        CALL NORCDF(X,CDF)
        GOTO9000
      ENDIF
C
C  STEP 1: FIND BRACKETING INTERVAL.
C
C
      DP=-1.0D0
      CALL GHPPF(0.01,G,H,XCDF01,DP,DPPF)
      IF(X.LT.XCDF01)THEN
        PLOW=0.0000001
        DP=-1.0D0
        CALL GHPPF(PLOW,G,H,XLOW,DP,DPPF)
        IF(X.LT.XLOW)THEN
          CDF=0.0
          GOTO9000
        ENDIF
        PUP=0.015
        GOTO1000
      ENDIF
      DP=-1.0D0
      CALL GHPPF(0.1,G,H,XCDF1,DP,DPPF)
      IF(X.GE.XCDF01 .AND. X.LE.XCDF1)THEN
        PLOW=0.005
        PUP=0.15
        GOTO1000
      ENDIF
      DP=-1.0D0
      CALL GHPPF(0.9,G,H,XCDF9,DP,DPPF)
      IF(X.GE.XCDF1 .AND. X.LE.XCDF9)THEN
        PLOW=0.05
        PUP=0.95
        GOTO1000
      ENDIF
      DP=-1.0D0
      CALL GHPPF(0.95,G,H,XCDF95,DP,DPPF)
      IF(X.GE.XCDF95)THEN
        PUP=0.9999999
        DP=-1.0D0
        CALL GHPPF(PUP,G,H,XUP,DP,DPPF)
        IF(X.GT.XUP)THEN
          CDF=1.0
          GOTO9000
        ENDIF
        PLOW=0.945
        GOTO1000
      ELSE
        PLOW=0.89
        PUP=0.96
      ENDIF
C
 1000 CONTINUE
      AE=1.E-6
      RE=1.E-6
      G2=G
      H2=H
      X2=X
      IFLAG=0
      CALL FZERO(GHFU2,PLOW,PUP,PUP,RE,AE,IFLAG)
C
      CDF=PLOW
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 GHCDF--')
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   WRITE(ICOUT,113)
CC113   FORMAT('      CDF 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 GHCDF--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,123)
  123   FORMAT('      CDF 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 GHCDF--')
        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 GHCDF--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,143)
  143   FORMAT('      MAXIMUM ITERATIONS EXCEEDED.')
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE GFUNC2(X,N,IR,ALPHA,GAMMA,WEIVAL)
C
C   COMPUTE FUNCTION USED IN ESTIMATING THE SHAPE
C   PARAMETERS FOR A CENSORED WEIBULL DISTRIBUTION.
C
      DOUBLE PRECISION DN, DG, DIR, DX, DALPHA
      DOUBLE PRECISION DSUM1, DSUM2, DSUM3
      DOUBLE PRECISION DTERM1, DTERM2, DTERM3, DTERM4
      DIMENSION X(*)
C
C  CALCULATE SOME INTERMEDIATE VALUES
C
      DN=DBLE(N)
      DIR=DBLE(IR)
      DG=DBLE(GAMMA)
      DALPHA=DBLE(ALPHA)
C
      DSUM1=0.0
      DSUM2=0.0
      DSUM3=0.0
C
      DO100I=1,IR
        DX=DBLE(X(I))
        DSUM1=DSUM1 + DX**DG
        DSUM2=DSUM2 + (DX**DG)*DLOG(DX)
        DSUM3=DSUM3 + DLOG(DX)
  100 CONTINUE
C
      DX=DBLE(X(IR))
      DTERM1=DSUM2 + DBLE(N-IR)*(DX**DG)*DLOG(DX)
      DTERM2=1.0D0/(DSUM1 + DBLE(N-IR)*DX**DG)
      DTERM3=DSUM3/DIR
      DTERM4=1.0D0/(DTERM1 + DTERM2 - DTERM3)
C
      WEIVAL=GAMMA - REAL(DTERM4)
      ALPHA=FNALP2(X,N,IR,GAMMA)
C
      RETURN
      END
      REAL FUNCTION GHFU2(P)
C
C     PURPOSE--GHCDF CALLS FZERO TO FIND A ROOT FOR THE G-H
C              CUMULATIVE DISTRIBUTION FUNCTION.  GHFU2 IS THE
C              FUNCTION FOR WHICH THE ZERO IS FOUND.  IT IS:
C                 X - GHPPF(P,G,H)
C              WHERE X IS THE DESIRED CUMULATIVE DISTRIBUTION POINT.
C     INPUT  ARGUMENTS--P      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE PERCENT POINT
C                                FUNCTION IS TO BE EVALUATED.
C     OUTPUT--THE SINGLE PRECISION FUNCTION VALUE GHFU2.
C     PRINTING--NONE.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--GHPPF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--HOAGLIN, 'SUMMARIZING SHAPES NUMERICALLY: THE
C                 G-AND-H DISTRIBUTION", IN "EXPLORING DATA TABLES,
C                 TRENDS AND SHAPES", HOAGLIN, MOSTELLER, TUKEY,
C                 WILEY, 1985.
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
C
      REAL X
      COMMON/GH2COM/X
C
      DOUBLE PRECISION DP
      DOUBLE PRECISION DPPF
C
      REAL G
      REAL H
      COMMON/GHCOM/G,H
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      DP=-1.0D0
      CALL GHPPF(P,G,H,PPF,DP,DPPF)
      GHFU2=X - PPF
C
      RETURN
      END
      REAL FUNCTION GHFU3(X)
C
C     PURPOSE--GHPDF CALLS DIFF TO FIND A NUMERICAL DERIVATIVE
C              FOR THE G-H CUMULATIVE DISTRIBUTION FUNCTION.  GHFU3
C              IS A FUNCTION THAT CALL GHCDF.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE DERIVATIVE
C                                IS TO BE EVALUATED.
C     OUTPUT--THE SINGLE PRECISION FUNCTION VALUE GHFU3.
C     PRINTING--NONE.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--GHCDF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--HOAGLIN, 'SUMMARIZING SHAPES NUMERICALLY: THE
C                 G-AND-H DISTRIBUTION", IN "EXPLORING DATA TABLES,
C                 TRENDS AND SHAPES", HOAGLIN, MOSTELLER, TUKEY,
C                 WILEY, 1985.
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
      REAL G
      REAL H
      COMMON/GHCOM/G,H
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      CALL GHCDF(X,G,H,CDF)
      GHFU3=CDF
C
      RETURN
      END
      SUBROUTINE GHPDF(X,G,H,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE G-H DISTRIBUTION
C              WITH SHAPE PARAMETERS G AND H.
C              THIS DISTRIBUTION IS DEFINED FOR ALL X AND THE
C              PROBABILITY DENSITY FUNCTION IS COMPUTED BY COMPUTING
C              THE NUMERICAL DERIVATIVE OF THE CUMULATIVE DISTRIBUTION
C              FUNCTION.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                     --G      = THE SKEWNESS SHAPE PARAMETER
C                     --H      = THE KURTOSIS 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--FZERO.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--HOAGLIN, 'SUMMARIZING SHAPES NUMERICALLY: THE
C                 G-AND-H DISTRIBUTION", IN "EXPLORING DATA TABLES,
C                 TRENDS AND SHAPES", HOAGLIN, MOSTELLER, TUKEY,
C                 WILEY, 1985.
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
      REAL PDF
      REAL G
      REAL H
C
      REAL GHFU3
      EXTERNAL GHFU3
C
      REAL G2
      REAL H2
      COMMON/GHCOM/G2,H2
C
      CHARACTER*4 IERROR
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      IERROR='OFF'
      PDF=0.0
      IF(H.LT.0.0)THEN
        WRITE(ICOUT, 7)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,48)H
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
    7 FORMAT('***** ERROR--THE THIRD (H) INPUT ARGUMENT TO THE ',
     1'GHPDF SUBROUTINE IS NEGATIVE *****')
   48 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',F15.7,' *****')
C
C  IF G AND H BOTH ZERO, USE NORPDF.
C
      IF(G.EQ.0.0 .AND. H.EQ.0.0)THEN
        CALL NORPDF(X,PDF)
        GOTO9000
      ENDIF
C
C  FIND NUMERIC DERIVATIVE OF CDF ROUTINE
C
      IORD=1
      EPS=0.0001
      ACCUR=0.0
      IFAIL=0
      X0 = X
      XMIN=CPUMIN
      XMAX=CPUMAX
      G2=G
      H2=H
C
      CALL DIFF(IORD,X0,XMIN,XMAX,GHFU3,EPS,ACCUR,PDF,ERROR,IFAIL)
C
        IF(IFAIL.EQ.1)THEN
  999     FORMAT(1X)
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,301)
  301     FORMAT('***** WARNING IN NUMERICAL DERIVATIVE FOR GHPDF--')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,303)
  303     FORMAT('      THE ESTIMATED ERROR IN THE RESULT EXCEEDS THE')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,305)
  305     FORMAT('      REQUESTED ERROR, BUT THE MOST ACCURATE RESULT')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,307)
  307     FORMAT('      POSSIBLE HAS BEEN RETURNED.')
          CALL DPWRST('XXX','BUG ')
        ELSEIF(IFAIL.EQ.2)THEN
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,311)
  311     FORMAT('***** ERROR IN NUMERICAL DERIVATIVE FOR GHPDF--')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,313)
  313     FORMAT('      ERROR IN THE INPUT TO THE DIFF ROUTINE.')
          CALL DPWRST('XXX','BUG ')
          PDF=0.0
          ERROR=0.0
          IERROR='YES'
          GOTO9000
        ELSEIF(IFAIL.EQ.3)THEN
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,321)
  321     FORMAT('***** ERROR IN NUMERICAL DERIVATIVE FOR GHPDF--')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,323)
  323     FORMAT('      THE INTERVAL FOR DIFFERENTIATION, (',G15.7,
     1           ',',G15.7,')')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,325)
  325     FORMAT('      IS TOO SMALL.')
          CALL DPWRST('XXX','BUG ')
          PDF=0.0
          ERROR=0.0
          IERROR='YES'
          GOTO9000
        ENDIF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE GHPPF(P,G,H,PPF,DP,DPPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION FROM THE THE G AND H DISTIBUTION WITH
C              LOCATION = 0 AND SCALE = 1.  THE PERCENT POINT
C              FUNCTION IS DEFINED AS:
C              G(P,G,H) = [(EXP(G*Zp)-1)/G]*EXP(H*Zp**2/2)
C              WHERE Zp IS THE PERCENT POINT FUNCTION OF THE STANDARD
C              NORMAL DISTRIBUTION AND
C              G AND H ARE SHAPE PARAMETERS (G CONTROLS SKEWNESS
C              (0 = SYMMETRIC) AND H CONTROLS HOW HEAVY THE TAILS
C              ARE.  G=H=0 IMPLIES A STANDARD NORMAL DISTRIBUTION.
C              WHEN G=0, THE PERCENT POINT FUNCTION IS DEFINED AS:
C              F(X) = Z*EXP(H*Z**2/2)
C     INPUT  ARGUMENTS--P      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE PERCENT POINT
C                                FUNCTION IS TO BE EVALUATED.
C                     --G      = FIRST SHAPE PARAMETER (DETERMINES
C                                SKEWNESS WITH G=0 BEING SYMMETRIC)
C                     --H      = SECOND SHAPE PARAMETER (DETERMINES
C                                "HEAVY TAILEDNESS"
C     OUTPUT ARGUMENTS--PPF    = THE SINGLE PRECISION PERCENT POINT
C                                FUNCTION VALUE.
C     NOTE--SAVE DOUBLE PRECISION VALUES FOR P AND PPF (DP, DPPF)
C           FOR USE BY THE GHCDF FUNCTION
C     OUTPUT--THE SINGLE PRECISION PERCENT POINT FUNCTION VALUE PPF.
C     PRINTING--NONE.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NODPPF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--EXP.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--HOAGLIN, 'SUMMARIZING SHAPES NUMERICALLY: THE
C                 G-AND-H DISTRIBUTION", IN "EXPLORING DATA TABLES,
C                 TRENDS AND SHAPES", HOAGLIN, MOSTELLER, TUKEY,
C                 WILEY, 1985.
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--2003.1
C     ORIGINAL VERSION--JANUARY   2003.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      REAL H
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
      DOUBLE PRECISION DP
      DOUBLE PRECISION DG
      DOUBLE PRECISION DH
      DOUBLE PRECISION DPPF
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,5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,48)P
        CALL DPWRST('XXX','BUG ')
        GOTO9999
CCCCC ELSEIF(G.LT.0.0)THEN
CCCCC   WRITE(ICOUT, 6)
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   WRITE(ICOUT,48)G
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   GOTO9999
      ELSEIF(H.LT.0.0)THEN
        WRITE(ICOUT, 7)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,48)H
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
    5 FORMAT('***** ERROR--THE FIRST (P) ARGUMENT TO GHPPF ',
     1       'IS OUTSIDE THE (0,1) INTERVAL')
CCCC6 FORMAT('***** FATAL ERROR--THE SECOND (G) INPUT ARGUMENT TO THE ',
CCCC 1'GHPPF SUBROUTINE IS NEGATIVE *****')
    7 FORMAT('***** ERROR--THE THIRD (H) ARGUMENT TO GHPPF ',
     1       'IS NEGATIVE')
   48 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
C
C     TRANSFORM THE NORMAL PPF
C
      IF(DP.LT.0.0D0)THEN
        DP=DBLE(P)
      ENDIF
      DG=DBLE(G)
      DH=DBLE(H)
C
      CALL NODPPF(DP,DTERM3)
      IF(G.EQ.0.0 .AND. H.EQ.0.0)THEN
        PPF=REAL(DTERM3)
      ELSEIF(G.EQ.0.0)THEN
        DPPF=DTERM3*DEXP(DH*DTERM3*DTERM3/2.0D0)
        PPF=REAL(DPPF)
      ELSEIF(H.EQ.0.0)THEN
        DPPF=(DEXP(DG*DTERM3)-1.0D0)/DG
        PPF=REAL(DPPF)
      ELSE
        DTERM1=(DEXP(DG*DTERM3)-1.0D0)/DG
        DTERM2=DEXP(DH*DTERM3*DTERM3/2.0D0)
        DPPF=DTERM1*DTERM2
        PPF=REAL(DPPF)
      ENDIF
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE GHRAN(N,G,H,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE THE G AND H DISTIBUTION WITH LOCATION = 0
C              AND SCALE = 1.  THIS DISTRIBUTION IS DEFINED FOR ALL
C              X AND HAS THE PROBABILITY DENSITY FUNCTION
C              F(X) = [(EXP(G*Z)-1)/g]*EXP(H*Z**2/2)
C              WHERE Z IS A STANDARD NORMAL DISTRIBUTION AND
C              G AND H ARE SHAPE PARAMETERS (G CONTROLS SKEWNESS
C              (0 = SYMMETRIC) AND H CONTROLS HOW HEAVY THE TAILS
C              ARE.  G=H=0 IMPLIES A STANDARD NORMAL DISTRIBUTION.
C              WHEN G = 0, THE FUNCTION IS:
C              F(X) = Z*EXP(H*Z**2/2)
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                     --G      = A SINGLE PRECISON SCALAR THAT DEFINES
C                                THE SKEWNESS SHAPE PARAMETER.
C                     --H      = A SINGLE PRECISON SCALAR THAT DEFINES
C                                THE "HEAVY-TAILEDNESS" SHAPE
C                                PARAMETER.
C     OUTPUT--A RANDOM SAMPLE OF SIZE N FROM THE G-AND-H DISTRIBUTION
C             WITH LOCATION = 0 AND SCALE = 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     METHOD--TRANSFORM NORMAL RANDOM NUMBERS
C     REFERENCES--HOAGLIN, 'SUMMARIZING SHAPES NUMERICALLY: THE
C                 G-AND-H DISTRIBUTION", IN "EXPLORING DATA TABLES,
C                 TRENDS AND SHAPES", HOAGLIN, MOSTELLER, TUKEY,
C                 WILEY, 1985.
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--2003.1
C     ORIGINAL VERSION--JANUARY   2003.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
      REAL G
      REAL H
      DOUBLE PRECISION DQ
      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 FIRST (N) ARGUMENT TO ',
     1         'GHRAN 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
CCCCC ELSEIF(G.LT.0.0)THEN
CCCCC   WRITE(ICOUT, 6)
CCCC6   FORMAT('***** ERROR--THE SECOND (G) ARGUMENT TO GHRAN ',
CCCCC1         'IS NEGATIVE.')
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   WRITE(ICOUT,48)G
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   GOTO9999
      ELSEIF(H.LT.0.0)THEN
        WRITE(ICOUT, 7)
    7   FORMAT('***** ERROR--THE THIRD (H) ARGUMENT TO GHRAN ',
     1         'IS NEGATIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,48)H
   48   FORMAT('***** THE VALUE OF THE ARGUMENT IS ',F10.5,'.')
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
C
C     GENERATE N UNIFORM NUMBERS;
C
      CALL UNIRAN(N,ISEED,X)
C
C     GENERATE N G-AND-H RANDON NUMBERS USING THE PERCENT POINT
C     FUNCTION TRANSFORMATION.
C
      DO100I=1,N
        Q=X(I)
        DQ=DBLE(-1.0D0)
        CALL GHPPF(Q,G,H,PPF,DQ,DPPF)
        X(I)=PPF
  100 CONTINUE
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE GIGCDF(X,LAMBDA,CHI,PSI,CDF)
C
CCCCC NOTE 7/2008: MODIFY PARAMERIZATION,
C
CCCCC SUBROUTINE GIGCDF(DX,CHI,LAMBDA,THETA,DCDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE GENERALIZED INVERSE GAUSSIAN
C              DISTRIBUTION.
C
C
C              THE PROBABILITY DENSITY FUNCTION IS:
C
C              f(X;LAMBDA,CHI,PSI) = SQRT(PSI/CHI)*X**(LAMBDA-1)*
C                                    EXP[-0.5*(LAMBDA/X + PSI*X)]/
C                                    {2*K1(SQRT(XHI*PSI))}
C                                    X > 0;
C                                    CHI > 0; PSI > 0
C
C              FOLLOWING IS PREVIOUS PARAMETERIZATION (BASED ON
C              PARAMETERIZATION GIVEN IN JOHNSON, KOTZ, AND
C              BALAKRISHNAN.  NOTE THAT THESE DEFINITIONS ARE
C              ACTUALLY EQUIVALENT.  I MADE THE SWITCH BECAUSE
C              THE NEW PARAMETERIZATION SEEMS TO BE THE MORE
C              COMMONLY USED.
C
C              SPECIFICALLY, THE RELATIONSHIP BETWEEN THE
C              PARAMETERIZATIONS IS:
C
C              NEW          OLD
C              ================
C              LAMBDA       THETA
C              PSI          LAMBDA
C              CHI          CHI
C
C              IT HAS SHAPE PARAMETERS CHI, LAMBDA,
C              AND THETA.  THIS DISTRIBUTION IS DEFINED FOR POSITIVE
C              X AND HAS THE PROBABILITY DENSITY FUNCTION
C                 f(X,CHI,LAMBDA,THETA) = C*X**(THETA-1)*
C                                         EXP(-(1/2)*(LAMBDA*X+CHI/X))
C                                         X > 0; CHI, LAMBDA > 0;
C                                         -INF < THETA < INF
C
C              WITH
C
C                 C = (LAMBDA/X)**(THETA/2)/[2*K(0)(SQRT(CHI*LAMBDA))]
C                     CHI, LAMBDA > 0
C
C                   = LAMBDA**THETA/[2**THETA*GAMMA(THETA)]
C                     CHI = 0; LAMBDA, THETA > 0
C
C                   = 2**THETA/[X**THETA*GAMMA(-THETA)]
C                     CHI > 0; LAMBDA=0; THETA < 0
C
C              WHERE K(LAMBDA) IS THE MODIFIED BESSEL FUNCTION
C              OF THE THIRD KIND.
C
C              THE CUMULATIVE DISTRIBUTION FUNCTION IS COMPUTED
C              BY NUMERICALLY INTEGRATING THE PROBABILITY DENSITY
C              FUNCTION.
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 POSITIVE.
C                     --LAMBDA  = THE FIRST SHAPE PARAMETER
C                     --CHI     = THE SECOND SHAPE PARAMETER
C                     --THETA   = THE THIRD SHAPE PARAMETER
C     OUTPUT ARGUMENTS--CDF     = THE DOUBLE PRECISION CUMULATIVE
C                                 DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE CDF FOR THE GENERALIZED INVERSE
C             GAUSSIAN DISTRIBUTION WITH SHAPE PARAMETERS LAMBDA,
C             CHI, AND PSI.
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, (1994), "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME 1", SECOND EDITION,
C                 WILEY, PP. pp. 284-285.
C               --PAOLELLA (2007), "INTERMEDIATE PROBABILITY: A
C                 COMPUTATIONAL APPROACH", WILEY, CHAPER 9.
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.8
C     ORIGINAL VERSION--AUGUST    2004.
C     UPDATED         --JULY      2008. MODIFY PARAMETERIZATION
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 CHI
      DOUBLE PRECISION LAMBDA
      DOUBLE PRECISION PSI
      DOUBLE PRECISION EPSABS
      DOUBLE PRECISION EPSREL
      DOUBLE PRECISION CDF
      DOUBLE PRECISION X
      DOUBLE PRECISION ABSERR
      DOUBLE PRECISION WORK(LENW)
C
      DOUBLE PRECISION GIGFUN
      EXTERNAL GIGFUN
C
      DOUBLE PRECISION DCHI
      DOUBLE PRECISION DLMBDA
      DOUBLE PRECISION DPSI
      COMMON/GIGCOM/DCHI,DLMBDA,DPSI
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
      IFLAG=0
      CDF=0.0D0
      CDF2=0.0D0
C
      IF(X.LE.0.0D0)THEN
        WRITE(ICOUT,4)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,48)X
        CALL DPWRST('XXX','WRIT')
        GOTO9000
    4 FORMAT('***** ERROR: THE VALUE OF THE FIRST ARGUMENT (X) TO ',
     1       'GIGCDF IS NON-POSITIVE.')
C
      ELSEIF(CHI.LT.0.0D0)THEN
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,48)CHI
        CALL DPWRST('XXX','WRIT')
        GOTO9000
    5   FORMAT('***** ERROR: THE VALUE OF THE SECOND SHAPE PARAMETER ',
     1         '(CHI) TO GIGCDF IS NEGATIVE.')
C
      ELSEIF(PSI.LT.0.0D0)THEN
        WRITE(ICOUT,6)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,48)PSI
        CALL DPWRST('XXX','WRIT')
        GOTO9000
    6   FORMAT('***** ERROR: THE VALUE OF THE THIRD SHAPE PARAMETER ',
     1         '(PSI) TO GIGCDF IS NEGATIVE.')
C
      ELSEIF(CHI.EQ.0.0D0)THEN
        IF(LAMBDA.LE.0.0D0 .OR. PSI.LE.0.0D0)THEN
          WRITE(ICOUT,7)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,8)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,49)LAMBDA
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,50)PSI
          CALL DPWRST('XXX','WRIT')
          GOTO9000
        ELSE
          IFLAG=1
        ENDIF
    7   FORMAT('***** ERROR: IF VALUE OF SECOND SHAPE PARAMETER ',
     1       '(CHI) TO GIGCDF IS EQUAL ZERO,')
    8 FORMAT('      THEN FIRST (LAMBDA) AND THIRD (PSI) SHAPE ',
     1       'PARAMETERS MUST BE POSITIVE.')
   49 FORMAT('      VALUE OF FIRST SHAPE PARAMETER IS: ',G15.7)
   50 FORMAT('      VALUE OF THIRD SHAPE PARAMETER IS: ',G15.7)
C
      ELSEIF(PSI.EQ.0.0D0)THEN
        IF(LAMBDA.GE.0.0D0 .OR. CHI.LE.0.0D0)THEN
          WRITE(ICOUT,9)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,10)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,11)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,51)CHI
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,52)PSI
          CALL DPWRST('XXX','WRIT')
          GOTO9000
        ELSE
          IFLAG=2
        ENDIF
    9   FORMAT('***** ERROR: IF VALUE OF THIRD SHAPE PARAMETER ',
     1       '(PSI) TO GIGCDF ROUTINE IS EQUAL ZERO,')
   10   FORMAT('      THEN FIRST SHAPE PARAMETER (LAMBDA) PARAMETER ',
     1       'MUST BE NEGATIVE AND')
   11   FORMAT('      THE SECOND SHAPE PARAMETER (CHI) MUST BE ',
     1       'POSITIVEE.')
   51   FORMAT('      VALUE OF FIRST SHAPE PARAMETER IS: ',G15.7)
   52   FORMAT('      VALUE OF SECOND SHAPE PARAMETER IS: ',G15.7)
      ENDIF
C
   48 FORMAT('      VALUE OF ARGUMENT IS: ',G15.7)
C
C               ************************************
C               **  STEP 1--                      **
C               **  COMPUTE THE CDF     FUNCTION  **
C               ************************************
C
C
C     BOUNDARY CASE I: GAMMA DISTRIBUTION WITH SHAPE PARAMETER
C                      LAMBDA AND SCALE PARAMETER PSI/2.
C
      IF(IFLAG.EQ.1)THEN
C
        SCALE=REAL(PSI/2.0D0)
        X2=REAL(X)/SCALE
        CALL GAMCDF(X2,REAL(LAMBDA),CDF2)
        CDF=DBLE(CDF2)
        GOTO9000
C
C     BOUNDARY CASE II: INVERTED GAMMA DISTRIBUTION WITH SHAPE PARAMETER
C                       -LAMBDA AND SCALE PARAMETER CHI/2.
C
      ELSEIF(IFLAG.EQ.2)THEN
C
        SCALE=REAL(CHI/2.0D0)
        X2=REAL(X)/SCALE
        CALL IGACDF(X2,REAL(-LAMBDA),PDF2)
        CDF=DBLE(CDF2)
        GOTO9000
      ENDIF
C
      EPSABS=0.0D0
      EPSREL=1.0D-7
      IER=0
      DCHI=CHI
      DLMBDA=LAMBDA
      DPSI=PSI
      CDF=0.0D0
C
      INF=1
C
      CALL DQAGI(GIGFUN,X,INF,EPSABS,EPSREL,CDF,ABSERR,NEVAL,
     1          IER,LIMIT,LENW,LAST,IWORK,WORK)
      CDF=1.0D0 - CDF
C
      IF(IER.EQ.1)THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,111)
  111   FORMAT('***** ERROR FROM GIGCDF--')
        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,111)
        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,111)
        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,111)
        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,111)
        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,111)
        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 GIGFUN(DX)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE GENERALIZED INVERSE GAUSIAN
C              DISTRIBUTION WITH SHAPE PARAMETERS CHI, LAMBDA, AND
C              PSI.  THIS DISTRIBUTION IS DEFINED FOR POSITIVE X.
C              FOR ALL X AND HAS THE PROBABILITY DENSITY FUNCTION
C              THE GIGPDF ROUTINE IS CALLED TO COMPUTE THE
C              PROBABILITY DENSITY (CHECK FOR THE FORMULA IN THAT
C              ROUTINE).  DEFINE AS FUNCTION TO BE USED FOR INTEGRATION
C              CODE CALLED BY GIGCDF.  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--GIGFUN  = THE DOUBLE PRECISION PROBABILITY
C                                 DENSITY FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE PDF FOR THE GENERALIZED INVERSE
C             GAUSSIAN DISTRIBUTION WITH SHAPE PARAMETERS CHI, LAMBDA,
C             AND THETA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--GIGPDF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, (1994), "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME 1", SECOND EDITION,
C                 WILEY, PP. 284-285.
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.8
C     ORIGINAL VERSION--AUGUST    2004.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DTERM
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DCHI
      DOUBLE PRECISION DLMBDA
      DOUBLE PRECISION DPSI
      COMMON/GIGCOM/DCHI,DLMBDA,DPSI
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 GIGPDF(DX,DCHI,DLMBDA,DPSI,DTERM)
      GIGFUN=DTERM
C
      RETURN
      END
      DOUBLE PRECISION FUNCTION GIGFU2(DX)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE GENERALIZED INVERSE GAUSIAN
C              DISTRIBUTION WITH SHAPE PARAMETERS CHI, LAMBDA, AND
C              PSI.  THIS DISTRIBUTION IS DEFINED FOR POSITIVE X.
C              FOR ALL X AND HAS THE PROBABILITY DENSITY FUNCTION
C              THE GIGPDF ROUTINE IS CALLED TO COMPUTE THE
C              PROBABILITY DENSITY (CHECK FOR THE FORMULA IN THAT
C              ROUTINE).  DEFINE AS FUNCTION TO BE USED FOR INTEGRATION
C              CODE CALLED BY GIGCDF.  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--GIGFU2  = THE DOUBLE PRECISION PROBABILITY
C                                 DENSITY FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE PDF FOR THE GENERALIZED INVERSE
C             GAUSSIAN DISTRIBUTION WITH SHAPE PARAMETERS CHI, LAMBDA,
C             AND THETA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--GIGPDF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, (1994), "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME 1", SECOND EDITION,
C                 WILEY, PP. 284-285.
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.8
C     ORIGINAL VERSION--AUGUST    2004.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DCDF
C
      DOUBLE PRECISION DP
      COMMON/GIGCO2/DP
C
      DOUBLE PRECISION DCHI
      DOUBLE PRECISION DLMBDA
      DOUBLE PRECISION DPSI
      COMMON/GIGCOM/DCHI,DLMBDA,DPSI
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----DATA STATEMENTS-------------------------------------------------
C
C-----START POINT-----------------------------------------------------
C
C               ************************************
C               **  STEP 1--                      **
C               **  COMPUTE THE CDF     FUNCTION  **
C               ************************************
C
      CALL GIGCDF(DX,DCHI,DLMBDA,DPSI,DCDF)
      GIGFU2=DP - DCDF
C
      RETURN
      END
      SUBROUTINE GIGPDF(X,LAMBDA,CHI,PSI,PDF)
C
CCCCC NOTE 7/2008: MODIFY PARAMETERIZATION.
C
CCCCC SUBROUTINE GIGPDF(X,CHI,LAMBDA,THETA,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE GENERALIZED INVERSE GAUSSIAN
C              DISTRIBUTION.
C
C              f(X;LAMBDA,CHI,PSI) = SQRT(PSI/CHI)*X**(LAMBDA-1)*
C                                    EXP[-0.5*(LAMBDA/X + PSI*X)]/
C                                    {2*K1(SQRT(XHI*PSI))}
C                                    X > 0;
C                                    CHI > 0; PSI > 0
C
C              FOLLOWING IS PREVIOUS PARAMETERIZATION (BASED ON
C              PARAMETERIZATION GIVEN IN JOHNSON, KOTZ, AND
C              BALAKRISHNAN.  NOTE THAT THESE DEFINITIONS ARE
C              ACTUALLY EQUIVALENT.  I MADE THE SWITCH BECAUSE
C              THE NEW PARAMETERIZATION SEEMS TO BE THE MORE
C              COMMONLY USED.
C
C              SPECIFICALLY, THE RELATIONSHIP BETWEEN THE
C              PARAMETERIZATIONS IS:
C
C              NEW          OLD
C              ================
C              LAMBDA       THETA
C              PSI          LAMBDA
C              CHI          CHI
C
C              IT HAS SHAPE PARAMETERS CHI, LAMBDA,
C              AND THETA.  THIS DISTRIBUTION IS DEFINED FOR POSITIVE
C              X AND HAS THE PROBABILITY DENSITY FUNCTION
C                 f(X,CHI,LAMBDA,THETA) = C*X**(THETA-1)*
C                                         EXP(-(1/2)*(LAMBDA*X+CHI/X))
C                                         X > 0; CHI, LAMBDA > 0;
C                                         -INF < THETA < INF
C
C              WITH
C
C                 C = (LAMBDA/X)**(THETA/2)/[2*K(0)(SQRT(CHI*LAMBDA))]
C                     CHI, LAMBDA > 0
C
C                   = LAMBDA**THETA/[2**THETA*GAMMA(THETA)]
C                     CHI = 0; LAMBDA, THETA > 0
C
C                   = 2**THETA/[X**THETA*GAMMA(-THETA)]
C                     CHI > 0; LAMBDA=0; THETA < 0
C
C              WHERE K(LAMBDA) IS THE MODIFIED BESSEL FUNCTION
C              OF THE THIRD KIND.
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 POSITIVE.
C                     --LAMBDA  = THE FIRST SHAPE PARAMETER
C                     --CHI     = THE SECOND SHAPE PARAMETER
C                     --THETA   = 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 GENERALIZED INVERSE GAUSSIAN
C             DISTRIBUTION WITH SHAPE PARAMETERS = LAMBDA, CHI, PSI.
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 BALAKRISHNAN, (1994), "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME 1", SECOND EDITION,
C                 WILEY, PP. 284-285.
C               --PAOLELLA (2007), "INTERMEDIATE PROBABILITY: A
C                 COMPUTATIONAL APPROACH", WILEY, CHAPER 9.
C               --xx
C                 "HANDBOOK OF COMPUTATIONAL STATISTICS",
C                 SPRINGER-VERLAG, PP.
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.8
C     ORIGINAL VERSION--AUGUST    2004.
C     UPDATED         --JULY      2008.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION X
      DOUBLE PRECISION CHI
      DOUBLE PRECISION LAMBDA
      DOUBLE PRECISION PSI
      DOUBLE PRECISION PDF
      DOUBLE PRECISION ETA
      DOUBLE PRECISION OMEGA
      DOUBLE PRECISION P1
      DOUBLE PRECISION P2
      DOUBLE PRECISION C
C
      DOUBLE PRECISION DTEMP1(10)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C               *****************************************
C               **  STEP 1--                           **
C               **  CHECK FOR VALID PARAMETERS         **
C               *****************************************
C
      IFLAG=0
C
      IF(X.LE.0.0D0)THEN
        WRITE(ICOUT,4)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,48)X
        CALL DPWRST('XXX','WRIT')
        PDF=0.0D0
        GOTO9000
    4 FORMAT('***** ERROR: THE VALUE OF THE FIRST ARGUMENT (X) TO ',
     1       'GIGPDF IS NON-POSITIVE.')
C
      ELSEIF(CHI.LT.0.0D0)THEN
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,48)CHI
        CALL DPWRST('XXX','WRIT')
        PDF=0.0D0
        GOTO9000
    5   FORMAT('***** ERROR: THE VALUE OF THE SECOND SHAPE PARAMETER ',
     1         '(CHI) TO GIGPDF IS NEGATIVE.')
C
      ELSEIF(PSI.LT.0.0D0)THEN
        WRITE(ICOUT,6)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,48)PSI
        CALL DPWRST('XXX','WRIT')
        PDF=0.0
        GOTO9000
    6   FORMAT('***** ERROR: THE VALUE OF THE THIRD SHAPE PARAMETER ',
     1         '(PSI) TO GIGPDF IS NEGATIVE.')
C
      ELSEIF(CHI.EQ.0.0D0)THEN
        IF(LAMBDA.LE.0.0D0 .OR. PSI.LE.0.0D0)THEN
          WRITE(ICOUT,7)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,8)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,49)LAMBDA
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,50)PSI
          CALL DPWRST('XXX','WRIT')
          PDF=0.0
          GOTO9000
        ELSE
          IFLAG=1
        ENDIF
    7   FORMAT('***** ERROR: IF VALUE OF SECOND SHAPE PARAMETER ',
     1       '(CHI) TO GIGPDF IS EQUAL ZERO,')
    8 FORMAT('      THEN FIRST (LAMBDA) AND THIRD (PSI) SHAPE ',
     1       'PARAMETERS MUST BE POSITIVE.')
   49 FORMAT('      VALUE OF FIRST SHAPE PARAMETER IS: ',G15.7)
   50 FORMAT('      VALUE OF THIRD SHAPE PARAMETER IS: ',G15.7)
C
      ELSEIF(PSI.EQ.0.0D0)THEN
        IF(LAMBDA.GE.0.0D0 .OR. CHI.LE.0.0D0)THEN
          WRITE(ICOUT,9)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,10)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,11)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,51)CHI
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,52)PSI
          CALL DPWRST('XXX','WRIT')
          PDF=0.0
          GOTO9000
        ELSE
          IFLAG=2
        ENDIF
    9   FORMAT('***** ERROR: IF VALUE OF THIRD SHAPE PARAMETER ',
     1       '(PSI) TO GIGPDF ROUTINE IS EQUAL ZERO,')
   10   FORMAT('      THEN FIRST SHAPE PARAMETER (LAMBDA) PARAMETER ',
     1       'MUST BE NEGATIVE AND')
   11   FORMAT('      THE SECOND SHAPE PARAMETER (CHI) MUST BE ',
     1       'POSITIVEE.')
   51   FORMAT('      VALUE OF FIRST SHAPE PARAMETER IS: ',G15.7)
   52   FORMAT('      VALUE OF SECOND SHAPE PARAMETER IS: ',G15.7)
      ENDIF
C
   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
C
CCCCC USE ALGORITHM GIVEN ON PAGE 307 OF PAOLELLA.
C
      IF(IFLAG.EQ.0)THEN
        ETA=DSQRT(CHI/PSI)
        OMEGA=DSQRT(CHI*PSI)
        IARG1=1
        ISCALE=1
        CALL DBESK(OMEGA,DABS(LAMBDA),ISCALE,IARG1,DTEMP1,NZERO)
        C=1.0D0/(2*ETA**LAMBDA*DTEMP1(IARG1))
        P1=C*X**(LAMBDA-1.0D0)
        P2=-0.5D0*((CHI/X) + PSI*X)
        PDF=P1*EXP(P2)
C
C     BOUNDARY CASE I: GAMMA DISTRIBUTION WITH SHAPE PARAMETER
C                      LAMBDA AND SCALE PARAMETER PSI/2.
C
      ELSEIF(IFLAG.EQ.1)THEN
C
        SCALE=REAL(PSI/2.0D0)
        X2=REAL(X)/SCALE
        CALL GAMPDF(X2,REAL(LAMBDA),PDF2)
        PDF=DBLE(PDF2)/SCALE
C
C     BOUNDARY CASE II: INVERTED GAMMA DISTRIBUTION WITH SHAPE PARAMETER
C                       -LAMBDA AND SCALE PARAMETER CHI/2.
C
      ELSEIF(IFLAG.EQ.2)THEN
C
        SCALE=REAL(CHI/2.0D0)
        X2=REAL(X)/SCALE
        CALL IGAPDF(X2,REAL(-LAMBDA),PDF2)
        PDF=DBLE(PDF2)/SCALE
C
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE GIGPPF(P,CHI,LAMBDA,PSI,PPF)
C
C     NOTE 7/2008: MODIFY PARAMETERIZATION.
C
CCCCC SUBROUTINE GIGPPF(P,CHI,LAMBDA,THETA,PPF)
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE GENERALIZED INVERSE GAUSSIAN
C              DISTRIBUTION.
C
C              f(X;LAMBDA,CHI,PSI) = SQRT(PSI/CHI)*X**(LAMBDA-1)*
C                                    EXP[-0.5*(LAMBDA/X + PSI*X)]/
C                                    {2*K1(SQRT(XHI*PSI))}
C                                    X > 0;
C                                    CHI > 0; PSI > 0
C
C              FOLLOWING IS PREVIOUS PARAMETERIZATION (BASED ON
C              PARAMETERIZATION GIVEN IN JOHNSON, KOTZ, AND
C              BALAKRISHNAN.  NOTE THAT THESE DEFINITIONS ARE
C              ACTUALLY EQUIVALENT.  I MADE THE SWITCH BECAUSE
C              THE NEW PARAMETERIZATION SEEMS TO BE THE MORE
C              COMMONLY USED.
C
C              SPECIFICALLY, THE RELATIONSHIP BETWEEN THE
C              PARAMETERIZATIONS IS:
C
C              NEW          OLD
C              ================
C              LAMBDA       THETA
C              PSI          LAMBDA
C              CHI          CHI
C
C              IT HAS SHAPE PARAMETERS CHI, LAMBDA,
C              AND THETA.  THIS DISTRIBUTION IS DEFINED FOR POSITIVE
C              X AND HAS THE PROBABILITY DENSITY FUNCTION
C                 f(X,CHI,LAMBDA,THETA) = C*X**(THETA-1)*
C                                         EXP(-(1/2)*(LAMBDA*X+CHI/X))
C                                         X > 0; CHI, LAMBDA > 0;
C                                         -INF < THETA < INF
C
C              WITH
C
C                 C = (LAMBDA/X)**(THETA/2)/[2*K(0)(SQRT(CHI*LAMBDA))]
C                     CHI, LAMBDA > 0
C
C                   = LAMBDA**THETA/[2**THETA*GAMMA(THETA)]
C                     CHI = 0; LAMBDA, THETA > 0
C
C                   = 2**THETA/[X**THETA*GAMMA(-THETA)]
C                     CHI > 0; LAMBDA=0; THETA < 0
C
C              WHERE K(LAMBDA) IS THE MODIFIED BESSEL FUNCTION
C              OF THE THIRD KIND.
C
C              THE PERCENT POINT FUNCTION IS COMPUTED BY
C              NUMERICALLY INVERTING THE CDF WITH A BISECTION
C              METHOD (THE CDF IS COMPUTED BY
C              NUMERICALLY INTEGRATING THE CDF FUNCTION).
C
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                     --LAMBDA  = THE FIRST SHAPE PARAMETER
C                     --CHI     = THE SECOND SHAPE PARAMETER
C                     --PSI     = 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 GENERALIZED INVERSE GAUSSIAN
C             DISTRIBUTION WITH SHAPE PARAMETERS = CHI, LAMBDA, PSI.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--DFZERO.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, (1994), "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME 1", SECOND EDITION,
C                 WILEY, PP. 284-285.
C               --PAOLELLA (2007), "INTERMEDIATE PROBABILITY: A
C                 COMPUTATIONAL APPROACH", WILEY, CHAPER 9.
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.8
C     ORIGINAL VERSION--AUGUST    2004.
C     UPDATED         --JULY      2008. MODIFY PARAMETERIZATION
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION P
      DOUBLE PRECISION PTEMP
      DOUBLE PRECISION CHI
      DOUBLE PRECISION LAMBDA
      DOUBLE PRECISION PSI
      DOUBLE PRECISION PPF
      DOUBLE PRECISION DMEAN
      DOUBLE PRECISION DSD
      DOUBLE PRECISION DR
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
C
      DOUBLE PRECISION DTEMP1(10)
C
      DOUBLE PRECISION XUP
      DOUBLE PRECISION XUP2
      DOUBLE PRECISION XLOW
      DOUBLE PRECISION RE
      DOUBLE PRECISION AE
C
      DOUBLE PRECISION GIGFU2
      EXTERNAL GIGFU2
C
      DOUBLE PRECISION DP
      COMMON/GIGCO2/DP
C
      DOUBLE PRECISION DCHI
      DOUBLE PRECISION DLMBDA
      DOUBLE PRECISION DPSI
      COMMON/GIGCOM/DCHI,DLMBDA,DPSI
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C               *****************************************
C               **  STEP 1--                           **
C               **  CHECK FOR VALID PARAMETERS         **
C               *****************************************
C
      PPF=0.0D0
      IFLAG=0
C
      IF(P.LE.0.0D0 .OR. P.GE.1.0D0)THEN
        WRITE(ICOUT,4)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,48)P
        CALL DPWRST('XXX','WRIT')
        GOTO9000
    4   FORMAT('***** ERROR: VALUE OF THE FIRST ARGUMENT (P) TO ',
     1       'GIGPPF IS OUTSIDE THE (0,1) INTERVAL.')
C
      ELSEIF(CHI.LT.0.0D0)THEN
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,48)CHI
        CALL DPWRST('XXX','WRIT')
        PPF=0.0D0
        GOTO9000
    5   FORMAT('***** ERROR: THE VALUE OF THE SECOND SHAPE PARAMETER ',
     1         '(CHI) TO GIGPPF IS NEGATIVE.')
C
      ELSEIF(PSI.LT.0.0D0)THEN
        WRITE(ICOUT,6)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,48)PSI
        CALL DPWRST('XXX','WRIT')
        PPF=0.0
        GOTO9000
    6   FORMAT('***** ERROR: THE VALUE OF THE THIRD SHAPE PARAMETER ',
     1         '(PSI) TO GIGPPF IS NEGATIVE.')
C
      ELSEIF(CHI.EQ.0.0D0)THEN
        IF(LAMBDA.LE.0.0D0 .OR. PSI.LE.0.0D0)THEN
          WRITE(ICOUT,7)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,8)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,49)LAMBDA
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,50)PSI
          CALL DPWRST('XXX','WRIT')
          PPF=0.0
          GOTO9000
        ELSE
          IFLAG=1
        ENDIF
    7   FORMAT('***** ERROR: IF VALUE OF SECOND SHAPE PARAMETER ',
     1       '(CHI) TO GIGPPF IS EQUAL ZERO,')
    8 FORMAT('      THEN FIRST (LAMBDA) AND THIRD (PSI) SHAPE ',
     1       'PARAMETERS MUST BE POSITIVE.')
   49 FORMAT('      VALUE OF FIRST SHAPE PARAMETER IS: ',G15.7)
   50 FORMAT('      VALUE OF THIRD SHAPE PARAMETER IS: ',G15.7)
C
      ELSEIF(PSI.EQ.0.0D0)THEN
        IF(LAMBDA.GE.0.0D0 .OR. CHI.LE.0.0D0)THEN
          WRITE(ICOUT,9)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,10)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,11)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,51)CHI
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,52)PSI
          CALL DPWRST('XXX','WRIT')
          PPF=0.0
          GOTO9000
        ELSE
          IFLAG=2
        ENDIF
    9   FORMAT('***** ERROR: IF VALUE OF THIRD SHAPE PARAMETER ',
     1       '(PSI) TO GIGPPF ROUTINE IS EQUAL ZERO,')
   10   FORMAT('      THEN FIRST SHAPE PARAMETER (LAMBDA) PARAMETER ',
     1       'MUST BE NEGATIVE AND')
   11   FORMAT('      THE SECOND SHAPE PARAMETER (CHI) MUST BE ',
     1       'POSITIVEE.')
   51   FORMAT('      VALUE OF FIRST SHAPE PARAMETER IS: ',G15.7)
   52   FORMAT('      VALUE OF SECOND SHAPE PARAMETER IS: ',G15.7)
      ENDIF
C
   48 FORMAT('      VALUE OF ARGUMENT IS: ',G15.7)
C
C               *****************************************
C               **  STEP 2--                           **
C               **  COMPUTE THE PERCENT POINT FUNCTION.**
C               *****************************************
C
C     BOUNDARY CASE I: GAMMA DISTRIBUTION WITH SHAPE PARAMETER
C                      LAMBDA AND SCALE PARAMETER PSI/2.
C
      IF(IFLAG.EQ.1)THEN
C
        SCALE=REAL(PSI/2.0D0)
        P2=REAL(P)
        CALL GAMPPF(P2,REAL(LAMBDA),PPF2)
        PPF=SCALE*PPF2
        GOTO9000
C
C     BOUNDARY CASE II: INVERTED GAMMA DISTRIBUTION WITH SHAPE PARAMETER
C                       -LAMBDA AND SCALE PARAMETER CHI/2.
C
      ELSEIF(IFLAG.EQ.2)THEN
C
        SCALE=REAL(CHI/2.0D0)
        P2=REAL(P)
        CALL IGAPPF(P2,REAL(-LAMBDA),PPF2)
        PPF=SCALE*PPF2
        GOTO9000
      ENDIF
C
C  STEP 1: FIND BRACKETING INTERVAL.  LOWER BOUND IS ZERO.  START
C          WITH UPPER BOUND = MEAN:
C             MEAN=K(LAMBDA+1)(SQRT(PSI*CHI))*SQRT(CHI/PSI)/
C                      K(LAMBDA)(SQRT(PSI*CHI))
C          INCREMENT IN INTERVALS OF 1 STANDARD DEVIATION:
C             VARIANCE=K(LAMBDA+2)(SQRT(PSI*CHI))*(CHI/PSI)/
C                      K(LAMBDA)(SQRT(PSI*CHI))
C
      XLOW=0.000000001D0
      CALL GIGCDF(XLOW,CHI,LAMBDA,PSI,PTEMP)
      IF(P.LE.PTEMP)THEN
        PPF=XLOW
        GOTO9000
      ENDIF
C
      IARG1=1
      ISCALE=1
      DR=DABS(LAMBDA)
      CALL DBESK(DSQRT(PSI*CHI),DR,ISCALE,IARG1,DTEMP1,NZERO)
      DTERM1=DTEMP1(1)
      DR=DABS(LAMBDA+1.0D0)
      CALL DBESK(DSQRT(PSI*CHI),DR,ISCALE,IARG1,DTEMP1,NZERO)
      DTERM2=DTEMP1(1)
      DR=DABS(LAMBDA+2.0D0)
      CALL DBESK(DSQRT(PSI*CHI),DR,ISCALE,IARG1,DTEMP1,NZERO)
      DTERM3=DTEMP1(1)
      DMEAN=(DTERM2/DTERM1)*DSQRT(CHI/PSI)
      DSD=DSQRT((DTERM3/DTERM1)*(CHI/PSI))
C
      MAXIT=1000
      NIT=0
C
      XUP2=DMEAN
  200 CONTINUE
        IF(NIT.GT.MAXIT)THEN
          PPF=0.0D0
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,131)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,133)
          CALL DPWRST('XXX','BUG ')
          GOTO9000
        ENDIF
        CALL GIGCDF(XUP2,CHI,LAMBDA,PSI,PTEMP)
        IF(PTEMP.GT.P)THEN
          XUP=XUP2
        ELSE
          XLOW=XUP2
          XUP2=XUP2 + DSD
          NIT=NIT+1
          GOTO200
        ENDIF
C
      AE=1.D-7
      RE=1.D-7
      DCHI=CHI
      DLMBDA=LAMBDA
      DPSI=PSI
      DP=P
      CALL DFZERO(GIGFU2,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 GIGPPF--')
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 GIGPPF--')
        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 GIGPPF--')
        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 GIGPPF--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,143)
  143   FORMAT('      MAXIMUM ITERATIONS EXCEEDED.')
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE GIGRAN(N,CHI,LAMBDA,PSI,ISEED,X)
C
CCCCC NOTE 7/2008: MODIFY PARAMETERIZATION.
C
CCCCC SUBROUTINE GIGRAN(N,CHI,LAMBDA,THETA,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE THE GENERALIZED INVERSE GAUSSIAN DISTIBUTION.
C
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE 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                     --LAMBDA = A SINGLE PRECISON SCALAR THAT DEFINES
C                                THE FIRST SHAPE PARAMETER.
C                     --CHI     = A SINGLE PRECISON SCALAR THAT DEFINES
C                                THE SECOND SHAPE PARAMETER.
C                     --PSI    = A SINGLE PRECISON SCALAR THAT DEFINES
C                                THE THIRD SHAPE PARAMETER.
C     OUTPUT--A RANDOM SAMPLE OF SIZE N FROM THE COMPERTZ-MAKEHAM
C             DISTRIBUTION WITH LOCATION = 0 AND SCALE = 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, GIGPPF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     METHOD--TRANSFORM NORMAL RANDOM NUMBERS
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, (1994), "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME 1", SECOND EDITION,
C                 WILEY, PP. 284-285.
C               --PAOLELLA (2007), "INTERMEDIATE PROBABILITY: A
C                 COMPUTATIONAL APPROACH", WILEY, CHAPER 9.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY DIVISION
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--2004.8
C     ORIGINAL VERSION--OCTOBER   2004.
C     UPDATED         --JULY      2008. MODIFY PARAMERIZATION
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
      REAL CHI
      REAL PSI
      REAL LAMBDA
C
      DOUBLE PRECISION DCHI
      DOUBLE PRECISION DPSI
      DOUBLE PRECISION DLMBDA
      DOUBLE PRECISION DPPF
      DOUBLE PRECISION DXTEMP
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IFLAG=0
C
      IF(N.LT.1)THEN
        WRITE(ICOUT, 3)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT, 4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
        CALL DPWRST('XXX','BUG ')
        GOTO9000
    3 FORMAT('***** ERROR--THE REQUESTED NUMBER OF GENERALIZED ',
     1'INVERSE GAUSIAN')
    4 FORMAT('      RANDOM NUMBERS IS NON-POSITIVE.')
C
      ELSEIF(CHI.LT.0.0D0)THEN
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,48)CHI
        CALL DPWRST('XXX','WRIT')
        PDF=0.0D0
        GOTO9000
    5   FORMAT('***** ERROR: THE VALUE OF THE SECOND SHAPE PARAMETER ',
     1         '(CHI) IS NEGATIVE.')
C
      ELSEIF(PSI.LT.0.0D0)THEN
        WRITE(ICOUT,6)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,48)PSI
        CALL DPWRST('XXX','WRIT')
        GOTO9000
    6   FORMAT('***** ERROR: THE VALUE OF THE THIRD SHAPE PARAMETER ',
     1         '(PSI) IS NEGATIVE.')
C
      ELSEIF(CHI.EQ.0.0D0)THEN
        IF(LAMBDA.LE.0.0D0 .OR. PSI.LE.0.0D0)THEN
          WRITE(ICOUT,7)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,8)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,49)LAMBDA
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,50)PSI
          CALL DPWRST('XXX','WRIT')
          GOTO9000
        ELSE
          IFLAG=1
        ENDIF
    7   FORMAT('***** ERROR: IF VALUE OF SECOND SHAPE PARAMETER ',
     1       '(CHI) IS EQUAL ZERO,')
    8 FORMAT('      THEN FIRST (LAMBDA) AND THIRD (PSI) SHAPE ',
     1       'PARAMETERS MUST BE POSITIVE.')
   49 FORMAT('      VALUE OF FIRST SHAPE PARAMETER IS: ',G15.7)
   50 FORMAT('      VALUE OF THIRD SHAPE PARAMETER IS: ',G15.7)
C
      ELSEIF(PSI.EQ.0.0D0)THEN
        IF(LAMBDA.GE.0.0D0 .OR. CHI.LE.0.0D0)THEN
          WRITE(ICOUT,9)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,10)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,11)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,51)CHI
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,52)PSI
          CALL DPWRST('XXX','WRIT')
          GOTO9000
        ELSE
          IFLAG=2
        ENDIF
    9   FORMAT('***** ERROR: IF VALUE OF THIRD SHAPE PARAMETER ',
     1       '(PSI) IS EQUAL ZERO,')
   10   FORMAT('      THEN FIRST SHAPE PARAMETER (LAMBDA) PARAMETER ',
     1       'MUST BE NEGATIVE AND')
   11   FORMAT('      THE SECOND SHAPE PARAMETER (CHI) MUST BE ',
     1       'POSITIVEE.')
   51   FORMAT('      VALUE OF FIRST SHAPE PARAMETER IS: ',G15.7)
   52   FORMAT('      VALUE OF SECOND SHAPE PARAMETER IS: ',G15.7)
      ENDIF
C
   48 FORMAT('      VALUE OF ARGUMENT IS: ',G15.7)
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
C
C     GENERATE N GENERALIZED INVERSE GAUSSIAN RANDON NUMBERS USING
C     THE PERCENT POINT FUNCTION TRANSFORMATION.
C
      IF(IFLAG.EQ.0)THEN
C
C       GENERATE N UNIFORM NUMBERS;
C
        CALL UNIRAN(N,ISEED,X)
        DCHI=DBLE(CHI)
        DLMBDA=DBLE(LAMBDA)
        DPSI=DBLE(PSI)
        DO100I=1,N
          DXTEMP=DBLE(X(I))
          CALL GIGPPF(DXTEMP,DLMBDA,DCHI,DPSI,DPPF)
          X(I)=REAL(DPPF)
  100   CONTINUE
C
C     BOUNDARY CASE I: GAMMA DISTRIBUTION WITH SHAPE PARAMETER
C                      LAMBDA AND SCALE PARAMETER PSI/2.
C
      ELSEIF(IFLAG.EQ.1)THEN
        CALL GAMRAN(N,LAMBDA,ISEED,X)
        SCALE=PSI/2.0
        DO210I=1,N
          X(I)=SCALE*X(I)
  210   CONTINUE
C
C     BOUNDARY CASE II: INVERTED GAMMA DISTRIBUTION WITH SHAPE PARAMETER
C                       -LAMBDA AND SCALE PARAMETER PSI/2.
C
      ELSEIF(IFLAG.EQ.2)THEN
        SHAPE=-LAMBDA
        CALL IGARAN(N,SHAPE,ISEED,X)
        SCALE=CHI/2.0
        DO310I=1,N
          X(I)=SCALE*X(I)
  310   CONTINUE
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE GI2CDF(X,LAMBDA,OMEGA,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE GENERALIZED INVERSE GAUSSIAN
C              DISTRIBUTION PARAMETERIZED TO HAVE 2 SHAPE PARAMETERS
C              (AS OPPOSSED TO 3 SHAPE PARAMETERS IN THE ORIGINAL
C              PARAMETERIZATION).
C
C              f(X;LAMBDA,OMEGA) = X**(LAMBDA-1)*EXP[-0.5*OMEGA((1/X) + X)]/
C                                    {2*K(OMEGA,LAMBDA)}
C                                    X > 0; OMEGA > 0;
C
C              WHERE K(X,LAMBDA) IS THE MODIFIED BESSEL FUNCTION
C              OF THE THIRD KIND.
C
C              THE CUMULATIVE DISTRIBUTION FUNCTION IS COMPUTED
C              BY NUMERICALLY INTEGRATING THE PROBABILITY DENSITY
C              FUNCTION.
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 POSITIVE.
C                     --LAMBDA  = THE FIRST SHAPE PARAMETER
C                     --OMEGA   = 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 CDF FOR THE GENERALIZED INVERSE
C             GAUSSIAN DISTRIBUTION WITH SHAPE PARAMETERS LAMBDA AND OMEGA.
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, (1994), "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME 1", SECOND EDITION,
C                 WILEY, PP. pp. 284-285.
C               --PAOLELLA (2007), "INTERMEDIATE PROBABILITY: A
C                 COMPUTATIONAL APPROACH", WILEY, CHAPER 9.
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--2008.7
C     ORIGINAL VERSION--JULY      2008.
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 LAMBDA
      DOUBLE PRECISION OMEGA
      DOUBLE PRECISION EPSABS
      DOUBLE PRECISION EPSREL
      DOUBLE PRECISION CDF
      DOUBLE PRECISION X
      DOUBLE PRECISION ABSERR
      DOUBLE PRECISION WORK(LENW)
C
      DOUBLE PRECISION GI2FUN
      EXTERNAL GI2FUN
C
      DOUBLE PRECISION DLMBDA
      DOUBLE PRECISION DOMEGA
      COMMON/GI2COM/DLMBDA,DOMEGA
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
      IFLAG=0
      CDF=0.0D0
C
      IF(X.LE.0.0D0)THEN
        GOTO9000
C
      ELSEIF(OMEGA.LE.0.0D0)THEN
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,48)OMEGA
        CALL DPWRST('XXX','WRIT')
        GOTO9000
    5   FORMAT('***** ERROR: THE VALUE OF THE SECOND SHAPE PARAMETER ',
     1         '(OMEGA) TO GIGCDF IS NEGATIVE.')
C
      ENDIF
C
   48 FORMAT('      THE VALUE OF THE ARGUMENT IS: ',G15.7)
C
C               ************************************
C               **  STEP 1--                      **
C               **  COMPUTE THE CDF     FUNCTION  **
C               ************************************
C
      EPSABS=0.0D0
      EPSREL=1.0D-7
      IER=0
      DOMEGA=OMEGA
      DLMBDA=LAMBDA
      DPSI=PSI
      INF=1
C
      CALL DQAGI(GI2FUN,X,INF,EPSABS,EPSREL,CDF,ABSERR,NEVAL,
     1          IER,LIMIT,LENW,LAST,IWORK,WORK)
      CDF=1.0D0 - CDF
C
      IF(IER.EQ.1)THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,111)
  111   FORMAT('***** ERROR FROM GI2CDF--')
        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,111)
        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,111)
        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,111)
        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,111)
        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,111)
        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 GI2FUN(DX)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE GENERALIZED INVERSE GAUSIAN
C              DISTRIBUTION WITH SHAPE PARAMETERS LAMBDA AND
C              OMEGA.  THIS DISTRIBUTION IS DEFINED FOR POSITIVE X.
C              FOR ALL X AND HAS THE PROBABILITY DENSITY FUNCTION
C              THE GI2PDF ROUTINE IS CALLED TO COMPUTE THE
C              PROBABILITY DENSITY (CHECK FOR THE FORMULA IN THAT
C              ROUTINE).  DEFINE AS FUNCTION TO BE USED FOR INTEGRATION
C              CODE CALLED BY GI2CDF.  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--GI2FUN  = THE DOUBLE PRECISION PROBABILITY
C                                 DENSITY FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE PDF FOR THE GENERALIZED INVERSE
C             GAUSSIAN DISTRIBUTION WITH SHAPE PARAMETERS LAMBDA
C             AND OMEGA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--GI2PDF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--PAOLELLA (2007), "INTERMEDIATE PROBABILITY: A
C                 COMPUTATIONAL APPROACH", WILEY, CHAPER 9.
C               --GENTLE, HARDLE, MORI (EDS.) (2004),
C                 "HANDBOOK OF COMPUTATIONAL STATISTICS: CONCEPTS AND
C                 METHODS", SPRINGER-VERLAG, PP. 933.
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--2008.7
C     ORIGINAL VERSION--JULY      2008.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DTERM
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DLMBDA
      DOUBLE PRECISION DOMEGA
      COMMON/GI2COM/DLMBDA,DOMEGA
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 GI2PDF(DX,DLMBDA,DOMEGA,DTERM)
      GI2FUN=DTERM
C
      RETURN
      END
      DOUBLE PRECISION FUNCTION GI2FU2(DX)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE GENERALIZED INVERSE GAUSIAN
C              DISTRIBUTION WITH SHAPE PARAMETERS LAMBDA AND
C              OMEGA.  THIS DISTRIBUTION IS DEFINED FOR POSITIVE X.
C              FOR ALL X AND HAS THE PROBABILITY DENSITY FUNCTION
C              THE GI2PDF ROUTINE IS CALLED TO COMPUTE THE
C              PROBABILITY DENSITY (CHECK FOR THE FORMULA IN THAT
C              ROUTINE).  DEFINE AS FUNCTION TO BE USED FOR INTEGRATION
C              CODE CALLED BY GI2CDF.  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--GI2FU2  = THE DOUBLE PRECISION PROBABILITY
C                                 DENSITY FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE PDF FOR THE GENERALIZED INVERSE
C             GAUSSIAN DISTRIBUTION WITH SHAPE PARAMETERS LAMBDA
C             AND OMEGA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--GI2PDF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--PAOLELLA (2007), "INTERMEDIATE PROBABILITY: A
C                 COMPUTATIONAL APPROACH", WILEY, CHAPER 9.
C               --GENTLE, HARDLE, MORI (EDS.) (2004),
C                 "HANDBOOK OF COMPUTATIONAL STATISTICS: CONCEPTS AND
C                 METHODS", SPRINGER-VERLAG, PP. 933.
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--2008.7
C     ORIGINAL VERSION--JULY      2008.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DCDF
C
      DOUBLE PRECISION DP
      COMMON/GI2CO2/DP
C
      DOUBLE PRECISION DLMBDA
      DOUBLE PRECISION DOMEGA
      COMMON/GI2COM/DLMBDA,DOMEGA
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----DATA STATEMENTS-------------------------------------------------
C
C-----START POINT-----------------------------------------------------
C
C               ************************************
C               **  STEP 1--                      **
C               **  COMPUTE THE CDF     FUNCTION  **
C               ************************************
C
      CALL GI2CDF(DX,DLMBDA,DOMEGA,DCDF)
      GI2FU2=DP - DCDF
C
      RETURN
      END
      SUBROUTINE GI2PDF(X,LAMBDA,OMEGA,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE GENERALIZED INVERSE GAUSSIAN
C              DISTRIBUTION PARAMETERIZED TO HAVE 2 SHAPE PARAMETERS
C              (AS OPPOSSED TO 3 SHAPE PARAMETERS IN THE ORIGINAL
C              PARAMETERIZATION).
C
C              f(X;LAMBDA,OMEGA) = X**(LAMBDA-1)*EXP[-0.5*OMEGA((1/X) + X)]/
C                                    {2*K(OMEGA,LAMBDA)}
C                                    X > 0; OMEGA > 0;
C
C              WHERE K(X,LAMBDA) IS THE MODIFIED BESSEL FUNCTION
C              OF THE THIRD KIND.
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 POSITIVE.
C                     --LAMBDA  = THE FIRST SHAPE PARAMETER
C                     --OMEGA   = THE SECOND 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 GENERALIZED INVERSE GAUSSIAN
C             DISTRIBUTION WITH SHAPE PARAMETERS = LAMBDA AND OMEGA.
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.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--PAOLELLA (2007), "INTERMEDIATE PROBABILITY: A
C                 COMPUTATIONAL APPROACH", WILEY, CHAPER 9.
C               --GENTLE, HARDLE, MORI (EDS.) (2004),
C                 "HANDBOOK OF COMPUTATIONAL STATISTICS: CONCEPTS AND
C                 METHODS", SPRINGER-VERLAG, PP. 933.
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--2008.7
C     ORIGINAL VERSION--JULY      2008.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION X
      DOUBLE PRECISION OMEGA
      DOUBLE PRECISION LAMBDA
      DOUBLE PRECISION PDF
      DOUBLE PRECISION P1
      DOUBLE PRECISION P2
      DOUBLE PRECISION C
C
      DOUBLE PRECISION DTEMP1(10)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C               *****************************************
C               **  STEP 1--                           **
C               **  CHECK FOR VALID PARAMETERS         **
C               *****************************************
C
      IFLAG=0
      PDF=0.0D0
C
      IF(X.LE.0.0D0)THEN
        WRITE(ICOUT,4)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,48)X
        CALL DPWRST('XXX','WRIT')
        GOTO9000
    4 FORMAT('***** ERROR: THE VALUE OF THE FIRST ARGUMENT (X) TO ',
     1       'GIGPDF IS NON-POSITIVE.')
C
      ELSEIF(OMEGA.LE.0.0D0)THEN
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,48)OMEGA
        CALL DPWRST('XXX','WRIT')
        GOTO9000
    5   FORMAT('***** ERROR: THE VALUE OF THE SECOND SHAPE PARAMETER ',
     1         '(OMEGA) TO GIGPDF IS NEGATIVE.')
C
      ENDIF
C
   48 FORMAT('      THE VALUE OF THE 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
C
      IARG1=1
      ISCALE=1
      CALL DBESK(OMEGA,DABS(LAMBDA),ISCALE,IARG1,DTEMP1,NZERO)
      C=1.0D0/(2*DTEMP1(IARG1))
      P1=C*X**(LAMBDA-1.0D0)
      P2=-0.5D0*OMEGA*((1.0D0/X) + X)
      PDF=P1*EXP(P2)
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE GI2PPF(P,LAMBDA,OMEGA,PPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE GENERALIZED INVERSE GAUSSIAN
C              DISTRIBUTION PARAMETERIZED TO HAVE 2 SHAPE PARAMETERS
C              (AS OPPOSSED TO 3 SHAPE PARAMETERS IN THE ORIGINAL
C              PARAMETERIZATION).
C
C              f(X;LAMBDA,OMEGA) = X**(LAMBDA-1)*EXP[-0.5*OMEGA((1/X) + X)]/
C                                    {2*K(OMEGA,LAMBDA)}
C                                    X > 0; OMEGA > 0;
C
C              WHERE K(X,LAMBDA) IS THE MODIFIED BESSEL FUNCTION
C              OF THE THIRD KIND.
C
C              THE PERCENT POINT FUNCTION IS COMPUTED BY
C              INVERTING THE CDF FUNCTION WITH A BISECTION
C              METHOD (THE CDF IS COMPUTED BY
C              NUMERICALLY INTEGRATING THE CDF FUNCTION).
C
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                     --LAMBDA  = THE FIRST SHAPE PARAMETER
C                     --OMEGA   = THE SECOND 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 GENERALIZED INVERSE GAUSSIAN
C             DISTRIBUTION WITH SHAPE PARAMETERS LAMBDA AND OMEGA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--DFZERO.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--PAOLELLA (2007), "INTERMEDIATE PROBABILITY: A
C                 COMPUTATIONAL APPROACH", WILEY, CHAPER 9.
C               --GENTLE, HARDLE, MORI (EDS.) (2004),
C                 "HANDBOOK OF COMPUTATIONAL STATISTICS: CONCEPTS AND
C                 METHODS", SPRINGER-VERLAG, PP. 933.
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--2008.7
C     ORIGINAL VERSION--JULY      2008.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION P
      DOUBLE PRECISION PTEMP
      DOUBLE PRECISION LAMBDA
      DOUBLE PRECISION OMEGA
      DOUBLE PRECISION PPF
      DOUBLE PRECISION DMEAN
      DOUBLE PRECISION DSD
      DOUBLE PRECISION DR
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
C
      DOUBLE PRECISION DTEMP1(10)
C
      DOUBLE PRECISION XUP
      DOUBLE PRECISION XUP2
      DOUBLE PRECISION XLOW
      DOUBLE PRECISION RE
      DOUBLE PRECISION AE
C
      DOUBLE PRECISION GI2FU2
      EXTERNAL GI2FU2
C
      DOUBLE PRECISION DP
      COMMON/GI2CO2/DP
C
      DOUBLE PRECISION DLMBDA
      DOUBLE PRECISION DOMEGA
      COMMON/GI2COM/DLMBDA,DOMEGA
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C               *****************************************
C               **  STEP 1--                           **
C               **  CHECK FOR VALID PARAMETERS         **
C               *****************************************
C
      PPF=0.0D0
C
      IF(P.LE.0.0D0 .OR. P.GE.1.0D0)THEN
        WRITE(ICOUT,4)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,48)P
        CALL DPWRST('XXX','WRIT')
        GOTO9000
    4   FORMAT('***** ERROR: VALUE OF THE FIRST ARGUMENT (P) TO ',
     1       'GIGPPF IS OUTSIDE THE (0,1) INTERVAL.')
      ELSEIF(OMEGA.LE.0.0D0)THEN
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,48)OMEGA
        CALL DPWRST('XXX','WRIT')
        GOTO9000
    5   FORMAT('***** ERROR: THE VALUE OF THE SECOND SHAPE PARAMETER ',
     1         '(OMEGA) TO GIGPDF IS NON-POSITIVE.')
C
      ENDIF
C
   48 FORMAT('      THE VALUE OF THE ARGUMENT IS: ',G15.7)
C
C               *****************************************
C               **  STEP 2--                           **
C               **  COMPUTE THE PERCENT POINT FUNCTION.**
C               *****************************************
C
C  STEP 1: FIND BRACKETING INTERVAL.  LOWER BOUND IS ZERO.  START
C          WITH UPPER BOUND = MEAN:
C
C          MEAN=K(LAMBDA+1)(OMEGA)/K(LAMBDA)(OMEGA)
C
C          INCREMENT IN INTERVALS OF 1 STANDARD DEVIATION:
C
C          VARIANCE=
C          {K(LAMBDA+2)(OMEGA)*K(LAMBDA)(OMEGA) - K(LAMBDA+1)(OMEGA)**2}/
C          K(LAMBDA)(OMEGA)**2
C
      XLOW=0.000000001D0
      CALL GI2CDF(XLOW,LAMBDA,OMEGA,PTEMP)
      IF(P.LE.PTEMP)THEN
        PPF=XLOW
        GOTO9000
      ENDIF
C
      IARG1=1
      ISCALE=1
      DR=DABS(LAMBDA)
      CALL DBESK(OMEGA,DR,ISCALE,IARG1,DTEMP1,NZERO)
      DTERM1=DTEMP1(1)
      DR=DABS(LAMBDA+1.0D0)
      CALL DBESK(OMEGA,DR,ISCALE,IARG1,DTEMP1,NZERO)
      DTERM2=DTEMP1(1)
      DR=DABS(LAMBDA+2.0D0)
      CALL DBESK(OMEGA,DR,ISCALE,IARG1,DTEMP1,NZERO)
      DTERM3=DTEMP1(1)
      DMEAN=DTERM2/DTERM1
      DSD=DSQRT((DTERM1*DTERM3 - DTERM2**2)/DTERM1**2)
C
      MAXIT=1000
      NIT=0
C
      XUP2=DMEAN
  200 CONTINUE
        IF(NIT.GT.MAXIT)THEN
          PPF=0.0D0
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,131)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,133)
          CALL DPWRST('XXX','BUG ')
          GOTO9000
        ENDIF
        CALL GI2CDF(XUP2,LAMBDA,OMEGA,PTEMP)
        IF(PTEMP.GT.P)THEN
          XUP=XUP2
        ELSE
          XLOW=XUP2
          XUP2=XUP2 + DSD
          NIT=NIT+1
          GOTO200
        ENDIF
C
      AE=1.D-7
      RE=1.D-7
      DLMBDA=LAMBDA
      DOMEGA=OMEGA
      DP=P
      CALL DFZERO(GI2FU2,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 GIGPPF--')
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 GI2PPF--')
        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 GI2PPF--')
        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 GI2PPF--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,143)
  143   FORMAT('      MAXIMUM ITERATIONS EXCEEDED.')
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE GI2RAN(N,LAMBDA,OMEGA,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE THE GENERALIZED INVERSE GAUSSIAN DISTIBUTION
C              PARAMETERIZED WITH TWO SHAPE PARAMETERS.
C
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE 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                     --LAMBDA = A SINGLE PRECISON SCALAR THAT DEFINES
C                                THE FIRST SHAPE PARAMETER.
C                     --OMEGA  = A SINGLE PRECISON SCALAR THAT DEFINES
C                                THE SECOND SHAPE PARAMETER.
C     OUTPUT--A RANDOM SAMPLE OF SIZE N FROM THE COMPERTZ-MAKEHAM
C             DISTRIBUTION WITH LOCATION = 0 AND SCALE = 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, GI2PPF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     METHOD--TRANSFORM NORMAL RANDOM NUMBERS
C     REFERENCES--PAOLELLA (2007), "INTERMEDIATE PROBABILITY: A
C                 COMPUTATIONAL APPROACH", WILEY, CHAPER 9.
C               --GENTLE, HARDLE, MORI (EDS.) (2004),
C                 "HANDBOOK OF COMPUTATIONAL STATISTICS: CONCEPTS AND
C                 METHODS", SPRINGER-VERLAG, PP. 933.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY DIVISION
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.7
C     ORIGINAL VERSION--JULY      2008.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
      REAL OMEGA
      REAL LAMBDA
C
      DOUBLE PRECISION DOMEGA
      DOUBLE PRECISION DLMBDA
      DOUBLE PRECISION DPPF
      DOUBLE PRECISION DXTEMP
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IFLAG=0
C
      IF(N.LT.1)THEN
        WRITE(ICOUT, 3)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT, 4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
        CALL DPWRST('XXX','BUG ')
        GOTO9000
    3 FORMAT('***** ERROR--THE REQUESTED NUMBER OF GENERALIZED ',
     1'INVERSE GAUSIAN')
    4 FORMAT('      RANDOM NUMBERS IS NON-POSITIVE.')
C
      ELSEIF(OMEGA.LE.0.0D0)THEN
        WRITE(ICOUT,6)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,48)OMEGA
        CALL DPWRST('XXX','WRIT')
        GOTO9000
    6   FORMAT('***** ERROR: THE VALUE OF THE SECOND SHAPE PARAMETER ',
     1         '(OMEGA) IS NON-POSITIVE.')
C
      ENDIF
C
   47 FORMAT('      THE VALUE OF THE ARGUMENT IS: ',I8)
   48 FORMAT('      THE VALUE OF THE ARGUMENT IS: ',G15.7)
C
C     GENERATE N UNIFORM NUMBERS;
C
      CALL UNIRAN(N,ISEED,X)
C
C     GENERATE N GENERALIZED INVERSE GAUSSIAN RANDON NUMBERS USING
C     THE PERCENT POINT FUNCTION TRANSFORMATION.
C
C     NOTE: CHECK INTO DAGPUNAR'S GENERATOR.  UNTIL I TRACK THAT
C           DOWN, USE THE PERCENT POINT TRANSFORMATION.
C
      DLMBDA=DBLE(LAMBDA)
      DOMEGA=DBLE(OMEGA)
      DO100I=1,N
        DXTEMP=DBLE(X(I))
        CALL GI2PPF(DXTEMP,DLMBDA,DOMEGA,DPPF)
        X(I)=REAL(DPPF)
  100 CONTINUE
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE GJACC(X,Y,N,ICASPL,IWRITE,STATVA,DIST,
     1                 ISUBRO,IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE GENERALIZED JACCARD
C              COEFFICIENT BETWEEN THE TWO SETS OF DATA IN THE INPUT
C              VECTORS X AND Y.  THE SAMPLE GENERALIZED JACCARD
C              COEFFICIENT WILL BE A SINGLE PRECISION VALUE CALCULATED
C              USING THE FORMULA
C
C                 J(X,Y) = SUM[i=1 to n][MIN(X(i),Y(i)]/
C                          SUM[i=1 to n][MAX(X(i),Y(i)]
C
C              THE JACCARD DISTANCE IS THEN DEFINED AS 1 - J(X,Y).
C
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF UNSORTED
C                                OBSERVATIONS WHICH CONSTITUTE THE FIRST
C                                SET OF DATA.
C                     --Y      = THE SINGLE PRECISION VECTOR OF UNSORTED
C                                OBSERVATIONS WHICH CONSTITUTE THE SECOND
C                                SET OF DATA.
C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS IN
C                                THE IN THE VECTORS X AND Y.
C     OUTPUT ARGUMENTS--STATVA = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED GENERALIZED JACCARD COEFFICIENT
C                                BETWEEN THE 2 SETS OF DATA IN THE INPUT
C                                VECTORS X AND Y.  THIS SINGLE PRECISION
C                                VALUE WILL BE BETWEEN -1.0 AND 1.0.
C                     --DIST   = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED GENERALIZED JACCARD DISTANCE
C                                BETWEEN THE 2 SETS OF DATA IN THE INPUT
C                                VECTORS X AND Y.  THIS SINGLE PRECISION
C                                VALUE WILL BE BETWEEN -1.0 AND 1.0.
C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE SAMPLE JACCARD
C             COEFFICIENT BETWEEN THE 2 SETS OF DATA IN THE INPUT VECTORS
C             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--MIN, MAX.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JACCARD (1912), "THE DISTRIBUTION OF FLORA IN THE
C                 ALPINE ZONE", NEW PHYTOLOGIST, VOL. 11, PP. 37-50.
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--2017/08
C     ORIGINAL VERSION--AUGUST    2017.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 ICASPL
      CHARACTER*4 IWRITE
      CHARACTER*4 ISUBRO
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX1
      DOUBLE PRECISION DY1
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DSUM2
C
      DIMENSION X(*)
      DIMENSION Y(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='GJAC'
      ISUBN2='C   '
      IERROR='NO'
C
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'JACC')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,51)
   51   FORMAT('***** AT THE BEGINNING OF GJACC--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,52)IBUGA3,ISUBRO,ICASPL,N
   52   FORMAT('IBUGA3,ISUBRO,ICASPL,N = ',3(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
      IF(N.LT.1)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,111)
  111   FORMAT('***** ERROR IN GENERALIZED JACCARD COEFFICIENT--')
        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('      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 GENERALIZED JACCARD COEFFICIENT **
C               **************************************************
C
      DSUM1=0.0D0
      DSUM2=0.0D0
      DO200I=1,N
        DX1=DBLE(X(I))
        DY1=DBLE(Y(I))
        IF(X(I).LE.Y(I))THEN
          DSUM1=DSUM1+DX1
          DSUM2=DSUM2+DY1
        ELSE
          DSUM1=DSUM1+DY1
          DSUM2=DSUM2+DX1
        ENDIF
  200 CONTINUE
C
      DSTAT=DSUM1/DSUM2
      STATVA=REAL(DSTAT)
      DSTAT=1.0D0 - DSTAT
      DIST=REAL(DSTAT)
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(ICASPL.EQ.'GJCO')THEN
          WRITE(ICOUT,811)N,STATVA
  811     FORMAT('THE GENERALIZED JACCARD COEFFICIENT OF THE ',I8,
     1           ' OBSERVATIONS = ',G15.7)
          CALL DPWRST('XXX','BUG ')
        ELSE
          WRITE(ICOUT,813)N,DIST
  813     FORMAT('THE GENERALIZED JACCARD DISTANCE OF THE ',I8,
     1           ' OBSERVATIONS = ',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.'JACC')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END       OF GJACC--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9012)IERROR,STATVA,DIST,DSUM1,DSUM2
 9012   FORMAT('IERROR,STATVA,DIST,DSUM1,DSUM2 = ',A4,2X,4G15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      RETURN
      END
      SUBROUTINE GLDCDF(DX,DL3,DL4,DCDF,IGLDDF,IWRITE)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE GENERALIZED LAMBDA DISTRIBUTION
C              WITH SHAPE PARAMETER VALUES = ALAMB3 AND ALAMB4.
C
C              NOTE THAT THERE ARE TWO COMMON PARAMETERIZATIONS
C              OF THIS PPF.
C
C              THE ORIGINAL RAMBERG AND SCHMEISER PARAMETERIZATION:
C
C                G(P) = P**LAMBDA3 - (1-P)**LAMBDA4
C
C              THE FREIMER, MUDHOLKAR, KOLLIA, AND LIN (FMKL)
C              PARAMETERIZATION:
C
C                G(P) = (P**LAMBDA3 - 1)/LAMBDA3  -
C                       ((1-P)**LAMBDA4 -1)/LAMBDA4
C
C              THE IDEF VARIABLE IDENTIFIES THE APPROPRIATE
C              DEFINITION TO USE.  THE FMKL DEFINITION IS
C              BECOMING THE PREFERRED PARAMETERIZATION) SINCE IT
C              DEFINES A VALID PROBABILITY DISTRIBUTION FOR ALL
C              VALUES OF LAMBDA3 AND LAMBDA4 (THE RAMBERG
C              PARAMETERIZATION HAS REGIONS OF LAMBDA3 AND LAMBDA4
C              WHERE A VALID PROBABILITY DISTRIBUTION IS NOT
C              DEFINED).
C
C     INPUT  ARGUMENTS--DX     = THE DOUBLE PRECISION VALUE AT
C                                WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C                     --DL3    = THE DOUBLE PRECISION VALUE OF LAMBDA3
C                                (THE FIRST SHAPE PARAMETER).
C                     --DL4    = THE DOUBLE PRECISION VALUE OF LAMBDA4
C                                (THE SECOND SHAPE PARAMETER).
C     OUTPUT ARGUMENTS--DCDF   = THE DOUBLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE DCDF FOR THE GENERALIZED TUKEY LAMBDA
C             DISTRIBUTION WITH SHAPE PARAMETERS = ALAMB3 AND ALAMB4.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--CALL GLDCHK TO CHECK FOR VALID VALUES OF THE
C                   SHAPE PARAMETERS.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN.
C     REFERENCES--KARIAN AND DUDEWICZ, 'FITTING STATISTICAL
C                 DISTRIBUTIONS: THE GENERALIZED LAMBDA DISTRIBUTION
C                 AND GENERALIZED BOOTSTRAP METHODS', CRC, 2000.
C               --STEVE SU, "A DISCRETIZED APPROACH TO FLEXIBLY FIT
C                 GENRALIZED LAMBDA DISTRIBUTIONS TO DATA",
C                 JOURNAL OF MODERN APPLIED STATISTICAL METHODS,
C                 NOVEMBER, 2005,, VOL. 4, NO. 2, 408-424.
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--AUGUST    2001.
C     UPDATED         --MARCH     2006. FLMK PARAMETERIZATION
C                                       MAKE DOUBLE PRECISION
C                                       BOUNDS ON CDF FOR CASE
C                                       WHERE EITHER LAMBDA3 OR
C                                       LAMBDA4 <= 0
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DL3
      DOUBLE PRECISION DL4
      DOUBLE PRECISION DCDF
      DOUBLE PRECISION DZERO
      DOUBLE PRECISION DONE
      DOUBLE PRECISION DLOWER
      DOUBLE PRECISION DUPPER
CCCCC DOUBLE PRECISION DEPS
      DOUBLE PRECISION PDEL
      DOUBLE PRECISION PMIN
      DOUBLE PRECISION PMAX
      DOUBLE PRECISION PMAXIN
      DOUBLE PRECISION PMID
      DOUBLE PRECISION PMIDZ
      DOUBLE PRECISION XCALC
      DOUBLE PRECISION XTEMP1
      DOUBLE PRECISION XTEMP2
C
      CHARACTER*4 IWRITE
      CHARACTER*4 IGLDDF
C
      INCLUDE 'DPCOP2.INC'
C
      DATA DZERO /0.0D0/
      DATA DONE  /1.0D0/
CCCCC DATA DEPS  /1.0D-8/
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      DZERO=0.0D0
      DONE=1.0D0
C
C     RAMBERG PARAMETERIZATION NOT CURRENTLY SUPPORTED.  MAY
C     ADD LATER.
C
CCCCC IF(IGLDDF.EQ.'RAMB')THEN
CCCCC   CALL GLDCHK(REAL(DL3),REAL(DL4),ALOWER,AUPPER,IFLAG,
CCCCC1              ISIGN,IWRITE)
CCCCC   DLOWER=DBLE(ALOWER)
CCCCC   DUPPER=DBLE(AUPPER)
CCCCC   IF(IFLAG.EQ.1)GOTO9000
C
CCCCC   IF(DX.LE.DLOWER)THEN
CCCCC     DCDF=0.0D0
CCCCC     GOTO9000
CCCCC   ENDIF
CCCCC   IF(DX.GE.DUPPER)THEN
CCCCC     DCDF=1.0D0
CCCCC     GOTO9000
CCCCC   ENDIF
CCCCC ELSE
C
C     FOR THE FMKL PARAMETERIZATION:
C
C     1) IF LAMBDA3 <= 0, THE LOWER TAIL IS UNBOUNDED.
C        IF LAMDA3   > 0, THE LOWER TAIL IS BOUNDED AT -1/LAMBDA3
C
C     2) IF LAMBDA4 <= 0, THE UPPER TAIL IS UNBOUNDED.
C        IF LAMDA4   > 0, THE UPPER TAIL IS BOUNDED AT 1/LAMBDA4
C
        IF(DL3.LE.0.0D0 .AND. DL4.LE.0.0D0)THEN
          DLOWER=DBLE(CPUMIN)
          DUPPER=DBLE(CPUMAX)
          PMIN=0.00001D0
          PMAX=0.99999D0
        ELSEIF(DL3.LE.0.0D0)THEN
          DLOWER=DBLE(CPUMIN)
          CALL GLDPPF(DONE,DL3,DL4,DUPPER,IGLDDF,IWRITE)
          PMIN=0.00001D0
          PMAX=1.0D0
        ELSEIF(DL4.LE.0.0D0)THEN
          CALL GLDPPF(DZERO,DL3,DL4,DLOWER,IGLDDF,IWRITE)
          DUPPER=DBLE(CPUMAX)
          PMIN=0.0D0
          PMAX=0.99999D0
        ELSE
          CALL GLDPPF(DZERO,DL3,DL4,DLOWER,IGLDDF,IWRITE)
          CALL GLDPPF(DONE,DL3,DL4,DUPPER,IGLDDF,IWRITE)
          PMIN=0.0D0
          PMAX=1.0D0
        ENDIF
CCCCC ENDIF
C
      DCDF=0.0D0
C
C  STEP 1: DETERMINE IF X IS OUTSIDE BOUNDS
C
      IF(DX.LE.DLOWER)THEN
        DCDF=0.0D0
        GOTO9000
      ELSEIF(DX.GE.DUPPER)THEN
        DCDF=1.0D0
        GOTO9000
      ENDIF
C
C  STEP 2: DETERMINE AN APPROPRIATE BRACKETING INTERVAL.
C          NOTE THAT THIS IS ONLY AN ISSUE IF ONE OR BOTH OF
C          THE SHAPE PARAMETERS IS ZERO.
C
      ITER=0
      PMAXIN=0.000009
  100 CONTINUE
        CALL GLDPPF(PMIN,DL3,DL4,XTEMP1,IGLDDF,IWRITE)
        CALL GLDPPF(PMAX,DL3,DL4,XTEMP2,IGLDDF,IWRITE)
        IF((DX.GE.XTEMP1) .AND. DX.LE.XTEMP2)THEN
          GOTO200
          PMAX=XUP2
        ELSEIF(DX.LT.XTEMP1)THEN
          PMIN=PMIN/10.0D0
        ELSEIF(DX.GT.XTEMP2)THEN
          PMAXIN=PMAXIN/10.0D0
          PMAX=PMAX + PMAXIN
        ENDIF
C
        ITER=ITER+1
        IF(ITER.GT.20)THEN
          WRITE(ICOUT,201)
  201     FORMAT('***** ERROR FROM GLDCDF--UNABLE TO FIND A ',
     1           'BRACKETING INTERVAL')
          CALL DPWRST('XXX','BUG ')
          GOTO9000
        ENDIF
C
      GOTO100
C
C  ITERATION LOOP (BISECTION SEARCH OF PPF FUNCTION)
C
  200 CONTINUE
      PLOWER=PMIN
      PUPPER=PMAX
      PMID=0.5D0
      ICOUNT=0
C
      IWRITE='OFF'
  210 CONTINUE
      PMIDZ=PMID
      CALL GLDPPF(PMIDZ,DL3,DL4,XCALC,IGLDDF,IWRITE)
      IF(XCALC.EQ.DX)THEN
        DCDF=PMID
        GOTO9000
      ELSEIF(XCALC.GT.DX)THEN
        PMAX=PMID
        PMID=(PMID+PMIN)/2.0D0
        PDEL=DABS(PMID-PMIN)
        ICOUNT=ICOUNT+1
        IF(PDEL.LT.0.00000001D0.OR.ICOUNT.GT.1000)THEN
          DCDF=PMID
          GOTO9000
        ENDIF
        GOTO210
      ELSE
        PMIN=PMID
        PMID=(PMID+PMAX)/2.0D0
        PDEL=DABS(PMID-PMIN)
        ICOUNT=ICOUNT+1
        IF(PDEL.LT.0.00000001D0.OR.ICOUNT.GT.1000)THEN
          DCDF=PMID
          GOTO9000
        ENDIF
        GOTO210
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE GLDCHK(ALAMB3,ALAMB4,ALOWER,AUPPER,IFLAG,ISIGN,
     1IWRITE)
C
C     PURPOSE--THIS SUBROUTINE DETERMINES IF THE SPECIFIED PARAMETERS
C              FOR THE GENERALIZD LAMBDA DISTRIBUTION RESULT IN
C              A VALID PROBABILITY DISTRIBUTION.  IF SO, IT ALSO
C              RETURNS THE LOWER AND UPPER RANGES OF THE PDF FOR
C              THE SPECIFIED VALUES.  IN PARTICULAR:
C              1) ALAMB3 >= 0, ALAMB4 >= 0:
C                 VALID,   (-1,1)
C              2) ALAMB3 <= 0, ALAMB4 <= 0:
C                 VALID,   (-1,1)
C              3) ALAMB3 <= -1, ALAMB4 >= 1:
C                 VALID,   (-1,1)
C              4) ALAMB3 >= 1, ALAMB4 <= -1:
C                 VALID
C              5) 0 < ALAMB3 < 1, ALAMB4 < 0:
C                 NOT VALID
C              6) ALAMB3 < 0, 0 < ALAMB4 < 1:
C                 NOT VALID
C              7) -1 < ALAMB3 < 0, ALAMB4 > 0:
C                 VALID IF
C                 [(1-ALAMB3)**(1-ALAMB3)]/
C                 [(ALAMB4-ALAMB3)**(ALAMB4-ALAMB3)]*
C                 (ALAMB4-1)**(ALAMB4-1) < -ALAMB3/ALAMB4
C              8)  ALAMB3 > 1, -1 < ALAMB4 < 0:
C                 VALID IF
C                 [(1-ALAMB4)**(1-ALAMB4)]/
C                 [(ALAMB3-ALAMB4)**(ALAMB3-ALAMB4)]*
C                 (ALAMB3-1)**(ALAMB3-1) < -ALAMB4/ALAMB3
C
C            --THE SUPPORT REGIONS ARE
C              1) ALAMB3 > 0, ALAMB4 > 0:     [-1,1]
C              2) ALAMB3 > 0, ALAMB4 = 0:     [0,1]
C              3) ALAMB3 = 0, ALAMB4 > 0:     [-1,0]
C              4) ALAMB3 < 0, ALAMB4 < 0:     (CPUMIN,CPUMAX)
C              5) ALAMB3 < 0, ALAMB4 = 0:     (CPUMIN,1]
C              6) ALAMB3 = 0, ALAMB4 < 0:     [-1,CPUMAX)
C
C           --NOTE: SIGN OF SHAPE PARAMETER MUST BE THE SAME AS
C                   SIGN RETURNED BY GLDPPF FUNCTION.  RETURN
C                   ISIGN AS +1 IF SHAPE MUST BE POSITIVE AND
C                   -1 IF SHAPE PARAMETER MUST BE NEGATIVE.
C
C           --THE ABOVE REGIONS FOR VALID PDFS AND SUPPORT REGIONS
C             ARE FROM KARIAN AND DUDEWIZC
C             (SEE REFERENCE BELOW)
C     INPUT  ARGUMENTS--ALAMB3 = THE SINGLE PRECISION VALUE OF LAMBDA3
C                                (THE FIRST SHAPE PARAMETER).
C                     --ALAMB4 = THE SINGLE PRECISION VALUE OF LAMBDA3
C                                (THE SECOND SHAPE PARAMETER).
C     OUTPUT ARGUMENTS--ALOWER = THE SINGLE PRECISION VALUE THAT IS
C                                THE MINIMUM OF THE ACCEPTABLE RANGE.
C                     --AUPPER = THE SINGLE PRECISION VALUE THAT IS
C                                THE MAXIMUM OF THE ACCEPTABLE RANGE.
C                     --IFLAG  = THE INTEGER FLAG THAT IS SET TO 0
C                                FOR A VALID DISTRIBUTION AND TO 1
C                                FOR AN INVALID DISTRIBUTION.
C     OUTPUT--THE SINGLE PRECISION PERCENT POINT
C             FUNCTION VALUE PPF FOR THE TUKEY LAMBDA DISTRIBUTION
C             WITH TAIL LENGTH PARAMETERS = ALAMB3 AND ALAMB4.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--TO BE ADDED.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--LOG.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISIONS.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--KARIAN AND DUDEWICZ, 'FITTING STATISTICAL
C                 DISTRIBUTIONS: THE GENERALIZED LAMBDA DISTRIBUTION
C                 AND GENERALIZED BOOTSTRAP METHODS', CRC, 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 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2001.8
C     ORIGINAL VERSION--AUGUST    2001.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
      DOUBLE PRECISION DTERM4
      DOUBLE PRECISION DTERM5
      DOUBLE PRECISION DLAM3
      DOUBLE PRECISION DLAM4
      DOUBLE PRECISION DP
C
      CHARACTER*4 IWRITE
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK FOR VALID PDF FIRST.  ASSUME VALID, THEN CHECK FOR
C     INVALID REGIONS AND THEN FOR AMBIGUOUS REGION.  NO NEED
C     TO EXPLICITLY CHECK THE FOUR VALID REGIONS.
C
      IFLAG=0
      IF(ALAMB3.GT.0.0 .AND. ALAMB4.GT.0.0)THEN
        ISIGN=+1
      ELSEIF(ALAMB3.LT.0.0 .AND. ALAMB4.LT.0.0)THEN
        ISIGN=-1
      ELSE
        DLAM3=ALAMB3
        DLAM4=ALAMB4
        DP=0.5D0
        DTERM1=DLAM3*DP**(DLAM3-1.0D0) +
     1         DLAM4*(1.0D0-DP)**(DLAM4-1.0D0)
        ISIGN=+1
        IF(DTERM1.LT.0.0D0)ISIGN=-1
      ENDIF
      ALOWER=CPUMIN
      AUPPER=CPUMAX
C
      IF(ALAMB3.LT.0.0 .AND. (0.0.LT.ALAMB4 .AND. ALAMB4.LT.1.0))THEN
        IFLAG=1
        GOTO9000
      ENDIF
      IF(ALAMB4.LT.0.0 .AND. (0.0.LT.ALAMB3 .AND. ALAMB3.LT.1.0))THEN
        IFLAG=1
        GOTO9000
      ENDIF
C
      IF(ALAMB4.GT.1.0 .AND. (-1.0.LT.ALAMB3 .AND. ALAMB3.LT.0.0))THEN
        DLAM3=DBLE(ALAMB3)
        DLAM4=DBLE(ALAMB4)
        DTERM1=(1.0D0-DLAM3)**(1.0D0-DLAM3)
        DTERM2=(DLAM4-DLAM3)**(DLAM4-DLAM3)
        DTERM3=(DLAM4-1.0D0)**(DLAM4-1.0D0)
        DTERM4=(DTERM1/DTERM2)*DTERM3
        DTERM5=-DLAM3/DLAM4
        IF(DTERM4.GE.DTERM5)THEN
          IFLAG=1
          GOTO9000
        ENDIF
      ENDIF
      IF(ALAMB3.GT.1.0 .AND. (-1.0.LT.ALAMB4 .AND. ALAMB4.LT.0.0))THEN
        DLAM3=DBLE(ALAMB3)
        DLAM4=DBLE(ALAMB4)
        DTERM1=(1.0D0-DLAM4)**(1.0D0-DLAM4)
        DTERM2=(DLAM3-DLAM4)**(DLAM3-DLAM4)
        DTERM3=(DLAM3-1.0D0)**(DLAM3-1.0D0)
        DTERM4=(DTERM1/DTERM2)*DTERM3
        DTERM5=-DLAM4/DLAM3
        IF(DTERM4.GE.DTERM5)THEN
          IFLAG=1
          GOTO9000
        ENDIF
      ENDIF
C
C     DETERMINE THE VALID SUPPORT REGION
C
      ALOWER=-1.0
      AUPPER=1.0
      IF(ALAMB3.GT.0.0 .AND. ALAMB4.EQ.0.0)THEN
        ALOWER=0.0
        AUPPER=1.0
      ELSEIF(ALAMB3.EQ.0.0 .AND. ALAMB4.GT.0.0)THEN
        ALOWER=-1.0
        AUPPER=0.0
      ELSEIF(ALAMB3.LT.0.0 .AND. ALAMB4.LT.0.0)THEN
        ALOWER=CPUMIN
        AUPPER=CPUMAX
      ELSEIF(ALAMB3.LT.0.0 .AND. ALAMB4.EQ.0.0)THEN
        ALOWER=CPUMIN
        AUPPER=1.0
      ELSEIF(ALAMB3.EQ.0.0 .AND. ALAMB4.LT.0.0)THEN
        ALOWER=-1.0
        AUPPER=CPUMAX
      ENDIF
C
 9000 CONTINUE
      IF(IFLAG.EQ.0 .AND. IWRITE.EQ.'ON')THEN
        WRITE(ICOUT,9001)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9003)ALAMB3
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9005)ALAMB4
        CALL DPWRST('XXX','BUG ')
      ELSEIF(IFLAG.EQ.1 .AND. IWRITE.EQ.'ON')THEN
        WRITE(ICOUT,9011)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9003)ALAMB3
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9005)ALAMB4
        CALL DPWRST('XXX','BUG ')
      ENDIF
 9001 FORMAT('***** GIVEN SHAPE PARAMETERS RESULT IN A VALID ',
     1       'GENERALIZED LAMBDA DISTRIBUTION.')
 9003 FORMAT('      FIRST SHAPE PARAMETER (LAMBDA3)  = ',G15.7)
 9005 FORMAT('      SECOND SHAPE PARAMETER (LAMBDA4) = ',G15.7)
 9011 FORMAT('***** GIVEN SHAPE PARAMETERS DO NOT RESULT IN A VALID ',
     1       'GENERALIZED LAMBDA DISTRIBUTION.')
      RETURN
      END
      SUBROUTINE GLDPDF(DX,DL3,DL4,DPDF,IGLDDF,IWRITE)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE GENERALIZED LAMBDA DISTRIBUTION
C              WITH SHAPE PARAMETER VALUES = DL3 (LAMBDA3) AND
C              DL4 (LAMBDA4).
C
C              NOTE THAT THERE ARE TWO COMMON PARAMETERIZATIONS
C              OF THIS PPF.
C
C              THE ORIGINAL RAMBERG AND SCHMEISER PARAMETERIZATION:
C
C                G(P) = P**LAMBDA3 - (1-P)**LAMBDA4
C
C              THE FREIMER, MUDHOLKAR, KOLLIA, AND LIN (FMKL)
C              PARAMETERIZATION:
C
C                G(P) = (P**LAMBDA3 - 1)/LAMBDA3  -
C                       ((1-P)**LAMBDA4 -1)/LAMBDA4
C
C              THE IDEF VARIABLE IDENTIFIES THE APPROPRIATE
C              DEFINITION TO USE.  THE FMKL DEFINITION IS
C              BECOMING THE PREFERRED PARAMETERIZATION) SINCE IT
C              DEFINES A VALID PROBABILITY DISTRIBUTION FOR ALL
C              VALUES OF LAMBDA3 AND LAMBDA4 (THE RAMBERG
C              PARAMETERIZATION HAS REGIONS OF LAMBDA3 AND LAMBDA4
C              WHERE A VALID PROBABILITY DISTRIBUTION IS NOT
C              DEFINED).
C
C     INPUT  ARGUMENTS--DX     = THE DOUBLE PRECISION VALUE AT
C                                WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C                     --DL3    = THE DOUBLE PRECISION VALUE OF LAMBDA3
C                                (THE FIRST SHAPE PARAMETER).
C                     --DL4    = THE DOUBLE PRECISION VALUE OF LAMBDA4
C                                (THE SECOND SHAPE PARAMETER).
C     OUTPUT ARGUMENTS--DPDF   = THE DOUBLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION PROBABILITY DENSITY FUNCTION
C             VALUE PDF FOR THE GENERALIZED TUKEY LAMBDA DISTRIBUTION
C             WITH SHAPE PARAMETERS = DL3 AND DL4.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--CALL GLDCHK TO CHECK FOR VALID VALUES OF THE
C                   SHAPE PARAMETERS.
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--KARIAN AND DUDEWICZ, 'FITTING STATISTICAL
C                 DISTRIBUTIONS: THE GENERALIZED LAMBDA DISTRIBUTION
C                 AND GENERALIZED BOOTSTRAP METHODS', CRC, 2000.
C               --STEVE SU, "A DISCRETIZED APPROACH TO FLEXIBLY FIT
C                 GENRALIZED LAMBDA DISTRIBUTIONS TO DATA",
C                 JOURNAL OF MODERN APPLIED STATISTICAL METHODS,
C                 NOVEMBER, 2005,, VOL. 4, NO. 2, 408-424.
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--MARCH     2006.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DSF
      DOUBLE PRECISION DCDF
      DOUBLE PRECISION DX
      DOUBLE PRECISION DL3
      DOUBLE PRECISION DL4
      DOUBLE PRECISION DPDF
      DOUBLE PRECISION DLOWER
      DOUBLE PRECISION DUPPER
      DOUBLE PRECISION DZERO
      DOUBLE PRECISION DONE
C
      CHARACTER*4 IGLDDF
      CHARACTER*4 IWRITE
C
      INCLUDE 'DPCOP2.INC'
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      DPDF=0.0D0
      DZERO=0.0D0
      DONE=1.0D0
C
CCCCC IF(IGLDDF.EQ.'RAMB')THEN
CCCCC   CALL GLDCHK(REAL(DL3),REAL(DL4),ALOWER,AUPPER,IFLAG,
CCCCC1              ISIGN,IWRITE)
CCCCC   IF(IFLAG.EQ.1)GOTO9000
CCCCC   DLOWER=DBLE(ALOWER)
CCCCC   DUPPER=DBLE(AUPPER)
CCCCC ELSE
C
C     FOR THE FMKL PARAMETERIZATION:
C
C     1) IF LAMBDA3 <= 0, THE LOWER TAIL IS UNBOUNDED.
C        IF LAMDA3   > 0, THE LOWER TAIL IS BOUNDED AT -1/LAMBDA3
C
C     2) IF LAMBDA4 <= 0, THE UPPER TAIL IS UNBOUNDED.
C        IF LAMDA4   > 0, THE UPPER TAIL IS BOUNDED AT 1/LAMBDA4
C
        IF(DL3.LE.0.0D0 .AND. DL4.LE.0.0D0)THEN
          DLOWER=DBLE(CPUMIN)
          DUPPER=DBLE(CPUMAX)
        ELSEIF(DL3.LE.0.0D0)THEN
          DLOWER=DBLE(CPUMIN)
          CALL GLDPPF(DONE,DL3,DL4,DUPPER,IGLDDF,IWRITE)
        ELSEIF(DL4.LE.0.0D0)THEN
          CALL GLDPPF(DZERO,DL3,DL4,DLOWER,IGLDDF,IWRITE)
          DUPPER=DBLE(CPUMAX)
        ELSE
          CALL GLDPPF(DZERO,DL3,DL4,DLOWER,IGLDDF,IWRITE)
          CALL GLDPPF(DONE,DL3,DL4,DUPPER,IGLDDF,IWRITE)
        ENDIF
CCCCC ENDIF
C
      IF(DX.LT.DLOWER .OR. DX.GT.DUPPER)THEN
        WRITE(ICOUT,2)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,3)DLOWER,DUPPER
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)DX
        CALL DPWRST('XXX','BUG ')
        DPDF=0.0D0
        GOTO9000
      ENDIF
    2 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO GLDPDF',
     1       'IS OUTSIDE')
    3 FORMAT('      THE ALLOWABLE INTERVAL (',G15.7,',',G15.7,')')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
C
C-----START POINT-----------------------------------------------------
C
C
      IWRITE='OFF'
C
CCCCC IF(IGLDDF.EQ.'RAMB')THEN
CCCCC   CALL GLDCDF(DX,DL3,DL4,DCDF,IGLDDF,IWRITE)
C
CCCCC   DTERM1=0.0D0
CCCCC   DTERM2=0.0D0
CCCCC   DSF=0.0D0
CCCCC   IF(DCDF.GT.0.0D0)THEN
CCCCC     DTERM1=DL3*DCDF**DL3-1.0D0
CCCCC   ENDIF
CCCCC   IF((1.0D0-DCDF).GT.0.0D0)THEN
CCCCC     DTERM2=DL4*(1.0D0-DCDF)**(DL4-1.0D0)
CCCCC   ENDIF
CCCCC   DSF=DTERM1 + DTERM2
CCCCC   IF(DSF.NE.0.0D0)THEN
CCCCC     DPDF=1.0D0/DSF
CCCCC   ENDIF
CCCCC ELSE
        CALL GLDCDF(DX,DL3,DL4,DCDF,IGLDDF,IWRITE)
        DSF=DCDF**(DL3-1.0D0) + (1.0D0 - DCDF)**(DL4-1.0D0)
        IF(DSF.NE.0.0D0)THEN
          DPDF=1.0D0/DSF
        ELSE
          DPDF=0.0D0
        ENDIF
CCCCC ENDIF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE GLDPPF(DP,DL3,DL4,DPPF,IGLDDF,IWRITE)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE GENERALIZD LAMBDA DISTRIBUTION
C              WITH SHAPE PARAMETERS ALAMB3 AND ALAMB4.
C              THIS DISTRIBUTION IS DEFINED IN TERMS OF ITS
C              PERCENT POINT FUNCTION.
C
C              NOTE THAT THERE ARE TWO COMMON PARAMETERIZATIONS
C              OF THIS PPF.
C
C              THE ORIGINAL RAMBERG AND SCHMEISER PARAMETERIZATION:
C
C                G(P) = P**LAMBDA3 - (1-P)**LAMBDA4
C
C              THE FREIMER, MUDHOLKAR, KOLLIA, AND LIN (FMKL)
C              PARAMETERIZATION:
C
C                G(P) = (P**LAMBDA3 - 1)/LAMBDA3  -
C                       ((1-P)**LAMBDA4 -1)/LAMBDA4
C
C              THE CASES WHERE LAMBDA3 AND LAMBDA4 EQUAL ZERO
C              HAVE TO BE HANDLED SEPARATELY.  SPECIFICALLY,
C              IF LAMBDA3 = 0, THEN
C
C                   (P**LAMBDA3 - 1)/LAMBDA3 = LOG(P)
C
C              IF LAMBDA4 = 0, THEN
C
C                   ((1-P)**LAMBDA4 - 1)/LAMBDA4 = LOG(1-P)
C
C              THE IDEF VARIABLE IDENTIFIES THE APPROPRIATE
C              DEFINITION TO USE.  THE FMKL DEFINITION IS
C              BECOMING THE PREFERRED PARAMETERIZATION) SINCE IT
C              DEFINES A VALID PROBABILITY DISTRIBUTION FOR ALL
C              VALUES OF LAMBDA3 AND LAMBDA4 (THE RAMBERG
C              PARAMETERIZATION HAS REGIONS OF LAMBDA3 AND LAMBDA4
C              WHERE A VALID PROBABILITY DISTRIBUTION IS NOT
C              DEFINED).
C
C              CURRENTLY, ONLY THE FMKL PARAMETERIZATION IS
C              SUPPORTED.
C
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 DOUBLE PRECISION VALUE
C                                (BETWEEN 0.0 AND 1.0)
C                                AT WHICH THE PERCENT POINT
C                                FUNCTION IS TO BE EVALUATED.
C                     --DL3    = THE DOUBLE PRECISION VALUE OF LAMBDA3
C                                (THE FIRST SHAPE PARAMETER).
C                     --DL4    = THE DOUBLE PRECISION VALUE OF LAMBDA3
C                                (THE SECOND SHAPE PARAMETER).
C     OUTPUT ARGUMENTS--DPPF   = THE DOUBLE PRECISION PERCENT
C                                POINT FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION PERCENT POINT
C             FUNCTION VALUE PPF FOR THE TUKEY LAMBDA DISTRIBUTION
C             WITH TAIL LENGTH PARAMETERS = DL3 AND DL4.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--TO BE ADDED.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISIONS.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--KARIAN AND DUDEWICZ, "FITTING STATISTICAL
C                 DISTRIBUTIONS: THE GENERALIZED LAMBDA DISTRIBUTION
C                 AND GENERALIZED BOOTSTRAP METHODS", CRC, 2000.
C               --STEVE SU, "A DISCRETIZED APPROACH TO FLEXIBLY FIT
C                 GENRALIZED LAMBDA DISTRIBUTIONS TO DATA",
C                 JOURNAL OF MODERN APPLIED STATISTICAL METHODS,
C                 NOVEMBER, 2005,, VOL. 4, NO. 2, 408-424.
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--2001.8
C     ORIGINAL VERSION--AUGUST    2001.
C     UPDATED         --FEBRUARY  2006. SUPPORT FOR FMKL DEFINITION
C                                       AND MAKE ROUTINE DOUBLE
C                                       PRECISION
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DP
      DOUBLE PRECISION DPPF
CCCCC DOUBLE PRECISION DEPS
      DOUBLE PRECISION DL3
      DOUBLE PRECISION DL4
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
C
      CHARACTER*4 IGLDDF
      CHARACTER*4 IWRITE
C
      INCLUDE 'DPCOBE.INC'
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(ISUBG4.EQ.'DPPF')THEN
        WRITE(ICOUT,52)IWRITE,IGLDDF,DP,DL3,DL4
   52   FORMAT('IWRITE,IGLDDF,DP,DL3,DL4 = ',2(A4,2X),3G15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
CCCCC IF(IGLDDF.EQ.'RAMB')THEN
CCCCC   IWRITE='ERRO'
CCCCC   CALL GLDCHK(ALAMB3,ALAMB4,ALOWER,AUPPER,IFLAG,ISIGN,IWRITE)
CCCCC   DPPF=0.0
CCCCC   DEPS=1.0D-12
CCCCC   IF(IFLAG.EQ.1)GOTO9000
CCCCC   GOTO9000
CCCCC ELSE
CCCCC   ALOWER=0.0
CCCCC   AUPPER=0.0
CCCCC ENDIF
C
C     FOR THE FMKL PARAMETERIZATION:
C
C     1) IF LAMBDA3 <= 0, THE LOWER TAIL IS UNBOUNDED.
C        IF LAMDA3   > 0, THE LOWER TAIL IS BOUNDED AT -1/LAMBDA3
C
C     2) IF LAMBDA4 <= 0, THE UPPER TAIL IS UNBOUNDED.
C        IF LAMDA4   > 0, THE UPPER TAIL IS BOUNDED AT 1/LAMBDA4
C
      IF(DL3.LE.0.0D0 .AND. DL4.LE.0.0D0)THEN
        IF(DP.LE.0.0D0 .OR. DP.GE.1.0D0)THEN
          WRITE(ICOUT,1)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,46)DP
          CALL DPWRST('XXX','BUG ')
          GOTO9000
        ENDIF
      ELSEIF(DL3.LE.0.0D0)THEN
        IF(DP.LE.0.0D0 .OR. DP.GT.1.0D0)THEN
          WRITE(ICOUT,1)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,46)DP
          CALL DPWRST('XXX','BUG ')
          GOTO9000
        ENDIF
      ELSEIF(DL4.LE.0.0D0)THEN
        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
        ENDIF
      ELSE
        IF(DP.LT.0.0D0 .OR. DP.GT.1.0D0)THEN
          WRITE(ICOUT,1)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,46)DP
          CALL DPWRST('XXX','BUG ')
          GOTO9000
        ENDIF
      ENDIF
    1 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO GLDPPF ',
     1'IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
C
C     CALCULATE THE PPF FUNCTION
C
CCCCC IF(IGLDDF.EQ.'RAMB')THEN
CCCCC   IF(DP.LE.DEPS)THEN
CCCCC     DPPF=DBLE(ALOWER)
CCCCC   ELSEIF(DP.GE.1.0D0-DEPS)THEN
CCCCC     DPPF=DBLE(AUPPER)
CCCCC   ELSEIF(DL3.EQ.0.0D0 .AND. DL4.EQ.0.0D0)THEN
CCCCC     DPPF=DLOG(DP) - DLOG(1.0D0 - DP)
CCCCC   ELSEIF(DL3.EQ.0.0D0)THEN
CCCCC     DPPF=DLOG(DP) - (1.0D0-DP)**DL4
CCCCC   ELSEIF(DL4.EQ.0.0D0)THEN
CCCCC     DPPF=DP**DL3 - DLOG(1.0D0 - DP)
CCCCC   ELSE
CCCCC     DPPF= DP**DL3 - (1.0D0-DP)**DL4
CCCCC   ENDIF
CCCCC ELSE
        IF(DL3.EQ.0.0D0 .AND. DL4.EQ.0.0D0)THEN
          DPPF=DLOG(DP) - DLOG(1.0D0 - DP)
        ELSEIF(DL3.EQ.0.0D0)THEN
          DPPF=DLOG(DP) - ((1.0D0-DP)**DL4 - 1.0D0)/DL4
        ELSEIF(DL4.EQ.0.0D0)THEN
          DPPF=(DP**DL3-1.0D0)/DL3 - DLOG(1.0D0 - DP)
        ELSE
          DTERM1=(DP**DL3-1.0D0)/DL3
          DTERM2=((1.0D0-DP)**DL4 - 1.0D0)/DL4
          DPPF=DTERM1 - DTERM2
        ENDIF
CCCCC ENDIF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE GLDRAN(N,ALAMB3,ALAMB4,ISEED,IGLDDF,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FOR THE GENERALIZD LAMBDA DISTRIBUTION
C              WITH SHAPE PARAMETERS ALAMB3 AND ALAMB4.
C              THE PERCENT POINT FUNCTION FOR THIS DISTRIBUTION IS
C              G(P) = P**LAMBDA3 - (1-Y)**LAMBDA4
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--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --ALAMB3 = THE SINGLE PRECISION VALUE OF LAMBDA
C                                (THE FIRST SHAPE PARAMETER).
C                     --ALAMB4 = THE SINGLE PRECISION VALUE OF LAMBDA
C                                (THE FIRST 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 GENERALIZED LAMBDA DISTRIBUTION
C             WITH SHAPE PARAMETER VALUES = ALAMB3 AND ALAMB4.
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--NONE.
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               --KARIAN AND DUDEWICZ, 'FITTING STATISTICAL
C                 DISTRIBUTIONS: THE GENERALIZED LAMBDA DISTRIBUTION
C                 AND GENERALIZED BOOTSTRAP METHODS', CRC, 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 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1966)
C     VERSION NUMBER--2001.8
C     ORIGINAL VERSION--AUGUST    2001.
C     UPDATED         --FEBRUARY  2006. SUPPORT FOR FMKL
C                                       PARAMETERIZATION
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
C
      DOUBLE PRECISION DPPF
C
      CHARACTER*4 IWRITE
      CHARACTER*4 IGLDDF
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(IGLDDF.EQ.'RAMB')THEN
        IWRITE='ERRO'
        CALL GLDCHK(ALAMB3,ALAMB4,ALOWER,AUPPER,IFLAG,ISIGN,IWRITE)
        ZSCALE=1.0
        IF(ISIGN.LT.0)ZSCALE=-1.0
        IF(IFLAG.EQ.1)THEN
          DO10I=1,N
            X(I)=0.0
   10     CONTINUE
          GOTO9000
        ENDIF
      ENDIF
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--A NON-POSITIVE NUMBER OF RANDOM NUMBERS ',
     1       'WAS REQUESTED FOR ')
    6 FORMAT('      THE GENERALIZED TUKEY-LAMBDA DISTRIBUTION.')
   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 GENERALIZED TUKEY-LAMBDA DISTRIBUTION RANDOM NUMBERS
C     USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD.
C
      IWRITE='OFF'
      DO100I=1,N
        Q=X(I)
        CALL GLDPPF(DBLE(Q),DBLE(ALAMB3),DBLE(ALAMB4),DPPF,
     1              IGLDDF,IWRITE)
        X(I)=REAL(DPPF)
  100 CONTINUE
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE GLGCDF(X,P,J,A,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE AT THE SINGLE PRECISION VALUE X
C              FOR THE GENERALIZED LOST GAMES DISTRIBUTION
C              WITH SINGLE PRECISION SHAPE PARAMETERS P, A, AND
C              J.  THIS DISTRIBUTION IS DEFINED FOR ALL
C              NON-NEGATIVE INTEGER X >= J.
C
C              THE CUMULATIVE DISTRIBUTION FUNCTION IS COMPUTED FROM THE
C              RECURRENCE RELATION:
C
C              p(X;P,J,A) =(2*X+A-2*J-1)*(2*X+A-2*J-2)*P*(1-P)*p(X;P,J,A)/
C                          {(X-J)*(X+A-J)}
C
C              P(0;P,J,A)=P**A
C
C              THIS DISTRIBUTION IS USED TO MODEL THE "GAMBLER'S
C              RUIN" PROBLEM.
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 >= J.
C                     --P      = THE SINGLE PRECISION VALUE
C                                OF THE FIRST SHAPE PARAMETER (PROBABILITY OF
C                                LOSING AN INDIVIDUAL GAME).
C                     --J      = THE INTEGER VALUE OF THE SECOND SHAPE
C                                PARAMETER.
C                     --A      = THE SINGLE PRECISION VALUE OF THE THIRD SHAPE
C                                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 GENERALIZED LOST GAMES DISTRIBUTION
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE AN INTEGER >= J
C                 --0.5 < P < 1,  AND J >= 0
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--DEXP, DLOG
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,
C                 WILEY, PP. 503-505.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2006/11
C     ORIGINAL VERSION--NOVEMBER  2006.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DP
      DOUBLE PRECISION DJ
      DOUBLE PRECISION DA
      DOUBLE PRECISION DPDF
      DOUBLE PRECISION DPDFSV
      DOUBLE PRECISION DCDF
      DOUBLE PRECISION DC1
      DOUBLE PRECISION DC2
      DOUBLE PRECISION DC3
      DOUBLE PRECISION DC4
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 GLGCDF ',
     1' IS OUTSIDE THE ALLOWABLE (0.5,1) INTERVAL')
C
      IF(J.LT.0)THEN
        WRITE(ICOUT,12)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)J
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9999
      ENDIF
   12 FORMAT('***** ERROR--THE THIRD ARGUMENT TO GLGCDF IS ',
     1' NEGATIVE')
C
      IF(A.LE.0.0)THEN
        WRITE(ICOUT,13)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)A
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9999
      ENDIF
   13 FORMAT('***** ERROR--THE FOURTH ARGUMENT TO GLGCDF IS ',
     1' NEGATIVE')
C
      INTX=INT(X+0.5)
      IF(INTX.LT.J)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 GLGCDF 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)
      DJ=DBLE(J)
      DA=DBLE(A)
      DCDF=0.0D0
C
C     USE THE RECURRENCE RELATION DESCRIBED ABOVE.
C
      DPDF=DA*DLOG(DP)
      DPDFSV=DPDF
      DCDF=DEXP(DPDF)
C
      IF(INTX.GT.J)THEN
        DO200I=J+1,INTX
          DX=DBLE(I)
          DC1=DLOG(2.0D0*DX+DA-2.0D0*DJ-1.0D0)
          DC2=DLOG(2.0D0*DX+DA-2.0D0*DJ-2.0D0)
          DC3=DLOG(DP) + DLOG(1.0D0-DP)
          DC4=DLOG(DX-DJ) + DLOG(DX+DA-DJ)
          DPDF=DC1 + DC2 + DC3 + DPDFSV - DC4
          DCDF=DCDF + DEXP(DPDF)
          DPDFSV=DPDF
  200   CONTINUE
      ENDIF
C
      CDF=REAL(DCDF)
C
 9999 CONTINUE

      RETURN
      END
      SUBROUTINE GLGFUN(N,X,FVEC,IFLAG,Y,K)
C
C     PURPOSE--THIS ROUTINE COMPUTES THE FUNCTIONS FOR THE
C              GENERALIZED LOST GAMES MAXIMUM LIKELIHOOD EQUATIONS.
C
C                 N*SUM[x>=0][f(x)*{(a+x)/p - x/(1-p)} = 0
C
C                 N*SUM[x >= 0][f(x)*{LOG(p) + 1/a + PSI(a+2*x) -
C                 PS(a+x-1)}] = 0
C
C              WITH P AND A DENOTING THE SHAPE PARAMETERS.
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--GENERALIZED LOST GAMES MAXIMUM LIKELIHOOD Y
C     REFERENCES--JOHNSON, KOTZ, AND KEMP (2006).  "UNIVARIATE
C                 DISCRETE DISTRIBUTIONS", THIRD EDITION,
C                 WILEY, PP. 503-505.
C               --KEMP AND KEMP (1992), "A GROUP-DYNAMIC MODEL AND
C                 THE LOST-GAMES DISTRIBUTION", COMMUNICATIONS IN
C                 STATISTICS--THEORY AND METHODS, 21(3),
C                 PP. 791-798.
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/12
C     ORIGINAL VERSION--DECEMBER  2006.
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION X(*)
      DOUBLE PRECISION FVEC(*)
      REAL Y(*)
C
CCCCC EXTERNAL DPSI
C
      DOUBLE PRECISION DN
      DOUBLE PRECISION DX
      DOUBLE PRECISION DX2
      DOUBLE PRECISION DP
      DOUBLE PRECISION DA
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DSUM2
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DFREQ
CCCCC DOUBLE PRECISION DPSI
C
      DOUBLE PRECISION XBAR,S2,F0
      COMMON/GLGCOM/XBAR,S2,F0,MAXNXT,IINDX,NTOT
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C  COMPUTE SOME SUMS
C
      N=2
      IFLAG=0
C
      DP=X(1)
      DA=X(2)
      DN=DBLE(NTOT)
C
      DSUM1=0.0D0
      DSUM2=0.0D0
C
      DO200I=1,K
C
        DX=DBLE(Y(IINDX+I))
        DFREQ=DBLE(Y(I))
        IF(DFREQ.LE.0.0D0)GOTO200
C
        DTERM1=((DA+DX)/DP) - (DX/(1.0D0-DP))
        DSUM1=DSUM1 + (DFREQ/DN)*DTERM1
CCCCC   DTERM1=DLOG(DP) + 1.0D0/DA + DPSI(DA+2.0D0*DX) -
CCCCC1         DPSI(DA+DX-1.0D0)
CCCCC   DSUM2=DSUM2 + (DFREQ/DN)*DTERM1
C
  200 CONTINUE
      FVEC(1)=DN*DSUM1
CCCCC FVEC(2)=DN*DSUM2
C
      DSUM1=0.0D0
      DSUM2=0.0D0
      DO300I=1,K
        DSUM2=0.0D0
        DX=DBLE(Y(IINDX+I))
        IF(DX.LT.1.99D0)GOTO300
        DFREQ=Y(I)
        IK=INT(DX-1.0D0 + 0.5D0)
        DO400J=1,IK
          DX2=DBLE(Y(IINDX+J))
          DSUM2=DSUM2 + 1.0D0/(DA+DX+DBLE(J))
  400   CONTINUE
        DSUM1=DSUM1 + (DFREQ/DN)*DSUM2
  300 CONTINUE
C
      FVEC(2)=DN*DLOG(DP) + DN*(1.0D0 - F0)/DA + DN*DSUM1
C
      RETURN
      END
      SUBROUTINE GLGPDF(X,P,J,A,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE AT THE SINGLE PRECISION VALUE X
C              FOR THE GENERALIZED LOST GAMES DISTRIBUTION
C              WITH SINGLE PRECISION SHAPE PARAMETERS P, A, AND
C              J.  THIS DISTRIBUTION IS DEFINED FOR ALL
C              NON-NEGATIVE INTEGER X >= J AND HAS THE PROBABILITY
C              MASS FUNCTION:
C
C              p(X;P,J,A) = (2*X+A-2*J-1)!A*P**(A+X-J)*
C                           (1-P)**(X-J)/{(X+A-J)!*(X-J)!}
C                           X = J, J+1, ...
C                           A > 0; 0 < P < 1
C
C              THE PROBABILITIES CAN BE COMPUTED FROM THE FOLLOWING
C              RECURRENCE RELATION:
C
C              p(X;P,J,A) =(2*X+A-2*J-1)*(2*X+A-2*J-2)*P*(1-P)*p(X;P,J,A)/
C                          {(X-J)*(X+A-J)}
C
C              P(0;P,J,A)=P**A
C
C              THIS DISTRIBUTION IS USED TO MODEL THE "GAMBLER'S
C              RUIN" PROBLEM.
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 AN INTEGR >= J.
C                     --P      = THE SINGLE PRECISION VALUE
C                                OF THE FIRST SHAPE PARAMETER (PROBABILITY OF
C                                LOSING AN INDIVIDUAL GAME).
C                     --J      = THE INTEGER VALUE OF THE SECOND SHAPE
C                                PARAMETER.
C                     --A      = THE SINGLE PRECISION VALUE OF THE THIRD SHAPE
C                                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 GENERALIZED LOST GAMES
C             DISTRIBUTION
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE AN INTEGER >= J
C                 --0.5 < P < 1,  AND J >= 0, A > 0
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--DEXP, DLOG
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,
C                 WILEY, PP. 503-505.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2006/11
C     ORIGINAL VERSION--NOVEMBER  2006.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DP
      DOUBLE PRECISION DJ
      DOUBLE PRECISION DA
      DOUBLE PRECISION DPDF
      DOUBLE PRECISION DPDFSV
      DOUBLE PRECISION DC1
      DOUBLE PRECISION DC2
      DOUBLE PRECISION DC3
      DOUBLE PRECISION DC4
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
      SAVE DPDFSV
      SAVE PSV
      SAVE ASV
      SAVE XSV
      SAVE JSV
C
      DATA DPDFSV /-99.0/
      DATA PSV    /-99.0/
      DATA ASV    /-99.0/
      DATA JSV    /-99/
      DATA XSV    /-99.0/
C
C-----START POINT-----------------------------------------------------
C
      PDF=0.0
      DPDF=0.0D0
      INTX=INT(X+0.5)
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(P.LE.0.5 .OR. P.GE.1.0)THEN
        WRITE(ICOUT,11)
   11   FORMAT('***** ERROR--THE SECOND ARGUMENT TO GLGPDF ',
     1         'IS OUTSIDE THE ALLOWABLE (0.5,1) INTERVAL.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)P
   46   FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7,'.')
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ELSEIF(J.LT.0)THEN
        WRITE(ICOUT,12)
   12   FORMAT('***** ERROR--THE THIRD ARGUMENT TO GLGPDF IS ',
     1         'NEGATIVE')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)J
   47   FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,'.')
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ELSEIF(A.LE.0.0)THEN
        WRITE(ICOUT,13)
   13   FORMAT('***** ERROR--THE FOURTH ARGUMENT TO GLGPDF IS ',
     1         'NEGATIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)A
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ELSEIF(INTX.LT.J)THEN
        WRITE(ICOUT,5)
    5   FORMAT('***** ERROR--THE FIRST ARGUMENT TO GLGPDF IS LESS ',
     1         'THAN THE THIRD ARUGMENT.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)INTX
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)INTX
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
C
C     NOTE: FOR EFFICIENCY, CHECK IF THE CURRENT VALUES OF THE
C           PARAMETERS ARE THE SAME AS THE SAVED VALUES AND IF
C           THE CURRENT X IS GREATER THAN OR EQUAL THE SAVED X.
C
      DP=DBLE(P)
      DJ=DBLE(J)
      DA=DBLE(A)
C
      IF(P.EQ.PSV .AND. A.EQ.ASV .AND. J.EQ.JSV .AND.
     1   X.GE.XSV)THEN
C
C       USE PARAMETERS FROM PREVIOUS CALL
C
        IF(X.EQ.XSV)THEN
          DPDF=DEXP(DPDFSV)
          PDF=REAL(DPDF)
          GOTO10000
        ELSE
          ISTRT=INT(XSV+0.5)
          DO100I=ISTRT+1,INTX
            DX=DBLE(I)
            DC1=DLOG(2.0D0*DX+DA-2.0D0*DJ-1.0D0)
            DC2=DLOG(2.0D0*DX+DA-2.0D0*DJ-2.0D0)
            DC3=DLOG(DP) + DLOG(1.0D0-DP)
            DC4=DLOG(DX-DJ) + DLOG(DX+DA-DJ)
            DPDF=DC1 + DC2 + DC3 + DPDFSV - DC4
            DPDFSV=DPDF
  100     CONTINUE
          DPDF=DEXP(DPDF)
          PDF=REAL(DPDF)
        ENDIF
      ELSE
C
C       NEW PARAMETERS
C
        DPDF=DA*DLOG(DP)
        DPDFSV=DPDF
C
        IF(INTX.GT.J)THEN
          DO200I=J+1,INTX
            DX=DBLE(I)
            DC1=DLOG(2.0D0*DX+DA-2.0D0*DJ-1.0D0)
            DC2=DLOG(2.0D0*DX+DA-2.0D0*DJ-2.0D0)
            DC3=DLOG(DP) + DLOG(1.0D0-DP)
            DC4=DLOG(DX-DJ) + DLOG(DX+DA-DJ)
            DPDF=DC1 + DC2 + DC3 + DPDFSV - DC4
            DPDFSV=DPDF
  200     CONTINUE
        ENDIF
        DPDF=DEXP(DPDF)
        PDF=REAL(DPDF)
      ENDIF
      GOTO9000
C
 9000 CONTINUE
      PSV=P
      ASV=A
      JSV=J
      XSV=X
      GOTO10000
C
 9999 CONTINUE
      PSV=-99.0
      ASV=-99.0
      JSV=-99
      XSV=-99.0
C
10000 CONTINUE
      RETURN
      END
      SUBROUTINE GLGPPF(P,PPAR,J,A,PPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE AT THE SINGLE PRECISION VALUE P
C              FOR THE GENERALIZED LOST GAMES DISTRIBUTION
C              WITH SINGLE PRECISION SHAPE PARAMETERS P, A, AND
C              J.  THIS DISTRIBUTION IS DEFINED FOR ALL
C              NON-NEGATIVE INTEGER X >= J.
C
C              THE CUMULATIVE DISTRIBUTION FUNCTION IS COMPUTED FROM
C              THE RECURRENCE RELATION:
C
C              p(X;P,J,A) =(2*X+A-2*J-1)*(2*X+A-2*J-2)*P*(1-P)*p(X;P,J,A)/
C                          {(X-J)*(X+A-J)}
C
C              P(0;P,J,A)=P**A
C
C              THE PERCENT POINT FUNCTION IS COMPUTED BY GENERATING
C              THE CDF FUNCTION UNTIL THE APPROPRIATE PROBABILITY
C              IS REACHED.
C
C              THIS DISTRIBUTION IS USED TO MODEL THE "GAMBLER'S
C              RUIN" PROBLEM.  IT ADDS THE ADDITIONAL PARAMETER, A,
C              TO THE LOST GAMES DISTRIBUTION.
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 (PROBABILITY OF
C                                LOSING AN INDIVIDUAL GAME).
C                     --J      = THE INTEGER VALUE OF THE SECOND SHAPE
C                                PARAMETER.
C                     --A      = THE SINGLE PRECISION VALUE OF THE THIRD SHAPE
C                                PARAMETER.
C     OUTPUT ARGUMENTS--PPF    = THE SINGLE PRECISION PERCENT POINT
C                                FUNCTION VALUE
C     OUTPUT--THE SINGLE PRECISION PERCENT POINT FUNCTION VALUE
C             PPF FOR THE GENERALIZED LOST GAMES DISTRIBUTION
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--0 <= P < 1.
C                 --0.5 < P < 1,  AND J >= 0
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--DEXP, DLOG
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,
C                 WILEY, PP. 503-505.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2006/11
C     ORIGINAL VERSION--NOVEMBER  2006.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DP
      DOUBLE PRECISION DPPAR
      DOUBLE PRECISION DJ
      DOUBLE PRECISION DA
      DOUBLE PRECISION DPDF
      DOUBLE PRECISION DPDFSV
      DOUBLE PRECISION DCDF
      DOUBLE PRECISION DC1
      DOUBLE PRECISION DC2
      DOUBLE PRECISION DC3
      DOUBLE PRECISION DC4
      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(P.LT.0.0 .OR. P.GE.1.0)THEN
        WRITE(ICOUT,15)
   15   FORMAT('***** ERROR--THE FIRST ARGUMENT TO GLGPPF ',
     1         'IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)P
   46   FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7,'.')
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ELSEIF(PPAR.LE.0.5 .OR. PPAR.GE.1.0)THEN
        WRITE(ICOUT,11)
   11   FORMAT('***** ERROR--THE SECOND ARGUMENT TO GLGPPF ',
     1         'IS OUTSIDE THE ALLOWABLE (0.5,1) INTERVAL.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)PPAR
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ELSEIF(J.LT.0)THEN
        WRITE(ICOUT,12)
   12   FORMAT('***** ERROR--THE THIRD ARGUMENT TO GLGPPF IS ',
     1         'NEGATIVE')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)J
   47   FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,'.')
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ELSEIF(A.LE.0.0)THEN
        WRITE(ICOUT,13)
   13   FORMAT('***** ERROR--THE FOURTH ARGUMENT TO GLGPPF IS ',
     1         'NEGATIVE')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)A
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
C
      DEPS=1.0D-7
      DP=DBLE(P)
      DPPAR=DBLE(PPAR)
      DJ=DBLE(J)
      DA=DBLE(A)
      DCDF=0.0D0
C
C     USE THE RECURRENCE RELATION DESCRIBED ABOVE.
C
      I=J
      DPDF=DA*DLOG(DPPAR)
      DPDFSV=DPDF
      DCDF=DEXP(DPDF)
      IF(DCDF.GE.DP-DEPS)THEN
        PPF=REAL(J)
        GOTO9999
      ENDIF
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=REAL(I)
          GOTO9999
        ENDIF
        DX=DBLE(I)
        DC1=DLOG(2.0D0*DX+DA-2.0D0*DJ-1.0D0)
        DC2=DLOG(2.0D0*DX+DA-2.0D0*DJ-2.0D0)
        DC3=DLOG(DPPAR) + DLOG(1.0D0-DPPAR)
        DC4=DLOG(DX-DJ) + DLOG(DX+DA-DJ)
        DPDF=DC1 + DC2 + DC3 + DPDFSV - DC4
        DCDF=DCDF + DEXP(DPDF)
        DPDFSV=DPDF
        IF(DCDF.GE.DP-DEPS)THEN
          PPF=REAL(I)
          GOTO9999
        ENDIF
      GOTO100
C
 9999 CONTINUE

      RETURN
      END
      SUBROUTINE GLGRAN(N,P,J,A,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF
C              SIZE N FROM THE GENERALIZED LOST GAMES DISTRIBUTION
C              WITH SHAPE PARAMETERS P AND IR.
C              IR.  THIS DISTRIBUTION IS DEFINED FOR ALL
C              NON-NEGATIVE INTEGER X >= J.
C              THIS DISTRIBUTION HAS THE PROBABILITY FUNCTION
C              p(X;P,J,A) = ...
C                           X = J, J+ 1, ...
C                           A > 0, 0.5 < P < 1
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                     --J      = THE INTEGER VALUE
C                                OF THE SECOND SHAPE PARAMETER.
C                     --A      = 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 FROM THE GENERALIZED
C             LOST GAMES DISTRIBUTION WITH SHAPE PARAMETERS
C             P, J, AND A.
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.5 < P < 1, J A NON-NEGATIVE INTEGER, A > 0
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, KEMP, AND KOTZ (2005).  "UNIVARIATE
C                 DISCRETE DISTRIBUTIONS", THIRD EDITION,
C                 WILEY, PP. 503-505.
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/11
C     ORIGINAL VERSION--NOVEMBER  2006.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      INTEGER N
      INTEGER J
      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'GENERALIZED 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 ')
        GOTO9999
      ENDIF
   11 FORMAT('***** ERROR--THE P PARAMETER FOR THE GENERALIZED ',
     1       'LOST GAMES')
   12 FORMAT('      RANDOM NUMBERS IS OUTSIDE THE ALLOWABLE (0.5,1) ',
     1       'INTERVAL')
C
      IF(J.LT.0)THEN
        WRITE(ICOUT,21)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)J
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
   21 FORMAT('***** ERROR--THE J PARAMETER FOR THE GENERALIZED ',
     1       'LOST GAMES RANDOM NUMBERS IS NON-POSITIVE')
C
      IF(A.LE.0.0)THEN
        WRITE(ICOUT,31)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,32)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)A
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
   31 FORMAT('***** ERROR--THE A PARAMETER FOR THE GENERALIZED ',
     1       'LOST GAMES')
   32 FORMAT('      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 GLGPPF(XTEMP,P,J,A,PPF)
        X(I)=PPF
  100 CONTINUE
C
 9999 CONTINUE
C
      RETURN
      END
      SUBROUTINE GLOCDF(X,ALPHA,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE TYPE 1 GENERALIZED LOGISTIC
C              DISTRIBUTION WITH SHAPE PARAMETER ALPHA.
C              THIS DISTRIBUTION IS DEFINED FOR ALL X
C              AND HAS THE CUMULATIVE DISTRIBUTION FUNCTION
C              F(X) = 1/(1+EXP(-X))**ALPHA
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE
C                                AT WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
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     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN.
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--2, 1994, PAGES 140-142
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--DECEMBER  1995.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX, DA, DCDF
      DOUBLE PRECISION DTERM1
C
      INCLUDE 'DPCOP2.INC'
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(ALPHA.LE.0.0)THEN
        WRITE(ICOUT,4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ALPHA
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9999
      ENDIF
    4 FORMAT('***** NON-FATAL DIAGNOSTIC--THE SECOND INPUT ARGUMENT ',
     *       'TO THE GLOCDF SUBROUTINE')
    5 FORMAT('      IS NON-POSITIVE. *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
C-----START POINT-----------------------------------------------------
C
      DX=DBLE(X)
      DA=DBLE(ALPHA)
      DTERM1=-DA*DLOG(1.D0+DEXP(-DX))
      IF(DTERM1.LE.-500.D0)THEN
        CDF=0.0
      ELSEIF(DTERM1.GE.500.D0)THEN
        CDF=1.0
      ELSE
        DCDF=DEXP(DTERM1)
        CDF=SNGL(DCDF)
      ENDIF
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE GLOPDF(X,ALPHA,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE TYPE 1 GENERALIZED LOGISTIC
C              DISTRIBUTION WITH SHAPE PARAMETER ALPHA.
C              THIS DISTRIBUTION IS DEFINED FOR ALL X
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C              F(X) = ALPHA*EXP(-X)/(1+EXP(-X))**(ALPHA+1)
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE
C                                AT 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 FOR THE GENERALIZED LOGISTIC
C             DISTRIBUTION
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE NON-NEGATIVE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN.
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--2, 1994, PAGES 140-142
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--DECEMBER  1995.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX, DA, DPDF
      DOUBLE PRECISION DTERM1, DTERM2, DTERM3
C
      INCLUDE 'DPCOP2.INC'
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(ALPHA.LE.0.0)THEN
        WRITE(ICOUT,4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ALPHA
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ENDIF
    4 FORMAT('***** NON-FATAL DIAGNOSTIC--THE SECOND INPUT ARGUMENT ',
     *       'TO THE GLOPDF SUBROUTINE')
    5 FORMAT('      IS NON-POSITIVE. *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
C-----START POINT-----------------------------------------------------
C
      DX=DBLE(X)
      DA=DBLE(ALPHA)
      DTERM1=DLOG(DA)
      DTERM2=DX + (DA+1.0D0)*DLOG(1.0+DEXP(-DX))
      DTERM3=DTERM1-DTERM2
      IF(DTERM3.LE.-500.D0)THEN
        PDF=0.0
      ELSE
        DPDF=DEXP(DTERM3)
        PDF=SNGL(DPDF)
      ENDIF
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE GLOPPF(P,ALPHA,PPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE TYPE 1 GENERALIZED LOGISTIC
C              DISTRIBUTION WITH SHAPE PARAMETER ALPHA.
C              THIS DISTRIBUTION IS DEFINED FOR ALL X
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C              F(X) = ALPHA/(EXP(X)*(1+EXP(-X))**(ALPHA+1))
C                                                     0<=X<=1/K
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 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, KOTZ, AND BALAKRISHNAN CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--2, 1994, PAGES 140-142
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--95/12
C     ORIGINAL VERSION--DECEMBER  1995.
C
C-----STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DOUBLE PRECISION DP, DA, DPPF
      DOUBLE PRECISION DTERM1
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 ')
        PPF=0.0
        GOTO9999
      ENDIF
    1 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ',
     1'GLOPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
      DP=DBLE(P)
      DA=DBLE(ALPHA)
      DTERM1=DP**(-1.0D0/DA) - 1.0D0
      DPPF=-DLOG(DTERM1)
      PPF=SNGL(DPPF)
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE GLORAN(N,ALPHA,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE GENERALIZED 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 GENERALIZED 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     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,47)N
        CALL DPWRST('XXX','BUG ')
        RETURN
      ENDIF
    5 FORMAT('***** ERROR--THE REQUESTED NUMBER OF GENERALIZED ',
     1       'LOGISTIC 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 GENERALIZED LOGISTIC RANDOM NUMBERS
C     USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD
C
      DO100I=1,N
      CALL GLOPPF(X(I),ALPHA,XTEMP)
      X(I)=XTEMP
  100 CONTINUE
C
      RETURN
      END
      SUBROUTINE GL2CDF(DX,DALPHA,DCDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE TYPE 2 GENERALIZED LOGISTIC
C              DISTRIBUTION WITH SHAPE PARAMETER ALPHA.
C              THIS DISTRIBUTION IS DEFINED FOR ALL X
C              AND HAS THE CUMULATIVE DISTRIBUTION FUNCTION
C              F(X) = 1 - EXP(-ALPHA*X)/(1+EXP(-X))**ALPHA
C     INPUT  ARGUMENTS--DX     = THE DOUBLE PRECISION VALUE
C                                AT WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                     --DALPHA = THE DOUBLE PRECISION SHAPE
C                                PARAMETER.
C     OUTPUT ARGUMENTS--DCDF   = THE DOUBLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION CUMULATIVE DISTRIBUTION FUNCTION
C             VALUE FOR THE TYPE 2 GENERALIZED LOGISTIC DISTRIBUTION
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--ALPHA SHOULD BE POSITIVE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--DLOG, DEXP.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN.
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--2, 1994, PAGES 140-142
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--MARCH     2006.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DALPHA
      DOUBLE PRECISION DCDF
      DOUBLE PRECISION DTERM1
C
      INCLUDE 'DPCOP2.INC'
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(DALPHA.LE.0.0D0)THEN
        WRITE(ICOUT,4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)DALPHA
        CALL DPWRST('XXX','BUG ')
        DCDF=0.0D0
        GOTO9999
      ENDIF
    4 FORMAT('***** ERROR--THE SHAPE PARAMETER FOR THE GL2CDF ',
     1       'SUBROUTINE IS NON-POSITIVE.')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
C
C-----START POINT-----------------------------------------------------
C
      DTERM1=-DALPHA*DX - DALPHA*DLOG(1.0D0 + DEXP(-DX))
      DCDF=1.0D0 - DEXP(DTERM1)
C
 9999 CONTINUE
      RETURN
      END
      DOUBLE PRECISION FUNCTION GL2FU2(DX)
C
C     PURPOSE--GL2PPF CALLS DFZERO TO FIND A ROOT FOR THE PERCENT
C              POINT FUNCTION.  GL2FU2 IS THE FUNCTION FOR WHICH
C              THE ZERO IS FOUND.  IT IS:
C                 P - GL2CDF(X,ALPHA)
C              WHERE P IS THE DESIRED PERCENT POINT.
C     INPUT  ARGUMENTS--DX     = THE DOUBLE PRECISION VALUE AT
C                                WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C     OUTPUT--THE DOUBLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE GL2FU2.
C     PRINTING--NONE.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--GL2CDF.
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 UNIVARIATE
C                 DISTRIBUTIONS--2, 1994, PAGES 140-142
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--2006.3
C     ORIGINAL VERSION--MARCH     2006.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DCDF
C
      DOUBLE PRECISION DP
      DOUBLE PRECISION DALPHA
      COMMON/GL2COM/DP,DALPHA
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      CALL GL2CDF(DX,DALPHA,DCDF)
      GL2FU2=DP - DCDF
C
      RETURN
      END
      SUBROUTINE GL2PDF(DX,DALPHA,DPDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE TYPE 2 GENERALIZED LOGISTIC
C              DISTRIBUTION WITH SHAPE PARAMETER ALPHA.
C              THIS DISTRIBUTION IS DEFINED FOR ALL X
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C              F(X,ALPHA) = ALPHA*EXP(X)/(1+EXP(X))**(ALPHA+1)
C                           ALPHA > 0
C
C     INPUT  ARGUMENTS--DX     = THE DOUBLE PRECISION VALUE
C                                AT WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                     --DALPHA = THE DOUBLE PRECISION SHAPE
C                                PARAMETER.
C     OUTPUT ARGUMENTS--DPDF   = THE DOUBLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION PROBABILITY DENSITY FUNCTION
C             VALUE FOR THE TYPE 2 GENERALIZED LOGISTIC DISTRIBUTION
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--ALPHA SHOULD BE POSITIVE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--EXP, LOG.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN.
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--2, 1994, PAGES 140-142
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--MARCH     2006.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DALPHA
      DOUBLE PRECISION DPDF
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
C
      INCLUDE 'DPCOP2.INC'
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(DALPHA.LE.0.0D0)THEN
        WRITE(ICOUT,4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)DALPHA
        CALL DPWRST('XXX','BUG ')
        DPDF=0.0D0
        GOTO9999
      ENDIF
    4 FORMAT('***** ERROR--THE SHAPE PARAMETER FOR THE GL2PDF ',
     1       'SUBROUTINE IS NON-POSITIVE.')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
C
C-----START POINT-----------------------------------------------------
C
C  COMPUTE FIRST COMPONENT
C
      DX=-DX
      DTERM1=DLOG(DALPHA)
      DTERM2=DX + (DALPHA+1.0D0)*DLOG(1.0+DEXP(-DX))
      DTERM3=DTERM1-DTERM2
      DPDF=DEXP(DTERM3)
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE GL2PPF(DP,DALPHA,DPPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE GENERALIZED LOGISTIC TYPE 2
C              DISTRIBUTION WITH SHAPE PARAMETER ALPHA.
C              THIS DISTRIBUTION IS DEFINED FOR REAL X AND THE
C              PERCENT POINT FUNCTION IS COMPUTED BY
C              NUMERICALLY INVERTING THE CDF FUNCTION.
C     INPUT  ARGUMENTS--DP     = THE DOUBLE PRECISION VALUE AT
C                                WHICH THE PERCENT POINT
C                                FUNCTION IS TO BE EVALUATED.
C                     --DALPHA = THE FIRST SHAPE PARAMETER
C     OUTPUT ARGUMENTS--DPPF   = THE DOUBLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION PERCENT POINT FUNCTION VALUE DPPF.
C     PRINTING--NONE.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--DFZERO.
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 UNIVARIATE
C                 DISTRIBUTIONS--2, 1994, PAGES 140-142
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     ORIGINAL VERSION--MARCH     2006.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DP
      DOUBLE PRECISION DALPHA
      DOUBLE PRECISION DPPF
C
      DOUBLE PRECISION GL2FU2
      EXTERNAL GL2FU2
C
      DOUBLE PRECISION DP2
      DOUBLE PRECISION DALPH2
      COMMON/GL2COM/DP2,DALPH2
C
      DOUBLE PRECISION XLOW
      DOUBLE PRECISION XLOW2
      DOUBLE PRECISION XUP
      DOUBLE PRECISION XUP2
      DOUBLE PRECISION PTEMPL
      DOUBLE PRECISION PTEMPU
      DOUBLE PRECISION AE
      DOUBLE PRECISION RE
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      DPPF=0.0D0
      NIT=0
      IF(DALPHA.LE.0.0D0)THEN
        WRITE(ICOUT,101)
  101   FORMAT('***** ERROR--THE FIRST SHAPE PARAMETER, ALPHA, TO ',
     1         'GL2PPF IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,104)DALPHA
  104   FORMAT('      THE VALUE OF THE ARGUMENT IS ',G15.7,'.')
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(DP.LE.0.0D0.OR.DP.GE.1.0D0)THEN
         WRITE(ICOUT,61)
   61    FORMAT('***** ERROR--THE FIRST ARGUMENT TO GL2PPF ',
     1          'IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL.')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,104)DP
         CALL DPWRST('XXX','BUG ')
         GOTO9000
      ENDIF
C
C  STEP 1: FIND BRACKETING INTERVAL.  START WITH (-5,5) AND
C          INCREMENT UNITL A BRACKETING INTERVAL IS FOUND.
C
      NIT=0
      MAXIT=2000
      XLOW2=-10.0D0
      XUP2=10.0D0
  200 CONTINUE
        CALL GL2CDF(XLOW2,DALPHA,PTEMPL)
        CALL GL2CDF(XUP2,DALPHA,PTEMPU)
        IF(PTEMPL.LT.DP .AND. PTEMPU.GT.DP)THEN
          XUP=XUP2
          XLOW=XLOW2
          GOTO300
        ELSEIF(PTEMPL.LT.DP .AND. PTEMPU.LT.DP)THEN
          NIT=NIT+1
          XUP2=10.0D0*XUP2
          IF(NIT.LE.MAXIT)GOTO200
        ELSEIF(PTEMPL.GT.DP .AND. PTEMPU.GT.DP)THEN
          NIT=NIT+1
          XLOW2=10.0D0*XLOW2
          IF(NIT.LE.MAXIT)GOTO200
        ENDIF
C
        WRITE(ICOUT,201)
  201   FORMAT('***** ERROR FROM GL2PPF--UNABLE TO FIND A ',
     1         'BRACKETING INTERVAL')
        CALL DPWRST('XXX','BUG ')
        GOTO9000
C
  300 CONTINUE
      AE=1.0D-8
      RE=1.0D-8
      DP2=DP
      DALPH2=DALPHA
      CALL DFZERO(GL2FU2,XLOW,XUP,XUP,RE,AE,IFLAG)
C
      DPPF=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,121)
CC111   FORMAT('***** WARNING FROM GL2PPF--')
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 GL2PPF--')
        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 GL2PPF--')
        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,121)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,143)
  143   FORMAT('      MAXIMUM ITERATIONS EXCEEDED.')
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE GL2RAN(N,ALPHA,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE GENERALIZED LOGISTIC TYPE 2 DISTRIBUTION
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --ALPHA  = THE SHAPE PARAMETER
C                     --SEED   = THE SEED FOR THE RANDOM NUMBER
C                                GENERATOR
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 GENERALIZED LOGISTIC TYPE 2 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, GL2PPF.
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--2006/3
C     ORIGINAL VERSION--MARCH     2006.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
C
      DOUBLE PRECISION DX
      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)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,6)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
        CALL DPWRST('XXX','BUG ')
        RETURN
      ENDIF
    5 FORMAT('***** ERROR--THE REQUESTED NUMBER OF GENERALIZED ',
     1       'LOGISTIC TYPE 2')
    6 FORMAT('      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 GENERALIZED LOGISTIC TYPE 2 RANDOM NUMBERS
C     USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD
C
      DO100I=1,N
        DX=DBLE(X(I))
        CALL GL2PPF(DX,DBLE(ALPHA),DPPF)
        X(I)=REAL(DPPF)
  100 CONTINUE
C
      RETURN
      END
      SUBROUTINE GL3CDF(DX,DALPHA,DCDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE GENERALIZED LOGISTIC TYPE 3
C              DISTRIBUTION WITH SHAPE PARAMETER ALPHA.
C              THE CUMULATIVE DISTRIBUTION IS COMPUTED BY
C              NUMERICALLY INTEGRATING THE PDF FUNCTION.
C     INPUT  ARGUMENTS--DX     = THE DOUBLE PRECISION VALUE AT
C                                WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C                     --DALPHA = THE DOUBLE PRECISION SHAPE PARAMETER.
C     OUTPUT ARGUMENTS--DCDF   = THE DOUBLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE FOR THE GENERALIZED LOGISTIC TYPE 3
C             DISTRIBUTION WITH SHAPE PARAMETER ALPHA.
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, PP. 140-142, 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 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION ALPHAMBER--2006/3
C     ORIGINAL VERSION--MARCH     2006.
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)
      DOUBLE PRECISION DX
      DOUBLE PRECISION DALPHA
      DOUBLE PRECISION DCDF
      DOUBLE PRECISION DA
      DOUBLE PRECISION EPSABS
      DOUBLE PRECISION EPSREL
      DOUBLE PRECISION ABSERR
      DOUBLE PRECISION WORK(LENW)
C
      DOUBLE PRECISION GL3FUN
      EXTERNAL GL3FUN
C
      DOUBLE PRECISION DALPH2
      COMMON/GL3COM/DALPH2
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
      DCDF=0.0D0
      IF(DALPHA.LE.0.0D0)THEN
        WRITE(ICOUT,101)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,102)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,104)DALPHA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
  101 FORMAT('***** ERROR--THE SHAPE PARAMETER, ALPHA, TO THE')
  102 FORMAT('      GL3CDF ROUTINE IS NON-POSITIVE.')
  104 FORMAT('***** VALUE OF THE ARGUMENT = ',G15.7)
C
C
C               ************************************
C               **  STEP 1--                      **
C               **  COMPUTE THE DENSITY FUNCTION  **
C               ************************************
C
      EPSABS=1.0D-8
      EPSREL=1.0D-8
      IER=0
      IKEY=3
      DCDF=0.0D0
C
      DA=1.0D-7
      DALPH2=DALPHA
C
      IF(DX.LE.0.0D0)THEN
        INF=-1
        CALL DQAGI(GL3FUN,DX,INF,EPSABS,EPSREL,DCDF,ABSERR,NEVAL,
     1          IER,LIMIT,LENW,LAST,IWORK,WORK)
      ELSE
C
        INF=+1
        CALL DQAGI(GL3FUN,DX,INF,EPSABS,EPSREL,DCDF,ABSERR,NEVAL,
     1          IER,LIMIT,LENW,LAST,IWORK,WORK)
        DCDF=1.0D0 - 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 GL3CDF--')
        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 GL3CDF--')
        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 GL3CDF--')
        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 GL3CDF--')
        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 GL3CDF--')
        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 GL3CDF--')
        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 GL3FUN(DX)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE GENERALIZED LOGISTIC TYPE 3
C              DISTRIBUTION WITH SHAPE PARAMETER ALPHA.
C              THIS DISTRIBUTION IS DEFINED FOR X > 0 AND HAS
C              THE PROBABILITY DENSITY FUNCTION
C              f(X;ALPHA) = (1/BETA(ALPHA,ALPHA)*EXP(-ALPHA*X)/
C                           (1+EXP(-X))**(2*ALPHA)    ALPHA > 0
C              THIS FUNCTION IS USED FOR INTEGRATION BY THE
C              GL3CDF ROUTINE.
C     INPUT  ARGUMENTS--DX     = THE DOUBLE PRECISION VALUE AT
C                                WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C     OUTPUT ARGUMENTS--GL3FUN = THE DOUBLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE PDF FOR THE GENERALIZED LOGISTIC
C             TYPE 3 DISTRIBUTION WITH SHAPE PARAMETER ALPHA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--GL3PDF.
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 UNIVARIATE
C                 DISTRIBUTIONS--2, 1994, PAGES 140-142
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--2006.3
C     ORIGINAL VERSION--MARCH     2006.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DPDF
C
      DOUBLE PRECISION DALPHA
      COMMON/GL3COM/DALPHA
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 GL3PDF(DX,DALPHA,DPDF)
      GL3FUN=DPDF
C
      RETURN
      END
      DOUBLE PRECISION FUNCTION GL3FU2(DX)
C
C     PURPOSE--GL3PPF CALLS DFZERO TO FIND A ROOT FOR THE PERCENT
C              POINT FUNCTION.  GL3FU2 IS THE FUNCTION FOR WHICH
C              THE ZERO IS FOUND.  IT IS:
C                 P - GL3CDF(X,P,Q)
C              WHERE P IS THE DESIRED PERCENT POINT.
C     INPUT  ARGUMENTS--DX     = THE DOUBLE PRECISION VALUE AT
C                                WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C     OUTPUT--THE DOUBLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE GL3FU2.
C     PRINTING--NONE.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--GL3CDF.
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 UNIVARIATE
C                 DISTRIBUTIONS--2, 1994, PAGES 140-143
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--2006.3
C     ORIGINAL VERSION--MARCH     2006.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DCDF
C
      DOUBLE PRECISION DP
      DOUBLE PRECISION DALPHA
      COMMON/GL3CO2/DP,DALPHA
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      CALL GL3CDF(DX,DALPHA,DCDF)
      GL3FU2=DP - DCDF
C
      RETURN
      END
      SUBROUTINE GL3RAN(N,ALPHA,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE GENERALIZED LOGISTIC TYPE 3 DISTRIBUTION
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --ALPHA  = THE SHAPE PARAMETER
C                     --SEED   = THE SEED FOR THE RANDOM NUMBER
C                                GENERATOR
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 GENERALIZED LOGISTIC TYPE 3 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, GL3PPF.
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--2006/3
C     ORIGINAL VERSION--MARCH     2006.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
C
      DOUBLE PRECISION DX
      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)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,6)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
        CALL DPWRST('XXX','BUG ')
        RETURN
      ENDIF
    5 FORMAT('***** ERROR--THE REQUESTED NUMBER OF GENERALIZED ',
     1       'LOGISTIC TYPE 3')
    6 FORMAT('      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 GENERALIZED LOGISTIC TYPE 3 RANDOM NUMBERS
C     USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD
C
      DO100I=1,N
        DX=DBLE(X(I))
        CALL GL3PPF(DX,DBLE(ALPHA),DPPF)
        X(I)=REAL(DPPF)
  100 CONTINUE
C
      RETURN
      END
      SUBROUTINE GL3PDF(DX,DALPHA,DPDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE TYPE 3 GENERALIZED LOGISTIC
C              DISTRIBUTION WITH SHAPE PARAMETER ALPHA.
C              THIS DISTRIBUTION IS DEFINED FOR ALL X
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C              f(X;ALPHA) = (1/BETA(ALPHA,ALPHA)*EXP(-ALPHA*X)/
C                           (1+EXP(-X))**(2*ALPHA)
C     INPUT  ARGUMENTS--DX     = THE DOUBLE PRECISION VALUE
C                                AT WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                     --DALPHA = THE DOUBLE PRECISION SHAPE
C                                PARAMETER.
C     OUTPUT ARGUMENTS--DPDF   = THE DOUBLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION PROBABILITY DENSITY FUNCTION
C             VALUE FOR THE TYPE 3 GENERALIZED LOGISTIC DISTRIBUTION
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--ALPHA SHOULD BE POSITIVE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--DLOG, DEXP,DLBETA.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN.
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--2, 1994, PAGES 140-142
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--MARCH     2006.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DALPHA
      DOUBLE PRECISION DPDF
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DLBETA
C
      INCLUDE 'DPCOP2.INC'
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(DALPHA.LE.0.0D0)THEN
        WRITE(ICOUT,4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)DALPHA
        CALL DPWRST('XXX','BUG ')
        DPDF=0.0D0
        GOTO9999
      ENDIF
    4 FORMAT('***** ERROR--THE SHAPE PARAMETER FOR THE GL3PDF ',
     1       'SUBROUTINE IS NON-POSITIVE.')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
C
C-----START POINT-----------------------------------------------------
C
      DTERM1=DLBETA(DALPHA,DALPHA)
      DTERM2=-DALPHA*DX - 2.0D0*DALPHA*DLOG(1.0D0 + DEXP(-DX))
      DPDF=DEXP(DTERM2 - DTERM1)
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE GL3PPF(DP,DALPHA,DPPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE GENERALIZED LOGISTIC TYPE 3
C              DISTRIBUTION WITH SHAPE PARAMETER ALPHA.
C              THIS DISTRIBUTION IS DEFINED FOR REAL X AND THE
C              PERCENT POINT FUNCTION IS COMPUTED BY
C              NUMERICALLY INVERTING THE CDF FUNCTION.
C     INPUT  ARGUMENTS--DP     = THE DOUBLE PRECISION VALUE AT
C                                WHICH THE PERCENT POINT
C                                FUNCTION IS TO BE EVALUATED.
C                     --DALPHA = THE SHAPE PARAMETER
C     OUTPUT ARGUMENTS--DPPF   = THE DOUBLE PRECISION PERCENT POINT
C                                FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION PERCENT POINT FUNCTION VALUE DPPF.
C     PRINTING--NONE.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--DFZERO.
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 UNIVARIATE
C                 DISTRIBUTIONS--2, 1994, PAGES 140-143
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     ORIGINAL VERSION--MARCH     2006.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DP
      DOUBLE PRECISION DALPHA
      DOUBLE PRECISION DPPF
C
      DOUBLE PRECISION GL3FU2
      EXTERNAL GL3FU2
C
      DOUBLE PRECISION DP2
      DOUBLE PRECISION DALPH2
      COMMON/GL3CO2/DP2,DALPH2
C
      DOUBLE PRECISION XLOW
      DOUBLE PRECISION XLOW2
      DOUBLE PRECISION XUP
      DOUBLE PRECISION XUP2
      DOUBLE PRECISION PTEMPL
      DOUBLE PRECISION PTEMPU
      DOUBLE PRECISION AE
      DOUBLE PRECISION RE
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      DPPF=0.0D0
      IF(DALPHA.LE.0.0D0)THEN
        WRITE(ICOUT,101)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,102)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,104)DALPHA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
  101 FORMAT('***** ERROR--THE FIRST SHAPE PARAMETER, ALPHA, TO THE')
  102 FORMAT('      GL3PPF ROUTINE IS NON-POSITIVE.')
  104 FORMAT('      THE VALUE OF THE ARGUMENT IS ',E15.7,' ******')
C
      IF(DP.LE.0.0D0.OR.DP.GE.1.0D0)THEN
         WRITE(ICOUT,61)
   61    FORMAT('***** ERROR--THE FIRST  INPUT ARGUMENT ',
     1          'TO THE GL3PPF SUBROUTINE ')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,62)
   62    FORMAT('      IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,63)DP
   63    FORMAT('      THE VALUE OF ARGUMENT = ',G15.7)
         CALL DPWRST('XXX','BUG ')
         GOTO9000
      ENDIF
C
C  STEP 1: FIND BRACKETING INTERVAL.  START WITH (-5,5) AND
C          INCREMENT UNITL A BRACKETING INTERVAL IS FOUND.
C
C          TAKE ADVANTAGE OF FACT THAT GL3 IS SYMMETRIC
C          (P = 0.5 IMPLIES PPF = 0).
C
C          ALSO, MEAN = 0 AND SD = SQRT(2*PSI'(ALPHA))
C
      MAXIT=1000
      NIT=1
      IF(DP.EQ.0.5D0)THEN
        DPPF=0.0D0
        GOTO9000
      ELSEIF(DP.LT.0.5D0)THEN
        XLOW2=-10.0D0
        XUP2=0.0D0
      ELSE
        XLOW2=0.0D0
        XUP2=10.0D0
      ENDIF
C
  200 CONTINUE
        CALL GL3CDF(XLOW2,DALPHA,PTEMPL)
        CALL GL3CDF(XUP2,DALPHA,PTEMPU)
        IF(PTEMPL.LT.DP .AND. PTEMPU.GT.DP)THEN
          XUP=XUP2
          XLOW=XLOW2
          GOTO300
        ELSEIF(PTEMPL.LT.DP .AND. PTEMPU.LT.DP)THEN
          NIT=NIT+1
          XUP2=10.0D0*XUP2
          IF(NIT.LE.MAXIT)GOTO200
        ELSEIF(PTEMPL.GT.DP .AND. PTEMPU.GT.DP)THEN
          NIT=NIT+1
          XLOW2=10.0D0*XLOW2
          IF(NIT.LE.MAXIT)GOTO200
        ENDIF
C
        WRITE(ICOUT,201)
  201   FORMAT('***** ERROR FROM GL3PPF--UNABLE TO FIND A ',
     1         'BRACKETING INTERVAL')
        CALL DPWRST('XXX','BUG ')
        GOTO9000
C
  300 CONTINUE
      AE=1.0D-6
      RE=1.0D-6
      DP2=DP
      DALPH2=DALPHA
      CALL DFZERO(GL3FU2,XLOW,XUP,XUP,RE,AE,IFLAG)
C
      DPPF=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,121)
CC111   FORMAT('***** WARNING FROM GL3PPF--')
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 GL3PPF--')
        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 GL3PPF--')
        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,121)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,143)
  143   FORMAT('      MAXIMUM ITERATIONS EXCEEDED.')
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE GL4CDF(DX,DP,DQ,DCDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE GENERALIZED LOGISTIC TYPE 4
C              DISTRIBUTION WITH SHAPE PARAMETER P AND Q.
C              THE CUMULATIVE DISTRIBUTION IS COMPUTED BY
C              NUMERICALLY INTEGRATING THE PDF FUNCTION.
C     INPUT  ARGUMENTS--DX     = THE DOUBLE PRECISION VALUE AT
C                                WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C                     --DALPHA = THE DOUBLE PRECISION SHAPE PARAMETER.
C     OUTPUT ARGUMENTS--DCDF   = THE DOUBLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE FOR THE GENERALIZED LOGISTIC TYPE 4
C             DISTRIBUTION WITH SHAPE PARAMETER P AND Q.
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, PP. 140-142, 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 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION ALPHAMBER--2006/3
C     ORIGINAL VERSION--MARCH     2006.
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)
      DOUBLE PRECISION DX
      DOUBLE PRECISION DP
      DOUBLE PRECISION DQ
      DOUBLE PRECISION DCDF
      DOUBLE PRECISION EPSABS
      DOUBLE PRECISION EPSREL
      DOUBLE PRECISION ABSERR
      DOUBLE PRECISION WORK(LENW)
C
      DOUBLE PRECISION GL4FUN
      EXTERNAL GL4FUN
C
      DOUBLE PRECISION DP2,DQ2
      COMMON/GL4COM/DP2,DQ2
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
      DCDF=0.0D0
      IF(DP.LE.0.0D0)THEN
        WRITE(ICOUT,101)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,102)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,104)DP
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
      IF(DQ.LE.0.0D0)THEN
        WRITE(ICOUT,105)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,106)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,104)DQ
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
  101 FORMAT('***** ERROR--THE FIRST SHAPE PARAMETER, P, TO THE')
  102 FORMAT('      GL4CDF ROUTINE IS NON-POSITIVE.')
  105 FORMAT('***** ERROR--THE SECOND SHAPE PARAMETER, Q, TO THE')
  106 FORMAT('      GL4CDF ROUTINE IS NON-POSITIVE.')
  104 FORMAT('***** VALUE OF THE ARGUMENT = ',G15.7)
C
C
C               ************************************
C               **  STEP 1--                      **
C               **  COMPUTE THE DENSITY FUNCTION  **
C               ************************************
C
      EPSABS=1.0D-10
      EPSREL=1.0D-10
      IER=0
      IKEY=3
      DCDF=0.0D0
C
      DP2=DP
      DQ2=DQ
C
      IF(DX.LE.0.0D0)THEN
        INF=-1
        CALL DQAGI(GL4FUN,DX,INF,EPSABS,EPSREL,DCDF,ABSERR,NEVAL,
     1          IER,LIMIT,LENW,LAST,IWORK,WORK)
      ELSE
C
        INF=+1
        CALL DQAGI(GL4FUN,DX,INF,EPSABS,EPSREL,DCDF,ABSERR,NEVAL,
     1          IER,LIMIT,LENW,LAST,IWORK,WORK)
        DCDF=1.0D0 - 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 GL4CDF--')
        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 GL4CDF--')
        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 GL4CDF--')
        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 GL4CDF--')
        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 GL4CDF--')
        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 GL4CDF--')
        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 GL4FUN(DX)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE GENERALIZED LOGISTIC TYPE 4
C              DISTRIBUTION WITH SHAPE PARAMETER ALPHA.
C              THIS DISTRIBUTION IS DEFINED FOR X > 0 AND HAS
C              THE PROBABILITY DENSITY FUNCTION
C              f(X;P,Q) = (1/BETA(P,Q)*EXP(-Q*X)/
C                         (1+EXP(-X))**(P+Q)
C                         P, Q > 0
C              THIS FUNCTION IS USED FOR INTEGRATION BY THE
C              GL4CDF ROUTINE.
C     INPUT  ARGUMENTS--DX     = THE DOUBLE PRECISION VALUE AT
C                                WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C     OUTPUT ARGUMENTS--GL4FUN = THE DOUBLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE PDF FOR THE GENERALIZED LOGISTIC
C             TYPE 4 DISTRIBUTION WITH SHAPE PARAMETER ALPHA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--GL4PDF.
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 UNIVARIATE
C                 DISTRIBUTIONS--2, 1994, PAGES 140-142
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--2006.3
C     ORIGINAL VERSION--MARCH     2006.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DPDF
C
      DOUBLE PRECISION DP
      DOUBLE PRECISION DQ
      COMMON/GL4COM/DP,DQ
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 GL4PDF(DX,DP,DQ,DPDF)
      GL4FUN=DPDF
C
      RETURN
      END
      DOUBLE PRECISION FUNCTION GL4FU2(DX)
C
C     PURPOSE--GL4PPF CALLS DFZERO TO FIND A ROOT FOR THE PERCENT
C              POINT FUNCTION.  GL4FU2 IS THE FUNCTION FOR WHICH
C              THE ZERO IS FOUND.  IT IS:
C                 P - GL4CDF(X,P,Q)
C              WHERE P IS THE DESIRED PERCENT POINT.
C     INPUT  ARGUMENTS--DX     = THE DOUBLE PRECISION VALUE AT
C                                WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C     OUTPUT--THE DOUBLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE GL4FU2.
C     PRINTING--NONE.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--GL4CDF.
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 UNIVARIATE
C                 DISTRIBUTIONS--2, 1994, PAGES 140-143
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--2006.3
C     ORIGINAL VERSION--MARCH     2006.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DCDF
C
      DOUBLE PRECISION DP
      DOUBLE PRECISION DPPAR
      DOUBLE PRECISION DQPAR
      COMMON/GL4CO2/DP,DPPAR,DQPAR
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      CALL GL4CDF(DX,DPPAR,DQPAR,DCDF)
      GL4FU2=DP - DCDF
C
      RETURN
      END
      SUBROUTINE GL4PDF(DX,DP,DQ,DPDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE TYPE 4 GENERALIZED LOGISTIC
C              DISTRIBUTION WITH SHAPE PARAMETERS P AND Q.
C              THIS DISTRIBUTION IS DEFINED FOR ALL X
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C              f(X;P,Q) = (1/BETA(P,Q)*EXP(-Q*X)/
C                         (1+EXP(-X))**(P+Q)
C                         P, Q > 0
C     INPUT  ARGUMENTS--DX     = THE DOUBLE PRECISION VALUE
C                                AT WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                     --DP     = THE DOUBLE PRECISION FIRST SHAPE
C                                PARAMETER.
C                     --DQ     = THE DOUBLE PRECISION SECOND SHAPE
C                                PARAMETER.
C     OUTPUT ARGUMENTS--DPDF   = THE DOUBLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION PROBABILITY DENSITY FUNCTION
C             VALUE FOR THE TYPE 3 GENERALIZED LOGISTIC DISTRIBUTION
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--ALPHA SHOULD BE POSITIVE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--DLOG, DEXP,DLBETA.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN.
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--2, 1994, PAGES 140-143
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--MARCH     2006.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DP
      DOUBLE PRECISION DQ
      DOUBLE PRECISION DPDF
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DLBETA
C
      INCLUDE 'DPCOP2.INC'
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      DPDF=0.0D0
      IF(DP.LE.0.0D0)THEN
        WRITE(ICOUT,4)
    4   FORMAT('***** ERROR--THE FIRST SHAPE PARAMETER FOR ',
     1       'GL4PDF IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)DP
   46   FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7,'.')
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ELSEIF(DQ.LE.0.0D0)THEN
        WRITE(ICOUT,5)
    5   FORMAT('***** ERROR--THE SECOND SHAPE PARAMETER FOR GL4PDF ',
     1         'IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)DQ
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
C
C-----START POINT-----------------------------------------------------
C
      DTERM1=DLBETA(DP,DQ)
      DTERM2=-DQ*DX - (DP+DQ)*DLOG(1.0D0 + DEXP(-DX))
      DPDF=DEXP(DTERM2 - DTERM1)
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE GL4PPF(DP,DPPAR,DQPAR,DPPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE GENERALIZED LOGISTIC TYPE 4
C              DISTRIBUTION WITH SHAPE PARAMETERS P AND Q.
C              THIS DISTRIBUTION IS DEFINED FOR REAL X AND THE
C              PERCENT POINT FUNCTION IS COMPUTED BY
C              NUMERICALLY INVERTING THE CDF FUNCTION.
C     INPUT  ARGUMENTS--DP     = THE DOUBLE PRECISION VALUE AT
C                                WHICH THE PERCENT POINT
C                                FUNCTION IS TO BE EVALUATED.
C                     --DPPAR  = THE FIRST SHAPE PARAMETER
C                     --DQPAR  = THE SECOND SHAPE PARAMETER
C     OUTPUT ARGUMENTS--DPPF   = THE DOUBLE PRECISION PERCENT POINT
C                                FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION PERCENT POINT FUNCTION VALUE DPPF.
C     PRINTING--NONE.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--DFZERO.
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 UNIVARIATE
C                 DISTRIBUTIONS--2, 1994, PAGES 140-143
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     ORIGINAL VERSION--MARCH     2006.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DP
      DOUBLE PRECISION DPPAR
      DOUBLE PRECISION DQPAR
      DOUBLE PRECISION DPPF
C
      DOUBLE PRECISION GL4FU2
      EXTERNAL GL4FU2
C
      DOUBLE PRECISION DP2
      DOUBLE PRECISION DPPAR2
      DOUBLE PRECISION DQPAR2
      COMMON/GL4CO2/DP2,DPPAR2,DQPAR2
C
      DOUBLE PRECISION XLOW
      DOUBLE PRECISION XLOW2
      DOUBLE PRECISION XUP
      DOUBLE PRECISION XUP2
      DOUBLE PRECISION PTEMPL
      DOUBLE PRECISION PTEMPU
      DOUBLE PRECISION AE
      DOUBLE PRECISION RE
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      DPPF=0.0D0
      IF(DPPAR.LE.0.0D0)THEN
        WRITE(ICOUT,101)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,102)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,104)DPPAR
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
      IF(DQPAR.LE.0.0D0)THEN
        WRITE(ICOUT,103)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,102)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,104)DQPAR
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
  101 FORMAT('***** ERROR--THE FIRST SHAPE PARAMETER, P, TO THE')
  102 FORMAT('      GL4PPF ROUTINE IS NON-POSITIVE.')
  103 FORMAT('***** ERROR--THE SECOND SHAPE PARAMETER, Q, TO THE')
  104 FORMAT('      THE VALUE OF THE ARGUMENT IS ',E15.7,' ******')
C
      IF(DP.LE.0.0D0.OR.DP.GE.1.0D0)THEN
         WRITE(ICOUT,61)
   61    FORMAT('***** ERROR--THE FIRST  INPUT ARGUMENT ',
     1          'TO THE GL4PPF SUBROUTINE ')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,62)
   62    FORMAT('      IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,63)DP
   63    FORMAT('      THE VALUE OF ARGUMENT = ',G15.7)
         CALL DPWRST('XXX','BUG ')
         GOTO9000
      ENDIF
C
C  STEP 1: FIND BRACKETING INTERVAL.  START WITH (-5,5) AND
C          INCREMENT UNITL A BRACKETING INTERVAL IS FOUND.
C
      MAXIT=1000
      XLOW2=-5.0D0
      XUP2=5.0D0
C
  200 CONTINUE
        CALL GL4CDF(XLOW2,DPPAR,DQPAR,PTEMPL)
        CALL GL4CDF(XUP2,DPPAR,DQPAR,PTEMPU)
        IF(PTEMPL.LT.DP .AND. PTEMPU.GT.DP)THEN
          XUP=XUP2
          XLOW=XLOW2
          GOTO300
        ELSEIF(PTEMPL.LT.DP .AND. PTEMPU.LT.DP)THEN
          MAXIT=MAXIT+1
          XUP2=5.0D0*XUP2
          IF(MAXIT.LE.MAXIT)GOTO200
        ELSEIF(PTEMPL.GT.DP .AND. PTEMPU.GT.DP)THEN
          MAXIT=MAXIT+1
          XLOW2=5.0D0*XLOW2
          IF(MAXIT.LE.MAXIT)GOTO200
        ENDIF
C
        WRITE(ICOUT,201)
  201   FORMAT('***** ERROR FROM GL4PPF--UNABLE TO FIND A ',
     1         'BRACKETING INTERVAL')
        CALL DPWRST('XXX','BUG ')
        GOTO9000
C
  300 CONTINUE
      AE=1.0D-8
      RE=1.0D-8
      DP2=DP
      DPPAR2=DPPAR
      DQPAR2=DQPAR
      CALL DFZERO(GL4FU2,XLOW,XUP,XUP,RE,AE,IFLAG)
C
      DPPF=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,121)
CC111   FORMAT('***** WARNING FROM GL4PPF--')
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 GL4PPF--')
        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 GL4PPF--')
        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,121)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,143)
  143   FORMAT('      MAXIMUM ITERATIONS EXCEEDED.')
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE GL4RAN(N,P,Q,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE GENERALIZED LOGISTIC TYPE 4 DISTRIBUTION
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --P      = THE FIRST SHAPE PARAMETER
C                     --Q      = THE SECOND SHAPE PARAMETER
C                     --SEED   = THE SEED FOR THE RANDOM NUMBER
C                                GENERATOR
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 GENERALIZED LOGISTIC TYPE 4 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, GL4PPF.
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--2006/3
C     ORIGINAL VERSION--MARCH     2006.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
C
      DOUBLE PRECISION DX
      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)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,6)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
        CALL DPWRST('XXX','BUG ')
        RETURN
      ENDIF
    5 FORMAT('***** ERROR--THE REQUESTED NUMBER OF GENERALIZED ',
     1       'LOGISTIC TYPE 4')
    6 FORMAT('      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 GENERALIZED LOGISTIC TYPE 4 RANDOM NUMBERS
C     USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD
C
      DO100I=1,N
        DX=DBLE(X(I))
        CALL GL4PPF(DX,DBLE(P),DBLE(Q),DPPF)
        X(I)=REAL(DPPF)
  100 CONTINUE
C
      RETURN
      END
      SUBROUTINE GL5ML1(Y,N,
     1                  DTEMP1,XMOM,NMOM,
     1                  XMEAN,XSD,XVAR,XMIN,XMAX,
     1                  ALOCML,SCALML,SHAPML,
     1                  ISUBRO,IBUGA3,IERROR)
C
C     PURPOSE--THIS ROUTINE COMPUTES THE L-MOMENTS ESTIMATES FOR THE
C              GENERALIZED LOGISTIC TYPE 5 DISTRIBUTION FOR THE RAW DATA
C              CASE (I.E., NO CENSORING AND NO GROUPING).  THIS ROUTINE
C              RETURNS ONLY 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 (DPMLP3 WILL GENERATE THE OUTPUT
C              FOR THE GENERALIZED LOGISTIC TYPE 5 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--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/7
C     ORIGINAL VERSION--JULY      2010. EXTRACTED AS A SEPARATE
C                                       SUBROUTINE (FROM DPMLP3)
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DIMENSION Y(*)
      DOUBLE PRECISION DTEMP1(*)
      DOUBLE PRECISION XMOM(*)
      DOUBLE PRECISION XPAR(3)
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='GL5M'
      ISUBN2='L1  '
      IERROR='NO'
      IWRITE='NO'
C
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'5ML1')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,51)
   51   FORMAT('**** AT THE BEGINNING OF GL5ML3--')
        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 GENERALIZED LOGISTIC TYPE 5 MLE ESTIMATE  **
C               ****************************************************
C
      ISTEPN='2'
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'5ML1')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IDIST='GENERALIZED LOGISTIC TYPE 5'
      ALOCML=CPUMIN
      SCALML=CPUMIN
      SHAPML=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=3
      DO2110I=1,N
        DTEMP1(I)=DBLE(Y(I))
 2110 CONTINUE
      CALL SAMLMU(DTEMP1,N,XMOM,NMOM)
      CALL PELGLO(XMOM,XPAR)
      ALOCML=REAL(XPAR(1))
      SCALML=REAL(XPAR(2))
      SHAPML=REAL(XPAR(3))
C
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'5ML1')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9011)
 9011   FORMAT('**** AT THE END OF GL5ML3--')
        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,9015)XMOM(1),XMOM(2),XMOM(3)
 9015   FORMAT('XMOM(1),XMOM(2),XMOM(3) = ',3G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9016)XPAR(1),XPAR(2),XPAR(3)
 9016   FORMAT('XPAR(1),XPAR(2),XPAR(3) = ',3G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9017)SHAPML,SCALML,ALOCML
 9017   FORMAT('SHAPML,SCALML,ALOCML =  ',3G15.7)
        CALL DPWRST('XXX','WRIT')
      ENDIF
C
      RETURN
      END
      SUBROUTINE GL5PDF(X,GAMMA,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE TYPE 5 GENERALIZED LOGISTIC
C              DISTRIBUTION WITH SHAPE PARAMETER GAMMA.
C              THIS DISTRIBUTION IS DEFINED FOR ALL X
C              THIS DEFINITION IS DUE TO HOSKINGS AND HAS THE
C              FOLLOWING DEFINITION:
C
C              F(X,GAMMA) = (1-GAMMA*X)**((1/GAMMA)-1)/
C                           {1+(1-GAMMA*X)**(1/GAMMA}**2
C                           X <= 1/GAMMA    FOR GAMMA > 0
C                           X >= 1/GAMMA    FOR GAMMA < 0
C              FOR GAMMA = 0, JUST COMPUTE THE STANDARD
C              LOGISTIC DISTRIBUTION.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE
C                                AT WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                     --GAMMA  = THE SINGLE 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 FOR THE GENERALIZED LOGISTIC TYPE 5
C             DISTRIBUTION
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE NON-NEGATIVE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN.
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--2, 1994, PAGE 145
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE:  301-975-2855
C     ORIGINAL VERSION--FEBRUARY  2006.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION X
      DOUBLE PRECISION GAMMA
      DOUBLE PRECISION PDF
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
C
      INCLUDE 'DPCOP2.INC'
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(GAMMA.EQ.0.0D0)THEN
        CALL LOGPDF(REAL(X),PDF2)
        PDF=DBLE(PDF2)
        GOTO9999
      ELSEIF(GAMMA.GT.0.0D0)THEN
        IF(X.GT.1.0D0/GAMMA)THEN
          WRITE(ICOUT,4)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,5)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,46)X
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,47)GAMMA
          CALL DPWRST('XXX','BUG ')
          PDF=0.0D0
          GOTO9999
        ENDIF
    4   FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO THE ',
     1       'GL5PDF SUBROUTINE')
    5   FORMAT('      IS GREATER THAN 1/GAMMA')
   46   FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.8)
   47   FORMAT('***** THE VALUE OF GAMMA IS        ',G15.8)
C
        IF(X.EQ.1.0/GAMMA)THEN
          PDF=0.0D0
        ELSE
          DTERM1=(1.0D0/GAMMA)
          DTERM2=(DTERM1 - 1.0D0)*DLOG(1.0D0 - X*GAMMA)
          DTERM3=2.0D0*DLOG(1.0D0 + (1.0D0 - GAMMA*X)**DTERM1)
          PDF=DEXP(DTERM2 - DTERM3)
        ENDIF
C
      ELSEIF(GAMMA.LT.0.0)THEN
        IF(X.LT.1.0/GAMMA)THEN
          WRITE(ICOUT,4)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,15)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,46)X
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,47)GAMMA
          CALL DPWRST('XXX','BUG ')
          PDF=0.0
          GOTO9999
        ENDIF
   15   FORMAT('      IS LESS THAN 1/GAMMA')
C
        IF(X.EQ.1.0/GAMMA)THEN
          PDF=0.0D0
        ELSE
          DTERM1=(1.0D0/GAMMA)
          DTERM2=(DTERM1 - 1.0D0)*DLOG(1.0D0 - X*GAMMA)
          DTERM3=2.0D0*DLOG(1.0D0 + (1.0D0 - GAMMA*X)**DTERM1)
          PDF=DEXP(DTERM2 - DTERM3)
        ENDIF
C
      ENDIF
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE GL5RAN(N,ALPHA,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE GENERALIZED LOGISTIC TYPE 5 (HOSKING)
C              DISTRIBUTION
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --ALPHA  = THE SHAPE PARAMETER
C                     --SEED   = THE SEED FOR THE RANDOM NUMBER
C                                GENERATOR
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 GENERALIZED LOGISTIC TYPE 5 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, QUAGLO.
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--2006/2
C     ORIGINAL VERSION--FEBRUARY  2006.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
C
      DOUBLE PRECISION XPAR(3)
      DOUBLE PRECISION QUAGLO
      DOUBLE PRECISION DX
      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)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,6)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
        CALL DPWRST('XXX','BUG ')
        RETURN
      ENDIF
    5 FORMAT('***** ERROR--THE REQUESTED NUMBER OF GENERALIZED ',
     1       'LOGISTIC TYPE 5 (HOSKING)')
    6 FORMAT('      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 GENERALIZED LOGISTIC TYPE 5 RANDOM NUMBERS
C     USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD
C
      XPAR(1)=0.0D0
      XPAR(2)=1.0D0
      XPAR(3)=DBLE(ALPHA)
C
      DO100I=1,N
        DX=DBLE(X(I))
        DPPF=QUAGLO(DX,XPAR)
        X(I)=REAL(DPPF)
  100 CONTINUE
C
      RETURN
      END
      SUBROUTINE GLSCDF(X,THETA,BETA,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE GENERALIZED LOGARITHMIC SERIES
C              DISTRIBUTION WITH SHAPE PARAMETERS THETA AND BETA.
C              THIS DISTRIBUTION IS DEFINED FOR ALL INTEGER X >= 1.
C              THE PROBABILITY MASS FUNCTION IS:
C              p(X;THETA,BETA)=
C                  Gamma(BETA*X+1)*THETA**X*(1-THETA)**(BETA*X-X)/
C                  X!*(BETA*X)*Gamma(BETA*X-X+1)*[-LOG(1-THETA)]
C                  X = 1, 2, 3, ,...
C                  0 < THETA < 1; 1 <= BETA < 1/THETA
C
C              THE CUMULATIVE DISTRIBUTION FUNCTION IS COMPUTED
C              BY SUMMING THE PROBABILITY MASS 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 A NON-NEGATIVE INTEGER.
C                     --THETA  = THE FIRST SHAPE PARAMETER
C                     --BETA   = THE SECOND SHAPE PARAMETER
C     OUTPUT ARGUMENTS--CDF    = THE SINGLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION FUNCTION
C             VALUE CDF FOR THE GENERALIZED LOGARITHMIC SERIES
C             DISTRIBUTION WITH SHAPE PARAMETERS THETA AND BETA
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE A POSITIVE INTEGER
C                 --0 < THETA < 1; 1 < BETA < 1/THETA
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--FAMOYE (1997), "SAMPLING FROM A GENERALIZED
C                 LOGARITHMIC SERIES DISTRIBUTION", COMPUTING,
C                 58(4), PP. 365-376.
C               --CONSUL AND FAMOYE (2006), "LAGRANGIAN PROBABILITY
C                 DISTRIBUTIONS", BIRKHAUSER, CHAPTER 11.
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 DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
      DOUBLE PRECISION DSUM
      DOUBLE PRECISION DX
      DOUBLE PRECISION DTHETA
      DOUBLE PRECISION DBETA
      DOUBLE PRECISION DPDF
      DOUBLE PRECISION DPDFSV
      DOUBLE PRECISION DCDF
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IX=INT(X+0.5)
      IF(IX.LT.1)THEN
        WRITE(ICOUT,4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9000
      ENDIF
    4 FORMAT('***** ERROR--THE FIRST ARGUMENT TO GLSCDF IS LESS ',
     1'THAN 1')
C
      IF(THETA.LE.0.0 .OR. THETA.GE.1.0)THEN
        WRITE(ICOUT,15)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)THETA
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9000
      ENDIF
   15 FORMAT('***** ERROR--THE SECOND ARGUMENT TO GLSCDF IS NOT IN ',
     1'THE INTERVAL (0,1)')
C
      IF(BETA.LT.1.0 .OR. BETA.GE.1.0/THETA)THEN
        WRITE(ICOUT,25)1.0/THETA
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)THETA
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9000
      ENDIF
   25 FORMAT('***** ERROR--THE THIRD ARGUMENT TO GLSCDF IS NOT IN ',
     1'THE INTERVAL (1,',G15.7,')')
C
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
C
      DTHETA=DBLE(THETA)
      DBETA=DBLE(BETA)
C
C     USE THE RECURRENCE RELATION (PAGE 228 OF CONSUL AND FAMOYE):
C
C     P(X+1;THETA,BETA) = (BETA - X/(X+1))*THETA*(1-THETA)**(BETA-1)*
C                         PROD[j=1 to X-1][1 + BETA/(BETA*X-j)]*
C                         P(X;THETA,BETA)
C
C     COMPUTE BY TAKING LOG OF THIS FORMULA WHEN X >= 3.
C
      DCDF=DTHETA*(1.0D0 - DTHETA)**(DBETA - 1.0D0)/
     1     (-DLOG(1.0D0 - DTHETA))
      IF(IX.EQ.1)GOTO1000
C
      DPDF=(DBETA-0.5D0)*DTHETA*(1.0D0-DTHETA)**(DBETA-1.0D0)*DCDF
      DCDF=DCDF + DPDF
      IF(IX.EQ.2)GOTO1000
      DPDFSV=DPDF
      DTERM2=DLOG(DTHETA) + (DBETA - 1.0D0)*DLOG(1.0D0 - DTHETA)
C
      DO100I=3,IX
        DX=DBLE(I)
        DTERM1=DLOG(DBETA - (DX-1.0D0)/DX)
        IF(DPDFSV.LE.0.0D0)THEN
          GOTO1000
        ELSE
          DTERM3=DLOG(DPDFSV)
        ENDIF
        DSUM=0.0D0
        DO200J=1,I-2
          DSUM=DSUM + DLOG(1.0D0 + DBETA/(DBETA*(DX-1.0D0)-DBLE(J)))
  200   CONTINUE
        DPDF=DEXP(DTERM1 + DTERM2 + DTERM3 + DSUM)
        DCDF=DCDF + DPDF
        DPDFSV=DPDF
  100 CONTINUE
C
 1000 CONTINUE
      CDF=REAL(DCDF)
C
 9000 CONTINUE
      RETURN
      END
      DOUBLE PRECISION FUNCTION GLSFUN(DTHETA)
C
C     PURPOSE--THIS ROUTINE COMPUTES THE FUNCTIONS FOR THE
C              GENERALIZED LOGARITHMIC SERIES METHOD OF MOMENT
C              EQUATIONS.
C
C                 (1-THETA)*XBAR**3/ALPHA**2 -
C                 THETA**2*(s**2+XBAR**2) 0
C
C              WITH THETA DENOTING THE SHAPE PARAMETER AND
C              ALPHA = 1/-LOG(1-THETA).  THIS
C              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--GENERALIZED LOGARITHMIC SERIES MAXIMUM LIKELIHOOD Y
C     REFERENCES--CONSUL AND FAMOYE (2006), "LAGRANGIAN PROBABILITY
C                 DISTRIBUTIONS", BIRKHAUSER, CHAPTER 11.
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 DTHETA
      DOUBLE PRECISION DALPHA
C
      DOUBLE PRECISION XBAR
      DOUBLE PRECISION S2
      DOUBLE PRECISION F1FREQ
      COMMON/GLSCOM/XBAR,S2,F1FREQ,MAXROW,N
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C  COMPUTE SOME SUMS
C
      DALPHA=-1.0D0/DLOG(1.0D0 - DTHETA)
      GLSFUN=(1.0D0-DTHETA)*XBAR**3/(DALPHA**2) -
     1       DTHETA**2*(S2+XBAR**2)
C
      RETURN
      END
      SUBROUTINE GLSFU2(N,XPAR,FVEC,IFLAG,Y,K)
C
C     PURPOSE--THIS ROUTINE COMPUTES THE FUNCTIONS FOR THE
C              GENERALIZED LOGARITHMIC SERIES MAXIMUM LIKELIHOOD
C              EQUATIONS.
C
C              THE MAXIMUM LIKELIHOOD ESTIMATES ARE THE SOLUTIONS
C              TO THE EQUATIONS:
C
C                 (N*XBAR/THETA) - (BETA-1)*N*XBAR/(1-THETA) +
C                 N/((1-THETA)*LOG(1-THETA)) = 0
C
C                 N*XBAR*LOG(1-THETA) +
C                 SUM[X=2 to K][SUM[i=1 to x-1][X*N(X)/(BETA*X-i)]]
C                 = 0
C
C              WITH THETA DENOTING THE SHAPE PARAMETER AND
C              ALPHA = 1/-LOG(1-THETA).  THIS
C              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--GENERALIZED LOGARITHMIC SERIES MAXIMUM LIKELIHOOD Y
C     REFERENCES--CONSUL AND FAMOYE (2006), "LAGRANGIAN PROBABILITY
C                 DISTRIBUTIONS", BIRKHAUSER, CHAPTER 11.
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 DX
      DOUBLE PRECISION DFREQ
      DOUBLE PRECISION DTHETA
      DOUBLE PRECISION DBETA
      DOUBLE PRECISION DALPHA
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DN
C
      DOUBLE PRECISION XBAR
      DOUBLE PRECISION S2
      DOUBLE PRECISION F1FREQ
      COMMON/GLSCOM/XBAR,S2,F1FREQ,MAXROW,NTOT
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C  COMPUTE SOME SUMS
C
      N=2
      IFLAG=0
C
      DTHETA=XPAR(1)
      DBETA=XPAR(2)
      DALPHA=-1.0D0/DLOG(1.0D0 - DTHETA)
      DN=DBLE(NTOT)
C
      IINDX=MAXROW/2
C
      DTERM1=DN*XBAR/DTHETA
      DTERM2=(DBETA-1.0D0)*DN*XBAR/(1.0D0-DTHETA)
      DTERM3=DN/((1.0D0-DTHETA)*DLOG(1.0D0-DTHETA))
      FVEC(1)=DTERM1 - DTERM2 + DTERM3
C
      DSUM1=0.0D0
      DTERM1=DN*XBAR*DLOG(1.0D0-DTHETA)
C
      DO100I=2,K
        DX=DBLE(Y(IINDX+I))
        DFREQ=Y(I)
        DO200J=1,I-1
          DSUM1=DSUM1 + DX*DFREQ/(DBETA*DX - DBLE(J))
  200   CONTINUE
  100 CONTINUE
C
      FVEC(2)=DTERM1 + DSUM1
C
      RETURN
      END
      DOUBLE PRECISION FUNCTION GLSFU3(DTHETA)
C
C     PURPOSE--THIS ROUTINE COMPUTES THE FUNCTIONS FOR THE
C              GENERALIZED LOGARITHMIC SERIES METHOD OF ONES
C              FREQUENCY AND SAMPLE MEAN EQUATIONS.
C
C                 LOG(THETA) + ((1/THETA) -
C                 (1/XBAR)*(-1/LOG(1-THETA) - 1)*LOG(1-THETA) -
C                 LOG(-LOG(1-THETA)) - LOG(F1/N) = 0
C
C              WITH THETA DENOTING THE SHAPE PARAMETER.
C
C              CALLED BY DFZERO ROUTINE.
C     EXAMPLE--GENERALIZED LOGARITHMIC SERIES MAXIMUM LIKELIHOOD Y
C     REFERENCES--CONSUL AND FAMOYE (2006), "LAGRANGIAN PROBABILITY
C                 DISTRIBUTIONS", BIRKHAUSER, CHAPTER 11.
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 DTHETA
      DOUBLE PRECISION DALPHA
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
      DOUBLE PRECISION DTERM4
C
      DOUBLE PRECISION XBAR
      DOUBLE PRECISION S2
      DOUBLE PRECISION F1
      COMMON/GLSCOM/XBAR,S2,F1,MAXROW,N
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C  COMPUTE SOME SUMS
C
      DN=DBLE(N)
      DTERM1=DLOG(DTHETA)
      DALPHA=-1.0D0/DLOG(1.0D0 - DTHETA)
      DTERM2=((1.0D0/DTHETA) - DALPHA/XBAR - 1.0D0)*
     1       DLOG(1.0D0 - DTHETA)
      DTERM3=DLOG(-DLOG(1.0D0-DTHETA))
      DTERM4=DLOG(F1)
      GLSFU3=DTERM1 + DTERM2 - DTERM3 - DTERM4
C
      RETURN
      END
      SUBROUTINE GLSPDF(X,THETA,BETA,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY MASS
C              FUNCTION VALUE FOR THE GENERALIZED LOGARITHMIC SERIES
C              DISTRIBUTION WITH SHAPE PARAMETERS THETA AND BETA.
C              THIS DISTRIBUTION IS DEFINED FOR ALL INTEGER X >= 1.
C              THE PROBABILITY MASS FUNCTION IS:
C              p(X;THETA,BETA)=
C                  Gamma(BETA*X+1)*THETA**X*(1-THETA)**(BETA*X-X)/
C                  X!*(BETA*X)*Gamma(BETA*X-X+1)*[-LOG(1-THETA)]
C                  X = 1, 2, 3, ,...
C                  0 < THETA < 1; 1 <= BETA < 1/THETA
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE PROBABILITY MASS
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE A NON-NEGATIVE INTEGER.
C                     --THETA  = THE FIRST SHAPE PARAMETER
C                     --BETA   = THE SECOND SHAPE PARAMETER
C     OUTPUT ARGUMENTS--PDF    = THE SINGLE PRECISION PROBABILITY MASS
C                                FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PROBABILITY MASS FUNCTION VALUE
C             PDF FOR THE GENERALIZED LOGARITHMIC SERIES
C             DISTRIBUTION WITH SHAPE PARAMETERS THETA AND BETA
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE A POSITIVE INTEGER
C                 --0 < THETA < 1; 1 < BETA < 1/THETA
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--FAMOYE (1997), "SAMPLING FROM A GENERALIZED
C                 LOGARITHMIC SERIES DISTRIBUTION", COMPUTING,
C                 58(4), PP. 365-376.
C               --CONSUL AND FAMOYE (2006), "LAGRANGIAN PROBABILITY
C                 DISTRIBUTIONS", BIRKHAUSER, CHAPTER 11.
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 DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
      DOUBLE PRECISION DTERM4
      DOUBLE PRECISION DX
      DOUBLE PRECISION DTHETA
      DOUBLE PRECISION DBETA
      DOUBLE PRECISION DPDF
      DOUBLE PRECISION DLNGAM
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IX=INT(X+0.5)
      IF(IX.LT.1)THEN
        WRITE(ICOUT,4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9000
      ENDIF
    4 FORMAT('***** ERROR--THE FIRST ARGUMENT TO GLSPDF IS LESS ',
     1'THAN 1')
C
      IF(THETA.LE.0.0 .OR. THETA.GE.1.0)THEN
        WRITE(ICOUT,15)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)THETA
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9000
      ENDIF
   15 FORMAT('***** ERROR--THE SECOND ARGUMENT TO GLSPDF IS NOT IN ',
     1'THE INTERVAL (0,1)')
C
      IF(BETA.LT.1.0 .OR. BETA.GE.1.0/THETA)THEN
        WRITE(ICOUT,25)1.0/THETA
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)THETA
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9000
      ENDIF
   25 FORMAT('***** ERROR--THE THIRD ARGUMENT TO GLSPDF IS NOT IN ',
     1'THE INTERVAL (1,',G15.7,')')
C
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
C
      DX=DBLE(IX)
      DTHETA=DBLE(THETA)
      DBETA=DBLE(BETA)
C
      DTERM1=DLNGAM(DBETA*DX+1.0D0) + DX*DLOG(DTHETA) +
     1       (DBETA*DX-DX)*DLOG(1.0D0 - DTHETA)
      DTERM2=DLNGAM(DX+1.0D0) + DLOG(DBETA) + DLOG(DX)
      DTERM3=DLNGAM(DBETA*DX-DX+1.0D0) + DLOG(-DLOG(1.0D0-DTHETA))
      DTERM4=DTERM1 - DTERM2 - DTERM3
      DPDF=DEXP(DTERM4)
      PDF=REAL(DPDF)
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE GLSPPF(P,THETA,BETA,PPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE GENERALIZED LOGARITHMIC SERIES
C              DISTRIBUTION WITH SHAPE PARAMETERS THETA AND BETA.
C              THIS DISTRIBUTION IS DEFINED FOR ALL INTEGER X >= 1.
C              THE PROBABILITY MASS FUNCTION IS:
C              p(X;THETA,BETA)=
C                  Gamma(BETA*X+1)*THETA**X*(1-THETA)**(BETA*X-X)/
C                  X!*(BETA*X)*Gamma(BETA*X-X+1)*[-LOG(1-THETA)]
C                  X = 1, 2, 3, ,...
C                  0 < THETA < 1; 1 <= BETA < 1/THETA
C
C              THE CUMULATIVE DISTRIBUTION FUNCTION IS COMPUTED
C              BY SUMMING THE PROBABILITY MASS FUNCTION.  THE
C              PERCENT POINT FUNCTION IS COMPUTED BY COMPUTING THE
C              CUMULATIVE DISTRIBUTION UNTIL THE APPROPRIATE
C              PROBABILITY IS REACHED.
C     INPUT  ARGUMENTS--P      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE PERCENT POINT
C                                FUNCTION IS TO BE EVALUATED.
C                                0 <= P < 1.
C                     --THETA  = THE FIRST SHAPE PARAMETER
C                     --BETA   = THE SECOND SHAPE PARAMETER
C     OUTPUT ARGUMENTS--PPF    = THE SINGLE PRECISION PERCENT POINT
C                                FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PERCENT POINT FUNCTION
C             VALUE PPF FOR THE GENERALIZED LOGARITHMIC SERIES
C             DISTRIBUTION WITH SHAPE PARAMETERS THETA AND BETA
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--0 <= P < 1
C                 --0 < THETA < 1; 1 < BETA < 1/THETA
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--FAMOYE (1997), "SAMPLING FROM A GENERALIZED
C                 LOGARITHMIC SERIES DISTRIBUTION", COMPUTING,
C                 58(4), PP. 365-376.
C               --CONSUL AND FAMOYE (2006), "LAGRANGIAN PROBABILITY
C                 DISTRIBUTIONS", BIRKHAUSER, CHAPTER 11.
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 DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
      DOUBLE PRECISION DSUM
      DOUBLE PRECISION DX
      DOUBLE PRECISION DTHETA
      DOUBLE PRECISION DBETA
      DOUBLE PRECISION DPDF
      DOUBLE PRECISION DPDFSV
      DOUBLE PRECISION DCDF
      DOUBLE PRECISION DEPS
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOMC.INC'
      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,4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)P
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
        GOTO9000
      ENDIF
    4 FORMAT('***** ERROR--THE FIRST ARGUMENT TO GLSPPF IS OUTSIDE ',
     1'THE (0,1] INTERVAL')
C
      IF(THETA.LE.0.0 .OR. THETA.GE.1.0)THEN
        WRITE(ICOUT,15)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)THETA
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
        GOTO9000
      ENDIF
   15 FORMAT('***** ERROR--THE SECOND ARGUMENT TO GLSPPF IS NOT IN ',
     1'THE INTERVAL (0,1)')
C
      IF(BETA.LT.1.0 .OR. BETA.GE.1.0/THETA)THEN
        WRITE(ICOUT,25)1.0/THETA
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)THETA
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
        GOTO9000
      ENDIF
   25 FORMAT('***** ERROR--THE THIRD ARGUMENT TO GLSPPF IS NOT IN ',
     1'THE INTERVAL (1,',G15.7,')')
C
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
C
      DTHETA=DBLE(THETA)
      DBETA=DBLE(BETA)
      DP=DBLE(P)
      DEPS=1.0D-7
      DCDF=DTHETA*(1.0D0 - DTHETA)**(DBETA - 1.0D0)/
     1     (-DLOG(1.0D0 - DTHETA))
      IF(DCDF.GE.DP-DEPS)THEN
        PPF=1.0
        GOTO9000
      ENDIF
C
      DPDF=(DBETA-0.5D0)*DTHETA*(1.0D0-DTHETA)**(DBETA-1.0D0)*DCDF
      DCDF=DCDF + DPDF
      IF(DCDF.GE.DP-DEPS)THEN
        PPF=2.0
        GOTO9000
      ENDIF
      DPDFSV=DPDF
      DTERM2=DLOG(DTHETA) + (DBETA - 1.0D0)*DLOG(1.0D0 - DTHETA)
C
      I=2
  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)
        DTERM1=DLOG(DBETA - (DX-1.0D0)/DX)
        IF(DPDFSV.LE.0.0D0)THEN
          DPDF=0.0D0
          GOTO1000
        ELSE
          DTERM3=DLOG(DPDFSV)
        ENDIF
        DSUM=0.0D0
        DO200J=1,I-2
          DSUM=DSUM + DLOG(1.0D0 + DBETA/(DBETA*(DX-1.0D0)-DBLE(J)))
  200   CONTINUE
        DPDF=DEXP(DTERM1 + DTERM2 + DTERM3 + DSUM)
 1000   CONTINUE
        DCDF=DCDF + DPDF
        DPDFSV=DPDF
        IF(DCDF.GE.DP-DEPS)THEN
          PPF=REAL(I)
          GOTO9000
        ENDIF
      GOTO100
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE GLSRAN(N,THETA,BETA,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE GENERALIZED LOGARITHMIC SERIES DISTRIBUTION
C              WITH SHAPE PARAMETERS THETA AND BETA.
C              THIS DISTRIBUTION IS DEFINED FOR ALL
C              NON-NEGATIVE INTEGER X >= 1.
C              p(X;THETA,BETA)=
C                  Gamma(BETA*X+1)*THETA**X*(1-THETA)**(BETA*X-X)/
C                  X!*(BETA*X)*Gamma(BETA*X-X+1)*[-LOG(1-THETA)]
C                  X = 1, 2, 3, ,...
C                  0 < THETA < 1; 1 < BETA < 1/THETA
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --THETA = 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--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 GENERALIZED LOGARITHMIC SERIES DISTRIBUTION
C             WITH SHAPE PARAMETERS THETA 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                 --0 < THETA < 1, 1 < BETA < 1/THETA
C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN, GLSPPF
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--FAMOYE (1997), "SAMPLING FROM A GENERALIZED
C                 LOGARITHMIC SERIES DISTRIBUTION", COMPUTING,
C                 58(4), PP. 365-376.
C               --CONSUL AND FAMOYE (2006), "LAGRANGIAN PROBABILITY
C                 DISTRIBUTIONS", BIRKHAUSER, CHAPTER 11.
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 THETA
      REAL BETA
      DIMENSION X(*)
CCCCC DIMENSION XTEMP(2)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----DATA STATEMENTS-------------------------------------------------
C
CCCCC DATA PI / 3.1415926535 8979323846 E0 /
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         'GENERALIZED LOGARITHMIC SERIES')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,6)
    6   FORMAT('      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(THETA.LE.0.0 .OR. THETA.GE.1.0)THEN
        WRITE(ICOUT,11)
   11   FORMAT('***** ERROR--THE THETA PARAMETER FOR THE ',
     1         'GENERALIZED LOGARITHMIC SERIES')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,12)
   12   FORMAT('      RANDOM NUMBERS IS OUTSIDE THE (0,1) INTERVAL.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)THETA
   46   FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7,'.')
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ELSEIF(BETA.LE.1.0 .OR. BETA.GE.1.0/THETA)THEN
        WRITE(ICOUT,21)
   21   FORMAT('***** ERROR--THE BETA PARAMETER FOR THE ',
     1         'GENERALIZED LOGARITHMIC SERIES')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,22)
   22   FORMAT('      RANDOM NUMBERS IS OUTSIDE THE (0,',G15.7,
     1         ') INTERVAL.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)BETA
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
C
C     GENERATE N GENERALIZED LOGARITHMIC SERIES DISTRIBUTION
C     RANDOM NUMBERS.  FOLLOWING RECOMMENDATION OF CONSUL AND
C     FAYMOE, USE INVERSION METHOD FOR THETA*BETA <= 0.45 AND
C     BRANCHING METHOD OTHERWISE.
C
C     BRANCHING ALGORITHM DOESN'T SEEM TO RETURN REASONABLE
C     RESULTS (MAYBE USING A SLIGHTLY DIFFERENT DEFINITION
C     FOR NEGATIVE BINOMIAL?), SO USE REJECTION ALGORITHM
C     INSTEAD.
C
CCCCC IF(THETA*BETA.LE.0.45)THEN
        CALL UNIRAN(N,ISEED,X)
        DO100I=1,N
          ZTEMP=X(I)
          CALL GLSPPF(ZTEMP,THETA,BETA,PPF)
          X(I)=PPF
  100   CONTINUE
CCCCC ELSE
C
C       BRANCHING ALGORITHM
C
CCCCC   NTEMP=1
CCCCC   DO200I=1,N
CCCCC     CALL DLGRAN(NTEMP,THETA,ISEED,XTEMP)
CCCCC     Y=XTEMP(1)
CCCCC     XX=Y
CC210     CONTINUE
CCCCC     AK=(BETA-1.0)*Y
CCCCC     CALL NBRAN(NTEMP,1.0-THETA,AK,ISEED,XTEMP)
CCCCC     Z=XTEMP(1)
CCCCC     XX=XX+Z
CCCCC     Y=Z
CCCCC     IF(Y.GT.0)GOTO210
CCCCC     X(I)=XX
CC200   CONTINUE
C
C       REJECTION ALGORITHM
C
CCCCC   NTEMP=2
CCCCC   C=(1.0+SQRT(2.0))/((-LOG(1.0-THETA))*SQRT(PI*BETA*(BETA-1.0)))
CCCCC   DO300I=1,N
CC310     CONTINUE
CCCCC     CALL UNIRAN(NTEMP,ISEED,XTEMP)
CCCCC     U=XTEMP(1)
CCCCC     V=XTEMP(2)
CCCCC     IXX=INT(1.0/V**2)
CCCCC     XX=IXX
CCCCC     CALL GLSPDF(XX,THETA,BETA,PDF)
CCCCC     TERM1=U*C*(1.0/SQRT(XX) - 1.0/SQRT(XX+1.0))
CCCCC     IF(TERM1.LE.PDF)THEN
CCCCC       X(I)=XX
CCCCC     ELSE
CCCCC       GOTO310
CCCCC     ENDIF
CC300   CONTINUE
CCCCC ENDIF
C
 9999 CONTINUE
C
      RETURN
      END
      SUBROUTINE GMCCDF(X,ALPHA,A,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE GENERALIZED MCLEISH
C              DISTRIBUTION WITH SHAPE PARAMETERS ALPHA AND A.
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                     --A       = 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 GENERALIZED MCLEISH
C             DISTRIBUTION WITH SHAPE PARAMETERS ALPHA AND A.
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, (1994), "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME 1", SECOND EDITION,
C                 WILEY, PP. 50-53.
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 A
      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 GMCFUN
      EXTERNAL GMCFUN
C
      DOUBLE PRECISION DALPHA
      DOUBLE PRECISION DA
      COMMON/GMCCOM/DALPHA,DA
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.0D0
      IF(ALPHA.LE.0.0D0)THEN
        WRITE(ICOUT,5)
    5   FORMAT('***** ERROR: VALUE OF SHAPE PARAMETER (ALPHA)',
     1         ' IN GMCCDF ROUTINE IS NON-POSITIVE.')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,48)ALPHA
   48   FORMAT('      VALUE OF ARGUMENT IS: ',G15.7)
        CALL DPWRST('XXX','WRIT')
        GOTO9000
      ELSEIF(ABS(A).GE.1.0D0)THEN
        WRITE(ICOUT,8)
    8   FORMAT('***** ERROR: ABSOLUTE VALUE OF SECOND SHAPE ',
     1         'PARAMETER (A) IN GMCCDF ROUTINE IS >= 1.')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,48)A
        CALL DPWRST('XXX','WRIT')
        GOTO9000
      ENDIF
C
C               ************************************
C               **  STEP 1--                      **
C               **  COMPUTE THE DENSITY FUNCTION  **
C               ************************************
C
      INF=-1
      EPSABS=0.0D0
      EPSREL=1.0D-7
      IER=0
      DCDF=0.0D0
      IFLAG=0
C
      DX=X
      IF(DX.LT.0.0D0)THEN
        IFLAG=1
        INF=1
      ENDIF
      DA=A
      DALPHA=ALPHA
C
      CALL DQAGI(GMCFUN,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 GMCCDF--')
        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 GMCCDF--')
        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 GMCCDF--')
        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 GMCCDF--')
        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 GMCCDF--')
        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 GMCCDF--')
        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 GMCFUN(DX)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE GENERALIZED MCLEISH
C              DISTRIBUTION WITH SHAPE PARAMETERS ALPHA AND A.
C              THIS DISTRIBUTION IS DEFINED FOR ALL REAL X
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C
C                 f(X;ALPHA,A) = [1/(SQRT(PI)*GAMMA(ALPHA))]*
C                                (ABS(X)/2)**(ALPHA-1/2)*K(X,ALPHA-1/2)
C                                *(1-A**2)**ALPHA*EXP(A*X)
C              WHERE
C                 K(X,N) IS THE MODIFIED BESSEL FUNCTION OF THE
C                        SECOND KIND
C                 GAMMA IS THE GAMMA FUNCTION
C
C              THE GMCPDF ROUTINE IS CALLED TO COMPUTE THE
C              PROBABILITY DENSITY.  DEFINE AS FUNCTION TO BE USED FOR
C              INTEGRATION CODE CALLED BY GMCCDF.  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--GMCFUN  = THE DOUBLE PRECISION PROBABILITY
C                                 DENSITY FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE PDF FOR THE GENERALIZED MCLEISH
C             DISTRIBUTION WITH SHAPE PARAMETER ALPHA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--GMCPDF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, (1994), "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME 1", SECOND EDITION,
C                 WILEY, PP. 50-53.
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 DA
      COMMON/GMCCOM/DALPHA,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
      CALL GMCPDF(DX,DALPHA,DA,DTERM)
      GMCFUN=DTERM
C
      RETURN
      END
      DOUBLE PRECISION FUNCTION GMCFU2(DX)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE GENERALIZED MCLEISH
C              DISTRIBUTION WITH SHAPE PARAMETERS ALPHA AND A.
C              THIS DISTRIBUTION IS DEFINED FOR ALL REAL X
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C
C                 f(X;ALPHA,A) = [1/(SQRT(PI)*GAMMA(ALPHA))]*
C                                (ABS(X)/2)**(ALPHA-1/2)*K(X,ALPHA-1/2)
C                                *(1-A**2)**ALPHA*EXP(A*X)
C              WHERE
C                 K(X,N) IS THE MODIFIED BESSEL FUNCTION OF THE
C                        SECOND KIND
C                 GAMMA IS THE GAMMA FUNCTION
C
C              THE GMCCDF ROUTINE IS CALLED TO COMPUTE THE
C              PROBABILITY DENSITY.  DEFINE AS FUNCTION TO BE USED FOR
C              INTEGRATION CODE CALLED BY GMCCDF.  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--GMCFU2  = THE DOUBLE PRECISION CUMULATIVE
C                                 DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE CDF FOR THE GENERALIZED MCLEISH
C             DISTRIBUTION WITH SHAPE PARAMETERS ALPHA AND A.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--GMCCDF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, (1994), "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME 1", SECOND EDITION,
C                 WILEY, PP. 50-53.
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 DCDF
      DOUBLE PRECISION DX
C
      DOUBLE PRECISION DP
      COMMON/GM2COM/DP
C
      DOUBLE PRECISION DALPHA
      DOUBLE PRECISION DA
      COMMON/GMCCOM/DALPHA,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
      CALL GMCCDF(DX,DALPHA,DA,DCDF)
      GMCFU2=DP - DCDF
C
      RETURN
      END
      SUBROUTINE GMCPDF(X,ALPHA,A,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE GENERALIZED MCLEISH BESSEL
C              K-FUNCTION DISTRIBUTION.  IT HAS SHAPE PARAMETERS
C              ALPHA.  THIS DISTRIBUTION IS ASYMMETRIC AND IS DEFINED
C              FOR ALL REAL X AND HAS THE PROBABILITY DENSITY FUNCTION
C
C                 f(X;ALPHA,A) = [1/(SQRT(PI)*GAMMA(ALPHA))]*
C                                (ABS(X)/2)**(ALPHA-1/2)*K(X,ALPHA-1/2)
C                                *(1-A**2)**ALPHA*EXP(A*X)
C              WHERE
C                 K(X,N) IS THE MODIFIED BESSEL FUNCTION OF THE
C                        SECOND KIND
C                 GAMMA IS THE GAMMA FUNCTION
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                                 X SHOULD BE POSITIVE
C                     --ALPHA   = THE FIRST SHAPE PARAMETER
C                     --A       = THE SECOND 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 GENERALIZED MCLEISH DISTRIBUTION
C             WITH SHAPE PARAMETERS ALPHA AND NU.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--DBESI.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--DEXP, DLOG, DLNGAM.
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. 50-53.
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 DX
      DOUBLE PRECISION ALPHA
      DOUBLE PRECISION A
      DOUBLE PRECISION PDF
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
      DOUBLE PRECISION DTERM4
      DOUBLE PRECISION DTERM5
      DOUBLE PRECISION DTERM6
      DOUBLE PRECISION DORD
      DOUBLE PRECISION DPI
      DOUBLE PRECISION DEPS
      DOUBLE PRECISION DLNGAM
      EXTERNAL DLNGAM
C
      DOUBLE PRECISION DTEMP1(10)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----DATA STATEMENTS-------------------------------------------------
C
      DATA DPI / 3.14159265358979D+00/
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 GMCPDF ROUTINE IS NON-POSITIVE.')
      IF(ABS(A).GE.1.0D0)THEN
        WRITE(ICOUT,8)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,48)A
        CALL DPWRST('XXX','WRIT')
        PDF=0.0D0
        GOTO9000
      ENDIF
    8 FORMAT('***** ERROR: ABSOLUTE VALUE OF SECOND SHAPE PARAMETER ',
     1       '(A) IN GMCPDF ROUTINE IS >= 1.')
   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
C  COMPUTE BESSEL FUNCTION FIRST.  IF THIS IS 0, SET PDF TO
C  0 AND RETURN.
C
      DEPS=1.0D-12
      IF(ALPHA.GT.25.0)DEPS=1.0D-10
      DX=X
      DX=DABS(DX)
      IF(DX.EQ.0.0D0)DX=DEPS
      DORD=DABS(ALPHA-0.5D0)
      IARG1=1
      ISCALE=1
      CALL DBESK(DX,DORD,ISCALE,IARG1,DTEMP1,NZERO)
      DTERM3=DTEMP1(IARG1)
      IF(DTERM3.LE.0.0D0)THEN
        PDF=0.0D0
        GOTO9000
      ENDIF
      DTERM3=DLOG(DTERM3)
C
      DTERM1=0.5D0*DLOG(DPI) + DLNGAM(ALPHA)
      DTERM2=(ALPHA-0.5D0)*DLOG(DX/2.0D0)
      DTERM4=ALPHA*DLOG(1.0D0 - A**2)
      DTERM5=A*X
      DTERM6 = -DTERM1+DTERM2+DTERM3+DTERM4+DTERM5
      PDF=DEXP(DTERM6)
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE GMCPPF(P,ALPHA,A,PPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT FUNCTION
C              VALUE FOR THE GENERALIZED MCLEISH DISTRIBUTION.  IT HAS
C              SHAPE PARAMETERS ALPHA AND A.  THIS DISTRIBUTION IS
C              DEFINED FOR ALL REAL X AND HAS THE PROBABILITY DENSITY
C              FUNCTION
C
C                 f(X;ALPHA,A) = [1/(SQRT(PI)*GAMMA(ALPHA))]*
C                                (ABS(X)/2)**(ALPHA-1/2)*K(X,ALPHA-1/2)
C                                *(1-A**2)**ALPHA*EXP(A*X)
C              WHERE
C                 K(X,N) IS THE MODIFIED BESSEL FUNCTION OF THE
C                        SECOND KIND
C                 GAMMA IS THE GAMMA FUNCTION
C
C              THE PERCENT POINT FUNCTION IS COMPUTED BY NUMERICALLY
C              INVERTING THE GENERALIZED MCLEISH CUMULATIVE
C              DISTRIBUTION FUNCTION (WHICH IN TURN IS COMPUTED BY
C              NUMERICAL INTEGRATION OF THE PROBABILITYT DENSITY).
C
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                     --A       = THE SECOND 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 GENERALIZED MCLEISH
C             DISTRIBUTION WITH SHAPE PARAMETERS ALPHA AND A.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--DFZERO.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, (1994), "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME 1", SECOND EDITION,
C                 WILEY, PP. 50-53.
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 P
      DOUBLE PRECISION PTEMPL
      DOUBLE PRECISION PTEMPU
      DOUBLE PRECISION ALPHA
      DOUBLE PRECISION A
      DOUBLE PRECISION PPF
      DOUBLE PRECISION DINC
C
      DOUBLE PRECISION XUP
      DOUBLE PRECISION XUP2
      DOUBLE PRECISION XLOW
      DOUBLE PRECISION RE
      DOUBLE PRECISION AE
C
      DOUBLE PRECISION GMCFU2
      EXTERNAL GMCFU2
C
      DOUBLE PRECISION DP
      COMMON/GM2COM/DP
C
      DOUBLE PRECISION DALPHA
      DOUBLE PRECISION DA
      COMMON/GMCCOM/DALPHA,DA
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C               *****************************************
C               **  STEP 1--                           **
C               **  CHECK FOR VALID PARAMETERS         **
C               *****************************************
C
      IF(P.LE.0.0D0 .OR. P.GE.1.0D0)THEN
        WRITE(ICOUT,4)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,14)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,48)P
        CALL DPWRST('XXX','WRIT')
        PPF=0.0D0
        GOTO9000
      ENDIF
    4 FORMAT('***** ERROR: VALUE OF INPUT ARGUMENT (P) IN ',
     1       'GMCPPF ROUTINE')
   14 FORMAT('      IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL.')
      IF(ALPHA.LE.0.0D0)THEN
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,48)ALPHA
        CALL DPWRST('XXX','WRIT')
        PPF=0.0D0
        GOTO9000
      ENDIF
    5 FORMAT('***** ERROR: VALUE OF FIRST SHAPE PARAMETER (ALPHA)',
     1       ' IN GMCPPF ROUTINE IS NON-POSITIVE.')
      IF(ABS(A).GE.1.0D0)THEN
        WRITE(ICOUT,8)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,48)A
        CALL DPWRST('XXX','WRIT')
        PPF=0.0D0
        GOTO9000
      ENDIF
    8 FORMAT('***** ERROR: ABSOLUTE VALUE OF SECOND SHAPE PARAMETER ',
     1       '(A) IN GMCPPF ROUTINE IS >= 1.')
   48 FORMAT('      VALUE OF ARGUMENT IS: ',G15.7)
C
C               *****************************************
C               **  STEP 2--                           **
C               **  COMPUTE THE PERCENT POINT FUNCTION.**
C               *****************************************
C
C  STEP 1: FIND BRACKETING INTERVAL.  START WITH -10 AND +10,
C          INCREMENT BY 10.
C
      XLOW=-10.0D0
      XUP2=10.0D0
      CALL GMCCDF(XLOW,ALPHA,A,PTEMPL)
      CALL GMCCDF(XUP2,ALPHA,A,PTEMPU)
      DINC=10.0D0
      IF(ALPHA.GT.20.0D0)THEN
        DINC=ALPHA
      ENDIF
C
      MAXIT=1000
      NIT=0
C
  200 CONTINUE
      IF(NIT.GT.MAXIT)THEN
        PPF=0.0D0
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,131)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,133)
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
      CALL GMCCDF(XLOW,ALPHA,A,PTEMPL)
      CALL GMCCDF(XUP2,ALPHA,A,PTEMPU)
      IF(PTEMPL.LE.P .AND. P.LE.PTEMPU)THEN
        XUP=XUP2
        GOTO300
      ELSEIF(P.GT.PTEMPU)THEN
        XLOW=XUP2
        XUP2=XUP2 + DINC
        NIT=NIT+1
        GOTO200
      ELSEIF(P.LT.PTEMPL)THEN
        XUP2=XLOW
        XLOW=XLOW - DINC
        NIT=NIT+1
        GOTO200
      ENDIF
C
  300 CONTINUE
      AE=1.D-7
      RE=1.D-7
      DALPHA=ALPHA
      DP=P
      CALL DFZERO(GMCFU2,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 GMCPPF--')
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 GMCPPF--')
        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 GMCPPF--')
        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 GMCPPF--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,143)
  143   FORMAT('      MAXIMUM ITERATIONS EXCEEDED.')
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE GMCRAN(N,ALPHA,A,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE GENERALIZED MCLEISH DISTRIBUTION WITH SHAPE
C              PARAMETERS ALPHA AND A.  THIS DISTRIBUTION IS DEFINED
C              FOR ALL X AND HAS THE PROBABILITY DENSITY FUNCTION
C
C                 f(X;ALPHA,A) = [1/(SQRT(PI)*GAMMA(ALPHA))]*
C                                (ABS(X)/2)**(ALPHA-1/2)*K(X,ALPHA-1/2)
C                                *(1-A**2)**ALPHA*EXP(A*X)
C              WHERE
C                 K(X,N) IS THE MODIFIED BESSEL FUNCTION OF THE
C                        SECOND KIND
C                 GAMMA IS THE GAMMA FUNCTION
C
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --ALPHA  = THE FIRST SHAPE PARAMETER FOR THE
C                                GENERALIZED MCLEISH DISTRIBUTION
C                     --A      = THE SECOND SHAPE PARAMETER FOR THE
C                                GENERALIZED MCLEISH 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 FROM THE GENERALIZED MCLEISH
C             DISTRIBUTION WITH SHAPE PARAMETERS ALPHA AND A.
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--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISNAN, "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME I", SECOND EDITION,
C                 WILEY, 1994, PP. 50-53.
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.9
C     ORIGINAL VERSION--SEPTEMBER 2004.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DPPF
      DIMENSION X(*)
CCCCC 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 ')
        GOTO9000
      ENDIF
C
    5 FORMAT('***** ERROR--FOR THE GENERALIZED MCLEISH DISTRIBUTION, ',
     1       'THE REQUESTED')
    6 FORMAT('      NUMBER OF RANDOM NUMBERS WAS NON-POSITIVE.')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,'.')
      IF(ALPHA.LE.0.0D0)THEN
        WRITE(ICOUT,7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,17)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,48)ALPHA
        CALL DPWRST('XXX','WRIT')
        GOTO9000
      ENDIF
    7 FORMAT('***** ERROR: VALUE OF FIRST SHAPE PARAMETER (ALPHA)',
     1       ' FOR GENERALIZED MCLEISH')
   17 FORMAT('      RANDOM NUMBERS IS NON-POSITIVE.')
      IF(ABS(A).GE.1.0D0)THEN
        WRITE(ICOUT,8)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,18)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,48)A
        CALL DPWRST('XXX','WRIT')
        GOTO9000
      ENDIF
    8 FORMAT('***** ERROR: VALUE OF SECOND SHAPE PARAMETER (A)',
     1       ' FOR GENERALIZED MCLEISH')
   18 FORMAT('      RANDOM NUMBERS HAS ABSOLUTE VALUE >= 1')
   48 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7,'.')
C
C     MCLEISH IS DISTRIBUTION OF SQRT(G)*Z WHERE G IS A GAMMA
C     DISTRIBUTION WITH SHAPE PARAMETER ALPHA AND SCALE PARAMETER 2.
C     Z IS A STANDARD NORMAL DISTRIBUTION.
C
C     FOR THE GENERALIZED MCLEISH, ...
C
      CALL UNIRAN(N,ISEED,X)
      NTEMP=1
      DO100I=1,N
CCCCC   CALL GAMRAN(NTEMP,ALPHA,ISEED,Y)
CCCCC   G1=SQRT(2.0*Y(1))
CCCCC   CALL NORRAN(NTEMP,ISEED,Y)
CCCCC   G2=Y(1)
CCCCC   APPF=G1*G2
CCCCC   X(I)=APPF
        ATEMP=X(I)
        CALL GMCPPF(DBLE(ATEMP),DBLE(ALPHA),DBLE(A),DPPF)
        X(I)=REAL(DPPF)
  100 CONTINUE
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE GNBCDF(X,THETA,BETA,M,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE GENERALIZED NEGATIVE BINOMIAL
C              DISTRIBUTION WITH SHAPE PARAMETERS THETA, BETA, AND
C              M.  THIS DISTRIBUTION IS DEFINED FOR ALL INTEGER
C              X >= 1.
C
C              THE PROBABILITY MASS FUNCTION IS:
C              p(X;THETA,BETA,M)=
C                  (M/(M+BETA*X)*
C                  (M+BETA*X  X)*THETA**X*(1-THETA)**(M+BETA*X-X)
C                  X = 0, 1, 2, 3, ,...
C                  0 < THETA < 1; BETA = 0 OR 1 <= BETA <= 1/THETA;
C                  M > 0 (M A POSITIVE INTEGER IF BETA = 0)
C
C              THE CUMULATIVE DISTRIBUTION FUNCTION IS COMPUTED
C              FROM THE FOLLOWING RECURRENCE RELATION:
C
C              P(X+1) = (M+(BETA-1)*X+BETA)/(X+1)*
C                       THETA*(1-THETA)**(BETA-1)*
C                       PROD[J=1 TO X-1][1 + BETA/(M+BETA*X-J)]*P(X)
C
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE A NON-NEGATIVE INTEGER.
C                     --THETA  = THE FIRST SHAPE PARAMETER
C                     --BETA   = THE SECOND SHAPE PARAMETER
C                     --M      = THE THIRD SHAPE PARAMETER
C     OUTPUT ARGUMENTS--CDF    = THE SINGLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION FUNCTION
C             VALUE CDF FOR THE GENERALIZED NEGATIVE BINOMIAL
C             DISTRIBUTION WITH SHAPE PARAMETERS THETA AND BETA
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE A NON-NEGATIVE INTEGER
C                 --0 < THETA < 1; 1 <= BETA <= 1/THETA
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--CONSUL AND FAMOYE (2006), "LAGRANGIAN PROBABILITY
C                 DISTRIBUTIONS", BIRKHAUSER, CHAPTER 10.
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/7
C     ORIGINAL VERSION--JULY      2006.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      REAL M
C
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
      DOUBLE PRECISION DSUM
      DOUBLE PRECISION DX
      DOUBLE PRECISION DTHETA
      DOUBLE PRECISION DBETA
      DOUBLE PRECISION DM
      DOUBLE PRECISION DPDF
      DOUBLE PRECISION DPDFSV
      DOUBLE PRECISION DCDF
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IX=INT(X+0.5)
      IF(IX.LT.0)THEN
        WRITE(ICOUT,4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9000
      ENDIF
    4 FORMAT('***** ERROR--THE FIRST ARGUMENT TO GNBCDF IS LESS ',
     1'THAN 0')
C
      IF(THETA.LE.0.0 .OR. THETA.GE.1.0)THEN
        WRITE(ICOUT,15)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)THETA
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9000
      ENDIF
   15 FORMAT('***** ERROR--THE SECOND ARGUMENT TO GNBCDF IS NOT IN ',
     1'THE INTERVAL (0,1)')
C
      IF(BETA.LE.1.0 .OR. BETA.GE.1.0/THETA .AND. BETA.NE.0.0)THEN
        WRITE(ICOUT,25)1.0/THETA
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)THETA
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9000
      ENDIF
   25 FORMAT('***** ERROR--THE THIRD ARGUMENT TO GNBCDF IS NOT IN ',
     1'THE INTERVAL (1,',G15.7,')')
C
      IF(M.LE.0.0)THEN
        WRITE(ICOUT,35)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)M
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9000
      ENDIF
   35 FORMAT('***** ERROR--THE FOURTH ARGUMENT TO GNBCDF IS ',
     1'NON-POSITIVE')
      IF(BETA.EQ.0.0)THEN
        IM=INT(M+0.5)
        IF(IM.EQ.0)IM=1
        M=REAL(IM)
      ENDIF
C
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
C
      DTHETA=DBLE(THETA)
      DBETA=DBLE(BETA)
      DM=DBLE(M)
C
C     USE THE RECURRENCE RELATION (PAGE 199 OF CONSUL AND FAMOYE):
C
      DCDF=(1.0D0 - DTHETA)**DM
      IF(IX.EQ.0)GOTO1000
C
      DPDF=DM*DTHETA*(1.0D0 - DTHETA)**(DM+DBETA-1.0D0)
      DCDF=DCDF + DPDF
      IF(IX.EQ.1)GOTO1000
C
      DPDFSV=DPDF
      DTERM2=DLOG(DTHETA) + (DBETA - 1.0D0)*DLOG(1.0D0 - DTHETA)
C
      DO100I=2,IX
        DX=DBLE(I)
        DTERM1=DLOG(DM + (DBETA-1.0D0)*(DX-1.0D0) + DBETA) -
     1         DLOG(DX)
        IF(DPDFSV.LE.0.0D0)THEN
          GOTO1000
        ELSE
          DTERM3=DLOG(DPDFSV)
        ENDIF
        IF(I-2.GE.1)THEN
          DSUM=0.0D0
          DO200J=1,I-2
            DSUM=DSUM + DLOG(1.0D0 + DBETA/
     1           (DM + DBETA*(DX-1.0D0)-DBLE(J)))
  200     CONTINUE
        ELSE
          DSUM=0.0D0
        ENDIF
        DPDF=DEXP(DTERM1 + DTERM2 + DTERM3 + DSUM)
        DCDF=DCDF + DPDF
        DPDFSV=DPDF
  100 CONTINUE
C
 1000 CONTINUE
      CDF=REAL(DCDF)
C
 9000 CONTINUE
      RETURN
      END
      DOUBLE PRECISION FUNCTION GNBFUN(DTHETA)
C
C     PURPOSE--THIS ROUTINE COMPUTES THE FUNCTION FOR FINDING
C              THE ESTIMATE OF THETA FOR THE
C              GENERALIZED NEGATIVE BINOMIAL METHOD OF MOMENT
C              EQUATIONS.
C
C                 THETAHAT = 1 - 0.5*A + (A**2/4 - 1)**(0.5)
C                 A = -2 + (XBAR*S3 - 3*S2**2)**2/(XBAR*S2**3)
C
C              CALLED BY DFZERO ROUTINE FOR FINDING THE ROOT OF
C              A NONLINEAR EQUATIONS.
C     EXAMPLE--GENERALIZED NEGATIVE BINOMIAL MAXIMUM LIKELIHOOD Y
C     REFERENCES--CONSUL AND FAMOYE (2006), "LAGRANGIAN PROBABILITY
C                 DISTRIBUTIONS", BIRKHAUSER, CHAPTER 10.
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 DTHETA
      DOUBLE PRECISION DA
C
      DOUBLE PRECISION XBAR
      DOUBLE PRECISION S2
      DOUBLE PRECISION S3
      DOUBLE PRECISION F0FREQ
      DOUBLE PRECISION F1FREQ
      DOUBLE PRECISION F10FRE
      DOUBLE PRECISION DC1
      COMMON/GNBCOM/XBAR,S2,S3,F0FREQ,F1FREQ,F10FRE,DC1,
     1              MAXROW,NTOT2
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOBE.INC'
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C  COMPUTE SOME SUMS
C
      DA=-2.0D0 + (XBAR*S3 - 3.0D0*S2**2)**2/(XBAR*S2**3)
      GNBFUN=1.0D0 - 0.5D0*DA + DSQRT(DA**2/4.0D0 - 1.0D0)
C
      IF(ISUBG4.EQ.'BFUN')THEN
        WRITE(ICOUT,52)DTHETA,DA,GNBFUN
   52   FORMAT('DTHETA,DA,GNBFUN = ',3G15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      RETURN
      END
      SUBROUTINE GNBFU2(N,XPAR,FVEC,IFLAG,Y,K)
C
C     PURPOSE--THIS ROUTINE COMPUTES THE FUNCTIONS FOR THE
C              GENERALIZED NEGATIVE BINOMIAL MAXIMUM LIKELIHOOD
C              EQUATIONS.
C
C              THE MAXIMUM LIKELIHOOD ESTIMATES ARE THE SOLUTIONS
C              TO THE EQUATIONS:
C
C                 M*(XBAR - THETA*(M + BETA*XBAR))/
C                 (THETA*(1 - THETA))
C
C                 N*XBAR*LOG(1-THETA) +
C                 SUM[X=2 to k][SUM[i=1 to x-1]
C                 [X*N(x)/(M+BETA*X-i]] = 0
C
C                 (N-N0)*XBAR/M + N*LOG(1 - THETA) +
C                 SUM[X=2 to k][SUM[i=1 to x-1]
C                 [(X-XBAR)*N(x)/(M+BETA*X-i]] = 0
C
C              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--GENERALIZED NEGATIVE BINOMIAL MAXIMUM LIKELIHOOD Y
C     REFERENCES--CONSUL AND FAMOYE (2006), "LAGRANGIAN PROBABILITY
C                 DISTRIBUTIONS", BIRKHAUSER, CHAPTER 10.
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 DX
      DOUBLE PRECISION DM
      DOUBLE PRECISION DBETA
      DOUBLE PRECISION DTHETA
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DSUM2
      DOUBLE PRECISION DN
      DOUBLE PRECISION DJ
      DOUBLE PRECISION DN0
      DOUBLE PRECISION DFREQ
      DOUBLE PRECISION DNUM1
      DOUBLE PRECISION DNUM2
      DOUBLE PRECISION DENOM
C
      DOUBLE PRECISION XBAR
      DOUBLE PRECISION S2
      DOUBLE PRECISION S3
      DOUBLE PRECISION F0FREQ
      DOUBLE PRECISION F1FREQ
      DOUBLE PRECISION F10FRE
      DOUBLE PRECISION DC1
      COMMON/GNBCOM/XBAR,S2,S3,F0FREQ,F1FREQ,F10FRE,DC1,
     1              MAXROW,NTOT2
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C  COMPUTE SOME SUMS
C
      N=2
      IFLAG=0
C
      DBETA=XPAR(1)
      DM=XPAR(2)
      DTHETA=XPAR(3)
      DN=DBLE(NTOT2)
C
      IINDX=MAXROW/2
C
      DN0=DN*F0FREQ
      DTERM1=DN*XBAR*DLOG(1.0D0 - DTHETA)
      DTERM2=(DN - DN0)/DM + DN*DLOG(1.0D0 - DTHETA)
C
      DSUM1=0.0D0
      DSUM2=0.0D0
C
C     NOTE: CONSUL AND FAMOYE DEFINE CLASSES FOR I = 0 TO K,
C           SO ADJUST FOR FACT THAT FORTRAN ARRAYS START AT 1.
C
      DO100I=1,K
        DX=DBLE(Y(IINDX+I))
        IX=INT(DX + 0.5D0)
        IF(IX.LT.2)GOTO100
        DFREQ=DBLE(Y(I))
        IF(DFREQ.LE.0.0D0)GOTO100
        DNUM1=DX*DFREQ
        DNUM2=DFREQ
        DO200J=1,K
          DJ=DBLE(Y(IINDX+J))
          IJ=INT(DJ + 0.5D0)
          IF(IJ.LT.1 .OR. IJ.GT.IX-1)GOTO200
          DENOM=DM + DBETA*DX - DJ
          DSUM1=DSUM1 + DNUM1/DENOM
          DSUM2=DSUM2 + DNUM2/DENOM
  200   CONTINUE
  100 CONTINUE
C
      FVEC(1)=DM*(XBAR - DTHETA*(DM + DBETA*XBAR))/
     1        (DTHETA*(1.0D0 - DTHETA))
      FVEC(2)=DTERM1 + DSUM1
      FVEC(3)=DTERM2 + DSUM2
C
      RETURN
      END
      DOUBLE PRECISION FUNCTION GNBFU3(DTHETA)
C
C     PURPOSE--THIS ROUTINE COMPUTES THE FUNCTION FOR FINDING
C              THE ESTIMATE OF THETA FOR THE
C              GENERALIZED NEGATIVE BINOMIAL METHOD OF MOMENTS
C              AND ZERO-CLASS FREQUENCY EQUATION.
C
C                 S2*(LOG(F0)**2/XBAR**3 -
C                 (1-THETA)*(LOG(1-THETA))**2/THETA**2 = 0
C
C              CALLED BY DFZERO ROUTINE FOR FINDING THE ROOT OF
C              A NONLINEAR EQUATIONS.
C     EXAMPLE--GENERALIZED NEGATIVE BINOMIAL MAXIMUM LIKELIHOOD Y
C     REFERENCES--CONSUL AND FAMOYE (2006), "LAGRANGIAN PROBABILITY
C                 DISTRIBUTIONS", BIRKHAUSER, CHAPTER 10.
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 DTHETA
C
      DOUBLE PRECISION XBAR
      DOUBLE PRECISION S2
      DOUBLE PRECISION S3
      DOUBLE PRECISION F0FREQ
      DOUBLE PRECISION F1FREQ
      DOUBLE PRECISION F10FRE
      DOUBLE PRECISION DC1
      COMMON/GNBCOM/XBAR,S2,S3,F0FREQ,F1FREQ,F10FRE,DC1,
     1              MAXROW,NTOT2
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C  COMPUTE SOME SUMS
C
      GNBFU3=DC1 - (1.0D0 - DTHETA)*DLOG(1.0D0 - DTHETA)**2/DTHETA**2
C
      RETURN
      END
      DOUBLE PRECISION FUNCTION GNBFU4(DTHETA)
C
C     PURPOSE--THIS ROUTINE COMPUTES THE FUNCTION FOR FINDING
C              THE ESTIMATE OF THETA FOR THE
C              GENERALIZED NEGATIVE BINOMIAL METHOD OF MOMENTS
C              AND RATIO OF FREQUENCIES EQUATION
C
C                 {(2/THETA) - (2/THETA)*SQRT(XBAR*(1-THETA)/S2)-1}*
C                 LOG(1-THETA) - LOG(S2*F10**2/XBAR**3) = 0
C
C              CALLED BY DFZERO ROUTINE FOR FINDING THE ROOT OF
C              A NONLINEAR EQUATIONS.
C     EXAMPLE--GENERALIZED NEGATIVE BINOMIAL MAXIMUM LIKELIHOOD Y
C     REFERENCES--CONSUL AND FAMOYE (2006), "LAGRANGIAN PROBABILITY
C                 DISTRIBUTIONS", BIRKHAUSER, CHAPTER 10.
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 DTHETA
C
      DOUBLE PRECISION XBAR
      DOUBLE PRECISION S2
      DOUBLE PRECISION S3
      DOUBLE PRECISION F0FREQ
      DOUBLE PRECISION F1FREQ
      DOUBLE PRECISION F10FRE
      DOUBLE PRECISION DC1
      COMMON/GNBCOM/XBAR,S2,S3,F0FREQ,F1FREQ,F10FRE,DC1,
     1              MAXROW,NTOT2
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C  COMPUTE SOME SUMS
C
      GNBFU4=((2.0D0/DTHETA) -
     1       (2.0D0/DTHETA)*DSQRT(XBAR*(1.0D0-DTHETA)/S2)-1.0D0)*
     1       DLOG(1.0D0-DTHETA) - DLOG(S2*F10FRE**2/XBAR**3)
C
      RETURN
      END
      DOUBLE PRECISION FUNCTION GNBFU5(DM)
C
C     PURPOSE--THIS ROUTINE COMPUTES THE FUNCTION FOR FINDING
C              THE ESTIMATE OF M FOR THE TRUNCATED GENERALIZED
C              NEGATIVE BINOMIAL RATIO OF FREQUENCIES METHOD.
C              SOLVE THE FOLLOWING EQUATONS:
C
C              H(M) = -XBAR/M + (1-XBAR)*F1/(M*F0) +
C                     SUM[X=2 to t][((X-XBAR)/X!)*(F1/(M*F0))*
C                     PROD[i=1 to x-1][M + (X*M*F0*F2/F(i)**2) -
C                     X*(M-1)/2 - i]]
C
C              WITH XBAR, F0, F1, F2 DENOTING THE SAMPLE MEAN
C              AND THE FREQUENCIES FOR THE FIRST THREE CLASSES.
C              F(i) IS THE FREQUENCY OF CLASS i.
C
C              CALLED BY DFZERO ROUTINE FOR FINDING THE ROOT OF
C              A NONLINEAR EQUATIONS.
C     EXAMPLE--GENERALIZED NEGATIVE BINOMIAL MAXIMUM LIKELIHOOD Y
C     REFERENCES--CONSUL AND FAMOYE (2006), "LAGRANGIAN PROBABILITY
C                 DISTRIBUTIONS", BIRKHAUSER, CHAPTER 10.
C               --FAMOYE AND CONSUL (1993), "THE TRUNCATED
C                 GENERALZIED NEGATIVE BINOMIAL DISTRIBUTION",
C                 JOURNAL OF APPLIED STATISTICAL SCIENCES,
C                 VOL. 1, NO. 2, PP. 141-157.
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/1
C     ORIGINAL VERSION--JANUARY   2007.
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DM
C
      DOUBLE PRECISION XBAR
      DOUBLE PRECISION S2
      DOUBLE PRECISION S3
      DOUBLE PRECISION F0FREQ
      DOUBLE PRECISION F1FREQ
      DOUBLE PRECISION F10FRE
      DOUBLE PRECISION DC1
      COMMON/GNBCOM/XBAR,S2,S3,F0FREQ,F1FREQ,F10FRE,DC1,
     1              MAXROW,NTOT2
C
CCCCC DOUBLE PRECISION DN
CCCCC DOUBLE PRECISION DTERM1
CCCCC DOUBLE PRECISION DTERM2
CCCCC DOUBLE PRECISION DTERM3
CCCCC DOUBLE PRECISION DTERM4
CCCCC DOUBLE PRECISION DTERM5
CCCCC DOUBLE PRECISION DTERM6
CCCCC DOUBLE PRECISION DSUM
CCCCC DOUBLE PRECISION DPROD
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOBE.INC'
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C  COMPUTE SOME SUMS
C
CCCCC DN=DBLE(NTOT2)
CCCCC IINDX=MAXROW/2
CCCCC DF0=DBLE(Y(1))
CCCCC DF1=DBLE(Y(2))
CCCCC DF2=DBLE(Y(2))
C
CCCCC DTERM1=XBAR/DM
CCCCC DTERM2=(1.0D0 - XBAR)*DF2/(DM*DF1)
C
C     NOTE: CONSUL AND FAMOYE DEFINE CLASSES FOR I = 0 TO K,
C           SO ADJUST FOR FACT THAT FORTRAN ARRAYS START AT 1.
C
CCCCC DSUM=0.0D0
CCCCC DO100I=3,K
C
CCCCC   DX=DBLE(Y(IINDX+I))
CCCCC   IX=INT(DX+0.5D0)
CCCCC   DFREQ=DBLE(Y(I))
CCCCC   DTERM3=(DX-XBAR)/DGAMMA(DX+1)
CCCCC   DTERM4=(DF1/(DM*DF0))**DX
C
CCCCC   DPROD=1.0D0
CCCCC   DO200J=2,IX-1
CCCCC     DTERM5=DM + (DX*DM*DF0*DF2/DFREQ**2)
CCCCC     DTERM6=-DX*(DM-1.0D0)/2.0D0  - DBLE(J-1)
CCCCC     DPROD=DPROD*(DTERM5 + DTERM6)
CC200   CONTINUE
CCCCC   DSUM=DSUM + DTERM3*DTERM4*DPROD
CC100 CONTINUE
C
CCCCC GNBFU5=DTERM1 + DTERM2 + DSUM
      GNBFU5=0.0D0
C
      IF(ISUBG4.EQ.'BFU5')THEN
        WRITE(ICOUT,52)DM,GNBFU5
   52   FORMAT('DM,GNBFU5 = ',2G15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      RETURN
      END
      SUBROUTINE GNBPDF(X,THETA,BETA,M,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY MASS
C              FUNCTION VALUE FOR THE GENERALIZED NEGATIVE BINOMIAL
C              DISTRIBUTION WITH SHAPE PARAMETERS THETA, BETA, AND
C              M.  THIS DISTRIBUTION IS DEFINED FOR ALL INTEGER
C              X >= 1.
C
C              THE PROBABILITY MASS FUNCTION IS:
C              p(X;THETA,BETA,M)=
C                  (M/(M+BETA*X)*
C                  (M+BETA*X  X)*THETA**X*(1-THETA)**(M+BETA*X-X)
C                  X = 0, 1, 2, 3, ,...
C                  0 < THETA < 1; BETA = 0 OR 1 <= BETA <= 1/THETA;
C                  M > 0 (M A POSITIVE INTEGER IF BETA = 0)
C
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE PROBABILITY MASS
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE A NON-NEGATIVE INTEGER.
C                     --THETA  = THE FIRST SHAPE PARAMETER
C                     --BETA   = THE SECOND SHAPE PARAMETER
C                     --M      = THE THIRD SHAPE PARAMETER
C     OUTPUT ARGUMENTS--PDF    = THE SINGLE PRECISION PROBABILITY
C                                MASS FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PROBABILITY MASS FUNCTION
C             VALUE PDF FOR THE GENERALIZED NEGATIVE BINOMIAL
C             DISTRIBUTION WITH SHAPE PARAMETERS THETA, BETA AND M.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE A NON-NEGATIVE INTEGER
C                 --0 < THETA < 1; 1 <= BETA <= 1/THETA
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--CONSUL AND FAMOYE (2006), "LAGRANGIAN PROBABILITY
C                 DISTRIBUTIONS", BIRKHAUSER, CHAPTER 10.
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/7
C     ORIGINAL VERSION--JULY      2006.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      REAL M
C
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
      DOUBLE PRECISION DX
      DOUBLE PRECISION DTHETA
      DOUBLE PRECISION DBETA
      DOUBLE PRECISION DM
      DOUBLE PRECISION DPDF
      DOUBLE PRECISION DLNGAM
      EXTERNAL DLNGAM
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IX=INT(X+0.5)
      IF(IX.LT.0)THEN
        WRITE(ICOUT,4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9000
      ENDIF
    4 FORMAT('***** ERROR--THE FIRST ARGUMENT TO GNBPDF IS LESS ',
     1'THAN 0')
C
      IF(THETA.LE.0.0 .OR. THETA.GE.1.0)THEN
        WRITE(ICOUT,15)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)THETA
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9000
      ENDIF
   15 FORMAT('***** ERROR--THE SECOND ARGUMENT TO GNBPDF IS NOT IN ',
     1'THE INTERVAL (0,1)')
C
      IF(BETA.LE.1.0 .OR. BETA.GE.1.0/THETA .AND. BETA.NE.0.0)THEN
        WRITE(ICOUT,25)1.0/THETA
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)THETA
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9000
      ENDIF
   25 FORMAT('***** ERROR--THE THIRD ARGUMENT TO GNBPDF IS NOT IN ',
     1'THE INTERVAL (1,',G15.7,')')
C
      IF(M.LE.0.0)THEN
        WRITE(ICOUT,35)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)M
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9000
      ENDIF
   35 FORMAT('***** ERROR--THE FOURTH ARGUMENT TO GNBPDF IS ',
     1'NON-POSITIVE')
      IF(BETA.EQ.0.0)THEN
        IM=INT(M+0.5)
        IF(IM.EQ.0)IM=1
        M=REAL(IM)
      ENDIF
C
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
C
      DTHETA=DBLE(THETA)
      DBETA=DBLE(BETA)
      DM=DBLE(M)
      DX=DBLE(IX)
C
      IF(IX.EQ.0)THEN
        DPDF=(1.0D0 - DTHETA)**DM
      ELSEIF(IX.EQ.1)THEN
        DPDF=DM*DTHETA*(1.0D0 - DTHETA)**(DM+DBETA-1.0D0)
      ELSE
        DTERM1=DLOG(DM) - DLOG(DM + DBETA*DX)
        DTERM2=DX*DLOG(DTHETA)
        DTERM3=(DM+DBETA*DX-DX)*DLOG(1.0D0 - DTHETA)
        DTERM4=DLNGAM(DM+DBETA*DX+1.0D0) - DLNGAM(DX+1.0D0) -
     1         DLNGAM(DM+DBETA*DX-DX+1.0D0)
        DPDF=DEXP(DTERM1+DTERM2+DTERM3+DTERM4)
      ENDIF
C
      PDF=REAL(DPDF)
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE GNBPPF(P,THETA,BETA,M,PPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE GENERALIZED NEGATIVE BINOMIAL
C              DISTRIBUTION WITH SHAPE PARAMETERS THETA, BETA, AND
C              M.  THIS DISTRIBUTION IS DEFINED FOR ALL INTEGER
C              X >= 1.
C
C              THE PROBABILITY MASS FUNCTION IS:
C              p(X;THETA,BETA,M)=
C                  (M/(M+BETA*X)*
C                  (M+BETA*X  X)*THETA**X*(1-THETA)**(M+BETA*X-X)
C                  X = 0, 1, 2, 3, ,...
C                  0 < THETA < 1; BETA = 0 OR 1 <= BETA <= 1/THETA;
C                  M > 0 (M A POSITIVE INTEGER IF BETA = 0)
C
C              THE CUMULATIVE DISTRIBUTION FUNCTION IS COMPUTED
C              FROM THE FOLLOWING RECURRENCE RELATION:
C
C              P(X+1) = (M+(BETA-1)*X+BETA)/(X+1)*
C                       THETA*(1-THETA)**(BETA-1)*
C                       PROD[J=1 TO X-1][1 + BETA/(M+BETA*X-J)]*P(X)
C
C              THE PERCENT POINT FUNCTION IS COMPUTED BY COMPUTING
C              THE CUMULATIVE DISTRIBUTION FUNCTION UNTIL THE
C              THE SPECIFIED PROBABILITY IS REACHED.
C     INPUT  ARGUMENTS--P      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE PERCENT POINT
C                                FUNCTION IS TO BE EVALUATED.
C                                0 <= P < 1
C                     --THETA  = THE FIRST SHAPE PARAMETER
C                     --BETA   = THE SECOND SHAPE PARAMETER
C                     --M      = THE THIRD SHAPE PARAMETER
C     OUTPUT ARGUMENTS--PPF    = THE SINGLE PRECISION PERCENT POINT
C                                FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PERCENT POINT FUNCTION
C             VALUE PPF FOR THE GENERALIZED NEGATIVE BINOMIAL
C             DISTRIBUTION WITH SHAPE PARAMETERS THETA, BETA AND M.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--0 <= P < 1
C                 --0 < THETA < 1; 1 <= BETA <= 1/THETA; M > 0
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--CONSUL AND FAMOYE (2006), "LAGRANGIAN PROBABILITY
C                 DISTRIBUTIONS", BIRKHAUSER, CHAPTER 10.
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/7
C     ORIGINAL VERSION--JULY      2006.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      REAL M
C
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
      DOUBLE PRECISION DSUM
      DOUBLE PRECISION DX
      DOUBLE PRECISION DTHETA
      DOUBLE PRECISION DBETA
      DOUBLE PRECISION DM
      DOUBLE PRECISION DPDF
      DOUBLE PRECISION DPDFSV
      DOUBLE PRECISION DPPF
      DOUBLE PRECISION DP
      DOUBLE PRECISION DEPS
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOMC.INC'
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      PPF=0.0
      DPPF=0.0D0
C
      IF(P.LT.0.0 .OR. P.GE.1.0)THEN
        WRITE(ICOUT,4)
    4   FORMAT('***** ERROR--THE FIRST ARGUMENT TO GNBPPF IS OUTSIDE ',
     1         'THE (0,1] INTERVAL.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)P
   46   FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7,'.')
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(THETA.LE.0.0 .OR. THETA.GE.1.0)THEN
        WRITE(ICOUT,15)
   15   FORMAT('***** ERROR--THE SECOND ARGUMENT TO GNBPPF IS NOT IN ',
     1         'THE INTERVAL (0,1).')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)THETA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(BETA.LE.1.0 .OR. BETA.GE.1.0/THETA .AND. BETA.NE.0.0)THEN
        WRITE(ICOUT,25)1.0/THETA
   25   FORMAT('***** ERROR--THE THIRD ARGUMENT TO GNBPPF IS NOT IN ',
     1         'THE INTERVAL (1,',G15.7,').')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)THETA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(M.LE.0.0)THEN
        WRITE(ICOUT,35)
   35   FORMAT('***** ERROR--THE FOURTH ARGUMENT TO GNBPPF IS ',
     1         'NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)M
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
      IF(BETA.EQ.0.0)THEN
        IM=INT(M+0.5)
        IF(IM.EQ.0)IM=1
        M=REAL(IM)
      ENDIF
C
      DTHETA=DBLE(THETA)
      DBETA=DBLE(BETA)
      DM=DBLE(M)
      DP=DBLE(P)
      DEPS=1.0D-7
C
C     USE THE RECURRENCE RELATION (PAGE 199 OF CONSUL AND FAMOYE):
C
      DCDF=(1.0D0 - DTHETA)**DM
      IF(DCDF.GE.DP-DEPS)THEN
        PPF=0.0
        GOTO9000
      ENDIF
C
      DPDF=DM*DTHETA*(1.0D0 - DTHETA)**(DM+DBETA-1.0D0)
      DCDF=DCDF + DPDF
      IF(DCDF.GE.DP-DEPS)THEN
        PPF=1.0
        GOTO9000
      ENDIF
C
      DPDFSV=DPDF
      DTERM2=DLOG(DTHETA) + (DBETA - 1.0D0)*DLOG(1.0D0 - DTHETA)
      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
          GOTO9000
        ENDIF
        DX=DBLE(I)
C
        DTERM1=DLOG(DM + (DBETA-1.0D0)*(DX-1.0D0) + DBETA) -
     1         DLOG(DX)
        IF(DPDFSV.LE.0.0D0)THEN
          GOTO1000
        ELSE
          DTERM3=DLOG(DPDFSV)
        ENDIF
        IF(I-2.GE.1)THEN
          DSUM=0.0D0
          DO200J=1,I-2
            DSUM=DSUM + DLOG(1.0D0 + DBETA/
     1           (DM + DBETA*(DX-1.0D0)-DBLE(J)))
  200     CONTINUE
        ELSE
          DSUM=0.0D0
        ENDIF
        DPDF=DEXP(DTERM1 + DTERM2 + DTERM3 + DSUM)
        DCDF=DCDF + DPDF
        DPDFSV=DPDF
        IF(DCDF.GE.DP-DEPS)THEN
          PPF=REAL(I)
          GOTO9000
        ENDIF
      GOTO100
C
 1000 CONTINUE
      PPF=REAL(DPPF)
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE GNBRAN(N,THETA,BETA,AM,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE GENERALIZED NEGATIVE BINOMIAL DISTRIBUTION
C              WITH SHAPE PARAMETERS THETA, BETA, AND M.
C              THE PROBABILITY MASS FUNCTION IS:
C              p(X;THETA,BETA,M)=
C                  (M/(M+BETA*X)*
C                  (M+BETA*X  X)*THETA**X*(1-THETA)**(M+BETA*X-X)
C                  X = 0, 1, 2, 3, ,...
C                  0 < THETA < 1; BETA = 0 OR 1 <= BETA <= 1/THETA;
C                  M > 0 (M A POSITIVE INTEGER IF BETA = 0)
C
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --THETA  = THE SINGLE PRECISION VALUE
C                                OF THE FIRST SHAPE PARAMETER.
C                     --BETA   = THE SINGLE PRECISION VALUE
C                                OF THE SECOND SHAPE PARAMETER.
C                     --AM     = 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 GENERALIZED NEGATIVE BINOMIAL DISTRIBUTION
C             WITH SHAPE PARAMETERS THETA, BETA, AND M.
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 < THETA < 1, 1 < BETA < 1/THETA, M > 0
C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN, GNBPPF
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--FAMOYE (1997), "SAMPLING FROM A GENERALIZED
C                 NEGATIVE BINOMIAL DISTRIBUTION", COMPUTING,
C                 58(4), PP. 365-376.
C               --CONSUL AND FAMOYE (2006), "LAGRANGIAN PROBABILITY
C                 DISTRIBUTIONS", BIRKHAUSER, CHAPTERS 11 AND 16.
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/7
C     ORIGINAL VERSION--JULY      2006.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      REAL THETA
      REAL BETA
      DIMENSION X(*)
      DIMENSION XTEMP(2)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----DATA STATEMENTS-------------------------------------------------
C
CCCCC DATA PI / 3.1415926535 8979323846 E0 /
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         'GENERALIZED NEGATIVE BINOMIAL')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,6)
    6   FORMAT('      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(THETA.LE.0.0 .OR. THETA.GE.1.0)THEN
        WRITE(ICOUT,11)
   11   FORMAT('***** ERROR--THE THETA PARAMETER FOR THE ',
     1         'GENERALIZED NEGATIVE BINOMIAL')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,12)
   12   FORMAT('      RANDOM NUMBERS IS OUTSIDE THE (0,1) INTERVAL.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)THETA
   46   FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7,'.')
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ELSEIF(BETA.LE.1.0 .OR. BETA.GE.1.0/THETA)THEN
        WRITE(ICOUT,21)
   21   FORMAT('***** ERROR--THE BETA PARAMETER FOR THE ',
     1         'GENERALIZED NEGATIVE BINOMIAL')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,22)
   22   FORMAT('      RANDOM NUMBERS IS OUTSIDE THE (0,',G15.7,
     1         ') INTERVAL.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)BETA
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ELSEIF(AM.LE.0.0)THEN
        WRITE(ICOUT,31)
   31   FORMAT('***** ERROR--THE M PARAMETER FOR THE ',
     1         'GENERALIZED NEGATIVE BINOMIAL')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,32)
   32   FORMAT('      RANDOM NUMBERS IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)AM
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
C
C     GENERATE N GENERALIZED NEGATIVE BINOMIAL DISTRIBUTION
C     RANDOM NUMBERS.  FOLLOWING RECOMMENDATION OF CONSUL AND
C     FAYMOE, USE INVERSION METHOD FOR THETA*BETA <= 0.60 AND
C     BRANCHING METHOD OTHERWISE.
C
C     BRANCHING ALGORITHM DOESN'T SEEM TO RETURN AS ACCURATE
C     A RESULT AS THE INVERSION METHOD, SO USE THE INVERSION
C     METHOD EVEN IF SOMEWHAT SLOWER.
C
      IFLAG=0
      IF(THETA*BETA.LE.0.6 .OR. IFLAG.EQ.0)THEN
        CALL UNIRAN(N,ISEED,X)
        DO100I=1,N
          ZTEMP=X(I)
          CALL GNBPPF(ZTEMP,THETA,BETA,AM,PPF)
          X(I)=PPF
  100   CONTINUE
      ELSE
C
C       BRANCHING ALGORITHM
C
        NTEMP=1
        DO200I=1,N
          CALL NBRAN(NTEMP,1.0-THETA,AM,ISEED,XTEMP)
          Y=XTEMP(1)
          IF(Y.LE.0.0)THEN
            X(I)=Y
            GOTO200
          ENDIF
          XX=0.0
  220     CONTINUE
          AK=(BETA-1.0)*Y
          CALL NBRAN(NTEMP,1.0-THETA,AK,ISEED,XTEMP)
          Z=XTEMP(1)
          XX=XX+Y+Z
          Y=Z
          IF(Y.GT.0.0)GOTO220
          X(I)=XX
  200   CONTINUE
      ENDIF
C
 9999 CONTINUE
C
      RETURN
      END
      SUBROUTINE GNTCDF(X,THETA,BETA,M,NTRUNC,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE TRUNCATED GENERALIZED
C              NEGATIVE BINOMIAL DISTRIBUTION WITH SHAPE PARAMETERS
C              THETA, BETA, AND M.
C
C              THE PROBABILITY MASS FUNCTION FOR THE NON-TRUNCATED
C              GENERALIZED NEGATIVE BINOMIAL DISTRIBUTION IS:
C
C              p(X;THETA,BETA,M)=
C                  (M/(M+BETA*X)*
C                  (M+BETA*X  X)*THETA**X*(1-THETA)**(M+BETA*X-X)
C                  X = 0, 1, 2, 3, ,...
C                  0 < THETA < 1; BETA = 0 OR 1 <= BETA <= 1/THETA;
C                  M > 0 (M A POSITIVE INTEGER IF BETA = 0)
C
C              THE TRUNCATED GENERALIZED NEGATIVE BINOMIAL
C              DISTRIBUTION CAN BE DEFINED AS:
C
C              p(X;THETA,BETA,M)/F(NTRUNC,THETA,BETA,M)
C
C              WITH p, F, AND NTRUNC DENOTING THE PROBABILITY
C              MASS AND CUMULATIVE DISTRIBUTION FUNCTION OF
C              THE GENERALIZED NEGATIVE BINOMIAL DISTRIBUTION
C              AND THE TRUNCATION POINT, RESPECTIVELY.
C
C              THE TRUNCATED CUMULATIVE DISTRIBUTION FUNCTION
C              CAN THEREFORE BE COMPUTED AS:
C
C              F(X;THETA,BETA,M)/F(NTRUNC,THETA,BETA,M)
C
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE A NON-NEGATIVE INTEGER.
C                     --THETA  = THE FIRST SHAPE PARAMETER
C                     --BETA   = THE SECOND SHAPE PARAMETER
C                     --M      = THE THIRD SHAPE PARAMETER
C                     --NTRUNC = THE TRUNCATION POINT
C     OUTPUT ARGUMENTS--CDF    = THE SINGLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION FUNCTION
C             VALUE CDF FOR THE GENERALIZED NEGATIVE BINOMIAL
C             DISTRIBUTION WITH SHAPE PARAMETERS THETA, BETA AND M.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--0 <= X <= NTRUNC; SHOULD BE A NON-NEGATIVE INTEGER
C                 --0 < THETA < 1; 1 <= BETA <= 1/THETA
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--CONSUL AND FAMOYE (2006), "LAGRANGIAN PROBABILITY
C                 DISTRIBUTIONS", BIRKHAUSER, CHAPTER 10.
C     REFERENCES--CONSUL AND FAMOYE (1993), "THE TRUNCATED
C                 GENERALIZED NEGATIVE BINOMIAL DISTRIBUTION",
C                 JOURNAL OF APPLIED STATISTICAL SCIENCE,
C                 VOL. 1, NO. 2, PP. 141-157.
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
      REAL M
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(NTRUNC.LT.1)THEN
        WRITE(ICOUT,3)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)NTRUNC
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9000
      ENDIF
    3 FORMAT('***** ERROR--THE FIFTH ARGUMENT TO GNTCDF, THE ',
     1      'TRUNCATION POINT, IS LESS THAN 1')
C
      IX=INT(X+0.5)
      IF(IX.LT.0)THEN
        WRITE(ICOUT,4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9000
      ENDIF
    4 FORMAT('***** ERROR--THE FIRST ARGUMENT TO GNTCDF IS LESS ',
     1'THAN 0')
C
      IF(THETA.LE.0.0 .OR. THETA.GE.1.0)THEN
        WRITE(ICOUT,15)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)THETA
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9000
      ENDIF
   15 FORMAT('***** ERROR--THE SECOND ARGUMENT TO GNTCDF IS NOT IN ',
     1'THE INTERVAL (0,1)')
C
      IF(BETA.LE.1.0 .OR. BETA.GE.1.0/THETA .AND. BETA.NE.0.0)THEN
        WRITE(ICOUT,25)1.0/THETA
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)THETA
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9000
      ENDIF
   25 FORMAT('***** ERROR--THE THIRD ARGUMENT TO GNTCDF IS NOT IN ',
     1'THE INTERVAL (1,',G15.7,')')
C
      IF(M.LE.0.0)THEN
        WRITE(ICOUT,35)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)M
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9000
      ENDIF
   35 FORMAT('***** ERROR--THE FOURTH ARGUMENT TO GNTCDF IS ',
     1'NON-POSITIVE')
      IF(BETA.EQ.0.0)THEN
        IM=INT(M+0.5)
        IF(IM.EQ.0)IM=1
        M=REAL(IM)
      ENDIF
C
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8)
C
      IF(IX.EQ.NTRUNC)THEN
        CDF=1.0
      ELSE
        CALL GNBCDF(X,THETA,BETA,M,TERM1)
        CALL GNBCDF(REAL(NTRUNC),THETA,BETA,M,TERM2)
        CDF=TERM1/TERM2
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE GNTPDF(X,THETA,BETA,M,NTRUNC,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY MASS
C              FUNCTION VALUE FOR THE TRUNCATED GENERALIZED
C              NEGATIVE BINOMIAL DISTRIBUTION WITH SHAPE PARAMETERS
C              THETA, BETA, AND M.
C
C              THE PROBABILITY MASS FUNCTION FOR THE NON-TRUNCATED
C              GENERALIZED NEGATIVE BINOMIAL DISTRIBUTION IS:
C
C              p(X;THETA,BETA,M)=
C                  (M/(M+BETA*X)*
C                  (M+BETA*X  X)*THETA**X*(1-THETA)**(M+BETA*X-X)
C                  X = 0, 1, 2, 3, ,...
C                  0 < THETA < 1; BETA = 0 OR 1 <= BETA <= 1/THETA;
C                  M > 0 (M A POSITIVE INTEGER IF BETA = 0)
C
C              THE TRUNCATED GENERALIZED NEGATIVE BINOMIAL
C              DISTRIBUTION CAN BE DEFINED AS:
C
C              p(X;THETA,BETA,M)/F(NTRUNC,THETA,BETA,M)
C
C              WITH p, F, AND NTRUNC DENOTING THE PROBABILITY
C              MASS AND CUMULATIVE DISTRIBUTION FUNCTION OF
C              THE GENERALIZED NEGATIVE BINOMIAL DISTRIBUTION
C              AND THE TRUNCATION POINT, RESPECTIVELY.
C
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE PROBABILITY MASS
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE A NON-NEGATIVE INTEGER.
C                     --THETA  = THE FIRST SHAPE PARAMETER
C                     --BETA   = THE SECOND SHAPE PARAMETER
C                     --M      = THE THIRD SHAPE PARAMETER
C                     --NTRUNC = THE TRUNCATION POINT
C     OUTPUT ARGUMENTS--PDF    = THE SINGLE PRECISION PROBABILITY
C                                MASS FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PROBABILITY MASS FUNCTION
C             VALUE PDF FOR THE GENERALIZED NEGATIVE BINOMIAL
C             DISTRIBUTION WITH SHAPE PARAMETERS THETA, BETA AND M.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--0 <= X <= NTRUNC; SHOULD BE A NON-NEGATIVE INTEGER
C                 --0 < THETA < 1; 1 <= BETA <= 1/THETA
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--CONSUL AND FAMOYE (2006), "LAGRANGIAN PROBABILITY
C                 DISTRIBUTIONS", BIRKHAUSER, CHAPTER 10.
C     REFERENCES--CONSUL AND FAMOYE (1993), "THE TRUNCATED
C                 GENERALIZED NEGATIVE BINOMIAL DISTRIBUTION",
C                 JOURNAL OF APPLIED STATISTICAL SCIENCE,
C                 VOL. 1, NO. 2, PP. 141-157.
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
      REAL M
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(NTRUNC.LT.1)THEN
        WRITE(ICOUT,3)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)NTRUNC
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9000
      ENDIF
    3 FORMAT('***** ERROR--THE FIFTH ARGUMENT TO GNTPDF, THE ',
     1      'TRUNCATION POINT, IS LESS THAN 1')
C
      IX=INT(X+0.5)
      IF(IX.LT.0)THEN
        WRITE(ICOUT,4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9000
      ENDIF
    4 FORMAT('***** ERROR--THE FIRST ARGUMENT TO GNTPDF IS LESS ',
     1'THAN 0')
C
      IF(THETA.LE.0.0 .OR. THETA.GE.1.0)THEN
        WRITE(ICOUT,15)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)THETA
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9000
      ENDIF
   15 FORMAT('***** ERROR--THE SECOND ARGUMENT TO GNTPDF IS NOT IN ',
     1'THE INTERVAL (0,1)')
C
      IF(BETA.LE.1.0 .OR. BETA.GE.1.0/THETA .AND. BETA.NE.0.0)THEN
        WRITE(ICOUT,25)1.0/THETA
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)THETA
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9000
      ENDIF
   25 FORMAT('***** ERROR--THE THIRD ARGUMENT TO GNTPDF IS NOT IN ',
     1'THE INTERVAL (1,',G15.7,')')
C
      IF(M.LE.0.0)THEN
        WRITE(ICOUT,35)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)M
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9000
      ENDIF
   35 FORMAT('***** ERROR--THE FOURTH ARGUMENT TO GNTPDF IS ',
     1'NON-POSITIVE')
      IF(BETA.EQ.0.0)THEN
        IM=INT(M+0.5)
        IF(IM.EQ.0)IM=1
        M=REAL(IM)
      ENDIF
C
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8)
C
      CALL GNBPDF(X,THETA,BETA,M,TERM1)
      CALL GNBCDF(REAL(NTRUNC),THETA,BETA,M,TERM2)
      PDF=TERM1/TERM2
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE GNTPPF(P,THETA,BETA,M,NTRUNC,PPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE TRUNCATED GENERALIZED
C              NEGATIVE BINOMIAL DISTRIBUTION WITH SHAPE
C              PARAMETERS THETA, BETA, AND M.
C
C              THE PROBABILITY MASS FUNCTION FOR THE NON-TRUNCATED
C              GENERALIZED NEGATIVE BINOMIAL DISTRIBUTION IS:
C
C              p(X;THETA,BETA,M)=
C                  (M/(M+BETA*X)*
C                  (M+BETA*X  X)*THETA**X*(1-THETA)**(M+BETA*X-X)
C                  X = 0, 1, 2, 3, ,...
C                  0 < THETA < 1; BETA = 0 OR 1 <= BETA <= 1/THETA;
C                  M > 0 (M A POSITIVE INTEGER IF BETA = 0)
C
C              THE TRUNCATED GENERALIZED NEGATIVE BINOMIAL
C              DISTRIBUTION CAN BE DEFINED AS:
C
C              p(X;THETA,BETA,M)/F(NTRUNC,THETA,BETA,M)
C
C              WITH p, F, AND NTRUNC DENOTING THE PROBABILITY
C              MASS AND CUMULATIVE DISTRIBUTION FUNCTION OF
C              THE GENERALIZED NEGATIVE BINOMIAL DISTRIBUTION
C              AND THE TRUNCATION POINT, RESPECTIVELY.
C
C              THE TRUNCATED CUMULATIVE DISTRIBUTION FUNCTION
C              CAN THEREFORE BE COMPUTED AS:
C
C              F(X;THETA,BETA,M)/F(NTRUNC,THETA,BETA,M)
C
C              THE PERCENT POINT FUNCTION IS COMPUTED BY COMPUTING
C              THE CUMULATIVE DISTRIBUTION FUNCTION UNTIL THE
C              THE SPECIFIED PROBABILITY IS REACHED.
C     INPUT  ARGUMENTS--P      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE PERCENT POINT
C                                FUNCTION IS TO BE EVALUATED.
C                                0 <= P <= 1
C                     --THETA  = THE FIRST SHAPE PARAMETER
C                     --BETA   = THE SECOND SHAPE PARAMETER
C                     --M      = THE THIRD SHAPE PARAMETER
C                     --NTRUNC = THE TRUNCATION POINT
C     OUTPUT ARGUMENTS--PPF    = THE SINGLE PRECISION PERCENT POINT
C                                FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PERCENT POINT FUNCTION
C             VALUE PPF FOR THE TRUNCATED GENERALIZED NEGATIVE
C             BINOMIAL DISTRIBUTION WITH SHAPE PARAMETERS THETA,
C             BETA, M AND NRUNC.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--0 <= P <= 1
C                 --0 < THETA < 1; 1 <= BETA <= 1/THETA; M > 0
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--CONSUL AND FAMOYE (2006), "LAGRANGIAN PROBABILITY
C                 DISTRIBUTIONS", BIRKHAUSER, CHAPTER 10.
C     REFERENCES--CONSUL AND FAMOYE (1993), "THE TRUNCATED
C                 GENERALIZED NEGATIVE BINOMIAL DISTRIBUTION",
C                 JOURNAL OF APPLIED STATISTICAL SCIENCE,
C                 VOL. 1, NO. 2, PP. 141-157.
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
      REAL M
C
C----COMMON-----------------------------------------------------------
C
      INCLUDE 'DPCOMC.INC'
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(NTRUNC.LT.1)THEN
        WRITE(ICOUT,3)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)NTRUNC
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
        GOTO9000
      ENDIF
    3 FORMAT('***** ERROR--THE FIFTH ARGUMENT TO GNTPPF, THE ',
     1      'TRUNCATION POINT, IS LESS THAN 1')
C
      IF(P.LT.0.0 .OR. P.GT.1.0)THEN
        WRITE(ICOUT,4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)P
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
        GOTO9000
      ENDIF
    4 FORMAT('***** ERROR--THE FIRST ARGUMENT TO GNTPPF IS OUTSIDE ',
     1'THE (0,1] INTERVAL')
C
      IF(THETA.LE.0.0 .OR. THETA.GE.1.0)THEN
        WRITE(ICOUT,15)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)THETA
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
        GOTO9000
      ENDIF
   15 FORMAT('***** ERROR--THE SECOND ARGUMENT TO GNTPPF IS NOT IN ',
     1'THE INTERVAL (0,1)')
C
      IF(BETA.LE.1.0 .OR. BETA.GE.1.0/THETA .AND. BETA.NE.0.0)THEN
        WRITE(ICOUT,25)1.0/THETA
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)THETA
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
        GOTO9000
      ENDIF
   25 FORMAT('***** ERROR--THE THIRD ARGUMENT TO GNTPPF IS NOT IN ',
     1'THE INTERVAL (1,',G15.7,')')
C
      IF(M.LE.0.0)THEN
        WRITE(ICOUT,35)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)M
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
        GOTO9000
      ENDIF
   35 FORMAT('***** ERROR--THE FOURTH ARGUMENT TO GNTPPF IS ',
     1'NON-POSITIVE')
      IF(BETA.EQ.0.0)THEN
        IM=INT(M+0.5)
        IF(IM.EQ.0)IM=1
        M=REAL(IM)
      ENDIF
C
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8)
C
      IF(P.EQ.0.0)THEN
        PPF=0.0
        GOTO9000
      ELSEIF(P.EQ.1.0)THEN
        PPF=REAL(NTRUNC)
        GOTO9000
      ENDIF
C
      EPS=1.0E-7
      X=0.0
      CALL GNTCDF(X,THETA,BETA,M,NTRUNC,CDF)
      IF(CDF.GE.P-EPS)THEN
        PPF=0.0
        GOTO9000
      ENDIF
C
      X=1.0
      CALL GNTPDF(X,THETA,BETA,M,NTRUNC,PDF)
      CDF=CDF + PDF
      IF(CDF.GE.P-EPS)THEN
        PPF=1.0
        GOTO9000
      ENDIF
C
      I=1
C
  100 CONTINUE
        I=I+1
        IF(I.GE.NTRUNC)THEN
          PPF=REAL(NTRUNC)
          GOTO9000
        ENDIF
        X=DBLE(I)
        CALL GNTPDF(X,THETA,BETA,M,NTRUNC,PDF)
        CDF=CDF + PDF
C
        IF(CDF.GE.P-EPS)THEN
          PPF=REAL(I)
          GOTO9000
        ENDIF
      GOTO100
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE GNTRAN(N,THETA,BETA,AM,NTRUNC,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE TRUNCATED GENERALIZED NEGATIVE BINOMIAL
C              DISTRIBUTION WITH SHAPE PARAMETERS THETA, BETA, M,
C              AND NTRUNC.
C
C              THE PROBABILITY MASS FUNCTION FOR THE NON-TRUNCATED
C              GENERALIZED NEGATIVE BINOMIAL DISTRIBUTION IS:
C
C              p(X;THETA,BETA,M)=
C                  (M/(M+BETA*X)*
C                  (M+BETA*X  X)*THETA**X*(1-THETA)**(M+BETA*X-X)
C                  X = 0, 1, 2, 3, ,...
C                  0 < THETA < 1; BETA = 0 OR 1 <= BETA <= 1/THETA;
C                  M > 0 (M A POSITIVE INTEGER IF BETA = 0)
C
C              THE TRUNCATED GENERALIZED NEGATIVE BINOMIAL
C              DISTRIBUTION CAN BE DEFINED AS:
C
C              p(X;THETA,BETA,M)/F(NTRUNC,THETA,BETA,M)
C
C              WITH p, F, AND NTRUNC DENOTING THE PROBABILITY
C              MASS AND CUMULATIVE DISTRIBUTION FUNCTION OF
C              THE GENERALIZED NEGATIVE BINOMIAL DISTRIBUTION
C              AND THE TRUNCATION POINT, RESPECTIVELY.
C
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --THETA  = THE SINGLE PRECISION VALUE
C                                OF THE FIRST SHAPE PARAMETER.
C                     --BETA   = THE SINGLE PRECISION VALUE
C                                OF THE SECOND SHAPE PARAMETER.
C                     --AM     = THE SINGLE PRECISION VALUE
C                                OF THE THIRD SHAPE PARAMETER.
C                     --NTRUNC = THE TRUNCATION POINT
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 TRUNCATED GENERALIZED NEGATIVE BINOMIAL
C             DISTRIBUTION WITH SHAPE PARAMETERS THETA, BETA,
C             M, AND NTRUNC.
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 < THETA < 1, 1 < BETA < 1/THETA, M > 0,
C                   NTRUNC >= 1
C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN, GNTPPF
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--CONSUL AND FAMOYE (1993), "THE TRUNCATED
C                 GENERALIZED NEGATIVE BINOMIAL DISTRIBUTION",
C                 JOURNAL OF APPLIED STATISTICAL SCIENCE,
C                 VOL. 1, NO. 2, PP. 141-157.
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
      REAL THETA
      REAL BETA
      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,6)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
    5 FORMAT('***** ERROR--THE REQUESTED NUMBER OF ',
     1'TRUNCATED GENERALIZED NEGATIVE BINOMIAL')
    6 FORMAT('      RANDOM NUMBERS IS NON-POSITIVE')
C
      IF(NTRUNC.LT.1)THEN
        WRITE(ICOUT,3)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)NTRUNC
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ENDIF
    3 FORMAT('***** ERROR--THE TRUNCATION PARAMETER FOR THE ')
    4 FORMAT('      TRUNCATED GENERALIZED NEGATIVE BINOMIAL RANDOM ',
     1       'NUMBERS IS LESS THAN 1')
C
      IF(THETA.LE.0.0 .OR. THETA.GE.1.0)THEN
        WRITE(ICOUT,11)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,12)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)THETA
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
   11 FORMAT('***** ERROR--THE THETA PARAMETER FOR THE ',
     1'TRUNCATED GENERALIZED NEGATIVE BINOMIAL')
   12 FORMAT('      RANDOM NUMBERS IS OUTSIDE THE (0,1) INTERVAL')
C
      IF(BETA.LE.1.0 .OR. BETA.GE.1.0/THETA)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 ',
     1'TRUNCATED GENERALIZED NEGATIVE BINOMIAL')
   22 FORMAT('      RANDOM NUMBERS IS OUTSIDE THE (0,',G15.7,
     1       ') INTERVAL')
C
      IF(AM.LE.0.0)THEN
        WRITE(ICOUT,31)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,32)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)AM
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
   31 FORMAT('***** ERROR--THE M PARAMETER FOR THE ',
     1'TRUNCATED GENERALIZED NEGATIVE BINOMIAL')
   32 FORMAT('      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
C     GENERATE N TRUNCATED GENERALIZED NEGATIVE BINOMIAL DISTRIBUTION
C     RANDOM NUMBERS.
C
      CALL UNIRAN(N,ISEED,X)
      DO100I=1,N
        ZTEMP=X(I)
        CALL GNTPPF(ZTEMP,THETA,BETA,AM,NTRUNC,PPF)
        X(I)=PPF
  100 CONTINUE
C
 9999 CONTINUE
C
      RETURN
      END
      SUBROUTINE GOMCDF(X,C,B,IGOMDF,CDF)
C
C     THIS SUBROUTINE COMPUTES THE GOMPERTZ CUMULATIVE DISTRIBUTION
C     FUNCTION.  THIS IS A TRUNCATED FORM OF THE TYPE 1 EXTREME
C     VALUE DISTRIBUTION.  IT HAS THE FOLLOWING CDF:
C         F(X,C,B) = 1 - EXP(-B*(C**X-1)/LOG(C))    X>=0, B>0, C>=1
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     REFERENCE--"CONTINUOUS UNIVARIATE DISTRIBUTIONS - VOL. 2", 2ND ED
C                JOHNSON, KOTZ, AND BALAKRISHNAN, WILEY, 1994, PP. 25-26
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         --JANUARY   2007. SUPPORT FOR ALTERNATE
C                                       PARAMETERIZATION
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DOUBLE PRECISION DCDF
      DOUBLE PRECISION DC
      DOUBLE PRECISION DB
      DOUBLE PRECISION DK
      DOUBLE PRECISION DALPHA
      DOUBLE PRECISION DX
      DOUBLE PRECISION DTERM1
C
      CHARACTER*4 IGOMDF
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      IF(IGOMDF.EQ.'GARG')GOTO1000
C
      IF(C.LE.1.0)THEN
        WRITE(ICOUT,101)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,103)C
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
      IF(B.LE.0.0)THEN
        WRITE(ICOUT,102)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,103)B
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
      IF(X.LT.0.0)THEN
        WRITE(ICOUT,105)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,103)X
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
  101 FORMAT('***** ERROR--THE SECOND ARGUMENT TO ',
     1       'GOMCDF IS LESS THAN 1.')
  102 FORMAT('***** ERROR--THE THIRD ARGUMENT TO ',
     1       'GOMCDF IS NON-POSITIVE.')
  103 FORMAT('      THE VALUE OF THE ARGUMENT IS ',G15.7)
  105 FORMAT('***** ERROR--THE FIRST ARGUMENT TO ',
     1       'GOMCDF IS NEGATIVE.')
C
      IF(X.LE.0.0)THEN
        CDF=0.0
        GOTO9999
      ENDIF
C
      DX=DBLE(X)
      DC=DBLE(C)
      DB=DBLE(B)
      DTERM1=-DB*(DC**DX - 1.D0)/DLOG(DC)
      IF(DTERM1.GE.80.D0)THEN
        CDF=1.0
        GOTO9999
      ENDIF
      DCDF=1.0D0-DEXP(DTERM1)
      CDF=REAL(DCDF)
      GOTO9999
C
 1000 CONTINUE
C
C     JANUARY 2007: SUPPORT FOR ALTERNATE PARAMETERIZATION
C     THAT HAS THE FOLOWING CDF:
C         F(X,K,ALPHA) = 1 - EXP(-K*(EXP(ALPHA*X)-1)/ALPHA
C
      DX=DBLE(X)
      DK=DBLE(B)
      DALPHA=DBLE(C)
      IF(DALPHA.LE.0.0D0)THEN
        WRITE(ICOUT,1001)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,103)REAL(DALPHA)
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
      IF(DK.LE.0.0D0)THEN
        WRITE(ICOUT,1002)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,103)REAL(DK)
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
      IF(X.LT.0.0)THEN
        WRITE(ICOUT,1005)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,103)X
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
 1001 FORMAT('***** ERROR--THE SECOND ARGUMENT TO ',
     1       'GOMCDF IS NON-POSITIVE.')
 1002 FORMAT('***** ERROR--THE THIRD ARGUMENT TO ',
     1       'GOMCDF IS NON-POSITIVE.')
 1005 FORMAT('***** ERROR--THE FIRST ARGUMENT TO ',
     1       'GOMCDF IS NEGATIVE.')
C
      DTERM1=-DK*(DEXP(DALPHA*DX) - 1.D0)/DALPHA
      IF(DTERM1.GE.80.D0)THEN
        CDF=1.0
        GOTO9999
      ENDIF
      DCDF=1.0D0-DEXP(DTERM1)
      CDF=REAL(DCDF)
      GOTO9999
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE GOMCHA(X,C,B,IGOMDF,CHA)
C
C     THIS SUBROUTINE COMPUTES THE GOMPERTZ CUMULATIVE HAZARD
C     FUNCTION.  THIS IS A TRUNCATED FORM OF THE TYPE 1 EXTREME
C     VALUE DISTRIBUTION.  IT HAS THE FOLLOWING CUMULATIVE HAZARD
C     FUNCTION:
C         H(X,C,B) = B*(C**X-1)/LOG(C))   X>=0, B>0, C>=1
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     REFERENCE--"CONTINUOUS UNIVARIATE DISTRIBUTIONS - VOL. 2", 2ND ED
C                JOHNSON, KOTZ, AND BALAKRISHNAN, WILEY, 1994, PP. 25-26
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         --JANUARY   2007. SUPPORT FOR ALTERNATE
C                                       PARAMETERIZATION
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DOUBLE PRECISION DCHA
      DOUBLE PRECISION DC
      DOUBLE PRECISION DB
      DOUBLE PRECISION DK
      DOUBLE PRECISION DALPHA
      DOUBLE PRECISION DX
C
      CHARACTER*4 IGOMDF
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      IF(IGOMDF.EQ.'GARG')GOTO1000
C
      IF(C.LE.1.0)THEN
        WRITE(ICOUT,101)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,103)C
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
      IF(B.LE.0.0)THEN
        WRITE(ICOUT,102)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,103)B
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
      IF(X.LT.0.0)THEN
        WRITE(ICOUT,105)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,103)X
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
  101 FORMAT('***** ERROR--THE SECOND ARGUMENT TO ',
     1       'GOMCHA IS LESS THAN 1.')
  102 FORMAT('***** ERROR--THE THIRD ARGUMENT TO ',
     1       'GOMCHA IS NON-POSITIVE.')
  103 FORMAT('      THE VALUE OF THE ARGUMENT IS ',G15.7)
  105 FORMAT('***** ERROR--THE FIRST ARGUMENT TO ',
     1       'GOMCHA IS NEGATIVE.')
C
      IF(X.LE.0.0)THEN
        CHA=0.0
        GOTO9999
      ENDIF
C
      DX=DBLE(X)
      DC=DBLE(C)
      DB=DBLE(B)
      DCHA=DB*(DC**DX - 1.D0)/DLOG(DC)
      CHA=REAL(DCHA)
      GOTO9999
C
 1000 CONTINUE
C
C     JANUARY 2007: SUPPORT FOR ALTERNATE PARAMETERIZATION
C     THAT HAS THE FOLOWING CHA:
C         H(X,K,ALPHA) = K*(EXP(ALPHA*X)-1)/ALPHA
C
      DX=DBLE(X)
      DK=DBLE(B)
      DALPHA=DBLE(C)
      IF(DALPHA.LE.0.0D0)THEN
        WRITE(ICOUT,1001)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,103)REAL(DALPHA)
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
      IF(DK.LE.0.0D0)THEN
        WRITE(ICOUT,1002)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,103)REAL(DK)
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
      IF(X.LT.0.0)THEN
        WRITE(ICOUT,1005)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,103)X
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
 1001 FORMAT('***** ERROR--THE SECOND ARGUMENT TO ',
     1       'GOMCHA IS NON-POSITIVE.')
 1002 FORMAT('***** ERROR--THE THIRD ARGUMENT TO ',
     1       'GOMCHA IS NON-POSITIVE.')
 1005 FORMAT('***** ERROR--THE FIRST ARGUMENT TO ',
     1       'GOMCHA IS NEGATIVE.')
C
      DCHA=DK*(DEXP(DALPHA*DX) - 1.D0)/DALPHA
      CHA=REAL(DCHA)
      GOTO9999
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE GOMHAZ(X,C,B,IGOMDF,HAZ)
C
C     THIS SUBROUTINE COMPUTES THE GOMPERTZ HAZARD
C     FUNCTION.  IT HAS THE FOLLOWING HAZARD FUNCTION:
C         h(X,C,B) = B*C**X     X >= 0
C     THIS IS THE PARAMETERIZATION GIVEN ON PAGE 25 OF JOHNSON,
C     KOTZ, AND BALAKRISHNAN.  AN ALTERNATE PARAMETERIZATION IS
C     GIVEN ON PAGE 82:
C         h(X,K,ALPHA) = K*EXP(ALPHA*X)    X >= 0
C     DATAPLOT SUPPORTS BOTH PARAMETERIZATIONS.
C     THEY ARE RELATED BY:
C         ALPHA = LOG(C)
C         K     = B
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     REFERENCE--"CONTINUOUS UNIVARIATE DISTRIBUTIONS - VOL. 2", 2ND ED
C                JOHNSON, KOTZ, AND BALAKRISHNAN, WILEY, 1994, PP. 25-26
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         --JANUARY   2007. SUPPORT ALTERNATE DEFINITION
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DOUBLE PRECISION DHAZ
      DOUBLE PRECISION DC
      DOUBLE PRECISION DB
      DOUBLE PRECISION DK
      DOUBLE PRECISION DALPHA
      DOUBLE PRECISION DX
C
      CHARACTER*4 IGOMDF
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      IF(IGOMDF.EQ.'GARG')GOTO1000
C
      IF(C.LE.1.0 .OR. B.LE.0.0)THEN
        WRITE(ICOUT,101)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,103)C
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
      IF(B.LE.0.0)THEN
        WRITE(ICOUT,102)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,103)B
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
      IF(X.LT.0.0)THEN
        WRITE(ICOUT,105)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,103)X
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
  101 FORMAT('***** ERROR--THE SECOND ARGUMENT TO GOMHAZ ',
     1       'IS LESS THAN 1.')
  102 FORMAT('***** ERROR--THE THIRD INPUT ARGUMENT TO GOMHAZ ',
     1       'IS NON-POSITIVE.')
  103 FORMAT('      THE VALUE OF THE ARGUMENT IS ',G15.7)
  105 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO GOMHAZ ',
     1      'IS NEGATIVE.')
C
      DX=DBLE(X)
      DC=DBLE(C)
      DB=DBLE(B)
      DHAZ=DLOG(DB) + DX*DLOG(DC)
      DHAZ=DEXP(DHAZ)
      HAZ=REAL(DHAZ)
C
      GOTO9999
C
 1000 CONTINUE
      DX=DBLE(X)
      DK=DBLE(B)
      DALPHA=DBLE(C)
C
      IF(X.LT.0.0)THEN
        WRITE(ICOUT,105)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,103)X
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
      IF(DK.LE.0.0D0)THEN
        WRITE(ICOUT,1001)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,103)REAL(DK)
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
      IF(DALPHA.LE.0.0D0)THEN
        WRITE(ICOUT,1002)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,103)REAL(DALPHA)
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
 1001 FORMAT('***** ERROR--THE SECOND ARGUMENT TO GOMHAZ ',
     1       'IS NON-POSITIVE.')
 1002 FORMAT('***** ERROR--THE THIRD ARGUMENT TO GOMHAZ ',
     1       'IS NON-POSITIVE.')
C
      DHAZ=DLOG(DK) + DALPHA*DX
      DHAZ=DEXP(DHAZ)
      HAZ=REAL(DHAZ)
      GOTO9999
C
 9999 CONTINUE
      RETURN
      END
      DOUBLE PRECISION FUNCTION GOMFUN (ALPHAT,X)
C
C     PURPOSE--THIS ROUTINE IS USED IN FINDING THE MAXIMUM LIKELIHOOD
C              ESTIMATE OF ALPHA FOR THE GOMPERTZ DISTRIBUTION.
C              A CONSTANT IN A COMMON BLOCK.
C
C              THE MAXIMUM LIKELIHOOD ESTIMATES ARE:
C
C                  KHAT = D*ALPHAHAT/Q(ALPHAHAT)
C
C              WHERE ALPHAHAT IS THE SOLUTION OF THE EQUATION
C
C                  T + (D/ALPHA) - D*Q'(ALPHA)/Q(ALPHA) = 0
C
C                  N    = THE TOTAL NUMBER OF OBSERVATIONS
C                  d(i) = NUMBER OF FAILURE TIMES IN THE
C                         I-TH INTERVAL
C                  s(i) = NUMBER OF CENSORING TIMES IN I-TH
C                         INTERVAL
C                  t(i) = UPPER END POINT OF I-TH INTERVAL
C                  tau  = MID-POINT OF I-TH INTERVAL
C
C                  T    = SUM[i=1 to p][d(i)*tau(i)]
C                  D    = SUM[i=1 to p][d(i)]
C                  Q(ALPHA)  = SUM[i=1 to p]
C                              [s(i)*(EXP(ALPHA*t(i)) - 1) +
C                              d(i)*(EXP(ALPHA*t(i)) - 1)]
C
C                  Q'   = DERIVATIVE OF Q
C                       = SUM[ALPHA*s(i)*EXP(ALPHA*t(i)) +
C                         ALPHA*d(i)*EXP(ALPHA*t(i))]
C              CALLED BY DFZER2 ROUTINE FOR FINDING THE ROOT OF A
C              FUNCTION.
C
C              NOTE THAT THIS ALGORITHM ASSUMES THE DATA IS
C              GROUPED AND IT ACCOMODATES CENSORED DATA.
C     EXAMPLE--GOMPERTZ MAXIMUM LIKELIHOOD Y
C     REFERENCE--GARG, RAO, AND REDMOND (1970), "MAXIMUM LIKELIHOOD
C                ESTIMATION OF THE PARAMETERS OF THE GOMPERTZ
C                SURVIVAL FUNCTION", APPLIED STATISTICS,
C                PP. 152-159.
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/1
C     ORIGINAL VERSION--JANUARY    2007.
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION ALPHAT
      DOUBLE PRECISION X(*)
C
      INTEGER NTOT,NCLASS
      DOUBLE PRECISION D
      DOUBLE PRECISION T
      DOUBLE PRECISION DQ
      DOUBLE PRECISION DQP
      DOUBLE PRECISION DQPP
      COMMON/GOMCOM/D,T,DQ,DQP,DQPP,NTOT,NCLASS
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DSUM2
      DOUBLE PRECISION DSUM3
      DOUBLE PRECISION DSUM4
      DOUBLE PRECISION DSUM5
      DOUBLE PRECISION DSUM6
      DOUBLE PRECISION DA
      DOUBLE PRECISION DI
      DOUBLE PRECISION SI
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
      DSUM5=0.0D0
      DSUM6=0.0D0
      DA=ALPHAT
C
      DO100I=1,NCLASS
        DI=X(I)
        SI=X(I+25000)
        XLOW=X(I+50000)
        XUPP=X(I+75000)
        TAU=(XLOW+XUPP)/2.0D0
        DSUM1=DSUM1 + SI*(DEXP(DA*XUPP) - 1.0D0)
        DSUM2=DSUM2 + DI*(DEXP(DA*TAU) - 1.0D0)
        DSUM3=DSUM3 + XUPP*SI*DEXP(DA*XUPP)
        DSUM4=DSUM4 + TAU*DI*DEXP(DA*TAU)
        DSUM5=DSUM5 + XUPP*XUPP*SI*DEXP(DA*XUPP)
        DSUM6=DSUM6 + TAU*TAU*DI*DEXP(DA*TAU)
  100 CONTINUE
C
      DQ=DSUM1 + DSUM2
      DQP=DSUM3 + DSUM4
      DQPP=DSUM5 + DSUM6
      GOMFUN=T + (D/DA) - D*DQP/DQ
C
      RETURN
      END
      SUBROUTINE GOMPDF(X,C,B,IGOMDF,PDF)
C
C     THIS SUBROUTINE COMPUTES THE GOMPERTZ CUMULATIVE DISTRIBUTION
C     FUNCTION.  THIS IS A TRUNCATED FORM OF THE TYPE 1 EXTREME
C     VALUE DISTRIBUTION.  IT HAS THE FOLLOWING PDF:
C         F(X,C,B) = B*C**X/EXP(B*(C**X-1)/LOG(C))     X>=0, B>0, C>=1
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     REFERENCE--"CONTINUOUS UNIVARIATE DISTRIBUTIONS - VOL. 2", 2ND ED
C                JOHNSON, KOTZ, AND BALAKRISHNAN, WILEY, 1994, PP. 25-26
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         --JANUARY   2007. SUPPORT ALTERNATE DEFINITION
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DOUBLE PRECISION DPDF
      DOUBLE PRECISION DC
      DOUBLE PRECISION DB
      DOUBLE PRECISION DK
      DOUBLE PRECISION DALPHA
      DOUBLE PRECISION DX
      DOUBLE PRECISION DTERM1, DTERM2, DTERM3
C
      CHARACTER*4 IGOMDF
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      IF(IGOMDF.EQ.'GARG')GOTO1000
C
      IF(C.LE.1.0 .OR. B.LE.0.0)THEN
        WRITE(ICOUT,101)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,103)C
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
      IF(B.LE.0.0)THEN
        WRITE(ICOUT,102)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,103)B
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
      IF(X.LT.0.0)THEN
        WRITE(ICOUT,105)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,103)X
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
  101 FORMAT('***** ERROR--THE SECOND ARGUMENT TO GOMPDF ',
     1       'IS LESS THAN 1.')
  102 FORMAT('***** ERROR--THE THIRD ARGUMENT TO GOMPDF ',
     1       'IS NON-POSITIVE.')
  103 FORMAT('      THE VALUE OF THE ARGUMENT IS ',G15.7)
  105 FORMAT('***** ERROR--THE FIRST ARGUMENT TO GOMPDF ',
     1      'IS NEGATIVE.')
C
      DX=DBLE(X)
      DC=DBLE(C)
      DB=DBLE(B)
      DTERM1=DLOG(DB) + DX*DLOG(DC)
      DTERM2=(DB/DLOG(DC))*(DC**DX-1.0D0)
      DTERM3=DTERM1-DTERM2
      IF(DTERM3.LE.-80.D0)THEN
        PDF=0.0
        GOTO9999
      ELSEIF(DTERM3.GE.80.D0)THEN
        PDF=0.0
        WRITE(ICOUT,401)
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
  401 FORMAT('***** NON-FATAL DIAGNOSTIC FROM GOMPDF.  THE COMPUTED ',
     1'PDF VALUE EXCEEDS MACHINE PRECISION.')
C
      DPDF=DEXP(DTERM3)
      PDF=REAL(DPDF)
C
      GOTO9999
C
C     JANUARY 2007: GARG PARAMETERIZATION IS
C                   K*EXP(ALPHA*X)*EXP(-K*(EXP(ALPHA*X - 1)/ALPHA)
C                   THEY ARE RELATED BY:
C                       ALPHA = LOG(C)
C                       K     = B
C
 1000 CONTINUE
      DX=DBLE(X)
      DALPHA=DBLE(C)
      DK=DBLE(B)
C
      IF(X.LT.0.0)THEN
        WRITE(ICOUT,105)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,103)X
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
      IF(DK.LE.0.0D0)THEN
        WRITE(ICOUT,1001)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,103)REAL(DK)
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
      IF(DALPHA.LE.0.0D0)THEN
        WRITE(ICOUT,1002)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,103)REAL(DALPHA)
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
 1001 FORMAT('***** ERROR--THE SECOND ARGUMENT TO GOMPDF ',
     1       'IS NON-NEGATIVE.')
 1002 FORMAT('***** ERROR--THE THIRD ARGUMENT TO GOMPDF ',
     1       'IS NON-POSITIVE.')
C
      DTERM1=DLOG(DK)
      DTERM2=DALPHA*DX
      DTERM3=-DK*(DEXP(DALPHA*DX) - 1.0D0)/DALPHA
      DPDF=DEXP(DTERM1 + DTERM2 + DTERM3)
      PDF=REAL(DPDF)
      GOTO9999
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE GOMPPF(P,C,B,IGOMDF,PPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE GOMPERTZ PERCENT POINT
C              FUNCTION.  THIS IS A TRUNCATED FORM OF THE TYPE 1
C              EXTREME VALUE DISTRIBUTION.  IT HAS THE FOLLOWING PDF:
C                 F(X,C,B) = B*C**X/EXP(B*(C**X-1)/LOG(C))
C                                                   X>=0, B>0, C>=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                     --C      = THE SINGLE PRECISION VALUE
C                                OF THE FIRST SHAPE PARAMETER.
C                                C SHOULD BE > 1.
C                     --B      = THE SINGLE PRECISION VALUE
C                                OF THE SECOND SHAPE PARAMETER.
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 GOMPERTZ DISTRIBUTION
C             WITH SHAPE PARAMETERS C AND B.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--C SHOULD BE > 1.
C                 --B SHOULD BE POSITIVE.
C                 --P SHOULD BE BETWEEN 0.0 (EXCLUSIVELY)
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     REFERENCE --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--2, 1994, PAGES 25-26.
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/10
C     ORIGINAL VERSION--OCTOBER   1995.
C     UPDATED         --JANUARY   2007. SUPPORT FOR ALTERNATE
C                                       PARAMETERIZATION
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IGOMDF
C
      DOUBLE PRECISION DPPF
      DOUBLE PRECISION DC
      DOUBLE PRECISION DB
      DOUBLE PRECISION DP
      DOUBLE PRECISION DK
      DOUBLE PRECISION DALPHA
      DOUBLE PRECISION DTERM1
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
    1 FORMAT('***** ERROR--THE FIRST ARGUMENT TO ',
     1'GOMPPF IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
C
      IF(IGOMDF.EQ.'GARG')GOTO1000
C
      IF(C.LE.1.0)THEN
        WRITE(ICOUT,101)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)C
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
      IF(B.LE.0.0)THEN
        WRITE(ICOUT,102)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)B
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
  101 FORMAT('***** ERROR--THE SECOND ARGUMENT TO GOMPPF ',
     1       'IS LESS THAN 1.')
  102 FORMAT('***** ERROR--THE THIRD ARGUMENT TO GOMPPF ',
     1       'IS NON-POSITIVE.')
C
      IF(P.EQ.0.0)THEN
        PPF=0.0
        GOTO9999
      ENDIF
C
      DP=DBLE(P)
      DC=DBLE(C)
      DB=DBLE(B)
C
      DTERM1=1.0D0 - DLOG(1.0D0-DP)*DLOG(DC)/DB
      DPPF=DLOG(DTERM1)/DLOG(DC)
      PPF=REAL(DPPF)
      GOTO9999
C
 1000 CONTINUE
C
C     JANUARY 2007: ALTERNATE PARAMETERIZATION
C
      DK=DBLE(B)
      DALPHA=DBLE(C)
      IF(DALPHA.LE.0.0D0)THEN
        WRITE(ICOUT,1001)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)REAL(DALPHA)
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
      IF(DK.LE.0.0D0)THEN
        WRITE(ICOUT,1002)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)REAL(DK)
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
 1001 FORMAT('***** ERROR--THE SECOND ARGUMENT TO GOMPPF ',
     1       'IS NON-POSITIVE.')
 1002 FORMAT('***** ERROR--THE THIRD ARGUMENT TO GOMPPF ',
     1       'IS NON-POSITIVE.')
C
      IF(P.EQ.0.0)THEN
        PPF=0.0
        GOTO9999
      ENDIF
C
      DP=DBLE(P)
C
      DTERM1=1.0D0 - DLOG(1.0D0-DP)*DALPHA/DK
      DPPF=DLOG(DTERM1)/DALPHA
      PPF=REAL(DPPF)
      GOTO9999
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE GOMRAN(N,C,B,IGOMDF,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE GOMPERTZ DISTRIBUTION
C              WITH SHAPE PARAMETER VALUES = C, B.
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --C  = THE SINGLE PRECISION VALUE OF THE
C                                FIRST SHAPE PARAMETER.
C                                C SHOULD BE > 1.
C                     --B  = THE SINGLE PRECISION VALUE OF THE
C                                SECOND SHAPE PARAMETER.
C                                B 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 GOMPERTZ DISTRIBUTION
C             WITH SHAPE PARAMETER VALUES = C AND B.
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                 --C 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.9
C     ORIGINAL VERSION--SEPTEMBER 2001.
C     UPDATED         --JANUARY   2007. ALTERNATE PARAMETERIZATION
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
C
      CHARACTER*4 IGOMDF
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'GOMRAN 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 GOMPERTZ DISTRIBUTION RANDOM NUMBERS
C     USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD.
C
      DO100I=1,N
        CALL GOMPPF(X(I),C,B,IGOMDF,XTEMP)
        X(I)=XTEMP
  100 CONTINUE
C
 9000 CONTINUE
      RETURN
      END
      DOUBLE PRECISION FUNCTION GOODST(XVALUE)
C
C   DESCRIPTION:
C
C      This function calculates the function defined as
C
C        GOODST(x) = {integral 0 to inf} ( exp(-u*u)/(u+x) ) du
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, an error message is printed, and the
C      code returns the value 0.0.
C
C
C   MACHINE-DEPENDENT CONSTANTS:
C
C      NTERM1 - The no. of terms to be used in the array AGOST.
C                The recommended value is such that
C                    AGOST(NTERM1) < EPS/100,
C
C      NTERM2 - The no. of terms to be used in the array AGOSTA.
C                The recommended value is such that
C                    AGOSTA(NTERM2) < EPS/100,
C
C      XLOW - The value below which f(x) = -(gamma/2) - ln(x)
C             to machine precision. The recommended value is
C                EPSNEG
C
C      XHIGH - The value above which f(x) = sqrt(pi)/(2x) to
C              machine precision. The recommended value is
C                 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
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 REVISION:
C                    23 January, 1996
C
C
      INTEGER NTERM1,NTERM2
      DOUBLE PRECISION AGOST(0:28),AGOSTA(0:23),
CCCCC1     CHEVAL,FVAL,GAMBY2,HALF,ONE,ONEHUN,RTPIB2,SIX,
     1     CHEVAL,FVAL,GAMBY2,HALF,ONEHUN,RTPIB2,SIX,
     2     T,TWO,X,XHIGH,XLOW,XVALUE,ZERO
CCCCC CHARACTER FNNAME*6,ERRMSG*15
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOMC.INC'
      INCLUDE 'DPCOP2.INC'
C
CCCCC DATA FNNAME/'GOODST'/
CCCCC DATA ERRMSG/'ARGUMENT <= 0.0'/
CCCCC DATA ZERO,HALF,ONE/ 0.0 D 0 , 0.5 D 0 , 1.0 D 0 /
      DATA ZERO,HALF/ 0.0D0,0.5D0 /
      DATA TWO,SIX/ 2.0 D 0 , 6.0 D 0 /
      DATA ONEHUN/100.0 D 0/
      DATA GAMBY2/0.28860 78324 50766 43030 D 0/
      DATA RTPIB2/0.88622 69254 52758 01365 D 0/
      DATA AGOST(0)/  0.63106 56056 03984 46247  D    0/
      DATA AGOST(1)/  0.25051 73779 32167 08827  D    0/
      DATA AGOST(2)/ -0.28466 20597 90189 40757  D    0/
      DATA AGOST(3)/  0.87615 87523 94862 3552   D   -1/
      DATA AGOST(4)/  0.68260 22672 21252 724    D   -2/
      DATA AGOST(5)/ -0.10811 29544 19225 4677   D   -1/
      DATA AGOST(6)/  0.16910 12441 17152 176    D   -2/
      DATA AGOST(7)/  0.50272 98462 26151 86     D   -3/
      DATA AGOST(8)/ -0.18576 68720 41000 84     D   -3/
      DATA AGOST(9)/ -0.42870 36741 68474        D   -5/
      DATA AGOST(10)/ 0.10095 98903 20290 5      D   -4/
      DATA AGOST(11)/-0.86529 91351 7382         D   -6/
      DATA AGOST(12)/-0.34983 87432 0734         D   -6/
      DATA AGOST(13)/ 0.64832 78683 494          D   -7/
      DATA AGOST(14)/ 0.75759 24985 83           D   -8/
      DATA AGOST(15)/-0.27793 54243 62           D   -8/
      DATA AGOST(16)/-0.48302 35135              D  -10/
      DATA AGOST(17)/ 0.86632 21283              D  -10/
      DATA AGOST(18)/-0.39433 9687               D  -11/
      DATA AGOST(19)/-0.20952 9625               D  -11/
      DATA AGOST(20)/ 0.21501 759                D  -12/
      DATA AGOST(21)/ 0.39590 15                 D  -13/
      DATA AGOST(22)/-0.69227 9                  D  -14/
      DATA AGOST(23)/-0.54829                    D  -15/
      DATA AGOST(24)/ 0.17108                    D  -15/
      DATA AGOST(25)/ 0.376                      D  -17/
      DATA AGOST(26)/-0.349                      D  -17/
      DATA AGOST(27)/ 0.7                        D  -19/
      DATA AGOST(28)/ 0.6                        D  -19/
      DATA AGOSTA(0)/  1.81775 46798 47187 58767  D    0/
      DATA AGOSTA(1)/ -0.99211 46570 74409 7467   D   -1/
      DATA AGOSTA(2)/ -0.89405 86452 54819 243    D   -2/
      DATA AGOSTA(3)/ -0.94955 33127 77267 85     D   -3/
      DATA AGOSTA(4)/ -0.10971 37996 67596 65     D   -3/
      DATA AGOSTA(5)/ -0.13466 94539 57859 0      D   -4/
      DATA AGOSTA(6)/ -0.17274 92743 08265        D   -5/
      DATA AGOSTA(7)/ -0.22931 38019 9498         D   -6/
      DATA AGOSTA(8)/ -0.31278 44178 918          D   -7/
      DATA AGOSTA(9)/ -0.43619 79736 71           D   -8/
      DATA AGOSTA(10)/-0.61958 46474 3            D   -9/
      DATA AGOSTA(11)/-0.89379 91276              D  -10/
      DATA AGOSTA(12)/-0.13065 11094              D  -10/
      DATA AGOSTA(13)/-0.19316 6876               D  -11/
      DATA AGOSTA(14)/-0.28844 270                D  -12/
      DATA AGOSTA(15)/-0.43447 96                 D  -13/
      DATA AGOSTA(16)/-0.65951 8                  D  -14/
      DATA AGOSTA(17)/-0.10080 1                  D  -14/
      DATA AGOSTA(18)/-0.15502                    D  -15/
      DATA AGOSTA(19)/-0.2397                     D  -16/
      DATA AGOSTA(20)/-0.373                      D  -17/
      DATA AGOSTA(21)/-0.58                       D  -18/
      DATA AGOSTA(22)/-0.9                        D  -19/
      DATA AGOSTA(23)/-0.1                        D  -19/
C
      XLOW = 0.0
      XHIGH = 0.0
C
C   Start computation
C
      X = XVALUE
C
C   Error test
C
      IF ( X .LE. ZERO ) THEN
CCCCC    CALL ERRPRN(FNNAME,ERRMSG)
         WRITE(ICOUT,999)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,101)X
         CALL DPWRST('XXX','BUG ')
         GOODST = ZERO
         RETURN
      ENDIF
  999 FORMAT(1X)
  101 FORMAT('***** ERROR FROM GOODST--ARGUMENT MUST BE ',
     1       'POSITIVE, ARGUMENT = ',G15.7)
C
C   Compute the machine-dependent constants.
C
      FVAL = D1MACH(3)
      T = FVAL / ONEHUN
      IF ( X .LE. TWO ) THEN
         DO 10 NTERM1 = 28 , 0 , -1
            IF ( ABS(AGOST(NTERM1)) .GT. T ) GOTO 19
 10      CONTINUE
 19      XLOW = FVAL
      ELSE
         DO 40 NTERM2 = 23 , 0 , -1
            IF ( ABS(AGOSTA(NTERM2)) .GT. T ) GOTO 49
 40      CONTINUE
 49      XHIGH = TWO / FVAL
      ENDIF
C
C   Computation for 0 < x <= 2
C
      IF ( X .LE. TWO ) THEN
         IF ( X .LT. XLOW ) THEN
            GOODST = - GAMBY2 - LOG(X)
         ELSE
            T = ( X - HALF ) - HALF
            GOODST = CHEVAL(NTERM1,AGOST,T) - EXP(-X*X) * LOG(X)
         ENDIF
      ELSE
C
C   Computation for x > 2
C
         FVAL = RTPIB2 / X
         IF ( X .GT. XHIGH ) THEN
            GOODST = FVAL
         ELSE
            T = ( SIX - X ) / ( TWO + X )
            GOODST = FVAL * CHEVAL(NTERM2,AGOSTA,T)
         ENDIF
      ENDIF
      RETURN
      END
      DOUBLE PRECISION FUNCTION GR1FUN (DA)
C
C     PURPOSE--THIS ROUTINE IS USED IN FINDING THE CDF VALUE FOR THE
C              GRUBBS TEST.
C
C              CALLED BY DFZERO ROUTINE FOR FINDING THE ROOT OF A
C              FUNCTION.  DFZERO IS CALLED BY DPGRU2.
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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2019/10
C     ORIGINAL VERSION--OCTOBER    2019.
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DA
C
      COMMON/GR1COM/AFACT,STATV2,ANU,N
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C  COMPUTE SOME SUMS
C
      NM2=N-2
      ALPHAT=REAL(1.0D0 - DA)
      P2=1.0 - (ALPHAT/REAL(N))/AFACT
      CALL TPPF(P2,REAL(NM2),T)
      AVAL=(REAL(N-1)/SQRT(REAL(N)))*SQRT(T*T/(REAL(NM2)+T*T))
      GR1FUN=STATV2 - AVAL
C
      RETURN
      END
      DOUBLE PRECISION FUNCTION GR2FUN (DA)
C
C     PURPOSE--THIS ROUTINE IS USED IN FINDING THE CDF VALUE FOR THE
C              GRUBBS TEST.
C
C              CALLED BY DFZERO ROUTINE FOR FINDING THE ROOT OF A
C              FUNCTION.  DFZERO IS CALLED BY DPGRU2.
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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2019/10
C     ORIGINAL VERSION--OCTOBER    2019.
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DA
C
      COMMON/GR1COM/AFACT,STATV2,ANU,N
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C  COMPUTE SOME SUMS
C
      ALPHAT=REAL(1.0D0 - DA)
      P2=1.0 - (ALPHAT/REAL(N))/AFACT
      CALL TPPF(P2,ANU,T)
      AVAL=T*SQRT(1.0 - 1.0/REAL(N))
      GR2FUN=STATV2 - AVAL
C
      RETURN
      END
      SUBROUTINE grat1(a,x,r,p,q,eps)
C     .. Scalar Arguments ..
      DOUBLE PRECISION a,eps,p,q,r,x
C     ..
C     .. Local Scalars ..
      DOUBLE PRECISION a2n,a2nm1,am0,an,an0,b2n,b2nm1,c,cma,g,h,j,l,sum,
     +                 t,tol,w,z
C     ..
C     .. External Functions ..
CCCCC DOUBLE PRECISION erf,erfc1,gam1,rexp
CCCCC EXTERNAL erf,erfc1,gam1,rexp
      DOUBLE PRECISION erfdp,erfc1,gam1,rexp
      EXTERNAL erfdp,erfc1,gam1,rexp
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC abs,dlog,exp,sqrt
C     ..
C     .. Executable Statements ..
C-----------------------------------------------------------------------
C        EVALUATION OF THE INCOMPLETE GAMMA RATIO FUNCTIONS
C                      P(A,X) AND Q(A,X)
C
C     IT IS ASSUMED THAT A .LE. 1.  EPS IS THE TOLERANCE TO BE USED.
C     THE INPUT ARGUMENT R HAS THE VALUE E**(-X)*X**A/GAMMA(A).
C-----------------------------------------------------------------------
      IF (a*x.EQ.0.0D0) GO TO 120
      IF (a.EQ.0.5D0) GO TO 100
      IF (x.LT.1.1D0) GO TO 10
      GO TO 60
C
C             TAYLOR SERIES FOR P(A,X)/X**A
C
   10 an = 3.0D0
      c = x
      sum = x/ (a+3.0D0)
      tol = 0.1D0*eps/ (a+1.0D0)
   20 an = an + 1.0D0
      c = -c* (x/an)
      t = c/ (a+an)
      sum = sum + t
      IF (abs(t).GT.tol) GO TO 20
      j = a*x* ((sum/6.0D0-0.5D0/ (a+2.0D0))*x+1.0D0/ (a+1.0D0))
C
      z = a*dlog(x)
      h = gam1(a)
      g = 1.0D0 + h
      IF (x.LT.0.25D0) GO TO 30
      IF (a.LT.x/2.59D0) GO TO 50
      GO TO 40

   30 IF (z.GT.-.13394D0) GO TO 50
C
   40 w = exp(z)
      p = w*g* (0.5D0+ (0.5D0-j))
      q = 0.5D0 + (0.5D0-p)
      RETURN
C
   50 l = rexp(z)
      w = 0.5D0 + (0.5D0+l)
      q = (w*j-l)*g - h
      IF (q.LT.0.0D0) GO TO 90
      p = 0.5D0 + (0.5D0-q)
      RETURN
C
C              CONTINUED FRACTION EXPANSION
C
   60 a2nm1 = 1.0D0
      a2n = 1.0D0
      b2nm1 = x
      b2n = x + (1.0D0-a)
      c = 1.0D0
   70 a2nm1 = x*a2n + c*a2nm1
      b2nm1 = x*b2n + c*b2nm1
      am0 = a2nm1/b2nm1
      c = c + 1.0D0
      cma = c - a
      a2n = a2nm1 + cma*a2n
      b2n = b2nm1 + cma*b2n
      an0 = a2n/b2n
      IF (abs(an0-am0).GE.eps*an0) GO TO 70
      q = r*an0
      p = 0.5D0 + (0.5D0-q)
      RETURN
C
C                SPECIAL CASES
C
   80 p = 0.0D0
      q = 1.0D0
      RETURN
C
   90 p = 1.0D0
      q = 0.0D0
      RETURN
C
  100 IF (x.GE.0.25D0) GO TO 110
      p = erfdp(sqrt(x))
      q = 0.5D0 + (0.5D0-p)
      RETURN

  110 q = erfc1(0,sqrt(x))
      p = 0.5D0 + (0.5D0-q)
      RETURN
C
  120 IF (x.LE.a) GO TO 80
      GO TO 90

      END
      SUBROUTINE GRDEP2(X1,Y1,X2,Y2,DEL,X3,Y3,X4,Y4)
C
C     PURPOSE--GIVEN THE LINE SEGMENT FROM (X1,Y1) TO (X2,Y2)
C              DETERMINE THE COORDINATES (X3,Y3) AND X4,Y4)
C              OF A PARALLEL LINE SEGMENT AT A DISTANCE OF DEL UNITS
C              AWAY (ORTHOGONALLY) IN A COUNTER-CLOCKWISE ANGLE.
C
      DELX=X2-X1
      DELY=Y2-Y1
      RSQ=DELX**2+DELY**2
C
      R=0.0
      IF(RSQ.GT.0.0)R=SQRT(RSQ)
C
      FACTOR=0.0
      IF(R.GT.0.0)FACTOR=DEL/R
C
      DELX2=FACTOR*DELY
      DELY2=FACTOR*DELX
C
      X3=X1-DELX2
      Y3=Y1+DELY2
C
      X4=X2-DELX2
      Y4=Y2+DELY2
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
      RETURN
      END
      SUBROUTINE GPAFUN (N, X, FVEC, IFLAG, XDATA, NOBS)
C
C     PURPOSE--THIS ROUTINE COMPUTES THE FUNCTIONS FOR THE
C              GENERALIZED PARETO MAXIMUM LIKELIHOOD EQUATIONS.
C
C              [1 + (1/N)*SUM[i=1 to N][LOG(1 - Chat*X(i)/Khat]*
C                 [(1/N)*SUM[i=1 to N][1/(1 + Chat*X(i)/Khat)] - 1 = 0
C                 SUM[I=1 TO N][LOG((X(I)-A)/(B-A))] = 0
C
C              Chat + (1/N)*SUM[i=1 to N][LOG(1 - Chat*X(i)/Khat] = 0
C
C              WITH C AND K DENOTING THE SHAPE PARAMETERS,
C              RESPECTIVELY.
C
C              NOTE THAT MAXIMUM LIKELIHOOD ESTIMATION ONLY WORKS
C              WELL IF C < 1/2.
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--GENERALIZED PARETO MAXIMUM LIKELIHOOD Y
C     REFERENCE--JOHNSON, KOTZ, AND BALAKRISHNAN (1994).  "CONTINUOUS
C                UNIVARIATE DISTRIBUTIONS: VOLUME 1", SECOND EDITION,
C                JOHN WILEY, PP. 614-619.
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--2003/11
C     ORIGINAL VERSION--NOVEMBER  2003.
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION X(*)
      DOUBLE PRECISION FVEC(*)
      REAL XDATA(*)
C
      DOUBLE PRECISION DN
      DOUBLE PRECISION DX
      DOUBLE PRECISION DC
      DOUBLE PRECISION DK
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DSUM2
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C  COMPUTE SOME SUMS
C
      N=2
      IFLAG=0
C
      DC=X(1)
      DK=X(2)
      DN=DBLE(NOBS)
C
      DSUM1=0.0D0
      DSUM2=0.0D0
C
      DO200I=1,NOBS
        DX=DBLE(XDATA(I))
        DSUM1=DSUM1 + DLOG(1.0D0 - DC*DX/DK)
        DSUM2=DSUM2 + 1.0D0/(1.0D0 + DC*DX/DK)
  200 CONTINUE
C
      FVEC(1)=(1.0D0 + (1.0D0/DN)*DSUM1)*((1.0D0/DN)*DSUM2) - 1.0D0
      FVEC(2)=DC + (1.0D0/DN)*DSUM1
C
      RETURN
      END
      SUBROUTINE GRDEPL(PX,PY,NP,DEL,PX3,PY3,NP3)
C
C     PURPOSE--DETERMINE COORDINATES OF TRACE PARALLEL
C              TO TRACE IN (PX(.),PY(.)) AT AN
C              ORTHOGONAL DISTANCE OF DEL UNITS (0.0 TO 100.0)
C
C     UPDATED--MAY 1989 INCREASE THE DIMENSION CHECK FOR ARRAYS
C     UPDATED         --JUNE      1990. TEMPORARY ARRAYS TO GARBAGE COMMON
C     UPDATED         --SEPTEMBER 1993. DO DEGENERATE (NP = 1) CASE
C     UPDATED         --JULY      2019. TWEAK SCRATCH STORAGE
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOPA.INC'
C
      DIMENSION PX(*)
      DIMENSION PY(*)
      DIMENSION PX3(*)
      DIMENSION PY3(*)
C
      DIMENSION PXPRE(MAXPOP)
      DIMENSION PYPRE(MAXPOP)
C
      DIMENSION PXPOST(MAXPOP)
      DIMENSION PYPOST(MAXPOP)
      INCLUDE 'DPCOZZ.INC'
      EQUIVALENCE (GARBAG(IGARG6),PXPRE(1))
      EQUIVALENCE (GARBAG(IGARG7),PYPRE(1))
      EQUIVALENCE (GARBAG(IGARG8),PXPOST(1))
      EQUIVALENCE (GARBAG(IGARG9),PYPOST(1))
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOBE.INC'
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DEPL')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF GRDEPL--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)DEL
   52 FORMAT('DEL = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,54)NP
   54 FORMAT('NP = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO55I=1,NP
      WRITE(ICOUT,56)I,PX(I),PY(I)
   56 FORMAT('I,PX(I),PY(I) = ',
     1I8,2E15.7)
      CALL DPWRST('XXX','BUG ')
   55 CONTINUE
      WRITE(ICOUT,59)IBUGG4,ISUBG4,IERRG4
   59 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
   90 CONTINUE
C
CCCCC THE FOLLOWING 6 LINES WERE ADDED          SEPTEMBER 1993
CCCCC TO HANDLE THE DEGENERATE NP = 1 CASE      SEPTEMBER 1993
      IF(NP.LE.1)THEN
         PX3(1)=PX(1)
         PY3(1)=PY(1)
         NP3=NP
         GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING LINE WAS REPLACED MAY 1989
CCCCC BY THE SUCCEEDING LINE          MAY 1989
CCCCC IF(NP.LE.1000)GOTO1090
      IF(NP.LE.MAXPOP)GOTO1090
      WRITE(ICOUT,1011)
 1011 FORMAT('***** ERROR IN GRDEPL--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1012)
 1012 FORMAT('      NP HAS JUST EXCEEDED ARRAY DIMENSION')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1013)NP
 1013 FORMAT('      NP = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1014)
 1014 FORMAT('      FIX DIMENSION OF ARRAYS IN GRDEPL')
      CALL DPWRST('XXX','BUG ')
      IERRG4='YES'
      GOTO9000
 1090 CONTINUE
C
      NPM1=NP-1
      DO1100I=1,NPM1
      IP1=I+1
      X1=PX(I)
      Y1=PY(I)
      X2=PX(IP1)
      Y2=PY(IP1)
      CALL GRDEP2(X1,Y1,X2,Y2,DEL,X3,Y3,X4,Y4)
      PXPOST(I)=X3
      PYPOST(I)=Y3
      PXPRE(IP1)=X4
      PYPRE(IP1)=Y4
 1100 CONTINUE
      PXPOST(NP)=PXPRE(NP)
      PYPOST(NP)=PYPRE(NP)
      PXPRE(1)=PXPOST(1)
      PYPRE(1)=PYPOST(1)
C
C               ******************************************
C               **  STEP XX--                           **
C               **  TREAT THE INTERMEDIATE POINTS CASE  **
C               ******************************************
C
      DO1200I=2,NPM1
      IM1=I-1
      IP1=I+1
C
      DELX1=PX(I)-PX(IM1)
      DELY1=PY(I)-PY(IM1)
      IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'DEPL')
     1WRITE(ICOUT,1111)I,IM1,PX(IM1),PX(I)
 1111 FORMAT('I,IM1,PX(IM1),PX(I) = ',2I8,2E15.7)
      IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'DEPL')
     1CALL DPWRST('XXX','BUG ')
      SLOPE1=CPUMAX
      IF(ABS(DELX1).GE.0.000001)SLOPE1=DELY1/DELX1
      IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'DEPL')
     1WRITE(ICOUT,1112)DELX1,SLOPE1
 1112 FORMAT('DELX1,SLOPE1 = ',2E15.7)
      IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'DEPL')
     1CALL DPWRST('XXX','BUG ')
C
      DELX2=PX(IP1)-PX(I)
      DELY2=PY(IP1)-PY(I)
      IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'DEPL')
     1WRITE(ICOUT,1121)I,IP1,PX(I),PX(IP1)
 1121 FORMAT('I,IP1,PX(I),PX(IP1) = ',2I8,2E15.7)
      IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'DEPL')
     1CALL DPWRST('XXX','BUG ')
      SLOPE2=CPUMAX
      IF(ABS(DELX2).GE.0.000001)SLOPE2=DELY2/DELX2
      IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'DEPL')
     1WRITE(ICOUT,1122)DELX2,SLOPE2
 1122 FORMAT('DELX2,SLOPE2 = ',2E15.7)
      IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'DEPL')
     1CALL DPWRST('XXX','BUG ')
C
      IF(SLOPE1.EQ.SLOPE2)GOTO1210
      GOTO1220
C
 1210 CONTINUE
      PX3(I)=PXPRE(I)
      PY3(I)=PYPRE(I)
      GOTO1200
C
 1220 CONTINUE
      IF(SLOPE1.EQ.CPUMAX)GOTO1221
      IF(SLOPE2.EQ.CPUMAX)GOTO1222
      GOTO1223
 1221 CONTINUE
      PX3(I)=PXPRE(I)
      PY3(I)=PYPOST(I)
      GOTO1229
 1222 CONTINUE
      PX3(I)=PXPOST(I)
      PY3(I)=PYPRE(I)
      GOTO1229
 1223 CONTINUE
      DENOM=SLOPE2-SLOPE1
      ANUM=PYPRE(I)-PYPOST(I)-SLOPE1*PXPRE(I)+SLOPE2*PXPOST(I)
      IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'DEPL')
     1WRITE(ICOUT,1224)SLOPE1,SLOPE2,DENOM
 1224 FORMAT('SLOPE1,SLOPE2,DENOM = ',3E15.7)
      IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'DEPL')
     1CALL DPWRST('XXX','BUG ')
      PX3(I)=ANUM/DENOM
      PY3(I)=PYPRE(I)+SLOPE1*(PX3(I)-PXPRE(I))
 1229 CONTINUE
C
 1200 CONTINUE
C
C               *******************************************
C               **  STEP XX--                            **
C               **  TREAT THE FIRST AND LAST POINT CASE  **
C               *******************************************
C
      IF(PX(1).EQ.PX(NP).AND.PY(1).EQ.PY(NP))GOTO2100
      PX3(1)=PXPOST(1)
      PY3(1)=PYPOST(1)
      PX3(NP)=PXPRE(NP)
      PY3(NP)=PYPRE(NP)
      GOTO2900
C
 2100 CONTINUE
      NPM1=NP-1
      DELX1=PX(NP)-PX(NPM1)
      DELY1=PY(NP)-PY(NPM1)
      IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'DEPL')
     1WRITE(ICOUT,2111)NPM1,NP,PX(NPM1),PX(NP)
 2111 FORMAT('NPM1,NP,PX(NPM1),PX(NP) = ',2I8,2E15.7)
      IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'DEPL')
     1CALL DPWRST('XXX','BUG ')
      SLOPE1=CPUMAX
      IF(ABS(DELX1).GE.0.000001)SLOPE1=DELY1/DELX1
      IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'DEPL')
     1WRITE(ICOUT,2112)DELX1,SLOPE1
 2112 FORMAT('DELX1,SLOPE1 = ',2E15.7)
      IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'DEPL')
     1CALL DPWRST('XXX','BUG ')
C
      I=1
      IP1=I+1
      DELX2=PX(IP1)-PX(I)
      DELY2=PY(IP1)-PY(I)
      IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'DEPL')
     1WRITE(ICOUT,2121)I,IP1,PX(I),PX(IP1)
 2121 FORMAT('I,IP1,PX(I),PX(IP1) = ',2I8,2E15.7)
      IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'DEPL')
     1CALL DPWRST('XXX','BUG ')
      SLOPE2=CPUMAX
      IF(ABS(DELX2).GE.0.000001)SLOPE2=DELY2/DELX2
      IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'DEPL')
     1WRITE(ICOUT,2122)DELX2,SLOPE2
 2122 FORMAT('DELX2,SLOPE2 = ',2E15.7)
      IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'DEPL')
     1CALL DPWRST('XXX','BUG ')
C
      IF(SLOPE1.EQ.SLOPE2)GOTO2210
      GOTO2220
C
 2210 CONTINUE
      PX3(1)=PXPRE(NP)
      PY3(1)=PYPRE(NP)
      PX3(NP)=PX3(1)
      PY3(NP)=PY3(1)
      GOTO2200
C
 2220 CONTINUE
      IF(SLOPE1.EQ.CPUMAX)GOTO2221
      IF(SLOPE2.EQ.CPUMAX)GOTO2222
      GOTO2223
 2221 CONTINUE
      PX3(1)=PXPRE(NP)
      PY3(1)=PYPOST(1)
      PX3(NP)=PX3(1)
      PY3(NP)=PY3(1)
      GOTO2229
 2222 CONTINUE
      PX3(1)=PXPOST(1)
      PY3(1)=PYPRE(NP)
      PX3(NP)=PX3(1)
      PY3(NP)=PY3(1)
      GOTO2229
 2223 CONTINUE
      DENOM=SLOPE2-SLOPE1
      ANUM=PYPRE(1)-PYPOST(1)-SLOPE1*PXPRE(1)+SLOPE2*PXPOST(1)
      IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'DEPL')
     1WRITE(ICOUT,2224)SLOPE1,SLOPE2,DENOM
 2224 FORMAT('SLOPE1,SLOPE2,DENOM = ',3E15.7)
      IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'DEPL')
     1CALL DPWRST('XXX','BUG ')
      PX3(1)=ANUM/DENOM
      PY3(1)=PYPRE(1)+SLOPE1*(PX3(1)-PXPRE(1))
      PX3(NP)=PX3(1)
      PY3(NP)=PY3(1)
 2229 CONTINUE
C
 2200 CONTINUE
C
 2900 CONTINUE
      NP3=NP
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DEPL')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF GRDEPL--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)DEL
 9012 FORMAT('DEL = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9014)NP
 9014 FORMAT('NP = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO9015I=1,NP
      WRITE(ICOUT,9016)I,PXPRE(I),PYPRE(I),PXPOST(I),PYPOST(I)
 9016 FORMAT('I,PXPRE(I),PYPRE(I),PXPOST(I),PYPOST(I) = ',
     1I8,4E15.7)
      CALL DPWRST('XXX','BUG ')
 9015 CONTINUE
      DO9025I=1,NP
      WRITE(ICOUT,9026)I,PX(I),PY(I),PX3(I),PY3(I)
 9026 FORMAT('I,PX(I),PY(I),PX3(I),PY3(I) = ',
     1I8,4E15.7)
      CALL DPWRST('XXX','BUG ')
 9025 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 GRDETL(ICTEXT,NCTEXT,
     1IFONT,IDIR,ANGLE,
     1JFONT,JDIR,ANGLE2,
     1PHEIGH,PWIDTH,PVEGAP,PHOGAP,
     1JSIZE,
     1JHEIG2,JWIDT2,JVEGA2,JHOGA2,
     1PHEIG2,PWIDT2,PVEGA2,PHOGA2,
     1PXLEC,PXLECG,PYLEC,PYLECG)
C
C     PURPOSE--FOR A SPECIFIC GRAPHICS DEVICE,
C              AND FOR A GIVEN FONT AND DIRECTION,
C              DETERMINE THE LENGTH OF THE TEXT STRING IN THE
C              CHARACTER VECTOR ICTEXT(.),
C              WHICH CONSISTS OF NCTEXT CHARACTERS.
C     NOTE--THE LEGNTH IS IN STANDARDIZED COORDINATES
C           THAT IS, 0.0 TO 100.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-921-3651
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)--MAY       1983.
C
C-----NON-COMMON VARIABLES (GRAPHICS)-------------------------------------------
C
C
      CHARACTER*4 ICTEXT
      CHARACTER*4 IFONT
      CHARACTER*4 IDIR
C
      DIMENSION ICTEXT(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOGR.INC'
      INCLUDE 'DPCOBE.INC'
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DETL')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF GRDETL--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,54)NCTEXT
   54 FORMAT('NCTEXT = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,55)(ICTEXT(I),I=1,MIN(25,NCTEXT))
   55 FORMAT('(ICTEXT(I),I=1,NCTEXT) = ',25A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,61)IFONT,JFONT
   61 FORMAT('IFONT,JFONT= ',A4,I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,62)IDIR,JDIR
   62 FORMAT('IDIR,JDIR= ',A4,I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,64)ANGLE,ANGLE2
   64 FORMAT('ANGLE,ANGLE2= ',E15.7,E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,67)PHEIGH,JHEIG2,PHEIG2
   67 FORMAT('PHEIGH,JHEIG2,PHEIG2= ',E15.7,I8,E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,68)PWIDTH,JWIDT2,PWIDT2
   68 FORMAT('PWIDTH,JWIDT2,PWIDT2= ',E15.7,I8,E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,69)PVEGAP,JVEGA2,PVEGA2
   69 FORMAT('PVEGAP,JVEGA2,PVEGA2= ',E15.7,I8,E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,70)PHOGAP,JHOGA2,PHOGA2
   70 FORMAT('PHOGAP,JHOGA2,PHOGA2= ',E15.7,I8,E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,71)JSIZE
   71 FORMAT('JSIZE= ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,73)PXLEC,PXLECG
   73 FORMAT('PXLEC,PXLECG= ',E15.7,E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,74)PYLEC,PYLECG
   74 FORMAT('PYLEC,PYLECG= ',E15.7,E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,79)IBUGG4,ISUBG4,IERRG4
   79 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
   90 CONTINUE
C
C               *********************************
C               **  STEP 1--                   **
C               **  CALL THE APPROPRIATE CASE  **
C               **  AS DICTATED BY THE         **
C               **  FONT AND DIRECTION         **
C               *********************************
C
      IF(IFONT.EQ.'TEKT')GOTO1100
      GOTO1200
C
C               ****************************************
C               **  STEP 2--                          **
C               **  TREAT THE DEFAULT FONT            **
C               **  (= TEKTRONIX HARDWARE-GENERATED)  **
C               ****************************************
C
 1100 CONTINUE
      IF(IDIR.EQ.'HORI')GOTO1110
      IF(IDIR.EQ.'VERT')GOTO1120
      GOTO1130
C
C               **************************************
C               **  STEP 2.1--                      **
C               **  TREAT THE HORIZONTAL DIRECTION  **
C               **************************************
C
 1110 CONTINUE
      CALL GRDETH(ICTEXT,NCTEXT,
     1IFONT,IDIR,ANGLE,
     1JFONT,JDIR,ANGLE2,
     1PHEIGH,PWIDTH,PVEGAP,PHOGAP,
     1JSIZE,
     1JHEIG2,JWIDT2,JVEGA2,JHOGA2,
     1PHEIG2,PWIDT2,PVEGA2,PHOGA2,
     1PXLEC,PXLECG,PYLEC,PYLECG)
      GOTO9000
C
C               ************************************
C               **  STEP 2.2--                    **
C               **  TREAT THE VERTICAL DIRECTION  **
C               ************************************
C
 1120 CONTINUE
      CALL GRDETV(ICTEXT,NCTEXT,
     1IFONT,IDIR,ANGLE,
     1JFONT,JDIR,ANGLE2,
     1PHEIGH,PWIDTH,PVEGAP,PHOGAP,
     1JSIZE,
     1JHEIG2,JWIDT2,JVEGA2,JHOGA2,
     1PHEIG2,PWIDT2,PVEGA2,PHOGA2,
     1PXLEC,PXLECG,PYLEC,PYLECG)
      GOTO9000
C
C               ***********************************
C               **  STEP 2.3--                   **
C               **  TREAT THE GENERAL DIRECTION  **
C               ***********************************
C
 1130 CONTINUE
      GOTO9000
C
C               ******************************
C               **  STEP 3--                **
C               **  TREAT THE GENERAL FONT  **
C               **  (SOFTWARE-GENERATED)    **
C               ******************************
C
 1200 CONTINUE
      IF(IDIR.EQ.'HORI')GOTO1210
      IF(IDIR.EQ.'VERT')GOTO1220
      GOTO1230
C
C               **************************************
C               **  STEP 3.1--                      **
C               **  TREAT THE HORIZONTAL DIRECTION  **
C               **************************************
C
 1210 CONTINUE
CCCCC CALL GRDETG(ICTEXT,NCTEXT,
CCCCC1IFONT,IDIR,ANGLE,
CCCCC1JFONT,JDIR,ANGLE2,
CCCCC1PHEIGH,PWIDTH,PVEGAP,PHOGAP,
CCCCC1JSIZE,
CCCCC1JHEIG2,JWIDT2,JVEGA2,JHOGA2,
CCCCC1PHEIG2,PWIDT2,PVEGA2,PHOGA2,
CCCCC1PXLEC,PXLECG,PYLEC,PYLECG)
      GOTO9000
C
C               ************************************
C               **  STEP 3.2--                    **
C               **  TREAT THE VERTICAL DIRECTION  **
C               ************************************
C
 1220 CONTINUE
CCCCC CALL GRDETG(ICTEXT,NCTEXT,
CCCCC1IFONT,IDIR,ANGLE,
CCCCC1JFONT,JDIR,ANGLE2,
CCCCC1PHEIGH,PWIDTH,PVEGAP,PHOGAP,
CCCCC1JSIZE,
CCCCC1JHEIG2,JWIDT2,JVEGA2,JHOGA2,
CCCCC1PHEIG2,PWIDT2,PVEGA2,PHOGA2,
CCCCC1PXLEC,PXLECG,PYLEC,PYLECG)
      GOTO9000
C
C               ***********************************
C               **  STEP 3.3--                   **
C               **  TREAT THE GENERAL DIRECTION  **
C               ***********************************
C
 1230 CONTINUE
CCCCC CALL GRDETG(ICTEXT,NCTEXT,
CCCCC1IFONT,IDIR,ANGLE,
CCCCC1JFONT,JDIR,ANGLE2,
CCCCC1PHEIGH,PWIDTH,PVEGAP,PHOGAP,
CCCCC1JSIZE,
CCCCC1JHEIG2,JWIDT2,JVEGA2,JHOGA2,
CCCCC1PHEIG2,PWIDT2,PVEGA2,PHOGA2,
CCCCC1PXLEC,PXLECG,PYLEC,PYLECG)
      GOTO9000
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DETL')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF GRDETL--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9033)PXLEC,PXLECG
 9033 FORMAT('PXLEC,PXLECG= ',E15.7,E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9034)PYLEC,PYLECG
 9034 FORMAT('PYLEC,PYLECG= ',E15.7,E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9039)IBUGG4,ISUBG4,IERRG4
 9039 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE GRDRBP(PX,PY,NP,PXSPA,PYSPA,IFACTO,
     1IHORPA,IVERPA,IDUPPA,IDDOPA,
     1IPATT2,PTHICK,ICOL)
C  ABOVE LINE ADDED SEPTEMBER, 1987
C
C
C     PURPOSE--FOR A GENERAL GRAPHICS DEVICE,
C              DRAW A PATTERN WITHIN A BOX
C              THE PATTERN MAY BE ANY EVENLY-SPACED COMBINATION OF
C              HORIZONTAL, VERTICAL, AND/OR DIAGONAL PATTERNS
C     NOTE--THE COORDINATES IN (PX(.),PY(.)) ARE IN
C           STANDARDIZED (0.0 TO 100.0) UNITS.
C     NOTE--THERE ARE NP SUCH COORDINATE PAIRS.
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-921-3651
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)--MAY       1983.
C     UPDATED--         MARCH 1988 (TO FIX PROBLEM DEALING WITH
C                                  HOR., DU, DD, DDDU IN NEGATIVE BOXES)
C     UPDATED         --JANUARY  1989. SUN (BY BILL ANDERSON)
C     UPDATED         --JANUARY  1989. POSTSCRIPT (BY ALAN HECKERT)
C     UPDATED         --JANUARY  1989. CGM (BY ALAN HECKERT)
C     UPDATED         --JANUARY  1989. QMS QUIC (BY ALAN HECKERT)
C     UPDATED         --JANUARY  1989. CALCOMP (BY ALAN HECKERT)
C     UPDATED         --JANUARY  1989. ZETA (BY ALAN HECKERT)
C     UPDATED         --OCTOBER  1993. COMMENT OUT CALLS TO GRTRSD
C
C-----NON-COMMON VARIABLES (GRAPHICS)-------------------------------------------
C
      CHARACTER*4 IHORPA
      CHARACTER*4 IVERPA
      CHARACTER*4 IDUPPA
      CHARACTER*4 IDDOPA
C
      CHARACTER*4 ISUBN0
C
      CHARACTER*4 IFLAG
      CHARACTER*4 IPATT2
      CHARACTER*4 IFIG
      CHARACTER*4 ICOL
C
      DIMENSION PX(*)
      DIMENSION PY(*)
C
      DIMENSION PX2(2)
      DIMENSION PY2(2)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOGR.INC'
      INCLUDE 'DPCOBE.INC'
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN0='DRBP'
      IFIG='LINE'
C
      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DRBP')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF GRDRBP--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)NP
   52 FORMAT('NP = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO55I=1,NP
      WRITE(ICOUT,56)I,PX(I),PY(I)
   56 FORMAT('I,PX(I),PY(I) = ',I8,2E15.7)
      CALL DPWRST('XXX','BUG ')
   55 CONTINUE
      WRITE(ICOUT,57)PXSPA,PYSPA
   57 FORMAT('PXSPA,PYSPA = ',2E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,58)IFACTO
   58 FORMAT('IFACTO = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,61)IHORPA,IVERPA,IDUPPA,IDDOPA
   61 FORMAT('IHORPA,IVERPA,IDUPPA,IDDOPA = ',A4,2X,A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,69)IBUGG4,ISUBG4,IERRG4
   69 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
   90 CONTINUE
C
C               ***************************************************
C               **  STEP 1--                                     **
C               **  DRAW THE HORIZONTAL STRIPES (IF CALLED FOR)  **
C               ***************************************************
C
      IF(IHORPA.EQ.'ON')GOTO1100
      GOTO1190
 1100 CONTINUE
CCCCC THE FOLLOWING 2 LINES WERE INSERTED MARCH 1988
      ASIGN=1.0
      IF(PY(3).LT.PY(1))ASIGN=(-1.0)
      PX2(1)=PX(1)
      PX2(2)=PX(3)
      YCOMP=PY(1)
C  SEPTEMBER,1987
      IFLAG='ON'
      NP2=2
C
 1120 CONTINUE
CCCCC YCOMP=YCOMP+PYSPA                   MARCH 1988
CCCCC IF(YCOMP.GE.PY(3))GOTO1190          MARCH 1988
CCCCC THE FOLLOWING 3 LINES WERE INSERTED MARCH 1988
      YCOMP=YCOMP+ASIGN*PYSPA
      IF(ASIGN.GE.0.0.AND.YCOMP.GE.PY(3))GOTO1190
      IF(ASIGN.LT.0.0.AND.YCOMP.LE.PY(3))GOTO1190
      PY2(1)=YCOMP
      PY2(2)=YCOMP
      IF(IBUGG4.EQ.'ON')WRITE(ICOUT,1122)PX2(1),PY2(1),PX2(2),PY2(2)
 1122 FORMAT('PX2(1),PY2(1),   PX2(2),PY2(2) = ',2E15.7,4X,2E15.7)
      IF(IBUGG4.EQ.'ON')CALL DPWRST('XXX','BUG ')
CCCCC CALL GRTRSD(PX2(1),PY2(1),IX1,IY1,ISUBN0)
CCCCC CALL GRTRSD(PX2(2),PY2(2),IX2,IY2,ISUBN0)
CCCCC CALL GRDRLI(IX1,IY1,IX2,IY2,PX2(1),PY2(1),PX2(2),PY2(2),IFACTO)
      CALL DPDRPL(PX2,PY2,NP2,
     1IFIG,IPATT2,PTHICK,ICOL,
     1JPATT,JTHICK,PTHIC2,JCOL,IFLAG)
      IFLAG='OFF'
      GOTO1120
 1190 CONTINUE
C
C               ***************************************************
C               **  STEP 2--                                     **
C               **  DRAW THE VERTICAL   STRIPES (IF CALLED FOR)  **
C               ***************************************************
C
      IF(IVERPA.EQ.'ON')GOTO1200
      GOTO1290
 1200 CONTINUE
CCCCC THE FOLLOWING 2 LINES WERE INSERTED MARCH 1988
      ASIGN=1.0
      IF(PX(3).LT.PX(1))ASIGN=(-1.0)
      PY2(1)=PY(1)
      PY2(2)=PY(3)
      XCOMP=PX(1)
C  SEPTEMBER, 1987
      IFLAG='ON'
      NP2=2
C
 1220 CONTINUE
CCCCC XCOMP=XCOMP+PXSPA               MARCH 1988
CCCCC IF(XCOMP.GE.PX(3))GOTO1290      MARCH 1988
CCCCC THE FOLLOWING 3 LINES WERE INSERTED MARCH 1988
      XCOMP=XCOMP+ASIGN*PXSPA
      IF(ASIGN.GE.0.0.AND.XCOMP.GE.PX(3))GOTO1290
      IF(ASIGN.LT.0.0.AND.XCOMP.LE.PX(3))GOTO1290
      PX2(1)=XCOMP
      PX2(2)=XCOMP
      IF(IBUGG4.EQ.'ON')WRITE(ICOUT,1222)PX2(1),PY2(1),PX2(2),PY2(2)
 1222 FORMAT('PX2(1),PY2(1),   PX2(2),PY2(2) = ',2E15.7,4X,2E15.7)
      IF(IBUGG4.EQ.'ON')CALL DPWRST('XXX','BUG ')
CCCCC CALL GRTRSD(PX2(1),PY2(1),IX1,IY1,ISUBN0)
CCCCC CALL GRTRSD(PX2(2),PY2(2),IX2,IY2,ISUBN0)
CCCCC CALL GRDRLI(IX1,IY1,IX2,IY2,PX2(1),PY2(1),PX2(2),PY2(2),IFACTO)
      CALL DPDRPL(PX2,PY2,NP2,
     1IFIG,IPATT2,PTHICK,ICOL,
     1JPATT,JTHICK,PTHIC2,JCOL,IFLAG)
      IFLAG='OFF'
      GOTO1220
 1290 CONTINUE
C
C               ******************************************************
C               **  STEP 3--                                        **
C               **  DRAW THE UP-DIAGONAL   STRIPES (IF CALLED FOR)  **
C               ******************************************************
C
      IF(IDUPPA.EQ.'ON')GOTO1300
      GOTO1390
 1300 CONTINUE
C  SEPTEMBER, 1987
      NP2=2
      IFLAG='ON'
C
CCCCC THE FOLLOWING 2 LINES WERE INSERTED MARCH 1988
CCCCC PLUS OTHER SUBSTITUTIONS IN THIS SECTION WERE ALSO MADE.  MARCH 1988
      PSTART=PY(1)
      PSTOP=PY(3)
      IF(PY(3).LT.PY(1))PSTART=PY(3)
      IF(PY(3).LT.PY(1))PSTOP=PY(1)
      YCOMP=PSTART-(PX(3)-PX(1))*(PYSPA/PXSPA)-PYSPA
 1320 CONTINUE
      YCOMP=YCOMP+PYSPA
      IF(YCOMP.GT.PSTOP)GOTO1390
C
      YCOMPT=YCOMP
      YCOMP1=YCOMP
      IF(YCOMPT.LT.PSTART)YCOMP1=PSTART
      XCOMP1=PX(1)
      IF(YCOMPT.LT.PSTART)XCOMP1=PX(1)+(PSTART-YCOMPT)*(PXSPA/PYSPA)
C
      YCOMPT=YCOMP+(PX(3)-PX(1))*(PYSPA/PXSPA)
      YCOMP2=YCOMP+(PX(3)-PX(1))*(PYSPA/PXSPA)
      IF(YCOMPT.GT.PSTOP)YCOMP2=PSTOP
      XCOMP2=PX(3)
      IF(YCOMPT.GT.PSTOP)XCOMP2=PX(3)-(YCOMPT-PSTOP)*(PXSPA/PYSPA)
C
      PX2(1)=XCOMP1
      PX2(2)=XCOMP2
      PY2(1)=YCOMP1
      PY2(2)=YCOMP2
C
      IF(IBUGG4.EQ.'ON')WRITE(ICOUT,1322)PX2(1),PY2(1),PX2(2),PY2(2)
 1322 FORMAT('PX2(1),PY2(1),   PX2(2),PY2(2) = ',2E15.7,4X,2E15.7)
      IF(IBUGG4.EQ.'ON')CALL DPWRST('XXX','BUG ')
CCCCC CALL GRTRSD(PX2(1),PY2(1),IX1,IY1,ISUBN0)
CCCCC CALL GRTRSD(PX2(2),PY2(2),IX2,IY2,ISUBN0)
CCCCC CALL GRDRLI(IX1,IY1,IX2,IY2,PX2(1),PY2(1),PX2(2),PY2(2),IFACTO)
      CALL DPDRPL(PX2,PY2,NP2,
     1IFIG,IPATT2,PTHICK,ICOL,
     1JPATT,JTHICK,PTHIC2,JCOL,IFLAG)
      IFLAG='OFF'
      GOTO1320
C
 1390 CONTINUE
C
C               ******************************************************
C               **  STEP 4--                                        **
C               **  DRAW THE DOWN-DIAGONAL STRIPES (IF CALLED FOR)  **
C               ******************************************************
C
      IF(IDDOPA.EQ.'ON')GOTO1400
      GOTO1490
 1400 CONTINUE
C  SEPTEMBER,1987
      NP2=2
      IFLAG='ON'
C
CCCCC THE FOLLOWING 4 LINES WERE INSERTED MARCH 1988
CCCCC PLUS OTHER SUBSTITUTIONS IN THIS SECTION WERE ALSO MADE.  MARCH 1988
      PSTART=PY(1)
      PSTOP=PY(3)
      IF(PY(3).LT.PY(1))PSTART=PY(3)
      IF(PY(3).LT.PY(1))PSTOP=PY(1)
      YCOMP=PSTART-(PX(3)-PX(1))*(PYSPA/PXSPA)-PYSPA
 1420 CONTINUE
      YCOMP=YCOMP+PYSPA
      IF(YCOMP.GT.PSTOP)GOTO1490
C
      YCOMPT=YCOMP
      YCOMP2=YCOMP
      IF(YCOMPT.LT.PSTART)YCOMP2=PSTART
      XCOMP2=PX(3)
      IF(YCOMPT.LT.PSTART)XCOMP2=PX(3)-(PSTART-YCOMPT)*(PXSPA/PYSPA)
C
      YCOMPT=YCOMP+(PX(3)-PX(1))*(PYSPA/PXSPA)
      YCOMP1=YCOMP+(PX(3)-PX(1))*(PYSPA/PXSPA)
      IF(YCOMPT.GT.PSTOP)YCOMP1=PSTOP
      XCOMP1=PX(1)
      IF(YCOMPT.GT.PSTOP)XCOMP1=PX(1)+(YCOMPT-PSTOP)*(PXSPA/PYSPA)
C
      PX2(1)=XCOMP1
      PX2(2)=XCOMP2
      PY2(1)=YCOMP1
      PY2(2)=YCOMP2
C
      IF(IBUGG4.EQ.'ON')WRITE(ICOUT,1422)PX2(1),PY2(1),PX2(2),PY2(2)
 1422 FORMAT('PX2(1),PY2(1),   PX2(2),PY2(2) = ',2E15.7,4X,2E15.7)
      IF(IBUGG4.EQ.'ON')CALL DPWRST('XXX','BUG ')
CCCCC CALL GRTRSD(PX2(1),PY2(1),IX1,IY1,ISUBN0)
CCCCC CALL GRTRSD(PX2(2),PY2(2),IX2,IY2,ISUBN0)
CCCCC CALL GRDRLI(IX1,IY1,IX2,IY2,PX2(1),PY2(1),PX2(2),PY2(2),IFACTO)
      CALL DPDRPL(PX2,PY2,NP2,
     1IFIG,IPATT2,PTHICK,ICOL,
     1JPATT,JTHICK,PTHIC2,JCOL,IFLAG)
      IFLAG='OFF'
      GOTO1420
C
 1490 CONTINUE
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DRBP')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF GRDRBP--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)NP
 9012 FORMAT('NP = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO9015I=1,NP
      WRITE(ICOUT,9016)I,PX(I),PY(I)
 9016 FORMAT('I,PX(I),PY(I) = ',I8,2E15.7)
      CALL DPWRST('XXX','BUG ')
 9015 CONTINUE
      WRITE(ICOUT,9017)PXSPA,PYSPA
 9017 FORMAT('PXSPA,PYSPA = ',2E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9018)IFACTO
 9018 FORMAT('IFACTO = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9021)IHORPA,IVERPA,IDUPPA,IDDOPA
 9021 FORMAT('IHORPA,IVERPA,IDUPPA,IDDOPA = ',A4,2X,A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9029)IBUGG4,ISUBG4,IERRG4
 9029 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE GRDRPG(PX,PY,NP,ISTRIN,NCSTRI,
     1                  IFIG,IPATT,IFONT,ICASE,IJUST,IDIR,ANGLE,
     1                  IFILL,ICOL,
     1                  JPATT,JFONT,JCASE,JJUST,JDIR,ANGLE2,JFILL,JCOL,
     1                  PTHICK,JTHICK,PTHIC2,
     1                  PHEIGH,PWIDTH,PVEGAP,PHOGAP,
     1                  PHEIG2,PWIDT2,PVEGA2,PHOGA2,
     1                  ISYMBL,ISPAC)
C
C     PURPOSE--FOR A SPECIFIC GRAPHICS DEVICE,
C              DRAW THE GENERAL (GENERAL FONT AND GENERAL DIRECTION)
C              POLYMARKER WHOSE COORDINATES
C              ARE GIVEN IN (PX(.),PY(.)).
C     NOTE--THE COORDINATES IN (PX(.),PY(.)) ARE IN
C           STANDARDIZED (0.0 TO 100.0) UNITS.
C     NOTE--THERE ARE NP SUCH COORDINATE PAIRS.
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-921-3651
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)--MAY       1983.
C     UPDATED       --SEPTEMBER   1999. SUPPORT FOR MULTIPLOT SCALE
C                                       FACTOR
C
C-----NON-COMMON VARIABLES (GRAPHICS)-------------------------------------------
C
      CHARACTER*4 IFIG
      CHARACTER*24 IPATT
      CHARACTER*4 IPATTZ
      CHARACTER*4 IFONT
      CHARACTER*4 ICASE
      CHARACTER*4 IJUST
      CHARACTER*4 IDIR
      CHARACTER*4 IFILL
      CHARACTER*4 ICOL
C
      CHARACTER*24 ISYMBL
      CHARACTER*4 ISPAC
C
      CHARACTER*4 IBUGD2
C
      CHARACTER*4 ISTRIN
C
      CHARACTER*4 IFOUND
      CHARACTER*4 IERROR
C
      DIMENSION PX(*)
      DIMENSION PY(*)
      DIMENSION ISTRIN(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOGR.INC'
      INCLUDE 'DPCOBE.INC'
      CHARACTER*4 IMPSW2
      COMMON/CMISC3/
     1IMPSW2
      COMMON /RMISC2/
     1AMPSCH, AMPSCW
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      IERRG4='NO'
      IFOUND='-999'
      IERROR='-999'
C
      IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'DRPG')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,51)
   51   FORMAT('***** AT THE BEGINNING OF GRDRPG--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,52)IMANUF,IFIG,IPATT,NP,JPATT
   52   FORMAT('IMANUF,IFIG,IPATT,NP,JPATT = ',2(A4,2X),A24,2X,2I8)
        CALL DPWRST('XXX','BUG ')
        DO55I=1,NP
          WRITE(ICOUT,56)PX(I),PY(I)
   56     FORMAT('PX(I),PY(I) = ',2G15.7)
          CALL DPWRST('XXX','BUG ')
   55   CONTINUE
        WRITE(ICOUT,60)IFONT,ICASE,JFONT,JCASE,JFILL
   60   FORMAT('IFONT,ICASE,JFONT,JCASE,JFILL = ',2(A4,2X),3I8)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,62)IJUST,IDIR,JJUST,JDIR,ANGLE,ANGLE2
   62   FORMAT('IJUST,IDIR,JJUST,JDIR,ANGLE,ANGLE2 = ',
     1         2(A4,2X),2I8,2G15.7)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,64)IFILL,ICOL,ISPAC,ISYMBL,JCOL
   64   FORMAT('IFILL,ICOL,ISPAC,ISYMBL,JCOL = ',3(A4,2X),A24,2X,I8)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,66)PTHICK,PTHIC2,JTHICK
   66   FORMAT('PTHICK,PTHIC2,JTHICK = ',2G15.7,I8)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,67)PHEIGH,PWIDTH,PVEGAP,PHOGAP
   67   FORMAT('PHEIGH,PWIDTH,PVEGAP,PHOGAP = ',4G15.7)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,68)PHEIG2,PWIDT2,PVEGA2,PHOGA2
   68   FORMAT('PHEIG2,PWIDT2,PVEGA2,PHOGA2 = ',4G15.7)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,78)IFOUND,IBUGD2,IERROR
   78   FORMAT('IFOUND,IBUGD2,IERROR = ',2(A4,2X),A4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,79)IBUGG4,ISUBG4,IERRG4
   79   FORMAT('IBUGG4,ISUBG4,IERRG4 = ',2(A4,2X),A4)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      CALL GRTRPG(IPATT,ISTRIN,NCSTRI)
C
      HEIGHT=PHEIGH+PVEGAP
      WIDTH=PWIDTH+PHOGAP
C
      IBUGD2=IBUGG4
      HMAX=100.0
      VMAX=100.0
      AMAX=360.0
      IPATTZ='SOLI'
      JPATTZ=96
C
      DO1100I=1,NP
        X0=PX(I)
        Y0=PY(I)
        CALL DPSCR7(ISTRIN,NCSTRI,X0,Y0,
     1              IFONT,ICASE,IJUST,ANGLE,HMAX,VMAX,AMAX,
     1              WIDTH,HEIGHT,
     1              PHEIGH,PWIDTH,PVEGAP,PHOGAP,
     1              PHEIG2,PWIDT2,PVEGA2,PHOGA2,
     1              ANUMHP,ANUMVP,
     1              IPATTZ,PTHICK,ICOL,
     1              JPATTZ,JTHICK,PTHIC2,JCOL,
     1              ISYMBL,ISPAC,IFILL,
     1              IMPSW2,AMPSCH,AMPSCW,
     1              XEND,YEND,IFOUND,IBUGD2,IERROR)
 1100 CONTINUE
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DRPG')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF GRDRPG--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)NP
 9012 FORMAT('NP = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)IMANUF
 9013 FORMAT('IMANUF = ',A4)
      CALL DPWRST('XXX','BUG ')
      DO9015I=1,NP
      WRITE(ICOUT,9016)PX(I),PY(I)
 9016 FORMAT('PX(I),PY(I) = ',E15.7,E15.7)
      CALL DPWRST('XXX','BUG ')
 9015 CONTINUE
      WRITE(ICOUT,9018)IFIG
 9018 FORMAT('IFIG = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9019)IPATT,JPATT
 9019 FORMAT('IPATT,JPATT = ',A4,I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9020)IFONT,JFONT
 9020 FORMAT('IFONT,JFONT = ',A4,I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9021)ICASE,JCASE
 9021 FORMAT('ICASE,JCASE = ',A4,I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9022)IJUST,JJUST
 9022 FORMAT('IJUST,JJUST = ',A4,I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9023)IDIR,ANGLE,JDIR
 9023 FORMAT('IDIR,ANGLE,JDIR = ',A4,2X,E15.7,I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9024)ICOL,JCOL
 9024 FORMAT('ICOL,JCOL = ',A4,I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9026)PTHICK,JTHICK,PTHIC2
 9026 FORMAT('PTHICK,JTHICK,PTHIC2 = ',E15.7,I8,E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9027)PHEIGH,PWIDTH,PVEGAP,PHOGAP
 9027 FORMAT('PHEIGH,PWIDTH,PVEGAP,PHOGAP = ',4E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9028)PHEIG2,PWIDT2,PVEGA2,PHOGA2
 9028 FORMAT('PHEIG2,PWIDT2,PVEGA2,PHOGA2 = ',4E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9031)ISYMBL,ISPAC
 9031 FORMAT('ISYMBL,ISPAC = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9032)IFILL
 9032 FORMAT('IFILL = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9039)IBUGG4,ISUBG4,IERRG4
 9039 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE GRDRPM(PX,PY,NP,
     1IFIG,IPATT,IFONT,ICASE,IJUST,IDIR,ANGLE,IFILL,ICOL,
     1JPATT,JFONT,JCASE,JJUST,JDIR,ANGLE2,JFILL,JCOL,
     1PTHICK,JTHICK,PTHIC2,
     1PHEIGH,PWIDTH,PVEGAP,PHOGAP,
     1PHEIG2,PWIDT2,PVEGA2,PHOGA2,
     1JHEIG2,JWIDT2,JVEGA2,JHOGA2,
     1IMPSW2,AMPSCH,AMPSCW,
     1ISYMBL,ISPAC)
C
C     PURPOSE--FOR A SPECIFIC GRAPHICS DEVICE,
C              DRAW THE POLYMARKER WHOSE COORDINATES
C              ARE GIVEN IN (PX(.),PY(.)).
C     NOTE--THE COORDINATES IN (PX(.),PY(.)) ARE IN
C           STANDARDIZED (0.0 TO 100.0) UNITS.
C     NOTE--THERE ARE NP SUCH COORDINATE PAIRS.
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-921-3651
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)--MAY       1983.
C     UPDATED         --MARCH    1992.  USE GRWRTH FOR STRINGS LONGER THAN
C                                       ONE CHARACTER.  HOWEVER NEED TO TEST
C                                       FOR SPECIAL PLOT CHARACTERS (ALAN)
C     UPDATED         --AUGUST   1992.  UPDATED SYMBOL LIST
C                                       HANDLE ARROW, VECTORS DIFFERENTLY
C     UPDATED         --AUGUST   1993.  HARDWARE TEXT-HANDLE CASE
C     UPDATED         --FEBRUARY 1994.  VECTOR CASE FOR SOFTWARE FONT
C     UPDATED         --NOVEMBER 1995.  CASE CONVERSION IN DPDRPM
C     UPDATED         --DECEMBER 1995.  BUG WITH LOWER CASE "BLANK"
C     UPDATED         --AUGUST   1996.  DEVICE FONT COMMAND
C     UPDATED         --MARCH    1997.  BUG WITH LOWER CASE "BLANK"
C                                       FIXED FOR SOFTWARE FONT
C     UPDATED         --SEPTEMBER1999.  ARGUMENT LIST TO DPWRTE
C
C-----NON-COMMON VARIABLES (GRAPHICS)-------------------------------------------
C
      CHARACTER*4 IFONT
      CHARACTER*4 ICASE
      CHARACTER*4 IJUST
      CHARACTER*4 IDIR
      CHARACTER*4 IFILL
      CHARACTER*4 ICOL
      CHARACTER*4 IFIG
      CHARACTER*24 IPATT
C
      CHARACTER*24 ISYMBL
      CHARACTER*4 ISPAC
      CHARACTER*4 IMPSW2
C
      CHARACTER*4 ISTRIN(16)
C
      CHARACTER*4 ITRCSW
CCCCC AUGUST 1993.  ADD FOLLOWING LINE
      CHARACTER*1 ICTEMP
C
      DIMENSION PX(*)
      DIMENSION PY(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOGR.INC'
      INCLUDE 'DPCOBE.INC'
CCCCC THE FOLLOWING COMMON BLOCK WAS ADDED AUGUST 1992.
      COMMON /RWIND/
     1PWXMIN,PWXMAX,PWYMIN,PWYMAX,PWZMIN,PWZMAX,
     1WWXMIN,WWXMAX,WWYMIN,WWYMAX,WWZMIN,WWZMAX
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      IERRG4='NO'
C
      IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'DRPM')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,51)
   51   FORMAT('***** AT THE BEGINNING OF GRDRPM--')
        CALL DPWRST('XXX','BUG ')
        DO55I=1,NP
          WRITE(ICOUT,56)I,PX(I),PY(I)
   56     FORMAT('I,PX(I),PY(I) = ',I8,2G15.7)
          CALL DPWRST('XXX','BUG ')
   55   CONTINUE
        WRITE(ICOUT,59)NP,IMANUF,IFIG,IPATT,JPATT
   59   FORMAT('NP,IMANUF,IFIG,IPATT,JPATT = ',I8,2X,2(A4,2X),A16,2X,I8)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,60)IFONT,JFONT,ICASE,JCASE
   60   FORMAT('IFONT,JFONT,ICASE,JCASE = ',A4,I8,2X,A4,I8)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,63)IDIR,ANGLE,JDIR
   63   FORMAT('IDIR,ANGLE,JDIR = ',A4,2X,G15.7,I8)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,64)IJUST,JJUST,ICOL,JCOL
   64   FORMAT('IJUST,JJUST,ICOL,JCOL = ',A4,I8,2X,A4,I8)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,66)PTHICK,JTHICK,PTHIC2
   66   FORMAT('PTHICK,JTHICK,PTHIC2 = ',G15.7,I8,G15.7)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,67)PHEIGH,PWIDTH,PVEGAP,PHOGAP
   67   FORMAT('PHEIGH,PWIDTH,PVEGAP,PHOGAP = ',4G15.7)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,68)PHEIG2,PWIDT2,PVEGA2,PHOGA2
   68   FORMAT('PHEIG2,PWIDT2,PVEGA2,PHOGA2 = ',4G15.7)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,71)ISYMBL,ISPAC
   71   FORMAT('ISYMBL,ISPAC = ',A24,2X,A4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,79)IBUGG4,ISUBG4,IERRG4
   79   FORMAT('IBUGG4,ISUBG4,IERRG4 = ',2(A4,2X),A4)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
C               ************************************************
C               **  STEP 1--                                  **
C               **  CALL THE APPROPRIATE SUBROUTINE           **
C               **  DEPENDING ON WHETHER HAVE TEKTRONIX FONT  **
C               **  OR A GENERAL FONT.                        **
C               ************************************************
C
C  MARCH 1992.  FOLLOWING 3 LINES ADDED TO BLANK OUT ISTRIN.
      DO100I=1,16
        ISTRIN(I)=' '
 100  CONTINUE
C
CCCCC NOVEMBER 1995.  MODIFY FOLLOWING LINE.
CCCCC CALL GRTRPG(IPATT,ISTRIN,NCSTRI)
C
      IF(ISYMBL(1:4).EQ.'BLAN')THEN
        ISYMBL='BLAN'
        GOTO200
      ELSEIF(ISYMBL(1:4).EQ.'BL  ')THEN
        ISYMBL='BLAN'
        GOTO200
      ELSEIF(ISYMBL(1:4).EQ.'NONE')THEN
        ISYMBL='BLAN'
        GOTO200
      ELSEIF(IPATT(1:4).EQ.'NO  ')THEN
        ISYMBL='BLAN'
        GOTO200
      ENDIF
      CALL GRTRPG(ISYMBL,ISTRIN,NCSTRI)
C
C     MARCH 1997.  PUT FOLLOWING LINES FROM BELOW HERE TO FIX
C     BUG WITH CHARACTER BLANK WHEN SOFTWARE FONT USED.
      IF(IPATT(1:4).EQ.'BLAN')THEN
        IPATT='BLAN'
        GOTO200
      ELSEIF(IPATT(1:4).EQ.'BL  ')THEN
        IPATT='BLAN'
        GOTO200
      ELSEIF(IPATT(1:4).EQ.'NONE')THEN
        IPATT='BLAN'
        GOTO200
      ELSEIF(IPATT(1:4).EQ.'NO  ')THEN
        IPATT='BLAN'
        GOTO200
      ENDIF
C
      IF(IFONT.EQ.'TEKT'.AND.NCSTRI.LE.1)GOTO200
C
C     2015/10: DO THE FOLLOWING CHECK FOR BOTH HARDWARE AND
C              SOFTWARE FONTS
C
CCCCC IF(IFONT.NE.'TEKT')GOTO300
C
C     CHECK FOR SPECIAL PLOT CHARACTERS
C
C     JUNE 2010: SINCE CHARACTERS ARE NOW ALLOWED TO BE UP TO
C                16 CHARACTERS, NEED TO SET CERTAIN SPELLED OUT
C                SYMBOLS TO THEIR 4 CHARACTER REPRESENTATION (SO
C                THEY WILL BE RECOGNIZED CORRECTLY BY SOME LOWER
C                LEVEL CODES).  BASICALLY, IF THE FIRST 4 CHARACTERS
C                ARE EQUIVALENT TO ONE OF OUR SPECIAL CODES, THEN
C                SET IT EQUAL TO THE 4-CHARACTER REPRESENTATION.
C
      IF(IPATT(1:4).EQ.'TRIA')THEN
        IPATT='TRIA'
        GOTO300
      ENDIF
      IF(IPATT(1:4).EQ.'TR  ')GOTO300
      IF(IPATT(1:4).EQ.'SQUA')THEN
        IPATT='SQUA'
        GOTO300
      ENDIF
      IF(IPATT(1:4).EQ.'SQ  ')GOTO300
      IF(IPATT(1:4).EQ.'DIAM')THEN
        IPATT='DIAM'
        GOTO300
      ENDIF
      IF(IPATT(1:4).EQ.'DI  ')GOTO300
CCCCC IF(IPATT(1:4).EQ.'HEXA')GOTO300
      IF(IPATT(1:4).EQ.'CIRC')THEN
        IPATT='CIRC'
        GOTO300
      ENDIF
      IF(IPATT(1:4).EQ.'CI  ')GOTO300
      IF(IPATT(1:4).EQ.'CUBE')THEN
        IPATT='CUBE'
        GOTO300
      ENDIF
      IF(IPATT(1:4).EQ.'PYRA')THEN
        IPATT='PYRA'
        GOTO300
      ENDIF
C  AUGUST 1992. UNCOMMENTED FOLLOWING 2 LINES
      IF(IPATT(1:4).EQ.'REVT')THEN
        IPATT='REVT'
        GOTO300
      ENDIF
      IF(IPATT(1:4).EQ.'RT  ')GOTO300
      IF(IPATT(1:4).EQ.'TRIR')THEN
        IPATT='TRIR'
        GOTO300
      ENDIF
C  AUGUST 1992.  FOLLOWING LINE ADDED.
      IF(IPATT(1:4).EQ.'TRII')THEN
        IPATT='TRII'
        GOTO300
      ENDIF
CCCCC DECEMBER 1995. BLANK SHOULD GO TO GRDRPH, NOT GRDRPG
CCCCC MARCH 1997. MOVE FOLLOWING CODE (SAME BUG FOR SOFTWARE FONT)
CCCCC IF(IPATT(1:4).EQ.'BLAN')GOTO300
CCCCC IF(IPATT(1:4).EQ.'BL  ')GOTO300
CCCCC IF(IPATT(1:4).EQ.'NONE')GOTO300
CCCCC IF(IPATT(1:4).EQ.'NO  ')GOTO300
CCCCC IF(IPATT(1:4).EQ.'BLAN')GOTO200
CCCCC IF(IPATT(1:4).EQ.'BL  ')GOTO200
CCCCC IF(IPATT(1:4).EQ.'NONE')GOTO200
CCCCC IF(IPATT(1:4).EQ.'NO  ')GOTO200
      IF(IPATT(1:4).EQ.'BOX ')GOTO300
      IF(IPATT(1:4).EQ.'STAR')THEN
        IPATT='STAR'
        GOTO300
      ENDIF
      IF(IPATT(1:4).EQ.'ST  ')GOTO300
      IF(IPATT(1:4).EQ.'AU  ')GOTO300
      IF(IPATT(1:4).EQ.'AD  ')GOTO300
CCCCC IF(IPATT(1:4).EQ.'VB  ')GOTO300
      IF(IPATT(1:4).EQ.'POIN')THEN
        IPATT='POIN'
        GOTO300
      ENDIF
      IF(IPATT(1:4).EQ.'PT  ')GOTO300
      IF(IPATT(1:4).EQ.'PO  ')GOTO300
C  AUGUST 1992.  ADD ARROW CASE.
C  THIS CASE HANDLED SEPARATELY.
      IF(IPATT(1:4).EQ.'ARRO')THEN
        IPATT='ARRO'
        GOTO500
      ENDIF
      IF(IPATT(1:4).EQ.'ARRH')THEN
        IPATT='ARRH'
        GOTO500
      ENDIF
      IF(IPATT(1:4).EQ.'VECT')THEN
        IPATT='VECT'
        GOTO500
      ENDIF
C
      IF(IPATT(1:4).EQ.'DEGR')THEN
        IPATT='DEGR'
        GOTO300
      ENDIF
C
C  CHECK FOR GREEK CHARACTERS
C
      IF(IPATT(1:4).EQ.'ALPH')THEN
        IPATT='ALPH'
        GOTO300
      ENDIF
      IF(IPATT(1:4).EQ.'BETA')THEN
        IPATT='BETA'
        GOTO300
      ENDIF
      IF(IPATT(1:4).EQ.'GAMM')THEN
        IPATT='GAMM'
        GOTO300
      ENDIF
      IF(IPATT(1:4).EQ.'DELT')THEN
        IPATT='DELT'
        GOTO300
      ENDIF
      IF(IPATT(1:4).EQ.'EPSI')THEN
        IPATT='EPSI'
        GOTO300
      ENDIF
      IF(IPATT(1:4).EQ.'ZETA')THEN
        IPATT='ZETA'
        GOTO300
      ENDIF
      IF(IPATT(1:4).EQ.'ETA ')GOTO300
      IF(IPATT(1:4).EQ.'THET')THEN
        IPATT='THET'
        GOTO300
      ENDIF
      IF(IPATT(1:4).EQ.'IOTA')THEN
        GOTO300
      ENDIF
      IF(IPATT(1:4).EQ.'KAPP')THEN
        IPATT='KAPP'
        GOTO300
      ENDIF
      IF(IPATT(1:4).EQ.'LAMB')THEN
        IPATT='LAMB'
        GOTO300
      ENDIF
      IF(IPATT(1:4).EQ.'MU  ')GOTO300
      IF(IPATT(1:4).EQ.'NU  ')GOTO300
      IF(IPATT(1:4).EQ.'XI  ')GOTO300
      IF(IPATT(1:4).EQ.'OMIC')THEN
        IPATT='OMIC'
        GOTO300
      ENDIF
      IF(IPATT(1:4).EQ.'PI  ')GOTO300
      IF(IPATT(1:4).EQ.'RHO ')GOTO300
      IF(IPATT(1:4).EQ.'SIGM')THEN
        IPATT='SIGM'
        GOTO300
      ENDIF
      IF(IPATT(1:4).EQ.'TAU ')GOTO300
      IF(IPATT(1:4).EQ.'UPSI')THEN
        IPATT='UPSI'
        GOTO300
      ENDIF
      IF(IPATT(1:4).EQ.'PHI ')GOTO300
      IF(IPATT(1:4).EQ.'CHI ')GOTO300
      IF(IPATT(1:4).EQ.'PSI ')GOTO300
      IF(IPATT(1:4).EQ.'OMEG')THEN
        IPATT='OMEG'
        GOTO300
      ENDIF
C
C  CHECK FOR MATH SYMBOLS
C
      IF(IPATT(1:4).EQ.'PART')THEN
        IPATT='PART'
        GOTO300
      ENDIF
      IF(IPATT(1:4).EQ.'INTE')THEN
        IPATT='INTE'
        GOTO300
      ENDIF
      IF(IPATT(1:4).EQ.'CINT')THEN
        IPATT='CINT'
        GOTO300
      ENDIF
      IF(IPATT(1:4).EQ.'SUMM')THEN
        IPATT='SUMM'
        GOTO300
      ENDIF
      IF(IPATT(1:4).EQ.'PROD')THEN
        IPATT='PROD'
        GOTO300
      ENDIF
      IF(IPATT(1:4).EQ.'INFI')THEN
        IPATT='INFI'
        GOTO300
      ENDIF
      IF(IPATT(1:4).EQ.'+-  ')GOTO300
      IF(IPATT(1:4).EQ.'-+  ')GOTO300
      IF(IPATT(1:4).EQ.'TIME')THEN
        IPATT='TIME'
        GOTO300
      ENDIF
      IF(IPATT(1:4).EQ.'DOTP')THEN
        IPATT='DOTP'
        GOTO300
      ENDIF
      IF(IPATT(1:4).EQ.'DEL ')GOTO300
      IF(IPATT(1:4).EQ.'DIVI')THEN
        IPATT='DIVI'
        GOTO300
      ENDIF
      IF(IPATT(1:4).EQ.'LT  ')GOTO300
      IF(IPATT(1:4).EQ.'GT  ')GOTO300
      IF(IPATT(1:4).EQ.'LTEQ')THEN
        IPATT='LTEQ'
        GOTO300
      ENDIF
      IF(IPATT(1:4).EQ.'GTEQ')THEN
        IPATT='GTEQ'
        GOTO300
      ENDIF
      IF(IPATT(1:4).EQ.'NOT=')THEN
        IPATT='NOT='
        GOTO300
      ENDIF
      IF(IPATT(1:4).EQ.'APPR')THEN
        IPATT='APPR'
        GOTO300
      ENDIF
      IF(IPATT(1:4).EQ.'EQUI')THEN
        IPATT='EQUI'
        GOTO300
      ENDIF
      IF(IPATT(1:4).EQ.'VARI')THEN
        IPATT='VARI'
        GOTO300
      ENDIF
      IF(IPATT(1:4).EQ.'TILD')THEN
        IPATT='TILD'
        GOTO300
      ENDIF
      IF(IPATT(1:4).EQ.'CARA')THEN
        IPATT='CARA'
        GOTO300
      ENDIF
      IF(IPATT(1:4).EQ.'PRIM')THEN
        IPATT='PRIM'
        GOTO300
      ENDIF
      IF(IPATT(1:4).EQ.'RADI')THEN
        IPATT='RADI'
        GOTO300
      ENDIF
      IF(IPATT(1:4).EQ.'LRAD')THEN
        IPATT='LRAD'
        GOTO300
      ENDIF
      IF(IPATT(1:4).EQ.'BRAD')THEN
        IPATT='BRAD'
        GOTO300
      ENDIF
      IF(IPATT(1:4).EQ.'SUBS')THEN
        IPATT='SUBS'
        GOTO300
      ENDIF
      IF(IPATT(1:4).EQ.'SUPE')THEN
        IPATT='SUPE'
        GOTO300
      ENDIF
      IF(IPATT(1:4).EQ.'UNSB')THEN
        IPATT='UNSB'
        GOTO300
      ENDIF
      IF(IPATT(1:4).EQ.'UNSP')THEN
        IPATT='UNSP'
        GOTO300
      ENDIF
      IF(IPATT(1:4).EQ.'UNIO')THEN
        IPATT='UNIO'
        GOTO300
      ENDIF
      IF(IPATT(1:4).EQ.'INTR')THEN
        IPATT='INTR'
        GOTO300
      ENDIF
      IF(IPATT(1:4).EQ.'ELEM')THEN
        IPATT='ELEM'
        GOTO300
      ENDIF
      IF(IPATT(1:4).EQ.'THEX')THEN
        IPATT='THEX'
        GOTO300
      ENDIF
      IF(IPATT(1:4).EQ.'THFO')THEN
        IPATT='THFO'
        GOTO300
      ENDIF
C
C  CHECK FOR MISCELLANEOUS SYMBOLS
C
      IF(IPATT(1:4).EQ.'LAPO')THEN
        IPATT='LAPO'
        GOTO300
      ENDIF
      IF(IPATT(1:4).EQ.'RAPO')THEN
        IPATT='RAPO'
        GOTO300
      ENDIF
      IF(IPATT(1:4).EQ.'LBRA')THEN
        IPATT='LBRA'
        GOTO300
      ENDIF
      IF(IPATT(1:4).EQ.'RBRA')THEN
        IPATT='RBRA'
        GOTO300
      ENDIF
      IF(IPATT(1:4).EQ.'LCBR')THEN
        IPATT='LCBR'
        GOTO300
      ENDIF
      IF(IPATT(1:4).EQ.'RCBR')THEN
        IPATT='RCBR'
        GOTO300
      ENDIF
      IF(IPATT(1:4).EQ.'LELB')THEN
        IPATT='LELB'
        GOTO300
      ENDIF
      IF(IPATT(1:4).EQ.'RELB')THEN
        IPATT='RELB'
        GOTO300
      ENDIF
      IF(IPATT(1:4).EQ.'RACC')THEN
        IPATT='RACC'
        GOTO300
      ENDIF
      IF(IPATT(1:4).EQ.'LACC')THEN
        IPATT='LACC'
        GOTO300
      ENDIF
      IF(IPATT(1:4).EQ.'BREV')THEN
        IPATT='BREV'
        GOTO300
      ENDIF
      IF(IPATT(1:4).EQ.'LQUO')THEN
        IPATT='LQUO'
        GOTO300
      ENDIF
      IF(IPATT(1:4).EQ.'NASP')THEN
        IPATT='NASP'
        GOTO300
      ENDIF
      IF(IPATT(1:4).EQ.'IASP')THEN
        IPATT='IASP'
        GOTO300
      ENDIF
      IF(IPATT(1:4).EQ.'RARR')THEN
        IPATT='RARR'
        GOTO300
      ENDIF
      IF(IPATT(1:4).EQ.'LARR')THEN
        IPATT='LARR'
        GOTO300
      ENDIF
      IF(IPATT(1:4).EQ.'UARR')THEN
        IPATT='UARR'
        GOTO300
      ENDIF
      IF(IPATT(1:4).EQ.'DARR')THEN
        IPATT='DARR'
        GOTO300
      ENDIF
      IF(IPATT(1:4).EQ.'PARA')THEN
        IPATT='PARA'
        GOTO300
      ENDIF
      IF(IPATT(1:4).EQ.'DAGG')THEN
        IPATT='DAGG'
        GOTO300
      ENDIF
      IF(IPATT(1:4).EQ.'DDAG')THEN
        IPATT='DDAG'
        GOTO300
      ENDIF
      IF(IPATT(1:4).EQ.'VBAR')THEN
        IPATT='VBAR'
        GOTO300
      ENDIF
      IF(IPATT(1:4).EQ.'DVBA')THEN
        IPATT='DVBA'
        GOTO300
      ENDIF
      IF(IPATT(1:4).EQ.'LVBA')THEN
        IPATT='LVBA'
        GOTO300
      ENDIF
      IF(IPATT(1:4).EQ.'LHBA')THEN
        IPATT='LHBA'
        GOTO300
      ENDIF
      IF(IPATT(1:4).EQ.'BAR ')GOTO300
      IF(IPATT(1:4).EQ.'DEL ')GOTO300
CCCCC SEPTEMBER 1995.  PIXEL IS SPECIAL CASE (TURN A SINGLE POINT ON).
CCCCC IMPLEMENTED IN THE GRDRPH ROUTINE.
      IF(IPATT(1:4).EQ.'PIXE')THEN
        IPATT='PIXE'
        GOTO200
      ENDIF
      IF(IPATT(1:4).EQ.'DEL ')GOTO300
C
      IF(IFONT.NE.'TEKT')GOTO300
      IF(IFONT.EQ.'TEKT'.AND.NCSTRI.GE.2)GOTO400
      GOTO300
C
C  ONE CHARACTER, HARDWARE TEXT
C
 200  CONTINUE
CCCCC AUGUST 1993.  SET CASE CORRECTLY.  NOTE THAT NO ACTION REQUIRED
CCCCC IF CASE IS UPPER SINCE PLOT SYMBOL STORED IN UPPER CASE.
CCCCC NOVEMBER 1995.  CASE CONVERSION PERFORMED IN DPDRPM.
CCCCC IF(ICASE.EQ.'LOWE')THEN
CCCCC   ICTEMP=ISYMBL(1:1)
CCCCC   CALL DPCOAN(ICTEMP,IVALT)
CCCCC   IF(IVALT.GE.65.AND.IVALT.LE.90)IVALT=IVALT+32
CCCCC   CALL DPCONA(IVALT,ICTEMP)
CCCCC   ISYMBL(1:1)=ICTEMP
CCCCC END IF
CCCCC END CHANGE
CCCCC FOLLOWING SECTION MODIFIED AUGUST 1996.
      IF(IGFONT.EQ.'OFF')THEN
      ELSE
        IF(IPATT(1:4).EQ.'BLAN')GOTO299
        IF(IPATT(1:4).EQ.'BL  ')GOTO299
        IF(IPATT(1:4).EQ.'NONE')GOTO299
        IF(IPATT(1:4).EQ.'NO  ')GOTO299
        IF(IGFONT.NE.'TEKT')GOTO300
  299   CONTINUE
      ENDIF
C
      CALL GRDRPH(PX,PY,NP,
     1IFIG,IPATT,IFONT,ICASE,IJUST,IDIR,ANGLE,IFILL,ICOL,
     1JPATT,JFONT,JCASE,JJUST,JDIR,ANGLE2,JFILL,JCOL,
     1PTHICK,JTHICK,PTHIC2,
     1PHEIGH,PWIDTH,PVEGAP,PHOGAP,
     1PHEIG2,PWIDT2,PVEGA2,PHOGA2,
     1JHEIG2,JWIDT2,JVEGA2,JHOGA2,
     1ISYMBL,ISPAC)
      GOTO9000
C
C  MARCH 1992.  FOLLOWING LINE MODOIFIED.
CCCCC IF(IFONT.NE.'TEKT'.OR.NCSTRI.GE.2)
C  SOFTWARE TEXT (OR SPECIAL SYMBOL DRAWN WITH SOFTWARE TEXT)
C
 300  CONTINUE
C  FEBRUARY 1994.  ARROW CASE HANDLED SEPARATELY.
      IF(IPATT(1:4).EQ.'ARRO')GOTO500
      IF(IPATT(1:4).EQ.'ARRH')GOTO500
      IF(IPATT(1:4).EQ.'VECT')GOTO500
C
      CALL GRDRPG(PX,PY,NP,ISTRIN,NCSTRI,
     1IFIG,IPATT,IFONT,ICASE,IJUST,IDIR,ANGLE,IFILL,ICOL,
     1JPATT,JFONT,JCASE,JJUST,JDIR,ANGLE2,JFILL,JCOL,
     1PTHICK,JTHICK,PTHIC2,
     1PHEIGH,PWIDTH,PVEGAP,PHOGAP,
     1PHEIG2,PWIDT2,PVEGA2,PHOGA2,
     1ISYMBL,ISPAC)
      GOTO9000
C
C  MARCH 1992.  FOLLOWING BLOCK OF CODE ADDED.
C  MORE THAN ONE CHARACTER, HARDWARE TEXT (BUT NOT SPECIAL CHARACTER)
C
 400   CONTINUE
      IF(ISTRIN(NCSTRI-1).EQ.'('.AND.ISTRIN(NCSTRI).EQ.')')
     1NCSTRI=NCSTRI-2
CCCCC AUGUST 1993.  SET CASE CORRECTLY.  NOTE THAT NO ACTION REQUIRED
CCCCC IF CASE IS UPPER SINCE PLOT SYMBOL STORED IN UPPER CASE.
CCCCC NOVEMBER 1995.  PLOT SYMBOL CAN BE STORED WITH CASE ASIS
      IF(ICASE.EQ.'LOWE')THEN
        DO410I=1,NCSTRI
          ICTEMP=ISTRIN(I)(1:1)
          CALL DPCOAN(ICTEMP,IVALT)
          IF(IVALT.GE.65.AND.IVALT.LE.90)IVALT=IVALT+32
          CALL DPCONA(IVALT,ICTEMP)
          ISTRIN(I)(1:1)=ICTEMP
 410    CONTINUE
        DO420I=1,16
          ISYMBL(I:I)=ISTRIN(I)(1:1)
 420    CONTINUE
      ELSEIF(ICASE.EQ.'UPPE')THEN
        DO430I=1,NCSTRI
          ICTEMP=ISTRIN(I)(1:1)
          CALL DPCOAN(ICTEMP,IVALT)
          IF(IVALT.GE.97.AND.IVALT.LE.122)IVALT=IVALT-32
          CALL DPCONA(IVALT,ICTEMP)
          ISTRIN(I)(1:1)=ICTEMP
 430    CONTINUE
        DO440I=1,16
          ISYMBL(I:I)=ISTRIN(I)(1:1)
 440    CONTINUE
      END IF
CCCCC END CHANGE
      DO1000I=1,NP
      PX1=PX(I)
      PY1=PY(I)
      CALL DPWRTE(PX1,PY1,ISTRIN,NCSTRI,
     1IFONT,ICASE,IJUST,IDIR,ANGLE,IFILL,ICOL,
     1PHEIGH,PWIDTH,PVEGAP,PHOGAP,PTHICK,
     1ISYMBL,ISPAC,
     1IMPSW2,AMPSCH,AMPSCW,
     1PX99,PY99)
 1000 CONTINUE
      GOTO9000
C
C  AUGUST 1992.  HANDLE ARROW AND VECTOR CASE SEPARATELY.  THIS
C  CASE WILL USE THE DPARR3 ROUTINE (I COULDN'T GET IT TO WORK
C  RIGHT THROUGH THE FONT DRAWING ROUTINES). SINCE THE ARROW IS
C  DRAWN AT THE ANGLE DETERMINED BY TWO POINTS, THIS CASE WILL BE
C  HANDLED SEPARATELY.  IF THE PLOT SYMBOL IS "VECTOR", NO POINT IS
C  DRAWN AT THE FIRST POINT.  IF THE PLOT SYMBOL IS "ARROW" OR "ARRH",
C  DRAW THE ARROW HOIRZONTALLY (I.E., 0 DEGREES).
C
C  SINCE WANT THE ARROW HEAD TO BE AT THE POINT, ADJUST THE COORDINATES
C  TO BE CENTER JUSTIFIED.
C
 500  CONTINUE
      ITRCSW='OFF'
      PREPSP=0.1
      ISTART=2
      IF(NP.LT.ISTART)GOTO9000
      PXINC=PWIDT2/2.0
      PYINC=PHEIG2/2.0
      PXINC=PXINC*(100.0/(PWXMAX-PWXMIN))
      PYINC=PYINC*(100.0/(PWYMAX-PWYMIN))
      PXINC=0.0
      PYINC=0.0
      IF(IPATT.NE.'VECT')THEN
        PX2=PX(1)+PXINC
        PY2=PY(1)+PYINC
        PX1=PX2-1.0
        PY1=PY2
        CALL DPARR3(
     1  PX1,PY1,PX2,PY2,
     1  IFIG,
     1  ITRCSW,
     1  IPATT(1:4),ICOL,PTHICK,
     1  IFILL,ICOL,
     1  ICOL,PTHICK,PREPSP,
     1  PHEIGH,PWIDTH,PVEGAP,PHOGAP)
      ENDIF
      DO510I=ISTART,NP
      PX1=PX(I-1)+PXINC
      PX2=PX(I)+PXINC
      PY1=PY(I-1)+PYINC
      PY2=PY(I)+PYINC
      CALL DPARR3(
     1PX1,PY1,PX2,PY2,
     1IFIG,
     1ITRCSW,
     1IPATT(1:4),ICOL,PTHICK,
     1IFILL,ICOL,
     1ICOL,PTHICK,PREPSP,
     1PHEIGH,PWIDTH,PVEGAP,PHOGAP)
 510  CONTINUE
      GOTO9000
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DRPM')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF GRDRPM--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)NP
 9012 FORMAT('NP = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)IMANUF
 9013 FORMAT('IMANUF = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9014)IFONT,NCSTRI
 9014 FORMAT('IFONT,NCSTRI = ',A4,I8)
      CALL DPWRST('XXX','BUG ')
      DO9015I=1,NP
      WRITE(ICOUT,9016)PX(I),PY(I)
 9016 FORMAT('PX(I),PY(I) = ',E15.7,E15.7)
      CALL DPWRST('XXX','BUG ')
 9015 CONTINUE
      WRITE(ICOUT,9018)IFIG
 9018 FORMAT('IFIG = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9019)IPATT,JPATT
 9019 FORMAT('IPATT,JPATT = ',A16,I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9020)IFONT,JFONT
 9020 FORMAT('IFONT,JFONT = ',A4,I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9021)ICASE,JCASE
 9021 FORMAT('ICASE,JCASE = ',A4,I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9022)IJUST,JJUST
 9022 FORMAT('IJUST,JJUST = ',A4,I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9023)IDIR,ANGLE,JDIR
 9023 FORMAT('IDIR,ANGLE,JDIR = ',A4,2X,E15.7,I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9024)ICOL,JCOL
 9024 FORMAT('ICOL,JCOL = ',A4,I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9026)PTHICK,JTHICK,PTHIC2
 9026 FORMAT('PTHICK,JTHICK,PTHIC2 = ',E15.7,I8,E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9027)PHEIGH,PWIDTH,PVEGAP,PHOGAP
 9027 FORMAT('PHEIGH,PWIDTH,PVEGAP,PHOGAP = ',4E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9028)PHEIG2,PWIDT2,PVEGA2,PHOGA2
 9028 FORMAT('PHEIG2,PWIDT2,PVEGA2,PHOGA2 = ',4E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9031)ISYMBL,ISPAC
 9031 FORMAT('ISYMBL,ISPAC = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9039)IBUGG4,ISUBG4,IERRG4
 9039 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE GRFIR2(PX,PY,NP,PXSPA2,PYSPA2,IFACTO,
     1                  IHORPA,IVERPA,IDUPPA,IDDOPA,JCOL)
C
C     PURPOSE--FOR A GENERAL GRAPHICS DEVICE, DRAW A SOLID VERTICAL
C              PATTERN WITHIN A GENERAL POLYLINE WITH THE ONLY
C              CONSTRAINT THAT A GIVEN X VALUE HAVE AT MOST 2 Y VALUES.
C     NOTE--THE COORDINATES IN (PX(.),PY(.)) ARE IN
C           STANDARDIZED (0.0 TO 100.0) UNITS.
C     NOTE--THERE ARE NP SUCH COORDINATE PAIRS.
C
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--83.6
C     ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MAY       1983.
C     UPDATED         --JUNE      1990. TEMPORARY ARRAYS TO GARBAGE COMMON
C     UPDATED         --JULY      2001. ADD COLOR INDEX (FOR GD DEVICE)
C     UPDATED         --JULY      2019. TWEAK SCRATCH STORAGE
C
C-----NON-COMMON VARIABLES (GRAPHICS)-------------------------------------------
C
      CHARACTER*4 IHORPA
      CHARACTER*4 IVERPA
      CHARACTER*4 IDUPPA
      CHARACTER*4 IDDOPA
C
      CHARACTER*4 ISUBN0
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOPA.INC'
C
      DIMENSION PX(*)
      DIMENSION PY(*)
C
      DIMENSION PXS(MAXPOP)
      DIMENSION PYS(MAXPOP)
      INCLUDE 'DPCOZZ.INC'
      EQUIVALENCE (GARBAG(IGRG10),PXS(1))
      EQUIVALENCE (GARBAG(IGRG11),PYS(1))
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOGR.INC'
      INCLUDE 'DPCOBE.INC'
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN0='FIR2'
C
      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'FIR2')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF GRFIR2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)NP
   52 FORMAT('NP = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO55I=1,NP
      WRITE(ICOUT,56)I,PX(I),PY(I)
   56 FORMAT('I,PX(I),PY(I) = ',I8,2E15.7)
      CALL DPWRST('XXX','BUG ')
   55 CONTINUE
      WRITE(ICOUT,57)PXSPA2,PYSPA2
   57 FORMAT('PXSPA2,PYSPA2 = ',2E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,58)IFACTO
   58 FORMAT('IFACTO = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,61)IHORPA,IVERPA,IDUPPA,IDDOPA
   61 FORMAT('IHORPA,IVERPA,IDUPPA,IDDOPA = ',A4,2X,A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,69)IBUGG4,ISUBG4,IERRG4
   69 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
   90 CONTINUE
C
C               ************************************
C               **  STEP 1--                      **
C               **  SORT THE X COORDINATES        **
C               **  AND CARRY ALONG THE Y VALUES  **
C               ************************************
C
      IF(NP.LE.1000)GOTO1010
      GOTO1090
 1010 CONTINUE
      CALL SORTC(PX,PY,NP,PXS,PYS)
 1090 CONTINUE
C
C               **************************************
C               **  STEP 2--                        **
C               **  ITERATE WITHIN EACH X INTERVAL  **
C               **************************************
C
      NPM1=NP-1
      DO1100I=1,NPM1
      IP1=I+1
C
C               ****************************************
C               **  STEP 2.1--                        **
C               **  FIND THE MIDPOINT OF THE INTERVAL **
C               ****************************************
C
      IF(NP.LE.1000)GOTO1110
      GOTO1120
C
 1110 CONTINUE
      XI=PXS(I)
      YI=PYS(I)
      XIP1=PXS(IP1)
      YIP1=PYS(IP1)
      GOTO1180
C
 1120 CONTINUE
      XI=PX(I)
      YI=PY(I)
      XIP1=PX(IP1)
      YIP1=PY(IP1)
      GOTO1180
C
 1180 CONTINUE
      XMID=(XI+XIP1)/2.0
      YMID=(YI+YIP1)/2.0
C
      IF(IBUGG4.EQ.'ON')WRITE(ICOUT,1181)XI,YI,XIP1,YIP1,XMID,YMID
 1181 FORMAT('XI,YI,XIP1,YIP1,XMID,YMID = ',6E15.7)
      IF(IBUGG4.EQ.'ON')CALL DPWRST('XXX','BUG ')
C
C               *************************************
C               **  STEP 2.2--                     **
C               **  FIND THE ENDPOINT COORDINATES  **
C               **  OF ONE BOUNDING LINE SEGMENT.  **
C               *************************************
C
      DO1200J=1,NPM1
      JP1=J+1
      J1=J
      J2=J1+1
      IF(PX(J).LE.XMID.AND.XMID.LE.PX(JP1))GOTO1250
      IF(PX(JP1).LE.XMID.AND.XMID.LE.PX(J))GOTO1250
 1200 CONTINUE
      J1=NP
      J2=1
 1250 CONTINUE
      PX1=PX(J1)
      PY1=PY(J1)
      PX2=PX(J2)
      PY2=PY(J2)
      J2SAVE=J2
C
      IF(IBUGG4.EQ.'ON')WRITE(ICOUT,1221)J1,J2,J2SAVE
 1221 FORMAT('J1,J2,J2SAVE = ',3I8)
      IF(IBUGG4.EQ.'ON')CALL DPWRST('XXX','BUG ')
      IF(IBUGG4.EQ.'ON')WRITE(ICOUT,1222)PX1,PY1,PX2,PY2
 1222 FORMAT('PX1,PY1,PX2,PY2 = ',4E15.7)
      IF(IBUGG4.EQ.'ON')CALL DPWRST('XXX','BUG ')
C
C               *******************************************
C               **  STEP 2.3--                           **
C               **  FIND THE ENDPOINT COORDINATES        **
C               **  OF THE OTHER BOUNDING LINE SEGMENT.  **
C               *******************************************
C
      J3=J2SAVE
      J4=J3+1
      IF(J4.GT.NP)J4=1
      JMIN=J2SAVE
      IF(JMIN.GE.NP)GOTO1350
      DO1300J=JMIN,NPM1
      JP1=J+1
      J3=J
      J4=J3+1
      IF(PX(J).LE.XMID.AND.XMID.LE.PX(JP1))GOTO1350
      IF(PX(JP1).LE.XMID.AND.XMID.LE.PX(J))GOTO1350
 1300 CONTINUE
      J3=NP
      J4=1
 1350 CONTINUE
      PX3=PX(J3)
      PY3=PY(J3)
      PX4=PX(J4)
      PY4=PY(J4)
C
      IF(IBUGG4.EQ.'ON')WRITE(ICOUT,1321)J1,J2,J2SAVE,JMIN,J3,J4
 1321 FORMAT('J1,J2,J2SAVE,JMIN,J3,J4 = ',6I8)
      IF(IBUGG4.EQ.'ON')CALL DPWRST('XXX','BUG ')
      IF(IBUGG4.EQ.'ON')WRITE(ICOUT,1322)PX3,PY3,PX4,PY4
 1322 FORMAT('PX3,PY3,PX4,PY4 = ',4E15.7)
      IF(IBUGG4.EQ.'ON')CALL DPWRST('XXX','BUG ')
C
C               *****************************************
C               **  STEP 2.4--                        **
C               **  DETERMINE THE INTERCEPT AND SLOPE  **
C               **  OF ONE BOUNDING LINE SEGMENT.      **
C               *****************************************
C
      IF(PX1.EQ.PX2)GOTO1411
      IF(PY1.EQ.PY2)GOTO1412
      GOTO1413
C
 1411 CONTINUE
      AM12=CPUMAX
      B12=CPUMAX
      GOTO1419
C
 1412 CONTINUE
      AM12=0.0
      B12=PY1
      GOTO1419
C
 1413 CONTINUE
      AM12=(PY2-PY1)/(PX2-PX1)
      B12=PY1-AM12*PX1
      GOTO1419
C
 1419 CONTINUE
C
      IF(IBUGG4.EQ.'ON')WRITE(ICOUT,1421)AM12,B12
 1421 FORMAT('AM12,B12 = ',2E15.7)
      IF(IBUGG4.EQ.'ON')CALL DPWRST('XXX','BUG ')
C
C               *******************************************
C               **  STEP 2.5--                          **
C               **  DETERMINE THE INTERCEPT AND SLOPE    **
C               **  OF THE OTHER BOUNDING LINE SEGMENT.  **
C               *******************************************
C
      IF(PX3.EQ.PX4)GOTO1511
      IF(PY3.EQ.PY4)GOTO1512
      GOTO1513
C
 1511 CONTINUE
      AM34=CPUMAX
      B34=CPUMAX
      GOTO1519
C
 1512 CONTINUE
      AM34=0.0
      B34=PY3
      GOTO1519
C
 1513 CONTINUE
      AM34=(PY4-PY3)/(PX4-PX3)
      B34=PY3-AM34*PX3
      GOTO1519
C
 1519 CONTINUE
C
      IF(IBUGG4.EQ.'ON')WRITE(ICOUT,1521)AM34,B34
 1521 FORMAT('AM34,B34 = ',2E15.7)
      IF(IBUGG4.EQ.'ON')CALL DPWRST('XXX','BUG ')
C
C               *********************************
C               **  STEP 2.6--                 **
C               **  FILL THE LOCAL SUB-REGION  **
C               *********************************
C
      XDEL=PXSPA2
      X=XI-XDEL
 1600 CONTINUE
        X=X+XDEL
        IF(X.GT.XIP1)GOTO1690
        PX5=X
        PY5=PY1
        IF(AM12.NE.CPUMAX.AND.B12.NE.CPUMAX)PY5=AM12*X+B12
        PX6=X
        PY6=PY3
        IF(AM34.NE.CPUMAX.AND.B34.NE.CPUMAX)PY6=AM34*X+B34
C
        IF(IBUGG4.EQ.'ON')THEN
          WRITE(ICOUT,1611)X,PX5,PY5,PX6,PY6
 1611     FORMAT('X,PX5,PY5,PX6,PY6 = ',5E15.7)
          CALL DPWRST('XXX','BUG ')
        ENDIF
C
        CALL GRTRSD(PX5,PY5,IX5,IY5,ISUBN0)
        CALL GRTRSD(PX6,PY6,IX6,IY6,ISUBN0)
CCCCC   JULY 2001.  ADD COLOR INDEX (NEEDED FOR GD DEVICE)
CCCCC   CALL GRDRLI(IX5,IY5,IX6,IY6,PX5,PY5,PX6,PY6,IFACTO)
        CALL GRDRLI(IX5,IY5,IX6,IY6,PX5,PY5,PX6,PY6,IFACTO,JCOL)
      GOTO1600
C
 1690 CONTINUE
C
 1100 CONTINUE
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'FIR2')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF GRFIR2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)NP
 9012 FORMAT('NP = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO9015I=1,NP
      WRITE(ICOUT,9016)I,PX(I),PY(I)
 9016 FORMAT('I,PX(I),PY(I) = ',I8,2E15.7)
      CALL DPWRST('XXX','BUG ')
 9015 CONTINUE
      WRITE(ICOUT,9017)PXSPA2,PYSPA2
 9017 FORMAT('PXSPA2,PYSPA2 = ',2E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9018)IFACTO
 9018 FORMAT('IFACTO = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9021)IHORPA,IVERPA,IDUPPA,IDDOPA
 9021 FORMAT('IHORPA,IVERPA,IDUPPA,IDDOPA = ',A4,2X,A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9029)IBUGG4,ISUBG4,IERRG4
 9029 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE GRFIR3(PX,PY,NP,PXSPA,PYSPA,IFACTO,
     1                  IHORPA,IVERPA,IDUPPA,IDDOPA,
     1                  IPATT2,PTHICK,ICOL)
C
C     PURPOSE--FOR A GENERAL GRAPHICS DEVICE, FILL A POLYGON (CONVEX OR
C              CONCAVE) WITH A HATCH PATTERN.  THE ROUTINE GRHTCH
C              ACTUALLY DOES THE FILL.  THIS ROUTINE IS THE DRIVER FOR
C              THE 4 CASES OF VERTICAL, HORIZONTAL, UP DIAGONAL, DOWN
C              DIAGONAL.  SOLID FILLS ARE HANDLED VIA THE VERTICAL WITH
C              A SMALL SPACING.
C     NOTE--THE COORDINATES IN (PX(.),PY(.)) ARE IN
C           STANDARDIZED (0.0 TO 100.0) UNITS.
C     NOTE--THERE ARE NP SUCH COORDINATE PAIRS.
C
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--93.10
C     ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--OCTOBER   1993.
C     UPDATED         --JULY      2019. TWEAK SCRATCH STORAGE
C
C-----NON-COMMON VARIABLES (GRAPHICS)---------------------------------
C
      CHARACTER*4 IHORPA
      CHARACTER*4 IVERPA
      CHARACTER*4 IDUPPA
      CHARACTER*4 IDDOPA
C
      CHARACTER*4 ISUBN0
C
      CHARACTER*4 IPATT2
      CHARACTER*4 IFIG
      CHARACTER*4 ICOL
      CHARACTER*4 IDIR
C
      DIMENSION PX(*)
      DIMENSION PY(*)
C
      INCLUDE 'DPCOPA.INC'
      INCLUDE 'DPCOZZ.INC'
      DIMENSION PXS(MAXPOP)
      DIMENSION PYS(MAXPOP)
      EQUIVALENCE (GARBAG(IGRG10),PXS(1))
      EQUIVALENCE (GARBAG(IGRG11),PYS(1))
C
C
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOGR.INC'
      INCLUDE 'DPCOBE.INC'
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN0='FIR3'
      IFIG='LINE'
C
      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'FIR3')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF GRFIR3--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)NP
   52 FORMAT('NP = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO55I=1,NP
      WRITE(ICOUT,56)I,PX(I),PY(I)
   56 FORMAT('I,PX(I),PY(I) = ',I8,2E15.7)
      CALL DPWRST('XXX','BUG ')
   55 CONTINUE
      WRITE(ICOUT,57)PXSPA,PYSPA
   57 FORMAT('PXSPA,PYSPA = ',2E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,58)IFACTO
   58 FORMAT('IFACTO = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,61)IHORPA,IVERPA,IDUPPA,IDDOPA
   61 FORMAT('IHORPA,IVERPA,IDUPPA,IDDOPA = ',A4,2X,A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,69)IBUGG4,ISUBG4,IERRG4
   69 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,70)IPATT2,PTHICK,ICOL
   70 FORMAT('IPATT2,PTHICK,ICOL = ',A4,2X,E15.7,2X,A4)
      CALL DPWRST('XXX','BUG ')
   90 CONTINUE
C
C               ************************************
C               **  STEP 0--                      **
C               **  SORT THE X COORDINATES        **
C               **  AND CARRY ALONG THE Y VALUES  **
C               **  FILTER OUT POINTS IF NOT ENOUGH*
C               **  CHANGE.                       **
C               ************************************
C
      EPSX=0.001
      EPSY=0.001
C
      BXMIN=PX(1)
      BYMIN=PY(1)
      BXMAX=BXMIN
      BYMAX=BYMIN
      PXS(1)=PX(1)
      PYS(1)=PY(1)
      J=1
      DO10I=2,NP
        IF(ABS(PX(I)-PXS(J)).LE.EPSX .AND. ABS(PY(I)-PYS(J)).LE.EPSY)
     1     GOTO10
        J=J+1
        PXS(J)=PX(I)
        IF(PXS(J).LT.BXMIN)BXMIN=PXS(J)
        IF(PXS(J).GT.BXMAX)BXMAX=PXS(J)
        PYS(J)=PY(I)
        IF(PYS(J).LT.BYMIN)BYMIN=PYS(J)
        IF(PYS(J).GT.BYMAX)BYMAX=PYS(J)
 10   CONTINUE
      NP2=J
CCCCC IF(PXS(1).EQ.PXS(NP).AND.PYS(1).EQ.PYS(NP))NP2=NP-1
      BX=(BXMIN + BXMAX)/2.0
      BY=(BYMIN + BYMAX)/2.0
      IF(NP2.LT.3)GOTO9000
C
C               ***************************************************
C               **  STEP 1--                                     **
C               **  DRAW THE HORIZONTAL STRIPES (IF CALLED FOR)  **
C               ***************************************************
C
      IF(IHORPA.EQ.'ON')GOTO1100
      GOTO1190
 1100 CONTINUE
      IDIR='HORI'
      DIST=PXSPA
      CALL GRPLPX(PXS,PYS,NP2,IDIR,DIST,IPATT2,PTHICK,ICOL)
 1190 CONTINUE
C
C               ***************************************************
C               **  STEP 2--                                     **
C               **  DRAW THE VERTICAL   STRIPES (IF CALLED FOR)  **
C               ***************************************************
C
      IF(IVERPA.EQ.'ON')GOTO1200
      GOTO1290
 1200 CONTINUE
      IDIR='VERT'
      DIST=PYSPA
      CALL GRPLPX(PXS,PYS,NP2,IDIR,DIST,IPATT2,PTHICK,ICOL)
 1290 CONTINUE
C
C               ******************************************************
C               **  STEP 3--                                        **
C               **  DRAW THE UP-DIAGONAL   STRIPES (IF CALLED FOR)  **
C               ******************************************************
C
      IF(IDUPPA.EQ.'ON')GOTO1300
      GOTO1390
 1300 CONTINUE
      DX=1.0
      DY=1.0
      DIST=PXSPA
      CALL GRHTCH(PXS,PYS,NP2,BX,BY,DX,DY,DIST,IPATT2,PTHICK,ICOL)
C
 1390 CONTINUE
C
C               ******************************************************
C               **  STEP 4--                                        **
C               **  DRAW THE DOWN-DIAGONAL STRIPES (IF CALLED FOR)  **
C               ******************************************************
C
      IF(IDDOPA.EQ.'ON')GOTO1400
      GOTO1490
 1400 CONTINUE
      DX=1.0
      DY=-1.0
      DIST=PXSPA
      CALL GRHTCH(PXS,PYS,NP2,BX,BY,DX,DY,DIST,IPATT2,PTHICK,ICOL)
 1490 CONTINUE
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'FIR3')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF GRFIR3--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)NP2
 9012 FORMAT('NP = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO9015I=1,NP2
      WRITE(ICOUT,9016)I,PXS(I),PYS(I)
 9016 FORMAT('I,PXS(I),PYS(I) = ',I8,2E15.7)
      CALL DPWRST('XXX','BUG ')
 9015 CONTINUE
      WRITE(ICOUT,9017)PXSPA,PYSPA
 9017 FORMAT('PXSPA,PYSPA = ',2E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9018)IFACTO
 9018 FORMAT('IFACTO = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9021)IHORPA,IVERPA,IDUPPA,IDDOPA
 9021 FORMAT('IHORPA,IVERPA,IDUPPA,IDDOPA = ',A4,2X,A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9029)IBUGG4,ISUBG4,IERRG4
 9029 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE GRHTCH(X,Y,N,BX,BY,DX,DY,DIST,
     1IPATT2,PTHICK,ICOL)
C
C     PURPOSE--ROUTINE TO FILL A POLYGON WITH A HATCHING PATTERN.
C              ASSUME EQUI-SPACED PARRALLEL LINES (DIST = DISTANCE
C              BETWEEN PARRALLEL LINES).  EACH LINE HAS A DIRECTION
C              VECTOR DX,DY AND A BASE VECTOR BX,BY).
C              MAXP IS THE LIMIT ON THE FACET SIZE (SHOULD BE
C              ADEQUATE FOR DATAPLOT PURPOSES).
C     ALGORITHM--CODE IS FROM "HIGH-RESOLUTION COMPUTER GRAPHICS USING
C              FORTRAN 77" BY ANGEL AND GRIFFITH (PP 93-94).
C     VERSION NUMBER--93.10
C     ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--OCTOBER   1993.
C
      PARAMETER(MAXP=1000)
      REAL X(*)
      REAL Y(*)
C
      REAL PX(2)
      REAL PY(2)
      REAL PX2(MAXP)
      REAL PY2(MAXP)
C
      CHARACTER*4 IFIG
      CHARACTER*4 IFLAG
      CHARACTER*4 IPATT2
      CHARACTER*4 ICOL
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      IF(N.LE.3)GOTO9000
      EPS=0.000001
CCCCC FIND CMID, CMIN, CMAX
C
      CMID=DX*BY - DY*BX
      CMIN=DX*Y(1) - DY*X(1)
      CMAX=CMIN
      DO101I=2,N
        C=DX*Y(I)-DY*X(I)
        IF(C.LT.CMIN)THEN
          CMIN=C
        ELSEIF(C.GT.CMAX)THEN
          CMAX=C
        ENDIF
 101  CONTINUE
C
CCCCC CONSTRUCT VECTOR (SX,SY)
C
      DMOD=SQRT(DX**2+DY**2)
      SX=-DIST/DMOD*DY
      SY=DIST/DMOD*DX
C
CCCCC CALCULATE NMIN AND NMAX
C
      NMIN=IFIX((CMIN-CMID)/(DIST*DMOD)+0.9999)
      NMAX=IFIX((CMAX-CMID)/(DIST*DMOD))
C
CCCCC HATCH THE POLYGON
C
      DO401J=NMIN,NMAX
C
CCCCC FIND THE BASE VECTOR OF THE HATCHING LINE
C
        QX=BX+REAL(J)*SX
        QY=BY+REAL(J)*SY
C
CCCCC FIND THE INTERSECTIONS OF THE HATCHING LINE WITH THE
CCCCC EDGES OF THE POLYGON.
CCCCC EX = 0 (X(I)=X(NI)) AND EY = 0 (Y(I)=Y(NI)) ARE SPECIAL CASES.
C
        NINT=0
        NI=N
        DO201I=1,N
          EX=X(I)-X(NI)
          EY=Y(I)-Y(NI)
          CALL GRILL2(X(NI),Y(NI),EX,EY,QX,QY,DX,DY,XI,YI,ISEC)
          IF(ISEC.EQ.1)THEN
            NINT=NINT+1
            PX2(NINT)=XI
            PY2(NINT)=YI
          ENDIF
          NI=I
 201    CONTINUE
        IF(NINT.EQ.0)GOTO401
C
CCCCC SORT RMU VALUES INTO ORDER
C
        CALL SORTC(PX2,PY2,NINT,PX2,PY2)
C
CCCCC JOIN CORRESPONDING PAIRS OF INTERSECTIONS
C
        IFLAG='ON'
        IFIG='LINE'
        NP2=2
        NI=1
 399    CONTINUE
        IF(NI+1.LE.NINT)THEN
          PX(1)=PX2(NI)
          PY(1)=PY2(NI)
          PX(2)=PX2(NI+1)
          PY(2)=PY2(NI+1)
          CALL DPDRPL(PX,PY,NP2,
     1                IFIG,IPATT2,PTHICK,ICOL,
     1                JPATT,JTHICK,PTHIC2,JCOL,IFLAG)
          IFLAG='OFF'
          NI=NI+2
          GOTO399
        ENDIF
C
 401  CONTINUE
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE GRIDD(NI,NJ,FC,GC,BFI,BFJ,POI,POJ,XX,YY,EPS3,CDFX,
     *   IFLAG)
CCCCC DOUBLE PRECISION VERSION OF GRID.  THE DOUBLY NON-CENTRAL T
CCCCC CDF FUNCTION SEEMS TO REQUIRE DOUBLE PRECISION (THE DOUBLY
CCCCC NON-CENTRAL F SEEMS TO WORK FINE IN SINGLE PRECISION).
C
C--- COMPUTE DOUBLE SUMMATION OF COMPONENTS OF THE T" C.D.F. OVER THE
C--- GRID I=IMIN TO IMAX AND J=JMIN TO JMAX
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      DIMENSION BFI(*),BFJ(*),POI(*),POJ(*)
C
C--- COMPUTE BETA C.D.F. BY RECURRENCE WHEN I=IMIN, J=JMIN TO JMAX
C
      CALL EDGET(NJ,GC,FC,YY,XX,BFJ,CDFX,POJ,POI,EPS3,IFLAG,1)
      IF (NI.LE.1.OR.IFLAG.NE.0) RETURN
C
C--- COMPUTE BETA C.D.F. BY RECURRENCE WHEN J=JMIN, I=IMIN TO IMAX
C
      BFI(1) = BFJ(1)
      CALL EDGET (NI,FC,GC,XX,YY,BFI,CDFX,POI,POJ,EPS3,IFLAG,2)
      IF (NJ.LE.1.OR.IFLAG.NE.0) RETURN
C
C--- COMPUTE BETA C.D.F. BY RECURRENCE WHEN I>IMIN, J>JMIN
C
      DO 20 I = 2, NI
         BFJ(1) = BFI(I)
         DO 10 J = 2, NJ
            BFJ(J) = XX*BFJ(J)+YY*BFJ(J-1)
            CDFX = CDFX+POI(I)*POJ(J)*BFJ(J)
   10    CONTINUE
   20 CONTINUE
      RETURN
      END
      SUBROUTINE GRILL2(X1,Y1,X2,Y2,X3,Y3,X4,Y4,X,Y,ISEC)
C
C     PURPOSE--UTILITY ROUTINE USED BY GRHTCH
C              FIND THE POINT OF INTERSECTION (X,Y) OF 2 LINES
C              IN THE FORM (X1,Y1)+RMU*(X2,Y2) AND
C              (X2,Y3)*RLAM(X4,Y4).
C              ISEC IS 1 IF INTERSECTION EXISTS, 0 IF NOT.
C     ALGORITHM--CODE IS FROM "HIGH-RESOLUTION COMPUTER GRAPHICS USING
C              FORTRAN 77" BY ANGEL AND GRIFFITH (PP 44-45).
C     VERSION NUMBER--93.10
C     ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--OCTOBER   1993.
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
      DATA EPS/0.0000001/
C
C-----START POINT-----------------------------------------------------
C
      DELTA=X2*Y4-Y2*X4
C
C  IF DELTA IS ZERO, PARALLEL LINES
C  IF RMU > 1 OR RMU < 0, THEN POINT LIES OFF LINE.
C
      ISEC=0
      IF(ABS(DELTA).GE.EPS)THEN
        RMU=((X3-X1)*Y4 - (Y3-Y1)*X4)/DELTA
        IF(RMU.GE.0.0 .AND.RMU.LE.1.0)THEN
          ISEC=1
          X=X1+RMU*X2
          Y=Y1+RMU*Y2
        ENDIF
      ENDIF
C
      RETURN
      END
      SUBROUTINE GRPCOR(X,Y,W,N,IWRITE,CORR,
     1                  DIST,TEMP1,MAXOBV,
     1                  IBUGA3,ISUBRO,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE SAMPLE GROUPED DATA
C              CORRELATION COEFFIENT OF THE DATA IN X AND Y WITH THE
C              FREQUENCIES IN W.
C
C              THE DATA FOR A GROUPED CORRELATION IS TAKEN FROM A
C              BIVARIATE FREQUENCY TABLE.  FOR EXAMPLE, THE FOLLOWING
C              TABLE
C
C                       10-20    20-30     30-40    40-50    50-60
C                15-25    6        3         0        0        0
C                25-35    3       16        10        0        0
C                35-45    0       10        15        7        0
C                45-55    0        0         7       10        4
C                55-65    0        0         0        4        5
C
C              THIS WOULD BE CODED TO DATAPLOT AS
C
C                  X     Y  FREQ
C              =================
C                 20    15     6
C                 20    25  3
C                 20    35  0
C                 20    45  0
C                 20    55  0
C                 30    15  3
C                 30    25 16
C                 30    35 10
C                 30    45  0
C                 30    55  0
C                 40    15  0
C                 40    25 10
C                 40    35 15
C                 40    45  7
C                 40    55  0
C                 50    15  0
C                 50    25  0
C                 50    35  7
C                 50    45 10
C                 50    55  4
C                 60    15  0
C                 60    25  0
C                 60    35  0
C                 60    45  4
C                 60    55  5
C
C              THE COMPUTATIONAL FORMULA IS THEN
C
C                  r = N*C1 - C2*C3/SQRT(N*C4 - C2**2)*(N*C5 - C3**2))
C
C              WHERE
C
C                      F(i)   = THE FREQUENCY OF THE i-TH GROUP
C                      K      = THE NUMBER OF GROUPS
C                      N      = THE SUM OF ALL THE FREQUENCIES
C                      X(i)   = THE VALUE FOR RESPONSE VARIABLE ONE
C                               FOR THE i-TH GROUP
C                      Y(i)   = THE VALUE FOR RESPONSE VARIABLE TWO
C                               FOR THE i-TH GROUP
C                      C1     = SUM[i=1 to k][F(i)*X(i)*Y(i)]
C                      C2     = SUM[i=1 to k][F(i)*X(i)]
C                      C3     = SUM[i=1 to k][F(i)*Y(i)]
C                      C4     = SUM[i=1 to k][F(i)*X(i)**2]
C                      C5     = SUM[i=1 to k][F(i)*Y(i)**2]
C
C              IF THE CLASSES ARE EQUAL WIDTH, THEN THE X AND Y
C              CAN BE CODED FOR COMPUTATIONAL SIMPLICITY.
C
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF UNSORTED
C                                OBSERVATIONS FOR THE FIRST RESPONSE
C                                VARIABLE
C                     --Y      = THE SINGLE PRECISION VECTOR OF UNSORTED
C                                OBSERVATIONS FOR THE SECOND RESPONSE
C                                VARIABLE
C                     --W      = THE SINGLE PRECISION VECTOR OF
C                                FREQUENCIES.
C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTORS X, Y AND W.
C     OUTPUT ARGUMENTS--CORR   = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED SAMPLE GROUPED CORRELATION.
C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE SAMPLE GROUPED
C             CORRELATION OF 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--SQRT.
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--2018/11
C     ORIGINAL VERSION--NOVEMBER  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
      DOUBLE PRECISION DN
      DOUBLE PRECISION DX
      DOUBLE PRECISION DY
      DOUBLE PRECISION DW
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DSUM2
      DOUBLE PRECISION DSUM3
      DOUBLE PRECISION DSUM4
      DOUBLE PRECISION DSUM5
      DOUBLE PRECISION DNUM
      DOUBLE PRECISION DENOM
C
      DIMENSION X(*)
      DIMENSION Y(*)
      DIMENSION W(*)
      DIMENSION DIST(*)
      DIMENSION TEMP1(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='GRPC'
      ISUBN2='OR  '
      IERROR='NO'
C
      DN=0.0D0
      DSUM1=0.0D0
      DSUM2=0.0D0
      DSUM3=0.0D0
      DSUM4=0.0D0
      DSUM5=0.0D0
      CORR=0.0
C
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'PCOR')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,51)
   51   FORMAT('***** AT THE BEGINNING OF GRPCOR--')
        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),W(I)
   56     FORMAT('I,X(I),Y(I),W(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
C
      IF(N.LT.1)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,111)
  111   FORMAT('***** ERROR IN GROUPED CORRELATION--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,112)
  112   FORMAT('      THE INPUT NUMBER OF OBSERVATIONS IS LESS THAN ',
     1         'ONE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,117)N
  117   FORMAT('      THE INPUT NUMBER OF OBSERVATIONS = ',I8)
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        GOTO9000
      ELSEIF(N.EQ.1)THEN
        CORR=1.0
        GOTO9000
      ENDIF
C
C     CODE THE X AND Y FOR BETTER NUMERICAL STABILITY (BUT ONLY
C     IF BINS APPEAR TO BE EQUAL WIDTH)
C
      ICODEX=1
      CALL DISTIN(X,N,IWRITE,DIST,NDIST,IBUGA3,IERROR)
      CALL SORT(DIST,NDIST,DIST)
      DEL=CPUMIN
      DO160I=2,NDIST
        DELT=DIST(I) - DIST(I-1)
        IF(DEL.GT.0.0)THEN
          IF(DELT.NE.DEL)THEN
            ICODEX=0
            GOTO164
          ENDIF
        ENDIF
  160 CONTINUE
  164 CONTINUE
      IF(ICODEX.EQ.1)THEN
        CALL CODE(X,N,IWRITE,TEMP1,DIST,MAXOBV,IBUGA3,IERROR)
        DO169I=1,N
          X(I)=TEMP1(I)
  169   CONTINUE
      ENDIF
C
      ICODEY=1
      CALL DISTIN(Y,N,IWRITE,DIST,NDIST,IBUGA3,IERROR)
      CALL SORT(DIST,NDIST,DIST)
      DEL=CPUMIN
      DO170I=2,NDIST
        DELT=DIST(I) - DIST(I-1)
        IF(DEL.GT.0.0)THEN
          IF(DELT.NE.DEL)THEN
            ICODEY=0
            GOTO174
          ELSE
            DEL=DELT
          ENDIF
        ENDIF
  170 CONTINUE
  174 CONTINUE
      IF(ICODEY.EQ.1)THEN
        CALL CODE(Y,N,IWRITE,TEMP1,DIST,MAXOBV,IBUGA3,IERROR)
        DO179I=1,N
          Y(I)=TEMP1(I)
  179   CONTINUE
      ENDIF
C
C     CHECK FOR NEGATIVE WEIGHTS, REMOVE ANY ROWS WITH
C     ZERO WEIGHT.  ALSO, SINCE THE WEIGHTS IN THIS CASE
C     ARE FRQUENCIES, ROUND TO NEAREST INTEGER.
C
      ICNT=0
      NTOT=0
      DO120I=1,N
C
        IF(W(I).LT.0.0)THEN
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,111)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,122)I,W(I)
  122     FORMAT('      ROW ',I8,' HAS A NEGATIVE WEIGHT (',G15.7,').')
          CALL DPWRST('XXX','BUG ')
          IERROR='YES'
          GOTO9000
        ELSEIF(W(I).GT.0.0)THEN
          IVAL=INT(W(I)+0.5)
          IF(IVAL.LT.1)GOTO120
          ICNT=ICNT+1
          NTOT=NTOT+IVAL
          Y(ICNT)=Y(I)
          X(ICNT)=X(I)
          W(ICNT)=REAL(IVAL)
        ENDIF
C
  120 CONTINUE
      N=ICNT
      DN=REAL(NTOT)
C
C               ************************************************
C               **  STEP 11--                                 **
C               **  COMPUTE THE GROUPED CORRELATION           **
C               ************************************************
C
      DO1100I=1,N
C
        DX=DBLE(X(I))
        DY=DBLE(Y(I))
        DW=DBLE(W(I))
        DSUM1=DSUM1 + DX*DY*DW
        DSUM2=DSUM2 + DX*DW
        DSUM3=DSUM3 + DY*DW
        DSUM4=DSUM4 + DX*DX*DW
        DSUM5=DSUM5 + DY*DY*DW
C
 1100 CONTINUE
      DNUM=DN*DSUM1 - DSUM2*DSUM3
      DENOM=(DN*DSUM4 - DSUM2**2)*(DN*DSUM5 - DSUM3**2)
      IF(DENOM.GT.0.0D0)THEN
        DENOM=DSQRT(DENOM)
        DCORR=DNUM/DENOM
        CORR=REAL(DCORR)
      ELSE
        CORR=0.0
      ENDIF
C
C               *******************************
C               **  STEP 12--                **
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,1213)N,CORR
 1213   FORMAT('THE GROUPED CORRELATION OF THE ',I8,
     1           ' OBSERVATIONS = ',G15.7)
      ENDIF
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'PCOR')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END       OF GRPCOR--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9014)IERROR,DN,DNUM,DENOM,DCORR
 9014   FORMAT('IERROR,DN,DNUM,DENOM,DCORR = ',A4,2X,4G15.7)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9015)DSUM1,DSUM2,DSUM3,DSUM4,DSUM5
 9015   FORMAT('DSUM1,DSUM2,DSUM3,DSUM4,DSUM5 = ',5G15.7)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9017)ICODEX,ICODEY
 9017   FORMAT('ICODEX,ICODEY = ',2I5)
        CALL DPWRST('XXX','BUG ')
        IF(ICODEX.EQ.1 .OR. ICODEY.EQ.1)THEN
          DO9019I=1,N
            WRITE(ICOUT,9018)I,X(I),Y(I)
 9018       FORMAT('I,X,Y = ',I8,2X,2F10.1)
            CALL DPWRST('XXX','BUG ')
 9019     CONTINUE
        ENDIF
      ENDIF
C
      RETURN
      END
      SUBROUTINE GRPLPX(X,Y,N,IDIR,DIST,IPATT2,PTHICK,ICOL)
C
C     PURPOSE--ROUTINE TO FILL A POLYGON WITH A HORIZONTAL OR VERTICAL
C              HATCHING PATTERN.
C              ASSUME EQUI-SPACED PARRALLEL LINES (DIST = DISTANCE
C              BETWEEN PARALLEL LINES).
C     ALGORITHM--CODE IS FROM "HIGH-RESOLUTION COMPUTER GRAPHICS USING
C              FORTRAN 77" BY ANGEL AND GRIFFITH (PP 95-96).
C              MODIFIED THEIR INTEGER VERSION TO ONE WITH REAL NUMBERS.
C     VERSION NUMBER--93.11
C     ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--NOVEMBER  1993.
C
      PARAMETER(MAXP=1000)
      REAL X(*)
      REAL Y(*)
C
      PARAMETER (MAXINT=100)
      REAL PX(MAXINT)
      REAL PY(MAXINT)
      REAL PX2(2)
      REAL PY2(2)
C
      CHARACTER*4 IDIR
      CHARACTER*4 IFIG
      CHARACTER*4 IFLAG
      CHARACTER*4 IPATT2
      CHARACTER*4 ICOL
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
      INCLUDE 'DPCOBE.INC'
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'PLPX')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('****** AT THE BEGINING OF GRPLPX ---')
      CALL DPWRST(ICOUT,'BUG ')
      WRITE(ICOUT,52)N,IDIR,DIST
   52 FORMAT('N,IDIR,DIST = ',I8,2X,A4,2X,E15.7)
      CALL DPWRST(ICOUT,'BUG ')
      WRITE(ICOUT,53)IPATT2,PTHICK,ICOL
   53 FORMAT('IPATT2,PTHICK,ICOL = ',A4,2X,E15.7,2X,A4)
      CALL DPWRST(ICOUT,'BUG ')
      DO54I=1,N
      WRITE(ICOUT,55)I,X(I),Y(I)
      CALL DPWRST(ICOUT,'BUG ')
 54   CONTINUE
 55   FORMAT('I,X(I),Y(I)=',I8,2X,E15.7,2X,E15.7)
C
 90   CONTINUE
C
      IF(N.LE.3)GOTO9000
      IF(X(1).NE.X(N).OR.Y(1).NE.Y(N))THEN
        N=N+1
        X(N)=X(1)
        Y(N)=Y(1)
      ENDIF
      IF(IDIR.EQ.'HORI')THEN
        AMAXY=Y(1)
        AMINY=Y(1)
        DO100I=2,N
          IF(Y(I).GT.AMAXY)AMAXY=Y(I)
          IF(Y(I).LT.AMINY)AMINY=Y(I)
 100    CONTINUE
        IF(AMAXY.GE.100.0)AMAXY=100.0
        IF(AMINY.LE.0.0)AMINY=0.0
C
        AY=AMINY
 300    CONTINUE
          IV=N
          NINT=0
          DO200NV=1,N
            IF(AMAX1(Y(IV),Y(NV)).GE.AY .AND.
     +         AMIN1(Y(IV),Y(NV)).LE.AY .AND.  Y(IV).NE.Y(NV)) THEN
              RMU=(AY-Y(IV))/(Y(NV)-Y(IV))
              NINT=NINT+1
              XI=(1.0-RMU)*X(IV) + RMU*X(NV)
              PX(NINT)=XI
C
              IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'PLPX')GOTO390
              WRITE(ICOUT,999)
              CALL DPWRST('XXX','BUG ')
              WRITE(ICOUT,351)
  351         FORMAT('****** IN THE 200 LOOP ---')
              CALL DPWRST('XXX','BUG ')
              WRITE(ICOUT,352)AY,IV,NV
  352         FORMAT('AY,IV,NV=',E15.7,2X,I8,2X,I8)
              CALL DPWRST('XXX','BUG ')
              WRITE(ICOUT,353)RMU,XI,X(IV),X(NV)
  353         FORMAT('RMU,XI,X(IV),X(NV)=',4(E15.7,2X))
              CALL DPWRST('XXX','BUG ')
              WRITE(ICOUT,354)Y(IV),Y(NV)
  354         FORMAT('Y(IV),Y(NV)=',2(E15.7,2X))
              CALL DPWRST('XXX','BUG ')
 390          CONTINUE
C
            ENDIF
            IV=NV
 200      CONTINUE
          IF(NINT.LE.1)GOTO299
          CALL SORT(PX,NINT,PX)
          IFLAG='ON'
          IFIG='LINE'
          NP2=2
          DO250I=1,NINT,2
            IF(I+1.GT.NINT)GOTO299
            PX2(1)=PX(I)
            PX2(2)=PX(I+1)
            PY2(1)=AY
            PY2(2)=AY
            CALL DPDRPL(PX2,PY2,NP2,
     1                IFIG,IPATT2,PTHICK,ICOL,
     1                JPATT,JTHICK,PTHIC2,JCOL,IFLAG)
            IFLAG='OFF'
 250      CONTINUE
 299      CONTINUE
          AY=AY+DIST
          IF(AY.GT.AMAXY)GOTO9000
        GOTO300
      ELSEIF(IDIR.EQ.'VERT')THEN
        AMAXX=X(1)
        AMINX=X(1)
        DO400I=2,N
          IF(X(I).GT.AMAXX)AMAXX=X(I)
          IF(X(I).LT.AMINX)AMINX=X(I)
 400    CONTINUE
        IF(AMAXX.GE.100.0)AMAXX=100.0
        IF(AMINX.LE.0.0)AMINX=0.0
C
        AX=AMINX
 600    CONTINUE
          IV=N
          NINT=0
          DO500NV=1,N
            IF(AMAX1(X(IV),X(NV)).GE.AX .AND.
     +         AMIN1(X(IV),X(NV)).LE.AX .AND.  X(IV).NE.X(NV)) THEN
              RMU=(AX-X(IV))/(X(NV)-X(IV))
              NINT=NINT+1
              YI=(1.0-RMU)*Y(IV) + RMU*Y(NV)
              PY(NINT)=YI
            ENDIF
            IV=NV
 500      CONTINUE
          IF(NINT.LE.1)GOTO599
          CALL SORT(PY,NINT,PY)
          IFLAG='ON'
          IFIG='LINE'
          NP2=2
          DO550I=1,NINT,2
            IF(I+1.GT.NINT)GOTO599
            PY2(1)=PY(I)
            PY2(2)=PY(I+1)
            PX2(1)=AX
            PX2(2)=AX
            CALL DPDRPL(PX2,PY2,NP2,
     1                IFIG,IPATT2,PTHICK,ICOL,
     1                JPATT,JTHICK,PTHIC2,JCOL,IFLAG)
            IFLAG='OFF'
 550      CONTINUE
 599      CONTINUE
          AX=AX+DIST
          IF(AX.GT.AMAXX)GOTO9000
        GOTO600
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE GRPMEA(AMAT1,AMAT2,MAXROM,MAXCOM,NR1,NC1,
     1                  TAG,TAGDIS,NIJUNK,N2,NK,TEMP,IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE
C              GROUP MEANS OF A MATRIX.  THAT IS, A TAG VARIABLE
C              DIVIDES THE ROWS OF A MATRIX INTO DISTINCT GROUPS.
C              THE COMPUTED GROUP MEANS ARE RETURNED AS A MATRIX
C              (WHERE THE NUMBER OF ROWS EQUALS THE NUMBER OF GROUPS).
C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
C             GROUP MEANS.
C     NOTE--THE TAG VARIABLE IS A GROUP IDENTIFIER THAT DEFINES
C           WHAT MATRIX A GIVEN ROW BELONGS TO.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
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
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--98.9
C     ORIGINAL VERSION--SEPTEMBER 1998.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 IWRITE
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DIMENSION AMAT1(MAXROM,MAXCOM)
      DIMENSION AMAT2(MAXROM,MAXCOM)
      DIMENSION TAG(*)
      DIMENSION TAGDIS(*)
      DIMENSION TEMP(*)
      DIMENSION NIJUNK(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='GRPM'
      ISUBN2='EA  '
      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 GRPMEA--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,52)IBUGA3,N2,NR1,NC1
   52   FORMAT('IBUGA3,N2,NR1,NC1 = ',A4,2X,3I8)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
C               *************************************************
C               **  COMPUTE NUMBER OF DISTINCT ELEMENTS OF TAG **
C               *************************************************
C
      IWRITE='OFF'
      CALL DISTIN(TAG,NR1,IWRITE,TAGDIS,NK,IBUGA3,IERROR)
C
C               *************************************************
C               **  COMPUTE GROUP MEANS                        **
C               *************************************************
C
      DO95J=1,MAXCOM
        DO98I=1,MAXROM
          AMAT2(I,J)=0.0
   98   CONTINUE
   95 CONTINUE
      NSUM=0
C
      DO100IGROUP=1,NK
C
        ATEMP=TAGDIS(IGROUP)
        DO200J=1,NC1
          ICOUNT=0
          DO300I=1,NR1
            IF(TAG(I).EQ.ATEMP)THEN
              ICOUNT=ICOUNT+1
              TEMP(ICOUNT)=AMAT1(I,J)
            ENDIF
  300     CONTINUE
          IF(J.EQ.1)THEN
            NI=ICOUNT
            NIJUNK(IGROUP)=NI
          ENDIF
          CALL MEAN(TEMP,NI,IWRITE,XMEAN,IBUGA3,IERROR)
          AMAT2(IGROUP,J)=XMEAN
  200   CONTINUE
  100 CONTINUE
C
      DO400J=1,NC1
        CALL MEAN(AMAT2(1,J),NK,IWRITE,XMEAN,IBUGA3,IERROR)
        TEMP(J)=XMEAN
  400 CONTINUE
C
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 GRPMEA--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9012)IBUGA3,IERROR,NR1,NC1
 9012   FORMAT('IBUGA3,IERROR,NR1,NC1 = ',2(A4,2X),2I8)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      RETURN
      END
      SUBROUTINE GRPRNK(Y,XSEQ,XH1,XH2,XH3,XH4,XH5,XH6,
     1                  N,NUMV2,MAXNXT,ICASCT,
     1                  XH1DIS,XH2DIS,XH3DIS,XH4DIS,XH5DIS,XH6DIS,XSEQD,
     1                  RANKSM,INRANK,
     1                  TEMP1,TEMP2,TEMP3,TEMP4,
     1                  Y2,NOUT,
     1                  ISUBRO,IBUGA3,IERROR)
C
C     PURPOSE--RETURN THE "AVERAGE" RANK FOR CROSS-TABULATED DATA.
C              THE SYNTAX OF THE COMMAND IS:
C
C                  LET AVERANK = AVERAGE RANK Y XSEQ X1 ..., XK
C
C              WHERE
C
C                  Y          = THE RESPONSE VARIABLE
C                  XSEQ       = THE SEQUENCE NUMBER VARIABLE
C                  X1 ... XK  = THE GROUP-ID VARIABLE
C
C              THE SEQUENCE NUMBER VARIABLE IS USED TO SUPPORT THE CASE
C              WHERE THE GROUPS MAY NOT CONTAIN THE SAME NUMBER OF
C              VALUES AND TO AVOID THE ASSUMPTION THAT THE VALUES ARE IN
C              SAME ORDER.  SO WE WANT THE AVERAGE RANK OVER ALL GROUPS
C              CORRESPONDING TO SEQUENCE NUMBER 1, SEQUENCE NUMBER 2,
C              AND SO ON.
C
C     WRITTEN BY--ALAN HECKERT
C                 STATISTICAL ENGINEERING DIVISION
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--2018/07
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 ICASCT
      CHARACTER*4 ISUBRO
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 IWRITE
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 ISTEPN
C
C---------------------------------------------------------------------
C
      DIMENSION Y(*)
      DIMENSION XSEQ(*)
      DIMENSION XH1(*)
      DIMENSION XH2(*)
      DIMENSION XH3(*)
      DIMENSION XH4(*)
      DIMENSION XH5(*)
      DIMENSION XH6(*)
      DIMENSION Y2(*)
C
      DIMENSION XSEQD(*)
      DIMENSION XH1DIS(*)
      DIMENSION XH2DIS(*)
      DIMENSION XH3DIS(*)
      DIMENSION XH4DIS(*)
      DIMENSION XH5DIS(*)
      DIMENSION XH6DIS(*)
      DIMENSION RANKSM(*)
      DIMENSION TEMP1(*)
      DIMENSION TEMP2(*)
      DIMENSION TEMP3(*)
      DIMENSION TEMP4(*)
      INTEGER INRANK(*)
C
      INCLUDE 'DPCOPA.INC'
      INCLUDE 'DPCOST.INC'
      INCLUDE 'DPCOHK.INC'
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'PRNK')THEN
        WRITE(ICOUT,70)
   70   FORMAT('AT THE BEGINNING OF GRPRNK--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,71)N,NUMV2,MAXNXT,ICASCT,PSTAMV
   71   FORMAT('N,NUMV2,MAXNXT,ICASCT,PSTAMV = ',3I8,2X,A4,2X,G15.7)
        CALL DPWRST('XXX','BUG ')
        DO72I=1,N
          WRITE(ICOUT,73)I,Y(I),XSEQ(I),XH1(I),XH2(I),XH3(I),XH4(I)
   73     FORMAT('I,Y(I),XSEQ(I),XH1(I),XH2(I),XH3(I),XH4(I) = ',
     1           I8,6G15.7)
          CALL DPWRST('XXX','BUG ')
   72   CONTINUE
      ENDIF
C
      ISUBN1='GRPR'
      ISUBN2='NK  '
C
      DO81II=1,MAXNXT
        RANKSM(II)=0.0
        INRANK(II)=0
   81 CONTINUE
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      NOUT=0
      IF(N.EQ.1)THEN
        Y2(1)=1.0
        NOUT=N
        GOTO9000
      ELSEIF(N.LE.0)THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,11)
   11   FORMAT('***** ERROR IN LET ... = AVERAGE RANK ... --')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,12)
   12   FORMAT('      THE NUMBER OF OBSERVATIONS MUST BE AT LEAST 1.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,14)N
   14   FORMAT('      THE NUMBER OF OBSERVATIONS = ',I6)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        GOTO9000
      ELSEIF(NUMV2.LT.1 .OR. NUMV2.GT.8)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,11)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,22)
   22   FORMAT('      THE NUMBER OF VARIABLES MUST BE AT LEAST ',
     1         'ONE AND LESS THAN OR EQUAL TO EIGHT.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,24)NUMV2
   24   FORMAT('      THE NUMBER OF VARIBALES = ',I6)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        GOTO9000
      ELSEIF(NUMV2.EQ.1)THEN
C
C       IF ONLY ONE VARIABLE GIVEN, THEN JUST RETURN THE RANKS
C       OF THAT VARIABLE.
C
        CALL RANK(Y,N,IWRITE,Y2,TEMP3,MAXNXT,IBUGA3,IERROR)
        NOUT=N
        GOTO9000
      ELSEIF(NUMV2.EQ.2)THEN
C
C       IF TWO VARIABLES GIVEN, CHECK TO SEE IF THERE IS
C       REPLICATION IN THE SECOND VARIABLE.  IF THERE IS,
C       TREAT AS A GROUP-ID VARIABLE.  OTHERWISE, ASSUME IT
C       IS THE SEQUENCE VARIABLE AND JUST RANK THE RESPONSE
C       VARIABLE.
C
C       SINCE WE WANT TO SUPPORT THE POSSIBILITY OF UNEQUAL
C       SIZES FOR THE CROSS-TAB CELLS, TREAT THE CASE WHERE
C       THE SECOND VARIABLE IS A GROUP-ID VARIABLE AS AN ERROR.
C
        CALL DISTIN(XSEQ,N,IWRITE,XSEQD,NUMSE0,IBUGA3,IERROR)
        IF(N.EQ.NUMSE0)THEN
          CALL RANK(Y,N,IWRITE,Y2,TEMP3,MAXNXT,IBUGA3,IERROR)
          GOTO9000
        ELSE
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,11)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,32)
   32     FORMAT('      FOR THE TWO VARIABLE CASE, THE SECOND ',
     1           'VARIABLE HAS REPLICATION.')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,34)
   34     FORMAT('      FOR THE TWO VARIABLE CASE, THE SECOND ',
     1           'VARIABLE HAS REPLICATION.')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,36)
   36     FORMAT('      THIS IMPLIES THAT IT IS A GROUP-ID VARIABLE ',
     1           'RATHER THAN A SEQUENCE VARIABLE.')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
          IERROR='YES'
          GOTO9000
        ENDIF
      ENDIF
C
      NUMGRP=NUMV2-2
      NUMSE0=0
      NUMSE1=0
      NUMSE2=0
      NUMSE3=0
      NUMSE4=0
      NUMSE5=0
      NUMSE6=0
      ANUMS0=NUMSE0
      ANUMS1=NUMSE1
      ANUMS2=NUMSE2
      ANUMS3=NUMSE3
      ANUMS4=NUMSE4
      ANUMS5=NUMSE5
      ANUMS6=NUMSE6
C
      CALL DISTIN(XSEQ,N,IWRITE,XSEQD,NUMSE0,IBUGA3,IERROR)
      CALL SORT(XSEQD,NUMSE0,XH1DIS)
C
      IF(NUMGRP.GE.1)THEN
        CALL DISTIN(XH1,N,IWRITE,XH1DIS,NUMSE1,IBUGA3,IERROR)
        CALL SORT(XH1DIS,NUMSE1,XH1DIS)
      ENDIF
      IF(NUMGRP.GE.2)THEN
        CALL DISTIN(XH2,N,IWRITE,XH2DIS,NUMSE2,IBUGA3,IERROR)
        CALL SORT(XH2DIS,NUMSE2,XH2DIS)
      ENDIF
      IF(NUMGRP.GE.3)THEN
        CALL DISTIN(XH3,N,IWRITE,XH3DIS,NUMSE3,IBUGA3,IERROR)
        CALL SORT(XH3DIS,NUMSE3,XH3DIS)
      ENDIF
      IF(NUMGRP.GE.4)THEN
        CALL DISTIN(XH4,N,IWRITE,XH4DIS,NUMSE4,IBUGA3,IERROR)
        CALL SORT(XH4DIS,NUMSE4,XH4DIS)
      ENDIF
      IF(NUMGRP.GE.5)THEN
        CALL DISTIN(XH5,N,IWRITE,XH5DIS,NUMSE5,IBUGA3,IERROR)
        CALL SORT(XH5DIS,NUMSE5,XH5DIS)
      ENDIF
      IF(NUMGRP.GE.6)THEN
        CALL DISTIN(XH6,N,IWRITE,XH6DIS,NUMSE6,IBUGA3,IERROR)
        CALL SORT(XH6DIS,NUMSE6,XH6DIS)
      ENDIF
C
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'PRNK')THEN
        WRITE(ICOUT,191)NUMGRP,NUMSE0,NUMSE1,NUMSE2,NUMSE3,NUMSE4,
     1                  NUMSE5,NUMSE6
  191   FORMAT('NUMGRP,NUMSE0,NUMSE1,NUMSE2,NUMSE3,NUMSE4,NUMSE5,',
     1         'NUMSE6 = ',8I8)
        CALL DPWRST('XXX','BUG ')
        NTEMP=MAX(NUMSE0,NUMSE1)
        NTEMP=MAX(NUMSE1,NUMSE2)
        NTEMP=MAX(NTEMP,NUMSE3)
        NTEMP=MAX(NTEMP,NUMSE4)
        NTEMP=MAX(NTEMP,NUMSE5)
        NTEMP=MAX(NTEMP,NUMSE6)
        DO195I=1,NTEMP
          WRITE(ICOUT,197)I,XSEQD(I),XH1DIS(I),XH2DIS(I),XH3DIS(I),
     1                    XH4DIS(I),XH5DIS(I),XH6DIS(I)
  197     FORMAT('I,XSEQD(I),XH1DIS(I),XH2DIS(I),XH3DIS(I),XH4DIS(I),',
     1           'XH5DIS(I),XH6DIS(I) = ',I8,7G15.7)
          CALL DPWRST('XXX','BUG ')
  195   CONTINUE
      ENDIF
C
C               **************************************
C               **  STEP 2--                        **
C               **  ONE GROUP ID VARIABLE.          **
C               **************************************
C
      ISTEPN='2'
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'PRNK')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(NUMGRP.EQ.1)THEN
C
        NOUT=0
        DO210I=1,NUMSE1
          NTEMP=0
          HOLD=XH1DIS(I)
          DO230J=1,N
            IF(XH1(J).EQ.HOLD)THEN
              NTEMP=NTEMP+1
              TEMP1(NTEMP)=Y(J)
              TEMP2(NTEMP)=XSEQ(J)
            ENDIF
  230     CONTINUE
C
          IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'PRNK')THEN
            WRITE(ICOUT,231)I,NTEMP
  231       FORMAT('AT 230: I,NTEMP = ',2I8)
            CALL DPWRST('XXX','BUG ')
            DO235J=1,NTEMP
              WRITE(ICOUT,237)J,TEMP1(J),TEMP2(J)
  237         FORMAT('J,TEMP1(I),TEMP2(I) = ',I8,2G15.7)
              CALL DPWRST('XXX','BUG ')
  235      CONTINUE
          ENDIF
C
          IF(NTEMP.GT.0)THEN
            CALL RANK(TEMP1,NTEMP,IWRITE,TEMP3,TEMP4,MAXNXT,
     1                IBUGA3,IERROR)
            IF(IERROR.EQ.'YES')GOTO9000
            DO240J=1,NTEMP
              DO245K=1,NUMSE0
                IF(TEMP2(J).EQ.XSEQD(K))THEN
                  RANKSM(K)=RANKSM(K) + TEMP3(J)
                  INRANK(K)=INRANK(K) + 1
                  GOTO248
                ENDIF
  245         CONTINUE
  248         CONTINUE
  240       CONTINUE
          ENDIF
C
          IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'PRNK')THEN
            WRITE(ICOUT,261)I,NTEMP
  261       FORMAT('I,NTEMP = ',2I8)
            CALL DPWRST('XXX','BUG ')
            DO265J=1,NUMSE0
              WRITE(ICOUT,268)J,XSEQD(J),RANKSM(J),INRANK(J)
  268         FORMAT('J,XSEQD(J),RANKSM(J),INRANK(J) = ',I8,3G15.7)
              CALL DPWRST('XXX','BUG ')
  265       CONTINUE
          ENDIF
C
  210   CONTINUE
C
C       NOW PROPOGATE DEPENDING ON WHETHER WE HAVE "COLLAPSE" OR
C       "EXPAND" OPTIONS
C
        IF(ICTALT.EQ.'EXPA')THEN
          DO270J=1,NUMSE0
            IF(INRANK(J).GT.0)THEN
              RANKSM(J)=RANKSM(J)/REAL(INRANK(J))
            ELSE
              RANKSM(J)=0.0
            ENDIF
  270     CONTINUE
C
          DO273K=1,N
            HOLD=XSEQ(K)
            DO275J=1,NUMSE0
              IF(HOLD.EQ.XSEQD(J))THEN
                Y2(K)=RANKSM(J)
                GOTO278
              ENDIF
  275       CONTINUE
  278       CONTINUE
  273     CONTINUE
          NOUT=N
        ELSEIF(ICTALT.EQ.'COLL')THEN
          DO280J=1,NUMSE0
            IF(INRANK(J).GT.0)THEN
              Y2(J)=RANKSM(J)/REAL(INRANK(J))
            ELSE
              Y2(J)=0.0
            ENDIF
  280     CONTINUE
          NOUT=NUMSE0
        ENDIF
      ELSEIF(NUMGRP.EQ.2)THEN
C
C               **************************************
C               **  STEP 3--                        **
C               **  TWO GROUP ID VARIABLE.          **
C               **************************************
C
       ISTEPN='3'
       IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'PRNK')
     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
        NOUT=0
        DO310II1=1,NUMSE1
          HOLD1=XH1DIS(II1)
          DO320II2=1,NUMSE2
            NTEMP=0
            HOLD2=XH2DIS(II2)
            DO330J=1,N
              IF(XH1(J).EQ.HOLD1 .AND. XH2(J).EQ.HOLD2)THEN
                NTEMP=NTEMP+1
                TEMP1(NTEMP)=Y(J)
                TEMP2(NTEMP)=XSEQ(J)
              ENDIF
  330       CONTINUE
C
            IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'PRNK')THEN
              WRITE(ICOUT,331)II1,II2,NTEMP
  331         FORMAT('AT 330: II1,II2,NTEMP = ',3I8)
              CALL DPWRST('XXX','BUG ')
              DO335J=1,NTEMP
                WRITE(ICOUT,337)J,TEMP1(J),TEMP2(J)
  337           FORMAT('J,TEMP1(I),TEMP2(I) = ',I8,2G15.7)
                CALL DPWRST('XXX','BUG ')
  335        CONTINUE
            ENDIF
C
            IF(NTEMP.GT.0)THEN
              CALL RANK(TEMP1,NTEMP,IWRITE,TEMP3,TEMP4,MAXNXT,
     1                  IBUGA3,IERROR)
              IF(IERROR.EQ.'YES')GOTO9000
              DO340J=1,NTEMP
                DO345K=1,NUMSE0
                  IF(TEMP2(J).EQ.XSEQD(K))THEN
                    RANKSM(K)=RANKSM(K) + TEMP3(J)
                    INRANK(K)=INRANK(K) + 1
                    GOTO348
                  ENDIF
  345           CONTINUE
  348           CONTINUE
  340         CONTINUE
            ENDIF
C
            IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'PRNK')THEN
              WRITE(ICOUT,361)II1,II2,NTEMP
  361         FORMAT('II1,II2,NTEMP = ',3I8)
              CALL DPWRST('XXX','BUG ')
              DO365J=1,NUMSE0
                WRITE(ICOUT,368)J,XSEQD(J),RANKSM(J),INRANK(J)
  368           FORMAT('J,XSEQD(J),RANKSM(J),INRANK(J) = ',I8,3G15.7)
                CALL DPWRST('XXX','BUG ')
  365         CONTINUE
            ENDIF
C
  320     CONTINUE
  310   CONTINUE
C
C       NOW PROPOGATE DEPENDING ON WHETHER WE HAVE "COLLAPSE" OR
C       "EXPAND" OPTIONS
C
        IF(ICTALT.EQ.'EXPA')THEN
          DO370J=1,NUMSE0
            IF(INRANK(J).GT.0)THEN
              RANKSM(J)=RANKSM(J)/REAL(INRANK(J))
            ELSE
              RANKSM(J)=0.0
            ENDIF
  370     CONTINUE
C
          DO373K=1,N
            HOLD=XSEQ(K)
            DO375J=1,NUMSE0
              IF(HOLD.EQ.XSEQD(J))THEN
                Y2(K)=RANKSM(J)
                GOTO378
              ENDIF
  375       CONTINUE
  378       CONTINUE
  373     CONTINUE
          NOUT=N
        ELSEIF(ICTALT.EQ.'COLL')THEN
          DO380J=1,NUMSE0
            IF(INRANK(J).GT.0)THEN
              Y2(J)=RANKSM(J)/REAL(INRANK(J))
            ELSE
              Y2(J)=0.0
            ENDIF
  380     CONTINUE
          NOUT=NUMSE0
        ENDIF
      ELSEIF(NUMGRP.EQ.3)THEN
C
C               **************************************
C               **  STEP 4--                        **
C               **  THREE GROUP ID VARIABLES.       **
C               **************************************
C
       ISTEPN='4'
       IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'PRNK')
     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
        NOUT=0
        DO410II1=1,NUMSE1
          HOLD1=XH1DIS(II1)
          DO415II2=1,NUMSE2
            HOLD2=XH2DIS(II2)
            DO420II3=1,NUMSE3
              NTEMP=0
              HOLD3=XH3DIS(II3)
              DO430J=1,N
                IF(XH1(J).EQ.HOLD1 .AND. XH2(J).EQ.HOLD2 .AND.
     1             XH3(J).EQ.HOLD3)THEN
                  NTEMP=NTEMP+1
                  TEMP1(NTEMP)=Y(J)
                  TEMP2(NTEMP)=XSEQ(J)
                ENDIF
  430         CONTINUE
C
              IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'PRNK')THEN
                WRITE(ICOUT,441)II1,II2,II3,NTEMP
  441           FORMAT('AT 430: II1,II2,II3,NTEMP = ',4I8)
                CALL DPWRST('XXX','BUG ')
                DO445J=1,NTEMP
                  WRITE(ICOUT,447)J,TEMP1(J),TEMP2(J)
  447             FORMAT('J,TEMP1(I),TEMP2(I) = ',I8,2G15.7)
                  CALL DPWRST('XXX','BUG ')
  445           CONTINUE
              ENDIF
C
              IF(NTEMP.GT.0)THEN
                CALL RANK(TEMP1,NTEMP,IWRITE,TEMP3,TEMP4,MAXNXT,
     1                    IBUGA3,IERROR)
                IF(IERROR.EQ.'YES')GOTO9000
                DO450J=1,NTEMP
                  DO455K=1,NUMSE0
                    IF(TEMP2(J).EQ.XSEQD(K))THEN
                      RANKSM(K)=RANKSM(K) + TEMP3(J)
                      INRANK(K)=INRANK(K) + 1
                      GOTO458
                    ENDIF
  455             CONTINUE
  458             CONTINUE
  450           CONTINUE
              ENDIF
C
              IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'PRNK')THEN
                WRITE(ICOUT,461)II1,II2,II3,NTEMP
  461           FORMAT('II1,II2,II3,NTEMP = ',4I8)
                CALL DPWRST('XXX','BUG ')
                DO465J=1,NUMSE0
                  WRITE(ICOUT,468)J,XSEQD(J),RANKSM(J),INRANK(J)
  468             FORMAT('J,XSEQD(J),RANKSM(J),INRANK(J) = ',I8,3G15.7)
                  CALL DPWRST('XXX','BUG ')
  465           CONTINUE
              ENDIF
C
  420       CONTINUE
  415     CONTINUE
  410   CONTINUE
C
C       NOW PROPOGATE DEPENDING ON WHETHER WE HAVE "COLLAPSE" OR
C       "EXPAND" OPTIONS
C
        IF(ICTALT.EQ.'EXPA')THEN
          DO470J=1,NUMSE0
            IF(INRANK(J).GT.0)THEN
              RANKSM(J)=RANKSM(J)/REAL(INRANK(J))
            ELSE
              RANKSM(J)=0.0
            ENDIF
  470     CONTINUE
C
          DO473K=1,N
            HOLD=XSEQ(K)
            DO475J=1,NUMSE0
              IF(HOLD.EQ.XSEQD(J))THEN
                Y2(K)=RANKSM(J)
                GOTO478
              ENDIF
  475       CONTINUE
  478       CONTINUE
  473     CONTINUE
          NOUT=N
        ELSEIF(ICTALT.EQ.'COLL')THEN
          DO480J=1,NUMSE0
            IF(INRANK(J).GT.0)THEN
              Y2(J)=RANKSM(J)/REAL(INRANK(J))
            ELSE
              Y2(J)=0.0
            ENDIF
  480     CONTINUE
          NOUT=NUMSE0
        ENDIF
      ELSEIF(NUMGRP.EQ.4)THEN
C
C               **************************************
C               **  STEP 5--                        **
C               **  FOUR  GROUP ID VARIABLES.       **
C               **************************************
C
       ISTEPN='5'
       IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'PRNK')
     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
        NOUT=0
        DO510II1=1,NUMSE1
          HOLD1=XH1DIS(II1)
          DO515II2=1,NUMSE2
            HOLD2=XH2DIS(II2)
            DO520II3=1,NUMSE3
              HOLD3=XH3DIS(II3)
              DO525II4=1,NUMSE4
                NTEMP=0
                HOLD4=XH4DIS(II4)
                DO530J=1,N
                  IF(XH1(J).EQ.HOLD1 .AND. XH2(J).EQ.HOLD2 .AND.
     1               XH3(J).EQ.HOLD3 .AND. XH4(J).EQ.HOLD4)THEN
                    NTEMP=NTEMP+1
                    TEMP1(NTEMP)=Y(J)
                    TEMP2(NTEMP)=XSEQ(J)
                  ENDIF
  530           CONTINUE
C
                IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'PRNK')THEN
                  WRITE(ICOUT,541)II1,II2,II3,II4,NTEMP
  541             FORMAT('AT 530: II1,II2,II3,II4,NTEMP = ',5I8)
                  CALL DPWRST('XXX','BUG ')
                  DO545J=1,NTEMP
                    WRITE(ICOUT,547)J,TEMP1(J),TEMP2(J)
  547               FORMAT('J,TEMP1(I),TEMP2(I) = ',I8,2G15.7)
                    CALL DPWRST('XXX','BUG ')
  545             CONTINUE
                ENDIF
C
                IF(NTEMP.GT.0)THEN
                  CALL RANK(TEMP1,NTEMP,IWRITE,TEMP3,TEMP4,MAXNXT,
     1                      IBUGA3,IERROR)
                  IF(IERROR.EQ.'YES')GOTO9000
                  DO540J=1,NTEMP
                    DO555K=1,NUMSE0
                      IF(TEMP2(J).EQ.XSEQD(K))THEN
                        RANKSM(K)=RANKSM(K) + TEMP3(J)
                        INRANK(K)=INRANK(K) + 1
                        GOTO558
                      ENDIF
  555               CONTINUE
  558               CONTINUE
  540             CONTINUE
                ENDIF
C
                IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'PRNK')THEN
                  WRITE(ICOUT,561)II1,II2,II3,II4,NTEMP
  561             FORMAT('II1,II2,II3,II4,NTEMP = ',5I8)
                  CALL DPWRST('XXX','BUG ')
                  DO565J=1,NUMSE0
                    WRITE(ICOUT,568)J,XSEQD(J),RANKSM(J),INRANK(J)
  568               FORMAT('J,XSEQD(J),RANKSM(J),INRANK(J) = ',
     1                     I8,3G15.7)
                    CALL DPWRST('XXX','BUG ')
  565             CONTINUE
                ENDIF
C
  525         CONTINUE
  520       CONTINUE
  515     CONTINUE
  510   CONTINUE
C
C       NOW PROPOGATE DEPENDING ON WHETHER WE HAVE "COLLAPSE" OR
C       "EXPAND" OPTIONS
C
        IF(ICTALT.EQ.'EXPA')THEN
          DO570J=1,NUMSE0
            IF(INRANK(J).GT.0)THEN
              RANKSM(J)=RANKSM(J)/REAL(INRANK(J))
            ELSE
              RANKSM(J)=0.0
            ENDIF
  570     CONTINUE
C
          DO573K=1,N
            HOLD=XSEQ(K)
            DO575J=1,NUMSE0
              IF(HOLD.EQ.XSEQD(J))THEN
                Y2(K)=RANKSM(J)
                GOTO578
              ENDIF
  575       CONTINUE
  578       CONTINUE
  573     CONTINUE
          NOUT=N
        ELSEIF(ICTALT.EQ.'COLL')THEN
          DO580J=1,NUMSE0
            IF(INRANK(J).GT.0)THEN
              Y2(J)=RANKSM(J)/REAL(INRANK(J))
            ELSE
              Y2(J)=0.0
            ENDIF
  580     CONTINUE
          NOUT=NUMSE0
        ENDIF
      ELSEIF(NUMGRP.EQ.5)THEN
C
C               **************************************
C               **  STEP 6--                        **
C               **  FIVE  GROUP ID VARIABLES.       **
C               **************************************
C
       ISTEPN='6'
       IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'PRNK')
     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
        NOUT=0
        DO610II1=1,NUMSE1
          HOLD1=XH1DIS(II1)
          DO615II2=1,NUMSE2
            HOLD2=XH2DIS(II2)
            DO620II3=1,NUMSE3
              HOLD3=XH3DIS(II3)
              DO625II4=1,NUMSE4
                NTEMP=0
                HOLD4=XH4DIS(II4)
                DO628II5=1,NUMSE5
                  NTEMP=0
                  HOLD5=XH5DIS(II5)
                  DO630J=1,N
                    IF(XH1(J).EQ.HOLD1 .AND. XH2(J).EQ.HOLD2 .AND.
     1                 XH3(J).EQ.HOLD3 .AND. XH4(J).EQ.HOLD4 .AND.
     1                 XH5(J).EQ.HOLD5)THEN
                      NTEMP=NTEMP+1
                      TEMP1(NTEMP)=Y(J)
                      TEMP2(NTEMP)=XSEQ(J)
                    ENDIF
  630             CONTINUE
C
                  IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'PRNK')THEN
                    WRITE(ICOUT,641)II1,II2,II3,II4,II5,NTEMP
  641               FORMAT('AT 630: II1,II2,II3,II4,II5,NTEMP = ',6I8)
                    CALL DPWRST('XXX','BUG ')
                    DO645J=1,NTEMP
                      WRITE(ICOUT,647)J,TEMP1(J),TEMP2(J)
  647                 FORMAT('J,TEMP1(I),TEMP2(I) = ',I8,2G15.7)
                      CALL DPWRST('XXX','BUG ')
  645               CONTINUE
                  ENDIF
C
                  IF(NTEMP.GT.0)THEN
                    CALL RANK(TEMP1,NTEMP,IWRITE,TEMP3,TEMP4,MAXNXT,
     1                        IBUGA3,IERROR)
                    IF(IERROR.EQ.'YES')GOTO9000
                    DO640J=1,NTEMP
                      DO655K=1,NUMSE0
                        IF(TEMP2(J).EQ.XSEQD(K))THEN
                          RANKSM(K)=RANKSM(K) + TEMP3(J)
                          INRANK(K)=INRANK(K) + 1
                          GOTO658
                        ENDIF
  655                 CONTINUE
  658                 CONTINUE
  640               CONTINUE
                  ENDIF
C
                  IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'PRNK')THEN
                    WRITE(ICOUT,661)II1,II2,II3,II4,II5,NTEMP
  661               FORMAT('II1,II2,II3,II4,II5,NTEMP = ',6I8)
                    CALL DPWRST('XXX','BUG ')
                    DO665J=1,NUMSE0
                      WRITE(ICOUT,668)J,XSEQD(J),RANKSM(J),INRANK(J)
  668                 FORMAT('J,XSEQD(J),RANKSM(J),INRANK(J) = ',
     1                       I8,3G15.7)
                      CALL DPWRST('XXX','BUG ')
  665               CONTINUE
                  ENDIF
C
  628           CONTINUE
  625         CONTINUE
  620       CONTINUE
  615     CONTINUE
  610   CONTINUE
C
C       NOW PROPOGATE DEPENDING ON WHETHER WE HAVE "COLLAPSE" OR
C       "EXPAND" OPTIONS
C
        IF(ICTALT.EQ.'EXPA')THEN
          DO670J=1,NUMSE0
            IF(INRANK(J).GT.0)THEN
              RANKSM(J)=RANKSM(J)/REAL(INRANK(J))
            ELSE
              RANKSM(J)=0.0
            ENDIF
  670     CONTINUE
C
          DO673K=1,N
            HOLD=XSEQ(K)
            DO675J=1,NUMSE0
              IF(HOLD.EQ.XSEQD(J))THEN
                Y2(K)=RANKSM(J)
                GOTO678
              ENDIF
  675       CONTINUE
  678       CONTINUE
  673     CONTINUE
          NOUT=N
        ELSEIF(ICTALT.EQ.'COLL')THEN
          DO680J=1,NUMSE0
            IF(INRANK(J).GT.0)THEN
              Y2(J)=RANKSM(J)/REAL(INRANK(J))
            ELSE
              Y2(J)=0.0
            ENDIF
  680     CONTINUE
          NOUT=NUMSE0
        ENDIF
      ELSEIF(NUMGRP.EQ.6)THEN
C
C               **************************************
C               **  STEP 7--                        **
C               **  SIX   GROUP ID VARIABLES.       **
C               **************************************
C
       ISTEPN='7'
       IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'PRNK')
     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
        NOUT=0
        DO710II1=1,NUMSE1
          HOLD1=XH1DIS(II1)
          DO715II2=1,NUMSE2
            HOLD2=XH2DIS(II2)
            DO720II3=1,NUMSE3
              HOLD3=XH3DIS(II3)
              DO725II4=1,NUMSE4
                NTEMP=0
                HOLD4=XH4DIS(II4)
                DO728II5=1,NUMSE5
                  HOLD5=XH5DIS(II5)
                  DO729II6=1,NUMSE6
                    NTEMP=0
                    HOLD6=XH6DIS(II6)
                    DO730J=1,N
                      IF(XH1(J).EQ.HOLD1 .AND. XH2(J).EQ.HOLD2 .AND.
     1                   XH3(J).EQ.HOLD3 .AND. XH4(J).EQ.HOLD4 .AND.
     1                   XH5(J).EQ.HOLD5 .AND. XH6(J).EQ.HOLD6)THEN
                        NTEMP=NTEMP+1
                        TEMP1(NTEMP)=Y(J)
                        TEMP2(NTEMP)=XSEQ(J)
                      ENDIF
  730               CONTINUE
C
                    IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'PRNK')THEN
                      WRITE(ICOUT,731)II1,II2,II3,II4,II5,II6,NTEMP
  731                 FORMAT('AT 730: II1,II2,II3,II4,II5,II6,NTEMP = ',
     1                       7I8)
                      CALL DPWRST('XXX','BUG ')
                      DO735J=1,NTEMP
                        WRITE(ICOUT,737)J,TEMP1(J),TEMP2(J)
  737                   FORMAT('J,TEMP1(I),TEMP2(I) = ',I8,2G15.7)
                        CALL DPWRST('XXX','BUG ')
  735                 CONTINUE
                    ENDIF
C
                    IF(NTEMP.GT.0)THEN
                      CALL RANK(TEMP1,NTEMP,IWRITE,TEMP3,TEMP4,MAXNXT,
     1                          IBUGA3,IERROR)
                      IF(IERROR.EQ.'YES')GOTO9000
                      DO740J=1,NTEMP
                        DO745K=1,NUMSE0
                          IF(TEMP2(J).EQ.XSEQD(K))THEN
                            RANKSM(K)=RANKSM(K) + TEMP3(J)
                            INRANK(K)=INRANK(K) + 1
                            GOTO748
                          ENDIF
  745                   CONTINUE
  748                   CONTINUE
  740                 CONTINUE
                    ENDIF
C
                    IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'PRNK')THEN
                      WRITE(ICOUT,771)II1,II2,II3,II4,II5,II6,NTEMP
  771                 FORMAT('II1,II2,II3,II4,II5,II6,NTEMP = ',7I8)
                      CALL DPWRST('XXX','BUG ')
                      DO755J=1,NUMSE0
                        WRITE(ICOUT,758)J,XSEQD(J),RANKSM(J),INRANK(J)
  758                   FORMAT('J,XSEQD(J),RANKSM(J),INRANK(J) = ',
     1                         I8,3G15.7)
                        CALL DPWRST('XXX','BUG ')
  755                 CONTINUE
                    ENDIF
C
  729             CONTINUE
  728           CONTINUE
  725         CONTINUE
  720       CONTINUE
  715     CONTINUE
  710   CONTINUE
C
C       NOW PROPOGATE DEPENDING ON WHETHER WE HAVE "COLLAPSE" OR
C       "EXPAND" OPTIONS
C
        IF(ICTALT.EQ.'EXPA')THEN
          DO770J=1,NUMSE0
            IF(INRANK(J).GT.0)THEN
              RANKSM(J)=RANKSM(J)/REAL(INRANK(J))
            ELSE
              RANKSM(J)=0.0
            ENDIF
  770     CONTINUE
C
          DO773K=1,N
            HOLD=XSEQ(K)
            DO775J=1,NUMSE0
              IF(HOLD.EQ.XSEQD(J))THEN
                Y2(K)=RANKSM(J)
                GOTO778
              ENDIF
  775       CONTINUE
  778       CONTINUE
  773     CONTINUE
          NOUT=N
        ELSEIF(ICTALT.EQ.'COLL')THEN
          DO780J=1,NUMSE0
            IF(INRANK(J).GT.0)THEN
              Y2(J)=RANKSM(J)/REAL(INRANK(J))
            ELSE
              Y2(J)=0.0
            ENDIF
  780     CONTINUE
          NOUT=NUMSE0
        ENDIF
      ENDIF
C
C               ******************
C               **   STEP 90--  **
C               **   EXIT       **
C               ******************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'PRNK')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END       OF GRPRNK--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9015)IERROR,NOUT
 9015   FORMAT('IERROR,NOUT = ',A4,2X,I8)
        CALL DPWRST('XXX','BUG ')
        DO9017I=1,N
          WRITE(ICOUT,9018)I,Y2(I)
 9018     FORMAT('I,Y2(I) = ',I8,G15.7)
          CALL DPWRST('XXX','BUG ')
 9017   CONTINUE
      ENDIF
C
      RETURN
      END
      SUBROUTINE GRPSD(AMAT1,AMAT2,MAXROM,MAXCOM,NR1,NC1,
     1TAG,TAGDIS,NIJUNK,N2,NK,TEMP,IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE
C              GROUP STANDARD DEVIATIONS OF A MATRIX.  THAT IS,
C              A TAG VARIABLE
C              DIVIDES THE ROWS OF A MATRIX INTO DISTINCT GROUPS.
C              THE COMPUTED GROUP SD'S ARE RETURNED AS A MATRIX
C              (WHERE THE NUMBER OF ROWS EQUALS THE NUMBER OF GROUPS).
C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
C             GROUP STANDARD DEVIATIONS.
C     NOTE--THE TAG VARIABLE IS A GROUP IDENTIFIER THAT DEFINES
C           WHAT MATRIX A GIVEN ROW BELONGS TO.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
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
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--98.9
C     ORIGINAL VERSION--SEPTEMBER 1998.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 IWRITE
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DIMENSION AMAT1(MAXROM,MAXCOM)
      DIMENSION AMAT2(MAXROM,MAXCOM)
      DIMENSION TAG(*)
      DIMENSION TAGDIS(*)
      DIMENSION TEMP(*)
      DIMENSION NIJUNK(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='GRPM'
      ISUBN2='EA  '
      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 GRPSD--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,53)NR1,N2,NC1,IBUGA3
   53   FORMAT('NR1,N2,NC1,IBUGA3 = ',3I8,2X,A4)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
C               *************************************************
C               **  COMPUTE NUMBER OF DISTINCT ELEMENTS OF TAG **
C               *************************************************
C
      IWRITE='OFF'
      CALL DISTIN(TAG,NR1,IWRITE,TAGDIS,NK,IBUGA3,IERROR)
C
C               *************************************************
C               **  COMPUTE GROUP MEANS                        **
C               *************************************************
C
      DO95J=1,MAXCOM
        DO98I=1,MAXROM
          AMAT2(I,J)=0.0
   98   CONTINUE
   95 CONTINUE
      NSUM=0
C
      DO100IGROUP=1,NK
C
        ATEMP=TAGDIS(IGROUP)
        DO200J=1,NC1
          ICOUNT=0
          DO300I=1,NR1
            IF(TAG(I).EQ.ATEMP)THEN
              ICOUNT=ICOUNT+1
              TEMP(ICOUNT)=AMAT1(I,J)
            ENDIF
  300     CONTINUE
          IF(J.EQ.1)THEN
            NI=ICOUNT
            NIJUNK(IGROUP)=NI
          ENDIF
          CALL SD(TEMP,NI,IWRITE,XSD,IBUGA3,IERROR)
          AMAT2(IGROUP,J)=XSD
  200   CONTINUE
  100 CONTINUE
C
      DO400J=1,NC1
        CALL SD(AMAT2(1,J),NK,IWRITE,XSD,IBUGA3,IERROR)
        TEMP(J)=XSD
  400 CONTINUE
C
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 GRPSD--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9013)NR1,NC1,IERROR
 9013   FORMAT('NR1,NC1,IERROR = ',2I8,2X,A4)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      RETURN
      END
      SUBROUTINE GRPSHU(Y,X,N,XINDEX,N2,
     1                  IWRITE,Y2,X2,
     1                  IINDEX,TEMP1,XDIST,
     1                  IBUGA3,ISUBRO,IERROR)
C
C     PURPOSE--GIVEN A RESPONSE VARIABLE, Y, AND A GROUP-ID
C              VARIABLE, X, RE-ARRANGE THE GROUPS BASED ON THE
C              INDEX VARIABLE, XINDEX.  NOTE THAT THE DATA ARE NOT
C              RANDOMIZED WITHIN THE GROUPS.
C
C              THE MOTIVATION FOR THIS IS TO RANDOMIZE THE
C              ROWS (OR COLUMNS) OF A MATRIX OR IMAGE.
C
C              NOTE THAT THE RANDOMIZATION CAN BE EITHER WITH OR
C              WITHOUT REPLACEMENT (THIS IS DETERMINED BY THE
C              XINDEX VARIABLE).  THE SHUFFLED GROUP-ID VARIABLE
C              MAY OR MAY NOT BE OF INTEREST (THE "SHUFFLE GROUPS"
C              LET SUBCOMMAND DOES NOT CURRENTLY SAVE THIS VARIABLE.
C
C     INPUT  ARGUMENTS--Y      = SINGLE PRECISION VARIABLE CONTAINING
C                                THE RESPONSE VARIABLE.
C                     --X      = SINGLE PRECISION VARIABLE CONTAINING
C                                THE GROUP-ID VARIABLE.
C                     --XINDEX = SINGLE PRECISION VARIABLE CONTAINING
C                                THE INDEX VARIABLE.
C     OUTPUT ARGUMENTS--Y2     = SINGLE PRECISION VARIABLE CONTAINING
C                                THE SHUFFLED RESPONSE VARIABLE.
C                     --X2     = SINGLE PRECISION VARIABLE CONTAINING
C                                THE SHUFFLED GROUP-ID VARIABLE.
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/7
C     ORIGINAL VERSION--JULY      2014.
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
      INCLUDE 'DPCOPA.INC'
C
      DIMENSION Y(*)
      DIMENSION X(*)
      DIMENSION XINDEX(*)
      DIMENSION Y2(*)
      DIMENSION X2(*)
      DIMENSION XDIST(*)
      DIMENSION TEMP1(*)
      DIMENSION IINDEX(*)
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='GRPS'
      ISUBN2='HU  '
      IERROR='NO'
C
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'PSHU')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,51)
   51   FORMAT('***** AT THE BEGINNING OF GRPSHU--')
        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,XINDEX(I)
   66     FORMAT('I,XINDEX(I) = ',I8,G15.7)
          CALL DPWRST('XXX','BUG ')
   65   CONTINUE
      ENDIF
C
C               ****************************************
C               **  STEP 11--                         **
C               **  CHECK THE INDEX VARIABLE          **
C               ****************************************
C
      CALL CODE(X,N,IWRITE,TEMP1,XDIST,MAXOBV,IBUGA3,IERROR)
      CALL DISTIN(TEMP1,N,IWRITE,XDIST,NDIST,IBUGA3,IERROR)
      DO91I=1,N
        X(I)=TEMP1(I)
   91 CONTINUE
C
      IF(N2.NE.NDIST)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,101)
  101   FORMAT('***** ERROR IN SHUFFLE GROUPS--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,103)
  103   FORMAT('      THE NUMBER OF DISTINCT VALUES IN THE GROUP-ID ',
     1         'VARIABLE')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,105)
  105   FORMAT('      DOES NOT MATCH THE NUMBER OF VALUES IN THE ',
     1         'INDEX VARIABLE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,107)NDIST
  107   FORMAT('      THE NUMBER OF DISTINCT VALUES IN THE GROUP-ID ',
     1         'VARIABLE: ',I8)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,109)N2
  109   FORMAT('      THE NUMBER OF VALUES IN THE INDEX ',
     1         'VARIABLE: ',I8)
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        GOTO9000
      ENDIF
C
      DO110I=1,N2
        IINDEX(I)=INT(XINDEX(I)+0.5)
        IF(I.EQ.1)THEN
          IMINX=IINDEX(I)
          IMAXX=IINDEX(I)
        ELSE
          IF(IINDEX(I).LT.IMINX)IMINX=IINDEX(I)
          IF(IINDEX(I).GT.IMAXX)IMAXX=IINDEX(I)
        ENDIF
  110 CONTINUE
C
      IF(IMINX.LT.1 .OR. IMAXX.GT.N2)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,101)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,111)IMINX
  111   FORMAT('      THE MINIMUM INDEX VALUE IS: ',I8)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,113)IMAXX
  113   FORMAT('      THE MAXIMUM INDEX VALUE IS: ',I8)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,114)N2
  114   FORMAT('      THE NUMBER OF ELEMENTS IN THE INDEX VARIABLE ',
     1         'IS: ',I8)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,115)NDIST
  115   FORMAT('      THE NUMBER OF DISTINCT VALUES IN THE GROUP-ID ',
     1         'VARIABLE IS: ',I8)
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        GOTO9000
      ENDIF
C
C               ****************************************
C               **  STEP 2--                          **
C               **  NOW PERFORM THE RE-ORDERING       **
C               ****************************************
C
      ICNT=0
      DO200II=1,N2
        ITAG=IINDEX(II)
        DO210IROW=1,N
          IJUNK=INT(X(IROW)+0.5)
          IF(IJUNK.EQ.ITAG)THEN
            ICNT=ICNT+1
            X2(ICNT)=REAL(II)
            Y2(ICNT)=Y(IROW)
          ENDIF
  210   CONTINUE
  200 CONTINUE
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'PSHU')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END       OF GRPSHU--')
        CALL DPWRST('XXX','BUG ')
        DO9042I=1,N
          WRITE(ICOUT,9043)I,X(I),Y(I),X2(I),Y2(I)
 9043     FORMAT('I,X(I),Y(I),X2(I),Y2(I) = ',I8,4G15.7)
          CALL DPWRST('XXX','BUG ')
 9042   CONTINUE
      ENDIF
C
      RETURN
      END
      SUBROUTINE GRPSTA(Y,YTEMP,YTEMP2,
     1                  XH1,XH2,XH3,XH4,XH5,XH6,N,NUMRES,NUMV2,
     1                  ICASCT,ICASC2,ICASS7,MAXNXT,
     1                  XH1DIS,XH2DIS,XH3DIS,XH4DIS,XH5DIS,XH6DIS,
     1                  ZTEMP1,ZTEMP2,ZTEMP3,
     1                  TEMP3,TEMP4,TEMP5,
     1                  Y2,
     1                  ISEED,ITEMP1,ITEMP2,ITEMP3,
     1                  ITEMP4,ITEMP5,ITEMP6,
     1                  DTEMP1,DTEMP2,DTEMP3,
     1                  ISUBRO,IBUGA3,IERROR)
C
C     PURPOSE--STANDARDIZE A VARIABLE:
C              1) Z-SCORE (I.E., SUBTRACT MEAN, DIVIDE BY STANDARD
C                 DEVIATION) OR BY SUBTRACTING MEAN ONLY.
C              2) CAN HAVE 0, 1, 2, 3, OR 4 GROUP ID VARIABLES.  NOTE
C                 THAT THE STANDARDIZATION IS BY GROUP CELL (I.E.,
C                 IF TWO GROUP VARIABLES, CROSS TABULATE AND
C                 DO THE STANDARDIZATION WITHIN EACH CELL).
C              3) SUPPORT VARIOUS LOCATION AND SCALE STATISTICS
C                 (DEFAULT WILL BE MEAN AND STANDARD DEVIATION).
C     WRITTEN BY--ALAN HECKERT
C                 STATISTICAL ENGINEERING DIVISION
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--2001/3
C     UPDATED         --SEPTEMBER     2001. ADD SUPORT FOR MINIMUM
C                                           AS LOCATION STAT AND RANGE
C                                           AND INTERQUARTILE RANGE AS
C                                           SCALE STATISTIC.
C                                           ALSO, ADD SUPPORT FOR
C                                           SCALE ONLY OPTION.
C     UPDATED         --SEPTEMBER     2001. ADD A "CROSS-TAB" OPTION.
C                                           THIS PUTS THE VALUE OF
C                                           THE REQUESTED STATISTIC
C                                           IN THE OUTPUT VECTOR.
C     UPDATED         --NOVEMBER      2001. BIWEIGHT LOCATION
C     UPDATED         --NOVEMBER      2001. BIWEIGHT SCALE
C     UPDATED         --AUGUST        2002. USE "CMPSTA" TO COMPUTE
C                                           STATISTIC FOR CROSS
C                                           TABULATE CASE
C     UPDATED         --APRIL         2003. ADD SN AND QN, REQUIRED
C                                           ADDITIONAL SCRATCH ARRAYS
C     UPDATED         --NOVEMBER      2007. DOUBLE PRECISION ARRAYS FOR
C                                           CMPSTA
C     UPDATED         --FEBRUARY      2009. SUPPORT FOR "COLLAPSE"
C                                           OPTION
C     UPDATED         --FEBRUARY      2009. SUPPORT 3 OR 4 GROUP
C                                           VARIABLES
C     UPDATED         --FEBRUARY      2009. GROUP ONE
C                                           GROUP TWO
C                                           GROUP THREE
C                                           GROUP FOUR
C                                           (THESE EXTRACT THE VALUE OF
C                                           GROUP-ID VARIABLES, ONLY
C                                           USEFUL IN "COLLAPSE" MODE)
C     UPDATED         --SEPTEMBER     2009. FIX:
C                                           LET XD1 = CROSS TABULATE
C                                               GROUP ONE X1
C     UPDATED         --JUNE          2010. CALL LIST TO CMPSTA
C     UPDATED         --JULY          2011. SUPPORT FOR
C                                           SET LET CROSS TABU EMPTY
C                                           SET LET CROSS TABU COMPLEMENT
C     UPDATED         --JULY          2011. CONSOLIDATE GRPSTA, GRPST2,
C                                           AND GRPST3 INTO SINGLE
C                                           ROUTINE
C     UPDATED         --JANUARY       2012. SUPPORT FOR CUMULATIVE <STAT>:
C                                           LET YOUT = CROSS TABULATE
C                                                      CUMULATIVE MEAN Y X
C     UPDATED         --JANUARY       2014. SUPPORT UP TO 6 GROUP
C                                           VARIABLES
C     UPDATED         --JUNE          2016. WHEN THERE IS A SINGLE GROUP-ID
C                                           VARIABLE, SUPPORT CONTIGUOUS
C                                           OPTION (ICTAGR)
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 ICASCT
      CHARACTER*4 ICASC2
      CHARACTER*4 ICASS7
      CHARACTER*4 ILOC
      CHARACTER*4 ISCALE
      CHARACTER*4 ISUBRO
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 IWRITE
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 ISTEPN
      CHARACTER*4 ICTAL2
C
C---------------------------------------------------------------------
C
      DIMENSION Y(*)
      DIMENSION YTEMP(*)
      DIMENSION YTEMP2(*)
      DIMENSION XH1(*)
      DIMENSION XH2(*)
      DIMENSION XH3(*)
      DIMENSION XH4(*)
      DIMENSION XH5(*)
      DIMENSION XH6(*)
      DIMENSION Y2(*)
C
      DIMENSION XH1DIS(*)
      DIMENSION XH2DIS(*)
      DIMENSION XH3DIS(*)
      DIMENSION XH4DIS(*)
      DIMENSION XH5DIS(*)
      DIMENSION XH6DIS(*)
      DIMENSION ZTEMP1(*)
      DIMENSION ZTEMP2(*)
      DIMENSION ZTEMP3(*)
      DIMENSION TEMP3(*)
      DIMENSION TEMP4(*)
      DIMENSION TEMP5(*)
      INTEGER ITEMP1(*)
      INTEGER ITEMP2(*)
      INTEGER ITEMP3(*)
      INTEGER ITEMP4(*)
      INTEGER ITEMP5(*)
      INTEGER ITEMP6(*)
      DOUBLE PRECISION DTEMP1(*)
      DOUBLE PRECISION DTEMP2(*)
      DOUBLE PRECISION DTEMP3(*)
C
      INCLUDE 'DPCOPA.INC'
      INCLUDE 'DPCOST.INC'
      INCLUDE 'DPCOHK.INC'
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'PSTA')THEN
        WRITE(ICOUT,70)
   70   FORMAT('AT THE BEGINNING OF GRPSTA--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,71)N,NUMV2,NUMRES,ICASCT,ICASC2,PSTAMV
   71   FORMAT('N,NUMV2,NUMRES,ICASCT,ICASC2,PSTAMV = ',
     1         3I8,2(2X,A4),2X,G15.7)
        CALL DPWRST('XXX','BUG ')
        DO72I=1,N
          WRITE(ICOUT,73)I,Y(I),YTEMP(I),YTEMP2(I),XH1(I),XH2(I)
   73     FORMAT('I,Y(I),YTEMP(I),YTEMP2(I),XH1(I),XH2(I) = ',
     1           I8,5G15.7)
          CALL DPWRST('XXX','BUG ')
   72   CONTINUE
      ENDIF
C
C     2018/07: TURN OFF "SET LET CROSS TABULATE COLLAPSE" SWITCH FOR
C              STANDARDIZE CASE
C
      ICTAL2=ICTALT
      IF(ICASCT.EQ.'STAN')ICTALT='EXPA'
      IF(ICASCT.EQ.'ZSCO')ICTALT='EXPA'
      IF(ICASCT.EQ.'USCO')ICTALT='EXPA'
      IF(ICASCT.EQ.'LSTA')ICTALT='EXPA'
      IF(ICASCT.EQ.'LSST')ICTALT='EXPA'
      IF(ICASCT.EQ.'LOCA')ICTALT='EXPA'
      IF(ICASCT.EQ.'SCAL')ICTALT='EXPA'
C
      ISUBN1='GRPS'
      ISUBN2='TA  '
C
      ILOC=ISTALO
      ISCALE=ISTASC
      IF(ICASCT.EQ.'ZSCO')THEN
        ILOC='MEAN'
        ISCALE='SD'
      ELSEIF(ICASCT.EQ.'USCO')THEN
        ILOC='MINI'
        ISCALE='RANG'
      ENDIF
C
      AN=REAL(N)
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LE.1)THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,31)
   31   FORMAT('***** ERROR IN LET ... = CROSS TABULATE ... --')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,32)
   32   FORMAT('      THE NUMBER OF OBSERVATIONS MUST BE AT LEAST 2.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,34)N
   34   FORMAT('      THE ENTERED NUMBER OF OBSERVATIONS HERE = ',I6)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        GOTO9000
      ENDIF
C
      IF(ICASCT.NE.'CRTA')THEN
        IF(NUMRES.GT.1)THEN
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,31)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,37)
   37     FORMAT('      FOR THE LOCATION OR SCALE CASES, THE NUMBER')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,38)
   38     FORMAT('      OF RESPONSE VARIABLES MUST BE EXACTLY ONE.')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,39)NUMRES
   39     FORMAT('      THE NUMBER OF RESPONSE VARIABLES  = ',I8)
          CALL DPWRST('XXX','BUG ')
          IERROR='YES'
          GOTO9000
        ENDIF
      ENDIF
C               ******************************************************
C               **  STEP 1--                                        **
C               **  1-VARIABLE CASE, I.E. NO GROUP ID VARIABLES.    **
C               ******************************************************
C
      ISTEPN='1'
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'PSTA')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IWRITE='OFF'
      IF(NUMV2.EQ.NUMRES)THEN
C
CCCCC   IF(ICASS7(1:3).EQ.'GRO')THEN
CCCCC     IERROR='YES'
CCCCC     GOTO8000
CCCCC   ENDIF
C
        IF(ICASCT.EQ.'CRTA')THEN
          CALL CMPSTA(
     1         Y,YTEMP,YTEMP2,TEMP3,TEMP4,TEMP5,MAXNXT,
     1         N,N,N,NUMRES,ICASS7,
     1         ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
     1         DTEMP1,DTEMP2,DTEMP3,
CCCCC1         IQUAME,IQUASE,PSTAMV,
     1         STAT1,
     1         ISUBRO,IBUGA3,IERROR)
          IF(IERROR.EQ.'YES')GOTO9000
C
          IF(ICTALT.EQ.'COLL')THEN
             Y2(1)=STAT1
          ELSE
            DO111I=1,N
              Y2(I)=STAT1
  111       CONTINUE
          ENDIF
        ELSEIF(ICASCT.EQ.'CTCU')THEN
          DO121I=1,N
            NTEMP=I
            CALL CMPSTA(
     1           Y,YTEMP,YTEMP2,TEMP3,TEMP4,TEMP5,MAXNXT,
     1           NTEMP,NTEMP,NTEMP,NUMRES,ICASS7,
     1           ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
     1           DTEMP1,DTEMP2,DTEMP3,
CCCCC1           IQUAME,IQUASE,PSTAMV,
     1           STAT1,
     1           ISUBRO,IBUGA3,IERROR)
                 IF(IERROR.EQ.'YES')THEN
                   Y2(I)=PSTAMV
                 ELSE
                   Y2(I)=STAT1
                 ENDIF
  121     CONTINUE
        ELSE
          STAT1=0.0
          STAT2=1.0
          IF(ICASCT.NE.'SCAL')THEN
            CALL CMPSTA(
     1      Y,YTEMP,YTEMP2,TEMP3,TEMP4,TEMP5,MAXOBV,
     1      N,N,N,NUMRES,ILOC,
     1      ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
     1      DTEMP1,DTEMP2,DTEMP3,
CCCCC1      IQUAME,IQUASE,PSTAMV,
     1      STAT1,
     1      ISUBRO,IBUGA3,IERROR)
            IF(IERROR.EQ.'YES')GOTO9000
          ENDIF
C
          IF(ICASCT.NE.'LOCA')THEN
            CALL CMPSTA(
     1      Y,YTEMP,YTEMP2,TEMP3,TEMP4,TEMP5,MAXOBV,
     1      N,N,N,NUMRES,ISCALE,
     1      ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
     1      DTEMP1,DTEMP2,DTEMP3,
CCCCC1      IQUAME,IQUASE,PSTAMV,
     1      STAT2,
     1      ISUBRO,IBUGA3,IERROR)
            IF(IERROR.EQ.'YES')GOTO9000
          ENDIF
          DO113I=1,N
            Y2(I)=(Y(I)-STAT1)/STAT2
  113     CONTINUE
        ENDIF
        GOTO9000
      ENDIF
C
      NUMGRP=NUMV2-NUMRES
      NUMSE1=0
      NUMSE2=0
      NUMSE3=0
      NUMSE4=0
      NUMSE5=0
      NUMSE6=0
      ANUMS1=NUMSE1
      ANUMS2=NUMSE2
      ANUMS3=NUMSE3
      ANUMS4=NUMSE4
      ANUMS5=NUMSE5
      ANUMS6=NUMSE6
      IF(NUMGRP.GE.1)THEN
        IF(ICTAGR.EQ.'NONC')THEN
          CALL DISTIN(XH1,N,IWRITE,XH1DIS,NUMSE1,IBUGA3,IERROR)
          CALL SORT(XH1DIS,NUMSE1,XH1DIS)
        ENDIF
      ENDIF
      IF(NUMGRP.GE.2)THEN
        CALL DISTIN(XH2,N,IWRITE,XH2DIS,NUMSE2,IBUGA3,IERROR)
        CALL SORT(XH2DIS,NUMSE2,XH2DIS)
      ENDIF
      IF(NUMGRP.GE.3)THEN
        CALL DISTIN(XH3,N,IWRITE,XH3DIS,NUMSE3,IBUGA3,IERROR)
        CALL SORT(XH3DIS,NUMSE3,XH3DIS)
      ENDIF
      IF(NUMGRP.GE.4)THEN
        CALL DISTIN(XH4,N,IWRITE,XH4DIS,NUMSE4,IBUGA3,IERROR)
        CALL SORT(XH4DIS,NUMSE4,XH4DIS)
      ENDIF
      IF(NUMGRP.GE.5)THEN
        CALL DISTIN(XH5,N,IWRITE,XH5DIS,NUMSE5,IBUGA3,IERROR)
        CALL SORT(XH5DIS,NUMSE5,XH5DIS)
      ENDIF
      IF(NUMGRP.GE.6)THEN
        CALL DISTIN(XH6,N,IWRITE,XH6DIS,NUMSE6,IBUGA3,IERROR)
        CALL SORT(XH6DIS,NUMSE6,XH6DIS)
      ENDIF
C
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'PSTA')THEN
        WRITE(ICOUT,191)NUMGRP,NUMSE1,NUMSE2,NUMSE3,NUMSE4
  191   FORMAT('NUMGRP,NUMSE1,NUMSE2,NUMSE3,NUMSE4 = ',5I8)
        CALL DPWRST('XXX','BUG ')
        NTEMP=MAX(NUMSE1,NUMSE2)
        NTEMP=MAX(NTEMP,NUMSE3)
        NTEMP=MAX(NTEMP,NUMSE4)
        DO195I=1,NTEMP
          WRITE(ICOUT,197)I,XH1DIS(I),XH2DIS(I),XH3DIS(I),XH4DIS(I)
  197     FORMAT('I,XH1DIS(I),XH2DIS(I),XH3DIS(I),XH4DIS(I) = ',
     1           I8,4G15.7)
          CALL DPWRST('XXX','BUG ')
  195   CONTINUE
      ENDIF
C
C               **************************************
C               **  STEP 2--                        **
C               **  ONE GROUP ID VARIABLE.          **
C               **************************************
C
      ISTEPN='2'
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'PSTA')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(NUMGRP.EQ.1)THEN
C
        NOUT=0
C
C       JULY 2011: THE SET LET CROSS TABULATE COMPLEMENT OPTION HAS THE
C                  FOLLOWING OPTIONS:
C
C                  1) OFF  - DEFAULT BEHAVIOR, EXTRACT DATA AS DEFINED BY
C                            THE GROUP-ID VARIABLES
C
C                  2) ON   - FOR THE LAST GROUP-ID VARIABLE, EXTRACT ALL
C                            DATA THAT IS NOT EQUAL TO THE SPECIFIED GROUP
C                            VALUE.
C
C                  3) ONE  - FOR THE LAST GROUP-ID VARIABLE, THE FIRST
C                            RESPONSE VARIABLE WILL EXTRACT THE VALUES
C                            NOT EQUAL TO THE SPECIFIED GROUP VALUE AND
C                            THE SECOND RESPONSE VARIABLE WILL EXTRACT
C                            THE VALUES EQUAL TO THE SPECIFIED GROUP VALUE.
C
C                  4) TWO  - FOR THE LAST GROUP-ID VARIABLE, THE FIRST
C                            RESPONSE VARIABLE WILL EXTRACT THE VALUES
C                            EQUAL TO THE SPECIFIED GROUP VALUE AND THE
C                            SECOND RESPONSE VARIABLE WILL EXTRACT THE
C                            VALUES NOT EQUAL TO THE SPECIFIED GROUP VALUE.
C
C       JUNE 2016: IF THE "SET LET CROSS TABULATE GROUPS CONTIGUOUS ON"
C                  IS GIVEN, THEN DON'T COMPUTE DISTINCT VALUES.
C                  INSTEAD LOOP THROUGH THE GROUP-ID VARIABLE AND SPLIT
C                  INTO GROUPS WHEN VALUE OF GROUP-ID VARIABLE CHANGES.
C                  THAT IS, GROUP BY CONTIGUOUS VALUES FOR THE GROUP-ID
C                  VARIABLE.
C
        IF(ICTAGR.EQ.'CONT')THEN
          JSTRT=1
          IFRST=1
          ILAST=1
          HOLD=XH1(1)
          JCNTR=1
C
 2210     CONTINUE
C
          NTEMP=0
          NTEMP1=0
          NTEMP2=0
          NTEMP3=0
          IFRST=JSTRT
C
          IF(ICTACO.EQ.'ON')THEN
            DO2220J=JSTRT,N
              JCNTR=J
              IF(XH1(J).EQ.HOLD)THEN
                NTEMP=NTEMP+1
                ZTEMP1(NTEMP)=Y(J)
                ZTEMP2(NTEMP)=YTEMP(J)
                ZTEMP3(NTEMP)=YTEMP2(J)
              ELSE
                JSTRT=J
                HOLD=XH1(J)
                ILAST=J-1
                GOTO2229
              ENDIF
 2220       CONTINUE
 2229       CONTINUE
            IF(JCNTR.EQ.N)ILAST=J
          ELSE
            DO2230J=JSTRT,N
              JCNTR=J
              IF(XH1(J).EQ.HOLD)THEN
                NTEMP=NTEMP+1
                ZTEMP1(NTEMP)=Y(J)
                ZTEMP2(NTEMP)=YTEMP(J)
                ZTEMP3(NTEMP)=YTEMP2(J)
              ELSE
                JSTRT=J
                HOLD=XH1(J)
                ILAST=J-1
                GOTO2239
              ENDIF
 2230       CONTINUE
 2239       CONTINUE
            IF(JCNTR.EQ.N)ILAST=J
          ENDIF
C
          IF(NTEMP.GT.0)THEN
            NTEMP1=NTEMP
            NTEMP2=NTEMP
            NTEMP3=NTEMP
          ENDIF
          IFLAG=1
          IFLAG2=0
          IF(NUMRES.EQ.1 .AND. NTEMP1.LE.0)THEN
            IFLAG=0
          ELSEIF(NUMRES.EQ.2)THEN
            IF(NTEMP1.LE.0 .OR. NTEMP2.LE.0)THEN
              IFLAG=0
            ENDIF
          ELSEIF(NUMRES.EQ.3)THEN
            IF(NTEMP1.LE.0 .OR. NTEMP2.LE.0 .OR. NTEMP3.LE.0)THEN
              IFLAG=0
            ENDIF
          ENDIF
          IF(ICTAEM.EQ.'INCL' .AND. ICTALT.EQ.'COLL')IFLAG2=1
C
          IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'PSTA')THEN
            WRITE(ICOUT,2291)ISET1,IFLAG,IFLAG2
 2291       FORMAT('ISET1,IFLAG,IFLAG2 = ',3I8)
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,393)NTEMP,NTEMP1,NTEMP2,NTEMP3
            CALL DPWRST('XXX','BUG ')
          ENDIF
C
          IWRITE='OFF'
          IF(IFLAG.EQ.1 .OR. IFLAG2.EQ.1)THEN
            IF(ICASS7.EQ.'GRO1')THEN
              STAT1=XH1DIS(I)
              NOUT=NOUT+1
              Y2(NOUT)=STAT1
            ELSEIF(ICASS7(1:3).EQ.'GRO')THEN
              WRITE(ICOUT,297)ICASS7
              CALL DPWRST('XXX','BUG ')
              IERROR='YES'
              GOTO8000
            ELSEIF(ICASCT.EQ.'CRTA')THEN
              IF(IFLAG.EQ.0 .AND. IFLAG2.EQ.1)THEN
                STAT1=PSTAMV
              ELSEIF(NTEMP.GT.0)THEN
                CALL CMPSTA(
     1               ZTEMP1,ZTEMP2,ZTEMP3,TEMP3,TEMP4,TEMP5,
     1               MAXNXT,NTEMP1,NTEMP2,NTEMP3,NUMRES,ICASS7,
     1               ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
     1               DTEMP1,DTEMP2,DTEMP3,
     1               STAT1,
     1               ISUBRO,IBUGA3,IERROR)
                IF(IERROR.EQ.'YES')GOTO9000
              ELSE
                STAT1=PSTAMV
              ENDIF
              IF(ICTALT.EQ.'COLL')THEN
                NOUT=NOUT+1
                Y2(NOUT)=STAT1
              ELSE
                DO2260J=IFRST,ILAST
                  Y2(J)=STAT1
 2260           CONTINUE
              ENDIF
            ELSEIF(ICASCT.EQ.'CTCU')THEN
              DO2261J=1,NTEMP1
                NTEMPZ=J
                CALL CMPSTA(
     1               ZTEMP1,ZTEMP2,ZTEMP3,TEMP3,TEMP4,TEMP5,
     1               MAXNXT,NTEMPZ,NTEMPZ,NTEMPZ,NUMRES,ICASS7,
     1               ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
     1               DTEMP1,DTEMP2,DTEMP3,
     1               STAT1,
     1               ISUBRO,IBUGA3,IERROR)
                NOUT=NOUT+1
                IF(IERROR.EQ.'YES')THEN
                  Y2(NOUT)=PSTAMV
                ELSE
                  Y2(NOUT)=STAT1
                ENDIF
 2261         CONTINUE
            ELSEIF(ICTAEM.EQ.'INCL' .AND. ICTALT.EQ.'COLL')THEN
              STAT1=PSTAMV
              NOUT=NOUT+1
              Y2(NOUT)=STAT1
            ELSE
              STAT1=0.0
              STAT2=1.0
              IF(ICASCT.NE.'SCAL')THEN
                CALL CMPSTA(
     1            ZTEMP1,ZTEMP2,ZTEMP3,TEMP3,TEMP4,TEMP5,
     1            MAXNXT,NTEMP1,NTEMP2,NTEMP3,NUMRES,ILOC,
     1            ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
     1            DTEMP1,DTEMP2,DTEMP3,
     1            STAT1,
     1            ISUBRO,IBUGA3,IERROR)
                  IF(IERROR.EQ.'YES')GOTO9000
              ENDIF
C
              IF(ICASCT.NE.'LOCA')THEN
                CALL CMPSTA(
     1            ZTEMP1,ZTEMP2,ZTEMP3,TEMP3,TEMP4,TEMP5,
     1            MAXNXT,NTEMP1,NTEMP2,NTEMP3,NUMRES,ISCALE,
     1            ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
     1            DTEMP1,DTEMP2,DTEMP3,
     1            STAT2,
     1            ISUBRO,IBUGA3,IERROR)
                IF(IERROR.EQ.'YES')GOTO9000
              ENDIF
              DO2280J=IFRST,ILAST
                Y2(J)=(Y(J)-STAT1)/STAT2
 2280         CONTINUE
            ENDIF
          ENDIF
C
          IF(JCNTR.LT.N)GOTO2210
          IF(ICTALT.EQ.'COLL')N=NOUT
          GOTO9000
C
        ENDIF
C
        DO210I=1,NUMSE1
          NTEMP=0
          NTEMP1=0
          NTEMP2=0
          NTEMP3=0
          IF(ICTACO.EQ.'ON')THEN
            DO220J=1,N
              IF(XH1(J).NE.XH1DIS(I))THEN
                NTEMP=NTEMP+1
                ZTEMP1(NTEMP)=Y(J)
                ZTEMP2(NTEMP)=YTEMP(J)
                ZTEMP3(NTEMP)=YTEMP2(J)
              ENDIF
  220       CONTINUE
          ELSEIF(ICTACO.EQ.'ONE')THEN
            DO221J=1,N
              IF(XH1(J).EQ.XH1DIS(I))THEN
                NTEMP2=NTEMP2+1
                ZTEMP2(NTEMP2)=YTEMP(J)
                NTEMP3=NTEMP3+1
                ZTEMP3(NTEMP3)=YTEMP2(J)
              ELSEIF(XH1(J).NE.XH1DIS(I))THEN
                NTEMP1=NTEMP1+1
                ZTEMP1(NTEMP1)=Y(J)
              ENDIF
  221       CONTINUE
          ELSEIF(ICTACO.EQ.'TWO')THEN
            DO222J=1,N
              IF(XH1(J).EQ.XH1DIS(I))THEN
                NTEMP1=NTEMP1+1
                ZTEMP1(NTEMP1)=Y(J)
                NTEMP3=NTEMP3+1
                ZTEMP3(NTEMP3)=YTEMP2(J)
              ELSEIF(XH1(J).NE.XH1DIS(I))THEN
                NTEMP2=NTEMP2+1
                ZTEMP2(NTEMP2)=YTEMP(J)
              ENDIF
  222       CONTINUE
          ELSE
            DO230J=1,N
              IF(XH1(J).EQ.XH1DIS(I))THEN
                NTEMP=NTEMP+1
                ZTEMP1(NTEMP)=Y(J)
                ZTEMP2(NTEMP)=YTEMP(J)
                ZTEMP3(NTEMP)=YTEMP2(J)
              ENDIF
  230       CONTINUE
          ENDIF
C
          IF(NTEMP.GT.0)THEN
            NTEMP1=NTEMP
            NTEMP2=NTEMP
            NTEMP3=NTEMP
          ENDIF
          IFLAG=1
          IFLAG2=0
          IF(NUMRES.EQ.1 .AND. NTEMP1.LE.0)THEN
            IFLAG=0
          ELSEIF(NUMRES.EQ.2)THEN
            IF(NTEMP1.LE.0 .OR. NTEMP2.LE.0)THEN
              IFLAG=0
            ENDIF
          ELSEIF(NUMRES.EQ.3)THEN
            IF(NTEMP1.LE.0 .OR. NTEMP2.LE.0 .OR. NTEMP3.LE.0)THEN
              IFLAG=0
            ENDIF
          ENDIF
          IF(ICTAEM.EQ.'INCL' .AND. ICTALT.EQ.'COLL')IFLAG2=1
C
          IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'PSTA')THEN
            WRITE(ICOUT,291)ISET1,IFLAG,IFLAG2
  291       FORMAT('ISET1,IFLAG,IFLAG2 = ',3I8)
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,393)NTEMP,NTEMP1,NTEMP2,NTEMP3
            CALL DPWRST('XXX','BUG ')
          ENDIF
C
          IWRITE='OFF'
          IF(IFLAG.EQ.1 .OR. IFLAG2.EQ.1)THEN
CCCCC       IF(ICASS7.EQ.'NUMB')THEN
CCCCC         IF(IFLAG.EQ.0 .AND. IFLAG2.EQ.1)STAT1=PSTAMV
CCCCC         STAT1=NTEMP
CCCCC         NOUT=NOUT+1
CCCCC         Y2(NOUT)=STAT1
CCCCC       ELSEIF(ICASS7.EQ.'GRO1')THEN
            IF(ICASS7.EQ.'GRO1')THEN
              STAT1=XH1DIS(I)
              NOUT=NOUT+1
              Y2(NOUT)=STAT1
            ELSEIF(ICASS7(1:3).EQ.'GRO')THEN
              WRITE(ICOUT,297)ICASS7
  297         FORMAT('INVALID CASE: ',A4)
              CALL DPWRST('XXX','BUG ')
              IERROR='YES'
              GOTO8000
            ELSEIF(ICASCT.EQ.'CRTA')THEN
              IF(IFLAG.EQ.0 .AND. IFLAG2.EQ.1)THEN
                STAT1=PSTAMV
              ELSEIF(NTEMP.GT.0)THEN
                CALL CMPSTA(
     1               ZTEMP1,ZTEMP2,ZTEMP3,TEMP3,TEMP4,TEMP5,
     1               MAXNXT,NTEMP1,NTEMP2,NTEMP3,NUMRES,ICASS7,
     1               ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
     1               DTEMP1,DTEMP2,DTEMP3,
CCCCC1               IQUAME,IQUASE,PSTAMV,
     1               STAT1,
     1               ISUBRO,IBUGA3,IERROR)
                IF(IERROR.EQ.'YES')GOTO9000
              ELSE
                STAT1=PSTAMV
              ENDIF
              IF(ICTALT.EQ.'COLL')THEN
                NOUT=NOUT+1
                Y2(NOUT)=STAT1
              ELSE
                DO260J=1,N
                  IF(XH1(J).EQ.XH1DIS(I))THEN
                    Y2(J)=STAT1
                  ENDIF
  260           CONTINUE
              ENDIF
            ELSEIF(ICASCT.EQ.'CTCU')THEN
              DO261J=1,NTEMP1
                NTEMPZ=J
                CALL CMPSTA(
     1               ZTEMP1,ZTEMP2,ZTEMP3,TEMP3,TEMP4,TEMP5,
     1               MAXNXT,NTEMPZ,NTEMPZ,NTEMPZ,NUMRES,ICASS7,
     1               ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
     1               DTEMP1,DTEMP2,DTEMP3,
CCCCC1               IQUAME,IQUASE,PSTAMV,
     1               STAT1,
     1               ISUBRO,IBUGA3,IERROR)
                NOUT=NOUT+1
                IF(IERROR.EQ.'YES')THEN
                  Y2(NOUT)=PSTAMV
                ELSE
                  Y2(NOUT)=STAT1
                ENDIF
  261         CONTINUE
            ELSEIF(ICTAEM.EQ.'INCL' .AND. ICTALT.EQ.'COLL')THEN
              STAT1=PSTAMV
              NOUT=NOUT+1
              Y2(NOUT)=STAT1
            ELSE
              STAT1=0.0
              STAT2=1.0
              IF(ICASCT.NE.'SCAL')THEN
                CALL CMPSTA(
     1          ZTEMP1,ZTEMP2,ZTEMP3,TEMP3,TEMP4,TEMP5,
     1          MAXNXT,NTEMP1,NTEMP2,NTEMP3,NUMRES,ILOC,
     1          ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
     1          DTEMP1,DTEMP2,DTEMP3,
CCCCC1          IQUAME,IQUASE,PSTAMV,
     1          STAT1,
     1          ISUBRO,IBUGA3,IERROR)
                IF(IERROR.EQ.'YES')GOTO9000
              ENDIF
C
              IF(ICASCT.NE.'LOCA')THEN
                CALL CMPSTA(
     1          ZTEMP1,ZTEMP2,ZTEMP3,TEMP3,TEMP4,TEMP5,
     1          MAXNXT,NTEMP1,NTEMP2,NTEMP3,NUMRES,ISCALE,
     1          ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
     1          DTEMP1,DTEMP2,DTEMP3,
CCCCC1          IQUAME,IQUASE,PSTAMV,
     1          STAT2,
     1          ISUBRO,IBUGA3,IERROR)
                IF(IERROR.EQ.'YES')GOTO9000
              ENDIF
              DO280J=1,N
                IF(XH1(J).EQ.XH1DIS(I))THEN
                  Y2(J)=(Y(J)-STAT1)/STAT2
                ENDIF
  280         CONTINUE
            ENDIF
          ENDIF
  210   CONTINUE
        IF(ICTALT.EQ.'COLL')N=NOUT
        GOTO9000
      ENDIF
C
C               **************************************
C               **  STEP 3--                        **
C               **  TWO GROUP ID VARIABLES          **
C               **************************************
C
      ISTEPN='3'
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'PSTA')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(NUMGRP.EQ.2)THEN
C
        NOUT=0
        DO310ISET1=1,NUMSE1
          DO320ISET2=1,NUMSE2
            NTEMP=0
            NTEMP1=0
            NTEMP2=0
            NTEMP3=0
            IF(ICTACO.EQ.'ON')THEN
              DO330J=1,N
                IF(XH1(J).EQ.XH1DIS(ISET1))THEN
                  IF(XH2(J).NE.XH2DIS(ISET2))THEN
                    NTEMP=NTEMP+1
                    ZTEMP1(NTEMP)=Y(J)
                    ZTEMP2(NTEMP)=YTEMP(J)
                    ZTEMP3(NTEMP)=YTEMP2(J)
                  ENDIF
                ENDIF
  330         CONTINUE
            ELSEIF(ICTACO.EQ.'ONE')THEN
              DO331J=1,N
                IF(XH1(J).EQ.XH1DIS(ISET1))THEN
                  IF(XH2(J).EQ.XH2DIS(ISET2))THEN
                    NTEMP2=NTEMP2+1
                    ZTEMP2(NTEMP2)=YTEMP(J)
                    NTEMP3=NTEMP3+1
                    ZTEMP3(NTEMP3)=YTEMP2(J)
                  ELSEIF(XH2(J).NE.XH2DIS(ISET2))THEN
                    NTEMP1=NTEMP1+1
                    ZTEMP1(NTEMP1)=Y(J)
                  ENDIF
                ENDIF
  331         CONTINUE
            ELSEIF(ICTACO.EQ.'TWO')THEN
              DO332J=1,N
                IF(XH1(J).EQ.XH1DIS(ISET1))THEN
                  IF(XH2(J).EQ.XH2DIS(ISET2))THEN
                    NTEMP1=NTEMP1+1
                    ZTEMP1(NTEMP1)=Y(J)
                    NTEMP3=NTEMP3+1
                    ZTEMP3(NTEMP3)=YTEMP2(J)
                  ELSEIF(XH2(J).NE.XH2DIS(ISET2))THEN
                    NTEMP2=NTEMP2+1
                    ZTEMP2(NTEMP2)=YTEMP(J)
                  ENDIF
                ENDIF
  332         CONTINUE
            ELSE
              DO370J=1,N
                IF(XH1(J).EQ.XH1DIS(ISET1).AND.
     1             XH2(J).EQ.XH2DIS(ISET2))THEN
                  NTEMP=NTEMP+1
                  ZTEMP1(NTEMP)=Y(J)
                  ZTEMP2(NTEMP)=YTEMP(J)
                  ZTEMP3(NTEMP)=YTEMP2(J)
                ENDIF
  370         CONTINUE
            ENDIF
C
            IF(NTEMP.GT.0)THEN
              NTEMP1=NTEMP
              NTEMP2=NTEMP
              NTEMP3=NTEMP
            ENDIF
            IFLAG=1
            IFLAG2=0
            IF(NUMRES.EQ.0 .AND. NTEMP.LE.0)THEN
              IFLAG=0
            ELSEIF(NUMRES.EQ.1 .AND. NTEMP1.LE.0)THEN
              IFLAG=0
            ELSEIF(NUMRES.EQ.2)THEN
              IF(NTEMP1.LE.0 .OR. NTEMP2.LE.0)THEN
                IFLAG=0
              ENDIF
            ELSEIF(NUMRES.EQ.3)THEN
              IF(NTEMP1.LE.0 .OR. NTEMP2.LE.0 .OR. NTEMP3.LE.0)THEN
                IFLAG=0
              ENDIF
            ENDIF
            IF(ICTAEM.EQ.'INCL' .AND. ICTALT.EQ.'COLL')IFLAG2=1
C
            IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'PSTA')THEN
              WRITE(ICOUT,391)ISET1,ISET2,IFLAG,IFLAG2
  391         FORMAT('ISET1,ISET2,IFLAG,IFLAG2 = ',4I8)
              CALL DPWRST('XXX','BUG ')
              WRITE(ICOUT,393)NTEMP,NTEMP1,NTEMP2,NTEMP3
  393         FORMAT('NTEMP,NTEMP1,NTEMP2,NTEMP3 = ',4I8)
              CALL DPWRST('XXX','BUG ')
            ENDIF
C
            IWRITE='OFF'
            IF(IFLAG.EQ.1 .OR. IFLAG2.EQ.1)THEN
CCCCC         IF(ICASS7.EQ.'NUMB')THEN
CCCCC           IF(IFLAG.EQ.0 .AND. IFLAG2.EQ.1)STAT1=PSTAMV
CCCCC           STAT1=NTEMP
CCCCC           NOUT=NOUT+1
CCCCC           Y2(NOUT)=STAT1
CCCCC         ELSEIF(ICASS7.EQ.'GRO1')THEN
              IF(ICASS7.EQ.'GRO1')THEN
                STAT1=XH1DIS(ISET1)
                NOUT=NOUT+1
                Y2(NOUT)=STAT1
              ELSEIF(ICASS7.EQ.'GRO2')THEN
                STAT1=XH2DIS(ISET2)
                NOUT=NOUT+1
                Y2(NOUT)=STAT1
              ELSEIF(ICASS7(1:3).EQ.'GRO')THEN
                WRITE(ICOUT,397)ICASS7
  397           FORMAT('INVALID CASE: ',A4)
                CALL DPWRST('XXX','BUG ')
                IERROR='YES'
                GOTO8000
              ELSEIF(ICASCT.EQ.'CRTA')THEN
                IF(IFLAG.EQ.0 .AND. IFLAG2.EQ.1)THEN
                  STAT1=PSTAMV
                ELSEIF(NTEMP1.GT.0)THEN
                  CALL CMPSTA(
     1                 ZTEMP1,ZTEMP2,ZTEMP3,TEMP3,TEMP4,TEMP5,
     1                 MAXNXT,NTEMP1,NTEMP2,NTEMP3,NUMRES,ICASS7,
     1                 ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
     1                 DTEMP1,DTEMP2,DTEMP3,
CCCCC1                 IQUAME,IQUASE,PSTAMV,
     1                 STAT1,
     1                 ISUBRO,IBUGA3,IERROR)
                  IF(IERROR.EQ.'YES')GOTO9000
                ELSE
                  STAT1=PSTAMV
                ENDIF
                IF(ICTALT.EQ.'COLL')THEN
                  NOUT=NOUT+1
                  Y2(NOUT)=STAT1
                ELSE
                  DO380J=1,N
                    IF(XH1(J).EQ.XH1DIS(ISET1).AND.
     1                 XH2(J).EQ.XH2DIS(ISET2))THEN
                      Y2(J)=STAT1
                    ENDIF
  380             CONTINUE
                ENDIF
              ELSEIF(ICASCT.EQ.'CTCU')THEN
                DO381J=1,NTEMP1
                  NTEMPZ=J
                  CALL CMPSTA(
     1                 ZTEMP1,ZTEMP2,ZTEMP3,TEMP3,TEMP4,TEMP5,
     1                 MAXNXT,NTEMPZ,NTEMPZ,NTEMPZ,NUMRES,ICASS7,
     1                 ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
     1                 DTEMP1,DTEMP2,DTEMP3,
CCCCC1                 IQUAME,IQUASE,PSTAMV,
     1                 STAT1,
     1                 ISUBRO,IBUGA3,IERROR)
                  NOUT=NOUT+1
                  IF(IERROR.EQ.'YES')THEN
                    Y2(NOUT)=PSTAMV
                  ELSE
                    Y2(NOUT)=STAT1
                  ENDIF
  381           CONTINUE
              ELSEIF(ICTAEM.EQ.'INCL' .AND. ICTALT.EQ.'COLL')THEN
                STAT1=PSTAMV
                NOUT=NOUT+1
                Y2(NOUT)=STAT1
              ELSE
                STAT1=0.0
                STAT2=1.0
                IF(ICASCT.NE.'SCAL')THEN
                  CALL CMPSTA(
     1            ZTEMP1,ZTEMP2,ZTEMP3,TEMP3,TEMP4,TEMP5,
     1            MAXNXT,NTEMP1,NTEMP2,NTEMP3,NUMRES,ILOC,
     1            ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
     1            DTEMP1,DTEMP2,DTEMP3,
CCCCC1            IQUAME,IQUASE,PSTAMV,
     1            STAT1,
     1            ISUBRO,IBUGA3,IERROR)
                  IF(IERROR.EQ.'YES')GOTO9000
                ENDIF
C
                IF(ICASCT.NE.'LOCA')THEN
                  CALL CMPSTA(
     1            ZTEMP1,ZTEMP2,ZTEMP3,TEMP3,TEMP4,TEMP5,
     1            MAXNXT,NTEMP1,NTEMP2,NTEMP3,NUMRES,ISCALE,
     1            ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
     1            DTEMP1,DTEMP2,DTEMP3,
CCCCC1            IQUAME,IQUASE,PSTAMV,
     1            STAT2,
     1            ISUBRO,IBUGA3,IERROR)
                  IF(IERROR.EQ.'YES')GOTO9000
                ENDIF
                DO390J=1,N
                  IF(XH1(J).EQ.XH1DIS(ISET1).AND.
     1               XH2(J).EQ.XH2DIS(ISET2))THEN
                    Y2(J)=(Y(J)-STAT1)/STAT2
                  ENDIF
  390           CONTINUE
              ENDIF
            ENDIF
C
  320     CONTINUE
  310   CONTINUE
        IF(ICTALT.EQ.'COLL')N=NOUT
        GOTO9000
      ENDIF
C
C               **************************************
C               **  STEP 4--                        **
C               **  THREE GROUP ID VARIABLES        **
C               **************************************
C
      ISTEPN='4'
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'PSTA')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(NUMGRP.EQ.3)THEN
C
        NOUT=0
        DO410ISET1=1,NUMSE1
          DO420ISET2=1,NUMSE2
          DO430ISET3=1,NUMSE3
            NTEMP=0
            NTEMP1=0
            NTEMP2=0
            NTEMP3=0
            IF(ICTACO.EQ.'ON')THEN
              DO440J=1,N
                IF(XH1(J).EQ.XH1DIS(ISET1).AND.
     1             XH2(J).EQ.XH2DIS(ISET2))THEN
                  IF(XH3(J).NE.XH3DIS(ISET3))THEN
                    NTEMP=NTEMP+1
                    ZTEMP1(NTEMP)=Y(J)
                    ZTEMP2(NTEMP)=YTEMP(J)
                    ZTEMP3(NTEMP)=YTEMP2(J)
                  ENDIF
                ENDIF
  440         CONTINUE
            ELSEIF(ICTACO.EQ.'ONE')THEN
              DO441J=1,N
                IF(XH1(J).EQ.XH1DIS(ISET1).AND.
     1             XH2(J).EQ.XH2DIS(ISET2))THEN
                  IF(XH3(J).EQ.XH3DIS(ISET3))THEN
                    NTEMP2=NTEMP2+1
                    ZTEMP2(NTEMP2)=YTEMP(J)
                    NTEMP3=NTEMP3+1
                    ZTEMP3(NTEMP3)=YTEMP2(J)
                  ELSEIF(XH3(J).NE.XH3DIS(ISET3))THEN
                    NTEMP1=NTEMP1+1
                    ZTEMP1(NTEMP1)=Y(J)
                  ENDIF
                ENDIF
  441         CONTINUE
            ELSEIF(ICTACO.EQ.'TWO')THEN
              DO442J=1,N
                IF(XH1(J).EQ.XH1DIS(ISET1).AND.
     1             XH2(J).EQ.XH2DIS(ISET2))THEN
                  IF(XH3(J).EQ.XH3DIS(ISET3))THEN
                    NTEMP1=NTEMP1+1
                    ZTEMP1(NTEMP1)=Y(J)
                    NTEMP3=NTEMP3+1
                    ZTEMP3(NTEMP3)=YTEMP2(J)
                  ELSEIF(XH3(J).NE.XH3DIS(ISET3))THEN
                    NTEMP2=NTEMP2+1
                    ZTEMP2(NTEMP2)=YTEMP(J)
                  ENDIF
                ENDIF
  442         CONTINUE
            ELSE
              DO470J=1,N
                IF(XH1(J).EQ.XH1DIS(ISET1).AND.
     1             XH2(J).EQ.XH2DIS(ISET2).AND.
     1             XH3(J).EQ.XH3DIS(ISET3))THEN
                  NTEMP=NTEMP+1
                  ZTEMP1(NTEMP)=Y(J)
                  ZTEMP2(NTEMP)=YTEMP(J)
                  ZTEMP3(NTEMP)=YTEMP2(J)
                ENDIF
  470         CONTINUE
            ENDIF
C
            IF(NTEMP.GT.0)THEN
              NTEMP1=NTEMP
              NTEMP2=NTEMP
              NTEMP3=NTEMP
            ENDIF
            IFLAG=1
            IFLAG2=0
            IF(NUMRES.LE.1 .AND. NTEMP1.LE.0)THEN
              IFLAG=0
            ELSEIF(NUMRES.EQ.2)THEN
              IF(NTEMP1.LE.0 .OR. NTEMP2.LE.0)THEN
                IFLAG=0
              ENDIF
            ELSEIF(NUMRES.EQ.3)THEN
              IF(NTEMP1.LE.0 .OR. NTEMP2.LE.0 .OR. NTEMP3.LE.0)THEN
                IFLAG=0
              ENDIF
            ENDIF
            IF(ICTAEM.EQ.'INCL' .AND. ICTALT.EQ.'COLL')IFLAG2=1
C
CCCCC       IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'PSTA')THEN
CCCCC         WRITE(ICOUT,491)ISET1,ISET2,ISET3,IFLAG,IFLAG2
CC491         FORMAT('ISET1,ISET2,ISET3,IFLAG,IFLAG2 = ',5I8)
CCCCC         CALL DPWRST('XXX','BUG ')
CCCCC         WRITE(ICOUT,393)NTEMP,NTEMP1,NTEMP2,NTEMP3
CCCCC         CALL DPWRST('XXX','BUG ')
CCCCC       ENDIF
C
CCCCC       IWRITE='OFF'
            IF(IFLAG.EQ.1 .OR. IFLAG2.EQ.1)THEN
CCCCC         IF(ICASS7.EQ.'NUMB')THEN
CCCCC           IF(IFLAG.EQ.0 .AND. IFLAG2.EQ.1)STAT1=PSTAMV
CCCCC           STAT1=NTEMP
CCCCC           NOUT=NOUT+1
CCCCC           Y2(NOUT)=STAT1
CCCCC         ELSEIF(ICASS7.EQ.'GRO1')THEN
              IF(ICASS7.EQ.'GRO1')THEN
                STAT1=XH1DIS(ISET1)
                NOUT=NOUT+1
                Y2(NOUT)=STAT1
              ELSEIF(ICASS7.EQ.'GRO2')THEN
                STAT1=XH2DIS(ISET2)
                NOUT=NOUT+1
                Y2(NOUT)=STAT1
              ELSEIF(ICASS7.EQ.'GRO3')THEN
                STAT1=XH3DIS(ISET3)
                NOUT=NOUT+1
                Y2(NOUT)=STAT1
              ELSEIF(ICASS7(1:3).EQ.'GRO')THEN
                WRITE(ICOUT,497)ICASS7
  497           FORMAT('INVALID CASE: ',A4)
                CALL DPWRST('XXX','BUG ')
                IERROR='YES'
                GOTO8000
              ELSEIF(ICASCT.EQ.'CRTA')THEN
                IF(IFLAG.EQ.0 .AND. IFLAG2.EQ.1)THEN
                  STAT1=PSTAMV
                ELSEIF(NTEMP.GT.0)THEN
                  CALL CMPSTA(
     1                 ZTEMP1,ZTEMP2,ZTEMP3,TEMP3,TEMP4,TEMP5,
     1                 MAXNXT,NTEMP1,NTEMP2,NTEMP3,NUMRES,ICASS7,
     1                 ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
     1                 DTEMP1,DTEMP2,DTEMP3,
CCCCC1                 IQUAME,IQUASE,PSTAMV,
     1                 STAT1,
     1                 ISUBRO,IBUGA3,IERROR)
                  IF(IERROR.EQ.'YES')GOTO9000
                ELSE
                  STAT1=PSTAMV
                ENDIF
                IF(ICTALT.EQ.'COLL')THEN
                  NOUT=NOUT+1
                  Y2(NOUT)=STAT1
                ELSE
                  DO480J=1,N
                    IF(XH1(J).EQ.XH1DIS(ISET1).AND.
     1                 XH2(J).EQ.XH2DIS(ISET2).AND.
     1                 XH3(J).EQ.XH3DIS(ISET3))THEN
                      Y2(J)=STAT1
                    ENDIF
  480             CONTINUE
                ENDIF
              ELSEIF(ICASCT.EQ.'CTCU')THEN
                DO481J=1,NTEMP1
                  NTEMPZ=J
                  CALL CMPSTA(
     1                 ZTEMP1,ZTEMP2,ZTEMP3,TEMP3,TEMP4,TEMP5,
     1                 MAXNXT,NTEMPZ,NTEMPZ,NTEMPZ,NUMRES,ICASS7,
     1                 ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
     1                 DTEMP1,DTEMP2,DTEMP3,
CCCCC1                 IQUAME,IQUASE,PSTAMV,
     1                 STAT1,
     1                 ISUBRO,IBUGA3,IERROR)
                  NOUT=NOUT+1
                  IF(IERROR.EQ.'YES')THEN
                    Y2(NOUT)=PSTAMV
                  ELSE
                    Y2(NOUT)=STAT1
                  ENDIF
  481           CONTINUE
              ELSEIF(ICTAEM.EQ.'INCL' .AND. ICTALT.EQ.'COLL')THEN
                STAT1=PSTAMV
                NOUT=NOUT+1
                Y2(NOUT)=STAT1
              ELSE
                STAT1=0.0
                STAT2=1.0
                IF(ICASCT.NE.'SCAL')THEN
                  CALL CMPSTA(
     1            ZTEMP1,ZTEMP2,ZTEMP3,TEMP3,TEMP4,TEMP5,
     1            MAXNXT,NTEMP1,NTEMP2,NTEMP3,NUMRES,ILOC,
     1            ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
     1            DTEMP1,DTEMP2,DTEMP3,
CCCCC1            IQUAME,IQUASE,PSTAMV,
     1            STAT1,
     1            ISUBRO,IBUGA3,IERROR)
                  IF(IERROR.EQ.'YES')GOTO9000
                ENDIF
C
                IF(ICASCT.NE.'LOCA')THEN
                  CALL CMPSTA(
     1            ZTEMP1,ZTEMP2,ZTEMP3,TEMP3,TEMP4,TEMP5,
     1            MAXNXT,NTEMP1,NTEMP2,NTEMP3,NUMRES,ISCALE,
     1            ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
     1            DTEMP1,DTEMP2,DTEMP3,
CCCCC1            IQUAME,IQUASE,PSTAMV,
     1            STAT2,
     1            ISUBRO,IBUGA3,IERROR)
                  IF(IERROR.EQ.'YES')GOTO9000
                ENDIF
                DO490J=1,N
                  IF(XH1(J).EQ.XH1DIS(ISET1).AND.
     1               XH2(J).EQ.XH2DIS(ISET2).AND.
     1               XH3(J).EQ.XH3DIS(ISET3))THEN
                    Y2(J)=(Y(J)-STAT1)/STAT2
                  ENDIF
  490           CONTINUE
              ENDIF
            ENDIF
C
  430     CONTINUE
  420     CONTINUE
  410   CONTINUE
        IF(ICTALT.EQ.'COLL')N=NOUT
        GOTO9000
      ENDIF
C
C               **************************************
C               **  STEP 5--                        **
C               **  FOUR GROUP ID VARIABLES         **
C               **************************************
C
      ISTEPN='4'
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'PSTA')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(NUMGRP.EQ.4)THEN
C
        NOUT=0
        DO510ISET1=1,NUMSE1
          DO520ISET2=1,NUMSE2
          DO530ISET3=1,NUMSE3
          DO540ISET4=1,NUMSE4
            NTEMP=0
            NTEMP1=0
            NTEMP2=0
            NTEMP3=0
            IF(ICTACO.EQ.'ON')THEN
              DO550J=1,N
                IF(XH1(J).EQ.XH1DIS(ISET1).AND.
     1             XH2(J).EQ.XH2DIS(ISET2).AND.
     1             XH3(J).EQ.XH3DIS(ISET3))THEN
                  IF(XH4(J).NE.XH4DIS(ISET4))THEN
                    NTEMP=NTEMP+1
                    ZTEMP1(NTEMP)=Y(J)
                    ZTEMP2(NTEMP)=YTEMP(J)
                    ZTEMP3(NTEMP)=YTEMP2(J)
                  ENDIF
                ENDIF
  550         CONTINUE
            ELSEIF(ICTACO.EQ.'ONE')THEN
              DO551J=1,N
                IF(XH1(J).EQ.XH1DIS(ISET1).AND.
     1             XH2(J).EQ.XH2DIS(ISET2).AND.
     1             XH3(J).EQ.XH3DIS(ISET3))THEN
                  IF(XH4(J).EQ.XH4DIS(ISET4))THEN
                    NTEMP2=NTEMP2+1
                    ZTEMP2(NTEMP2)=YTEMP(J)
                    NTEMP3=NTEMP3+1
                    ZTEMP3(NTEMP3)=YTEMP2(J)
                  ELSEIF(XH4(J).NE.XH4DIS(ISET4))THEN
                    NTEMP1=NTEMP1+1
                    ZTEMP1(NTEMP1)=Y(J)
                  ENDIF
                ENDIF
  551         CONTINUE
            ELSEIF(ICTACO.EQ.'TWO')THEN
              DO552J=1,N
                IF(XH1(J).EQ.XH1DIS(ISET1).AND.
     1             XH2(J).EQ.XH2DIS(ISET2).AND.
     1             XH3(J).EQ.XH3DIS(ISET3))THEN
                  IF(XH4(J).EQ.XH4DIS(ISET4))THEN
                    NTEMP1=NTEMP1+1
                    ZTEMP1(NTEMP1)=Y(J)
                    NTEMP3=NTEMP3+1
                    ZTEMP3(NTEMP3)=YTEMP2(J)
                  ELSEIF(XH4(J).NE.XH4DIS(ISET4))THEN
                    NTEMP2=NTEMP2+1
                    ZTEMP2(NTEMP2)=YTEMP(J)
                  ENDIF
                ENDIF
  552         CONTINUE
            ELSE
              DO570J=1,N
                IF(XH1(J).EQ.XH1DIS(ISET1).AND.
     1             XH2(J).EQ.XH2DIS(ISET2).AND.
     1             XH3(J).EQ.XH3DIS(ISET3).AND.
     1             XH4(J).EQ.XH4DIS(ISET4))THEN
                  NTEMP=NTEMP+1
                  ZTEMP1(NTEMP)=Y(J)
                  ZTEMP2(NTEMP)=YTEMP(J)
                  ZTEMP3(NTEMP)=YTEMP2(J)
                ENDIF
  570         CONTINUE
            ENDIF
C
            IF(NTEMP.GT.0)THEN
              NTEMP1=NTEMP
              NTEMP2=NTEMP
              NTEMP3=NTEMP
            ENDIF
            IFLAG=1
            IFLAG2=0
            IF(NUMRES.EQ.1 .AND. NTEMP1.LE.0)THEN
              IFLAG=0
            ELSEIF(NUMRES.EQ.2)THEN
              IF(NTEMP1.LE.0 .OR. NTEMP2.LE.0)THEN
                IFLAG=0
              ENDIF
            ELSEIF(NUMRES.EQ.3)THEN
              IF(NTEMP1.LE.0 .OR. NTEMP2.LE.0 .OR. NTEMP3.LE.0)THEN
                IFLAG=0
              ENDIF
            ENDIF
            IF(ICTAEM.EQ.'INCL' .AND. ICTALT.EQ.'COLL')IFLAG2=1
C
            IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'PSTA')THEN
              WRITE(ICOUT,591)ISET1,ISET2,ISET3,ISET4,IFLAG,IFLAG2
  591         FORMAT('ISET1,ISET2,ISET3,ISET4,IFLAG,IFLAG2 = ',6I8)
              CALL DPWRST('XXX','BUG ')
              WRITE(ICOUT,393)NTEMP,NTEMP1,NTEMP2,NTEMP3
              CALL DPWRST('XXX','BUG ')
            ENDIF
C
            IWRITE='OFF'
            IF(IFLAG.EQ.1 .OR. IFLAG2.EQ.1)THEN
CCCCC         IF(ICASS7.EQ.'NUMB')THEN
CCCCC           IF(IFLAG.EQ.0 .AND. IFLAG2.EQ.1)STAT1=PSTAMV
CCCCC           STAT1=NTEMP
CCCCC           NOUT=NOUT+1
CCCCC           Y2(NOUT)=STAT1
CCCCC         ELSEIF(ICASS7.EQ.'GRO1')THEN
              IF(ICASS7.EQ.'GRO1')THEN
                STAT1=XH1DIS(ISET1)
                NOUT=NOUT+1
                Y2(NOUT)=STAT1
              ELSEIF(ICASS7.EQ.'GRO2')THEN
                STAT1=XH2DIS(ISET2)
                NOUT=NOUT+1
                Y2(NOUT)=STAT1
              ELSEIF(ICASS7.EQ.'GRO3')THEN
                STAT1=XH3DIS(ISET3)
                NOUT=NOUT+1
                Y2(NOUT)=STAT1
              ELSEIF(ICASS7.EQ.'GRO4')THEN
                STAT1=XH4DIS(ISET4)
                NOUT=NOUT+1
                Y2(NOUT)=STAT1
              ELSEIF(ICASS7(1:3).EQ.'GRO')THEN
                WRITE(ICOUT,597)ICASS7
  597           FORMAT('INVALID CASE: ',A4)
                CALL DPWRST('XXX','BUG ')
                IERROR='YES'
                GOTO8000
              ELSEIF(ICASCT.EQ.'CRTA')THEN
                IF(IFLAG.EQ.0 .AND. IFLAG2.EQ.1)THEN
                  STAT1=PSTAMV
                ELSEIF(NTEMP.GT.0)THEN
                  CALL CMPSTA(
     1                 ZTEMP1,ZTEMP2,ZTEMP3,TEMP3,TEMP4,TEMP5,
     1                 MAXNXT,NTEMP1,NTEMP2,NTEMP3,NUMRES,ICASS7,
     1                 ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
     1                 DTEMP1,DTEMP2,DTEMP3,
CCCCC1                 IQUAME,IQUASE,PSTAMV,
     1                 STAT1,
     1                 ISUBRO,IBUGA3,IERROR)
                  IF(IERROR.EQ.'YES')GOTO9000
                ELSE
                  STAT1=PSTAMV
                ENDIF
                IF(ICTALT.EQ.'COLL')THEN
                  NOUT=NOUT+1
                  Y2(NOUT)=STAT1
                ELSE
                  DO580J=1,N
                    IF(XH1(J).EQ.XH1DIS(ISET1).AND.
     1                 XH2(J).EQ.XH2DIS(ISET2).AND.
     1                 XH3(J).EQ.XH3DIS(ISET3).AND.
     1                 XH4(J).EQ.XH4DIS(ISET4))THEN
                      Y2(J)=STAT1
                    ENDIF
  580             CONTINUE
                ENDIF
              ELSEIF(ICASCT.EQ.'CTCU')THEN
                DO581J=1,NTEMP1
                  NTEMPZ=J
                  CALL CMPSTA(
     1                 ZTEMP1,ZTEMP2,ZTEMP3,TEMP3,TEMP4,TEMP5,
     1                 MAXNXT,NTEMPZ,NTEMPZ,NTEMPZ,NUMRES,ICASS7,
     1                 ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
     1                 DTEMP1,DTEMP2,DTEMP3,
CCCCC1                 IQUAME,IQUASE,PSTAMV,
     1                 STAT1,
     1                 ISUBRO,IBUGA3,IERROR)
                  NOUT=NOUT+1
                  IF(IERROR.EQ.'YES')THEN
                    Y2(NOUT)=PSTAMV
                  ELSE
                    Y2(NOUT)=STAT1
                  ENDIF
  581           CONTINUE
              ELSEIF(ICTAEM.EQ.'INCL' .AND. ICTALT.EQ.'COLL')THEN
                STAT1=PSTAMV
                NOUT=NOUT+1
                Y2(NOUT)=STAT1
              ELSE
                STAT1=0.0
                STAT2=1.0
                IF(ICASCT.NE.'SCAL')THEN
                  CALL CMPSTA(
     1            ZTEMP1,ZTEMP2,ZTEMP3,TEMP3,TEMP4,TEMP5,
     1            MAXNXT,NTEMP1,NTEMP2,NTEMP3,NUMRES,ILOC,
     1            ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
     1            DTEMP1,DTEMP2,DTEMP3,
CCCCC1            IQUAME,IQUASE,PSTAMV,
     1            STAT1,
     1            ISUBRO,IBUGA3,IERROR)
                  IF(IERROR.EQ.'YES')GOTO9000
                ENDIF
C
                IF(ICASCT.NE.'LOCA')THEN
                  CALL CMPSTA(
     1            ZTEMP1,ZTEMP2,ZTEMP3,TEMP3,TEMP4,TEMP5,
     1            MAXNXT,NTEMP1,NTEMP2,NTEMP3,NUMRES,ISCALE,
     1            ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
     1            DTEMP1,DTEMP2,DTEMP3,
CCCCC1            IQUAME,IQUASE,PSTAMV,
     1            STAT2,
     1            ISUBRO,IBUGA3,IERROR)
                  IF(IERROR.EQ.'YES')GOTO9000
                ENDIF
                DO590J=1,N
                  IF(XH1(J).EQ.XH1DIS(ISET1).AND.
     1               XH2(J).EQ.XH2DIS(ISET2).AND.
     1               XH3(J).EQ.XH3DIS(ISET3).AND.
     1               XH4(J).EQ.XH4DIS(ISET4))THEN
                    Y2(J)=(Y(J)-STAT1)/STAT2
                  ENDIF
  590           CONTINUE
              ENDIF
            ENDIF
C
  540     CONTINUE
  530     CONTINUE
  520     CONTINUE
  510   CONTINUE
        IF(ICTALT.EQ.'COLL')N=NOUT
        GOTO9000
      ENDIF
C
      GOTO9000
C
C               **************************************
C               **  STEP 6--                        **
C               **  FIVE GROUP ID VARIABLES         **
C               **************************************
C
      ISTEPN='5'
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'PSTA')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(NUMGRP.EQ.5)THEN
C
        NOUT=0
        DO610ISET1=1,NUMSE1
          DO620ISET2=1,NUMSE2
          DO630ISET3=1,NUMSE3
          DO640ISET4=1,NUMSE4
          DO650ISET5=1,NUMSE5
            NTEMP=0
            NTEMP1=0
            NTEMP2=0
            NTEMP3=0
            IF(ICTACO.EQ.'ON')THEN
              DO651J=1,N
                IF(XH1(J).EQ.XH1DIS(ISET1).AND.
     1             XH2(J).EQ.XH2DIS(ISET2).AND.
     1             XH3(J).EQ.XH3DIS(ISET3).AND.
     1             XH4(J).EQ.XH4DIS(ISET4))THEN
                  IF(XH5(J).NE.XH5DIS(ISET5))THEN
                    NTEMP=NTEMP+1
                    ZTEMP1(NTEMP)=Y(J)
                    ZTEMP2(NTEMP)=YTEMP(J)
                    ZTEMP3(NTEMP)=YTEMP2(J)
                  ENDIF
                ENDIF
  651         CONTINUE
            ELSEIF(ICTACO.EQ.'ONE')THEN
              DO653J=1,N
                IF(XH1(J).EQ.XH1DIS(ISET1).AND.
     1             XH2(J).EQ.XH2DIS(ISET2).AND.
     1             XH3(J).EQ.XH3DIS(ISET3).AND.
     1             XH4(J).EQ.XH4DIS(ISET4))THEN
                  IF(XH5(J).EQ.XH5DIS(ISET5))THEN
                    NTEMP2=NTEMP2+1
                    ZTEMP2(NTEMP2)=YTEMP(J)
                    NTEMP3=NTEMP3+1
                    ZTEMP3(NTEMP3)=YTEMP2(J)
                  ELSEIF(XH5(J).NE.XH5DIS(ISET5))THEN
                    NTEMP1=NTEMP1+1
                    ZTEMP1(NTEMP1)=Y(J)
                  ENDIF
                ENDIF
  653         CONTINUE
            ELSEIF(ICTACO.EQ.'TWO')THEN
              DO655J=1,N
                IF(XH1(J).EQ.XH1DIS(ISET1).AND.
     1             XH2(J).EQ.XH2DIS(ISET2).AND.
     1             XH3(J).EQ.XH3DIS(ISET3).AND.
     1             XH4(J).EQ.XH4DIS(ISET4))THEN
                  IF(XH5(J).EQ.XH5DIS(ISET5))THEN
                    NTEMP1=NTEMP1+1
                    ZTEMP1(NTEMP1)=Y(J)
                    NTEMP3=NTEMP3+1
                    ZTEMP3(NTEMP3)=YTEMP2(J)
                  ELSEIF(XH5(J).NE.XH5DIS(ISET5))THEN
                    NTEMP2=NTEMP2+1
                    ZTEMP2(NTEMP2)=YTEMP(J)
                  ENDIF
                ENDIF
  655         CONTINUE
            ELSE
              DO670J=1,N
                IF(XH1(J).EQ.XH1DIS(ISET1).AND.
     1             XH2(J).EQ.XH2DIS(ISET2).AND.
     1             XH3(J).EQ.XH3DIS(ISET3).AND.
     1             XH4(J).EQ.XH4DIS(ISET4).AND.
     1             XH5(J).EQ.XH5DIS(ISET5))THEN
                  NTEMP=NTEMP+1
                  ZTEMP1(NTEMP)=Y(J)
                  ZTEMP2(NTEMP)=YTEMP(J)
                  ZTEMP3(NTEMP)=YTEMP2(J)
                ENDIF
  670         CONTINUE
            ENDIF
C
            IF(NTEMP.GT.0)THEN
              NTEMP1=NTEMP
              NTEMP2=NTEMP
              NTEMP3=NTEMP
            ENDIF
            IFLAG=1
            IFLAG2=0
            IF(NUMRES.EQ.1 .AND. NTEMP1.LE.0)THEN
              IFLAG=0
            ELSEIF(NUMRES.EQ.2)THEN
              IF(NTEMP1.LE.0 .OR. NTEMP2.LE.0)THEN
                IFLAG=0
              ENDIF
            ELSEIF(NUMRES.EQ.3)THEN
              IF(NTEMP1.LE.0 .OR. NTEMP2.LE.0 .OR. NTEMP3.LE.0)THEN
                IFLAG=0
              ENDIF
            ENDIF
            IF(ICTAEM.EQ.'INCL' .AND. ICTALT.EQ.'COLL')IFLAG2=1
C
            IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'PSTA')THEN
              WRITE(ICOUT,691)ISET1,ISET2,ISET3,ISET4,ISET5,
     1                        IFLAG,IFLAG2
  691         FORMAT('ISET1,ISET2,ISET3,ISET4,ISET5,IFLAG,IFLAG2 = ',
     1               7I8)
              CALL DPWRST('XXX','BUG ')
              WRITE(ICOUT,393)NTEMP,NTEMP1,NTEMP2,NTEMP3
              CALL DPWRST('XXX','BUG ')
            ENDIF
C
            IWRITE='OFF'
            IF(IFLAG.EQ.1 .OR. IFLAG2.EQ.1)THEN
CCCCC         IF(ICASS7.EQ.'NUMB')THEN
CCCCC           IF(IFLAG.EQ.0 .AND. IFLAG2.EQ.1)STAT1=PSTAMV
CCCCC           STAT1=NTEMP
CCCCC           NOUT=NOUT+1
CCCCC           Y2(NOUT)=STAT1
CCCCC         ELSEIF(ICASS7.EQ.'GRO1')THEN
              IF(ICASS7.EQ.'GRO1')THEN
                STAT1=XH1DIS(ISET1)
                NOUT=NOUT+1
                Y2(NOUT)=STAT1
              ELSEIF(ICASS7.EQ.'GRO2')THEN
                STAT1=XH2DIS(ISET2)
                NOUT=NOUT+1
                Y2(NOUT)=STAT1
              ELSEIF(ICASS7.EQ.'GRO3')THEN
                STAT1=XH3DIS(ISET3)
                NOUT=NOUT+1
                Y2(NOUT)=STAT1
              ELSEIF(ICASS7.EQ.'GRO4')THEN
                STAT1=XH4DIS(ISET4)
                NOUT=NOUT+1
                Y2(NOUT)=STAT1
              ELSEIF(ICASS7.EQ.'GRO5')THEN
                STAT1=XH5DIS(ISET5)
                NOUT=NOUT+1
                Y2(NOUT)=STAT1
              ELSEIF(ICASS7(1:3).EQ.'GRO')THEN
                WRITE(ICOUT,697)ICASS7
  697           FORMAT('INVALID CASE: ',A4)
                CALL DPWRST('XXX','BUG ')
                IERROR='YES'
                GOTO8000
              ELSEIF(ICASCT.EQ.'CRTA')THEN
                IF(IFLAG.EQ.0 .AND. IFLAG2.EQ.1)THEN
                  STAT1=PSTAMV
                ELSEIF(NTEMP.GT.0)THEN
                  CALL CMPSTA(
     1                 ZTEMP1,ZTEMP2,ZTEMP3,TEMP3,TEMP4,TEMP5,
     1                 MAXNXT,NTEMP1,NTEMP2,NTEMP3,NUMRES,ICASS7,
     1                 ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
     1                 DTEMP1,DTEMP2,DTEMP3,
CCCCC1                 IQUAME,IQUASE,PSTAMV,
     1                 STAT1,
     1                 ISUBRO,IBUGA3,IERROR)
                  IF(IERROR.EQ.'YES')GOTO9000
                ELSE
                  STAT1=PSTAMV
                ENDIF
                IF(ICTALT.EQ.'COLL')THEN
                  NOUT=NOUT+1
                  Y2(NOUT)=STAT1
                ELSE
                  DO680J=1,N
                    IF(XH1(J).EQ.XH1DIS(ISET1).AND.
     1                 XH2(J).EQ.XH2DIS(ISET2).AND.
     1                 XH3(J).EQ.XH3DIS(ISET3).AND.
     1                 XH4(J).EQ.XH4DIS(ISET4).AND.
     1                 XH5(J).EQ.XH5DIS(ISET5))THEN
                      Y2(J)=STAT1
                    ENDIF
  680             CONTINUE
                ENDIF
              ELSEIF(ICASCT.EQ.'CTCU')THEN
                DO681J=1,NTEMP1
                  NTEMPZ=J
                  CALL CMPSTA(
     1                 ZTEMP1,ZTEMP2,ZTEMP3,TEMP3,TEMP4,TEMP5,
     1                 MAXNXT,NTEMPZ,NTEMPZ,NTEMPZ,NUMRES,ICASS7,
     1                 ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
     1                 DTEMP1,DTEMP2,DTEMP3,
CCCCC1                 IQUAME,IQUASE,PSTAMV,
     1                 STAT1,
     1                 ISUBRO,IBUGA3,IERROR)
                  NOUT=NOUT+1
                  IF(IERROR.EQ.'YES')THEN
                    Y2(NOUT)=PSTAMV
                  ELSE
                    Y2(NOUT)=STAT1
                  ENDIF
  681           CONTINUE
              ELSEIF(ICTAEM.EQ.'INCL' .AND. ICTALT.EQ.'COLL')THEN
                STAT1=PSTAMV
                NOUT=NOUT+1
                Y2(NOUT)=STAT1
              ELSE
                STAT1=0.0
                STAT2=1.0
                IF(ICASCT.NE.'SCAL')THEN
                  CALL CMPSTA(
     1            ZTEMP1,ZTEMP2,ZTEMP3,TEMP3,TEMP4,TEMP5,
     1            MAXNXT,NTEMP1,NTEMP2,NTEMP3,NUMRES,ILOC,
     1            ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
     1            DTEMP1,DTEMP2,DTEMP3,
CCCCC1            IQUAME,IQUASE,PSTAMV,
     1            STAT1,
     1            ISUBRO,IBUGA3,IERROR)
                  IF(IERROR.EQ.'YES')GOTO9000
                ENDIF
C
                IF(ICASCT.NE.'LOCA')THEN
                  CALL CMPSTA(
     1            ZTEMP1,ZTEMP2,ZTEMP3,TEMP3,TEMP4,TEMP5,
     1            MAXNXT,NTEMP1,NTEMP2,NTEMP3,NUMRES,ISCALE,
     1            ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
     1            DTEMP1,DTEMP2,DTEMP3,
CCCCC1            IQUAME,IQUASE,PSTAMV,
     1            STAT2,
     1            ISUBRO,IBUGA3,IERROR)
                  IF(IERROR.EQ.'YES')GOTO9000
                ENDIF
                DO690J=1,N
                  IF(XH1(J).EQ.XH1DIS(ISET1).AND.
     1               XH2(J).EQ.XH2DIS(ISET2).AND.
     1               XH3(J).EQ.XH3DIS(ISET3).AND.
     1               XH4(J).EQ.XH4DIS(ISET4).AND.
     1               XH5(J).EQ.XH5DIS(ISET5))THEN
                    Y2(J)=(Y(J)-STAT1)/STAT2
                  ENDIF
  690           CONTINUE
              ENDIF
            ENDIF
C
  650     CONTINUE
  640     CONTINUE
  630     CONTINUE
  620     CONTINUE
  610   CONTINUE
        IF(ICTALT.EQ.'COLL')N=NOUT
        GOTO9000
      ENDIF
C
      GOTO9000
C
C               **************************************
C               **  STEP 7--                        **
C               **  SIX  GROUP ID VARIABLES         **
C               **************************************
C
      ISTEPN='6'
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'PSTA')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(NUMGRP.EQ.6)THEN
C
        NOUT=0
        DO710ISET1=1,NUMSE1
          DO720ISET2=1,NUMSE2
          DO730ISET3=1,NUMSE3
          DO740ISET4=1,NUMSE4
          DO750ISET5=1,NUMSE5
          DO760ISET6=1,NUMSE6
            NTEMP=0
            NTEMP1=0
            NTEMP2=0
            NTEMP3=0
            IF(ICTACO.EQ.'ON')THEN
              DO761J=1,N
                IF(XH1(J).EQ.XH1DIS(ISET1).AND.
     1             XH2(J).EQ.XH2DIS(ISET2).AND.
     1             XH3(J).EQ.XH3DIS(ISET3).AND.
     1             XH4(J).EQ.XH4DIS(ISET4).AND.
     1             XH5(J).EQ.XH5DIS(ISET5))THEN
                  IF(XH6(J).NE.XH6DIS(ISET6))THEN
                    NTEMP=NTEMP+1
                    ZTEMP1(NTEMP)=Y(J)
                    ZTEMP2(NTEMP)=YTEMP(J)
                    ZTEMP3(NTEMP)=YTEMP2(J)
                  ENDIF
                ENDIF
  761         CONTINUE
            ELSEIF(ICTACO.EQ.'ONE')THEN
              DO763J=1,N
                IF(XH1(J).EQ.XH1DIS(ISET1).AND.
     1             XH2(J).EQ.XH2DIS(ISET2).AND.
     1             XH3(J).EQ.XH3DIS(ISET3).AND.
     1             XH4(J).EQ.XH4DIS(ISET4).AND.
     1             XH5(J).EQ.XH5DIS(ISET5))THEN
                  IF(XH6(J).EQ.XH6DIS(ISET6))THEN
                    NTEMP2=NTEMP2+1
                    ZTEMP2(NTEMP2)=YTEMP(J)
                    NTEMP3=NTEMP3+1
                    ZTEMP3(NTEMP3)=YTEMP2(J)
                  ELSEIF(XH5(J).NE.XH5DIS(ISET5))THEN
                    NTEMP1=NTEMP1+1
                    ZTEMP1(NTEMP1)=Y(J)
                  ENDIF
                ENDIF
  763         CONTINUE
            ELSEIF(ICTACO.EQ.'TWO')THEN
              DO765J=1,N
                IF(XH1(J).EQ.XH1DIS(ISET1).AND.
     1             XH2(J).EQ.XH2DIS(ISET2).AND.
     1             XH3(J).EQ.XH3DIS(ISET3).AND.
     1             XH4(J).EQ.XH4DIS(ISET4).AND.
     1             XH5(J).EQ.XH5DIS(ISET5))THEN
                  IF(XH6(J).EQ.XH6DIS(ISET6))THEN
                    NTEMP1=NTEMP1+1
                    ZTEMP1(NTEMP1)=Y(J)
                    NTEMP3=NTEMP3+1
                    ZTEMP3(NTEMP3)=YTEMP2(J)
                  ELSEIF(XH6(J).NE.XH6DIS(ISET6))THEN
                    NTEMP2=NTEMP2+1
                    ZTEMP2(NTEMP2)=YTEMP(J)
                  ENDIF
                ENDIF
  765         CONTINUE
            ELSE
              DO770J=1,N
                IF(XH1(J).EQ.XH1DIS(ISET1).AND.
     1             XH2(J).EQ.XH2DIS(ISET2).AND.
     1             XH3(J).EQ.XH3DIS(ISET3).AND.
     1             XH4(J).EQ.XH4DIS(ISET4).AND.
     1             XH5(J).EQ.XH5DIS(ISET5).AND.
     1             XH6(J).EQ.XH6DIS(ISET6))THEN
                  NTEMP=NTEMP+1
                  ZTEMP1(NTEMP)=Y(J)
                  ZTEMP2(NTEMP)=YTEMP(J)
                  ZTEMP3(NTEMP)=YTEMP2(J)
                ENDIF
  770         CONTINUE
            ENDIF
C
            IF(NTEMP.GT.0)THEN
              NTEMP1=NTEMP
              NTEMP2=NTEMP
              NTEMP3=NTEMP
            ENDIF
            IFLAG=1
            IFLAG2=0
            IF(NUMRES.EQ.1 .AND. NTEMP1.LE.0)THEN
              IFLAG=0
            ELSEIF(NUMRES.EQ.2)THEN
              IF(NTEMP1.LE.0 .OR. NTEMP2.LE.0)THEN
                IFLAG=0
              ENDIF
            ELSEIF(NUMRES.EQ.3)THEN
              IF(NTEMP1.LE.0 .OR. NTEMP2.LE.0 .OR. NTEMP3.LE.0)THEN
                IFLAG=0
              ENDIF
            ENDIF
            IF(ICTAEM.EQ.'INCL' .AND. ICTALT.EQ.'COLL')IFLAG2=1
C
            IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'PSTA')THEN
              WRITE(ICOUT,791)ISET1,ISET2,ISET3,ISET4,ISET5,ISET6,
     1                        IFLAG,IFLAG2
  791         FORMAT('ISET1,ISET2,ISET3,ISET4,ISET5,ISET6,',
     1               'IFLAG,IFLAG2 = ',8I8)
              CALL DPWRST('XXX','BUG ')
              WRITE(ICOUT,393)NTEMP,NTEMP1,NTEMP2,NTEMP3
              CALL DPWRST('XXX','BUG ')
            ENDIF
C
            IWRITE='OFF'
            IF(IFLAG.EQ.1 .OR. IFLAG2.EQ.1)THEN
CCCCC         IF(ICASS7.EQ.'NUMB')THEN
CCCCC           IF(IFLAG.EQ.0 .AND. IFLAG2.EQ.1)STAT1=PSTAMV
CCCCC           STAT1=NTEMP
CCCCC           NOUT=NOUT+1
CCCCC           Y2(NOUT)=STAT1
CCCCC         ELSEIF(ICASS7.EQ.'GRO1')THEN
              IF(ICASS7.EQ.'GRO1')THEN
                STAT1=XH1DIS(ISET1)
                NOUT=NOUT+1
                Y2(NOUT)=STAT1
              ELSEIF(ICASS7.EQ.'GRO2')THEN
                STAT1=XH2DIS(ISET2)
                NOUT=NOUT+1
                Y2(NOUT)=STAT1
              ELSEIF(ICASS7.EQ.'GRO3')THEN
                STAT1=XH3DIS(ISET3)
                NOUT=NOUT+1
                Y2(NOUT)=STAT1
              ELSEIF(ICASS7.EQ.'GRO4')THEN
                STAT1=XH4DIS(ISET4)
                NOUT=NOUT+1
                Y2(NOUT)=STAT1
              ELSEIF(ICASS7.EQ.'GRO5')THEN
                STAT1=XH5DIS(ISET5)
                NOUT=NOUT+1
                Y2(NOUT)=STAT1
              ELSEIF(ICASS7.EQ.'GRO6')THEN
                STAT1=XH6DIS(ISET6)
                NOUT=NOUT+1
                Y2(NOUT)=STAT1
              ELSEIF(ICASS7(1:3).EQ.'GRO')THEN
                WRITE(ICOUT,797)ICASS7
  797           FORMAT('INVALID CASE: ',A4)
                CALL DPWRST('XXX','BUG ')
                IERROR='YES'
                GOTO8000
              ELSEIF(ICASCT.EQ.'CRTA')THEN
                IF(IFLAG.EQ.0 .AND. IFLAG2.EQ.1)THEN
                  STAT1=PSTAMV
                ELSEIF(NTEMP.GT.0)THEN
                  CALL CMPSTA(
     1                 ZTEMP1,ZTEMP2,ZTEMP3,TEMP3,TEMP4,TEMP5,
     1                 MAXNXT,NTEMP1,NTEMP2,NTEMP3,NUMRES,ICASS7,
     1                 ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
     1                 DTEMP1,DTEMP2,DTEMP3,
CCCCC1                 IQUAME,IQUASE,PSTAMV,
     1                 STAT1,
     1                 ISUBRO,IBUGA3,IERROR)
                  IF(IERROR.EQ.'YES')GOTO9000
                ELSE
                  STAT1=PSTAMV
                ENDIF
                IF(ICTALT.EQ.'COLL')THEN
                  NOUT=NOUT+1
                  Y2(NOUT)=STAT1
                ELSE
                  DO780J=1,N
                    IF(XH1(J).EQ.XH1DIS(ISET1).AND.
     1                 XH2(J).EQ.XH2DIS(ISET2).AND.
     1                 XH3(J).EQ.XH3DIS(ISET3).AND.
     1                 XH4(J).EQ.XH4DIS(ISET4).AND.
     1                 XH5(J).EQ.XH5DIS(ISET5).AND.
     1                 XH6(J).EQ.XH6DIS(ISET6))THEN
                      Y2(J)=STAT1
                    ENDIF
  780             CONTINUE
                ENDIF
              ELSEIF(ICASCT.EQ.'CTCU')THEN
                DO781J=1,NTEMP1
                  NTEMPZ=J
                  CALL CMPSTA(
     1                 ZTEMP1,ZTEMP2,ZTEMP3,TEMP3,TEMP4,TEMP5,
     1                 MAXNXT,NTEMPZ,NTEMPZ,NTEMPZ,NUMRES,ICASS7,
     1                 ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
     1                 DTEMP1,DTEMP2,DTEMP3,
CCCCC1                 IQUAME,IQUASE,PSTAMV,
     1                 STAT1,
     1                 ISUBRO,IBUGA3,IERROR)
                  NOUT=NOUT+1
                  IF(IERROR.EQ.'YES')THEN
                    Y2(NOUT)=PSTAMV
                  ELSE
                    Y2(NOUT)=STAT1
                  ENDIF
  781           CONTINUE
              ELSEIF(ICTAEM.EQ.'INCL' .AND. ICTALT.EQ.'COLL')THEN
                STAT1=PSTAMV
                NOUT=NOUT+1
                Y2(NOUT)=STAT1
              ELSE
                STAT1=0.0
                STAT2=1.0
                IF(ICASCT.NE.'SCAL')THEN
                  CALL CMPSTA(
     1            ZTEMP1,ZTEMP2,ZTEMP3,TEMP3,TEMP4,TEMP5,
     1            MAXNXT,NTEMP1,NTEMP2,NTEMP3,NUMRES,ILOC,
     1            ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
     1            DTEMP1,DTEMP2,DTEMP3,
CCCCC1            IQUAME,IQUASE,PSTAMV,
     1            STAT1,
     1            ISUBRO,IBUGA3,IERROR)
                  IF(IERROR.EQ.'YES')GOTO9000
                ENDIF
C
                IF(ICASCT.NE.'LOCA')THEN
                  CALL CMPSTA(
     1            ZTEMP1,ZTEMP2,ZTEMP3,TEMP3,TEMP4,TEMP5,
     1            MAXNXT,NTEMP1,NTEMP2,NTEMP3,NUMRES,ISCALE,
     1            ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
     1            DTEMP1,DTEMP2,DTEMP3,
CCCCC1            IQUAME,IQUASE,PSTAMV,
     1            STAT2,
     1            ISUBRO,IBUGA3,IERROR)
                  IF(IERROR.EQ.'YES')GOTO9000
                ENDIF
                DO790J=1,N
                  IF(XH1(J).EQ.XH1DIS(ISET1).AND.
     1               XH2(J).EQ.XH2DIS(ISET2).AND.
     1               XH3(J).EQ.XH3DIS(ISET3).AND.
     1               XH4(J).EQ.XH4DIS(ISET4).AND.
     1               XH5(J).EQ.XH5DIS(ISET5).AND.
     1               XH6(J).EQ.XH6DIS(ISET6))THEN
                    Y2(J)=(Y(J)-STAT1)/STAT2
                  ENDIF
  790           CONTINUE
              ENDIF
            ENDIF
C
  760     CONTINUE
  750     CONTINUE
  740     CONTINUE
  730     CONTINUE
  720     CONTINUE
  710   CONTINUE
        IF(ICTALT.EQ.'COLL')N=NOUT
        GOTO9000
      ENDIF
C
      GOTO9000
C
 8000 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,8011)
 8011 FORMAT('***** ERROR IN LET ... = CROSS TABULATE ... --')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,8013)
 8013 FORMAT('      USE OF    GROUP <ONE/TWO/THREE/FOUR>   OPTION')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,8015)
 8015 FORMAT('      IS NOT VALID IN THIS CASE.  NOTHING DONE.')
      CALL DPWRST('XXX','BUG ')
      GOTO9000
C
C               ******************
C               **   STEP 90--  **
C               **   EXIT       **
C               ******************
C
 9000 CONTINUE
      ICTALT=ICTAL2
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'PSTA')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END       OF GRPSTA--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9015)N,NOUT
 9015   FORMAT('N,NOUT = ',2I8)
        CALL DPWRST('XXX','BUG ')
        DO9017I=1,N
          WRITE(ICOUT,9018)I,Y2(I)
 9018     FORMAT('I,Y2(I) = ',I8,G15.7)
          CALL DPWRST('XXX','BUG ')
 9017   CONTINUE
      ENDIF
C
      RETURN
      END
      SUBROUTINE GRSTRI(ICTEXT,NCTEXT)
C
C     PURPOSE--CHANGE LC() AND UC() IN CHARACTER STRINGS TO
C              ASCII UPPER AND LOWER CASE.  ALSO, CONVERT SP()
C              TO AN ASCII SPACE.  THIS IS DONE FOR HARDWARE GENERATED
C              TEXT ONLY (SOFTWARE GENERATED TEXT ALREADY HANDLES
C              IT AT A LOWER LEVEL).
C     INPUT  ARGUMENTS--ICTEXT      (CHARACTER)
C                       NCTEXT      (INTEGER)
C     OUTPUT ARGUMENTS--ICSTRING
C                       NCTEXT
C               WRITTEN BY -
C                      ALAN HECKERT
C                      CENTER FOR APPLIED MATHEMATICS,
C                      NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                      WASHINGTON, DC 20234
C                      TELEPHONE 301-975-2899
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--93/3
C     ORIGINAL VERSION--MARCH     1993. (ALAN)
C     UPDATED         --OCTOBER   1993. TEXT NO LONGER GARUNTEED TO
C                                       COME IN AS UPPER CASE (ALAN)
C     UPDATED         --FEBRUARY  2006. FOR SP(), CHECK THAT WE
C                                       DON'T HABE UNSP() CASE
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IFLAG
      CHARACTER*4 ICTEXT(*)
      CHARACTER*1 ICTEMP
CCCCC ADD FOLLOWING 4 LINES.                OCTOBER 1993
      CHARACTER*1 IA1
      CHARACTER*1 IA2
      CHARACTER*1 IA3
      CHARACTER*1 IA4
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      IF(NCTEXT.LT.4)GOTO9000
C
      J=0
      ISKIP=0
      IFLAG='UC'
CCCCC OCTOBER 1993.  FOLLOWING LOOP RECODED TO ACCOUNT FOR THE FACT
CCCCC TEXT COMING IN IS NO LONGER NECCESSARILY UPPER CASE!!!
      DO100I=1,NCTEXT
        IF(ISKIP.LE.0)GOTO110
          ISKIP=ISKIP-1
          GOTO100
  110   CONTINUE
        IF(I+3.GT.NCTEXT)GOTO150
C
C  CONVERT TO UPPER CASE (FIRST 2 CHARACTERS ONLY SINCE 3 AND 4 CHECKING
C  FOR ().
C
        IA1=ICTEXT(I)(1:1)
        CALL DPCOAN(IA1,IVAL)
        IF(IVAL.GE.97.AND.IVAL.LE.122)IVAL=IVAL-32
        CALL DPCONA(IVAL,IA1)
        IA2=ICTEXT(I+1)(1:1)
        CALL DPCOAN(IA2,IVAL)
        IF(IVAL.GE.97.AND.IVAL.LE.122)IVAL=IVAL-32
        CALL DPCONA(IVAL,IA2)
        IA3=ICTEXT(I+2)(1:1)
        IA4=ICTEXT(I+3)(1:1)
C
        IF(IA1.NE.'S'.OR.IA2.NE.'P'.OR.IA3.NE.'('.OR.IA4.NE.')')GOTO115
C
          IF(I.GE.3)THEN
            IF(
     1      (ICTEXT(I-2)(1:1).EQ.'U'.OR.ICTEXT(I-2)(1:1).EQ.'u').AND.
     1      (ICTEXT(I-1)(1:1).EQ.'N'.OR.ICTEXT(I-1)(1:1).EQ.'n'))THEN
            GOTO115
            ENDIF
          ENDIF
C
          J=J+1
          ICTEXT(J)=' '
          ISKIP=3
          GOTO100
  115   CONTINUE
        IF(IA1.NE.'U'.OR.IA2.NE.'C'.OR.IA3.NE.'('.OR.IA4.NE.')')GOTO120
          IFLAG='UC'
          ISKIP=3
          GOTO100
  120   CONTINUE
        IF(IA1.NE.'L'.OR.IA2.NE.'C'.OR.IA3.NE.'('.OR.IA4.NE.')')GOTO150
          IFLAG='LC'
          ISKIP=3
          GOTO100
  150   CONTINUE
        ICTEMP=ICTEXT(I)(1:1)
        CALL DPCOAN(ICTEMP,IVALT)
        IF(IFLAG.EQ.'LC'.AND.IVALT.GE.65.AND.IVALT.LE.90)GOTO160
          J=J+1
          ICTEXT(J)=ICTEMP
          GOTO100
  160   CONTINUE
        J=J+1
        IVALT=IVALT+32
        CALL DPCONA(IVALT,ICTEMP)
        ICTEXT(J)=ICTEMP
  100 CONTINUE
      NCTEXT=J
C
 9000 CONTINUE
      RETURN
      END