      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--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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004.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)
      DOUBLE PRECISION AK
      DOUBLE PRECISION TAU
      DOUBLE PRECISION X
      DOUBLE PRECISION CDF
      DOUBLE PRECISION EPSABS
      DOUBLE PRECISION EPSREL
      DOUBLE PRECISION RESULT
      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---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,AKMBPC,AKMCPW,AKMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----DATA STATEMENTS-------------------------------------------------
C
C-----START POINT-----------------------------------------------------
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      IF(IADEDF.EQ.'K')THEN
        IF(AK.LE.0.0)THEN
          WRITE(ICOUT,5)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,48)AK
          CALL DPWRST('XXX','WRIT')
          PDF=0.0
          GOTO9000
        ENDIF
      ELSE
        AK=SQRT(2.0)/(AK + SQRT(2.0 + AK*AK))
      ENDIF
    5 FORMAT('***** ERROR: VALUE OF FIRST SHAPE PARAMETER (K) IN ',
     1       'THE GALCDF ROUTINE IS NON-POSITIVE.')
      IF(TAU.LE.0.0)THEN
        WRITE(ICOUT,15)
   15   FORMAT('***** ERROR--THE SECOND SHAPE PARAMETER (TAU) IN THE ',
     1         'GALCDF ROUTINE IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,48)TAU
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9000
      ENDIF
   48 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
C
C               ************************************
C               **  STEP 1--                      **
C               **  COMPUTE THE DENSITY FUNCTION  **
C               ************************************
C
      IADED2=IADEDF
      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--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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004.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
      INCLUDE 'DPCOST.INC'
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----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
 9000 CONTINUE
      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--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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004.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---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----DATA STATEMENTS-------------------------------------------------
C
C-----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
 9000 CONTINUE
      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--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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004.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---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----DATA STATEMENTS-------------------------------------------------
C
      DATA DPI / 3.14159265358979D+00/
      DATA DEPS /0.00000001D0/
C
C-----START POINT-----------------------------------------------------
C
C               *****************************************
C               **  STEP 1--                           **
C               **  CHECK FOR VALID PARAMETERS         **
C               *****************************************
C
      IF(IADEDF.EQ.'K')THEN
        IF(AK.LE.0.0)THEN
          WRITE(ICOUT,5)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,48)AK
          CALL DPWRST('XXX','WRIT')
          PDF=0.0
          GOTO9000
        ENDIF
      ELSE
        AK=SQRT(2.0)/(AK + SQRT(2.0 + AK*AK))
      ENDIF
    5 FORMAT('***** ERROR: VALUE OF FIRST SHAPE PARAMETER (K) IN ',
     1       'GALPDF ROUTINE IS NON-POSITIVE.')
      IF(TAU.LE.0.0D0)THEN
        WRITE(ICOUT,6)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,48)TAU
        CALL DPWRST('XXX','WRIT')
        PDF=0.0D0
        GOTO9000
      ENDIF
    6 FORMAT('***** ERROR: VALUE OF SHAPE PARAMETER (TAU) IN ',
     1       'GALPDF ROUTINE IS NEGATIVE.')
   48 FORMAT('      VALUE OF ARGUMENT IS: ',G15.7)
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--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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004.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---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C               *****************************************
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,48)P
        CALL DPWRST('XXX','WRIT')
        PPF=0.0D0
        GOTO9000
      ENDIF
      IF(IADEDF.EQ.'K')THEN
        IF(AK.LE.0.0)THEN
          WRITE(ICOUT,5)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,48)AK
          CALL DPWRST('XXX','WRIT')
          PDF=0.0
          GOTO9000
        ENDIF
      ELSE
        AK=SQRT(2.0)/(AK + SQRT(2.0 + AK*AK))
      ENDIF
      IF(TAU.LE.0.0)THEN
        WRITE(ICOUT,6)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,48)TAU
        CALL DPWRST('XXX','WRIT')
        PDF=0.0
        GOTO9000
      ENDIF
    4 FORMAT('***** ERROR: VALUE OF INPUT ARGUMENT (P) IN ',
     1       'GALPPF ROUTINE')
   14 FORMAT('      IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL.')
    5 FORMAT('***** ERROR: VALUE OF FIRST SHAPE PARAMETER (K) IN ',
     1       'GALPPF ROUTINE IS NON-POSITIVE.')
    6 FORMAT('***** ERROR: VALUE OF SHAPE PARAMETER (TAU) IN ',
     1       'GALPPF ROUTINE IS NON-POSITIVE.')
   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.  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--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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004.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---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----DATA STATEMENTS-------------------------------------------------
C
C-----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
      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
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C  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
 9999 CONTINUE
      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
      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'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      ALNSML = ALOG(R1MACH(1))
      XMIN = -ALNSML
      DO 10 I=1,10
        XOLD = XMIN
        XLN = ALOG(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 = ALOG(R1MACH(2))
      XMAX = ALNBIG
      DO 30 I=1,10
        XOLD = XMAX
        XLN = ALOG(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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--82/7
C     ORIGINAL VERSION--JUNE      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---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----DATA STATEMENTS-------------------------------------------------
C
      DATA 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
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C---------------------------------------------------------------------
C
      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
      IF(X.LE.0.0)GOTO50
      IF(GAMMA.LE.0.0)GOTO55
      GOTO90
   50 CONTINUE
      WRITE(ICOUT,4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,5)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)X
      CALL DPWRST('XXX','BUG ')
      CDF=0.0
      RETURN
   55 CONTINUE
      WRITE(ICOUT,15) 
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)GAMMA
      CALL DPWRST('XXX','BUG ')
      CDF=0.0
      RETURN
   90 CONTINUE
    4 FORMAT('***** NON-FATAL DIAGNOSTIC--THE FIRST  INPUT ARGUMENT')
    5 FORMAT('      TO THE GAMCDF SUBROUTINE IS NON-POSITIVE *****')
   15 FORMAT('***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE')
   16 FORMAT('      GAMCDF SUBROUTINE IS NON-POSITIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,'*****')
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
      RETURN
C
  250 T=SUM
      CDF=(DX**DGAMMA)*(DEXP(-DX))*T/G
C
  204 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 ',E15.8)
  207 FORMAT('     THE INPUT VALUE OF GAMMA IS ',E15.8)
  208 FORMAT('     THE OUTPUT VALUE OF CDF HAS BEEN SET TO 1.0') 
C
      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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004/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
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C  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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004/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---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C
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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004/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---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C  STEP 1: 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--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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004/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---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      GAMFU4=DLOG(DB) + DPSI(DA) - DLOG(DGMEAN)
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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004/11
C     ORIGINAL VERSION--NOVEMBER   2004.
C
C---------------------------------------------------------------------
C
      REAL GHAT
C
      COMMON/GAMCO8/P,SCALE
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004/11
C     ORIGINAL VERSION--NOVEMBER   2004.
C
C---------------------------------------------------------------------
C
      COMMON/GAMCO9/P,GHAT
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      CALL GAMPPF(P,GHAT,APPF)
      GAMFU9=SCALE*APPF
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'
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX,DGAMMA,DLNGAM,DPDF
      DOUBLE PRECISION DTERM1, DTERM2, DTERM3, DTERM4, DTERM5
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(X.LT.0.0)GOTO50
      IF(GAMMA.LE.0.0)GOTO55
      GOTO90
   50 CONTINUE
      WRITE(ICOUT,4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,5)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)X
      CALL DPWRST('XXX','BUG ')
      PDF=0.0
      RETURN
   55 CONTINUE
      WRITE(ICOUT,15) 
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)GAMMA
      CALL DPWRST('XXX','BUG ')
      PDF=0.0
      RETURN
   90 CONTINUE
    4 FORMAT('***** NON-FATAL DIAGNOSTIC--THE FIRST  INPUT ARGUMENT')
    5 FORMAT('      TO THE GAMPDF SUBROUTINE IS NON-POSITIVE *****')
   15 FORMAT('***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE')
   16 FORMAT('      GAMPDF SUBROUTINE IS NON-POSITIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,'*****')
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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
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---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----DATA STATEMENTS-------------------------------------------------
C
      DATA 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
      IF(P.LE.0.0.OR.P.GE.1.0)GOTO50
      IF(GAMMA.LE.0.0)GOTO55
      GOTO90
   50 WRITE(ICOUT,1)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)P
      CALL DPWRST('XXX','BUG ')
      PPF=0.0
      RETURN
   55 WRITE(ICOUT,15)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)GAMMA
      CALL DPWRST('XXX','BUG ')
      PPF=0.0
      RETURN
   90 CONTINUE
    1 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ',
     1'GAMPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL')
   15 FORMAT('***** FATAL ERROR--THE 2ND INPUT ARGUMENT TO THE ',
     1'GAMPPF SUBROUTINE IS NON-POSITIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
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
      RETURN
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
      RETURN
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
      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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--82/7
C     ORIGINAL VERSION--NOVEMBER  1975.
C     UPDATED         --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
      DIMENSION XN(2)
      DIMENSION U(2)
C
      COMMON/SGAMM/AA,AAA
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----DATA STATEMENTS-------------------------------------------------
C
      DATA ATHIRD/0.3333333/
      DATA SQRT3 /1.73205081/
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      AA=0.0
      AAA=0.0
C
      IF(N.LT.1)GOTO50
      IF(GAMMA.LE.0.0)GOTO60
CCCCC IF(GAMMA.LE.0.33333333)GOTO65
      GOTO90
   50 WRITE(ICOUT, 5)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,47)N
      CALL DPWRST('XXX','BUG ')
      RETURN
   60 WRITE(ICOUT,15)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)GAMMA
      CALL DPWRST('XXX','BUG ')
      RETURN
CCC65 WRITE(ICOUT,16)
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC WRITE(ICOUT,17)
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC WRITE(ICOUT,46)GAMMA
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC RETURN
   90 CONTINUE
    5 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ',
     1'GAMRAN SUBROUTINE IS NON-POSITIVE *****')
   15 FORMAT('***** FATAL ERROR--THE 2ND INPUT ARGUMENT TO THE ',
     1'GAMRAN SUBROUTINE IS NON-POSITIVE *****')
   16 FORMAT('***** FATAL ERROR--THE 2ND INPUT ARGUMENT TO THE ',
     1'GAMRAN SUBROUTINE IS SMALLER THAN OR EQUAL TO 0.3333333')
   17 FORMAT( 44H                   (ALGORITHMIC RESTIRCTION))
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
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
      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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004/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 INF
      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---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      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)
      double precision  obsi(ngrp), xi(ngrp)
      double precision conf, mean, llmt, ulmt
c
      integer iseed
      real    thold(ngrp)
      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
      INTEGER IRD
      INTEGER IPR
      INTEGER NUMBPC
      INTEGER NUMCPW
      INTEGER NUMBPW
      INTEGER NCOUT
      INTEGER ILOUT
      REAL CPUMIN
      REAL CPUMAX
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      iseed = 1234579
c
      ilb = nrun * ((1.0d0 - conf)/2.0) + 1
      iub = 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/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
         do 30 m = 1, ngrp
            call chsran(1, real(ni(m) - 1), iseed, thold(m))
            esi(m) = (ni(m) - 1) * obsi(m)/thold(m)
            bb(m) = esi(m)/ni(m)
   30    continue
         call chsran(1, real(ngrp - 1), iseed, thold(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, thold(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/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,
     1IBUGG3,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---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'CHAR')GOTO1010
      GOTO1019
 1010 CONTINUE
      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 ')
 1019 CONTINUE
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
    5 PD(I) = 0.0D0
      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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--2001.11
C     ORIGINAL VERSION--NOVEMBER  2001.
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DGAMMA
      DOUBLE PRECISION DCDF
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     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         'GEECDF SUBROUTINE IS NEGATIVE')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        CDF=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         'GEECDF 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 ')
        CDF=0.0
        GOTO9000
      ENDIF
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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
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---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     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         'GEECHA SUBROUTINE IS NEGATIVE')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        HAZ=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         'GEECHA 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 ')
        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/G - SUM[i=1 to N][X(i)] -
C                  2*SUM[i=1 to N][EXP(-L*X(i)/(1-(1-G)*EXP(-L*X(i)))]
C
C              WITH G AND L DENOTING THE SHAPE PARAMETER GAMMA AND
C              SCALE PARAMETER LAMBDA RESPECTIVELY.
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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004/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---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C  COMPUTE SOME SUMS
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 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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--2001.11
C     ORIGINAL VERSION--NOVEMBER  2001.
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DGAMMA
      DOUBLE PRECISION DPDF
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
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---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     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         'GEEHAZ SUBROUTINE IS NEGATIVE')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        HAZ=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         'GEEHAZ 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 ')
        HAZ=0.0
        GOTO9000
      ENDIF
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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--2001.11
C     ORIGINAL VERSION--NOVEMBER  2001.
C
      DOUBLE PRECISION DP
      DOUBLE PRECISION DGAMMA
      DOUBLE PRECISION DPPF
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(P.LT.0.0.OR.P.GE.1.0)THEN
        WRITE(ICOUT,5)
    5   FORMAT('***** FATAL ERROR--THE FIRST INPUT ARGUMENT TO THE ',
     1         'GEEPPF SUBROUTINE')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,6)
    6   FORMAT('      OUTSIDE THE ALLOWABLE (0,1] INTERVAL.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)P
        CALL DPWRST('XXX','BUG ')
        PPF=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         'GEEPPF 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 ')
        PPF=0.0
        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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
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---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)THEN
        WRITE(ICOUT, 5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
      IF(GAMMA.LE.0.0)THEN
        WRITE(ICOUT,15)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)GAMMA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
    5 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ',
     1'GEERAN SUBROUTINE IS NON-POSITIVE *****')
   15 FORMAT('***** FATAL ERROR--THE 2ND INPUT ARGUMENT TO THE ',
     1'GEERAN SUBROUTINE IS NON-POSITIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
C
C     GENERATE N UNIFORM (0,1) RANDOM NUMBERS;
C
      CALL UNIRAN(N,ISEED,X)
C
C     GENERATE N 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,
     1Y5,Y6,N5,N6,SCAL3,ITYP3,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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--89/12
C     ORIGINAL VERSION--DECEMBER  1989.
C     UPDATED         --JUNE      1990. TEMPORARY ARRAYS TO GARBAGE 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-----DOUBLE PRECISION STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
CCCCC DOUBLE PRECISION DY1
CCCCC DOUBLE PRECISION DY2
CCCCC DOUBLE PRECISION DY3
CCCCC DOUBLE PRECISION DY4
CCCCC DOUBLE PRECISION DY5
CCCCC DOUBLE PRECISION DY6
CCCCC DOUBLE PRECISION DSUM5
CCCCC DOUBLE PRECISION DSUM6
C
      DOUBLE PRECISION DTOP
      DOUBLE PRECISION DMID
      DOUBLE PRECISION DBOT
CCCCC DOUBLE PRECISION DRATIO
C
CCCCC DOUBLE PRECISION DCUM
CCCCC DOUBLE PRECISION DX
CCCCC DOUBLE PRECISION DC
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOPA.INC'
C
      DIMENSION Y1(*)
      DIMENSION Y2(*)
      DIMENSION Y3(*)
      DIMENSION Y4(*)
      DIMENSION Y5(*)
      DIMENSION Y6(*)
C
      DIMENSION DTOP(MAXOBV)
      DIMENSION DMID(MAXOBV)
      DIMENSION DBOT(MAXOBV)
CCCCC FOLLOWING LINES ADDED JUNE, 1990
      INCLUDE 'DPCOZD.INC'
      EQUIVALENCE (DGARBG(IDGAR1),DTOP(1))
      EQUIVALENCE (DGARBG(IDGAR2),DMID(1))
      EQUIVALENCE (DGARBG(IDGAR3),DBOT(1))
CCCCC END CHANGE
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='GENA'
      ISUBN2='RI  '
C
      IERROR='NO'
C
      SCAL3=(-999.0)
      ITYP3='VECT'
C
      IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'PARI')GOTO90
      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 = ',A4,2X,A4,2X,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,2E13.5)
      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,2E13.5)
      CALL DPWRST('XXX','BUG ')
   65 CONTINUE
   90 CONTINUE
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 GENARI--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1152)
 1152 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1153)
 1153 FORMAT('      IN THE VARIABLE FOR WHICH')
      CALL DPWRST('XXX','BUG ')
      IF(IACASE.EQ.'GEAD')WRITE(ICOUT,1161)
 1161 FORMAT('      THE (DEX) GENERATOR ADDITION IS TO BE ',
     1'COMPUTED')
      IF(IACASE.EQ.'GEAD')CALL DPWRST('XXX','BUG ')
      IF(IACASE.EQ.'GESU')WRITE(ICOUT,1162)
 1162 FORMAT('      THE (DEX) GENERATOR SUBTRACTION IS TO BE ',
     1'COMPUTED')
      IF(IACASE.EQ.'GESU')CALL DPWRST('XXX','BUG ')
      IF(IACASE.EQ.'GEMU')WRITE(ICOUT,1163)
 1163 FORMAT('      THE (DEX) GENERATOR MULTIPLICATION IS TO BE ',
     1'COMPUTED')
      IF(IACASE.EQ.'GEMU')CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1181)
 1181 FORMAT('      MUST BE 1 OR LARGER.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1182)
 1182 FORMAT('      SUCH WAS NOT THE CASE HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1183)N1,N3
 1183 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS HERE = ',2I8,
     1'.')
      CALL DPWRST('XXX','BUG ')
      GOTO9000
C
 1190 CONTINUE
C
C               *********************************
C               **  STEP 12--                  **
C               **  BRANCH TO THE PROPER CASE  **
C               *********************************
C
      IF(IACASE.EQ.'GEAD')GOTO2100
      IF(IACASE.EQ.'GESU')GOTO2200
      IF(IACASE.EQ.'GEMU')GOTO2300
C
      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')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1213)
 1213 FORMAT('      GEAD, GESU, OR GEMU')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1215)
 1215 FORMAT('      IACASE = ',A4)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
C
C               *********************************************
C               **  STEP 21--                              **
C               **  TREAT THE (DEX) GENERATOR ADDITION    CASE  **
C               *********************************************
C
 2100 CONTINUE
      GOTO2300
C
C               *********************************************
C               **  STEP 22--                              **
C               **  TREAT THE (DEX) GENERATOR SUBTRACTION CASE  **
C               *********************************************
C
 2200 CONTINUE
      GOTO2300
C
C               ************************************************
C               **  STEP 23--                                 **
C               **  TREAT THE (DEX) GENERATOR MULTIPLICATION CASE  **
C               ************************************************
C
 2300 CONTINUE
      N5TEMP=0
      L=0
C
      IF(N1.LE.0)GOTO2319
      DO2310J=1,N1
      Y1J=Y1(J)
      IF(N3.LE.0)GOTO2329
      DO2320K=1,N3
      IF(Y3(K).EQ.Y1J)GOTO2310
 2320 CONTINUE
 2329 CONTINUE
      L=L+1
      Y5(L)=Y1J
 2310 CONTINUE
 2319 CONTINUE
C
      IF(N3.LE.0)GOTO2339
      DO2330J=1,N3
      Y3J=Y3(J)
      IF(N1.LE.0)GOTO2349
      DO2340K=1,N1
      IF(Y1(K).EQ.Y3J)GOTO2330
 2340 CONTINUE
 2349 CONTINUE
      L=L+1
      Y5(L)=Y3J
 2330 CONTINUE
 2339 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.'OFF'.AND.ISUBRO.NE.'PARI')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF GENARI--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IBUGA3,ISUBRO,IACASE,IWRITE
 9012 FORMAT('IBUGA3,ISUBRO,IACASE,IWRITE = ',A4,2X,A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)IERROR
 9013 FORMAT('IERROR = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9017)N1,N3,N5,N6
 9017 FORMAT('N1,N3,N5,N6 = ',4I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9018)SCAL3,ITYP3
 9018 FORMAT('SCAL3,ITYP3 = ',E15.7,2X,A4)
      CALL DPWRST('XXX','BUG ')
      IF(ITYP3.EQ.'SCAL')GOTO9090
      DO9021I=1,N1
      WRITE(ICOUT,9022)I,Y1(I),Y2(I)
 9022 FORMAT('I,Y1(I),Y2(I) = ',I8,2E13.5)
      CALL DPWRST('XXX','BUG ')
 9021 CONTINUE
      DO9031I=1,N3
      WRITE(ICOUT,9032)I,Y3(I),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,2E13.5)
      CALL DPWRST('XXX','BUG ')
 9041 CONTINUE
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE GEOCDF(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              THE GEOMETRIC DISTRIBUTION USED HEREIN
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--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 INSTITUTE OF STANDARDS AND TECHNOLOGY APPLIED MATHEMATICS
C                 SERIES 55, 1964, PAGE 929.
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
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(P.LE.0.0.OR.P.GE.1.0)GOTO50
      IF(X.LT.0.0)GOTO55
      INTX=X+0.0001 
      FINTX=INTX
      DEL=X-FINTX
      IF(DEL.LT.0.0)DEL=-DEL
      IF(DEL.GT.0.001)GOTO60
      GOTO90
   50 CONTINUE
      WRITE(ICOUT,11) 
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,12) 
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,13) 
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)P
      CALL DPWRST('XXX','BUG ')
      CDF=0.0
      RETURN
   55 CONTINUE
      WRITE(ICOUT,3)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)X
      CALL DPWRST('XXX','BUG ')
      CDF=0.0
      RETURN
   60 CONTINUE
      WRITE(ICOUT,5)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,6)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)X
      CALL DPWRST('XXX','BUG ')
   90 CONTINUE
    3 FORMAT('***** NON-FATAL DIAGNOSTIC--THE FIRST  INPUT ARGUMENT')
    4 FORMAT('      TO THE GEOCDF SUBROUTINE IS NEGATIVE *****')
    5 FORMAT('***** NON-FATAL DIAGNOSTIC--THE FIRST  INPUT ARGUMENT')
    6 FORMAT('      TO THE GEOCDF SUBROUTINE IS NON-INTEGRAL *****')
   11 FORMAT('***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE')
   12 FORMAT('      GEOCDF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1)')
   13 FORMAT('      INTERVAL *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
C-----START POINT-----------------------------------------------------
C
      CDF=1.0-(1.0-P)**(FINTX+1.0)
C
      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
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      CDF=0.0
      IF(P.LE.0.0.OR.P.GE.1.0)THEN
        WRITE(ICOUT,11) 
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,12) 
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,13) 
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)P
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
      IF(X.LT.0.0)THEN
        CDF=0.0
        GOTO9000
      ENDIF
      INTX=X+0.0001
      FINTX=INTX
      DEL=X-FINTX
      IF(ABS(DEL).GT.0.001)THEN
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,6)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
      ENDIF
    5 FORMAT('***** WARNING--THE FIRST  INPUT ARGUMENT TO THE GEOCDF')
    6 FORMAT('      SUBROUTINE IS NON-INTEGRAL *****')
   11 FORMAT('***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE')
   12 FORMAT('      GEOCDF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1)')
   13 FORMAT('      INTERVAL *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
C-----START POINT-----------------------------------------------------
C
      CDF=1.0-(1.0-P)**FINTX
C
 9000 CONTINUE
      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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--99.3
C     ORIGINAL VERSION--MARCH     1999.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DN
      DOUBLE PRECISION DX
      DOUBLE PRECISION DSUM
C
      DIMENSION X(*)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='GEOM'
      ISUBN2='EA  '
C
      IERROR='NO'
C
      IF(IBUGA3.EQ.'OFF')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF 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
  190 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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--99.3
C     ORIGINAL VERSION--MARCH     1999.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DN
      DOUBLE PRECISION DX
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DMEAN
      DOUBLE PRECISION DSD
C
      DIMENSION X(*)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='GEOS'
      ISUBN2='D   '
C
      IERROR='NO'
C
      IF(IBUGA3.EQ.'OFF')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF 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
  190 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 DENSITY
C              FUNCTION VALUE AT THE SINGLE PRECISION VALUE X
C              FOR THE GEOMETRIC DISTRIBUTION
C              WITH SINGLE PRECISION
C              'BERNOULLI PROBABILITY' PARAMETER = P.
C              THE GEOMETRIC DISTRIBUTION USED HEREIN
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--X      = THE SINGLE PRECISION VALUE 
C                                AT WHICH THE PROBABILITY DENSITY 
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--PDF    = THE SINGLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE PDF
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 PROBABILITY DENSITY 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 INSTITUTE OF STANDARDS AND TECHNOLOGY APPLIED MATHEMATICS
C                 SERIES 55, 1964, PAGE 929.
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
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      PDF=0.0
      IF(P.LE.0.0.OR.P.GE.1.0)THEN
        WRITE(ICOUT,11) 
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,12) 
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,13) 
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)P
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
      IF(X.LT.0.0)THEN
        WRITE(ICOUT,3)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9000
      ENDIF
      INTX=X+0.0001
      FINTX=INTX
      DEL=X-FINTX
      IF(ABS(DEL).GT.0.001)THEN
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,6)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
      ENDIF
    3 FORMAT('***** WARNING--THE FIRST  INPUT ARGUMENT TO THE GEOPDF')
    4 FORMAT('      SUBROUTINE IS NEGATIVE *****')
    5 FORMAT('***** WARNING--THE FIRST  INPUT ARGUMENT TO THE GEOPDF')
    6 FORMAT('      SUBROUTINE IS NON-INTEGRAL *****')
   11 FORMAT('***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE')
   12 FORMAT('      GEOPDF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1)')
   13 FORMAT('      INTERVAL *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
C-----START POINT-----------------------------------------------------
C
      TERM1=LOG(P) + FINTX*LOG(1.0-P)
      PDF=EXP(TERM1)
C
 9000 CONTINUE
      RETURN
      END 
      SUBROUTINE GE2PDF(X,P,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
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-1).
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 PROBABILITY DENSITY 
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--PDF    = THE SINGLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE PDF
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 PROBABILITY DENSITY 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 INSTITUTE OF STANDARDS AND TECHNOLOGY APPLIED MATHEMATICS
C                 SERIES 55, 1964, PAGE 929.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION (205.03)
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE:  301-975-2855
C     ORIGINAL VERSION--MARCH     2004. 
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      PDF=0.0
      IF(P.LE.0.0.OR.P.GE.1.0)THEN
        WRITE(ICOUT,11) 
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,12) 
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,13) 
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)P
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
      IF(X.LT.1.0)THEN
        WRITE(ICOUT,3)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9000
      ENDIF
      INTX=X+0.0001
      FINTX=INTX
      DEL=X-FINTX
      IF(ABS(DEL).GT.0.001)THEN
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,6)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
      ENDIF
    3 FORMAT('***** WARNING--THE FIRST  INPUT ARGUMENT TO THE GEOPDF')
    4 FORMAT('      SUBROUTINE IS NEGATIVE *****')
    5 FORMAT('***** WARNING--THE FIRST  INPUT ARGUMENT TO THE GEOPDF')
    6 FORMAT('      SUBROUTINE IS NON-INTEGRAL *****')
   11 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO THE')
   12 FORMAT('      GEOPDF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1)')
   13 FORMAT('      INTERVAL *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
C-----START POINT-----------------------------------------------------
C
      TERM1=LOG(P) + (FINTX-1.0)*LOG(1.0-P)
      PDF=EXP(TERM1)
C
 9000 CONTINUE
      RETURN
      END 
      SUBROUTINE GEOPPF(P,PPAR,PPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE GEOMETRIC
C              DISTRIBUTION WITH SINGLE PRECISION
C              'BERNOULLI PROBABILITY' PARAMETER = PPAR.
C              THE GEOMETRIC DISTRIBUTION USED
C              HEREIN HAS MEAN = (1-PPAR)/PPAR
C              AND STANDARD DEVIATION = SQRT((1-PPAR)/(PPAR*PPAR))).
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) = PPAR * (1-PPAR)**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 = 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 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                     --PPAR   = THE SINGLE PRECISION VALUE
C                                OF THE 'BERNOULLI PROBABILITY'
C                                PARAMETER FOR THE GEOMETRIC
C                                DISTRIBUTION.
C                                PPAR SHOULD BE BETWEEN
C                                0.0 (EXCLUSIVELY) AND
C                                1.0 (EXCLUSIVELY).
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 GEOMETRIC DISTRIBUTION
C             WITH 'BERNOULLI 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 (EXCLUSIVELY).
C                 --P SHOULD BE BETWEEN 0.0 (INCLUSIVELY)
C                   AND 1.0 (EXCLUSIVELY).
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--ALOG.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     COMMENT--NOTE THAT EVEN THOUGH THE OUTPUT
C              FROM THIS DISCRETE DISTRIBUTION
C              PERCENT POINT FUNCTION
C              SUBROUTINE MUST NECESSARILY BE A
C              DISCRETE INTEGER VALUE,
C              THE OUTPUT VARIABLE PPF IS SINGLE
C              PRECISION IN MODE.
C              PPF HAS BEEN SPECIFIED AS SINGLE
C              PRECISION SO AS TO CONFORM WITH THE DATAPAC
C              CONVENTION THAT ALL OUTPUT VARIABLES FROM ALL
C              DATAPAC SUBROUTINES ARE SINGLE PRECISION.
C              THIS CONVENTION IS BASED ON THE BELIEF THAT
C              1) A MIXTURE OF MODES (FLOATING POINT
C              VERSUS INTEGER) IS INCONSISTENT AND
C              AN UNNECESSARY COMPLICATION
C              IN A DATA ANALYSIS; AND
C              2) FLOATING POINT MACHINE ARITHMETIC
C              (AS OPPOSED TO INTEGER ARITHMETIC)
C              IS THE MORE NATURAL MODE FOR DOING
C              DATA ANALYSIS.
C     REFERENCES--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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--82/7
C     ORIGINAL VERSION--NOVEMBER  1975.
C     UPDATED         --DECEMBER  1981.
C     UPDATED         --MAY       1982.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(P.LT.0.0.OR.P.GE.1.0)GOTO50
      IF(PPAR.LE.0.0.OR.PPAR.GE.1.0)GOTO55
      GOTO90
   50 WRITE(ICOUT,1)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)P
      CALL DPWRST('XXX','BUG ')
      PPF=0.0
      RETURN
   55 WRITE(ICOUT,11)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)PPAR
      CALL DPWRST('XXX','BUG ')
      PPF=0.0
      RETURN
   90 CONTINUE
    1 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ',
     1'GEOPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL')
   11 FORMAT('***** FATAL ERROR--THE 2ND INPUT ARGUMENT TO THE ',
     1'GEOPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
      IF(P.NE.0.0)GOTO150
      PPF=0.0
      RETURN
  150 CONTINUE
C
      ARG1=1.0-P
      ARG2=1.0-PPAR
      ANUM=ALOG(ARG1)
      ADEN=ALOG(ARG2)
      RATIO=ANUM/ADEN
      IRATIO=RATIO
      PPF=IRATIO
      ARATIO=IRATIO
      IF(ARATIO.EQ.RATIO)PPF=IRATIO-1
      RETURN
C
      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--ALOG.
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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--82/7
C     ORIGINAL VERSION--NOVEMBER  1975.
C     UPDATED         --DECEMBER  1981.
C     UPDATED         --MAY       1982.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)THEN
        WRITE(ICOUT, 5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
      IF(P.LE.0.0.OR.P.GE.1.0)THEN
        WRITE(ICOUT,11)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,11)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)P
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
    5 FORMAT('***** ERROR--THE REQUESTED NUMBER OF GEOMETRIC ',
     1'RANDOM NUMBERS IS NON-POSITIVE.')
   11 FORMAT('***** ERROR--THE PROBABILITY OF SUCCESS PARAMETER ',
     1'FOR THE GEOMETRIC DISTRIBUTION')
   12 FORMAT('      IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8)
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8)
C
C     GENERATE N UNIFORM (0,1) RANDOM NUMBERS;
C
      CALL UNIRAN(N,ISEED,X)
C
C     GENERATE N 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=ALOG(ARG1)
      ADEN=ALOG(ARG2)
      RATIO=ANUM/ADEN
      IRATIO=RATIO
      X(I)=IRATIO
      ARATIO=IRATIO
      IF(ARATIO.EQ.RATIO)X(I)=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--ALOG.
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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--82/7
C     ORIGINAL VERSION--NOVEMBER  1975.
C     UPDATED         --DECEMBER  1981.
C     UPDATED         --MAY       1982.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)THEN
        WRITE(ICOUT, 5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
      IF(P.LE.0.0.OR.P.GE.1.0)THEN
        WRITE(ICOUT,11)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,11)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)P
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
    5 FORMAT('***** ERROR--THE REQUESTED NUMBER OF GEOMETRIC ',
     1'RANDOM NUMBERS IS NON-POSITIVE.')
   11 FORMAT('***** ERROR--THE PROBABILITY OF SUCCESS PARAMETER ',
     1'FOR THE GEOMETRIC DISTRIBUTION')
   12 FORMAT('      IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8)
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8)
C
C     GENERATE N UNIFORM (0,1) RANDOM NUMBERS;
C
      CALL UNIRAN(N,ISEED,X)
C
C     GENERATE N 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=ALOG(ARG1)
      ADEN=ALOG(ARG2)
      RATIO=ANUM/ADEN
      IRATIO=RATIO
      X(I)=IRATIO
      ARATIO=IRATIO
      IF(ARATIO.EQ.RATIO)X(I)=IRATIO-1
      X(I)=X(I)+1
  100 CONTINUE
C
 9000 CONTINUE
      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              THE GENERALIZED PARETO DISTRIBUTION USED
C              HEREIN IS DEFINED FOR ALL POSITIVE X,
C              AND HAS THE CUMULATIVE DISTRIBUTION FUNCTION
C                 F(X) = 1 - [1+GAMMA*X]**(-1/GAMMA)
C              JOHNSON, KOTZ, AND BALAKRISHNAN REVERSE THE SIGN OF
C              THE SHAPE PARAMETER TO YIELD:
C                 F(X) = 1 - [1-GAMMA*X]**(1/GAMMA)
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     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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
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
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
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(X.LT.0.0)THEN
        WRITE(ICOUT,1)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9000
      ELSEIF(X.EQ.0.0)THEN
        CDF=0.0
        GOTO9000
      ENDIF
C
      IF(IGEPDF.EQ.'JOHN')THEN
        IF(GAMMA.GT.0.0)THEN
          TEMP=1.0/GAMMA
          IF(X.GE.TEMP)THEN
            WRITE(ICOUT,3)
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,46)X
            CALL DPWRST('XXX','BUG ')
            CDF=0.0
            GOTO9000
          ENDIF
        ENDIF
      ELSE
        IF(GAMMA.LT.0.0)THEN
          TEMP=-1.0/GAMMA
          IF(X.GE.TEMP)THEN
            WRITE(ICOUT,2)
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,46)X
            CALL DPWRST('XXX','BUG ')
            CDF=0.0
            GOTO9000
          ENDIF
        ENDIF
      ENDIF
C
    1 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO GEPCDF IS ',
     1       'NON-POSITIVE.')
    2 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO GEPCDF IS ',
     1       '>= -1/GAMMA FOR NEGATIVE GAMMA')
    3 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO GEPCDF IS ',
     1       '>= 1/GAMMA FOR POSITIVE GAMMA')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
C
C     COMPUTE THE CDF VALUE
C
      DX=DBLE(X)
      DG=DBLE(GAMMA)
C
      IF(GAMMA.EQ.0.0)THEN
        DCDF=1.0D0-DEXP(-DX)
        IF(DCDF.LT.0.0D0)DCDF=0.0D0
      ELSE
        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
      ENDIF
      CDF=REAL(DCDF)
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--ALOG.
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-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
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
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
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(X.LE.0.0)THEN
        WRITE(ICOUT,1)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        HAZ=0.0
        GOTO9000
      ENDIF
C
      IF(IGEPDF.EQ.'JOHN')THEN
        IF(GAMMA.GT.0.0)THEN
          TEMP=1.0/GAMMA
          IF(X.GE.TEMP)THEN
            WRITE(ICOUT,3)
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,46)X
            CALL DPWRST('XXX','BUG ')
            HAZ=0.0
            GOTO9000
          ENDIF
        ENDIF
      ELSE
        IF(GAMMA.LT.0.0)THEN
          TEMP=-1.0/GAMMA
          IF(X.GE.TEMP)THEN
            WRITE(ICOUT,2)
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,46)X
            CALL DPWRST('XXX','BUG ')
            HAZ=0.0
            GOTO9000
          ENDIF
        ENDIF
      ENDIF
C
    1 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO GEPCHAZ IS ',
     1       'NON-POSITIVE.')
    2 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO GEPCHAZ IS ',
     1       '>= -1/GAMMA FOR NEGATIVE GAMMA')
    3 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO GEPCHAZ IS ',
     1       '>= 1/GAMMA FOR POSITIVE GAMMA')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
C
C     COMPUTE THE HAZ VALUE
C
      DX=DBLE(X)
      DG=DBLE(GAMMA)
C
      IF(GAMMA.EQ.0.0)THEN
        DHAZ=DX
      ELSE
        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
      ENDIF
      HAZ=REAL(DHAZ)
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     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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
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
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
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(X.LE.0.0)THEN
        WRITE(ICOUT,1)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        HAZ=0.0
        GOTO9000
      ENDIF
C
      IF(IGEPDF.EQ.'JOHN')THEN
        IF(GAMMA.GT.0.0)THEN
          TEMP=1.0/GAMMA
          IF(X.GE.TEMP)THEN
            WRITE(ICOUT,3)
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,46)X
            CALL DPWRST('XXX','BUG ')
            HAZ=0.0
            GOTO9000
          ENDIF
        ENDIF
      ELSE
        IF(GAMMA.LT.0.0)THEN
          TEMP=-1.0/GAMMA
          IF(X.GE.TEMP)THEN
            WRITE(ICOUT,2)
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,46)X
            CALL DPWRST('XXX','BUG ')
            HAZ=0.0
            GOTO9000
          ENDIF
        ENDIF
      ENDIF
C
    1 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO GEPHAZ IS ',
     1       'NON-POSITIVE.')
    2 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO GEPHAZ IS ',
     1       '>= -1/GAMMA FOR NEGATIVE GAMMA')
    3 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO GEPHAZ IS ',
     1       '>= 1/GAMMA FOR POSITIVE GAMMA')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
C
C     COMPUTE THE HAZ VALUE
C
      DX=DBLE(X)
      DG=DBLE(GAMMA)
      IF(GAMMA.EQ.0.0)THEN
        DHAZ=1.0D0
      ELSE
        IF(IGEPDF.EQ.'JOHN')THEN
          DHAZ=1.0D0/(1.0D0 - DG*DX)
        ELSE
          DHAZ=1.0D0/(1.0D0 + DG*DX)
        ENDIF
      ENDIF
      HAZ=DHAZ
C
 9000 CONTINUE
      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              THE GENERALIZED PARETO DENSITY USED
C              HEREIN IS DEFINED FOR ALL POSITIVE X,
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C                 F(X) = (1+GAMMA*X)**(-(1/GAMMA)-1)
C              JOHNSON AND KOTZ USE THE PARAMETERIZATION GAMMA=-GAMMA:
C                 F(X) = (1-GAMMA*X)**((1/GAMMA)-1)
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 = INTEGER VALUE, CURRENTLY NOT 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     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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--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
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IGEPDF
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DG
      DOUBLE PRECISION DPDF
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(X.LE.0.0)THEN
        WRITE(ICOUT,1)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9000
      ENDIF
C
      IF(IGEPDF.EQ.'JOHN')THEN
        IF(GAMMA.GT.0.0)THEN
          TEMP=1.0/GAMMA
          IF(X.GE.TEMP)THEN
            WRITE(ICOUT,3)
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,46)X
            CALL DPWRST('XXX','BUG ')
            PDF=0.0
            GOTO9000
          ENDIF
        ENDIF
      ELSE
        IF(GAMMA.LT.0.0)THEN
          TEMP=-1.0/GAMMA
          IF(X.GE.TEMP)THEN
            WRITE(ICOUT,2)
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,46)X
            CALL DPWRST('XXX','BUG ')
            PDF=0.0
            GOTO9000
          ENDIF
        ENDIF
      ENDIF
C
    1 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO GEPPDF IS ',
     1       'NON-POSITIVE.')
    2 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO GEPPDF IS ',
     1       '>= -1/GAMMA FOR NEGATIVE GAMMA')
    3 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO GEPPDF IS ',
     1       '>= 1/GAMMA FOR POSITIVE GAMMA')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
C
C     COMPUTE THE PDF VALUE
C
      DX=DBLE(X)
      DG=DBLE(GAMMA)
C
      IF(GAMMA.EQ.0.0)THEN
        DPDF=DEXP(-DX)
      ELSE
        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
      ENDIF
      PDF=REAL(DPDF)
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 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     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--ALOG.
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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
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
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IGEPDF
C
      DOUBLE PRECISION DP
      DOUBLE PRECISION DG
      DOUBLE PRECISION DPPF
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     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
        GOTO9000
      ENDIF
C
    1 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO ',
     1'GEPPPF IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL.')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
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
 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--ALOG.
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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
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---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      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 ')
        DPPF=0.0D0
        GOTO9000
      ENDIF
C
    1 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO ',
     1'GEDPPF IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL.')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
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
C              FUNCTION VALUE FOR THE GEOMETRIC
C              DISTRIBUTION WITH SINGLE PRECISION
C              '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
C              HEREIN HAS MEAN = 1/PPAR
C              AND STANDARD DEVIATION = SQRT((1-PPAR)/(PPAR*PPAR))).
C              THIS DISTRIBUTION IS DEFINED FOR
C              ALL POSITIVE INTEGER X--X = 1, 2, ... .
C              THIS DISTRIBUTION HAS THE PROBABILITY FUNCTION
C              F(X) = PPAR * (1-PPAR)**(X-1).
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 = 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 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                     --PPAR   = THE SINGLE PRECISION VALUE
C                                OF THE 'BERNOULLI PROBABILITY'
C                                PARAMETER FOR THE GEOMETRIC
C                                DISTRIBUTION.
C                                PPAR SHOULD BE BETWEEN
C                                0.0 (EXCLUSIVELY) AND
C                                1.0 (EXCLUSIVELY).
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 GEOMETRIC DISTRIBUTION
C             WITH 'BERNOULLI 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 (EXCLUSIVELY).
C                 --P SHOULD BE BETWEEN 0.0 (INCLUSIVELY)
C                   AND 1.0 (EXCLUSIVELY).
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--ALOG.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     COMMENT--NOTE THAT EVEN THOUGH THE OUTPUT
C              FROM THIS DISCRETE DISTRIBUTION
C              PERCENT POINT FUNCTION
C              SUBROUTINE MUST NECESSARILY BE A
C              DISCRETE INTEGER VALUE,
C              THE OUTPUT VARIABLE PPF IS SINGLE
C              PRECISION IN MODE.
C              PPF HAS BEEN SPECIFIED AS SINGLE
C              PRECISION SO AS TO CONFORM WITH THE DATAPAC
C              CONVENTION THAT ALL OUTPUT VARIABLES FROM ALL
C              DATAPAC SUBROUTINES ARE SINGLE PRECISION.
C              THIS CONVENTION IS BASED ON THE BELIEF THAT
C              1) A MIXTURE OF MODES (FLOATING POINT
C              VERSUS INTEGER) IS INCONSISTENT AND
C              AN UNNECESSARY COMPLICATION
C              IN A DATA ANALYSIS; AND
C              2) FLOATING POINT MACHINE ARITHMETIC
C              (AS OPPOSED TO INTEGER ARITHMETIC)
C              IS THE MORE NATURAL MODE FOR DOING
C              DATA ANALYSIS.
C     REFERENCES--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                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--2004/3
C     ORIGINAL VERSION--MARCH     2004.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     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
        GOTO9000
      ENDIF
      IF(PPAR.LE.0.0.OR.PPAR.GE.1.0)THEN
        WRITE(ICOUT,11)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)PPAR
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
        GOTO9000
      ENDIF
    1 FORMAT('***** FATAL ERROR--THE FIRST INPUT ARGUMENT TO THE ',
     1'GEOPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1] INTERVAL')
   11 FORMAT('***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE ',
     1'GEOPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
      IF(P.NE.0.0)GOTO150
      PPF=0.0
      RETURN
  150 CONTINUE
C
      ARG1=1.0-P
      ARG2=1.0-PPAR
      ANUM=ALOG(ARG1)
      ADEN=ALOG(ARG2)
      RATIO=ANUM/ADEN
      IRATIO=RATIO+0.99999
      PPF=IRATIO
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--ALOG.
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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
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
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
C
      DOUBLE PRECISION DP
      DOUBLE PRECISION DG
      DOUBLE PRECISION DPPF
C
      CHARACTER*4 IGEPDF
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     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
      IF(GAMMA.EQ.0.0)THEN
        CALL EXPRAN(N,ISEED,X)
      ELSE
        CALL UNIRAN(N,ISEED,X)
C
C       GENERATE N GENERALIZED PARETO DISTRIBUTION RANDOM NUMBERS
C       USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD.
C
        DG=DBLE(GAMMA)
C
        IF(IGEPDF.EQ.'JOHN')THEN
          DO100I=1,N
            DP=DBLE(X(I))
            DPPF=(-1.0D0/DG)*(((1.0D0-DP)**DG)-1.0D0)
            X(I)=REAL(DPPF)
  100     CONTINUE
        ELSE
          DO200I=1,N
            DP=DBLE(X(I))
            DPPF=(1.0D0/DG)*(((1.0D0-DP)**(-DG))-1.0D0)
            X(I)=REAL(DPPF)
  200     CONTINUE
        ENDIF
      ENDIF
C
 9000 CONTINUE
      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
      CHARACTER*4 IFEEDB
      CHARACTER*4 ICOUTINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,ICOUTINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
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
      CHARACTER*4 IFEEDB
      CHARACTER*4 ICOUTINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,ICOUTINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
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
      CHARACTER*4 IFEEDB
      CHARACTER*4 ICOUTINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,ICOUTINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
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 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
      CHARACTER*4 IFEEDB
      CHARACTER*4 ICOUTINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,ICOUTINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
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
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
      REAL CPUMIN
      REAL CPUMAX
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      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--ALOG.
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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--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
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     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--ALOG.
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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2001.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---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     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
      CHARACTER*4 IFEEDB
      CHARACTER*4 ICOUTINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,ICOUTINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
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
      CHARACTER*4 IFEEDB
      CHARACTER*4 ICOUTINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,ICOUTINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--96/2
C     ORIGINAL VERSION--FEBRUARY  1996.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DATA 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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
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---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
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---------------------------------------------------------------------
C
      INCLUDE 'DPCOMC.INC'
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----DATA STATEMENTS-------------------------------------------------
C
C-----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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
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---------------------------------------------------------------------
C
      INCLUDE 'DPCOMC.INC'
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----DATA STATEMENTS-------------------------------------------------
C
C-----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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
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'
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----DATA STATEMENTS-------------------------------------------------
C
C-----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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
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'
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----DATA STATEMENTS-------------------------------------------------
C
C-----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 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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
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'
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----DATA STATEMENTS-------------------------------------------------
C
C-----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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--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
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DATA 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
      IF(P.LT.0.0.OR.P.GE.1.0)THEN
        WRITE(ICOUT,1)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)P
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
        GOTO9999
      ENDIF
      IF(ALPHA.LE.0)THEN
        WRITE(ICOUT,15)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ALPHA
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
        GOTO9999
      ENDIF
      IF(C.EQ.0)THEN
        WRITE(ICOUT,16)
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
        GOTO9999
      ENDIF
C
    1 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ',
     1' GGDPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL.')
   15 FORMAT('***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE ',
     1'GGDPPF SUBROUTINE IS NON-POSITIVE *****')
   16 FORMAT('***** FATAL ERROR--THE THIRD INPUT ARGUMENT TO THE ',
     1'GGDPPF SUBROUTINE IS ZERO *****')
   11 FORMAT('***** FATAL ERROR--THE 2ND INPUT ARGUMENT TO THE ',
     1' GGDPPF SUBROUTINE IS LESS THAN OR EQUAL TO 0.')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
   90 CONTINUE
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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--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
      DIMENSION XN(2)
      DIMENSION U(2)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----DATA STATEMENTS-------------------------------------------------
C
      DATA ATHIRD/0.3333333/
      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)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
        CALL DPWRST('XXX','BUG ')
        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
    5 FORMAT('***** FATAL ERROR--THE REQUESTED NUMBER OF GENERALIZED',
     1' GAMMA RANDOM NUMBERS IS NON-POSITIVE')
   15 FORMAT('***** FATAL ERROR--THE ALPHA SHAPE PARAMETER FOR THE ',
     1'GENERALIZED GAMMA RANDOM NUMBERS IS NON-POSITIVE')
   16 FORMAT('***** FATAL ERROR--THE C SHAPE PARAMETER FOR THE ',
     1'GENERALIZED GAMMA RANDOM NUMBERS IS NON-POSITIVE')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
C
C     GENERATE N 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+ALOG(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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--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
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      CDF=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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--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
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      DP=-1.0D0
      CALL GHPPF(P,G,H,PPF,DP,DPPF)
      GHFU2=X - PPF
C
 9999 CONTINUE
      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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004.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
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      CALL GHCDF(X,G,H,CDF)
      GHFU3=CDF
C
 9999 CONTINUE
      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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004.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
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C               ********************************************
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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--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
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     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('***** FATAL ERROR--THE FIRST (P) INPUT ARGUMENT TO THE ',
     1'GHPPF SUBROUTINE 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('***** FATAL ERROR--THE THIRD (H) INPUT ARGUMENT TO THE ',
     1'GHPPF SUBROUTINE IS NEGATIVE *****')
   48 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',F15.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
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--ALOG, 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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
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---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     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
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('***** FATAL ERROR--THE FIRST (N) INPUT ARGUMENT TO THE ',
     1'GHRAN SUBROUTINE IS NON-POSITIVE *****')
    6 FORMAT('***** FATAL ERROR--THE SECOND (G) INPUT ARGUMENT TO THE ',
     1'GHRAN SUBROUTINE IS NEGATIVE *****')
    7 FORMAT('***** FATAL ERROR--THE THIRD (H) INPUT ARGUMENT TO THE ',
     1'GHRAN SUBROUTINE IS NEGATIVE *****')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
   48 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',F15.7,' *****')
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(DX,CHI,LAMBDA,THETA,DCDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE GENERALIZED INVERSE GAUSSIAN
C              DISTRIBUTION WITH SHAPE PARAMETERS CHI, LAMBDA, AND
C              THETA.  THE CUMULATIVE DISTRIBUTION IS COMPUTED BY
C              NUMERICALLY INTEGRATING THE PDF FUNCTION.
C     INPUT  ARGUMENTS--X       = THE SINGLE PRECISION VALUE AT
C                                 WHICH THE CUMULATIVE DISTRIBUTION
C                                 FUNCTION IS TO BE EVALUATED.
C                     --CHI     = THE FIRST SHAPE PARAMETER
C                     --LAMBDA  = THE THIRD SHAPE PARAMETER
C                     --THETA   = THE THIRD SHAPE PARAMETER
C     OUTPUT ARGUMENTS--CDF     = THE SINGLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE CDF FOR THE GENERALIZED INVERSE
C             GAUSSIAN DISTRIBUTION WITH SHAPE PARAMETERS CHI,
C             LAMBDA, AND THETA.
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     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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004.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)
      DOUBLE PRECISION CHI
      DOUBLE PRECISION LAMBDA
      DOUBLE PRECISION THETA
      DOUBLE PRECISION EPSABS
      DOUBLE PRECISION EPSREL
      DOUBLE PRECISION RESULT
      DOUBLE PRECISION DCDF
      DOUBLE PRECISION DX
      DOUBLE PRECISION ABSERR
      DOUBLE PRECISION WORK(LENW)
C
      DOUBLE PRECISION GIGFUN
      EXTERNAL GIGFUN
C
      DOUBLE PRECISION DCHI
      DOUBLE PRECISION DLMBDA
      DOUBLE PRECISION DTHETA
      COMMON/GIGCOM/DCHI,DLMBDA,DTHETA
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,AKMBPC,AKMCPW,AKMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----DATA STATEMENTS-------------------------------------------------
C
C-----START POINT-----------------------------------------------------
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      IF(DX.LE.0.0D0)THEN
        WRITE(ICOUT,4)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,48)DX
        CALL DPWRST('XXX','WRIT')
        DCDF=0.0
        GOTO9000
      ENDIF
      IF(CHI.LT.0.0D0)THEN
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,48)CHI
        CALL DPWRST('XXX','WRIT')
        DCDF=0.0
        GOTO9000
      ENDIF
      IF(LAMBDA.LT.0.0D0)THEN
        WRITE(ICOUT,6)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,48)THETA
        CALL DPWRST('XXX','WRIT')
        DCDF=0.0
        GOTO9000
      ENDIF
C
      IF(CHI.EQ.0.0D0)THEN
        IF(LAMBDA.EQ.0.0D0 .OR. THETA.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)THETA
          CALL DPWRST('XXX','WRIT')
          CDF=0.0
          GOTO9000
        ENDIF
        IFLAG=1
      ENDIF
C
      IF(LAMBDA.EQ.0.0D0)THEN
        IF(CHI.EQ.0.0D0 .OR. THETA.GT.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,50)THETA
          CALL DPWRST('XXX','WRIT')
          CDF=0.0
          GOTO9000
        ENDIF
        IFLAG=2
      ENDIF
C
    4 FORMAT('***** ERROR: VALUE OF INPUT ARGUMENT (X) IN ',
     1       'GIGCDF ROUTINE IS NON-POSITIVE.')
    5 FORMAT('***** ERROR: VALUE OF FIRST SHAPE PARAMETER (CHI) IN ',
     1       'GIGCDF ROUTINE IS NEGATIVE.')
    6 FORMAT('***** ERROR: VALUE OF SECOND SHAPE PARAMETER (LAMBDA) ',
     1       'IN GIGCDF ROUTINE IS NEGATIVE.')
    7 FORMAT('***** ERROR: IF VALUE OF FIRST SHAPE PARAMETER (CHI) ',
     1       'IN GIGCDF ROUTINE IS EQUAL ZERO,')
    8 FORMAT('      THEN SECOND (LAMBDA) AND THIRD (THETA) SHAPE ',
     1       'PARAMETERS MUST BE POSITIVE.')
    9 FORMAT('***** ERROR: IF VALUE OF SECOND SHAPE PARAMETER ',
     1       '(LAMBDA) IN GIGCDF ROUTINE IS EQUAL ZERO,')
   10 FORMAT('      THEN FIRST SHAPE PARAMETER (LAMBDA) PARAMETER ',
     1       'MUST BE POSITIVE AND')
   11 FORMAT('      THE THIRD SHAPE PARAMETER (THETA) MUST BE ',
     1       'NEGATIVE.')
   48 FORMAT('      VALUE OF ARGUMENT IS: ',G15.7)
   49 FORMAT('      VALUE OF SECOND SHAPE PARAMETER IS: ',G15.7)
   50 FORMAT('      VALUE OF THIRD SHAPE PARAMETER IS: ',G15.7)
   51 FORMAT('      VALUE OF FIRST SHAPE PARAMETER IS: ',G15.7)
C
C               ************************************
C               **  STEP 1--                      **
C               **  COMPUTE THE DENSITY FUNCTION  **
C               ************************************
C
      EPSABS=0.0D0
      EPSREL=1.0D-7
      IER=0
      DCDF=0.0D0
C
      DCHI=CHI
      DLMBDA=LAMBDA
      DTHETA=THETA
      DCDF=0.0D0
C
      INF=1
C
      CALL DQAGI(GIGFUN,DX,INF,EPSABS,EPSREL,DCDF,ABSERR,NEVAL,
     1          IER,LIMIT,LENW,LAST,IWORK,WORK)
      DCDF=1.0D0 - DCDF
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,121)
  121   FORMAT('***** ERROR FROM GIGCDF--')
        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 GIGCDF--')
        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 GIGCDF--')
        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 GIGCDF--')
        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 GIGCDF--')
        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              TAU.  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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004.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 DTHETA
      COMMON/GIGCOM/DCHI,DLMBDA,DTHETA
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----DATA STATEMENTS-------------------------------------------------
C
C-----START POINT-----------------------------------------------------
C
C               ************************************
C               **  STEP 1--                      **
C               **  COMPUTE THE DENSITY FUNCTION  **
C               ************************************
C
      CALL GIGPDF(DX,DCHI,DLMBDA,DTHETA,DTERM)
      GIGFUN=DTERM
C
 9000 CONTINUE
      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              TAU.  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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004.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/GI2COM/DP
C
      DOUBLE PRECISION DCHI
      DOUBLE PRECISION DLMBDA
      DOUBLE PRECISION DTHETA
      COMMON/GIGCOM/DCHI,DLMBDA,DTHETA
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----DATA STATEMENTS-------------------------------------------------
C
C-----START POINT-----------------------------------------------------
C
C               ************************************
C               **  STEP 1--                      **
C               **  COMPUTE THE CDF     FUNCTION  **
C               ************************************
C
      CALL GIGCDF(DX,DCHI,DLMBDA,DTHETA,DCDF)
      GIGFU2=DP - DCDF
C
 9000 CONTINUE
      RETURN
      END
      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.  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                     --CHI     = THE FIRST SHAPE PARAMETER
C                     --LAMBDA  = THE THIRD SHAPE PARAMETER
C                     --THETA   = THE THIRD SHAPE PARAMETER
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 INVERSE GAUSSIAN
C             DISTRIBUTION WITH SHAPE PARAMETERS = CHI, LAMBDA, THETA.
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     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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004.8
C     ORIGINAL VERSION--AUGUST    2004.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION X
      DOUBLE PRECISION CHI
      DOUBLE PRECISION LAMBDA
      DOUBLE PRECISION THETA
      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 DLNGAM
      EXTERNAL DLNGAM
C
      DOUBLE PRECISION DTEMP1(10)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C               *****************************************
C               **  STEP 1--                           **
C               **  CHECK FOR VALID PARAMETERS         **
C               *****************************************
C
      IF(X.LE.0.0D0)THEN
        WRITE(ICOUT,4)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,48)X
        CALL DPWRST('XXX','WRIT')
        PDF=0.0
        GOTO9000
      ENDIF
      IF(CHI.LT.0.0D0)THEN
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,48)CHI
        CALL DPWRST('XXX','WRIT')
        PDF=0.0
        GOTO9000
      ENDIF
      IF(LAMBDA.LT.0.0D0)THEN
        WRITE(ICOUT,6)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,48)THETA
        CALL DPWRST('XXX','WRIT')
        PDF=0.0
        GOTO9000
      ENDIF
C
      IFLAG=0
C
      IF(CHI.EQ.0.0D0)THEN
        IF(LAMBDA.EQ.0.0D0 .OR. THETA.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)THETA
          CALL DPWRST('XXX','WRIT')
          PDF=0.0
          GOTO9000
        ENDIF
        IFLAG=1
      ENDIF
C
      IF(LAMBDA.EQ.0.0D0)THEN
        IF(CHI.EQ.0.0D0 .OR. THETA.GT.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,50)THETA
          CALL DPWRST('XXX','WRIT')
          PDF=0.0
          GOTO9000
        ENDIF
        IFLAG=2
      ENDIF
C
    4 FORMAT('***** ERROR: VALUE OF INPUT ARGUMENT (X) IN ',
     1       'GIGPDF ROUTINE IS NON-POSITIVE.')
    5 FORMAT('***** ERROR: VALUE OF FIRST SHAPE PARAMETER (CHI) IN ',
     1       'GIGPDF ROUTINE IS NEGATIVE.')
    6 FORMAT('***** ERROR: VALUE OF SECOND SHAPE PARAMETER (LAMBDA) ',
     1       'IN GIGPDF ROUTINE IS NEGATIVE.')
    7 FORMAT('***** ERROR: IF VALUE OF FIRST SHAPE PARAMETER (CHI) ',
     1       'IN GIGPDF ROUTINE IS EQUAL ZERO,')
    8 FORMAT('      THEN SECOND (LAMBDA) AND THIRD (THETA) SHAPE ',
     1       'PARAMETERS MUST BE POSITIVE.')
    9 FORMAT('***** ERROR: IF VALUE OF SECOND SHAPE PARAMETER ',
     1       '(LAMBDA) IN GIGPDF ROUTINE IS EQUAL ZERO,')
   10 FORMAT('      THEN FIRST SHAPE PARAMETER (LAMBDA) PARAMETER ',
     1       'MUST BE POSITIVE AND')
   11 FORMAT('      THE THIRD SHAPE PARAMETER (THETA) MUST BE ',
     1       'NEGATIVE.')
   48 FORMAT('      VALUE OF ARGUMENT IS: ',G15.7)
   49 FORMAT('      VALUE OF SECOND SHAPE PARAMETER IS: ',G15.7)
   50 FORMAT('      VALUE OF THIRD SHAPE PARAMETER IS: ',G15.7)
   51 FORMAT('      VALUE OF FIRST SHAPE PARAMETER 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
      IF(IFLAG.EQ.0)THEN
        DC1=(THETA/2.0D0)*DLOG(LAMBDA/CHI) - DLOG(2.0D0)
        DC2=DSQRT(LAMBDA*CHI)
        DC3=DABS(THETA)
CCCCC   IF(DC3.EQ.0.0D0)THEN
CCCCC     TERM3=BESK0(REAL(DC2))
CCCCC     DTERM2=DLOG(DBLE(TERM3))
CCCCC   ELSEIF(DC3.EQ.1.0D0)THEN
CCCCC     TERM3=BESK1(REAL(DC2))
CCCCC     DTERM2=DLOG(DBLE(TERM3))
CCCCC   ELSE
          IARG1=1
          ISCALE=1
          CALL DBESK(DC2,THETA,ISCALE,IARG1,DTEMP1,NZERO)
          DTERM2=DLOG(DTEMP1(IARG1))
CCCCC   ENDIF
        DTERM1=DC1 - DTERM2
      ELSEIF(IFLAG.EQ.1)THEN
        DTERM2=THETA*DLOG(LAMBDA) - THETA*DLOG(2.0D0) - DLNGAM(THETA)
        DTERM1=DEXP(DTERM1)
      ELSEIF(IFLAG.EQ.2)THEN
        DTERM2=THETA*DLOG(2.0D0) - THETA*DLOG(CHI) - DLNGAM(-THETA)
        DTERM1=DEXP(DTERM1)
      ENDIF
C
      DTERM2=(THETA-1.0D0)*DLOG(X)
      DTERM3=-0.5*(LAMBDA*X + (CHI/X))
      DTERM4=DTERM1 + DTERM2 + DTERM3
C
      IF(DTERM4.LE.-80.0D0)THEN
        PDF=0.0D0
      ELSEIF(DTERM4.GE.80.0D0)THEN
        PDF=0.0D0
        WRITE(ICOUT,1005)X
        CALL DPWRST('XXX','WRIT')
      ELSE
        PDF=DEXP(DTERM4)
      ENDIF
 1005 FORMAT('***** ERROR: COMPUTATION FOR GIGPDF RESULTS IN ',
     1       'OVERFLOW FOR INPUT ARGUMENT = ',G15.7)
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE GIGPPF(P,CHI,LAMBDA,THETA,PPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE GENERALIZED INVERSE GAUSSIAN
C              DISTRIBUTION.  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 NUMERICALLY
C              INVERTING THE GENERALIZED INVERSE GAUSSIAN 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                     --CHI     = THE FIRST SHAPE PARAMETER
C                     --LAMBDA  = THE THIRD SHAPE PARAMETER
C                     --THETA   = 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 INVERSE GAUSSIAN
C             DISTRIBUTION WITH SHAPE PARAMETERS = CHI, LAMBDA, THETA.
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     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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004.8
C     ORIGINAL VERSION--AUGUST    2004.
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 THETA
      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/GI2COM/DP
C
      DOUBLE PRECISION DCHI
      DOUBLE PRECISION DLMBDA
      DOUBLE PRECISION DTHETA
      COMMON/GIGCOM/DCHI,DLMBDA,DTHETA
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C               *****************************************
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,48)P
        CALL DPWRST('XXX','WRIT')
        PPF=0.0D0
        GOTO9000
      ENDIF
      IF(CHI.LT.0.0D0)THEN
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,48)CHI
        CALL DPWRST('XXX','WRIT')
        PPF=0.0D0
        GOTO9000
      ENDIF
      IF(LAMBDA.LT.0.0D0)THEN
        WRITE(ICOUT,6)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,48)THETA
        CALL DPWRST('XXX','WRIT')
        PPF=0.0D0
        GOTO9000
      ENDIF
C
      IFLAG=0
C
      IF(CHI.EQ.0.0D0)THEN
        IF(LAMBDA.EQ.0.0D0 .OR. THETA.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)THETA
          CALL DPWRST('XXX','WRIT')
          PPF=0.0D0
          GOTO9000
        ENDIF
        IFLAG=1
      ENDIF
C
      IF(LAMBDA.EQ.0.0D0)THEN
        IF(CHI.EQ.0.0D0 .OR. THETA.GT.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,50)THETA
          CALL DPWRST('XXX','WRIT')
          PPF=0.0D0
          GOTO9000
        ENDIF
        IFLAG=2
      ENDIF
C
    4 FORMAT('***** ERROR: VALUE OF INPUT ARGUMENT (P) IN ',
     1       'GIGPPF ROUTINE')
   14 FORMAT('      IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL.')
    5 FORMAT('***** ERROR: VALUE OF FIRST SHAPE PARAMETER (CHI) IN ',
     1       'GIGPPF ROUTINE IS NEGATIVE.')
    6 FORMAT('***** ERROR: VALUE OF SECOND SHAPE PARAMETER (LAMBDA) ',
     1       'IN GIGPPF ROUTINE IS NEGATIVE.')
    7 FORMAT('***** ERROR: IF VALUE OF FIRST SHAPE PARAMETER (CHI) ',
     1       'IN GIGPPF ROUTINE IS EQUAL ZERO,')
    8 FORMAT('      THEN SECOND (LAMBDA) AND THIRD (THETA) SHAPE ',
     1       'PARAMETERS MUST BE POSITIVE.')
    9 FORMAT('***** ERROR: IF VALUE OF SECOND SHAPE PARAMETER ',
     1       '(LAMBDA) IN GIGPPF ROUTINE IS EQUAL ZERO,')
   10 FORMAT('      THEN FIRST SHAPE PARAMETER (LAMBDA) PARAMETER ',
     1       'MUST BE POSITIVE AND')
   11 FORMAT('      THE THIRD SHAPE PARAMETER (THETA) MUST BE ',
     1       'NEGATIVE.')
   48 FORMAT('      VALUE OF ARGUMENT IS: ',G15.7)
   49 FORMAT('      VALUE OF SECOND SHAPE PARAMETER IS: ',G15.7)
   50 FORMAT('      VALUE OF THIRD SHAPE PARAMETER IS: ',G15.7)
   51 FORMAT('      VALUE OF FIRST SHAPE PARAMETER 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             MEAN=K(THETA+1)(SQRT(LAMBDA*CHI))*SQRT(CHI/LAMBDA)/
C                      K(THETA)(SQRT(LAMBDA*CHI))
C          INCREMENT IN INTERVALS OF 1 STANDARD DEVIATION:
C             VARIANCE=K(THETA+2)(SQRT(LAMBDA*CHI))*(CHI/LAMBDA)/
C                      K(THETA)(SQRT(LAMBDA*CHI))
C
      XLOW=0.000000001D0
      CALL GIGCDF(XLOW,CHI,LAMBDA,THETA,PTEMP)
      IF(P.LE.PTEMP)THEN
        PPF=XLOW
        GOTO9000
      ENDIF
C
      IARG1=1
      ISCALE=1
      DR=DABS(THETA)
      CALL DBESK(DSQRT(LAMBDA*CHI),DR,ISCALE,IARG1,DTEMP1,NZERO)
      DTERM1=DTEMP1(1)
      DR=DABS(THETA+1.0D0)
      CALL DBESK(DSQRT(LAMBDA*CHI),DR,ISCALE,IARG1,DTEMP1,NZERO)
      DTERM2=DTEMP1(1)
      DR=DABS(THETA+2.0D0)
      CALL DBESK(DSQRT(LAMBDA*CHI),DR,ISCALE,IARG1,DTEMP1,NZERO)
      DTERM3=DTEMP1(1)
      DMEAN=(DTERM2/DTERM1)*DSQRT(CHI/LAMBDA)
      DSD=DSQRT((DTERM3/DTERM1)*(CHI/LAMBDA))
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,THETA,PTEMP)
        IF(PTEMP.GT.P)THEN
          XUP=XUP2
        ELSE
          XLOW=XUP2
          XUP2=XUP2 + DSD
          NIT=NIT+1
          GOTO200
        ENDIF
C
  300 CONTINUE
      AE=1.D-7
      RE=1.D-7
      DCHI=CHI
      DLMBDA=LAMBDA
      DTHETA=THETA
      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,THETA,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE THE GENERALIZED INVERSE GAUSSIAN DISTIBUTION
C              WITH LOCATION = 0 AND SCALE = 1.  THIS DISTRIBUTION IS
C              DEFINED FOR POSITIVE X AND HAS THE PROBABILITY DENSITY
C              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--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                     --CHI     = A SINGLE PRECISON SCALAR THAT DEFINES
C                                THE FIRST SHAPE PARAMETER.
C                     --LAMBDA = A SINGLE PRECISON SCALAR THAT DEFINES
C                                THE SECOND SHAPE PARAMETER.
C                     --THETA  = 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     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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--2004.8
C     ORIGINAL VERSION--OCTOBER   2004.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
      REAL CHI
      REAL THETA
      REAL LAMBDA
C
      DOUBLE PRECISION DCHI
      DOUBLE PRECISION DTHETA
      DOUBLE PRECISION DLMBDA
      DOUBLE PRECISION DPPF
      DOUBLE PRECISION DXTEMP
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
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
      ENDIF
    3 FORMAT('***** ERROR--THE REQUESTED NUMBER OF GENERALIZED ',
     1'INVERSE GAUSIAN')
    4 FORMAT('      RANDOM NUMBERS IS NON-POSITIVE.')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
C
      IF(CHI.LT.0.0)THEN
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,48)CHI
        CALL DPWRST('XXX','WRIT')
        GOTO9000
      ENDIF
      IF(LAMBDA.LT.0.0)THEN
        WRITE(ICOUT,6)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,48)THETA
        CALL DPWRST('XXX','WRIT')
        GOTO9000
      ENDIF
C
      IFLAG=0
C
      IF(CHI.EQ.0.0)THEN
        IF(LAMBDA.EQ.0.0 .OR. THETA.LE.0.0)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)THETA
          CALL DPWRST('XXX','WRIT')
          GOTO9000
        ENDIF
        IFLAG=1
      ENDIF
C
      IF(LAMBDA.EQ.0.0)THEN
        IF(CHI.EQ.0.0 .OR. THETA.GT.0.0)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,50)THETA
          CALL DPWRST('XXX','WRIT')
          GOTO9000
        ENDIF
        IFLAG=2
      ENDIF
C
    5 FORMAT('***** ERROR: VALUE OF FIRST SHAPE PARAMETER (CHI) IN ',
     1       'GIGRAN ROUTINE IS NEGATIVE.')
    6 FORMAT('***** ERROR: VALUE OF SECOND SHAPE PARAMETER (LAMBDA) ',
     1       'IN GIGRAN ROUTINE IS NEGATIVE.')
    7 FORMAT('***** ERROR: IF VALUE OF FIRST SHAPE PARAMETER (CHI) ',
     1       'IN GIGRAN ROUTINE IS EQUAL ZERO,')
    8 FORMAT('      THEN SECOND (LAMBDA) AND THIRD (THETA) SHAPE ',
     1       'PARAMETERS MUST BE POSITIVE.')
    9 FORMAT('***** ERROR: IF VALUE OF SECOND SHAPE PARAMETER ',
     1       '(LAMBDA) IN GIGRAN ROUTINE IS EQUAL ZERO,')
   10 FORMAT('      THEN FIRST SHAPE PARAMETER (LAMBDA) PARAMETER ',
     1       'MUST BE POSITIVE AND')
   11 FORMAT('      THE THIRD SHAPE PARAMETER (THETA) MUST BE ',
     1       'NEGATIVE.')
   48 FORMAT('      VALUE OF ARGUMENT IS: ',G15.7)
   49 FORMAT('      VALUE OF SECOND SHAPE PARAMETER IS: ',G15.7)
   50 FORMAT('      VALUE OF THIRD SHAPE PARAMETER IS: ',G15.7)
   51 FORMAT('      VALUE OF FIRST SHAPE PARAMETER 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
      DCHI=DBLE(CHI)
      DLMBDA=DBLE(LAMBDA)
      DTHETA=DBLE(THETA)
      DO100I=1,N
        DXTEMP=DBLE(X(I))
        CALL GIGPPF(DXTEMP,DCHI,DLMBDA,DTHETA,DPPF)
        X(I)=REAL(DPPF)
  100 CONTINUE
C
 9000 CONTINUE
      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 DPPF
      DOUBLE PRECISION DZERO
      DOUBLE PRECISION DONE
      DOUBLE PRECISION DLOWER
      DOUBLE PRECISION DUPPER
      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
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DATA DZERO /0.0D0/
      DATA DONE  /1.0D0/
      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--ALOG.
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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2001.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---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     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 DTERM1
      DOUBLE PRECISION DTERM2
      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
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C---------------------------------------------------------------------
C
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--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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2001.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
      DOUBLE PRECISION DEPS
      DOUBLE PRECISION DL3
      DOUBLE PRECISION DL4
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
C
      CHARACTER*4 IGLDDF
      CHARACTER*4 IWRITE
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
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---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     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 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
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C---------------------------------------------------------------------
C
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
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C---------------------------------------------------------------------
C
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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--95/12
C     ORIGINAL VERSION--DECEMBER  1995.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DP, DA, DPPF
      DOUBLE PRECISION DTERM1
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004/3
C     ORIGINAL VERSION--MARCH     2004.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     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
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C---------------------------------------------------------------------
C
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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--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
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      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
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C---------------------------------------------------------------------
C
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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     ORIGINAL VERSION--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
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,ALPHAMBPC,ALPHAMCPW,ALPHAMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
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('      GL2PPF ROUTINE IS NON-POSITIVE.')
  104 FORMAT('      THE VALUE OF THE ARGUMENT IS ',G15.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 GL2PPF 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('      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=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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--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---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION 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 RESULT
      DOUBLE PRECISION ABSERR
      DOUBLE PRECISION WORK(LENW)
C
      DOUBLE PRECISION GL3FUN
      EXTERNAL GL3FUN
C
      DOUBLE PRECISION DALPH2
      COMMON/GL3COM/DALPH2
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,ALPHAMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--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---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----DATA STATEMENTS-------------------------------------------------
C
C-----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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--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
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--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---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     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
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C---------------------------------------------------------------------
C
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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     ORIGINAL VERSION--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
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,ALPHAMBPC,ALPHAMCPW,ALPHAMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION 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 RESULT
      DOUBLE PRECISION ABSERR
      DOUBLE PRECISION WORK(LENW)
C
      DOUBLE PRECISION GL4FUN
      EXTERNAL GL4FUN
C
      DOUBLE PRECISION DP2,DQ2
      COMMON/GL4COM/DP2,DQ2
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,ALPHAMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--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---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----DATA STATEMENTS-------------------------------------------------
C
C-----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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--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
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      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
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(DP.LE.0.0D0)THEN
        WRITE(ICOUT,4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)DP
        CALL DPWRST('XXX','BUG ')
        DPDF=0.0D0
        GOTO9999
      ENDIF
      IF(DQ.LE.0.0D0)THEN
        WRITE(ICOUT,4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)DQ
        CALL DPWRST('XXX','BUG ')
        DPDF=0.0D0
        GOTO9999
      ENDIF
    4 FORMAT('***** ERROR--THE FIRST SHAPE PARAMETER FOR THE GL4PDF ',
     1       'SUBROUTINE IS NON-POSITIVE.')
    5 FORMAT('***** ERROR--THE SECOND SHAPE PARAMETER FOR THE GL4PDF ',
     1       'SUBROUTINE IS NON-POSITIVE.')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     ORIGINAL VERSION--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
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,ALPHAMBPC,ALPHAMCPW,ALPHAMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--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---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     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 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
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C---------------------------------------------------------------------
C
C     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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--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---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     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 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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004.9
C     ORIGINAL VERSION--SEPTEMBER 2004.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
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 RESULT
      DOUBLE PRECISION DCDF
      DOUBLE PRECISION CDF
      DOUBLE PRECISION X
      DOUBLE PRECISION DX
      DOUBLE PRECISION DB
      DOUBLE PRECISION DC
      DOUBLE PRECISION DM
      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---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,AKMBPC,AKMCPW,AKMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----DATA STATEMENTS-------------------------------------------------
C
C-----START POINT-----------------------------------------------------
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      IF(ALPHA.LE.0.0D0)THEN
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,48)ALPHA
        CALL DPWRST('XXX','WRIT')
        CDF=0.0D0
        GOTO9000
      ENDIF
    5 FORMAT('***** ERROR: VALUE OF SHAPE PARAMETER (ALPHA)',
     1       ' IN GMCCDF 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')
        CDF=0.0D0
        GOTO9000
      ENDIF
    8 FORMAT('***** ERROR: ABSOLUTE VALUE OF SECOND SHAPE PARAMETER ',
     1       '(A) IN GMCCDF ROUTINE IS >= 1.')
   48 FORMAT('      VALUE OF ARGUMENT IS: ',G15.7)
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
      IF(DX.LT.0.0D0)THEN
        IFLAG=1
        INF=1
      ENDIF
C
      DX=X
      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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004.9
C     ORIGINAL VERSION--SEPTEMBER 2004.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DTERM
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DALPHA
      DOUBLE PRECISION DA
      COMMON/GMCCOM/DALPHA,DA
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----DATA STATEMENTS-------------------------------------------------
C
C-----START POINT-----------------------------------------------------
C
C               ************************************
C               **  STEP 1--                      **
C               **  COMPUTE THE DENSITY FUNCTION  **
C               ************************************
C
      CALL GMCPDF(DX,DALPHA,DA,DTERM)
      GMCFUN=DTERM
C
 9000 CONTINUE
      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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004.9
C     ORIGINAL VERSION--SEPTEMBER 2004.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
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---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----DATA STATEMENTS-------------------------------------------------
C
C-----START POINT-----------------------------------------------------
C
C               ************************************
C               **  STEP 1--                      **
C               **  COMPUTE THE DENSITY FUNCTION  **
C               ************************************
C
      CALL GMCCDF(DX,DALPHA,DA,DCDF)
      GMCFU2=DP - DCDF
C
 9000 CONTINUE
      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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004.9
C     ORIGINAL VERSION--SEPTEMBER 2004.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
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---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----DATA STATEMENTS-------------------------------------------------
C
      DATA 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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004.9
C     ORIGINAL VERSION--SEPTEMBER 2004.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION P
      DOUBLE PRECISION PTEMPL
      DOUBLE PRECISION PTEMPU
      DOUBLE PRECISION ALPHA
      DOUBLE PRECISION A
      DOUBLE PRECISION PPF
      DOUBLE PRECISION DINC
      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 GMCFU2
      EXTERNAL GMCFU2
C
      DOUBLE PRECISION DP
      COMMON/GM2COM/DP
C
      DOUBLE PRECISION DALPHA
      DOUBLE PRECISION DA
      COMMON/GMCCOM/DALPHA,DA
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C               *****************************************
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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004.9
C     ORIGINAL VERSION--SEPTEMBER 2004.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DPPF
      DIMENSION X(*)
CCCCC DIMENSION Y(2)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----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 GOMCDF(X,C,B,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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--95/10
C     ORIGINAL VERSION--OCTOBER   1995.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DOUBLE PRECISION DCDF
      DOUBLE PRECISION DC
      DOUBLE PRECISION DB
      DOUBLE PRECISION DX
      DOUBLE PRECISION DTERM1
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      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,301)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,302)X
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
  101 FORMAT('***** FATAL DIAGNOSTIC FROM GOMCDF--THE SECOND INPUT ',
     *'ARGUMENT IS LESS THAN 1.')
  102 FORMAT('***** FATAL DIAGNOSTIC FROM GOMCDF--THE THIRD INPUT ',
     *'ARGUMENT IS NON-POSITIVE.')
  103 FORMAT('      THE VALUE OF THE ARGUMENT IS ',E15.7)
  104 FORMAT('      THE VALUE OF THE THIRD ARGUMENT IS ',E15.7)
  301 FORMAT('***** FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT IS ')
  302 FORMAT('      NEGATIVE.  IT HAS THE VALUE ',E15.7)
C
      IF(X.LE.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=SNGL(DCDF)
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE GOMPDF(X,C,B,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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--95/10
C     ORIGINAL VERSION--OCTOBER   1995.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DOUBLE PRECISION DPDF
      DOUBLE PRECISION DC
      DOUBLE PRECISION DB
      DOUBLE PRECISION DX
      DOUBLE PRECISION DTERM1, DTERM2, DTERM3
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      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,301)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,302)X
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
  101 FORMAT('***** FATAL DIAGNOSTIC FROM GOMPDF--THE SECOND INPUT ',
     *'ARGUMENT IS LESS THAN 1.')
  102 FORMAT('***** FATAL DIAGNOSTIC FROM GOMPDF--THE THIRD INPUT ',
     *'ARGUMENT IS NON-POSITIVE.')
  103 FORMAT('      THE VALUE OF THE ARGUMENT IS ',E15.7)
  104 FORMAT('      THE VALUE OF THE THIRD ARGUMENT IS ',E15.7)
  301 FORMAT('***** FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT IS ')
  302 FORMAT('      NEGATIVE.  IT HAS THE VALUE ',E15.7)
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=SNGL(DPDF)
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE GOMPPF(P,C,B,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--ALOG.
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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--95/10
C     ORIGINAL VERSION--OCTOBER   1995.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DPPF
      DOUBLE PRECISION DC
      DOUBLE PRECISION DB
      DOUBLE PRECISION DP
      DOUBLE PRECISION DTERM1
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     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(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('***** FATAL DIAGNOSTIC FROM GOMPPF--THE SECOND INPUT ',
     *'ARGUMENT IS LESS THAN 1.')
  102 FORMAT('***** FATAL DIAGNOSTIC FROM GOMPPF--THE THIRD INPUT ',
     *'ARGUMENT IS NON-POSITIVE.')
C
    1 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ',
     1'GOMPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
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=SNGL(DPPF)
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE GOMRAN(N,C,B,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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2001.9
C     ORIGINAL VERSION--SEPTEMBER 2001.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     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,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),
     1     CHEVAL,FVAL,GAMBY2,HALF,ONE,ONEHUN,RTPIB2,SIX,
     2     T,TWO,X,XHIGH,XLOW,XVALUE,ZERO
CCCCC CHARACTER FNNAME*6,ERRMSG*15
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
CCCCC DATA FNNAME/'GOODST'/
CCCCC DATA ERRMSG/'ARGUMENT <= 0.0'/
      DATA ZERO,HALF,ONE/ 0.0 D 0 , 0.5 D 0 , 1.0 D 0 /
      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
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
      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
 9000 CONTINUE
      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
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)
CCCCC FOLLOWING LINES ADDED JUNE, 1990
      INCLUDE 'DPCOZ2.INC'
      EQUIVALENCE (G2RBAG(IGRG15),PXPRE(1))
      EQUIVALENCE (G2RBAG(IGRG16),PYPRE(1))
      EQUIVALENCE (G2RBAG(IGRG17),PXPOST(1))
      EQUIVALENCE (G2RBAG(IGRG18),PYPOST(1))
CCCCC END CHANGE
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOBE.INC'
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONCTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--83.6
C     ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MAY       1983.
C
C-----NON-COMMON VARIABLES (GRAPHICS)-------------------------------------------
C
C
      CHARACTER*4 ICTEXT
      CHARACTER*4 IFONT
      CHARACTER*4 IDIR
C
      DIMENSION ICTEXT(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOGR.INC'
      INCLUDE 'DPCOBE.INC'
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'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,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,9014)NCTEXT
 9014 FORMAT('NCTEXT = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9015)(ICTEXT(I),I=1,NCTEXT)
 9015 FORMAT('(ICTEXT(I),I=1,NCTEXT) = ',25A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9021)IFONT,JFONT
 9021 FORMAT('IFONT,JFONT= ',A4,I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9022)IDIR,JDIR
 9022 FORMAT('IDIR,JDIR= ',A4,I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9024)ANGLE,ANGLE2
 9024 FORMAT('ANGLE,ANGLE2= ',E15.7,E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9027)PHEIGH,JHEIG2,PHEIG2
 9027 FORMAT('PHEIGH,JHEIG2,PHEIG2= ',E15.7,I8,E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9028)PWIDTH,JWIDT2,PWIDT2
 9028 FORMAT('PWIDTH,JWIDT2,PWIDT2= ',E15.7,I8,E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9029)PVEGAP,JVEGA2,PVEGA2
 9029 FORMAT('PVEGAP,JVEGA2,PVEGA2= ',E15.7,I8,E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9030)PHOGAP,JHOGA2,PHOGA2
 9030 FORMAT('PHOGAP,JHOGA2,PHOGA2= ',E15.7,I8,E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9031)JSIZE
 9031 FORMAT('JSIZE= ',I8)
      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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--83.6
C     ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MAY       1983.
C     UPDATED--         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'
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      ISUBN0='DRBP'
C
      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
 9000 CONTINUE
      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,
     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)
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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--83.6
C     ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MAY       1983.
C     UPDATED       --SEPTEMBER   1999. SUPPORT FOR MULTIPLOT SCALE
C                                       FACTOR
C
C-----NON-COMMON VARIABLES (GRAPHICS)-------------------------------------------
C
      CHARACTER*4 IFIG
      CHARACTER*4 IPATT
      CHARACTER*4 IPATTZ
      CHARACTER*4 IFONT
      CHARACTER*4 ICASE
      CHARACTER*4 IJUST
      CHARACTER*4 IDIR
      CHARACTER*4 IFILL
      CHARACTER*4 ICOL
C
      CHARACTER*4 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
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      IERRG4='NO'
      IFOUND='-999'
      IERROR='-999'
C
      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DRPG')GOTO90
      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)NP
   52 FORMAT('NP = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)IMANUF
   53 FORMAT('IMANUF = ',A4)
      CALL DPWRST('XXX','BUG ')
      DO55I=1,NP
      WRITE(ICOUT,56)PX(I),PY(I)
   56 FORMAT('PX(I),PY(I) = ',E15.7,E15.7)
      CALL DPWRST('XXX','BUG ')
   55 CONTINUE
      WRITE(ICOUT,58)IFIG
   58 FORMAT('IFIG = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,59)IPATT,JPATT
   59 FORMAT('IPATT,JPATT = ',A4,I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,60)IFONT,JFONT
   60 FORMAT('IFONT,JFONT = ',A4,I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,61)ICASE,JCASE
   61 FORMAT('ICASE,JCASE = ',A4,I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,62)IJUST,JJUST
   62 FORMAT('IJUST,JJUST = ',A4,I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,63)IDIR,ANGLE,JDIR
   63 FORMAT('IDIR,ANGLE,JDIR = ',A4,2X,E15.7,I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,64)ICOL,JCOL
   64 FORMAT('ICOL,JCOL = ',A4,I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,66)PTHICK,JTHICK,PTHIC2
   66 FORMAT('PTHICK,JTHICK,PTHIC2 = ',E15.7,I8,E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,67)PHEIGH,PWIDTH,PVEGAP,PHOGAP
   67 FORMAT('PHEIGH,PWIDTH,PVEGAP,PHOGAP = ',4E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,68)PHEIG2,PWIDT2,PVEGA2,PHOGA2
   68 FORMAT('PHEIG2,PWIDT2,PVEGA2,PHOGA2 = ',4E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,71)ISYMBL,ISPAC
   71 FORMAT('ISYMBL,ISPAC = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,72)IFILL
   72 FORMAT('IFILL = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,78)IFOUND,IBUGD2,IERROR
   78 FORMAT('IFOUND,IBUGD2,IERROR = ',A4,2X,A4,2X,A4)
      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
      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,
     1IFONT,ICASE,IJUST,ANGLE,HMAX,VMAX,AMAX,WIDTH,HEIGHT,
     1PHEIGH,PWIDTH,PVEGAP,PHOGAP,
     1PHEIG2,PWIDT2,PVEGA2,PHOGA2,
     1ANUMHP,ANUMVP,
     1IPATTZ,PTHICK,ICOL,
     1JPATTZ,JTHICK,PTHIC2,JCOL,
     1ISYMBL,ISPAC,
     1IFILL,
     1IMPSW2,AMPSCH,AMPSCW,
     1XEND,YEND,IFOUND,IBUGD2,IERROR)
 1100 CONTINUE
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      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,
     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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--83.6
C     ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MAY       1983.
C     UPDATED         --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*4 IPATT
C
      CHARACTER*4 ISYMBL
      CHARACTER*4 ISPAC
      CHARACTER*4 IMPSW2
C
      CHARACTER*4 ISTRIN
C
      CHARACTER*4 ITRCSW
CCCCC AUGUST 1993.  ADD FOLLOWING LINE
      CHARACTER*1 ICTEMP
C
      DIMENSION PX(*)
      DIMENSION PY(*)
C
      DIMENSION ISTRIN(10)
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
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      IERRG4='NO'
C
      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DRPM')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF GRDRPM--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)NP
   52 FORMAT('NP = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)IMANUF
   53 FORMAT('IMANUF = ',A4)
      CALL DPWRST('XXX','BUG ')
      DO55I=1,NP
      WRITE(ICOUT,56)PX(I),PY(I)
   56 FORMAT('PX(I),PY(I) = ',E15.7,E15.7)
      CALL DPWRST('XXX','BUG ')
   55 CONTINUE
      WRITE(ICOUT,58)IFIG
   58 FORMAT('IFIG = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,59)IPATT,JPATT
   59 FORMAT('IPATT,JPATT = ',A4,I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,60)IFONT,JFONT
   60 FORMAT('IFONT,JFONT = ',A4,I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,61)ICASE,JCASE
   61 FORMAT('ICASE,JCASE = ',A4,I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,62)IJUST,JJUST
   62 FORMAT('IJUST,JJUST = ',A4,I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,63)IDIR,ANGLE,JDIR
   63 FORMAT('IDIR,ANGLE,JDIR = ',A4,2X,E15.7,I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,64)ICOL,JCOL
   64 FORMAT('ICOL,JCOL = ',A4,I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,66)PTHICK,JTHICK,PTHIC2
   66 FORMAT('PTHICK,JTHICK,PTHIC2 = ',E15.7,I8,E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,67)PHEIGH,PWIDTH,PVEGAP,PHOGAP
   67 FORMAT('PHEIGH,PWIDTH,PVEGAP,PHOGAP = ',4E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,68)PHEIG2,PWIDT2,PVEGA2,PHOGA2
   68 FORMAT('PHEIG2,PWIDT2,PVEGA2,PHOGA2 = ',4E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,71)ISYMBL,ISPAC
   71 FORMAT('ISYMBL,ISPAC = ',A4,2X,A4)
      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 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,10
      ISTRIN(I)='    '
 100  CONTINUE
C
CCCCC NOVEMBER 1995.  MODIFY FOLLOWING LINE.
CCCCC CALL GRTRPG(IPATT,ISTRIN,NCSTRI)
      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.EQ.'BLAN')GOTO200
      IF(IPATT.EQ.'BL  ')GOTO200
      IF(IPATT.EQ.'NONE')GOTO200
      IF(IPATT.EQ.'NO  ')GOTO200
C
      IF(IFONT.EQ.'TEKT'.AND.NCSTRI.LE.1)GOTO200
      IF(IFONT.NE.'TEKT')GOTO300
C
C  CHECK FOR SPECIAL PLOT CHARACTERS
C
      IF(IPATT.EQ.'TRIA')GOTO300
      IF(IPATT.EQ.'TR  ')GOTO300
      IF(IPATT.EQ.'SQUA')GOTO300
      IF(IPATT.EQ.'SQ  ')GOTO300
      IF(IPATT.EQ.'DIAM')GOTO300
      IF(IPATT.EQ.'DI  ')GOTO300
CCCCC IF(IPATT.EQ.'HEXA')GOTO300
      IF(IPATT.EQ.'CIRC')GOTO300
      IF(IPATT.EQ.'CI  ')GOTO300
      IF(IPATT.EQ.'CUBE')GOTO300
      IF(IPATT.EQ.'PYRA')GOTO300
C  AUGUST 1992. UNCOMMENTED FOLLOWING 2 LINES
      IF(IPATT.EQ.'REVT')GOTO300
      IF(IPATT.EQ.'RT  ')GOTO300
      IF(IPATT.EQ.'TRIR')GOTO300
C  AUGUST 1992.  FOLLOWING LINE ADDED.
      IF(IPATT.EQ.'TRII')GOTO300
CCCCC DECEMBER 1995. BLANK SHOULD GO TO GRDRPH, NOT GRDRPG
CCCCC MARCH 1997. MOVE FOLLOWING CODE (SAME BUG FOR SOFTWARE FONT)
CCCCC IF(IPATT.EQ.'BLAN')GOTO300
CCCCC IF(IPATT.EQ.'BL  ')GOTO300
CCCCC IF(IPATT.EQ.'NONE')GOTO300
CCCCC IF(IPATT.EQ.'NO  ')GOTO300
CCCCC IF(IPATT.EQ.'BLAN')GOTO200
CCCCC IF(IPATT.EQ.'BL  ')GOTO200
CCCCC IF(IPATT.EQ.'NONE')GOTO200
CCCCC IF(IPATT.EQ.'NO  ')GOTO200
      IF(IPATT.EQ.'BOX ')GOTO300
      IF(IPATT.EQ.'STAR')GOTO300
      IF(IPATT.EQ.'ST  ')GOTO300
      IF(IPATT.EQ.'AU  ')GOTO300
      IF(IPATT.EQ.'AD  ')GOTO300
CCCCC IF(IPATT.EQ.'VB  ')GOTO300
      IF(IPATT.EQ.'POIN')GOTO300
      IF(IPATT.EQ.'PT  ')GOTO300
      IF(IPATT.EQ.'PO  ')GOTO300
C  AUGUST 1992.  ADD ARROW CASE.
C  THIS CASE HANDLED SEPARATELY.
      IF(IPATT.EQ.'ARRO')GOTO500
      IF(IPATT.EQ.'ARRH')GOTO500
      IF(IPATT.EQ.'VECT')GOTO500
C
      IF(IPATT.EQ.'DEGR')GOTO300
C
C  CHECK FOR GREEK CHARACTERS
C
      IF(IPATT.EQ.'ALPH')GOTO300
      IF(IPATT.EQ.'BETA')GOTO300
      IF(IPATT.EQ.'GAMM')GOTO300
      IF(IPATT.EQ.'DELT')GOTO300
      IF(IPATT.EQ.'EPSI')GOTO300
      IF(IPATT.EQ.'ZETA')GOTO300
      IF(IPATT.EQ.'ETA ')GOTO300
      IF(IPATT.EQ.'THET')GOTO300
      IF(IPATT.EQ.'IOTA')GOTO300
      IF(IPATT.EQ.'KAPP')GOTO300
      IF(IPATT.EQ.'LAMB')GOTO300
      IF(IPATT.EQ.'MU  ')GOTO300
      IF(IPATT.EQ.'NU  ')GOTO300
      IF(IPATT.EQ.'XI  ')GOTO300
      IF(IPATT.EQ.'OMIC')GOTO300
      IF(IPATT.EQ.'PI  ')GOTO300
      IF(IPATT.EQ.'RHO ')GOTO300
      IF(IPATT.EQ.'SIGM')GOTO300
      IF(IPATT.EQ.'TAU ')GOTO300
      IF(IPATT.EQ.'UPSI')GOTO300
      IF(IPATT.EQ.'PHI ')GOTO300
      IF(IPATT.EQ.'CHI ')GOTO300
      IF(IPATT.EQ.'PSI ')GOTO300
      IF(IPATT.EQ.'OMEG')GOTO300
C
C  CHECK FOR MATH SYMBOLS
C
      IF(IPATT.EQ.'PART')GOTO300
      IF(IPATT.EQ.'INTE')GOTO300
      IF(IPATT.EQ.'CINT')GOTO300
      IF(IPATT.EQ.'SUMM')GOTO300
      IF(IPATT.EQ.'PROD')GOTO300
      IF(IPATT.EQ.'INFI')GOTO300
      IF(IPATT.EQ.'+-  ')GOTO300
      IF(IPATT.EQ.'-+  ')GOTO300
      IF(IPATT.EQ.'TIME')GOTO300
      IF(IPATT.EQ.'DOTP')GOTO300
      IF(IPATT.EQ.'DEL ')GOTO300
      IF(IPATT.EQ.'DIVI')GOTO300
      IF(IPATT.EQ.'LT  ')GOTO300
      IF(IPATT.EQ.'GT  ')GOTO300
      IF(IPATT.EQ.'LTEQ')GOTO300
      IF(IPATT.EQ.'GTEQ')GOTO300
      IF(IPATT.EQ.'NOT=')GOTO300
      IF(IPATT.EQ.'APPR')GOTO300
      IF(IPATT.EQ.'EQUI')GOTO300
      IF(IPATT.EQ.'VARI')GOTO300
      IF(IPATT.EQ.'TILD')GOTO300
      IF(IPATT.EQ.'CARA')GOTO300
      IF(IPATT.EQ.'PRIM')GOTO300
      IF(IPATT.EQ.'RADI')GOTO300
      IF(IPATT.EQ.'LRAD')GOTO300
      IF(IPATT.EQ.'BRAD')GOTO300
      IF(IPATT.EQ.'SUBS')GOTO300
      IF(IPATT.EQ.'SUPE')GOTO300
      IF(IPATT.EQ.'UNSB')GOTO300
      IF(IPATT.EQ.'UNSP')GOTO300
      IF(IPATT.EQ.'UNIO')GOTO300
      IF(IPATT.EQ.'INTR')GOTO300
      IF(IPATT.EQ.'ELEM')GOTO300
      IF(IPATT.EQ.'THEX')GOTO300
      IF(IPATT.EQ.'THFO')GOTO300
C
C  CHECK FOR MISCELLANEOUS SYMBOLS
C
      IF(IPATT.EQ.'LAPO')GOTO300
      IF(IPATT.EQ.'RAPO')GOTO300
      IF(IPATT.EQ.'LBRA')GOTO300
      IF(IPATT.EQ.'RBRA')GOTO300
      IF(IPATT.EQ.'LCBR')GOTO300
      IF(IPATT.EQ.'RCBR')GOTO300
      IF(IPATT.EQ.'LELB')GOTO300
      IF(IPATT.EQ.'RELB')GOTO300
      IF(IPATT.EQ.'RACC')GOTO300
      IF(IPATT.EQ.'LACC')GOTO300
      IF(IPATT.EQ.'BREV')GOTO300
      IF(IPATT.EQ.'LQUO')GOTO300
      IF(IPATT.EQ.'NASP')GOTO300
      IF(IPATT.EQ.'IASP')GOTO300
      IF(IPATT.EQ.'RARR')GOTO300
      IF(IPATT.EQ.'LARR')GOTO300
      IF(IPATT.EQ.'UARR')GOTO300
      IF(IPATT.EQ.'DARR')GOTO300
      IF(IPATT.EQ.'PARA')GOTO300
      IF(IPATT.EQ.'DAGG')GOTO300
      IF(IPATT.EQ.'DDAG')GOTO300
      IF(IPATT.EQ.'VBAR')GOTO300
      IF(IPATT.EQ.'DVBA')GOTO300
      IF(IPATT.EQ.'LVBA')GOTO300
      IF(IPATT.EQ.'LHBA')GOTO300
      IF(IPATT.EQ.'BAR ')GOTO300
      IF(IPATT.EQ.'DEL ')GOTO300
CCCCC SEPTEMBER 1995.  PIXEL IS SPECIAL CASE (TURN A SINGLE POINT ON).
CCCCC IMPLEMENTED IN THE GRDRPH ROUTINE.
      IF(IPATT.EQ.'PIXE')GOTO200
      IF(IPATT.EQ.'DEL ')GOTO300
C
      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.EQ.'BLAN')GOTO299
        IF(IPATT.EQ.'BL  ')GOTO299
        IF(IPATT.EQ.'NONE')GOTO299
        IF(IPATT.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,
     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.EQ.'ARRO')GOTO500
      IF(IPATT.EQ.'ARRH')GOTO500
      IF(IPATT.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,4
          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,4
          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,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,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 = ',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,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,
     1IHORPA,IVERPA,IDUPPA,IDDOPA,
     1JCOL)
C
C     PURPOSE--FOR A GENERAL GRAPHICS DEVICE,
C              DRAW A SOLID VERTICAL PATTERN
C              WITHIN A GENERAL POLYLINE
C              WITH THE ONLY CONSTRAINT THAT A GIVEN X VALUE
C              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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--83.6
C     ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MAY       1983.
C     UPDATED         --JUNE      1990. TEMPORARY ARRAYS TO GARBAGE COMMON
C     UPDATED         --JULY      2001. ADD COLOR INDEX (FOR GD DEVICE)
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)
CCCCC FOLLOWING LINES ADDED JUNE, 1990
      INCLUDE 'DPCOZ2.INC'
      EQUIVALENCE (G2RBAG(IGRG13),PXS(1))
      EQUIVALENCE (G2RBAG(IGRG14),PYS(1))
CCCCC END CHANGE
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOGR.INC'
      INCLUDE 'DPCOBE.INC'
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      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 SORTC2(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
      IF(IBUGG4.EQ.'ON')WRITE(ICOUT,1611)X,PX5,PY5,PX6,PY6
 1611 FORMAT('X,PX5,PY5,PX6,PY6 = ',5E15.7)
      IF(IBUGG4.EQ.'ON')CALL DPWRST('XXX','BUG ')
      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)
 1610 CONTINUE
      GOTO1600
 1690 CONTINUE
C
 1100 CONTINUE
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      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,
     1IHORPA,IVERPA,IDUPPA,IDDOPA,
     1IPATT2,PTHICK,ICOL)
C
C     PURPOSE--FOR A GENERAL GRAPHICS DEVICE,
C              FILL A POLYGON (CONVEX OR CONCAVE) WITH A HATCH 
C              PATTERN.  THE ROUTINE GRHTCH ACTUALLY DOES THE 
C              FILL.  THIS ROUTINE IS THE DRIVER FOR THE 4 CASES OF
C              VERTICAL, HORIZONTAL, UP DIAGONAL, DOWN DIAGONAL.
C              SOLID FILLS ARE HANDLED VIA THE VERTICAL WITH A 
C              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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--93.10
C     ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--OCTOBER   1993.
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'
      DIMENSION PXS(MAXPOP)
      DIMENSION PYS(MAXPOP)
      INCLUDE 'DPCOZ2.INC'
      EQUIVALENCE (G2RBAG(IGRG13),PXS(1))
      EQUIVALENCE (G2RBAG(IGRG14),PYS(1))
C
C
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOGR.INC'
      INCLUDE 'DPCOBE.INC'
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      ISUBN0='FIR3'
C
      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
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      IF(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 SORTC2(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 GRID(NI,NJ,FC,GC,BFI,BFJ,POI,POJ,XX,YY,EPS3,CDFX,
     *   IFLAG)
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
      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 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
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DATA 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 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'
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'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,
     1TAG,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--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--98.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---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='GRPM'
      ISUBN2='EA  '
C
      IERROR='NO'
C
      IF(IBUGA3.EQ.'OFF')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF GRPMEA--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)IBUGA3
   52 FORMAT('IBUGA3 = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)NR1,NC1
   53 FORMAT('NR1, NC1 = ',3I8)
      CALL DPWRST('XXX','BUG ')
   90 CONTINUE
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
 9000 CONTINUE
      IF(IBUGA3.EQ.'OFF')GOTO9090
      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
 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)NR1,NC1
 9013 FORMAT('NR1,NC1 = ',2I8)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE 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--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--98.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---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='GRPM'
      ISUBN2='EA  '
C
      IERROR='NO'
C
      IF(IBUGA3.EQ.'OFF')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF GRPSD--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)IBUGA3
   52 FORMAT('IBUGA3 = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)NR1,N2,NC1
   53 FORMAT('NR1, N2, NC1 = ',3I8)
      CALL DPWRST('XXX','BUG ')
   90 CONTINUE
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
 9000 CONTINUE
      IF(IBUGA3.EQ.'OFF')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF GRPSD--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IBUGA3,IERROR
 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)NR1,NC1
 9013 FORMAT('NR1,NC1 = ',2I8)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE GRPSTA(Y,XH1,XH2,N,NUMV2,ICASCT,ICASC2,ICASS7,
     1MAXNXT,
     1XH1DIS,XH2DIS,TEMP,TEMP2,TEMP3,TEMP4,TEMP5,
     1Y2,
     1ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
     1ISUBRO,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, OR 2 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 BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2899
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2001/3
C     ORIGINAL VERSION--MARCH     2001.
C     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
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      EXTERNAL SUM
      EXTERNAL RANGE
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
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 ISTEPN
C
C---------------------------------------------------------------------
C
      DIMENSION Y(*)
      DIMENSION XH1(*)
      DIMENSION XH2(*)
      DIMENSION Y2(*)
C
      DIMENSION XH1DIS(*)
      DIMENSION XH2DIS(*)
      DIMENSION TEMP(*)
      DIMENSION TEMP2(*)
      DIMENSION TEMP3(*)
      DIMENSION TEMP4(*)
      DIMENSION TEMP5(*)
      INTEGER ITEMP1(*)
      INTEGER ITEMP2(*)
      INTEGER ITEMP3(*)
      INTEGER ITEMP4(*)
      INTEGER ITEMP5(*)
      INTEGER ITEMP6(*)
C
      INCLUDE 'DPCOPA.INC'
      INCLUDE 'DPCOST.INC'
      INCLUDE 'DPCOHK.INC'
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='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
      I2=0
      AN=0.0
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.GT.1)GOTO39
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,31)
   31 FORMAT('***** ERROR IN GRPSTA--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,32)
   32 FORMAT('      THE NUMBER OF OBSERVATIONS')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,33)
   33 FORMAT('      MUST BE AT LEAST 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
   39 CONTINUE
C
      IF(IBUGA3.EQ.'OFF')GOTO90
      WRITE(ICOUT,70)
   70 FORMAT('AT THE BEGINNING OF GRPSTA--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,71)N,ICASCT,NUMV2
   71 FORMAT('N,ICASCT,NUMV2 = ',I8,2X,A4,I8)
      CALL DPWRST('XXX','BUG ')
      DO72I=1,N
      WRITE(ICOUT,73)I,Y(I),XH1(I),XH2(I)
   73 FORMAT('I, Y(I), XH1(I),XH2(I) = ',I8,3F15.7)
      CALL DPWRST('XXX','BUG ')
   72 CONTINUE
   90 CONTINUE
C
C               ********************************************************
C               **  STEP 1--                                          **
C               **  1-VARIABLE CASE, I.E. NO GROUP ID VARIABLES.      **
C               ********************************************************
C
      ISTEPN='1'
      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
      IWRITE='OFF'
      IF(NUMV2.EQ.1)THEN
        IF(ICASCT.EQ.'CRTA')THEN
          NUMV=1
          CALL CMPSTA(
     1    Y,TEMP,TEMP2,TEMP3,TEMP4,MAXNXT,N,N,NUMV,ICASS7,
     1    ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
     1    IQUAME,IQUASE,
     1    STAT1,
     1    ISUBRO,IBUGA3,IERROR)
          IF(IERROR.EQ.'YES')GOTO9000
        ELSE
          IF(ICASCT.EQ.'SCAL')THEN
            STAT1=0.0
          ELSE
            NUMV=1
            CALL CMPSTA(
     1      Y,TEMP,TEMP2,TEMP3,TEMP4,MAXOBV,N,N,NUMV,ILOC,
     1      ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
     1      IQUAME,IQUASE,
     1      STAT1,
     1      ISUBRO,IBUGA3,IERROR)
            IF(IERROR.EQ.'YES')GOTO9000
          ENDIF
C
          IF(ICASCT.EQ.'LOCA')THEN
            STAT2=1.0
          ELSE
            NUMV=1
            CALL CMPSTA(
     1      Y,TEMP,TEMP2,TEMP3,TEMP4,MAXOBV,N,N,NUMV,ISCALE,
     1      ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
     1      IQUAME,IQUASE,
     1      STAT2,
     1      ISUBRO,IBUGA3,IERROR)
            IF(IERROR.EQ.'YES')GOTO9000
          ENDIF
        ENDIF
C
        IF(ICASCT.EQ.'CRTA')THEN
          DO112I=1,N
            Y2(I)=STAT1
  112     CONTINUE
          GOTO9000
        ELSE
          DO110I=1,N
            Y2(I)=(Y(I)-STAT1)/STAT2
  110     CONTINUE
          GOTO9000
        ENDIF
      ENDIF
C
C               ********************************************************
C               **  STEP 2--                                          **
C               **  DETERMINE THE NUMBER OF DISTINCT VALUES           **
C               **  FOR VARIABLE 2 (ONE OF THE GROUP VARIABLES).      **
C               ********************************************************
C
      ISTEPN='2'
      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(NUMV2.EQ.2)THEN
C
        NUMSE1=0
        DO260I=1,N
          IF(NUMSE1.EQ.0)GOTO265
          DO270J=1,NUMSE1
            IF(XH1(I).EQ.XH1DIS(J))GOTO260
  270     CONTINUE
  265   CONTINUE
        NUMSE1=NUMSE1+1
        XH1DIS(NUMSE1)=XH1(I)
  260   CONTINUE
        CALL SORT(XH1DIS,NUMSE1,XH1DIS)
C
  290   CONTINUE
C
        AN=N
        ANUMS1=NUMSE1
C
        DO310I=1,NUMSE1
          NTEMP=0
          DO320J=1,N
            IF(XH1(J).EQ.XH1DIS(I))THEN
              NTEMP=NTEMP+1
              TEMP2(NTEMP)=Y(J)
            ENDIF
  320     CONTINUE
          IWRITE='OFF'
          IF(NTEMP.GT.0)THEN
            IF(ICASCT.EQ.'CRTA')THEN
              NUMV=1
              CALL CMPSTA(
     1        TEMP2,TEMP,TEMP3,TEMP4,TEMP5,
     1        MAXNXT,NTEMP,NTEMP,NUMV,ICASS7,
     1        ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
     1        IQUAME,IQUASE,
     1        STAT1,
     1        ISUBRO,IBUGA3,IERROR)
              IF(IERROR.EQ.'YES')GOTO9000
            ELSE
              IF(ICASCT.EQ.'SCAL')THEN
                STAT1=0.0
              ELSE
                NUMV=1
                CALL CMPSTA(
     1          TEMP2,TEMP,TEMP3,TEMP4,TEMP5,
     1          MAXNXT,NTEMP,NTEMP,NUMV,ILOC,
     1          ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
     1          IQUAME,IQUASE,
     1          STAT1,
     1          ISUBRO,IBUGA3,IERROR)
                IF(IERROR.EQ.'YES')GOTO9000
              ENDIF
C
              IF(ICASCT.EQ.'LOCA')THEN
                STAT2=1.0
              ELSE
                NUMV=1
                CALL CMPSTA(
     1          TEMP2,TEMP,TEMP3,TEMP4,TEMP5,
     1          MAXNXT,NTEMP,NTEMP,NUMV,ISCALE,
     1          ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
     1          IQUAME,IQUASE,
     1          STAT2,
     1          ISUBRO,IBUGA3,IERROR)
                IF(IERROR.EQ.'YES')GOTO9000
              ENDIF
            ENDIF
          ENDIF
C
          IF(ICASCT.EQ.'CRTA')THEN
            DO420J=1,N
              IF(XH1(J).EQ.XH1DIS(I))THEN
                Y2(J)=STAT1
              ENDIF
  420       CONTINUE
          ELSE
            DO410J=1,N
              IF(XH1(J).EQ.XH1DIS(I))THEN
                Y2(J)=(Y(J)-STAT1)/STAT2
              ENDIF
  410       CONTINUE
          ENDIF
  310   CONTINUE
        GOTO9000
      ENDIF
C
C               ********************************************************
C               **  STEP 3--                                          **
C               **  DETERMINE THE NUMBER OF DISTINCT VALUES           **
C               **  FOR VARIABLE 2 (ONE OF THE GROUP VARIABLES).      **
C               **  IF ALL VALUES ARE DISTINCT, THEN THIS             **
C               **  IMPLIES WE HAVE THE NO REPLICATION CASE           **
C               **  WHICH IS AN ERROR CONDITION FOR A CROSS-TABULATION**
C               ********************************************************
C
      ISTEPN='3'
      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(NUMV2.EQ.3)THEN
C
        NUMSE1=0
        DO560I=1,N
          IF(NUMSE1.EQ.0)GOTO565
          DO570J=1,NUMSE1
            IF(XH1(I).EQ.XH1DIS(J))GOTO560
  570     CONTINUE
  565   CONTINUE
        NUMSE1=NUMSE1+1
        XH1DIS(NUMSE1)=XH1(I)
  560   CONTINUE
        CALL SORT(XH1DIS,NUMSE1,XH1DIS)
C
  590   CONTINUE
C
        AN=N
        ANUMS1=NUMSE1
C
        ISTEPN='3B'
        IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
        NUMSE2=0
        DO760I=1,N
          IF(NUMSE2.EQ.0)GOTO765
          DO770J=1,NUMSE2
            IF(XH2(I).EQ.XH2DIS(J))GOTO760
  770     CONTINUE
  765     CONTINUE
          NUMSE2=NUMSE2+1
          XH2DIS(NUMSE2)=XH2(I)
  760   CONTINUE
        CALL SORT(XH2DIS,NUMSE2,XH2DIS)
C
  790   CONTINUE
C
        AN=N
        ANUMS2=NUMSE2
        ISTEPN='3.C'
        IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
        IWRITE='OFF'
        J=0
C
        DO1110ISET1=1,NUMSE1
          DO1120ISET2=1,NUMSE2
C
            NTEMP=0
            DO1130I=1,N
              IF(XH1(I).EQ.XH1DIS(ISET1).AND.
     1           XH2(I).EQ.XH2DIS(ISET2))THEN
                NTEMP=NTEMP+1
                TEMP2(NTEMP)=Y(I)
              ENDIF
 1130       CONTINUE
            IWRITE='OFF'
            IF(NTEMP.GT.0)THEN
              IF(ICASCT.EQ.'CRTA')THEN
                NUMV=1
                CALL CMPSTA(
     1          TEMP2,TEMP,TEMP3,TEMP4,TEMP5,
     1          MAXNXT,NTEMP,NTEMP,NUMV,ICASS7,
     1          ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
     1          IQUAME,IQUASE,
     1          STAT1,
     1          ISUBRO,IBUGA3,IERROR)
                IF(IERROR.EQ.'YES')GOTO9000
              ELSE
                IF(ICASCT.EQ.'SCAL')THEN
                  STAT1=0.0
                ELSE
                  NUMV=1
                  CALL CMPSTA(
     1            TEMP2,TEMP,TEMP3,TEMP4,TEMP5,
     1            MAXNXT,NTEMP,NTEMP,NUMV,ILOC,
     1            ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
     1            IQUAME,IQUASE,
     1            STAT1,
     1            ISUBRO,IBUGA3,IERROR)
                  IF(IERROR.EQ.'YES')GOTO9000
                ENDIF
C
                IF(ICASCT.EQ.'LOCA')THEN
                  STAT2=1.0
                ELSE
                  NUMV=1
                  CALL CMPSTA(
     1            TEMP2,TEMP,TEMP3,TEMP4,TEMP5,
     1            MAXNXT,NTEMP,NTEMP,
     1            NUMV,ISCALE,
     1            ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
     1            IQUAME,IQUASE,
     1            STAT2,
     1            ISUBRO,IBUGA3,IERROR)
                  IF(IERROR.EQ.'YES')GOTO9000
                ENDIF
              ENDIF
C
              IF(ICASCT.EQ.'CRTA')THEN
                DO1160J=1,N
                  IF(XH1(J).EQ.XH1DIS(ISET1).AND.
     1               XH2(J).EQ.XH2DIS(ISET2))THEN
                     Y2(J)=STAT1
                  ENDIF
 1160           CONTINUE
              ELSE
                DO1150J=1,N
                  IF(XH1(J).EQ.XH1DIS(ISET1).AND.
     1               XH2(J).EQ.XH2DIS(ISET2))THEN
                     Y2(J)=(Y(J)-STAT1)/STAT2
                  ENDIF
 1150           CONTINUE
              ENDIF
            ENDIF
 1120     CONTINUE
 1110   CONTINUE
        GOTO9000
      ENDIF
C
C               ******************
C               **   STEP 90--  **
C               **   EXIT       **
C               ******************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'OFF')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF GRPSTA--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)NUMV2
 9013 FORMAT('NUMV2 = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9015)NUMSE1,NUMSE2
 9015 FORMAT('NUMSE1,NUMSE2 = ',2I8)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE GRPST2(Y,YTEMP,XH1,XH2,N,NUMV2,
     1ICASCT,ICASC2,ICASS7,
     1MAXNXT,
     1XH1DIS,XH2DIS,TEMP,TEMP2,TEMP3,TEMP4,TEMP5,
     1Y2,
     1ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
     1ISUBRO,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, OR 2 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 BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2899
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     NOTE--THIS IS A MODIFIED VERSION OF GRPSTA.  GRPSTA IS
C           USED FOR STATISTICS WITH ONE RESPONSE VARIABLE,
C           GRPST2 IS USED FOR THE CASE WITH TWO RESPONSE VARIABLES.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2003/3
C     ORIGINAL VERSION--MARCH     2003.
C     UPDATED         --APRIL     2003. ARGUMENT LIST TO CMPSTA
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      EXTERNAL SUM
      EXTERNAL RANGE
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
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 ISTEPN
C
C---------------------------------------------------------------------
C
      DIMENSION Y(*)
      DIMENSION YTEMP(*)
      DIMENSION XH1(*)
      DIMENSION XH2(*)
      DIMENSION Y2(*)
C
      DIMENSION XH1DIS(*)
      DIMENSION XH2DIS(*)
      DIMENSION TEMP(*)
      DIMENSION TEMP2(*)
      DIMENSION TEMP3(*)
      DIMENSION TEMP4(*)
      DIMENSION TEMP5(*)
      INTEGER ITEMP1(*)
      INTEGER ITEMP2(*)
      INTEGER ITEMP3(*)
      INTEGER ITEMP4(*)
      INTEGER ITEMP5(*)
      INTEGER ITEMP6(*)
C
      INCLUDE 'DPCOPA.INC'
      INCLUDE 'DPCOST.INC'
      INCLUDE 'DPCOHK.INC'
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='GRPS'
      ISUBN2='T2  '
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
      I2=0
      AN=0.0
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.GT.1)GOTO39
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,31)
   31 FORMAT('***** ERROR IN GRPSTA--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,32)
   32 FORMAT('      THE NUMBER OF OBSERVATIONS')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,33)
   33 FORMAT('      MUST BE AT LEAST 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
   39 CONTINUE
C
      IF(IBUGA3.EQ.'OFF')GOTO90
      WRITE(ICOUT,70)
   70 FORMAT('AT THE BEGINNING OF GRPSTA--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,71)N,ICASCT,NUMV2
   71 FORMAT('N,ICASCT,NUMV2 = ',I8,2X,A4,I8)
      CALL DPWRST('XXX','BUG ')
      DO72I=1,N
      WRITE(ICOUT,73)I,Y(I),XH1(I),XH2(I)
   73 FORMAT('I, Y(I), XH1(I),XH2(I) = ',I8,3F15.7)
      CALL DPWRST('XXX','BUG ')
   72 CONTINUE
   90 CONTINUE
C
C               ********************************************************
C               **  STEP 1--                                          **
C               **  1-VARIABLE CASE, I.E. NO GROUP ID VARIABLES.      **
C               ********************************************************
C
      ISTEPN='1'
      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
      IWRITE='OFF'
      IF(NUMV2.EQ.1)THEN
        IF(ICASCT.EQ.'CRTA')THEN
          NUMV=1
          CALL CMPSTA(
     1    Y,YTEMP,TEMP2,TEMP3,TEMP5,MAXNXT,N,N,NUMV,ICASS7,
     1    ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
     1    IQUAME,IQUASE,
     1    STAT1,
     1    ISUBRO,IBUGA3,IERROR)
          IF(IERROR.EQ.'YES')GOTO9000
        ELSE
          IF(ICASCT.EQ.'SCAL')THEN
            STAT1=0.0
          ELSE
            NUMV=1
            CALL CMPSTA(
     1      Y,YTEMP,TEMP2,TEMP3,TEMP5,MAXOBV,N,N,NUMV,ILOC,
     1      ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
     1      IQUAME,IQUASE,
     1      STAT1,
     1      ISUBRO,IBUGA3,IERROR)
            IF(IERROR.EQ.'YES')GOTO9000
          ENDIF
C
          IF(ICASCT.EQ.'LOCA')THEN
            STAT2=1.0
          ELSE
            NUMV=1
            CALL CMPSTA(
     1      Y,YTEMP,TEMP2,TEMP3,TEMP5,MAXOBV,N,N,NUMV,ISCALE,
     1      ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
     1      IQUAME,IQUASE,
     1      STAT2,
     1      ISUBRO,IBUGA3,IERROR)
            IF(IERROR.EQ.'YES')GOTO9000
          ENDIF
        ENDIF
C
        IF(ICASCT.EQ.'CRTA')THEN
          DO112I=1,N
            Y2(I)=STAT1
  112     CONTINUE
          GOTO9000
        ELSE
          DO110I=1,N
            Y2(I)=(Y(I)-STAT1)/STAT2
  110     CONTINUE
          GOTO9000
        ENDIF
      ENDIF
C
C               ********************************************************
C               **  STEP 2--                                          **
C               **  DETERMINE THE NUMBER OF DISTINCT VALUES           **
C               **  FOR VARIABLE 2 (ONE OF THE GROUP VARIABLES).      **
C               ********************************************************
C
      ISTEPN='2'
      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(NUMV2.EQ.2)THEN
C
        NUMSE1=0
        DO260I=1,N
          IF(NUMSE1.EQ.0)GOTO265
          DO270J=1,NUMSE1
            IF(XH1(I).EQ.XH1DIS(J))GOTO260
  270     CONTINUE
  265   CONTINUE
        NUMSE1=NUMSE1+1
        XH1DIS(NUMSE1)=XH1(I)
  260   CONTINUE
        CALL SORT(XH1DIS,NUMSE1,XH1DIS)
C
  290   CONTINUE
C
        AN=N
        ANUMS1=NUMSE1
C
        DO310I=1,NUMSE1
          NTEMP=0
          DO320J=1,N
            IF(XH1(J).EQ.XH1DIS(I))THEN
              NTEMP=NTEMP+1
              TEMP2(NTEMP)=Y(J)
              TEMP(NTEMP)=YTEMP(J)
            ENDIF
  320     CONTINUE
          IWRITE='OFF'
          IF(NTEMP.GT.0)THEN
            IF(ICASCT.EQ.'CRTA')THEN
              NUMV=1
              CALL CMPSTA(
     1        TEMP2,TEMP,TEMP3,TEMP4,TEMP5,
     1        MAXNXT,NTEMP,NTEMP,NUMV,ICASS7,
     1        ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
     1        IQUAME,IQUASE,
     1        STAT1,
     1        ISUBRO,IBUGA3,IERROR)
              IF(IERROR.EQ.'YES')GOTO9000
            ELSE
              IF(ICASCT.EQ.'SCAL')THEN
                STAT1=0.0
              ELSE
                NUMV=1
                CALL CMPSTA(
     1          TEMP2,TEMP,TEMP3,TEMP4,TEMP5,
     1          MAXNXT,NTEMP,NTEMP,NUMV,ILOC,
     1          ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
     1          IQUAME,IQUASE,
     1          STAT1,
     1          ISUBRO,IBUGA3,IERROR)
                IF(IERROR.EQ.'YES')GOTO9000
              ENDIF
C
              IF(ICASCT.EQ.'LOCA')THEN
                STAT2=1.0
              ELSE
                NUMV=1
                CALL CMPSTA(
     1          TEMP2,TEMP,TEMP3,TEMP4,TEMP5,
     1          MAXNXT,NTEMP,NTEMP,NUMV,ISCALE,
     1          ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
     1          IQUAME,IQUASE,
     1          STAT2,
     1          ISUBRO,IBUGA3,IERROR)
                IF(IERROR.EQ.'YES')GOTO9000
              ENDIF
            ENDIF
          ENDIF
C
          IF(ICASCT.EQ.'CRTA')THEN
            DO420J=1,N
              IF(XH1(J).EQ.XH1DIS(I))THEN
                Y2(J)=STAT1
              ENDIF
  420       CONTINUE
          ELSE
            DO410J=1,N
              IF(XH1(J).EQ.XH1DIS(I))THEN
                Y2(J)=(Y(J)-STAT1)/STAT2
              ENDIF
  410       CONTINUE
          ENDIF
  310   CONTINUE
        GOTO9000
      ENDIF
C
C               ********************************************************
C               **  STEP 3--                                          **
C               **  DETERMINE THE NUMBER OF DISTINCT VALUES           **
C               **  FOR VARIABLE 2 (ONE OF THE GROUP VARIABLES).      **
C               **  IF ALL VALUES ARE DISTINCT, THEN THIS             **
C               **  IMPLIES WE HAVE THE NO REPLICATION CASE           **
C               **  WHICH IS AN ERROR CONDITION FOR A CROSS-TABULATION**
C               ********************************************************
C
      ISTEPN='3'
      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(NUMV2.EQ.3)THEN
C
        NUMSE1=0
        DO560I=1,N
          IF(NUMSE1.EQ.0)GOTO565
          DO570J=1,NUMSE1
            IF(XH1(I).EQ.XH1DIS(J))GOTO560
  570     CONTINUE
  565   CONTINUE
        NUMSE1=NUMSE1+1
        XH1DIS(NUMSE1)=XH1(I)
  560   CONTINUE
        CALL SORT(XH1DIS,NUMSE1,XH1DIS)
C
  590   CONTINUE
C
        AN=N
        ANUMS1=NUMSE1
C
        ISTEPN='3B'
        IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
        NUMSE2=0
        DO760I=1,N
          IF(NUMSE2.EQ.0)GOTO765
          DO770J=1,NUMSE2
            IF(XH2(I).EQ.XH2DIS(J))GOTO760
  770     CONTINUE
  765     CONTINUE
          NUMSE2=NUMSE2+1
          XH2DIS(NUMSE2)=XH2(I)
  760   CONTINUE
        CALL SORT(XH2DIS,NUMSE2,XH2DIS)
C
  790   CONTINUE
C
        AN=N
        ANUMS2=NUMSE2
        ISTEPN='3.C'
        IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
        IWRITE='OFF'
        J=0
C
        DO1110ISET1=1,NUMSE1
          DO1120ISET2=1,NUMSE2
C
            NTEMP=0
            DO1130I=1,N
              IF(XH1(I).EQ.XH1DIS(ISET1).AND.
     1           XH2(I).EQ.XH2DIS(ISET2))THEN
                NTEMP=NTEMP+1
                TEMP2(NTEMP)=Y(I)
                TEMP(NTEMP)=YTEMP(I)
              ENDIF
 1130       CONTINUE
            IWRITE='OFF'
            IF(NTEMP.GT.0)THEN
              IF(ICASCT.EQ.'CRTA')THEN
                NUMV=1
                CALL CMPSTA(
     1          TEMP2,TEMP,TEMP3,TEMP4,TEMP5,
     1          MAXNXT,NTEMP,NTEMP,NUMV,ICASS7,
     1          ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
     1          IQUAME,IQUASE,
     1          STAT1,
     1          ISUBRO,IBUGA3,IERROR)
                IF(IERROR.EQ.'YES')GOTO9000
              ELSE
                IF(ICASCT.EQ.'SCAL')THEN
                  STAT1=0.0
                ELSE
                  NUMV=1
                  CALL CMPSTA(
     1            TEMP2,TEMP,TEMP3,TEMP4,TEMP5,
     1            MAXNXT,NTEMP,NTEMP,NUMV,ILOC,
     1            ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
     1            IQUAME,IQUASE,
     1            STAT1,
     1            ISUBRO,IBUGA3,IERROR)
                  IF(IERROR.EQ.'YES')GOTO9000
                ENDIF
C
                IF(ICASCT.EQ.'LOCA')THEN
                  STAT2=1.0
                ELSE
                  NUMV=1
                  CALL CMPSTA(
     1            TEMP2,TEMP,TEMP3,TEMP4,TEMP5,MAXNXT,NTEMP,NTEMP,
     1            NUMV,ISCALE,
     1            ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
     1            IQUAME,IQUASE,
     1            STAT2,
     1            ISUBRO,IBUGA3,IERROR)
                  IF(IERROR.EQ.'YES')GOTO9000
                ENDIF
              ENDIF
C
              IF(ICASCT.EQ.'CRTA')THEN
                DO1160J=1,N
                  IF(XH1(J).EQ.XH1DIS(ISET1).AND.
     1               XH2(J).EQ.XH2DIS(ISET2))THEN
                     Y2(J)=STAT1
                  ENDIF
 1160           CONTINUE
              ELSE
                DO1150J=1,N
                  IF(XH1(J).EQ.XH1DIS(ISET1).AND.
     1               XH2(J).EQ.XH2DIS(ISET2))THEN
                     Y2(J)=(Y(J)-STAT1)/STAT2
                  ENDIF
 1150           CONTINUE
              ENDIF
            ENDIF
 1120     CONTINUE
 1110   CONTINUE
        GOTO9000
      ENDIF
C
C               ******************
C               **   STEP 90--  **
C               **   EXIT       **
C               ******************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'OFF')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF GRPSTA--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)NUMV2
 9013 FORMAT('NUMV2 = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9015)NUMSE1,NUMSE2
 9015 FORMAT('NUMSE1,NUMSE2 = ',2I8)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
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
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      IF(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
