      SUBROUTINE HARMEA(X,N,IWRITE,XHARM,IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE
C              SAMPLE HARMONIC MEAN, XHARM,
C              OF THE DATA IN THE INPUT VECTOR X.
C              THE SAMPLE XHARM = SUM(N/(1/X))
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF
C                                (UNSORTED OR SORTED) OBSERVATIONS.
C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR X.
C     OUTPUT ARGUMENTS--XHARM  = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED SAMPLE HARMONIC MEAN.
C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
C             SAMPLE HARMONIC MEAN
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           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 HARMEA--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)IBUGA3
   52 FORMAT('IBUGA3 = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)N
   53 FORMAT('N = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO55I=1,N
      WRITE(ICOUT,56)I,X(I)
   56 FORMAT('I,X(I) = ',I8,E15.7)
      CALL DPWRST('XXX','BUG ')
   55 CONTINUE
   90 CONTINUE
C
C               ******************************
C               **  COMPUTE HARMONIC MEAN  **
C               ******************************
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      AN=N
C
      IF(N.GE.1)GOTO119
      IERROR='YES'
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,111)
  111 FORMAT('***** ERROR IN HARMEA--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,112)
  112 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,113)
  113 FORMAT('      IN THE VARIABLE FOR WHICH')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,114)
  114 FORMAT('      THE HARMEA IS TO BE COMPUTED')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,115)
  115 FORMAT('      MUST BE 1 OR LARGER.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,116)
  116 FORMAT('      SUCH WAS NOT THE CASE HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,117)N
  117 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8,
     1'.')
      CALL DPWRST('XXX','BUG ')
      GOTO9000
  119 CONTINUE
C
      IF(N.EQ.1)GOTO120
      GOTO129
  120 CONTINUE
      XHARM=X(1)
      GOTO9000
  129 CONTINUE
C
  190 CONTINUE
C
C               ***********************************
C               **  STEP 2--                     **
C               **  COMPUTE THE HARMONIC MEAN.   **
C               ***********************************
C
      DN=N
      DSUM=0.0D0
      DO200I=1,N
        DX=DBLE(X(I))
        IF(DX.NE.0.0D0)DSUM=DSUM+1.0D0/DX
  200 CONTINUE
      DSUM=DN/DSUM
      XHARM=REAL(DSUM)
C
C               *******************************
C               **  STEP 3--                 **
C               **  WRITE OUT A LINE         **
C               **  OF SUMMARY INFORMATION.  **
C               *******************************
C
      IF(IFEEDB.EQ.'OFF')GOTO890
      IF(IWRITE.EQ.'OFF')GOTO890
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,811)N,XHARM
  811 FORMAT('THE HARMONIC MEAN OF THE ',I8,' OBSERVATIONS = ',E15.7)
      CALL DPWRST('XXX','BUG ')
  890 CONTINUE
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'OFF')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF HARMEA--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IBUGA3,IERROR
 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)N
 9013 FORMAT('N = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9015)XHARM
 9015 FORMAT('XHARM = ',E15.7)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE HAZARD(X,TAG,NX,IWRITE,Y,IBUGA3,IERROR)
C
C     PURPOSE--COMPUTE HAZARD OF AN ARRAY
C              THE TAG VARIABLE IDENTIFIES CENSORED DATA
C              (1 = FAILURE TIME, 0 = CENSORED)
C     NOTE--IT IS PERMISSIBLE TO HAVE THE OUTPUT VECTOR Y(.)
C           BEING IDENTICAL TO THE INPUT VECTOR X(.).
C     WRITTEN BY--JAMES J. FILLIBEN
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--98/5
C     ORIGINAL VERSION--MAY       1998.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
      DIMENSION Y(*)
      DIMENSION TAG(*)
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='HAZA'
      ISUBN2='RD  '
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 HAZARD--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)IBUGA3
   52 FORMAT('IBUGA3 = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)NX
   53 FORMAT('NX = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO55I=1,NX
      WRITE(ICOUT,56)I,X(I),TAG(I)
   56 FORMAT('I,X(I), TAG(I) = ',I8,2E15.7)
      CALL DPWRST('XXX','BUG ')
   55 CONTINUE
   90 CONTINUE
C
C               **************************************
C               **  COMPUTE CUMULATIVE HAZARD       **
C               **************************************
C
      CALL SORTC(X,TAG,NX,Y,TAG)
      CALL RANK(Y,NX,IWRITE,Y,IBUGA3,IERROR)
      IF(IERROR.EQ.'YES')GOTO9000
      AFACT=REAL(NX+1)
      DO100I=1,NX
        IF(ABS(TAG(I)).GE.0.5)THEN
          Y(I)=100.0/(AFACT - Y(I))
        ELSE
          Y(I)=0.0
        ENDIF
  100 CONTINUE
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
C
      IF(IBUGA3.EQ.'OFF')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF HAZARD--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IBUGA3,IERROR
 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)NX
 9013 FORMAT('NX = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO9015I=1,NX
      WRITE(ICOUT,9016)I,X(I),Y(I)
 9016 FORMAT('I,X(I),Y(I) = ',I8,2E15.7)
      CALL DPWRST('XXX','BUG ')
 9015 CONTINUE
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE HBOCDF(X,ALPHA,XI,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE HYPERBOLIC
C              DISTRIBUTION WITH SHAPE PARAMETERS ALPHA AND XI.
C              THE CUMULATIVE DISTRIBUTION IS COMPUTED BY
C              NUMERICALLY INTEGRATING THE PDF FUNCTION.
C     INPUT  ARGUMENTS--X       = THE DOUBLE PRECISION VALUE AT
C                                 WHICH THE CUMULATIVE DISTRIBUTION
C                                 FUNCTION IS TO BE EVALUATED.
C                     --ALPHA   = THE FIRST SHAPE PARAMETER
C                     --XI      = THE SECOND SHAPE PARAMETER
C     OUTPUT ARGUMENTS--CDF     = THE DOUBLE PRECISION CUMULATIVE
C                                 DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE FOR THE HYPERBOLIC
C             DISTRIBUTION WITH SHAPE PARAMETERS ALPHA AND XI.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--DQAGI.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISNAN, "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME I", SECOND EDITION,
C                 WILEY, 1994, PP. 60.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           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 XI
      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 HBOFUN
      EXTERNAL HBOFUN
C
      DOUBLE PRECISION DALPHA
      DOUBLE PRECISION DXI
      COMMON/HBOCOM/DALPHA,DXI
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 FIRST SHAPE PARAMETER (ALPHA)',
     1       ' IN HBOCDF ROUTINE IS NON-POSITIVE.')
      IF(XI.LE.0.0D0)THEN
        WRITE(ICOUT,8)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,48)XI
        CALL DPWRST('XXX','WRIT')
        CDF=0.0D0
        GOTO9000
      ENDIF
    8 FORMAT('***** ERROR: VALUE OF SECOND SHAPE PARAMETER (XI)',
     1       ' IN HBOCDF ROUTINE IS NON-POSITIVE.')
   48 FORMAT('      VALUE OF ARGUMENT IS: ',G15.7)
C
C               ************************************
C               **  STEP 1--                      **
C               **  COMPUTE THE DENSITY FUNCTION  **
C               ************************************
C
      INF=-1
      EPSABS=0.0D0
      EPSREL=1.0D-7
      IER=0
      DCDF=0.0D0
      IFLAG=0
      IF(DX.LT.0.0D0)THEN
        IFLAG=1
        INF=1
      ENDIF
C
      DATEMP=0.0D0
      DXI=XI
C
      CALL DQAGI(HBOFUN,DX,INF,EPSABS,EPSREL,DCDF,ABSERR,NEVAL,
     1          IER,LIMIT,LENW,LAST,IWORK,WORK)
C
      IF(IFLAG.EQ.1)THEN
        CDF=1.0D0 - DCDF
      ELSE
        CDF=DCDF
      ENDIF
C
      IF(IER.EQ.1)THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,111)
  111   FORMAT('***** ERROR FROM HBOCDF--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,113)
  113   FORMAT('      MAXIMUM NUMBER OF SUBDIVISIONS EXCEEDED.')
        CALL DPWRST('XXX','BUG ')
      ELSEIF(IER.EQ.2)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,121)
  121   FORMAT('***** ERROR FROM HBOCDF--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,123)
  123   FORMAT('      ROUNDOFF ERROR PREVENTS REQUESTED TOLERANCE ',
     1         'FROM BEING ACHIEVED.')
        CALL DPWRST('XXX','BUG ')
      ELSEIF(IER.EQ.3)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,131)
  131   FORMAT('***** ERROR FROM HBOCDF--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,133)
  133   FORMAT('      BAD INTEGRAND BEHAVIOUR DETECTED.')
        CALL DPWRST('XXX','BUG ')
      ELSEIF(IER.EQ.4)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,141)
  141   FORMAT('***** ERROR FROM HBOCDF--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,143)
  143   FORMAT('      INTEGRATION DID NOT CONVERGE.')
        CALL DPWRST('XXX','BUG ')
      ELSEIF(IER.EQ.5)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,151)
  151   FORMAT('***** ERROR FROM HBOCDF--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,153)
  153   FORMAT('      THE INTEGRATION IS PROBABLY DIVERGENT.')
        CALL DPWRST('XXX','BUG ')
      ELSEIF(IER.EQ.6)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,161)
  161   FORMAT('***** ERROR FROM HBOCDF--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,163)
  163   FORMAT('      INVALID INPUT TO THE INTEGRATION ROUTINE.')
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      DOUBLE PRECISION FUNCTION HBOFUN(DX)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE HYPERBOLIC
C              DISTRIBUTION WITH SHAPE PARAMETERS ALPHA AND XI.
C              THIS DISTRIBUTION IS DEFINED FOR ALL REAL X
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C
C                 f(X;ALPHA,XI) = (1/{2*SQRT(1+ALPHA**2)*K(1)(XI)})*
C                     EXP{-XI*[SQRT(1+ALPHA**2)*SQRT(1+X**2)-ALPHA*X]}
C                     XI > 0
C              WHERE
C                 K(N,X) IS THE MODIFIED BESSEL FUNCTION OF THE
C                        SECOND KIND AND ORDER N.
C
C              THE HBOPDF ROUTINE IS CALLED TO COMPUTE THE
C              PROBABILITY DENSITY.  DEFINE AS FUNCTION TO BE USED FOR
C              INTEGRATION CODE CALLED BY HBOCDF.  THIS ROUTINE USES
C              DOUBLE PRECISION ARITHMETIC.
C     INPUT  ARGUMENTS--DX      = THE DOUBLE PRECISION VALUE AT
C                                 WHICH THE PROBABILITY DENSITY
C                                 FUNCTION IS TO BE EVALUATED.
C     OUTPUT ARGUMENTS--HBOFUN  = THE DOUBLE PRECISION PROBABILITY
C                                 DENSITY FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE PDF FOR THE HYPERBOLIC
C             DISTRIBUTION WITH SHAPE PARAMETERS ALPHA AND XI.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--HBOPDF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISNAN, "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME I", SECOND EDITION,
C                 WILEY, 1994, PP. 60.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           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 DXI
      COMMON/HBOCOM/DALPHA,DXI
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 HBOPDF(DX,DALPHA,DXI,DTERM)
      HBOFUN=DTERM
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE HBOPDF(X,ALPHA,XI,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE HYPERBOLIC DISTRIBUTION WITH
C              SHAPE PARAMETERS ALPHA AND XI.  THIS DISTRIBUTION IS
C              DEFINED FOR ALL REAL X AND HAS THE PROBABILITY DENSITY
C              FUNCTION
C
C                 f(X;ALPHA,XI) = (1/{2*SQRT(1+ALPHA**2)*K(1)(XI)})*
C                     EXP{-XI*[SQRT(1+ALPHA**2)*SQRT(1+X**2)-ALPHA*X]}
C                     XI > 0
C              WHERE
C                 K(N,X) IS THE MODIFIED BESSEL FUNCTION OF THE
C                        SECOND KIND AND ORDER N.
C
C     NOTE--ARGUMENTS TO THIS ROUTINE ARE IN DOUBLE PRECISION.
C     INPUT  ARGUMENTS--X       = THE DOUBLE PRECISION VALUE AT
C                                 WHICH THE PROBABILITY DENSITY
C                                 FUNCTION IS TO BE EVALUATED.
C                     --ALPHA   = THE FIRST SHAPE PARAMETER
C                     --XI      = THE SECOND SHAPE PARAMETER,
C                                 XI SHOULD BE POSITIVE.
C     OUTPUT ARGUMENTS--PDF     = THE DOUBLE PRECISION PROBABILITY
C                                 DENSITY FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION PROBABILITY DENSITY FUNCTION
C             VALUE PDF FOR THE HYPERBOLIC DISTRIBUTION
C             WITH SHAPE PARAMETERS ALPHA AND XI.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--DBESK.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--DEXP, DLOG.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISNAN, "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME I", SECOND EDITION,
C                 WILEY, 1994, PP. 60.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           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 ALPHA
      DOUBLE PRECISION XI
      DOUBLE PRECISION PDF
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
      DOUBLE PRECISION DBESK1
      EXTERNAL DBESK1
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 THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      IF(ALPHA.LE.0.0D0)THEN
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,48)ALPHA
        CALL DPWRST('XXX','WRIT')
        PDF=0.0D0
        GOTO9000
      ENDIF
    5 FORMAT('***** ERROR: VALUE OF FIRST SHAPE PARAMETER (ALPHA)',
     1       ' IN HBOPDF ROUTINE IS NON-POSITIVE.')
      IF(XI.LE.0.0D0)THEN
        WRITE(ICOUT,8)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,48)XI
        CALL DPWRST('XXX','WRIT')
        PDF=0.0D0
        GOTO9000
      ENDIF
    8 FORMAT('***** ERROR: VALUE OF SECOND SHAPE PARAMETER (XI)',
     1       ' IN HBOPDF ROUTINE IS NON-POSITIVE.')
   48 FORMAT('      VALUE OF ARGUMENT IS: ',G15.7)
C
C               *****************************************
C               **  STEP 2--                           **
C               **  COMPUTE THE DENSITY FUNCTION.  FOR **
C               **  BETTER NUMERICAL STABILITY,        **
C               **  COMPUTE LOGARIGHMS.                **
C               *****************************************
C
C
      DTERM1=DLOG(2.0D0) + 0.5D0*DLOG(1.0D0+ALPHA**2) +
     1       DLOG(DBESK1(XI))
      DTERM2=-XI*(DSQRT((1.0D0+ALPHA**2)*(1.0D0+X**2)) - ALPHA*X)
      DTERM3=-DTERM1 + DTERM2
      PDF=DEXP(DTERM3)
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE HCONS(Y,X,XIDTEM,TEMP,TEMP2,N,IWRITE,YOUT,NUMSET,
     1ISUBRO,IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE H CONSISTENCY STATISTIC
C              OF THE DATA IN THE INPUT VECTOR Y WITH LAB ID
C              VECTOR X.  THE H CONSISTENCY STATISTIC IS DEFINED AS:
C             
C                 H(i) = D(i)/s(xbar(i))
C
C              WITH
C
C                 xbar(i)     = MEAN OF GROUP I
C                 s(xbar(i))  = STANDARD DEVIATION OF THE GROUP
C                               MEANS
C                 D(i)        = xbar(i) - xbar
C                 xbar        = OVERALL MEAN
C
C     INPUT  ARGUMENTS--Y      = THE SINGLE PRECISION VECTOR OF
C                                (UNSORTED OR SORTED) OBSERVATIONS.
C                     --X      = THE SINGLE PRECISION VECTOR OF
C                                GROUP ID's.
C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR Y.
C     OUTPUT ARGUMENTS--YOUT   = THE SINGLE PRECISION VECTOR OF THE
C                                COMPUTED SAMPLE H CONSISTENCY
C                                STATISTIC.
C                     --NUMSET = THE INTEGER VALUE CONTAINING THE
C                                NUMBER OF GROUPS.
C     OUTPUT--THE COMPUTED SINGLE PRECISION VECTOR OF THE
C             SAMPLE H CONSISTENCY STATISTIC.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--SORT, DISTIN, SD.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--SQRT.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--"Standard Practice for Conducting an
C                 Interlaboratory Study to Determine the Precision
C                 of a Test Method", ASTM International,
C                 100 Barr Harbor Drive, PO BOX C700,
C                 West Conshohoceken, PA 19428-2959, USA.
C                 This document is in support of
C                 ASTM Standard E 691 - 99.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2005.2
C     ORIGINAL VERSION--FEBRUARY  2005.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGA3
      CHARACTER*4 ISUBRO
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DIMENSION Y(*)
      DIMENSION X(*)
      DIMENSION YOUT(*)
      DIMENSION XIDTEM(*)
      DIMENSION TEMP(*)
      DIMENSION TEMP2(*)
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='HCON'
      ISUBN2='S   '
C
      IERROR='NO'
C
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CONS')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,51)
   51   FORMAT('***** AT THE BEGINNING OF HCONS--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,52)IBUGA3,ISUBRO,N
   52   FORMAT('IBUGA3,ISUBRO,N = ',A4,1X,A4,1X,I8)
        CALL DPWRST('XXX','BUG ')
        DO55I=1,N
          WRITE(ICOUT,56)I,Y(I),X(I)
   56     FORMAT('I,Y(I),X(I) = ',I8,2E15.7)
          CALL DPWRST('XXX','BUG ')
   55   CONTINUE
      ENDIF
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      AN=N
C
      IF(N.LE.1)THEN
        IERROR='YES'
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,111)
  111   FORMAT('***** ERROR IN COMPUTING H CONSISTENCY STATISTIC--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,112)
  112   FORMAT('      THE INPUT NUMBER OF OBSERVATIONS IN THE')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,114)
  114   FORMAT('      VARIABLES FOR WHICH THE H CONSISTENCY ',
     1         'STATISTIC')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,115)
  115   FORMAT('      IS TO BE COMPUTED MUST BE 2 OR LARGER.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,116)
  116   FORMAT('      SUCH WAS NOT THE CASE HERE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,117)N
  117   FORMAT('      THE INPUT NUMBER OF OBSERVATIONS = ',I8,'.')
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        GOTO9000
      ENDIF
C
C               ****************************************************
C               **  STEP 2--                                      **
C               **  COMPUTE THE H CONSISTENCY STATISTIC           **
C               ****************************************************
C
      IWRITE='OFF'
      CALL DISTIN(X,N,IWRITE,XIDTEM,NUMSET,IBUGA3,IERROR)
      CALL SORT(XIDTEM,NUMSET,XIDTEM)
      CALL MEAN(Y,N,IWRITE,XBAR,IBUGA3,IERROR)
C
      IF(NUMSET.LT.1)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,111)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,192)
  192   FORMAT('      NUMBER OF LABS    NUMSET < 1')
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        GOTO9000
      ENDIF
C
      AN=N
      ANUMSE=NUMSET
C
      J=0
      DO1110ISET1=1,NUMSET
        K=0
        DO1130I=1,N
          IF(XIDTEM(ISET1).EQ.X(I))THEN
            K=K+1
            TEMP(K)=Y(I)
          ENDIF
 1130   CONTINUE
        NTEMP=K 
        CALL MEAN(TEMP,NTEMP,IWRITE,XBARI,IBUGA3,IERROR)
        TEMP2(ISET1)=XBARI
        YOUT(ISET1)=XBARI - XBAR
        IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CONS')THEN
          WRITE(ICOUT,1131)ISET1,XBARI
 1131     FORMAT('ISET1,XBARI = ',I8,G15.7)
          CALL DPWRST('XXX','BUG ')
        ENDIF
 1110 CONTINUE
C
      CALL SD(TEMP2,NUMSET,IWRITE,SDBARI,IBUGA3,IERROR)
      DO1150I=1,NUMSET
        YOUT(I)=YOUT(I)/SDBARI
 1150 CONTINUE
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CONS')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END       OF HCONS--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9012)IBUGA3,ISUBRO,IERROR
 9012   FORMAT('IBUGA3,ISUBRO,IERROR = ',A4,2X,A4,2X,A4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9013)N,NUMSET,XBAR
 9013   FORMAT('N,NUMSET,XBAR = ',I8,1X,I8,1X,G15.7)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9015)SDBARI
 9015   FORMAT('SDBARI = ',E15.7)
        CALL DPWRST('XXX','BUG ')
        DO9018I=1,NUMSET
          WRITE(ICOUT,9019)I,TEMP2(I),YOUT(I)
 9019     FORMAT('I,TEMP2(I),YOUT(I) = ',I8,2G15.7)
          CALL DPWRST('XXX','BUG ')
 9018   CONTINUE
      ENDIF
C
      RETURN
      END
      SUBROUTINE HCONS2(Y,X1,X2,XIDTEM,XIDTE2,TEMP,TEMP2,N,IWRITE,
     1YOUT,TAG,NOUT,
     1ISUBRO,IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE H CONSISTENCY STATISTIC
C              OF THE DATA IN THE INPUT VECTOR Y WITH LAB ID
C              VECTOR X.  THE H CONSISTENCY STATISTIC IS DEFINED AS:
C             
C                 H(i) = D(i)/s(xbar(i))
C
C              WITH
C
C                 xbar(i)     = MEAN OF GROUP I
C                 s(xbar(i))  = STANDARD DEVIATION OF THE GROUP
C                               MEANS
C                 D(i)        = xbar(i) - xbar
C                 xbar        = OVERALL MEAN
C
C              THE DISTINCTION BETWEEN HCONS AND HCONS2 IS THAT
C              HCONS IS USED TO COMPUTE THE H CONSISTENCY STATISTIC
C              FOR A SINGLE MATERIAL WHILE HCONS2 COMPUTES THE
C              H CONSISTENCY STATISTIC FOR MULTIPLE MATERIALS.
C
C     INPUT  ARGUMENTS--Y      = THE SINGLE PRECISION VECTOR OF
C                                (UNSORTED OR SORTED) OBSERVATIONS.
C                     --X1     = THE SINGLE PRECISION VECTOR OF
C                                GROUP ID's.
C                     --X2     = THE SINGLE PRECISION VECTOR OF
C                                MATERIAL ID's.
C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR Y.
C     OUTPUT ARGUMENTS--YOUT   = THE SINGLE PRECISION VECTOR OF THE
C                                COMPUTED SAMPLE H CONSISTENCY
C                                STATISTIC.
C                     --TAG    = THE SINGLE PRECISION VECTOR OF THE
C                                MATERIAL ID's.
C                     --NOUT   = THE INTEGER VALUE CONTAINING THE
C                                NUMBER OF VALUES IN YOUT
C     OUTPUT--THE COMPUTED SINGLE PRECISION VECTOR OF THE
C             SAMPLE H CONSISTENCY STATISTIC WITH THE CORRESPONDING
C             MATERIAL ID.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--SORT, DISTIN, SD.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--SQRT.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--"Standard Practice for Conducting an
C                 Interlaboratory Study to Determine the Precision
C                 of a Test Method", ASTM International,
C                 100 Barr Harbor Drive, PO BOX C700,
C                 West Conshohoceken, PA 19428-2959, USA.
C                 This document is in support of
C                 ASTM Standard E 691 - 99.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2005.2
C     ORIGINAL VERSION--FEBRUARY  2005.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGA3
      CHARACTER*4 ISUBRO
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DIMENSION Y(*)
      DIMENSION X1(*)
      DIMENSION X2(*)
      DIMENSION YOUT(*)
      DIMENSION TAG(*)
      DIMENSION XIDTEM(*)
      DIMENSION XIDTE2(*)
      DIMENSION TEMP(*)
      DIMENSION TEMP2(*)
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='HCON'
      ISUBN2='S2  '
C
      IERROR='NO'
C
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'ONS2')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,51)
   51   FORMAT('***** AT THE BEGINNING OF HCONS2--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,52)IBUGA3,ISUBRO,N
   52   FORMAT('IBUGA3,ISUBRO,N = ',A4,1X,A4,1X,I8)
        CALL DPWRST('XXX','BUG ')
        DO55I=1,N
          WRITE(ICOUT,56)I,Y(I),X1(I),X2(I)
   56     FORMAT('I,Y(I),X1(I),X2(I) = ',I8,3G15.7)
          CALL DPWRST('XXX','BUG ')
   55   CONTINUE
      ENDIF
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      AN=N
C
      IF(N.LE.1)THEN
        IERROR='YES'
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,111)
  111   FORMAT('***** ERROR IN COMPUTING H CONSISTENCY STATISTIC--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,112)
  112   FORMAT('      THE INPUT NUMBER OF OBSERVATIONS IN THE')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,114)
  114   FORMAT('      VARIABLES FOR WHICH THE H CONSISTENCY ',
     1         'STATISTIC')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,115)
  115   FORMAT('      IS TO BE COMPUTED MUST BE 2 OR LARGER.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,116)
  116   FORMAT('      SUCH WAS NOT THE CASE HERE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,117)N
  117   FORMAT('      THE INPUT NUMBER OF OBSERVATIONS = ',I8,'.')
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        GOTO9000
      ENDIF
C
C               ****************************************************
C               **  STEP 2--                                      **
C               **  COMPUTE THE H CONSISTENCY STATISTIC           **
C               ****************************************************
C
      IWRITE='OFF'
      CALL DISTIN(X1,N,IWRITE,XIDTEM,NUMSE1,IBUGA3,IERROR)
      CALL SORT(XIDTEM,NUMSE1,XIDTEM)
      CALL DISTIN(X2,N,IWRITE,XIDTE2,NUMSE2,IBUGA3,IERROR)
      CALL SORT(XIDTE2,NUMSE2,XIDTEM)
C
      IF(NUMSE1.LT.1)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,111)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,192)
  192   FORMAT('      NUMBER OF LABS    NUMSE1 < 1')
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        GOTO9000
      ENDIF
C
      IF(NUMSE2.LT.1)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,111)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,194)
  194   FORMAT('      NUMBER OF MATERIALS    NUMSE2 < 1')
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        GOTO9000
      ENDIF
C
      J=0
      NOUT=0
      DO1110ISET2=1,NUMSE2
C
C  STEP 1: COMPUTE OVERALL MEAN FOR CURRENT MATERIAL
C
        K=0
        DO1120I=1,N
          IF(XIDTE2(ISET2).EQ.X2(I))THEN
            K=K+1
            TEMP(K)=Y(I)
          ENDIF
 1120   CONTINUE
        NTEMP=K
        CALL MEAN(TEMP,NTEMP,IWRITE,XBAR,IBUGA3,IERROR)
C
        DO1130ISET1=1,NUMSE1
C
          K=0
          DO1140I=1,N
            IF(XIDTEM(ISET1).EQ.X1(I).AND.XIDTE2(ISET2).EQ.X2(I))THEN
              K=K+1
              TEMP(K)=Y(I)
            ENDIF
 1140     CONTINUE
          NTEMP=K
C
          CALL MEAN(TEMP,NTEMP,IWRITE,XBARI,IBUGA3,IERROR)
          TEMP2(ISET1)=XBARI
          NOUT=(ISET2-1)*NUMSE1 + ISET1
          YOUT(NOUT)=XBARI - XBAR
          TAG(NOUT)=REAL(ISET2)
          IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'ONS2')THEN
            WRITE(ICOUT,1141)ISET1,ISET2,XBAR,XBARI
 1141       FORMAT('ISET1,ISET2,XBAR,XBARI = ',2I8,2G15.7)
            CALL DPWRST('XXX','BUG ')
          ENDIF
 1130   CONTINUE
C
        CALL SD(TEMP2,NUMSE1,IWRITE,SDBARI,IBUGA3,IERROR)
        DO1150I=(ISET2-1)*NUMSE1+1,ISET2*NUMSE1
          YOUT(I)=YOUT(I)/SDBARI
 1150   CONTINUE
C
 1110 CONTINUE
      NOUT=NUMSE1*NUMSE2
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'ONS2')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END       OF HCONS2--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9012)IBUGA3,ISUBRO,IERROR
 9012   FORMAT('IBUGA3,ISUBRO,IERROR = ',A4,2X,A4,2X,A4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9013)N,NUMSE1,NUMSE2,XBAR
 9013   FORMAT('N,NUMSE1,NUMSE2,XBAR = ',I8,1X,I8,1X,I8,1X,G15.7)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9015)SDBARI
 9015   FORMAT('SDBARI = ',G15.7)
        CALL DPWRST('XXX','BUG ')
        DO9018I=1,NOUT
          WRITE(ICOUT,9019)I,TAG(I),YOUT(I)
 9019     FORMAT('I,TAG(I),YOUT(I) = ',I8,2G15.7)
          CALL DPWRST('XXX','BUG ')
 9018   CONTINUE
      ENDIF
C
      RETURN
      END
      SUBROUTINE HEADS(Y,X,TAG,N,
     1DIST,DTAG,
     1HEADS2,NTRIAL,AVEDEL,SDAVED,IBUGG3,ISUBRO,IERROR)
C
C     PURPOSE--DETERMINE NUMBER OF "HEADS" IN BLOCK PLOT
C     WRITTEN BY--JAMES J. FILLIBEN
C                 NATIONAL INSTITUTE OF STANDARDS & TECHNOLOGY
C                 GAITHERSBURG, MARYLAND 20899
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     ORIGINAL VERSION--MAY     1992.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IBUGG3
      CHARACTER*4 ISUBRO
      CHARACTER*4 IERROR
C
      CHARACTER*4 IWRITE
C
C---------------------------------------------------------------------
C
      DIMENSION Y(*)
      DIMENSION X(*)
      DIMENSION TAG(*)
      DIMENSION DIST(*)
      DIMENSION DTAG(*)
C
      DIMENSION TAGMAX(1000)
      DIMENSION TAGMIN(1000)
      DIMENSION DEL(1000)
C
      INCLUDE 'DPCOPA.INC'
      INCLUDE 'DPCOZZ.INC'
      EQUIVALENCE (GARBAG(IGARB7),TAGMAX(1))
      EQUIVALENCE (GARBAG(IGARB8),TAGMIN(1))
      EQUIVALENCE (GARBAG(IGARB9),DEL(1))
C
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      IERROR='NO'
C
      IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'EADS')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,70)
   70 FORMAT('AT THE BEGINNING OF HEADS--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,71)N
   71 FORMAT('N = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO75I=1,N
         WRITE(ICOUT,76)I,Y(I),X(I),TAG(I)
   76    FORMAT('I,Y(I),X(I),TAG(I) = ',I8,3F15.7)
      CALL DPWRST('XXX','BUG ')
   75 CONTINUE
   90 CONTINUE
C
C               **************************************************
C               **  STEP 1--                                    **
C               **  FORM A VECTOR (TAXMAX(.))                   **
C               **  WHICH WILL CONTAIN THE TAGS                 **
C               **  OF THE LARGEST ITEM IN EACH BLOCK.          **
C               **  THE NUMBER OF ITEMS IN TAGMAX(.)            **
C               **  WILL EQUAL THE NUMBER OF DISTINCT X VALUES. **
C               **************************************************
C
      CALL DISTIN(X,N,'OFF ',DIST,NTRIAL,IBUGG3,IERROR)
C
      DO1100ID=1,NTRIAL
C
         YIMAX=CPUMIN
         DO1200I=1,N
            IF(X(I).EQ.DIST(ID))THEN
               IF(Y(I).GT.YIMAX)THEN
                  YIMAX=Y(I)
                  TAGMAX(ID)=TAG(I)
               ENDIF
            ENDIF
 1200    CONTINUE
C
         YIMIN=CPUMAX
         DO1300I=1,N
            IF(X(I).EQ.DIST(ID))THEN
               IF(Y(I).LT.YIMIN)THEN
                  YIMIN=Y(I)
                  TAGMIN(ID)=TAG(I)
               ENDIF
            ENDIF
 1300    CONTINUE
C
      IF(TAGMAX(ID).EQ.TAGMAX(1))DEL(ID)=YIMAX-YIMIN
      IF(TAGMAX(ID).NE.TAGMAX(1))DEL(ID)=(-(YIMAX-YIMIN))
C
 1100 CONTINUE
C
C               **************************************************
C               **  STEP 2--                                    **
C               **  SCAN THE TAGMAX(.) VECTOR.                  **
C               **  DETERMINE THE MOST FREQUENT TAG IN TAXMAX(.). **
C               **  OUTPUT THAT MAX FREQUENCY (IN HEADS2).      **
C               **************************************************
C
      CALL DISTIN(TAGMAX,NTRIAL,'OFF ',DTAG,NDTAG,IBUGG3,IERROR)
C
      JMAX=(-999)
      DO2100IDTAG=1,NDTAG
         J=0
         DO2200I=1,NTRIAL
            IF(TAGMAX(I).EQ.DTAG(IDTAG))J=J+1
 2200    CONTINUE
         IF(J.GT.JMAX)JMAX=J
 2100 CONTINUE
      HEADS2=JMAX
C
C               *****************************************************
C               **  STEP 3--                                       **
C               **  COMPUTE THE AVERAGE DIFFERENCE (= EST. EFFECT) **
C               **  IN THE RESPONSE                                **
C               **  BETWEEN THE MAX AND THE MIN                    **
C               *****************************************************
C
      IWRITE='OFF'
      CALL MEAN(DEL,NTRIAL,IWRITE,AVEDEL,IBUGG3,IERROR)
      CALL SDMEAN(DEL,NTRIAL,IWRITE,SDAVED,IBUGG3,IERROR)
C
C               ******************
C               **   STEP 90--  **
C               **   EXIT       **
C               ******************
C
 9000 CONTINUE
      IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'EADS')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('AT THE END       OF HEADS--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9021)N
 9021 FORMAT('N = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO9022I=1,N
         WRITE(ICOUT,9023)I,Y(I),X(I),TAG(I)
 9023    FORMAT('I,Y(I),X(I),TAG(I) = ',I8,3F15.7)
      CALL DPWRST('XXX','BUG ')
 9022 CONTINUE
      WRITE(ICOUT,9031)HEADS2,NTRIAL
 9031 FORMAT('HEADS2,NTRIAL= ',F15.5,I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9032)AVEDEL,SDAVED
 9032 FORMAT('AVEDEL,SDAVED = ',2F15.5)
      CALL DPWRST('XXX','BUG ')
      DO9033I=1,NTRIAL
         WRITE(ICOUT,9034)I,DIST(I),TAGMAX(I)
 9034    FORMAT('I,DIST(I),TAGMAX(I) = ',I8,2F15.7)
      CALL DPWRST('XXX','BUG ')
 9033 CONTINUE
      WRITE(ICOUT,9041)NDTAG
 9041 FORMAT('NDTAG = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO9042I=1,NDTAG
         WRITE(ICOUT,9043)I,DTAG(I)
 9043    FORMAT('I,DTAG(I) = ',I8,F15.7)
      CALL DPWRST('XXX','BUG ')
 9042 CONTINUE
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE HERMIT(X,AN,HN)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE HERMITE POLYNOMIAL OF
C              ORDER N.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION INPUT ARGUMENT
C                       AN     = THE SINGLE PRECISION VALUE FOR THE
C                                ORDER OF THE FUNCTION (SHOULD BE
C                                NON-NEGATIVE ORDER)
C     OUTPUT ARGUMENTS--HN     = THE SINGLE PRECISION VALUE OF THE
C                                HERMITE POLYNOMIAL.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 
C     RESTRICTIONS--
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE
C     MODE OF INTERNAL OPERATIONS--SOME DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN. 
C     REFERENCES--"HANDBOOK OF MATHEMATICAL FUNCTIONS, AMS 55", 
C                 ABRAMOWITZ AND STEGUM.
C                 USE FOLLOWING RECURRENCE FORMULA:
C                    H(N+1) = 2.0*X*H(N)-2.0*N*H(N-1)
C                 FIRST FEW TERMS ARE FROM TABLE 22.12 OF ABRAMOWITZ
C                 AND STEGUM.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE:  301-975-2855
C     ORIGINAL VERSION--JULY       1995. 
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
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
      DOUBLE PRECISION DX
      DOUBLE PRECISION DN, DN2
      DOUBLE PRECISION DHN, DHN1, DHN2
C
C-----START POINT-----------------------------------------------------
C
      N=INT(AN+0.5)
      IF(N.LT.0)THEN
        WRITE(ICOUT,6)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
    6 FORMAT('***** NON-FATAL DIAGNOSTIC--THE 2ND INPUT ARGUMENT ',
     1'TO THE HERMIT SUBROUTINE IS NEGATIVE *****')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
C
      DX=DBLE(X)
      DN=DBLE(N)
C
      IF(N.LE.0)THEN
        HN=1.0
      ELSEIF(N.EQ.1)THEN
        HN=2.0*X
      ELSEIF(N.EQ.2)THEN
        HN=4.0*X**2 - 2.0
      ELSEIF(N.EQ.3)THEN
        DHN=8.0D0*DX**3 - 12.0D0*DX
        HN=REAL(DHN)
      ELSEIF(N.EQ.4)THEN
        DHN=16.0D0*DX**4 - 48.0D0*X**2 + 12.0D0
        HN=REAL(DHN)
      ELSEIF(N.EQ.5)THEN
        DHN=32.0D0*DX**5 - 160.0D0*DX**3 + 120.0D0*DX
        HN=REAL(DHN)
      ELSE
        DHN1=32.0D0*DX**5 - 160.0D0*DX**3 + 120.0D0*DX
        DHN2=16.0D0*DX**4 - 48.0D0*X**2 + 12.0D0
        DO1000I=6,N
          DN2=DBLE(I)-1.0D0
          DHN=2.0D0*DX*DHN1 - 2.0D0*DN2*DHN2
          DHN2=DHN1
          DHN1=DHN
 1000   CONTINUE
        HN=REAL(DHN)
      ENDIF
C
 9999 CONTINUE
      RETURN
      END 
      SUBROUTINE HERCDF(X,ALPHA,BETA,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE AT THE SINGLE PRECISION VALUE X
C              FOR THE HERMITE DISTRIBUTION
C              WITH SINGLE PRECISION PARAMETERS ALPHA AND BETA.
C              THIS DISTRIBUTION IS DEFINED FOR ALL
C              NON-NEGATIVE INTEGERS.
C              THIS DISTRIBUTION HAS THE PROBABILITY FUNCTION
C                 F(X) = (ALPHA**X*H(BETA)/X!)*PR(X=0)
C              WITH H(X) DENOTING THE MODIFIED HERMITE POLYNOMIAL:
C                 H(BETA) = SUM[j=0 to INT(N/2)]
C                           [N!*X**(N-2*j)/((N-2(j)!j!2**j)]
C              THE FIRST FEW TERMS ARE:
C                 PR(X=0) = EXP[-ALPHA*BETA - ALPHA**2/2]
C                 PR(X=1) = ALPHA*BETA*PR(X=0)
C                 PR(X=2) = (ALPHA**2*(BETA**2+1)/2!)*PR(X=0)
C                 PR(X=3) = (ALPHA**3*(BETA**3+3*BETA)/3!)*PR(X=0)
C                 PR(X=4) = (ALPHA**4*(BETA**4+6*BETA**2+3)/4!)*PR(X=0)
C                 PR(X=5) = (ALPHA**5*(BETA**5+10*BETA**3+15*BETA)/5!)
C                           *PR(X=0)
C              
C                 PR(X=X+1) = (1/(X+1))*ALPHA*BETA*PR(X=x) +
C                             ALPHA**2*PR(X=x-1)
C
C              FOR X <= 20, THE ABOVE RECURRENCE RELATION WILL
C              BE USED.  FOR X > 20, AN AYMPTOTIC FORMULA DUE
C              TO Y. C. PATEL WILL BE USED.  NOTE THAT THE
C              PATEL ARTICLE USES:
C
C                 A = ALPHA*BETA
C                 B = ALPHA**2/2
C
C              IF YOU WANT TO OBTAIN APPROPRIATE VALUES OF
C              ALPHA AND BETA GIVEN A AND B, THEN
C
C                 ALPHA = SQRT(2*B)
C                 BETA  = A/SQRT(2*B)
C 
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE
C                                AT WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE INTEGRAL-VALUED,
C                                AND BETWEEN 0.0 (INCLUSIVELY)
C                                AND N (INCLUSIVELY).
C                     --ALPHA  = THE SINGLE PRECISION VALUE
C                                OF THE FIRST SHAPE PARAMETER.
C                     --BETA   = THE SINGLE PRECISION VALUE
C                                OF THE SECOND SHAPE PARAMETER.
C     OUTPUT ARGUMENTS--CDF    = THE SINGLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE CDF FOR THE HERMITE DISTRIBUTION
C             WITH SHAPE PARAMETERS ALPHA AND BETA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE INTEGRAL-VALUED AND NON-NEGATIVE
C                 --ALPHA AND BETA SHOULD BE POSITIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--DLNGAM, DGAMMA.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--DLOG, DEXP, DSQRT, DCOSH,
C                                         DSINH, DLOG10.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND KEMP, "UNIVARIATE DISCRETE
C                 DISTRIBUTIONS", SECOND EDITION, WILEY, 1992,
C                 PP. 357-364.
C               --Y. C. PATEL, "AN ASYMPTOTIC EXPRESSION FOR
C                 CUMULATIVE SUM OF PROBABILITIES OF THE HERMITE
C                 DISTRIBUTION", COMMUNICATIOS IN STATISTICS-
C                 THEORY AND METHODS, 14, PP. 2233-2241.
C               --KEMP AND KEMP, "SOME PROPERTIES OF THE HERMITE
C                 DISTRIBUTION", BIOMETRIKA, 1965, 52, 3 AND 4,
C                 P. 381
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           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               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--2004/4
C     ORIGINAL VERSION--APRIL     2004.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DALPHA
      DOUBLE PRECISION DBETA
      DOUBLE PRECISION DA
      DOUBLE PRECISION DB
      DOUBLE PRECISION DTERM1, DTERM2, DTERM3, DTERM4, DTERM5
      DOUBLE PRECISION DCDF
      DOUBLE PRECISION DPDF
      DOUBLE PRECISION DCDF0
      DOUBLE PRECISION DS
      DOUBLE PRECISION DMU
      DOUBLE PRECISION DMUS
      DOUBLE PRECISION S0
      DOUBLE PRECISION K
      DOUBLE PRECISION ZS
      DOUBLE PRECISION DNUM
      DOUBLE PRECISION DDENOM
C
C---------------------------------------------------------------------
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
      CDF=0.0
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(ALPHA.LE.0.0)THEN
        WRITE(ICOUT,11)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ALPHA
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9999
      ENDIF
      IF(BETA.LE.0.0)THEN
        WRITE(ICOUT,12)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)BETA
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9999
      ENDIF
      INTX=X+0.0001
      FINTX=INTX
      DEL=X-FINTX
      IF(DEL.LT.0.0)DEL=-DEL
      IF(DEL.GT.0.001)THEN
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,6)INT(FINTX)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
      ENDIF
      IF(FINTX.LT.0.0)THEN
        WRITE(ICOUT,4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
C
    4 FORMAT('***** FATAL ERROR--THE FIRST INPUT ',
     1'ARGUMENT TO THE HERCDF SUBROUTINE IS NEGATIVE.')
    5 FORMAT('***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ',
     1'ARGUMENT TO THE HERCDF SUBROUTINE IS NON-INTEGRAL *****')
    6 FORMAT('      IT HAS BEEN SET TO ',I8)
   11 FORMAT('***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE ',
     1' HERCDF SUBROUTINE IS NON-POSITIVE')
   12 FORMAT('***** FATAL ERROR--THE THIRD INPUT ARGUMENT TO THE ',
     1' HERCDF SUBROUTINE IS NON-POSITIVE')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
C
      DALPHA=DBLE(ALPHA)
      DBETA=DBLE(BETA)
      DB=DALPHA**2/2.0D0
      DA=DALPHA*DBETA
C
C  USE EXACT FORMULAS
C
      IF(INTX.LE.25)THEN
        DCDF0=DEXP(-DALPHA*DBETA - DALPHA**2/2.0D0)
        DCDF=DCDF0
        IF(INTX.EQ.0)GOTO9010
C
        DCDF=DCDF + DALPHA*DBETA*DCDF0
        IF(INTX.EQ.1)GOTO9010
C
        DTERM1=DALPHA**2*(DBETA*DBETA + 1.0D0)
        DCDF=DCDF + (DTERM1/2.0D0)*DCDF0
        IF(INTX.EQ.2)GOTO9010
C
        DTERM1=DALPHA**3*(DBETA**3 + 3.0D0*DBETA)
        DCDF=DCDF + (DTERM1/6.0D0)*DCDF0
        IF(INTX.EQ.3)GOTO9010
C
        DTERM1=DALPHA**4*(DBETA**4 + 6.0D0*DBETA**2 + 3.0D0)
        DCDF=DCDF + (DTERM1/24.0D0)*DCDF0
        IF(INTX.EQ.4)GOTO9010
C
        DTERM1=DALPHA**5*(DBETA**5 + 10.0D0*DBETA**3 + 15.0D0*DBETA)
        DCDF=DCDF + (DTERM1/120.0D0)*DCDF0
        IF(INTX.EQ.5)GOTO9010
C
        DTERM1=DALPHA**4*(DBETA**4 + 6.0D0*DBETA**2 + 3.0D0)
        DTERM1=(DTERM1/24.0D0)*DCDF0
        DTERM2=DALPHA**5*(DBETA**5 + 10.0D0*DBETA**3 + 15.0D0*DBETA)
        DTERM2=(DTERM2/120.0D0)*DCDF0
C
        DO110I=6,INTX
          DPDF=(DALPHA*DBETA*DTERM2 + DALPHA*DALPHA*DTERM1)/DBLE(I)
          DCDF=DCDF + DPDF
          DTERM1=DTERM2
          DTERM2=DPDF
  110   CONTINUE
        GOTO9010
      ELSE
C
C  USE ASYMPTOTIC APPROXIMATION
C
        DS=DBLE(INTX)
        DMU=DA + 2.0D0*DB
        CALL HERPDF(0.0,ALPHA,BETA,PDF)
        S0=1.0D0 + 1.0D0/(12.0D0*DS) + 1.0D0/(288.0D0*DS*DS)
        DMUS=(DMU-DS)/DSQRT(DS+2.0D0*DB)
        C=DSQRT(2.0D0*DB/DS)
        K=DSQRT(1.0D0 + 2.0D0*DB/DS)
        CALL NODPDF(DMUS,ZS)
        CALL NODCDF(DMUS,DTERM1)
C
        DTERM1=1.0D0-DTERM1
        DTERM1=DTERM1*(1.0D0 + 1.0D0/(12.0D0*DS))
C
        DNUM=(DMUS**2 + (6.0D0*DB/DS) + 2.0D0)*DS
        DDENOM=3.0D0*(DS+2.0D0*DB)**(3.0D0/2.0D0)
        DTERM2=(DNUM/DDENOM)*ZS
C
        DNUM=DMUS*(DS**2 + 6.0D0*DB*DS + 48.0D0*DB*DB)
        DDENOM=12.0D0*(DS+2.0D0*DB)**3
        DTERM3=(DNUM/DDENOM)*ZS
C
        DNUM=DMUS**3*(DS + 42.0D0*DB)*DS
        DDENOM=36.0D0*(DS+2.0D0*DB)**3
        DTERM4=(DNUM/DDENOM)*ZS
C
        DNUM=DMUS**5*DS*DS
        DDENOM=18.0D0*(DS+2.0D0*DB)**3
        DTERM5=(DNUM/DDENOM)*ZS
C
        DCDF=DTERM5 + DTERM4 + DTERM3 + DTERM2 + DTERM1
        DCDF=(1.0D0/S0)*DCDF
        GOTO9010
      ENDIF
C
 9010 CONTINUE
      CDF=REAL(DCDF)
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE HERPDF(X,ALPHA,BETA,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE AT THE SINGLE PRECISION VALUE X
C              FOR THE HERMITE DISTRIBUTION
C              WITH SINGLE PRECISION PARAMETERS ALPHA AND BETA.
C              THIS DISTRIBUTION IS DEFINED FOR ALL
C              NON-NEGATIVE INTEGERS.
C              THIS DISTRIBUTION HAS THE PROBABILITY FUNCTION
C                 F(X) = (ALPHA**X*H(BETA)/X!)*PR(X=0)
C              WITH H(X) DENOTING THE MODIFIED HERMITE POLYNOMIAL:
C                 H(BETA) = SUM[j=0 to INT(N/2)]
C                           [N!*X**(N-2*j)/((N-2(j)!j!2**j)]
C              THE FIRST FEW TERMS ARE:
C                 PR(X=0) = EXP[-ALPHA*BETA - ALPHA**2/2]
C                 PR(X=1) = ALPHA*BETA*PR(X=0)
C                 PR(X=2) = (ALPHA**2*(BETA**2+1)/2!)*PR(X=0)
C                 PR(X=3) = (ALPHA**3*(BETA**3+3*BETA)/3!)*PR(X=0)
C                 PR(X=4) = (ALPHA**4*(BETA**4+6*BETA**2+3)/4!)*PR(X=0)
C                 PR(X=5) = (ALPHA**5*(BETA**5+10*BETA**3+15*BETA)/5!)
C                           *PR(X=0)
C              
C                 PR(X=X+1) = (1/(X+1))*ALPHA*BETA*PR(X=x) +
C                             ALPHA**2*PR(X=x-1)
C
C              FOR X <= 10, THE ABOVE RECURRENCE RELATION WILL
C              BE USED.  FOR X > 10, AN AYMPTOTIC FORMULA DUE
C              TO Y. C. PATEL WILL BE USED.  NOTE THAT THE
C              PATEL ARTICLE USES:
C
C                 A = ALPHA*BETA
C                 B = ALPHA**2/2
C
C              IF YOU WANT TO OBTAIN APPROPRIATE VALUES OF
C              ALPHA AND BETA GIVEN A AND B, THEN
C
C                 ALPHA = SQRT(2*B)
C                 BETA  = A/SQRT(2*B)
C 
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE
C                                AT WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE INTEGRAL-VALUED,
C                                AND BETWEEN 0.0 (INCLUSIVELY)
C                                AND N (INCLUSIVELY).
C                     --ALPHA  = THE SINGLE PRECISION VALUE
C                                OF THE FIRST SHAPE PARAMETER.
C                     --BETA   = THE SINGLE PRECISION VALUE
C                                OF THE SECOND SHAPE PARAMETER.
C     OUTPUT ARGUMENTS--PDF    = THE SINGLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE PDF FOR THE HERMITE DISTRIBUTION
C             WITH SHAPE PARAMETERS ALPHA AND BETA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE INTEGRAL-VALUED AND NON-NEGATIVE
C                 --ALPHA AND BETA SHOULD BE POSITIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--DLNGAM, DGAMMA.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--DLOG, DEXP, DSQRT, DCOSH,
C                                         DSINH, DLOG10.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND KEMP, "UNIVARIATE DISCRETE
C                 DISTRIBUTIONS", SECOND EDITION, WILEY, 1992,
C                 PP. 357-364.
C               --Y. C. PATEL, "AN ASYMPTOTIC EXPRESSION FOR
C                 CUMULATIVE SUM OF PROBABILITIES OF THE HERMITE
C                 DISTRIBUTION", COMMUNICATIOS IN STATISTICS-
C                 THEORY AND METHODS, 14, PP. 2233-2241.
C               --KEMP AND KEMP, "SOME PROPERTIES OF THE HERMITE
C                 DISTRIBUTION", BIOMETRIKA, 1965, 52, 3 AND 4,
C                 P. 381
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           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               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--2004/4
C     ORIGINAL VERSION--APRIL     2004.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DALPHA
      DOUBLE PRECISION DBETA
      DOUBLE PRECISION DA
      DOUBLE PRECISION DB
      DOUBLE PRECISION DTERM1, DTERM2, DTERM3, DTERM4
      DOUBLE PRECISION DSUM
      DOUBLE PRECISION DPDF
      DOUBLE PRECISION DPDF0
      DOUBLE PRECISION DTHETA
      DOUBLE PRECISION DLNGAM
      DOUBLE PRECISION DGAMMA
      DOUBLE PRECISION DIS
      DOUBLE PRECISION DAA
      DOUBLE PRECISION BS
      DOUBLE PRECISION CS
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
      PDF=0.0
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(ALPHA.LE.0.0)THEN
        WRITE(ICOUT,11)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ALPHA
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ENDIF
      IF(BETA.LE.0.0)THEN
        WRITE(ICOUT,12)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)BETA
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ENDIF
      INTX=X+0.0001
      FINTX=INTX
      DEL=X-FINTX
      IF(DEL.LT.0.0)DEL=-DEL
      IF(DEL.GT.0.001)THEN
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,6)INT(FINTX)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
      ENDIF
      IF(FINTX.LT.0.0)THEN
        WRITE(ICOUT,4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
C
    4 FORMAT('***** FATAL ERROR--THE FIRST INPUT ',
     1'ARGUMENT TO THE HERPDF SUBROUTINE IS NEGATIVE.')
    5 FORMAT('***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ',
     1'ARGUMENT TO THE HERPDF SUBROUTINE IS NON-INTEGRAL *****')
    6 FORMAT('      IT HAS BEEN SET TO ',I8)
   11 FORMAT('***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE ',
     1' HERPDF SUBROUTINE IS NON-POSITIVE')
   12 FORMAT('***** FATAL ERROR--THE THIRD INPUT ARGUMENT TO THE ',
     1' HERPDF SUBROUTINE IS NON-POSITIVE')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
C
      DALPHA=DBLE(ALPHA)
      DBETA=DBLE(BETA)
      DB=DALPHA**2/2.0D0
      DA=DALPHA*DBETA
C
C  USE EXACT FORMULAS
C
CCCCC IF(INTX.LE.20)THEN
      IF(INTX.LE.10)THEN
        DPDF0=DEXP(-DALPHA*DBETA - DALPHA**2/2.0D0)
        IF(INTX.EQ.0)THEN
          DPDF=DPDF0
        ELSEIF(INTX.EQ.1)THEN
          DPDF=DALPHA*DBETA*DPDF0
        ELSEIF(INTX.EQ.2)THEN
          DTERM1=DALPHA**2*(DBETA*DBETA + 1.0D0)
          DPDF=(DTERM1/2.0D0)*DPDF0
        ELSEIF(INTX.EQ.3)THEN
          DTERM1=DALPHA**3*(DBETA**3 + 3.0D0*DBETA)
          DPDF=(DTERM1/6.0D0)*DPDF0
        ELSEIF(INTX.EQ.4)THEN
          DTERM1=DALPHA**4*(DBETA**4 + 6.0D0*DBETA**2 + 3.0D0)
          DPDF=(DTERM1/24.0D0)*DPDF0
        ELSEIF(INTX.EQ.5)THEN
          DTERM1=DALPHA**5*(DBETA**5 + 10.0D0*DBETA**3 + 15.0D0*DBETA)
          DPDF=(DTERM1/120.0D0)*DPDF0
        ELSEIF(INTX.GE.6)THEN
          DTERM1=DALPHA**4*(DBETA**4 + 6.0D0*DBETA**2 + 3.0D0)
          DTERM1=(DTERM1/24.0D0)*DPDF0
          DTERM2=DALPHA**5*(DBETA**5 + 10.0D0*DBETA**3 + 15.0D0*DBETA)
          DTERM2=(DTERM2/120.0D0)*DPDF0
          DO110I=6,INTX
            DPDF=(DALPHA*DBETA*DTERM2 + DALPHA*DALPHA*DTERM1)/DBLE(I)
            DTERM1=DTERM2
            DTERM2=DPDF
  110     CONTINUE
        ENDIF
        PDF=REAL(DPDF)
      ELSE
        IF(MOD(INTX,2).EQ.0)THEN
          IS=INTX/2
          DIS=DBLE(IS)
          DAA=DA*DA/(8.0D0*DB)
          BS=(4.0D0*DIS+1.0D0)
          DTERM1=DSQRT(DAA)*DSQRT(DAA+BS)
          DTERM2=BS*DLOG10(DSQRT(1.0D0+DAA/BS)+DSQRT(DAA/BS))
          DTHETA=DCOSH(DTERM1 + DTERM2)
          DTERM1=-(DA+DB+DAA)
          DTERM2=DIS*DLOG(DB) - DLNGAM(DBLE(IS+1))
          DTERM3=-0.25D0*DLOG(1.0D0 + DAA/BS)
          DTERM4=DLOG(DTHETA)
          DPDF=DTERM1 + DTERM2 + DTERM3 + DTERM4
          DPDF=DEXP(DPDF)
          PDF=REAL(DPDF)
        ELSE
          IS=(INTX-1)/2
          DIS=DBLE(IS)
          DAA=DA*DA/(8.0D0*DB)
          CS=(4.0D0*DIS+3.0D0)/2.0D0
          DTERM1=DSQRT(DAA)*DSQRT(DAA+CS)
          DTERM2=CS*DLOG(DSQRT(1.0D0+DAA/CS)+DSQRT(DAA/CS))
          DTHETA=DSINH(DTERM1 + DTERM2)
          DTERM1=-(DA+DB+DAA)
          DTERM2=DIS*DLOG(DB) + 0.5D0*DLOG(2.0D0*DB) -
     1           0.5D0*DLOG(CS) - DLNGAM(DBLE(IS+1))
          DTERM3=0.25D0*DLOG(1.0D0 + DAA/CS)
          DTERM4=DLOG(DTHETA)
          DPDF=DTERM1 + DTERM2 + DTERM3 + DTERM4
          DPDF=DEXP(DPDF)
          PDF=REAL(DPDF)
        ENDIF
C
C  USE ASYMPTOTIC APPROXIMATION
C
      ENDIF
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE HERPPF(P,ALPHA,BETA,PPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE AT THE SINGLE PRECISION VALUE P
C              FOR THE HERMITE DISTRIBUTION
C              WITH SINGLE PRECISION PARAMETERS ALPHA AND BETA.
C              THE FIRST 25 TERMS OF THE HERMITE CUMULATIVE
C              DISTRIBUTION WILL BE COMPUTED.  IF THE PERCENT
C              POINT IS NOT FOUND WITHIN THESE FIRST 25 TERMS,
C              A BISECTION METHOD WILL BE ATTEMPTED.
C     INPUT  ARGUMENTS--P      = THE SINGLE PRECISION VALUE
C                                (BETWEEN 0.0 (INCLUSIVELY)
C                                AND 1.0 (INCLUSIVELY))
C                                AT WHICH THE PERCENT POINT
C                                FUNCTION IS TO BE EVALUATED.
C                     --ALPHA  = THE SINGLE PRECISION VALUE
C                                OF THE FIRST SHAPE PARAMETER.
C                     --BETA   = THE SINGLE PRECISION VALUE
C                                OF THE SECOND SHAPE PARAMETER.
C                                N SHOULD BE A POSITIVE INTEGER.
C     OUTPUT ARGUMENTS--PPF    = THE SINGLE PRECISION PERCENT
C                                POINT FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PERCENT POINT  .
C             FUNCTION VALUE PPF
C             FOR THE HERMITE DISTRIBUTION
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--ALPHA AND BETA SHOULD BE POSITIVE.
C                 --P SHOULD BE BETWEEN 0.0 (INCLUSIVELY)
C                   AND 1.0 (INCLUSIVELY).
C     OTHER DATAPAC   SUBROUTINES NEEDED--HERCDF
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION AND DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND KEMP, "UNIVARIATE DISCRETE
C                 DISTRIBUTIONS", SECOND EDITION, WILEY, 1992,
C                 PP. 357-364.
C               --Y. C. PATEL, "AN ASYMPTOTIC EXPRESSION FOR
C                 CUMULATIVE SUM OF PROBABILITIES OF THE HERMITE
C                 DISTRIBUTION", COMMUNICATIOS IN STATISTICS-
C                 THEORY AND METHODS, 14, PP. 2233-2241.
C               --KEMP AND KEMP, "SOME PROPERTIES OF THE HERMITE
C                 DISTRIBUTION", BIOMETRIKA, 1965, 52, 3 AND 4,
C                 P. 381
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           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/4
C     ORIGINAL VERSION--APRIL     2004.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DALPHA
      DOUBLE PRECISION DBETA
      DOUBLE PRECISION DTERM1, DTERM2, DTERM3, DTERM4, DTERM5
      DOUBLE PRECISION DCDF
      DOUBLE PRECISION DPDF
      DOUBLE PRECISION DCDF0
      DOUBLE PRECISION DP
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(ALPHA.LE.0.0)THEN
        WRITE(ICOUT,11)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ALPHA
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9999
      ENDIF
      IF(BETA.LE.0.0)THEN
        WRITE(ICOUT,12)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)BETA
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9999
      ENDIF
    1 FORMAT('***** FATAL ERROR--THE FIRST INPUT ARGUMENT TO THE ',
     1' HERPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1] INTERVAL')
   11 FORMAT('***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE ',
     1' HERPPF SUBROUTINE IS NON-POSITIVE')
   12 FORMAT('***** FATAL ERROR--THE THIRD INPUT ARGUMENT TO THE ',
     1' HERPPF SUBROUTINE IS NON-POSITIVE')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
C
      PPF=0.0
C
C     TREAT CERTAIN SPECIAL CASES IMMEDIATELY--
C     1) P = 0.0
C
      IF(P.EQ.0.0)THEN
        PPF=0.0
        GOTO9999
      ENDIF
C
C     COMPUTE THE HERCDF, TERMINATE WHEN CDF IS GREATER THAN OR
C     EQUAL TO P.
C
      DP=DBLE(P)
      DALPHA=DBLE(ALPHA)
      DBETA=DBLE(BETA)
C
      DCDF0=DEXP(-DALPHA*DBETA - DALPHA**2/2.0D0)
      DCDF=DCDF0
      IF(DCDF.GE.DP)THEN
        PPF=0.0
        GOTO9999
      ENDIF
C
      DCDF=DCDF + DALPHA*DBETA*DCDF0
      IF(DCDF.GE.DP)THEN
        PPF=1.0
        GOTO9999
      ENDIF
C
      DTERM1=DALPHA**2*(DBETA*DBETA + 1.0D0)
      DCDF=DCDF + (DTERM1/2.0D0)*DCDF0
      IF(DCDF.GE.DP)THEN
        PPF=2.0
        GOTO9999
      ENDIF
C
      DTERM1=DALPHA**3*(DBETA**3 + 3.0D0*DBETA)
      DCDF=DCDF + (DTERM1/6.0D0)*DCDF0
      IF(DCDF.GE.DP)THEN
        PPF=3.0
        GOTO9999
      ENDIF
C
      DTERM1=DALPHA**4*(DBETA**4 + 6.0D0*DBETA**2 + 3.0D0)
      DCDF=DCDF + (DTERM1/24.0D0)*DCDF0
      IF(DCDF.GE.DP)THEN
        PPF=4.0
        GOTO9999
      ENDIF
C
      DTERM1=DALPHA**5*(DBETA**5 + 10.0D0*DBETA**3 + 15.0D0*DBETA)
      DCDF=DCDF + (DTERM1/120.0D0)*DCDF0
      IF(DCDF.GE.DP)THEN
        PPF=5.0
        GOTO9999
      ENDIF
C
      DTERM1=DALPHA**4*(DBETA**4 + 6.0D0*DBETA**2 + 3.0D0)
      DTERM1=(DTERM1/24.0D0)*DCDF0
      DTERM2=DALPHA**5*(DBETA**5 + 10.0D0*DBETA**3 + 15.0D0*DBETA)
      DTERM2=(DTERM2/120.0D0)*DCDF0
C
      DO110I=6,25
        DPDF=(DALPHA*DBETA*DTERM2 + DALPHA*DALPHA*DTERM1)/DBLE(I)
        DCDF=DCDF + DPDF
        IF(DCDF.GE.DP)THEN
          PPF=REAL(I)
          GOTO9999
        ENDIF
        DTERM1=DTERM2
        DTERM2=DPDF
  110 CONTINUE
      P0=REAL(DCDF)
C
C     IF PPF NOT FOUND IN FIRST 25 TERMS, SWITCH TO BISECTION METHOD.
C
      X0=25.0
      AMEAN=ALPHA*(ALPHA+BETA)
      ASD=SQRT(ALPHA*(2*ALPHA+BETA))
      ISD=INT(ASD)+1
C
C     DETERMINE AN UPPER BOUND BY ITERATING IN STEPS OF ONE SD.
C
      MAXIT=1000
      ICOUNT=0
  200 CONTINUE
        ICOUNT=ICOUNT+1
        IF(ICOUNT.GT.MAXIT)THEN
          WRITE(ICOUT,210)
  210     FORMAT('***** ERROR: UNABLE TO FIND UPPER BOUND IN ',
     1           'HERPPF.')
          CALL DPWRST('XXX','BUG ')
          PPF=0.0
          GOTO9999
        ENDIF
        X1=X0 + REAL(ISD)
        CALL HERCDF(X1,ALPHA,BETA,P1)
        IF(P1.LT.P)THEN
          X0=X1
          GOTO200
        ENDIF
C
C     THE STOPPING CRITERION IS THAT THE LOWER BOUND
C     AND UPPER BOUND ARE EXACTLY 1 UNIT APART.
C     CHECK TO SEE IF IX1 = IX0 + 1;
C     IF SO, THE ITERATIONS ARE COMPLETE;
C     IF NOT, THEN BISECT, COMPUTE PROBABILIIES,
C     CHECK PROBABILITIES, AND CONTINUE ITERATING
C     UNTIL IX1 = IX0 + 1.
      IX0=INT(X0+ 0.01)
      IX1=INT(X1+ 0.01)
C
  300 CONTINUE
      IXOP1=IX0+1
      IF(IX1.EQ.IXOP1)THEN
        PPF=REAL(IX1)
        IF(P0.EQ.P)PPF=REAL(IX0)
        GOTO9999
      ENDIF
      IX2=(IX0+IX1)/2
      IF(IX2.EQ.IX0 .OR. IX2.EQ.IX0)THEN
        WRITE(ICOUT,311)
  311   FORMAT('***** INTERNAL ERROR IN HERPPF  SUBROUTINE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,313)
  313   FORMAT('      BISECTION VALUE (X2) = LOWER BOUND (X0) OR ',
     1         'UPPER BOUND (X1)')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,315)X0,P0
  315   FORMAT('      X0  = ',F14.7,10X,'P0 = ',F14.7)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,317)X1,P1
  317   FORMAT('      X1  = ',F14.7,10X,'P1 = ',F14.7)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,319)X2,P2
  319   FORMAT('      X2  = ',F14.7,10X,'P2 = ',F14.7)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,321)P
  321   FORMAT('      P    = ',F14.7)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,323)ALPHA,BETA
  323   FORMAT('      ALPHA, BETA = ',F14.7,F14.7)
        CALL DPWRST('XXX','BUG ')
      ELSE
        X2=REAL(IX2)
        CALL HERCDF(X2,ALPHA,BETA,P2)
        IF(P0.LT.P2 .AND. P2.LT.P1)THEN
          IF(P2.LE.P)THEN
            IX0=IX2
            X0=REAL(IX0)
            P0=P2
          ELSE
            IX1=IX2
            X1=REAL(IX1)
            P1=P2
          ENDIF
          GOTO300
        ELSEIF(P2.LE.P0 .OR. P2.GE.P1)THEN
          WRITE(ICOUT,311)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,313)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,315)X0,P0
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,317)X1,P1
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,319)X2,P2
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,321)P
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,323)ALPHA,BETA
          CALL DPWRST('XXX','BUG ')
        ELSE
          WRITE(ICOUT,311)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,313)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,315)X0,P0
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,317)X1,P1
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,319)X2,P2
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,321)P
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,323)ALPHA,BETA
          CALL DPWRST('XXX','BUG ')
        ENDIF
      ENDIF 
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE HERRAN(ALPHA,BETA,N,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE HERMITE DISTRIBUTION
C              WITH SHAPE PARAMETERS ALPHA AND BETA.
C              THIS DISTRIBUTION IS DEFINED FOR ALL
C              NON-NEGATIVE X.
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --ALPHA  = THE SINGLE PRECISION VALUE
C                                OF THE FIRST SHAPE PARAMETER OF THE
C                                HERMITE DISTRIBUTION.
C                                ALPHA > 0.
C                     --BETA   = THE SINGLE PRECISION VALUE
C                                OF THE SECOND SHAPE PARAMETER OF THE
C                                HERMITE DISTRIBUTION.
C                                BETA > 0.
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST N)
C                                INTO WHICH THE GENERATED
C                                RANDOM SAMPLE WILL BE PLACED.
C     OUTPUT--A RANDOM SAMPLE OF SIZE N
C             FROM THE HERMITE DISTRIBUTION.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C                 --ALPHA, BETA > 0
C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN, GEORAN.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND KEMP, "UNIVARIATE DISCRETE
C                 DISTRIBUTIONS", SECOND EDITION, WILEY, 1992,
C                 PP. 357-364.
C               --Y. C. PATEL, "AN ASYMPTOTIC EXPRESSION FOR
C                 CUMULATIVE SUM OF PROBABILITIES OF THE HERMITE
C                 DISTRIBUTION", COMMUNICATIOS IN STATISTICS-
C                 THEORY AND METHODS, 14, PP. 2233-2241.
C               --KEMP AND KEMP, "SOME PROPERTIES OF THE HERMITE
C                 DISTRIBUTION", BIOMETRIKA, 1965, 52, 3 AND 4,
C                 P. 381
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2899
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           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               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--2004/4
C     ORIGINAL VERSION--APRIL     2004.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION G(2)
      DIMENSION X(*)
C
C---------------------------------------------------------------------
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(ALPHA.LE.0.0)THEN
        WRITE(ICOUT,11)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ALPHA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
      IF(BETA.LE.0.0)THEN
        WRITE(ICOUT,12)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)BETA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
    5 FORMAT('***** FATAL ERROR--NUMBER OF HERMITE RANDOM ',
     1'NUMBERS REQUESTED < 1')
   11 FORMAT('***** FATAL ERROR--THE ALPHA SHAPE PARAMETER ARGUMENT',
     1' TO THE HERRAN SUBROUTINE IS <= 0')
   12 FORMAT('***** FATAL ERROR--THE BETA SHAPE PARAMETER ARGUMENT',
     1' TO THE HERRAN SUBROUTINE IS <= 0')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
C
C     ALGORITHM BASED ON FACT THAT HERMITE DISTRIBUTION IS
C
C          X1 + 2*X2
C
C     WHERE X1 AND X2 ARE INDPENDENT POISSON RANDOM VARIABLES
C     WITH SHAPE PARAMETERS ALPHA*BETA AND ALPHA**2/2, RESPECTIVELY.
C
      A1=ALPHA*BETA
      A2=ALPHA*ALPHA/2.0
      NTEMP=1
C
      DO100I=1,N
        CALL POIRAN(NTEMP,A1,ISEED,G(1))
        CALL POIRAN(NTEMP,A2,ISEED,G(2))
        X(I)=G(1) + 2.0*G(2)
  100 CONTINUE
C
 9000 CONTINUE
      RETURN
C
      END
      SUBROUTINE HESS(PNRFUN,X,N,SCL,STPSZ,FNBR,H)
C
C *   AUTHORS: Necip Doganaksoy and Wayne Nelson
C *   PURPOSE: Maximum likelihood fitting of the power-normal and
C *            -lognormal models to censored life or strength data
C *            from specimens of various sizes
C *   DOCUMENTATION: Wayne Nelson and Necip Doganaksoy, "A Computer
C *                  Program POWNOR for Fitting the Power-Normal and
C *                  -Lognormal Models to Life or Strength Data from
C *                  Specimens of Various Sizes", NISTIR 4760, 3/1992.
C *   PROJECT: 1990-91 ASA/NIST/NSF Fellowship
C
C     Declarations
C

      IMPLICIT DOUBLE PRECISION (a-h,o-z)
C
      DOUBLE PRECISION X(N),SCL(N),STPSZ(N),FNBR(N),H(N,N)
      DOUBLE PRECISION MACHEP
      DOUBLE PRECISION FNVAL
C
      REAL R1MACH
      INCLUDE 'DPCOMC.INC'
C
      EXTERNAL PNRFUN
C
C     End declarations
C
      MACHEP = D1MACH(4)
      FC = PNRFUN(X,N)
      C = MACHEP**(1.0D0/3.0D0)
C
C     Calculate stepsize and updated function value
C
      DO 10 i = 1,n
          stpsz(i) = dmax1(dabs(x(i)),1.0d0/scl(i))
          stpsz(i) = stpsz(i)*c*dsign(1.0d0,x(i))
          tempi = x(i)
          x(i) = x(i) + stpsz(i)
          stpsz(i) = x(i) - tempi
          FNBR(I) = PNRFUN(X,N)
          x(i) = tempi
   10 CONTINUE
      DO 30 i = 1,n
C
C     Calculate Hessian
C
C
C     Calculate Diagonal Elements
C
          tempi = x(i)
          x(i) = x(i) + 2.0d0*stpsz(i)
          fii=pnrfun(x,n)
          h(i,i) = ((fc-fnbr(i))+ (fii-fnbr(i)))/ (stpsz(i)*stpsz(i))
          x(i) = tempi + stpsz(i)
          DO 20 j = i + 1,n
C
C     Calculate Off-Diagonal Elements
C
              tempj = x(j)
              x(j) = x(j) + stpsz(j)
              fij=pnrfun(x,n)
              h(i,j) = ((fc-fnbr(i))+ (fij-fnbr(j)))/
     +                 (stpsz(i)*stpsz(j))
              h(j,i) = h(i,j)
              x(j) = tempj
   20     CONTINUE
          x(i) = tempi
   30 CONTINUE
C
      RETURN
      END
      SUBROUTINE HFCCDF(X,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE HALF-CAUCHY DISTRIBUTION
C              THIS DISTRIBUTION IS DEFINED FOR ALL NON-NEGATIVE X
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C              F(X) = (2/PI)/(1+x**2)
C              THE HALF-CAUCHY DISTRIBUTION USED HEREIN
C              IS THE DISTRIBUTION OF THE VARIATE X = ABS(Z) WHERE
C              THE VARIATE Z IS CAUCHY DISTRIBUTED
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE 
C                                AT WHICH THE CUMULATIVE DISTRIBUTION 
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE NON-NEGATIVE.
C     OUTPUT ARGUMENTS--CDF    = THE SINGLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE CDF FOR THE HALF-CAUCHY DISTRIBUTION
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 
C     RESTRICTIONS--X SHOULD BE NON-NEGATIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--CAUCDF. 
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN. 
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1994, PAGE 328
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE:  301-975-2855
C     ORIGINAL VERSION--OCTOBER   1995. 
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
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(X.LT.0.0)GOTO50
      GOTO90
   50 CONTINUE
      WRITE(ICOUT,4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,5)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)X
      CALL DPWRST('XXX','BUG ')
      CDF=0.0
      RETURN
   90 CONTINUE
    4 FORMAT('***** NON-FATAL DIAGNOSTIC--THE FIRST  INPUT ARGUMENT')
    5 FORMAT('      TO THE HFCCDF SUBROUTINE IS NEGATIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
C-----START POINT-----------------------------------------------------
C
      CALL CAUCDF(X,CDF)
      CDF=2.0*CDF-1.0
C
      RETURN
      END 
      SUBROUTINE HFCPDF(X,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE HALF-CAUCHY DISTRIBUTION.
C              THIS DISTRIBUTION IS DEFINED FOR ALL NON-NEGATIVE X
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C              F(X) = (2/PI)/(1+x**2)
C              THE HALF-CAUCHY DISTRIBUTION USED HEREIN
C              IS THE DISTRIBUTION OF THE VARIATE X = ABS(Z) WHERE
C              THE VARIATE Z IS CAUCHY DISTRIBUTED
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE 
C                                AT WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE NON-NEGATIVE.
C     OUTPUT ARGUMENTS--PDF    = THE SINGLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE PDF FOR THE HALF-CAUCHY
C             DISTRIBUTION
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 
C     RESTRICTIONS--X SHOULD BE NON-NEGATIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--CAUPDF. 
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN. 
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1994, PAGE 328
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE:  301-975-2855
C     ORIGINAL VERSION--OCTOBER   1995. 
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
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(X.LT.0.0)GOTO50
      GOTO90
   50 CONTINUE
      WRITE(ICOUT,4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,5)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)X
      CALL DPWRST('XXX','BUG ')
      PDF=0.0
      RETURN
   90 CONTINUE
    4 FORMAT('***** NON-FATAL DIAGNOSTIC--THE FIRST  INPUT ARGUMENT')
    5 FORMAT('      TO THE HFCPDF SUBROUTINE IS NEGATIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
C-----START POINT-----------------------------------------------------
C
      CALL CAUPDF(X,PDF)
      PDF=2.0*PDF
C
      RETURN
      END 
      SUBROUTINE HFCPPF(P,PPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE HALF-CAUCHY DISTRIBUTION
C              THIS DISTRIBUTION IS DEFINED FOR ALL NON-NEGATIVE X
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C              F(X) = (2/PI)/(1+X**2)
C              THE HALF-CAUCHY DISTRIBUTION USED HEREIN
C              IS THE DISTRIBUTION OF THE VARIATE X = ABS(Z) WHERE
C              THE VARIATE Z IS CAUCHY DISTRIBUTED
C              NOTE THAT THE PERCENT POINT FUNCTION OF A DISTRIBUTION
C              IS IDENTICALLY THE SAME AS THE INVERSE CUMULATIVE
C              DISTRIBUTION FUNCTION OF THE DISTRIBUTION.
C     INPUT  ARGUMENTS--P      = THE SINGLE PRECISION VALUE
C                                (BETWEEN 0.0 (INCLUSIVELY)
C                                AND 1.0 (EXCLUSIVELY))
C                                AT WHICH THE PERCENT POINT
C                                FUNCTION IS TO BE EVALUATED.
C     OUTPUT ARGUMENTS--PPF    = THE SINGLE PRECISION PERCENT
C                                POINT FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PERCENT POINT FUNCTION .
C             VALUE PPF FOR THE HALF-CAUCHY DISTRIBUTION
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--P SHOULD BE BETWEEN 0.0 (INCLUSIVELY)
C                   AND 1.0 (EXCLUSIVELY).
C     OTHER DATAPAC   SUBROUTINES NEEDED--CAUPPF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1994, PAGE 328
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           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/10
C     ORIGINAL VERSION--OCTOBER   1995.
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
      GOTO90
   50 WRITE(ICOUT,1)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)P
      CALL DPWRST('XXX','BUG ')
      PPF=0.0
      RETURN
   90 CONTINUE
    1 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ',
     1'HFCPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
      ARG=(1.0+P)/2.0
      CALL CAUPPF(ARG,PPF)
      IF(PPF.LE.0.0)PPF=0.0
C
      RETURN
      END
      SUBROUTINE HFCRAN(N,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE HALF-CAUCHY DISTRIBUTION
C              WITH MEDIAN = 0 AND 75% POINT = 1.
C              THIS DISTRIBUTION IS DEFINED FOR ALL X AND HAS
C              THE PROBABILITY DENSITY FUNCTION
C              F(X) = (2/PI)*(1/(1+X*X)).
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST N)
C                                INTO WHICH THE GENERATED
C                                RANDOM SAMPLE WILL BE PLACED.
C     OUTPUT--A RANDOM SAMPLE OF SIZE N
C             FUNCTION VALUE FOR THE HALF-CAUCHY DISTRIBUTION
C             WITH MEDIAN = 0 AND 75% POINT = 1.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--SIN, COS.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--TOCHER, THE ART OF SIMULATION,
C                 1963, PAGE 15.
C               --HAMMERSLEY AND HANDSCOMB, MONTE CARLO METHODS,
C                 1964, PAGE 36.
C               --FILLIBEN, SIMPLE AND ROBUST LINEAR ESTIMATION
C                 OF THE LOCATION PARAMETER OF A SYMMETRIC
C                 DISTRIBUTION (UNPUBLISHED PH.D. DISSERTATION,
C                 PRINCETON UNIVERSITY), 1969, PAGE 231.
C               --FILLIBEN, 'THE PERCENT POINT FUNCTION',
C                 (UNPUBLISHED MANUSCRIPT), 1970, PAGES 28-31.
C               --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1970, PAGES 154-165.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           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/10
C     ORIGINAL VERSION--OCTOBER   1995.
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-----DATA STATEMENTS-------------------------------------------------
C
      DATA PI/3.14159265359/
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)GOTO50
      GOTO90
   50 WRITE(ICOUT, 5)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,47)N
      CALL DPWRST('XXX','BUG ')
      RETURN
   90 CONTINUE
    5 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ',
     1'HFCRAN SUBROUTINE IS NON-POSITIVE *****')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8   ,' *****')
C
C     GENERATE N UNIFORM (0,1) RANDOM NUMBERS;
C
      CALL UNIRAN(N,ISEED,X)
C
C     GENERATE N CAUCHY RANDOM NUMBERS
C     USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD.
C
      DO100I=1,N
      ARG=PI*X(I)
      X(I)=-COS(ARG)/SIN(ARG)
  100 CONTINUE
C
C
C     GENERATE N HALF-CAUCHY RANDOM NUMBERS
C     USING THE DEFINITION THAT
C     A HALF-CAUCHY VARIATE
C     EQUALS THE ABSOLUTE VALUE OF A CAUCHY VARIATE.
C
      DO400I=1,N
      IF(X(I).LT.0.0)X(I)=-X(I)
  400 CONTINUE
C
      RETURN
      END
      SUBROUTINE HFLCDF(X,GAMMA,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE HALF-LOGISTIC DISTRIBUTION.
C              THIS DISTRIBUTION IS DEFINED FOR ALL NON-NEGATIVE X
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C              F(X) = 2*EXP(-X)/(1+EXP(-X))**2    X>=0
C              THE HALF-LOGISTIC DISTRIBUTION USED HEREIN
C              IS THE DISTRIBUTION OF THE VARIATE X = ABS(Z) WHERE
C              THE VARIATE Z IS LOGISTICALLY DISTRIBUTED
C              IF GAMMA IS POSITIVE, THE GENERALIZED HALF-LOGISTIC
C              DISTRIBUTION IS COMPUTED.  THIS HAS THE PDF:
C              F(X) = 2*(1-K*X)**((1/K)-1)/(1+(1-K*X)**(1/K))**2  
C                                                     0<=X<=1/K
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE 
C                                AT WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE NON-NEGATIVE.
C     OUTPUT ARGUMENTS--CDF    = THE SINGLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE CDF FOR THE HALF-LOGISTIC
C             DISTRIBUTION
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 
C     RESTRICTIONS--X SHOULD BE NON-NEGATIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--CAUCDF. 
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN. 
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--2, 1994, PAGES 150-151
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE:  301-975-2855
C     ORIGINAL VERSION--OCTOBER   1995. 
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX, DG, DCDF
      DOUBLE PRECISION DTERM1, DTERM2, DTERM3
C
      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(GAMMA.GT.10.0)THEN
          WRITE(ICOUT,24)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,25)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,46)GAMMA
          CALL DPWRST('XXX','BUG ')
          CDF=0.0
          GOTO9999
      ENDIF
      IF(GAMMA.LE.0.0)THEN
        IF(X.LT.0.0)THEN
          WRITE(ICOUT,4)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,5)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,46)X
          CALL DPWRST('XXX','BUG ')
          CDF=0.0
          GOTO9999
        ENDIF
      ELSE
        ARG1=1./GAMMA
        IF(X.LT.0.0.OR.X.GT.ARG1)THEN
          WRITE(ICOUT,14)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,15)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,46)X
          CALL DPWRST('XXX','BUG ')
          CDF=0.0
          GOTO9999
        ENDIF
      ENDIF
   90 CONTINUE
    4 FORMAT('***** NON-FATAL DIAGNOSTIC--THE FIRST  INPUT ARGUMENT ',
     *       'TO THE HFLCDF SUBROUTINE')
    5 FORMAT('      IS NEGATIVE. *****')
   14 FORMAT('***** NON-FATAL DIAGNOSTIC--THE FIRST  INPUT ARGUMENT ',
     *       'TO THE HFLCDF SUBROUTINE')
   15 FORMAT('      IS OUTSIDE THE (0,1/GAMMA) INTERVAL. *****')
   24 FORMAT('***** FATAL DIAGNOSTIC--THE SECOND INPUT ARGUMENT ',
     *       'TO THE HFLCDF SUBROUTINE')
   25 FORMAT('      IS GREATER THAN 10. *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
C-----START POINT-----------------------------------------------------
C
      IF(X.EQ.0.)THEN
        CDF=0.0
        GOTO9999
      ELSEIF(GAMMA.GT.0.0.AND.X.GE.1.0/GAMMA)THEN
        CDF=1.0
        GOTO9999
      ENDIF
C
      DX=DBLE(X)
      DG=DBLE(GAMMA)
      IF(GAMMA.LE.0.0)THEN
        DTERM1=DLOG(1.D0-DEXP(-DX))
        DTERM2=DLOG(1.D0+DEXP(-DX))
        DTERM3=DTERM1-DTERM2
        IF(DTERM3.LE.-500.D0)THEN
          CDF=0.0
        ELSEIF(DTERM3.GE.500.D0)THEN
          CDF=1.0
        ELSE
          DCDF=DEXP(DTERM3)
          CDF=SNGL(DCDF)
        ENDIF
      ELSE
        DTERM1=DLOG(1.D0-(1.D0-DG*DX)**(1.D0/DG))
        DTERM2=DLOG(1.D0+(1.D0-DG*DX)**(1.D0/DG))
        DTERM3=DTERM1-DTERM2
        IF(DTERM3.LE.-500.D0)THEN
          CDF=0.0
        ELSEIF(DTERM3.GE.500.D0)THEN
          CDF=1.0
        ELSE
          DCDF=DEXP(DTERM3)
          CDF=SNGL(DCDF)
        ENDIF
      ENDIF
C
 9999 CONTINUE
      RETURN
      END 
      SUBROUTINE HFLPDF(X,GAMMA,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE HALF-LOGISTIC DISTRIBUTION.
C              THIS DISTRIBUTION IS DEFINED FOR ALL NON-NEGATIVE X
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C              F(X) = 2*EXP(-X)/(1+EXP(-X))**2    X>=0
C              THE HALF-LOGISTIC DISTRIBUTION USED HEREIN
C              IS THE DISTRIBUTION OF THE VARIATE X = ABS(Z) WHERE
C              THE VARIATE Z IS LOGISTIC DISTRIBUTED
C              IF GAMMA IS POSITIVE, THE GENERALIZED HALF-LOGISTIC
C              DISTRIBUTION IS COMPUTED.  THIS HAS THE PDF:
C              F(X) = 2*(1-K*X)**((1/K)-1)/(1+(1-K*X)**(1/K))**2  
C                                                     0<=X<=1/K
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE 
C                                AT WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE NON-NEGATIVE.
C     OUTPUT ARGUMENTS--PDF    = THE SINGLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE PDF FOR THE HALF-LOGISTIC
C             DISTRIBUTION
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 
C     RESTRICTIONS--X SHOULD BE NON-NEGATIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--CAUPDF. 
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN. 
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--2, 1994, PAGES 150-151
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE:  301-975-2855
C     ORIGINAL VERSION--OCTOBER   1995. 
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX, DG, DPDF
      DOUBLE PRECISION DTERM1, DTERM2, DTERM3, DTERM4
C
      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(GAMMA.GT.10.0)THEN
          WRITE(ICOUT,24)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,25)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,46)GAMMA
          CALL DPWRST('XXX','BUG ')
          CDF=0.0
          GOTO9999
      ENDIF
      IF(GAMMA.LE.0.0)THEN
        IF(X.LT.0.0)THEN
          WRITE(ICOUT,4)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,5)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,46)X
          CALL DPWRST('XXX','BUG ')
          PDF=0.0
          GOTO9999
        ENDIF
      ELSE
        ARG1=1./GAMMA
        IF(X.LT.0.0.OR.X.GT.ARG1)THEN
          WRITE(ICOUT,14)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,15)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,46)X
          CALL DPWRST('XXX','BUG ')
          PDF=0.0
          GOTO9999
        ENDIF
      ENDIF
   90 CONTINUE
    4 FORMAT('***** NON-FATAL DIAGNOSTIC--THE FIRST  INPUT ARGUMENT ',
     *       'TO THE HFLPDF SUBROUTINE')
    5 FORMAT('      IS NEGATIVE. *****')
   14 FORMAT('***** NON-FATAL DIAGNOSTIC--THE FIRST  INPUT ARGUMENT ',
     *       'TO THE HFLPDF SUBROUTINE')
   15 FORMAT('      IS OUTSIDE THE (0,1/GAMMA) INTERVAL. *****')
   24 FORMAT('***** FATAL DIAGNOSTIC--THE SECOND INPUT ARGUMENT ',
     *       'TO THE HFLCDF SUBROUTINE')
   25 FORMAT('      IS GREATER THAN 10. *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
C-----START POINT-----------------------------------------------------
C
      IF(GAMMA.LE.0.0)THEN
        CALL LOGPDF(X,PDF)
        PDF=2.0*PDF
      ELSE
        DX=DBLE(X)
        IF(X.GE.1.0/GAMMA)THEN
          IF(GAMMA.LT.1.0)THEN
            PDF=0.0
            GOTO9999
          ELSEIF(GAMMA.EQ.1.0)THEN
            PDF=2.0
            GOTO9999
          ELSE
            DX=DX-0.000000001D0
          ENDIF
        ENDIF
        DG=DBLE(GAMMA)
        DTERM1=DLOG(2.0D0)
        DTERM2=((1.D0/DG)-1.D0)*DLOG(1.D0-DG*DX)
        DTERM3=2.D0*DLOG(1.D0+(1.D0-DG*DX)**(1.D0/DG))
        DTERM4=DTERM1+DTERM2-DTERM3
        IF(DABS(DTERM4).GE.40.D0)THEN
          PDF=0.0
        ELSE
          DPDF=DEXP(DTERM4)
          PDF=SNGL(DPDF)
        ENDIF
      ENDIF
C
 9999 CONTINUE
      RETURN
      END 
      SUBROUTINE HFLPPF(P,GAMMA,PPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE HALF-LOGISTIC DISTRIBUTION.
C              THIS DISTRIBUTION IS DEFINED FOR ALL NON-NEGATIVE X
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C              F(X) = 2*EXP(-X)/(1+EXP(-X))**2    X>=0
C              THE HALF-LOGISTIC DISTRIBUTION USED HEREIN
C              IS THE DISTRIBUTION OF THE VARIATE X = ABS(Z) WHERE
C              THE VARIATE Z IS LOGISTIC DISTRIBUTED
C              IF GAMMA IS POSITIVE, THE GENERALIZED HALF-LOGISTIC
C              DISTRIBUTION IS COMPUTED.  THIS HAS THE PDF:
C              F(X) = 2*(1-K*X)**((1/K)-1)/(1+(1-K*X)**(1/K))**2  
C                                                     0<=X<=1/K
C
C              FOR THE HALF-LOGISTIC, THE PPF FUNCTION IS:
C
C                 G(P) = -LOG((P-1)/(P+1))
C
C              FOR THE GENERALIZED HALF-LOGISTIC, THE PPF
C              FUNCTION IS:
C
C                 G(P,GAMMA) = (1 - ((1-P)/(1+P))**GAMMA)/GAMMA
C
C
C     INPUT  ARGUMENTS--P      = THE SINGLE PRECISION VALUE
C                                (BETWEEN 0.0 (INCLUSIVELY)
C                                AND 1.0 (EXCLUSIVELY))
C                                AT WHICH THE PERCENT POINT
C                                FUNCTION IS TO BE EVALUATED.
C     OUTPUT ARGUMENTS--PPF    = THE SINGLE PRECISION PERCENT
C                                POINT FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PERCENT POINT FUNCTION .
C             VALUE PPF FOR THE HALF-LOGISTIC DISTRIBUTION
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--P SHOULD BE BETWEEN 0.0 (INCLUSIVELY)
C                   AND 1.0 (EXCLUSIVELY).
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--2, 1994, PAGES 150-151
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           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/10
C     ORIGINAL VERSION--OCTOBER   1995.
C     UPDATED         --JANUARY   2005. REPLACE NUMERICAL INVERSION
C                                       WITH EXPLICIT FORMULAS
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DP
      DOUBLE PRECISION DPPF
      DOUBLE PRECISION DG
C
      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.GT.10.0)THEN
          WRITE(ICOUT,24)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,25)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,46)GAMMA
          CALL DPWRST('XXX','BUG ')
          CDF=0.0
          GOTO9999
      ENDIF
      IF(GAMMA.LE.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.LT.0.0.OR.P.GT.1.0)THEN
          WRITE(ICOUT,1)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,46)P
          CALL DPWRST('XXX','BUG ')
          PPF=0.0
          GOTO9999
        ENDIF
      ENDIF
    1 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO THE ',
     1'HFLPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL')
   24 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT ',
     *       'TO THE HFLCDF SUBROUTINE')
   25 FORMAT('      IS GREATER THAN 10. *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
C  STANDARD HALF-LOGISTIC CASE.  HAVE TO BOUND TO THE RIGHT.
C
      IF(P.EQ.0.0)THEN
        PPF=0.
        GOTO9999
      ENDIF
C
      DP=DBLE(P)
      DG=DBLE(GAMMA)
C
      IF(GAMMA.LE.0.0)THEN
        DPPF=-DLOG((1.0D0-DP)/(1.0D0+DP))
      ELSE
        IF(P.EQ.1.0)THEN
          DPPF=1.0D0/DG
        ELSE
          DPPF=(1.0D0 - ((1.0D0-DP)/(1.0D0+DP))**DG)/DG
        ENDIF
      ENDIF
      PPF=REAL(DPPF)
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE HFLRAN(N,GAMMA,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE HALF-LOGISTIC DISTRIBUTION
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST N)
C                                INTO WHICH THE GENERATED
C                                RANDOM SAMPLE WILL BE PLACED.
C     OUTPUT--A RANDOM SAMPLE OF SIZE N
C             FROM THE HALF-LOGISTIC DISTRIBUTION
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           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               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--2001/10
C     ORIGINAL VERSION--OCTOBER   2001.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
C
C---------------------------------------------------------------------
C
      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)GOTO50
      GOTO90
   50 WRITE(ICOUT, 5)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,47)N
      CALL DPWRST('XXX','BUG ')
      RETURN
   90 CONTINUE
    5 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ',
     1'HFLRAN 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 HALF-LOGISTIC RANDOM NUMBERS
C     USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD
C     AND THE FACT THAT THE HALF-LOGISTIC RANDOM NUMBER IS DEFINED
C     TO BE THE ABSOLUTE VALUE OF LOGISTIC RANDOM NUMBER.
C
      DO100I=1,N
      CALL HFLPPF(X(I),GAMMA,XTEMP)
      X(I)=XTEMP
  100 CONTINUE
C
      RETURN
      END
      SUBROUTINE HFNCDF(X,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE HALFNORMAL
C              DISTRIBUTION.
C              THE HALFNORMAL DISTRIBUTION USED
C              HEREIN HAS MEAN = SQRT(2/PI) = 0.79788456
C              AND STANDARD DEVIATION = 1.
C              THIS DISTRIBUTION IS DEFINED FOR ALL NON-NEGATIVE X
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C              F(X) = (2/SQRT(2*PI)) * EXP(-X*X/2).
C              THE HALFNORMAL DISTRIBUTION USED HEREIN
C              IS THE DISTRIBUTION OF THE VARIATE X = ABS(Z) WHERE
C              THE VARIATE Z IS NORMALLY DISTRIBUTED
C              WITH MEAN = 0 AND STANDARD DEVIATION = 1.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE 
C                                AT WHICH THE CUMULATIVE DISTRIBUTION 
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE NON-NEGATIVE.
C     OUTPUT ARGUMENTS--CDF    = THE SINGLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE CDF FOR THE HALFNORMAL
C             DISTRIBUTION WITH MEAN = SQRT(2/PI) = 0.79788456
C             AND STANDARD DEVIATION = 1.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 
C     RESTRICTIONS--X SHOULD BE NON-NEGATIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NORCDF. 
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN. 
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1970, PAGES 53, 59, 81, 83.
C               --DANIEL, 'USE OF HALF-NORMAL PLOTS IN
C                 INTERPRETING FACTORIAL TWO-LEVEL EXPERIMENTS',
C                 TECHNOMETRICS, 1959, PAGES 311-341.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE:  301-921-2315
C     ORIGINAL VERSION--APRIL     1994. 
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      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(X.LT.0.0)GOTO50
      GOTO90
   50 CONTINUE
      WRITE(ICOUT,4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,5)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)X
      CALL DPWRST('XXX','BUG ')
      CDF=0.0
      RETURN
   90 CONTINUE
    4 FORMAT('***** NON-FATAL DIAGNOSTIC--THE FIRST  INPUT ARGUMENT')
    5 FORMAT('      TO THE HFNCDF SUBROUTINE IS NEGATIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
C-----START POINT-----------------------------------------------------
C
      CALL NORCDF(X,CDF)
      CDF=2.0*CDF-1.0
C
      RETURN
      END 
      SUBROUTINE HFNPDF(X,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE HALFNORMAL DISTRIBUTION.
C              THE HALFNORMAL DISTRIBUTION USED
C              HEREIN HAS MEAN = SQRT(2/PI) = 0.79788456
C              AND STANDARD DEVIATION = 1.
C              THIS DISTRIBUTION IS DEFINED FOR ALL NON-NEGATIVE X
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C              F(X) = (2/SQRT(2*PI)) * EXP(-X*X/2).
C              THE HALFNORMAL DISTRIBUTION USED HEREIN
C              IS THE DISTRIBUTION OF THE VARIATE X = ABS(Z) WHERE
C              THE VARIATE Z IS NORMALLY DISTRIBUTED
C              WITH MEAN = 0 AND STANDARD DEVIATION = 1.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE 
C                                AT WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE NON-NEGATIVE.
C     OUTPUT ARGUMENTS--PDF    = THE SINGLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE PDF FOR THE HALFNORMAL
C             DISTRIBUTION WITH MEAN = SQRT(2/PI) = 0.79788456
C             AND STANDARD DEVIATION = 1.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 
C     RESTRICTIONS--X SHOULD BE NON-NEGATIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NORPDF. 
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN. 
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1970, PAGES 53, 59, 81, 83.
C               --DANIEL, 'USE OF HALF-NORMAL PLOTS IN
C                 INTERPRETING FACTORIAL TWO-LEVEL EXPERIMENTS',
C                 TECHNOMETRICS, 1959, PAGES 311-341.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE:  301-921-2315
C     ORIGINAL VERSION--APRIL     1994. 
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      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(X.LT.0.0)GOTO50
      GOTO90
   50 CONTINUE
      WRITE(ICOUT,4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,5)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)X
      CALL DPWRST('XXX','BUG ')
      PDF=0.0
      RETURN
   90 CONTINUE
    4 FORMAT('***** NON-FATAL DIAGNOSTIC--THE FIRST  INPUT ARGUMENT')
    5 FORMAT('      TO THE HFNPDF SUBROUTINE IS NEGATIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
C-----START POINT-----------------------------------------------------
C
      CALL NORPDF(X,PDF)
      PDF=2.0*PDF
C
      RETURN
      END 
      SUBROUTINE HFNPPF(P,PPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE HALFNORMAL
C              DISTRIBUTION.
C              THE HALFNORMAL DISTRIBUTION USED
C              HEREIN HAS MEAN = SQRT(2/PI) = 0.79788456
C              AND STANDARD DEVIATION = 1.
C              THIS DISTRIBUTION IS DEFINED FOR ALL NON-NEGATIVE X
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C              F(X) = (2/SQRT(2*PI)) * EXP(-X*X/2).
C              THE HALFNORMAL DISTRIBUTION USED HEREIN
C              IS THE DISTRIBUTION OF THE VARIATE X = ABS(Z) WHERE
C              THE VARIATE Z IS NORMALLY DISTRIBUTED
C              WITH MEAN = 0 AND STANDARD DEVIATION = 1.
C              NOTE THAT THE PERCENT POINT FUNCTION OF A DISTRIBUTION
C              IS IDENTICALLY THE SAME AS THE INVERSE CUMULATIVE
C              DISTRIBUTION FUNCTION OF THE DISTRIBUTION.
C     INPUT  ARGUMENTS--P      = THE SINGLE PRECISION VALUE
C                                (BETWEEN 0.0 (INCLUSIVELY)
C                                AND 1.0 (EXCLUSIVELY))
C                                AT WHICH THE PERCENT POINT
C                                FUNCTION IS TO BE EVALUATED.
C     OUTPUT ARGUMENTS--PPF    = THE SINGLE PRECISION PERCENT
C                                POINT FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PERCENT POINT FUNCTION .
C             VALUE PPF FOR THE HALFNORMAL DISTRIBUTION
C             WITH MEAN = SQRT(2/PI) = 0.79788456
C             AND STANDARD DEVIATION = 1.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--P SHOULD BE BETWEEN 0.0 (INCLUSIVELY)
C                   AND 1.0 (EXCLUSIVELY).
C     OTHER DATAPAC   SUBROUTINES NEEDED--NORPPF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1970, PAGES 53, 59, 81, 83.
C               --DANIEL, 'USE OF HALF-NORMAL PLOTS IN
C                 INTERPRETING FACTORIAL TWO-LEVEL EXPERIMENTS',
C                 TECHNOMETRICS, 1959, PAGES 311-341.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           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         --OCTOBER   1976.
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
      GOTO90
   50 WRITE(ICOUT,1)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)P
      CALL DPWRST('XXX','BUG ')
      PPF=0.0
      RETURN
   90 CONTINUE
    1 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ',
     1'HFNPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
      ARG=(1.0+P)/2.0
      CALL NORPPF(ARG,PPF)
      IF(PPF.LE.0.0)PPF=0.0
C
      RETURN
      END
      SUBROUTINE HFNRAN(N,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE HALFNORMAL DISTRIBUTION.
C              THE PROTOTYPE HALFNORMAL DISTRIBUTION USED
C              HEREIN HAS MEAN = SQRT(2/PI) = 0.79788456
C              AND STANDARD DEVIATION = 1.
C              THIS DISTRIBUTION IS DEFINED FOR ALL NON-NEGATIVE X
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C              F(X) = (2/SQRT(2*PI)) * EXP(-X*X/2).
C              THE PROTOTYPE HALFNORMAL DISTRIBUTION USED HEREIN
C              IS THE DISTRIBUTION OF THE VARIATE X = ABS(Z) WHERE
C              THE VARIATE Z IS NORMALLY DISTRIBUTED
C              WITH MEAN = 0 AND STANDARD DEVIATION = 1.
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST N)
C                                INTO WHICH THE GENERATED
C                                RANDOM SAMPLE WILL BE PLACED.
C     OUTPUT--A RANDOM SAMPLE OF SIZE N
C             FROM THE HALFNORMAL DISTRIBUTION
C              WITH MEAN = SQRT(2/PI) = 0.79788456
C              AND STANDARD DEVIATION = 1.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--ALOG, SQRT, SIN, COS.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--TOCHER, THE ART OF SIMULATION,
C                 1963, PAGES 14-15.
C               --HAMMERSLEY AND HANDSCOMB, MONTE CARLO METHODS,
C                 1964, PAGE 36.
C               --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1970, PAGES 53, 59, 81, 83.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           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         --JULY      1976.
C     UPDATED         --DECEMBER  1981.
C     UPDATED         --MAY       1982.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
      DIMENSION Y(2)
C
C---------------------------------------------------------------------
C
      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 PI/3.14159265359/
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)GOTO50
      GOTO90
   50 WRITE(ICOUT, 5)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,47)N
      CALL DPWRST('XXX','BUG ')
      RETURN
   90 CONTINUE
    5 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ',
     1'HFNRAN SUBROUTINE IS NON-POSITIVE *****')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
C
C     GENERATE N UNIFORM (0,1) RANDOM NUMBERS;
C     THEN GENERATE 2 ADDITIONAL UNIFORM (0,1) RANDOM NUMBERS
C     (TO BE USED BELOW IN FORMING THE N-TH NORMAL
C     RANDOM NUMBER WHEN THE DESIRED SAMPLE SIZE N
C     HAPPENS TO BE ODD).
C
      CALL UNIRAN(N,ISEED,X)
      CALL UNIRAN(2,ISEED,Y)
C
C     GENERATE N NORMAL RANDOM NUMBERS
C     USING THE BOX-MULLER METHOD.
C
      DO200I=1,N,2
      IP1=I+1
      U1=X(I)
      IF(I.EQ.N)GOTO210
      U2=X(IP1)
      GOTO220
  210 U2=Y(2)
  220 ARG1=-2.0*ALOG(U1)
      ARG2=2.0*PI*U2
      SQRT1=SQRT(ARG1)
      Z1=SQRT1*COS(ARG2)
      Z2=SQRT1*SIN(ARG2)
      X(I)=Z1
      IF(I.EQ.N)GOTO200
      X(IP1)=Z2
  200 CONTINUE
C
C     GENERATE N HALFNORMAL RANDOM NUMBERS
C     USING THE DEFINITION THAT
C     A HALFNORMAL VARIATE
C     EQUALS THE ABSOLUTE VALUE OF A NORMAL VARIATE.
C
      DO400I=1,N
      IF(X(I).LT.0.0)X(I)=-X(I)
  400 CONTINUE
C
      RETURN
      END
      SUBROUTINE HLQEST(X, N, XTEMP, LB, RB, Q, ISEED, RESULT)
C
C    SUBROUTINE HLQEST
C
C    PURPOSE       COMPUTES THE HODGES-LEHMANN LOCATION ESTIMATOR:
C                  MEDIAN OF ( X(I) + X(J) ) / 2   FOR 1 LE I LE J LE N
C
C    USAGE         CALL HLQEST(X,N,LB,RB,Q,RESULT)
C
C    ARGUMENTS  X   REAL ARRAY OF OBSERVATIONS  (INPUT)
C                 * VALUES OF X MUST BE IN NONDECREASING ORDER *
C
C               N   INTEGER NUMBER OF OBSERVATIONS  (INPUT)
C                 * N MUST NOT BE LESS THAN 1 *
C
C               LB  INTEGER ARRAY OF LENGTH N FOR WORKSPACE
C
C               RB  INTEGER ARRAY OF LENGTH N FOR WORKSPACE
C
C               Q   INTEGER ARRAY OF LENGTH N FOR WORKSPACE
C
C           ISEED   SEED FOR UNIFORM RANDOM NUMBER GENERATOR
C
C         NOTE ---  ONLY LB,RB, AND Q ARE CHANGED IN COMPUTATION
C
C   EXTERNAL ROUTINE
C              RAN  FUNCTION PROVIDING UNIFORM RANDOM VARIABLES
C                   IN THE INTERVAL (0,1)
C                   RAN REQUIRES A DUMMY INTEGER ARGUMENT
C
C   NOTES           HLQEST HAS AN EXPECTED TIME COMPLEXITY ON
C                   THE ORDER OF N * LG( N )
C
C
C                   FOR N <= 25, COMPUTE DIRECTLY
C
C  J F MONAHAN, APRIL 1982, DEPT OF STAT, N C S U, RALEIGH, N C 27650
C  FINAL VERSION  JUNE 1983
C
      REAL X(*), AMN, AMX, XRAN(1)
      REAL XTEMP(*)
      INTEGER LB(*), RB(*), Q(*), SM, SQ, I, J, K, K1, K2, L, N, NN,
     * MDLL, MDLU, LBI, RBI, MDLROW, IQ
C
C  TAKE CARE OF SPECIAL CASES: N=1 AND N=2
C
      IF (N.LE.0) THEN
         RESULT=0.0
         RETURN
      ENDIF
C
      CALL SORT(X,N,X)
      IF (N.EQ.1) THEN
          RESULT = X(1)
          RETURN
      ELSEIF (N.EQ.2) THEN
          RESULT = (X(1)+X(2))/2.
          RETURN
      ELSEIF (N.LE.25) THEN
          NN = 0
          DO 1 I=1,N
            DO 2 J = I,N
              NN = NN + 1
              XTEMP(NN) = X(I) + X(J)
 2          CONTINUE
 1        CONTINUE
          CALL SORT(XTEMP,NN,XTEMP)
          K=(NN+1)/2
          IF(2*K.EQ.NN) XTEMP(K) = (XTEMP(K) + XTEMP(K+1))/2.
          RESULT=XTEMP(K)/2.
          RETURN
      ENDIF
C
C  FIND THE TOTAL NUMBER OF PAIRS (NN) AND THE MEDIAN(S) (K1,K2) NEEDED
C
   10 CONTINUE
      NN = (N*(N+1))/2
      K1 = (NN+1)/2
      K2 = (NN+2)/2
C
C  INITIALIZE LEFT AND RIGHT BOUNDS
C
      DO 20 I=1,N
        LB(I) = I
        RB(I) = N
   20 CONTINUE
C  SM = NUMBER IN SET S AT STEP M
      SM = NN
C  L = NUMBER OF PAIRS LESS THAN THOSE IN SET S AT STEP M
      L = 0
C
C
C  USE THE MEDIAN OF X(I)'S TO PARTITION ON THE FIRST STEP
C
      MDLL = (N+1)/2
      MDLU = (N+2)/2
      AM = X(MDLL) + X(MDLU)
      GO TO 80
C
C  USE THE MIDRANGE OF SET S AS PARTITION ELEMENT WHEN TIES ARE LIKELY
C   -- OR GET THE AVERAGE OF THE LAST 2 ELEMENTS
C
   30 AMX = X(1) + X(1)
      AMN = X(N) + X(N)
      DO 40 I=1,N
C   SKIP THIS ROW IF NO ELEMENT IN IT IS IN SET S ON THIS STEP
        IF (LB(I).GT.RB(I)) GO TO 40
        LBI = LB(I)
C                             GET THE SMALLEST IN THIS ROW
        AMN = AMIN1(AMN,X(LBI)+X(I))
        RBI = RB(I)
C                             GET THE LARGEST IN THIS ROW
        AMX = AMAX1(AMX,X(RBI)+X(I))
   40 CONTINUE
      AM = (AMX+AMN)/2.
C  BE CAREFUL TO CUT OFF SOMETHING -- ROUNDOFF CAN DO WIERD THINGS
      IF (AM.LE.AMN .OR. AM.GT.AMX) AM = AMX
C  UNLESS FINISHED, JUMP TO PARTITION STEP
      IF (AMN.NE.AMX .AND. SM.NE.2) GO TO 80
C  ALL DONE IF ALL OF S IS THE SAME -OR- IF ONLY 2 ELEMENTS ARE LEFT
      RESULT = AM/2.
      RETURN
C
C   *****   RESTART HERE UNLESS WORRIED ABOUT TIES   *****
C
   50 CONTINUE
C                        USE RANDOM ROW MEDIAN AS PARTITION ELEMENT
CCCCC FOR DATAPLOT: CALL UNIRAN
CCCCC K = IFIX(FLOAT(SM)*RAN(SM))
      NTEMP=1
      CALL UNIRAN(NTEMP, ISEED, XRAN)
      K = IFIX(FLOAT(SM)*XRAN(1))
C                        K IS A RANDOM INTEGER FROM O TO SM-1
      DO 60 I=1,N
        J = I
        IF (K.LE.RB(I)-LB(I)) GO TO 70
        K = K - RB(I) + LB(I) - 1
   60 CONTINUE
C                        J IS A RANDOM ROW --- NOW GET ITS MEDIAN
   70 MDLROW = (LB(J)+RB(J))/2
      AM = X(J) + X(MDLROW)
C
C       *****   PARTITION STEP   *****
C
C  USE AM TO PARTITION S0 INTO 2 GROUPS: THOSE .LT. AM, THOSE .GE. AM
C  Q(I)= HOW MANY PAIRS (X(I)+X(J)) IN ROW I LESS THAN AM
   80 CONTINUE
      J = N
C                              START IN UPPER RIGHT CORNER
      SQ = 0
C                              I COUNTS ROWS
      DO 110 I=1,N
        Q(I) = 0
C                              HAVE WE HIT THE DIAGONAL ?
   90   IF (J.LT.I) GO TO 110
C                              SHALL WE MOVE LEFT ?
        IF (X(I)+X(J).LT.AM) GO TO 100
        J = J - 1
        GO TO 90
C                              WE'RE DONE IN THIS ROW
  100   Q(I) = J - I + 1
C  SQ = TOTAL NUMBER OF PAIRS LESS THAN AM
        SQ = SQ + Q(I)
  110 CONTINUE
C
C  ***  FINISHED PARTITION --- START BRANCHING  ***
C
C  IF CONSECUTIVE PARTITIONS ARE THE SAME WE PROBABLY HAVE TIES
      IF (SQ.EQ.L) GO TO 30
C
C  ARE WE NEARLY DONE, WITH THE VALUES WE WANT ON THE BORDER?
C  IF(WE NEED  MAX OF THOSE .LT. AM -OR- MIN OF THOSE .GE. AM) GO TO 90
C
      IF (SQ.EQ.K2-1) GO TO 180
C
C  THE SET S IS SPLIT, WHICH PIECE DO WE KEEP?
C  70  =  CUT OFF BOTTOM,   90  =  NEARLY DONE,   60  =  CUT OFF TOP
C
      IF (SQ-K1) 140, 180, 120
C
C  NEW S = (OLD S) .INTERSECT. (THOSE .LT. AM)
  120 CONTINUE
      DO 130 I=1,N
C                            RESET RIGHT BOUNDS FOR EACH ROW
        RB(I) = I + Q(I) - 1
  130 CONTINUE
      GO TO 160
C  NEW S = (OLD S) .INTERSECT. (THOSE .GE. AM)
  140 CONTINUE
      DO 150 I=1,N
C                            RESET LEFT BOUNDS FOR EACH ROW
        LB(I) = I + Q(I)
  150 CONTINUE
C
C  COUNT   SM = NUMBER OF PAIRS STILL IN NEW SET S
C           L = NUMBER OF PAIRS LESS THAN THOSE IN NEW SET S
  160 L = 0
      SM = 0
      DO 170 I=1,N
        L = L + LB(I) - I
        SM = SM + RB(I) - LB(I) + 1
  170 CONTINUE
C
C        *****   NORMAL RESTART JUMP   *****
C
      IF (SM.GT.2) GO TO 50
C  CAN ONLY GET TO 2 LEFT IF K1.NE.K2  -- GO GET THEIR AVERAGE
      GO TO 30
C
C  FIND:   MAX OF THOSE .LT. AM
C          MIN OF THOSE .GE. AM
  180 CONTINUE
      AMN = X(N) + X(N)
      AMX = X(1) + X(1)
      DO 190 I=1,N
        IQ = Q(I)
        IPIQ = I + IQ
        IF (IQ.GT.0) AMX = AMAX1(AMX,X(I)+X(IPIQ-1))
        IPIQ = I + IQ
        IF (IQ.LT.N-I+1) AMN = AMIN1(AMN,X(I)+X(IPIQ))
  190 CONTINUE
      RESULT = (AMN+AMX)/4.
C  WE ARE DONE, BUT WHICH SITUATION ARE WE IN?
      IF (K1.LT.K2) RETURN
      IF (SQ.EQ.K1) RESULT = AMX/2.
      IF (SQ.EQ.K1-1) RESULT = AMN/2.
      RETURN
      END
      SUBROUTINE HOOKDR(NR,N,X,F,G,A,UDIAG,P,XPLS,FPLS,
     +     SX,STEPMX,
CDPLT+     OPTFCN,SX,STEPMX,
     +     STEPTL,DLT,IRETCD,MXTAKE,AMU,DLTP,PHI,PHIP0,
     +     SC,XPLSP,WRK0,EPSM,ITNCNT,IPR)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C PURPOSE
C -------
C FIND A NEXT NEWTON ITERATE (XPLS) BY THE MORE-HEBDON METHOD
C
C PARAMETERS
C ----------
C NR           --> ROW DIMENSION OF MATRIX
C N            --> DIMENSION OF PROBLEM
C X(N)         --> OLD ITERATE X[K-1]
C F            --> FUNCTION VALUE AT OLD ITERATE, F(X)
C G(N)         --> GRADIENT AT OLD ITERATE, G(X), OR APPROXIMATE
C A(N,N)       --> CHOLESKY DECOMPOSITION OF HESSIAN IN LOWER
C                  TRIANGULAR PART AND DIAGONAL.
C                  HESSIAN IN UPPER TRIANGULAR PART AND UDIAG.
C UDIAG(N)     --> DIAGONAL OF HESSIAN IN A(.,.)
C P(N)         --> NEWTON STEP
C XPLS(N)     <--  NEW ITERATE X[K]
C FPLS        <--  FUNCTION VALUE AT NEW ITERATE, F(XPLS)
C OPTFCN       --> NAME OF SUBROUTINE TO EVALUATE FUNCTION
C SX(N)        --> DIAGONAL SCALING MATRIX FOR X
C STEPMX       --> MAXIMUM ALLOWABLE STEP SIZE
C STEPTL       --> RELATIVE STEP SIZE AT WHICH SUCCESSIVE ITERATES
C                  CONSIDERED CLOSE ENOUGH TO TERMINATE ALGORITHM
C DLT         <--> TRUST REGION RADIUS
C IRETCD      <--  RETURN CODE
C                    =0 SATISFACTORY XPLS FOUND
C                    =1 FAILED TO FIND SATISFACTORY XPLS SUFFICIENTLY
C                       DISTINCT FROM X
C MXTAKE      <--  BOOLEAN FLAG INDICATING STEP OF MAXIMUM LENGTH USED
C AMU         <--> [RETAIN VALUE BETWEEN SUCCESSIVE CALLS]
C DLTP        <--> [RETAIN VALUE BETWEEN SUCCESSIVE CALLS]
C PHI         <--> [RETAIN VALUE BETWEEN SUCCESSIVE CALLS]
C PHIP0       <--> [RETAIN VALUE BETWEEN SUCCESSIVE CALLS]
C SC(N)        --> WORKSPACE
C XPLSP(N)     --> WORKSPACE
C WRK0(N)      --> WORKSPACE
C EPSM         --> MACHINE EPSILON
C ITNCNT       --> ITERATION COUNT
C IPR          --> DEVICE TO WHICH TO SEND OUTPUT
C
      DIMENSION X(N),G(N),P(N),XPLS(N),SX(N)
      DIMENSION A(NR,1),UDIAG(N)
      DIMENSION SC(N),XPLSP(N),WRK0(N)
      LOGICAL MXTAKE,NWTAKE
      LOGICAL FSTIME
CDPLT EXTERNAL OPTFCN
C
      IRETCD=4
      FSTIME=.TRUE.
      TMP=0.
      DO 5 I=1,N
        TMP=TMP+SX(I)*SX(I)*P(I)*P(I)
    5 CONTINUE
      RNWTLN=SQRT(TMP)
C$    WRITE(IPR,954) RNWTLN
C
      IF(ITNCNT.GT.1) GO TO 100
C     IF(ITNCNT.EQ.1)
C     THEN
        AMU=0.
C
C       IF FIRST ITERATION AND TRUST REGION NOT PROVIDED BY USER,
C       COMPUTE INITIAL TRUST REGION.
C
        IF(DLT.NE. (-1.)) GO TO 100
C       IF(DLT.EQ. (-1.))
C       THEN
          ALPHA=0.
          DO 10 I=1,N
            ALPHA=ALPHA+(G(I)*G(I))/(SX(I)*SX(I))
   10     CONTINUE
          BETA=0.0
          DO 30 I=1,N
            TMP=0.
            DO 20 J=I,N
              TMP=TMP + (A(J,I)*G(J))/(SX(J)*SX(J))
   20       CONTINUE
            BETA=BETA+TMP*TMP
   30     CONTINUE
          DLT=ALPHA*SQRT(ALPHA)/BETA
          DLT = MIN(DLT, STEPMX)
C$        WRITE(IPR,950)
C$        WRITE(IPR,951) ALPHA,BETA,DLT
C       ENDIF
C     ENDIF
C
  100 CONTINUE
C
C FIND NEW STEP BY MORE-HEBDON ALGORITHM
      CALL HOOKST(NR,N,G,A,UDIAG,P,SX,RNWTLN,DLT,AMU,
     +     DLTP,PHI,PHIP0,FSTIME,SC,NWTAKE,WRK0,EPSM,IPR)
      DLTP=DLT
C
C CHECK NEW POINT AND UPDATE TRUST REGION
CDPLT CALL TREGUP(NR,N,X,F,G,A,OPTFCN,SC,SX,NWTAKE,STEPMX,STEPTL,
      CALL TREGUP(NR,N,X,F,G,A,SC,SX,NWTAKE,STEPMX,STEPTL,
     +         DLT,IRETCD,XPLSP,FPLSP,XPLS,FPLS,MXTAKE,IPR,3,UDIAG)
      IF(IRETCD.LE.1) RETURN
      GO TO 100
C
CC950 FORMAT(43H HOOKDR    INITIAL TRUST REGION NOT GIVEN. ,
CC   +       21H COMPUTE CAUCHY STEP.)
CC951 FORMAT(18H HOOKDR    ALPHA =,E20.13/
CC   +       18H HOOKDR    BETA  =,E20.13/
CC   +       18H HOOKDR    DLT   =,E20.13)
CC952 FORMAT(28H HOOKDR    CURRENT STEP (SC))
CC954 FORMAT(18H0HOOKDR    RNWTLN=,E20.13)
CC955 FORMAT(14H HOOKDR       ,5(E20.13,3X))
      END
      SUBROUTINE HOOKST(NR,N,G,A,UDIAG,P,SX,RNWTLN,DLT,AMU,
     +     DLTP,PHI,PHIP0,FSTIME,SC,NWTAKE,WRK0,EPSM,IPR)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C PURPOSE
C -------
C FIND NEW STEP BY MORE-HEBDON ALGORITHM
C
C PARAMETERS
C ----------
C NR           --> ROW DIMENSION OF MATRIX
C N            --> DIMENSION OF PROBLEM
C G(N)         --> GRADIENT AT CURRENT ITERATE, G(X)
C A(N,N)       --> CHOLESKY DECOMPOSITION OF HESSIAN IN
C                  LOWER TRIANGULAR PART AND DIAGONAL.
C                  HESSIAN OR APPROX IN UPPER TRIANGULAR PART
C UDIAG(N)     --> DIAGONAL OF HESSIAN IN A(.,.)
C P(N)         --> NEWTON STEP
C SX(N)        --> DIAGONAL SCALING MATRIX FOR N
C RNWTLN       --> NEWTON STEP LENGTH
C DLT         <--> TRUST REGION RADIUS
C AMU         <--> [RETAIN VALUE BETWEEN SUCCESSIVE CALLS]
C DLTP         --> TRUST REGION RADIUS AT LAST EXIT FROM THIS ROUTINE
C PHI         <--> [RETAIN VALUE BETWEEN SUCCESSIVE CALLS]
C PHIP0       <--> [RETAIN VALUE BETWEEN SUCCESSIVE CALLS]
C FSTIME      <--> BOOLEAN. =.TRUE. IF FIRST ENTRY TO THIS ROUTINE
C                  DURING K-TH ITERATION
C SC(N)       <--  CURRENT STEP
C NWTAKE      <--  BOOLEAN, =.TRUE. IF NEWTON STEP TAKEN
C WRK0         --> WORKSPACE
C EPSM         --> MACHINE EPSILON
C IPR          --> DEVICE TO WHICH TO SEND OUTPUT
C
      DIMENSION G(N),P(N),SX(N),SC(N),WRK0(N)
      DIMENSION A(NR,1),UDIAG(N)
      LOGICAL NWTAKE,DONE
      LOGICAL FSTIME
C
C HI AND ALO ARE CONSTANTS USED IN THIS ROUTINE.
C CHANGE HERE IF OTHER VALUES ARE TO BE SUBSTITUTED.
      IPR=IPR
      HI=1.5
      ALO=.75
C -----
      IF(RNWTLN.GT.HI*DLT) GO TO 15
C     IF(RNWTLN.LE.HI*DLT)
C     THEN
C
C       TAKE NEWTON STEP
C
        NWTAKE=.TRUE.
        DO 10 I=1,N
          SC(I)=P(I)
   10   CONTINUE
        DLT=MIN(DLT,RNWTLN)
        AMU=0.
C$      WRITE(IPR,951)
        RETURN
C     ELSE
C
C       NEWTON STEP NOT TAKEN
C
   15   CONTINUE
C$      WRITE(IPR,952)
        NWTAKE=.FALSE.
        IF(AMU.LE.0.) GO TO 20
C       IF(AMU.GT.0.)
C       THEN
          AMU=AMU- (PHI+DLTP) *((DLTP-DLT)+PHI)/(DLT*PHIP)
C$        WRITE(IPR,956) AMU
C       ENDIF
   20   CONTINUE
        PHI=RNWTLN-DLT
        IF(.NOT.FSTIME) GO TO 28
C       IF(FSTIME)
C       THEN
          DO 25 I=1,N
            WRK0(I)=SX(I)*SX(I)*P(I)
   25     CONTINUE
C
C         SOLVE L*Y = (SX**2)*P
C
          CALL FORSLV(NR,N,A,WRK0,WRK0)
          PHIP0=-DNRM2(N,WRK0,1)**2/RNWTLN
          FSTIME=.FALSE.
C       ENDIF
   28   PHIP=PHIP0
        AMULO=-PHI/PHIP
        AMUUP=0.0
        DO 30 I=1,N
          AMUUP=AMUUP+(G(I)*G(I))/(SX(I)*SX(I))
   30   CONTINUE
        AMUUP=SQRT(AMUUP)/DLT
        DONE=.FALSE.
C$      WRITE(IPR,956) AMU
C$      WRITE(IPR,959) PHI
C$      WRITE(IPR,960) PHIP
C$      WRITE(IPR,957) AMULO
C$      WRITE(IPR,958) AMUUP
C
C       TEST VALUE OF AMU; GENERATE NEXT AMU IF NECESSARY
C
  100   CONTINUE
        IF(DONE) RETURN
C$      WRITE(IPR,962)
        IF(AMU.GE.AMULO .AND. AMU.LE.AMUUP) GO TO 110
C       IF(AMU.LT.AMULO .OR.  AMU.GT.AMUUP)
C       THEN
          AMU=MAX(SQRT(AMULO*AMUUP),AMUUP*1.0E-3)
C$        WRITE(IPR,956) AMU
C       ENDIF
  110   CONTINUE
C
C       COPY (H,UDIAG) TO L
C       WHERE H <-- H+AMU*(SX**2) [DO NOT ACTUALLY CHANGE (H,UDIAG)]
        DO 130 J=1,N
          A(J,J)=UDIAG(J) + AMU*SX(J)*SX(J)
          IF(J.EQ.N) GO TO 130
          JP1=J+1
          DO 120 I=JP1,N
            A(I,J)=A(J,I)
  120     CONTINUE
  130   CONTINUE
C
C       FACTOR H=L(L+)
C
        CALL CHOLDC(NR,N,A,0.0D0,SQRT(EPSM),ADDMAX)
C
C       SOLVE H*P = L(L+)*SC = -G
C
        DO 140 I=1,N
          WRK0(I)=-G(I)
  140   CONTINUE
        CALL LLTSLV(NR,N,A,SC,WRK0)
C$      WRITE(IPR,955)
C$      WRITE(IPR,963) (SC(I),I=1,N)
C
C       RESET H.  NOTE SINCE UDIAG HAS NOT BEEN DESTROYED WE NEED DO
C       NOTHING HERE.  H IS IN THE UPPER PART AND IN UDIAG, STILL INTACT
C
        STEPLN=0.
        DO 150 I=1,N
          STEPLN=STEPLN + SX(I)*SX(I)*SC(I)*SC(I)
  150   CONTINUE
        STEPLN=SQRT(STEPLN)
        PHI=STEPLN-DLT
        DO 160 I=1,N
          WRK0(I)=SX(I)*SX(I)*SC(I)
  160   CONTINUE
        CALL FORSLV(NR,N,A,WRK0,WRK0)
        PHIP=-DNRM2(N,WRK0,1)**2/STEPLN
C$      WRITE(IPR,961) DLT,STEPLN
C$      WRITE(IPR,959) PHI
C$      WRITE(IPR,960) PHIP
        IF((ALO*DLT.GT.STEPLN .OR. STEPLN.GT.HI*DLT) .AND.
     +       (AMUUP-AMULO.GT.0.)) GO TO 170
C       IF((ALO*DLT.LE.STEPLN .AND. STEPLN.LE.HI*DLT) .OR.
C            (AMUUP-AMULO.LE.0.))
C       THEN
C
C         SC IS ACCEPTABLE HOOKSTEP
C
C$        WRITE(IPR,954)
          DONE=.TRUE.
          GO TO 100
C       ELSE
C
C         SC NOT ACCEPTABLE HOOKSTEP.  SELECT NEW AMU
C
  170     CONTINUE
C$        WRITE(IPR,953)
          AMULO=MAX(AMULO,AMU-(PHI/PHIP))
          IF(PHI.LT.0.) AMUUP=MIN(AMUUP,AMU)
          AMU=AMU-(STEPLN*PHI)/(DLT*PHIP)
C$        WRITE(IPR,956) AMU
C$        WRITE(IPR,957) AMULO
C$        WRITE(IPR,958) AMUUP
          GO TO 100
C       ENDIF
C     ENDIF
C
  951 FORMAT(27H0HOOKST    TAKE NEWTON STEP)
  952 FORMAT(32H0HOOKST    NEWTON STEP NOT TAKEN)
  953 FORMAT(31H HOOKST    SC IS NOT ACCEPTABLE)
  954 FORMAT(27H HOOKST    SC IS ACCEPTABLE)
  955 FORMAT(28H HOOKST    CURRENT STEP (SC))
  956 FORMAT(18H HOOKST    AMU   =,E20.13)
  957 FORMAT(18H HOOKST    AMULO =,E20.13)
  958 FORMAT(18H HOOKST    AMUUP =,E20.13)
  959 FORMAT(18H HOOKST    PHI   =,E20.13)
  960 FORMAT(18H HOOKST    PHIP  =,E20.13)
  961 FORMAT(18H HOOKST    DLT   =,E20.13/
     +       18H HOOKST    STEPLN=,E20.13)
  962 FORMAT(23H0HOOKST    FIND NEW AMU)
  963 FORMAT(14H HOOKST       ,5(E20.13,3X))
      END
      SUBROUTINE HORIND(X,XMIN,XMAX,I1,I2,I,IBUGU2,ISUBRO,IERROR)
C
C     PURPOSE--TRANSLATE A FLOATING POINT NUMBER
C              BETWEEN XMIN AND XMAX
C              INTO AN INTEGER INDEX BETWEEN I1 AND I2.
C              THIS IS USED IN REFERENCING ELEMENTS
C              IN HTE HORIZON TABLES USED IN
C              3-D HIDDEN LINE REMOVAL.
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IBUGU2
      CHARACTER*4 ISUBRO
      CHARACTER*4 IERROR
C
C---------------------------------------------------------------------
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 11--                                   **
C               **  COMPUTE THE INTEGER INDEX.                  **
C               **************************************************
C
      P=(X-XMIN)/(XMAX-XMIN)
      AI1=I1
      AI2=I2
      AI=AI1+P*(AI2-AI1)
      I=AI+0.5
C
C               **************************************************
C               **  STEP 90--                                   **
C               **  EXIT.                                       **
C               **************************************************
C
      IF(IBUGU2.EQ.'ON'.OR.ISUBRO.EQ.'NDEX')GOTO9010
      GOTO9090
 9010 CONTINUE
CCCCC WRITE(ICOUT,999)
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC WRITE(ICOUT,9011)
C9011 FORMAT('AT THE END       OF HORIND--')
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC WRITE(ICOUT,9012)X,XMIN,XMAX
C9012 FORMAT('X,XMIN,XMAX = ',3E15.7)
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC WRITE(ICOUT,9013)I1,I2,I
C9013 FORMAT('I1,I2,I = ',3I8)
CCCCC CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9014)X,XMIN,XMAX,I1,I2,I
 9014 FORMAT('FROM HORIND--X,XMIN,XMAX,I1,I2,I = ',3E15.7,3I8)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE HPBRES(IXSTRT,IYSTRT,IXSTOP,IYSTOP,
     * ICOLOR,IWIDTH)
C
C  THIS SUBROUTINE IMPLEMENTS THE BRESENHAM ALGORITHM FOR
C  GENERATING A VECTOR LINE ON AN HP-LASER JET PRINTER.
C
C  IXSTRT  - X COORDINATE OF START POINT OF THE LINE
C  IYSTRT  - Y COORDINATE OF START POINT OF THE LINE
C  IXSTOP  - X COORDINATE OF END POINT OF THE LINE
C  IYSTOP  - Y COORDINATE OF END  POINT OF THE LINE
C  ICOLOR  - COLOR THE POINT SHOULD BE PLOTTED AS
C            (NULL FOR NOW SINCE ALL CURRENT LASER JET PRINTERS ARE
C             BLACK AND WHITE)
C  IWIDTH  - WIDTH OF LINE IN PIXELS (SHOULD BE ODD INTEGER)
C
C  NOTE: THIS ROUTINE GENERATES INDIVIDUAL VECTORS, WHICH CAN GENERATE
C        AN EXTREMELY LARGE NUMBER OF POINTS FOR COMPLEX PLOTS.  AN
C        ALTERNATIVE IS TO A STORE THE VECTORIZED POINTS IN AN ARRAY
C        AND USE THE PCL RASTER GRAPHICS COMMANDS TO PRINT AN ENTIRE
C        PAGE AT ONE TIME.
C
C  THE METHOD TO DRAW A LINE IS TO MOVE TO A POINT AND THEN DRAW A
C  RECTANGLE OF GIVEN HEIGHT AND WIDTH.  THE HEIGHT WILL BE 1 AND THE
C  WIDTH IS THE DETERMINED BY THE DESIRED WIDTH OF THE LINE (3 PIXELS
C  BY DEFAULT).
C
C  THE RECTANGLE GRAPHICS COMMANDS ARE:
C
C    <IESC>*p<X COOR>X    - MOVE TO X COORDINATE (IN DOTS)
C    <IESC>*p<Y COOR>Y    - MOVE TO Y COORDINATE (IN DOTS)
C    <IESC>*c<DOTS>A      - HORIZONTAL SIZE OF RECTANGLE (IN DOTS)
C    <IESC>*c<DOTS>B      - VERTICAL SIZE OF RECTANGLE (IN DOTS)
C    <IESC>*c0P           - DRAW THE SOLID FILLED RECTANGLE
C
C  THE RASTER GRAPHICS COMMANDS ARE:
C
C    <IESC>*t#R           - RESOLUTION (#=75,100,150 OR 300)
C    <IESC>*r#A           - SET LEFT MARGIN (#=0 FOR 0, #=1 FOR CURRENT
C                           X POSITION)
C    <IESC>*rB            - END RASTER GRAPHICS
C    <IESC>*b#W[DATA]     - SEND BYTES OF RASTER DATA, EACH BYTE SETS
C                           8 DOTS (1=ON, 0=OFF), #=NUMBER OF BYTES
C
CCCCC INTEGER IXCOOR,IYCOOR
      CHARACTER*(*) ICOLOR
      CHARACTER*4 ISUBN0
      CHARACTER*130 ICSTR
C
      INCLUDE 'DPCONP.INC'
C
C  BRESENHAM PARAMETER INITIALIZATION
C
      ISUBN0='BRES'
      IERROR=0
      IDELX=IXSTOP-IXSTRT
      IDELY=IYSTOP-IYSTRT
      INCX=SIGN(1,IDELX)
      INCY=SIGN(1,IDELY)
      IADELX=ABS(IDELX)
      IADELY=ABS(IDELY)
      IXNEW=IXSTRT
      IYNEW=IYSTRT
      ICSTR=' '
C
C  TEST FOR VERTICAL LINE
C
      IF(IXSTRT.EQ.IXSTOP) THEN
        ICSTR(1:1)=IESCC
        ICSTR(2:3)='*p'
        IXTEMP=IXSTRT-IWIDTH/2
        NCSTR=3
        NCHTOT=4
        CALL GRTRIN(IXTEMP,NCHTOT,ICSTR,NCSTR)
        ICSTR(8:8)='x'
        NCSTR=8
        CALL GRTRIN(IYSTRT,NCHTOT,ICSTR,NCSTR)
        ICSTR(13:13)='Y'
        ICSTR(14:14)=IESCC
        ICSTR(15:16)='*c'
        NCHTOT=2
        NCSTR=16
        CALL GRTRIN(IWIDTH,NCHTOT,ICSTR,NCSTR)
        ICSTR(19:19)='a'
        NCHTOT=4
        NCSTR=19
        IYTEMP=ABS(IYSTOP-IYSTRT)+1
        CALL GRTRIN(IYTEMP,NCHTOT,ICSTR,NCSTR)
        ICSTR(24:24)='b'
        ICSTR(25:26)='0P'
        NCSTR=26
        CALL GRWRST(ICSTR,NCSTR,ISUBN0)
        GOTO999
      END IF
C
C  TEST FOR HORIZONTAL LINE
C
      IF(IYSTRT.EQ.IYSTOP) THEN
        ICSTR(1:1)=IESCC
        ICSTR(2:3)='*p'
        IYTEMP=IYSTRT-IWIDTH/2
        NCSTR=3
        NCHTOT=4
        CALL GRTRIN(IXSTRT,NCHTOT,ICSTR,NCSTR)
        ICSTR(8:8)='x'
        NCSTR=8
        CALL GRTRIN(IYTEMP,NCHTOT,ICSTR,NCSTR)
        ICSTR(13:13)='Y'
        ICSTR(14:14)=IESCC
        ICSTR(15:16)='*c'
        NCHTOT=2
        NCSTR=16
        CALL GRTRIN(IWIDTH,NCHTOT,ICSTR,NCSTR)
        ICSTR(19:19)='b'
        NCHTOT=4
        NCSTR=19
        IYTEMP=ABS(IYSTOP-IYSTRT)+1
        CALL GRTRIN(IYTEMP,NCHTOT,ICSTR,NCSTR)
        ICSTR(24:24)='a'
        ICSTR(25:26)='0P'
        NCSTR=26
        CALL GRWRST(ICSTR,NCSTR,ISUBN0)
        GOTO999
      END IF
C
C  BRESENHAM ALGORITHM.  TWO CASES: WHERE X INCRESES FASTER THAN
C  Y AND WHERE Y INCREASES FASTER THAN X.
C
C  CASE 1: X INCRESES FASTER THAN Y
C
      IF(IADELX.GE.IADELY) THEN
        IHALF=IADELX/2
        ICSTR(1:1)=IESCC
        ICSTR(2:13)='*p    x    Y'
        ICSTR(14:14)=IESCC
        ICSTR(15:19)='*c  b'
        ICSTR(20:21)='1a'
        ICSTR(22:23)='0P'
        ICSTR(24:46)=ICSTR(1:23)
        ICSTR(47:69)=ICSTR(1:23)
        ICSTR(70:92)=ICSTR(1:23)
        ICSTR(93:115)=ICSTR(1:23)
        NGEN=IADELX+1
        DO 100 I=1,NGEN
C
          NFACT=(MOD(I,5)-1)*23
          IYTEMP=IYNEW-IWIDTH/2
          NCSTR=NFACT+3
          NCHTOT=4
          CALL GRTRIN(IXNEW,NCHTOT,ICSTR,NCSTR)
          NCSTR=NFACT+8
          CALL GRTRIN(IYTEMP,NCHTOT,ICSTR,NCSTR)
          NCHTOT=2
          NCSTR=NFACT+16
          CALL GRTRIN(IWIDTH,NCHTOT,ICSTR,NCSTR)
          NCSTR=(NFACT+1)*23
          IF(NCSTR.GE.115)CALL GRWRST(ICSTR,NCSTR,ISUBN0)
C
          IXNEW=IXNEW+INCX
          IERROR=IERROR+IADELY
          IF(IERROR.GT.IHALF) THEN
            IERROR=IERROR-IADELX
            IYNEW=IYNEW+INCY
          END IF
 100    CONTINUE
        IF(NCSTR.LT.115)CALL GRWRST(ICSTR,NCSTR,ISUBN0)
      ELSE
C
C  CASE 2: Y INCRESES FASTER THAN X
C
        IHALF=IADELY/2
        ICSTR(1:1)=IESCC
        ICSTR(2:13)='*p    x    Y'
        ICSTR(14:14)=IESCC
        ICSTR(15:19)='*c  a'
        ICSTR(20:21)='1b'
        ICSTR(22:23)='0P'
        ICSTR(24:46)=ICSTR(1:23)
        ICSTR(47:69)=ICSTR(1:23)
        ICSTR(70:92)=ICSTR(1:23)
        ICSTR(93:115)=ICSTR(1:23)
        NGEN=IADELY+1
        DO 200 I=1,NGEN
C
          NFACT=(MOD(I,5)-1)*23
          IXTEMP=IXNEW-IWIDTH/2
          NCSTR=NFACT+3
          NCHTOT=4
          CALL GRTRIN(IXTEMP,NCHTOT,ICSTR,NCSTR)
          NCSTR=NFACT+8
          CALL GRTRIN(IYNEW,NCHTOT,ICSTR,NCSTR)
          NCHTOT=2
          NCSTR=NFACT+16
          CALL GRTRIN(IWIDTH,NCHTOT,ICSTR,NCSTR)
          NCSTR=(NFACT+1)*23
          IF(NCSTR.GE.115)CALL GRWRST(ICSTR,NCSTR,ISUBN0)
C
          IYNEW=IYNEW+INCY
          IERROR=IERROR+IADELX
          IF(IERROR.GT.IHALF) THEN
            IERROR=IERROR-IADELY
            IXNEW=IXNEW+INCX
          END IF
 200    CONTINUE
        IF(NCSTR.LT.115)CALL GRWRST(ICSTR,NCSTR,ISUBN0)
      END IF
C
C  END
C
 999  CONTINUE
      RETURN
      END
      SUBROUTINE HPSORT (HX, N, STRBEG, STREND, IPERM, KFLAG, WORK, IER)
C***BEGIN PROLOGUE  HPSORT
C***PURPOSE  Return the permutation vector generated by sorting a
C            substring within a character array and, optionally,
C            rearrange the elements of the array.  The array may be
C            sorted in forward or reverse lexicographical order.  A
C            slightly modified quicksort algorithm is used.
C***LIBRARY   SLATEC
C***CATEGORY  N6A1C, N6A2C
C***TYPE      CHARACTER (SPSORT-S, DPSORT-D, IPSORT-I, HPSORT-H)
C***KEYWORDS  PASSIVE SORTING, SINGLETON QUICKSORT, SORT, STRING SORTING
C***AUTHOR  Jones, R. E., (SNLA)
C           Rhoads, G. S., (NBS)
C           Sullivan, F. E., (NBS)
C           Wisniewski, J. A., (SNLA)
C***DESCRIPTION
C
C   HPSORT returns the permutation vector IPERM generated by sorting
C   the substrings beginning with the character STRBEG and ending with
C   the character STREND within the strings in array HX and, optionally,
C   rearranges the strings in HX.   HX may be sorted in increasing or
C   decreasing lexicographical order.  A slightly modified quicksort
C   algorithm is used.
C
C   IPERM is such that HX(IPERM(I)) is the Ith value in the
C   rearrangement of HX.  IPERM may be applied to another array by
C   calling IPPERM, SPPERM, DPPERM or HPPERM.
C
C   An active sort of numerical data is expected to execute somewhat
C   more quickly than a passive sort because there is no need to use
C   indirect references. But for the character data in HPSORT, integers
C   in the IPERM vector are manipulated rather than the strings in HX.
C   Moving integers may be enough faster than moving character strings
C   to more than offset the penalty of indirect referencing.
C
C   Description of Parameters
C      HX - input/output -- array of type character to be sorted.
C           For example, to sort a 80 element array of names,
C           each of length 6, declare HX as character HX(100)*6.
C           If ABS(KFLAG) = 2, then the values in HX will be
C           rearranged on output; otherwise, they are unchanged.
C      N  - input -- number of values in array HX to be sorted.
C      STRBEG - input -- the index of the initial character in
C               the string HX that is to be sorted.
C      STREND - input -- the index of the final character in
C               the string HX that is to be sorted.
C      IPERM - output -- permutation array such that IPERM(I) is the
C              index of the string in the original order of the
C              HX array that is in the Ith location in the sorted
C              order.
C      KFLAG - input -- control parameter:
C            =  2  means return the permutation vector resulting from
C                  sorting HX in lexicographical order and sort HX also.
C            =  1  means return the permutation vector resulting from
C                  sorting HX in lexicographical order and do not sort
C                  HX.
C            = -1  means return the permutation vector resulting from
C                  sorting HX in reverse lexicographical order and do
C                  not sort HX.
C            = -2  means return the permutation vector resulting from
C                  sorting HX in reverse lexicographical order and sort
C                  HX also.
C      WORK - character variable which must have a length specification
C             at least as great as that of HX.
C      IER - output -- error indicator:
C          =  0  if no error,
C          =  1  if N is zero or negative,
C          =  2  if KFLAG is not 2, 1, -1, or -2,
C          =  3  if work array is not long enough,
C          =  4  if string beginning is beyond its end,
C          =  5  if string beginning is out-of-range,
C          =  6  if string end is out-of-range.
C
C     E X A M P L E  O F  U S E
C
C      CHARACTER*2 HX, W
C      INTEGER STRBEG, STREND
C      DIMENSION HX(10), IPERM(10)
C      DATA (HX(I),I=1,10)/ '05','I ',' I','  ','Rs','9R','R9','89',
C     1     ',*','N"'/
C      DATA STRBEG, STREND / 1, 2 /
C      CALL HPSORT (HX,10,STRBEG,STREND,IPERM,1,W)
C      PRINT 100, (HX(IPERM(I)),I=1,10)
C 100 FORMAT (2X, A2)
C      STOP
C      END
C
C***REFERENCES  R. C. Singleton, Algorithm 347, An efficient algorithm
C                 for sorting with minimal storage, Communications of
C                 the ACM, 12, 3 (1969), pp. 185-187.
C***ROUTINES CALLED  XERMSG
C***REVISION HISTORY  (YYMMDD)
C   761101  DATE WRITTEN
C   761118  Modified by John A. Wisniewski to use the Singleton
C           quicksort algorithm.
C   811001  Modified by Francis Sullivan for string data.
C   850326  Documentation slightly modified by D. Kahaner.
C   870423  Modified by Gregory S. Rhoads for passive sorting with the
C           option for the rearrangement of the original data.
C   890620  Algorithm for rearranging the data vector corrected by R.
C           Boisvert.
C   890622  Prologue upgraded to Version 4.0 style by D. Lozier.
C   920507  Modified by M. McClain to revise prologue text.
C   920818  Declarations section rebuilt and code restructured to use
C           IF-THEN-ELSE-ENDIF.  (SMR, WRB)
C***END PROLOGUE  HPSORT
C     .. Scalar Arguments ..
      INTEGER IER, KFLAG, N, STRBEG, STREND
      CHARACTER * (*) WORK
C     .. Array Arguments ..
      INTEGER IPERM(*)
      CHARACTER * (*) HX(*)
C     .. Local Scalars ..
      REAL R
      INTEGER I, IJ, INDX, INDX0, IR, ISTRT, J, K, KK, L, LM, LMT, M,
     +        NN, NN2
C     .. Local Arrays ..
      INTEGER IL(21), IU(21)
C     .. External Subroutines ..
CCCCC EXTERNAL XERMSG
C     .. Intrinsic Functions ..
      INTRINSIC ABS, INT, LEN
C
      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***FIRST EXECUTABLE STATEMENT  HPSORT
      IER = 0
      NN = N
      IF (NN .LT. 1) THEN
         IER = 1
         WRITE(ICOUT,999)
  999    FORMAT(1X)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,901)
  901    FORMAT('***** ERROR IN HPSORT (SORTING CHARACTER DATA--')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,903)
  903    FORMAT('      THE NUMBER OF VALUES TO BE SORTED IS ',
     1          'NON-POSITIVE')
         CALL DPWRST('XXX','BUG ')
         GOTO9999
      ENDIF
      KK = ABS(KFLAG)
      IF (KK.NE.1 .AND. KK.NE.2) THEN
         IER = 2
         WRITE(ICOUT,999)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,901)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,921)
  921    FORMAT('      THE SORT CONTROL PARAMETER HAS AN INVALID ',
     1          'VALUE.')
         CALL DPWRST('XXX','BUG ')
         GOTO9999
      ENDIF
C
      IF(LEN(WORK) .LT. LEN(HX(1))) THEN
         IER = 3
         WRITE(ICOUT,999)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,901)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,931)
  931    FORMAT('      THE LENGTH OF THE WORK VARIABLE IS TOO SHORT.')
         CALL DPWRST('XXX','BUG ')
         GOTO9999
      ENDIF
      IF (STRBEG .GT. STREND) THEN
         IER = 4
         WRITE(ICOUT,999)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,901)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,941)STRBEG,STREND
  941    FORMAT('      THE STRING BEGINNING, ',I8,' IS BEYOND ITS ',
     1          'END, ',I8,' .')
         CALL DPWRST('XXX','BUG ')
         GOTO9999
      ENDIF
      IF (STRBEG .LT. 1 .OR. STRBEG .GT. LEN(HX(1))) THEN
         IER = 5
         WRITE(ICOUT,999)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,901)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,951)STRBEG
  951    FORMAT('      THE STRING BEGINNING, ',I8,' IS OUT-OF-RANGE.')
         CALL DPWRST('XXX','BUG ')
         GOTO9999
      ENDIF
      IF (STREND .LT. 1 .OR. STREND .GT. LEN(HX(1))) THEN
         IER = 6
         WRITE(ICOUT,999)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,901)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,961)STREND
  961    FORMAT('      THE STRING END, ',I8,' IS OUT-OF-RANGE.')
         CALL DPWRST('XXX','BUG ')
         GOTO9999
      ENDIF
C
C     Initialize permutation vector
C
      DO 10 I=1,NN
         IPERM(I) = I
   10 CONTINUE
C
C     Return if only one value is to be sorted
C
      IF (NN .EQ. 1) RETURN
C
C     Sort HX only
C
      M = 1
      I = 1
      J = NN
      R = .375E0
C
   20 IF (I .EQ. J) GO TO 70
      IF (R .LE. 0.5898437E0) THEN
         R = R+3.90625E-2
      ELSE
         R = R-0.21875E0
      ENDIF
C
   30 K = I
C
C     Select a central element of the array and save it in location L
C
      IJ = I + INT((J-I)*R)
      LM = IPERM(IJ)
C
C     If first element of array is greater than LM, interchange with LM
C
      IF (HX(IPERM(I))(STRBEG:STREND) .GT. HX(LM)(STRBEG:STREND)) THEN
         IPERM(IJ) = IPERM(I)
         IPERM(I) = LM
         LM = IPERM(IJ)
      ENDIF
      L = J
C
C     If last element of array is less than LM, interchange with LM
C
      IF (HX(IPERM(J))(STRBEG:STREND) .LT. HX(LM)(STRBEG:STREND)) THEN
         IPERM(IJ) = IPERM(J)
         IPERM(J) = LM
         LM = IPERM(IJ)
C
C        If first element of array is greater than LM, interchange
C        with LM
C
         IF (HX(IPERM(I))(STRBEG:STREND) .GT. HX(LM)(STRBEG:STREND))
     +      THEN
               IPERM(IJ) = IPERM(I)
               IPERM(I) = LM
               LM = IPERM(IJ)
         ENDIF
      ENDIF
      GO TO 50
   40 LMT = IPERM(L)
      IPERM(L) = IPERM(K)
      IPERM(K) = LMT
C
C     Find an element in the second half of the array which is smaller
C     than LM
C
   50 L = L-1
      IF (HX(IPERM(L))(STRBEG:STREND) .GT. HX(LM)(STRBEG:STREND))
     +    GO TO 50
C
C     Find an element in the first half of the array which is greater
C     than LM
C
   60 K = K+1
      IF (HX(IPERM(K))(STRBEG:STREND) .LT. HX(LM)(STRBEG:STREND))
     +   GO TO 60
C
C     Interchange these elements
C
      IF (K .LE. L) GO TO 40
C
C     Save upper and lower subscripts of the array yet to be sorted
C
      IF (L-I .GT. J-K) THEN
         IL(M) = I
         IU(M) = L
         I = K
         M = M+1
      ELSE
         IL(M) = K
         IU(M) = J
         J = L
         M = M+1
      ENDIF
      GO TO 80
C
C     Begin again on another portion of the unsorted array
C
   70 M = M-1
      IF (M .EQ. 0) GO TO 110
      I = IL(M)
      J = IU(M)
C
   80 IF (J-I .GE. 1) GO TO 30
      IF (I .EQ. 1) GO TO 20
      I = I-1
C
   90 I = I+1
      IF (I .EQ. J) GO TO 70
      LM = IPERM(I+1)
      IF (HX(IPERM(I))(STRBEG:STREND) .LE. HX(LM)(STRBEG:STREND))
     +   GO TO 90
      K = I
C
  100 IPERM(K+1) = IPERM(K)
      K = K-1
C
      IF (HX(LM)(STRBEG:STREND) .LT. HX(IPERM(K))(STRBEG:STREND))
     +    GO TO 100
      IPERM(K+1) = LM
      GO TO 90
C
C     Clean up
C
  110 IF (KFLAG .LE. -1) THEN
C
C        Alter array to get reverse order, if necessary
C
         NN2 = NN/2
         DO 120 I=1,NN2
           IR = NN-I+1
           LM = IPERM(I)
           IPERM(I) = IPERM(IR)
           IPERM(IR) = LM
  120    CONTINUE
      ENDIF
C
C     Rearrange the values of HX if desired
C
      IF (KK .EQ. 2) THEN
C
C        Use the IPERM vector as a flag.
C        If IPERM(I) < 0, then the I-th value is in correct location
C
         DO 140 ISTRT=1,NN
            IF (IPERM(ISTRT) .GE. 0) THEN
               INDX = ISTRT
               INDX0 = INDX
               WORK = HX(ISTRT)
  130          IF (IPERM(INDX) .GT. 0) THEN
                  HX(INDX) = HX(IPERM(INDX))
                  INDX0 = INDX
                  IPERM(INDX) = -IPERM(INDX)
                  INDX = ABS(IPERM(INDX))
                  GO TO 130
               ENDIF
               HX(INDX0) = WORK
            ENDIF
  140    CONTINUE
C
C        Revert the signs of the IPERM values
C
         DO 150 I=1,NN
            IPERM(I) = -IPERM(I)
  150    CONTINUE
C
      ENDIF
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE HPTRPT(IXC,IYC,ICSTR,NCSTR,ISUBN0)
C
C     PURPOSE--TRANSLATE AN INTEGER PAIR OF COORDINATES
C              (HP MBP = MULTIPLE BYTE PAIR OF NUMBERS)
C              INTO A 5-BYTE PACKED CHARACTER REPRESENTATION
C              THAT WILL BE UNDERSTOOD BY A HEWLETT-PACKARD
C              GRAPHICS DEVICE.
C     NOTE--THE RESULTING PACKED WORDS
C           WILL BE PLACED IN SPECIFIC ELEMENTS
C           OF THE CHARACTER*130 VARIABLE ICSTR(.:.).
C           THE VALUE OF THE VARIABLE    NCSTR
C           REPRESENTS THE NUMBER OF ELEMENTS IN ICSTR(.:.)
C           THAT HAVE ALREADY BEEN FILLED.
C           THE RESULTING PACKED WORDS WILL GO INTO
C           THE NEXT AVAILABLE ELEMENTS OF ICSTR(.:.)
C           AND THE VALUE OF    NCSTR    WILL BE
C           UPDATED ACCORDINGLY.
C     NOTE--MORE COMPACT (1 TO 4-BYTE REPRESENTATIONS)
C           ARE POSSIBLE FOR HP DEVICES FOR SMALLER
C           RANGES (0 TO 3, 0 TO 31, 0 TO 255, AND
C           0 TO 2047, RESPECTIVELY) OF THE INPUT X AND Y
C           COORDINATES.
C           THIS SUBROUTINE IS GENERAL AND TREATS ALL
C           X AND Y VALUES FROM 0 TO 2**14-1 (= 16383).
C           THE OUTPUT WILL THUS ALWAYS BE A 5-BYTE
C           REPRESENTATION.
C     DANGER--NCSTR IS BOTH AN INPUT ARGUMENT
C             AND AN OUTPUT ARGUMENT OF THIS SUBROUTINE.
C     NOTE--ISUBN0 = NAME OF SUBROUTINE WHICH CALLED HPTRPT
C                    (AND THEREBY HAVE WALKBACK INFORMATION).
C     REFERENCE--HP 7221 C AND HP 7221T GRAPHICS PLOTTER
C                OPERATING AND PROGRAMMING MANUAL,
C                PAGES 71-72 AND 319.
C
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           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)--MARCH     1984.
C
C-----NON-COMMON VARIABLES (GRAPHICS)-------------------------------------------
C
      CHARACTER*4 ISUBN0
C
      CHARACTER*130 ICSTR
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOGR.INC'
      INCLUDE 'DPCOBE.INC'
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----DATA STATEMENTS-----------------------------------------------
C
      DATA K2/4/
      DATA K4/16/
      DATA K6/64/
      DATA K10/1024/
      DATA K12/4096/
C
C-----START POINT-----------------------------------------------------
C
      IERRG4='NO'
C
      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'TRPT')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF HPTRPT--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)ISUBN0
   52 FORMAT('ISUBN0 (NAME OF THE CALLING SUBROUTINE) = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)IXC,IYC
   53 FORMAT('IXC,IYC = ',2I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,55)K2,K4,K6,K10,K12
   55 FORMAT('K2,K4,K6,K10,K12 = ',5I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,56)IGUNIT
   56 FORMAT('IGUNIT = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,63)NCSTR
   63 FORMAT('NCSTR = ',I8)
      CALL DPWRST('XXX','BUG ')
      IF(NCSTR.LE.0)GOTO67
      DO65I=1,NCSTR
CCCCC IASCNE=ICHAR(ICSTR(I:I))
      CALL DPCOAN(ICSTR(I:I),IASCNE)
      WRITE(ICOUT,66)I,ICSTR(I:I),IASCNE
   66 FORMAT('I,ICSTR(I:I),IASCNE = ',I8,2X,A1,I8)
      CALL DPWRST('XXX','BUG ')
   65 CONTINUE
   67 CONTINUE
      WRITE(ICOUT,69)IBUGG4,ISUBG4,IERRG4
   69 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
   90 CONTINUE
C
      IVX=IXC
      IVY=IYC
      IF(IVX.LT.0)IVX=0
      IF(IVY.LT.0)IVY=0
C
C               ******************************************************
C               **  STEP 1--                                        **
C               **  FORM THE HIGH-X 7-BIT BYTE--                    **
C               **  THE LEFT 3 BITS ARE 1 1 0;                      **
C               **  THE RIGHT 4 BITS = BITS 13 TO 10 OF X.          **
C               **  SHIFT THE X VALUE TO THE RIGHT 10 PLACES;       **
C               **  THEN KEEP ONLY THE RIGHT 4 PLACES;              **
C               **  THEN PLACE A 1 1 0 IN BITS 6, 5, AND 4          **
C               **  (WHERE BIT 6 = LEFT-MOST BIT IN A 7-BIT BYTE).  **
C               ******************************************************
C
      NCSTR=NCSTR+1
      IBYTE1=MOD(IVX/K10,K4)+96
CCCCC ICSTR(NCSTR:NCSTR)=CHAR(IBYTE1)
      CALL DPCONA(IBYTE1,ICSTR(NCSTR:NCSTR))
C
C               ***************************************************************
C               **  STEP 2--                                                 **
C               **  FORM THE MIDDLE-X 7-BIT BYTE--                           **
C               **  THE LEFT BIT IS THE COMPLEMENT OF THE NEXT-TO-LEFT BIT;  **
C               **  THE RIGHT 6 BITS = BITS 9 TO 4 OF X.                     **
C               **  SHIFT THE X VALUE TO THE RIGHT 4 PLACES;                 **
C               **  THEN KEEP ONLY THE RIGHT 6 PLACES;                       **
C               **  THEN IF NEW BIT 5 = 0, PLACE A 1 IN NEW BIT 6,           **
C               **  OR   IF NEW BIT 5 = 1, PLACE A 0 IN NEW BIT 6.           **
C               ***************************************************************
C
      NCSTR=NCSTR+1
      IBYTE2=MOD(IVX/K4,K6)
      IF(IBYTE2.LE.31)IBYTE2=IBYTE2+64
CCCCC ICSTR(NCSTR:NCSTR)=CHAR(IBYTE2)
      CALL DPCONA(IBYTE2,ICSTR(NCSTR:NCSTR))
C
C               ***************************************************************
C               **  STEP 3--                                                 **
C               **  FORM THE SHARED (LOW-X, HIGH Y) 7-BIT BYTE--             **
C               **  THE LEFT BIT IS THE COMPLEMENT OF THE NEXT-TO-LEFT BIT;  **
C               **  THE NEXT 4 BITS = BITS 3 TO 0 OF X;                      **
C               **  THE RIGHT 2 BITS = BITS 13 AND 12 OF Y.                  **
C               **  KEEP ONLY THE RIGHT 4 BITS OF X;                         **
C               **  SHIFT THESE 4 BITS TO THE LEFT 2 PLACES;                 **
C               **  SHIFT THE Y VALUE TO THE RIGHT 12 PLACES;                **
C               **  THEN KEEP ONLY THE RIGHT 2 BITS;                         **
C               **  THEN MERGE THE 4 X BITS AND THE 2 Y BITS;                **
C               **  FINALLY, IF NEW BIT 5 = 0, PLACE A 1 IN NEW BIT 6,       **
C               **  OR       IF NEW BIT 5 = 1, PLACE A 0 IN NEW BIT 6.       **
C               ***************************************************************
C
      NCSTR=NCSTR+1
      IBYTE3=MOD(IVX,K4)*K2+MOD(IVY/K12,K2)
      IF(IBYTE3.LE.31)IBYTE3=IBYTE3+64
CCCCC ICSTR(NCSTR:NCSTR)=CHAR(IBYTE3)
      CALL DPCONA(IBYTE3,ICSTR(NCSTR:NCSTR))
C
C               ***************************************************************
C               **  STEP 4--                                                 **
C               **  FORM THE MIDDLE-Y 7-BIT BYTE--                           **
C               **  THE LEFT BIT IS THE COMPLEMENT OF THE NEXT-TO-LEFT BIT;  **
C               **  THE RIGHT 6 BITS = BITS 11 TO 6 OF Y.                    **
C               **  SHIFT THE Y VALUE 6 PLACES TO THE RIGHT;                 **
C               **  THEN KEEP ONLY THE RIGHT 6 PLACES;                       **
C               **  THEN IF NEW BIT 5 = 0, PLACE A 1 IN NEW BIT 6,           **
C               **  OR   IF NEW BIT 5 = 1, PLACE A 0 IN NEW BIT 6.           **
C               ***************************************************************
C
      NCSTR=NCSTR+1
      IBYTE4=MOD(IVY/K6,K6)
      IF(IBYTE4.LE.31)IBYTE4=IBYTE4+64
CCCCC ICSTR(NCSTR:NCSTR)=CHAR(IBYTE4)
      CALL DPCONA(IBYTE4,ICSTR(NCSTR:NCSTR))
C
C               ***************************************************************
C               **  STEP 5--                                                 **
C               **  FORM THE LOW-Y 7-BIT BYTE--                              **
C               **  THE LEFT BIT IS THE COMPLEMENT OF THE NEXT-TO-LEFT BIT;  **
C               **  THE RIGHT 6 BITS = BITS 5 TO 0 OF Y.                     **
C               **  KEEP ONLY THE RIGHT 6 BITS OF Y;                         **
C               **  THEN IF NEW BIT 5 = 0, PLACE A 1 IN NEW BIT 6,           **
C               **  OR   IF NEW BIT 5 = 1, PLACE A 0 IN NEW BIT 6.           **
C               ***************************************************************
C
      NCSTR=NCSTR+1
      IBYTE5=MOD(IVY,K6)
      IF(IBYTE5.LE.31)IBYTE5=IBYTE5+64
CCCCC ICSTR(NCSTR:NCSTR)=CHAR(IBYTE5)
      CALL DPCONA(IBYTE5,ICSTR(NCSTR:NCSTR))
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'TRPT')GOTO9090
 9011 FORMAT('***** AT THE END       OF TKTRPT--')
      WRITE(ICOUT,9012)IXC,IYC
 9012 FORMAT('IXC,IYC = ',2I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)IVX,IVY
 9013 FORMAT('IVX,IVY = ',2I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9015)K2,K4,K6,K10,K12
 9015 FORMAT('K2,K4,K6,K10,K12 = ',5I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9016)IGUNIT
 9016 FORMAT('IGUNIT = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9017)IBYTE1,IBYTE2,IBYTE3,IBYTE4,IBYTE5
 9017 FORMAT('IBYTE1,IBYTE2,IBYTE3,IBYTE4,IBYTE5 = ',5I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9023)NCSTR
 9023 FORMAT('NCSTR = ',I8)
      CALL DPWRST('XXX','BUG ')
      IF(NCSTR.LE.0)GOTO9027
      DO9025I=1,NCSTR
CCCCC IASCNE=ICHAR(ICSTR(I:I))
      CALL DPCOAN(ICSTR(I:I),IASCNE)
      WRITE(ICOUT,9026)I,ICSTR(I:I),IASCNE
 9026 FORMAT('I,ICSTR(I:I),IASCNE = ',I8,2X,A1,I8)
      CALL DPWRST('XXX','BUG ')
 9025 CONTINUE
 9027 CONTINUE
      WRITE(ICOUT,9029)IBUGG4,ISUBG4,IERRG4
 9029 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE HQR(NM,N,LOW,IGH,H,WR,WI,IERR)
C***BEGIN PROLOGUE  HQR
C***DATE WRITTEN   760101   (YYMMDD)
C***REVISION DATE  830518   (YYMMDD)
C***CATEGORY NO.  D4C2B
C***KEYWORDS  EIGENVALUES,EIGENVECTORS,EISPACK
C***AUTHOR  SMITH, B. T., ET AL.
C***PURPOSE  Computes eigenvalues of a real upper Hessenberg matrix
C            using the QR method.
C***DESCRIPTION
C
C     This subroutine is a translation of the ALGOL procedure HQR,
C     NUM. MATH. 14, 219-231(1970) by Martin, Peters, and Wilkinson.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 359-371(1971).
C
C     This subroutine finds the eigenvalues of a REAL
C     UPPER Hessenberg matrix by the QR method.
C
C     On INPUT
C
C        NM must be set to the row dimension of two-dimensional
C          array parameters as declared in the calling program
C          dimension statement.
C
C        N is the order of the matrix.
C
C        LOW and IGH are integers determined by the balancing
C          subroutine  BALANC.  If  BALANC  has not been used,
C          set LOW=1, IGH=N.
C
C        H contains the upper Hessenberg matrix.  Information about
C          the transformations used in the reduction to Hessenberg
C          form by  ELMHES  or  ORTHES, if performed, is stored
C          in the remaining triangle under the Hessenberg matrix.
C
C     On OUTPUT
C
C        H has been destroyed.  Therefore, it must be saved
C          before calling  HQR  if subsequent calculation and
C          back transformation of eigenvectors is to be performed.
C
C        WR and WI contain the real and imaginary parts,
C          respectively, of the eigenvalues.  The eigenvalues
C          are unordered except that complex conjugate pairs
C          of values appear consecutively with the eigenvalue
C          having the positive imaginary part first.  If an
C          error exit is made, the eigenvalues should be correct
C          for indices IERR+1,...,N.
C
C        IERR is set to
C          Zero       for normal return,
C          J          if the J-th eigenvalue has not been
C                     determined after a total of 30*N iterations.
C
C     Questions and comments should be directed to B. S. Garbow,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C     ------------------------------------------------------------------
C***REFERENCES  B. T. SMITH, J. M. BOYLE, J. J. DONGARRA, B. S. GARBOW,
C                 Y. IKEBE, V. C. KLEMA, C. B. MOLER, *MATRIX EIGEN-
C                 SYSTEM ROUTINES - EISPACK GUIDE*, SPRINGER-VERLAG,
C                 1976.
C***ROUTINES CALLED  (NONE)
C***END PROLOGUE  HQR
C
      INTEGER I,J,K,L,M,N,EN,LL,MM,NA,NM,IGH,ITN,ITS,LOW,MP2,ENM2,IERR
      REAL H(NM,N),WR(N),WI(N)
      REAL P,Q,R,S,T,W,X,Y,ZZ,NORM,S1,S2
      LOGICAL NOTLAS
C
C***FIRST EXECUTABLE STATEMENT  HQR
      IERR = 0
      NORM = 0.0E0
      K = 1
C     .......... STORE ROOTS ISOLATED BY BALANC
C                AND COMPUTE MATRIX NORM ..........
      DO 50 I = 1, N
C
         DO 40 J = K, N
   40    NORM = NORM + ABS(H(I,J))
C
         K = I
         IF (I .GE. LOW .AND. I .LE. IGH) GO TO 50
         WR(I) = H(I,I)
         WI(I) = 0.0E0
   50 CONTINUE
C
      EN = IGH
      T = 0.0E0
      ITN = 30*N
C     .......... SEARCH FOR NEXT EIGENVALUES ..........
   60 IF (EN .LT. LOW) GO TO 1001
      ITS = 0
      NA = EN - 1
      ENM2 = NA - 1
C     .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
C                FOR L=EN STEP -1 UNTIL LOW DO -- ..........
   70 DO 80 LL = LOW, EN
         L = EN + LOW - LL
         IF (L .EQ. LOW) GO TO 100
         S = ABS(H(L-1,L-1)) + ABS(H(L,L))
         IF (S .EQ. 0.0E0) S = NORM
         S2 = S + ABS(H(L,L-1))
         IF (S2 .EQ. S) GO TO 100
   80 CONTINUE
C     .......... FORM SHIFT ..........
  100 X = H(EN,EN)
      IF (L .EQ. EN) GO TO 270
      Y = H(NA,NA)
      W = H(EN,NA) * H(NA,EN)
      IF (L .EQ. NA) GO TO 280
      IF (ITN .EQ. 0) GO TO 1000
      IF (ITS .NE. 10 .AND. ITS .NE. 20) GO TO 130
C     .......... FORM EXCEPTIONAL SHIFT ..........
      T = T + X
C
      DO 120 I = LOW, EN
  120 H(I,I) = H(I,I) - X
C
      S = ABS(H(EN,NA)) + ABS(H(NA,ENM2))
      X = 0.75E0 * S
      Y = X
      W = -0.4375E0 * S * S
  130 ITS = ITS + 1
      ITN = ITN - 1
C     .......... LOOK FOR TWO CONSECUTIVE SMALL
C                SUB-DIAGONAL ELEMENTS.
C                FOR M=EN-2 STEP -1 UNTIL L DO -- ..........
      DO 140 MM = L, ENM2
         M = ENM2 + L - MM
         ZZ = H(M,M)
         R = X - ZZ
         S = Y - ZZ
         P = (R * S - W) / H(M+1,M) + H(M,M+1)
         Q = H(M+1,M+1) - ZZ - R - S
         R = H(M+2,M+1)
         S = ABS(P) + ABS(Q) + ABS(R)
         P = P / S
         Q = Q / S
         R = R / S
         IF (M .EQ. L) GO TO 150
         S1 = ABS(P) * (ABS(H(M-1,M-1)) + ABS(ZZ) + ABS(H(M+1,M+1)))
         S2 = S1 + ABS(H(M,M-1)) * (ABS(Q) + ABS(R))
         IF (S2 .EQ. S1) GO TO 150
  140 CONTINUE
C
  150 MP2 = M + 2
C
      DO 160 I = MP2, EN
         H(I,I-2) = 0.0E0
         IF (I .EQ. MP2) GO TO 160
         H(I,I-3) = 0.0E0
  160 CONTINUE
C     .......... DOUBLE QR STEP INVOLVING ROWS L TO EN AND
C                COLUMNS M TO EN ..........
      DO 260 K = M, NA
         NOTLAS = K .NE. NA
         IF (K .EQ. M) GO TO 170
         P = H(K,K-1)
         Q = H(K+1,K-1)
         R = 0.0E0
         IF (NOTLAS) R = H(K+2,K-1)
         X = ABS(P) + ABS(Q) + ABS(R)
         IF (X .EQ. 0.0E0) GO TO 260
         P = P / X
         Q = Q / X
         R = R / X
  170    S = SIGN(SQRT(P*P+Q*Q+R*R),P)
         IF (K .EQ. M) GO TO 180
         H(K,K-1) = -S * X
         GO TO 190
  180    IF (L .NE. M) H(K,K-1) = -H(K,K-1)
  190    P = P + S
         X = P / S
         Y = Q / S
         ZZ = R / S
         Q = Q / P
         R = R / P
C     .......... ROW MODIFICATION ..........
         DO 210 J = K, EN
            P = H(K,J) + Q * H(K+1,J)
            IF (.NOT. NOTLAS) GO TO 200
            P = P + R * H(K+2,J)
            H(K+2,J) = H(K+2,J) - P * ZZ
  200       H(K+1,J) = H(K+1,J) - P * Y
            H(K,J) = H(K,J) - P * X
  210    CONTINUE
C
         J = MIN0(EN,K+3)
C     .......... COLUMN MODIFICATION ..........
         DO 230 I = L, J
            P = X * H(I,K) + Y * H(I,K+1)
            IF (.NOT. NOTLAS) GO TO 220
            P = P + ZZ * H(I,K+2)
            H(I,K+2) = H(I,K+2) - P * R
  220       H(I,K+1) = H(I,K+1) - P * Q
            H(I,K) = H(I,K) - P
  230    CONTINUE
C
  260 CONTINUE
C
      GO TO 70
C     .......... ONE ROOT FOUND ..........
  270 WR(EN) = X + T
      WI(EN) = 0.0E0
      EN = NA
      GO TO 60
C     .......... TWO ROOTS FOUND ..........
  280 P = (Y - X) / 2.0E0
      Q = P * P + W
      ZZ = SQRT(ABS(Q))
      X = X + T
      IF (Q .LT. 0.0E0) GO TO 320
C     .......... REAL PAIR ..........
      ZZ = P + SIGN(ZZ,P)
      WR(NA) = X + ZZ
      WR(EN) = WR(NA)
      IF (ZZ .NE. 0.0E0) WR(EN) = X - W / ZZ
      WI(NA) = 0.0E0
      WI(EN) = 0.0E0
      GO TO 330
C     .......... COMPLEX PAIR ..........
  320 WR(NA) = X + P
      WR(EN) = X + P
      WI(NA) = ZZ
      WI(EN) = -ZZ
  330 EN = ENM2
      GO TO 60
C     .......... SET ERROR -- NO CONVERGENCE TO AN
C                EIGENVALUE AFTER 30*N ITERATIONS ..........
 1000 IERR = EN
 1001 RETURN
      END
      SUBROUTINE HQR2(NM,N,LOW,IGH,H,WR,WI,Z,IERR)
C***BEGIN PROLOGUE  HQR2
C***DATE WRITTEN   760101   (YYMMDD)
C***REVISION DATE  830518   (YYMMDD)
C***CATEGORY NO.  D4C2B
C***KEYWORDS  EIGENVALUES,EIGENVECTORS,EISPACK
C***AUTHOR  SMITH, B. T., ET AL.
C***PURPOSE  Computes eigenvalues and eigenvectors of real upper
C            Hessenberg matrix using QR method.
C***DESCRIPTION
C
C     This subroutine is a translation of the ALGOL procedure HQR2,
C     NUM. MATH. 16, 181-204(1970) by Peters and Wilkinson.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971).
C
C     This subroutine finds the eigenvalues and eigenvectors
C     of a REAL UPPER Hessenberg matrix by the QR method.  The
C     eigenvectors of a REAL GENERAL matrix can also be found
C     if  ELMHES  and  ELTRAN  or  ORTHES  and  ORTRAN  have
C     been used to reduce this general matrix to Hessenberg form
C     and to accumulate the similarity transformations.
C
C     On INPUT
C
C        NM must be set to the row dimension of two-dimensional
C          array parameters as declared in the calling program
C          dimension statement.
C
C        N is the order of the matrix.
C
C        LOW and IGH are integers determined by the balancing
C          subroutine  BALANC.  If  BALANC  has not been used,
C          set LOW=1, IGH=N.
C
C        H contains the upper Hessenberg matrix.
C
C        Z contains the transformation matrix produced by  ELTRAN
C          after the reduction by  ELMHES, or by  ORTRAN  after the
C          reduction by  ORTHES, if performed.  If the eigenvectors
C          of the Hessenberg matrix are desired, Z must contain the
C          identity matrix.
C
C     On OUTPUT
C
C        H has been destroyed.
C
C        WR and WI contain the real and imaginary parts,
C          respectively, of the eigenvalues.  The eigenvalues
C          are unordered except that complex conjugate pairs
C          of values appear consecutively with the eigenvalue
C          having the positive imaginary part first.  If an
C          error exit is made, the eigenvalues should be correct
C          for indices IERR+1,...,N.
C
C        Z contains the real and imaginary parts of the eigenvectors.
C          If the I-th eigenvalue is real, the I-th column of Z
C          contains its eigenvector.  If the I-th eigenvalue is complex
C          with positive imaginary part, the I-th and (I+1)-th
C          columns of Z contain the real and imaginary parts of its
C          eigenvector.  The eigenvectors are unnormalized.  If an
C          error exit is made, none of the eigenvectors has been found.
C
C        IERR is set to
C          Zero       for normal return,
C          J          if the J-th eigenvalue has not been
C                     determined after a total of 30*N iterations.
C
C     Calls CDIV for complex division.
C
C     Questions and comments should be directed to B. S. Garbow,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C     ------------------------------------------------------------------
C***REFERENCES  B. T. SMITH, J. M. BOYLE, J. J. DONGARRA, B. S. GARBOW,
C                 Y. IKEBE, V. C. KLEMA, C. B. MOLER, *MATRIX EIGEN-
C                 SYSTEM ROUTINES - EISPACK GUIDE*, SPRINGER-VERLAG,
C                 1976.
C***ROUTINES CALLED  CDIV
C***END PROLOGUE  HQR2
C
      INTEGER I,J,K,L,M,N,EN,II,JJ,LL,MM,NA,NM,NN
      INTEGER IGH,ITN,ITS,LOW,MP2,ENM2,IERR
      REAL H(NM,N),WR(N),WI(N),Z(NM,N)
      REAL P,Q,R,S,T,W,X,Y,RA,SA,VI,VR,ZZ,NORM,S1
      LOGICAL NOTLAS
C
C***FIRST EXECUTABLE STATEMENT  HQR2
      IERR = 0
      NORM = 0.0E0
      K = 1
C     .......... STORE ROOTS ISOLATED BY BALANC
C                AND COMPUTE MATRIX NORM ..........
      DO 50 I = 1, N
C
         DO 40 J = K, N
   40    NORM = NORM + ABS(H(I,J))
C
         K = I
         IF (I .GE. LOW .AND. I .LE. IGH) GO TO 50
         WR(I) = H(I,I)
         WI(I) = 0.0E0
   50 CONTINUE
C
      EN = IGH
      T = 0.0E0
      ITN = 30*N
C     .......... SEARCH FOR NEXT EIGENVALUES ..........
   60 IF (EN .LT. LOW) GO TO 340
      ITS = 0
      NA = EN - 1
      ENM2 = NA - 1
C     .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
C                FOR L=EN STEP -1 UNTIL LOW DO -- ..........
   70 DO 80 LL = LOW, EN
         L = EN + LOW - LL
         IF (L .EQ. LOW) GO TO 100
         S = ABS(H(L-1,L-1)) + ABS(H(L,L))
         IF (S .EQ. 0.0E0) S = NORM
         S2 = S + ABS(H(L,L-1))
         IF (S2 .EQ. S) GO TO 100
   80 CONTINUE
C     .......... FORM SHIFT ..........
  100 X = H(EN,EN)
      IF (L .EQ. EN) GO TO 270
      Y = H(NA,NA)
      W = H(EN,NA) * H(NA,EN)
      IF (L .EQ. NA) GO TO 280
      IF (ITN .EQ. 0) GO TO 1000
      IF (ITS .NE. 10 .AND. ITS .NE. 20) GO TO 130
C     .......... FORM EXCEPTIONAL SHIFT ..........
      T = T + X
C
      DO 120 I = LOW, EN
  120 H(I,I) = H(I,I) - X
C
      S = ABS(H(EN,NA)) + ABS(H(NA,ENM2))
      X = 0.75E0 * S
      Y = X
      W = -0.4375E0 * S * S
  130 ITS = ITS + 1
      ITN = ITN - 1
C     .......... LOOK FOR TWO CONSECUTIVE SMALL
C                SUB-DIAGONAL ELEMENTS.
C                FOR M=EN-2 STEP -1 UNTIL L DO -- ..........
      DO 140 MM = L, ENM2
         M = ENM2 + L - MM
         ZZ = H(M,M)
         R = X - ZZ
         S = Y - ZZ
         P = (R * S - W) / H(M+1,M) + H(M,M+1)
         Q = H(M+1,M+1) - ZZ - R - S
         R = H(M+2,M+1)
         S = ABS(P) + ABS(Q) + ABS(R)
         P = P / S
         Q = Q / S
         R = R / S
         IF (M .EQ. L) GO TO 150
         S1 = ABS(P) * (ABS(H(M-1,M-1)) + ABS(ZZ) + ABS(H(M+1,M+1)))
         S2 = S1 + ABS(H(M,M-1)) * (ABS(Q) + ABS(R))
         IF (S2 .EQ. S1) GO TO 150
  140 CONTINUE
C
  150 MP2 = M + 2
C
      DO 160 I = MP2, EN
         H(I,I-2) = 0.0E0
         IF (I .EQ. MP2) GO TO 160
         H(I,I-3) = 0.0E0
  160 CONTINUE
C     .......... DOUBLE QR STEP INVOLVING ROWS L TO EN AND
C                COLUMNS M TO EN ..........
      DO 260 K = M, NA
         NOTLAS = K .NE. NA
         IF (K .EQ. M) GO TO 170
         P = H(K,K-1)
         Q = H(K+1,K-1)
         R = 0.0E0
         IF (NOTLAS) R = H(K+2,K-1)
         X = ABS(P) + ABS(Q) + ABS(R)
         IF (X .EQ. 0.0E0) GO TO 260
         P = P / X
         Q = Q / X
         R = R / X
  170    S = SIGN(SQRT(P*P+Q*Q+R*R),P)
         IF (K .EQ. M) GO TO 180
         H(K,K-1) = -S * X
         GO TO 190
  180    IF (L .NE. M) H(K,K-1) = -H(K,K-1)
  190    P = P + S
         X = P / S
         Y = Q / S
         ZZ = R / S
         Q = Q / P
         R = R / P
C     .......... ROW MODIFICATION ..........
         DO 210 J = K, N
            P = H(K,J) + Q * H(K+1,J)
            IF (.NOT. NOTLAS) GO TO 200
            P = P + R * H(K+2,J)
            H(K+2,J) = H(K+2,J) - P * ZZ
  200       H(K+1,J) = H(K+1,J) - P * Y
            H(K,J) = H(K,J) - P * X
  210    CONTINUE
C
         J = MIN0(EN,K+3)
C     .......... COLUMN MODIFICATION ..........
         DO 230 I = 1, J
            P = X * H(I,K) + Y * H(I,K+1)
            IF (.NOT. NOTLAS) GO TO 220
            P = P + ZZ * H(I,K+2)
            H(I,K+2) = H(I,K+2) - P * R
  220       H(I,K+1) = H(I,K+1) - P * Q
            H(I,K) = H(I,K) - P
  230    CONTINUE
C     .......... ACCUMULATE TRANSFORMATIONS ..........
         DO 250 I = LOW, IGH
            P = X * Z(I,K) + Y * Z(I,K+1)
            IF (.NOT. NOTLAS) GO TO 240
            P = P + ZZ * Z(I,K+2)
            Z(I,K+2) = Z(I,K+2) - P * R
  240       Z(I,K+1) = Z(I,K+1) - P * Q
            Z(I,K) = Z(I,K) - P
  250    CONTINUE
C
  260 CONTINUE
C
      GO TO 70
C     .......... ONE ROOT FOUND ..........
  270 H(EN,EN) = X + T
      WR(EN) = H(EN,EN)
      WI(EN) = 0.0E0
      EN = NA
      GO TO 60
C     .......... TWO ROOTS FOUND ..........
  280 P = (Y - X) / 2.0E0
      Q = P * P + W
      ZZ = SQRT(ABS(Q))
      H(EN,EN) = X + T
      X = H(EN,EN)
      H(NA,NA) = Y + T
      IF (Q .LT. 0.0E0) GO TO 320
C     .......... REAL PAIR ..........
      ZZ = P + SIGN(ZZ,P)
      WR(NA) = X + ZZ
      WR(EN) = WR(NA)
      IF (ZZ .NE. 0.0E0) WR(EN) = X - W / ZZ
      WI(NA) = 0.0E0
      WI(EN) = 0.0E0
      X = H(EN,NA)
      S = ABS(X) + ABS(ZZ)
      P = X / S
      Q = ZZ / S
      R = SQRT(P*P+Q*Q)
      P = P / R
      Q = Q / R
C     .......... ROW MODIFICATION ..........
      DO 290 J = NA, N
         ZZ = H(NA,J)
         H(NA,J) = Q * ZZ + P * H(EN,J)
         H(EN,J) = Q * H(EN,J) - P * ZZ
  290 CONTINUE
C     .......... COLUMN MODIFICATION ..........
      DO 300 I = 1, EN
         ZZ = H(I,NA)
         H(I,NA) = Q * ZZ + P * H(I,EN)
         H(I,EN) = Q * H(I,EN) - P * ZZ
  300 CONTINUE
C     .......... ACCUMULATE TRANSFORMATIONS ..........
      DO 310 I = LOW, IGH
         ZZ = Z(I,NA)
         Z(I,NA) = Q * ZZ + P * Z(I,EN)
         Z(I,EN) = Q * Z(I,EN) - P * ZZ
  310 CONTINUE
C
      GO TO 330
C     .......... COMPLEX PAIR ..........
  320 WR(NA) = X + P
      WR(EN) = X + P
      WI(NA) = ZZ
      WI(EN) = -ZZ
  330 EN = ENM2
      GO TO 60
C     .......... ALL ROOTS FOUND.  BACKSUBSTITUTE TO FIND
C                VECTORS OF UPPER TRIANGULAR FORM ..........
  340 IF (NORM .EQ. 0.0E0) GO TO 1001
C     .......... FOR EN=N STEP -1 UNTIL 1 DO -- ..........
      DO 800 NN = 1, N
         EN = N + 1 - NN
         P = WR(EN)
         Q = WI(EN)
         NA = EN - 1
         IF (Q) 710, 600, 800
C     .......... REAL VECTOR ..........
  600    M = EN
         H(EN,EN) = 1.0E0
         IF (NA .EQ. 0) GO TO 800
C     .......... FOR I=EN-1 STEP -1 UNTIL 1 DO -- ..........
         DO 700 II = 1, NA
            I = EN - II
            W = H(I,I) - P
            R = H(I,EN)
            IF (M .GT. NA) GO TO 620
C
            DO 610 J = M, NA
  610       R = R + H(I,J) * H(J,EN)
C
  620       IF (WI(I) .GE. 0.0E0) GO TO 630
            ZZ = W
            S = R
            GO TO 700
  630       M = I
            IF (WI(I) .NE. 0.0E0) GO TO 640
            T = W
            IF (T .NE. 0.0E0) GO TO 635
            T = NORM
  632       T = 0.5E0*T
            IF (NORM + T .GT. NORM) GO TO 632
            T = 2.0E0*T
  635       H(I,EN) = -R / T
            GO TO 700
C     .......... SOLVE REAL EQUATIONS ..........
  640       X = H(I,I+1)
            Y = H(I+1,I)
            Q = (WR(I) - P) * (WR(I) - P) + WI(I) * WI(I)
            T = (X * S - ZZ * R) / Q
            H(I,EN) = T
            IF (ABS(X) .LE. ABS(ZZ)) GO TO 650
            H(I+1,EN) = (-R - W * T) / X
            GO TO 700
  650       H(I+1,EN) = (-S - Y * T) / ZZ
  700    CONTINUE
C     .......... END REAL VECTOR ..........
         GO TO 800
C     .......... COMPLEX VECTOR ..........
  710    M = NA
C     .......... LAST VECTOR COMPONENT CHOSEN IMAGINARY SO THAT
C                EIGENVECTOR MATRIX IS TRIANGULAR ..........
         IF (ABS(H(EN,NA)) .LE. ABS(H(NA,EN))) GO TO 720
         H(NA,NA) = Q / H(EN,NA)
         H(NA,EN) = -(H(EN,EN) - P) / H(EN,NA)
         GO TO 730
  720    CALL CDIV(0.0E0,-H(NA,EN),H(NA,NA)-P,Q,H(NA,NA),H(NA,EN))
  730    H(EN,NA) = 0.0E0
         H(EN,EN) = 1.0E0
         ENM2 = NA - 1
         IF (ENM2 .EQ. 0) GO TO 800
C     .......... FOR I=EN-2 STEP -1 UNTIL 1 DO -- ..........
         DO 790 II = 1, ENM2
            I = NA - II
            W = H(I,I) - P
            RA = 0.0E0
            SA = H(I,EN)
C
            DO 760 J = M, NA
               RA = RA + H(I,J) * H(J,NA)
               SA = SA + H(I,J) * H(J,EN)
  760       CONTINUE
C
            IF (WI(I) .GE. 0.0E0) GO TO 770
            ZZ = W
            R = RA
            S = SA
            GO TO 790
  770       M = I
            IF (WI(I) .NE. 0.0E0) GO TO 780
            CALL CDIV(-RA,-SA,W,Q,H(I,NA),H(I,EN))
            GO TO 790
C     .......... SOLVE COMPLEX EQUATIONS ..........
  780       X = H(I,I+1)
            Y = H(I+1,I)
            VR = (WR(I) - P) * (WR(I) - P) + WI(I) * WI(I) - Q * Q
            VI = (WR(I) - P) * 2.0E0 * Q
            IF (VR .NE. 0.0E0 .OR. VI .NE. 0.0E0) GO TO 783
            S1 = NORM * (ABS(W)+ABS(Q)+ABS(X)+ABS(Y)+ABS(ZZ))
            VR = S1
  782       VR = 0.5E0*VR
            IF (S1 + VR .GT. S1) GO TO 782
            VR = 2.0E0*VR
  783       CALL CDIV(X*R-ZZ*RA+Q*SA,X*S-ZZ*SA-Q*RA,VR,VI,
     1                H(I,NA),H(I,EN))
            IF (ABS(X) .LE. ABS(ZZ) + ABS(Q)) GO TO 785
            H(I+1,NA) = (-RA - W * H(I,NA) + Q * H(I,EN)) / X
            H(I+1,EN) = (-SA - W * H(I,EN) - Q * H(I,NA)) / X
            GO TO 790
  785       CALL CDIV(-R-Y*H(I,NA),-S-Y*H(I,EN),ZZ,Q,
     1                H(I+1,NA),H(I+1,EN))
  790    CONTINUE
C     .......... END COMPLEX VECTOR ..........
  800 CONTINUE
C     .......... END BACK SUBSTITUTION.
C                VECTORS OF ISOLATED ROOTS ..........
      DO 840 I = 1, N
         IF (I .GE. LOW .AND. I .LE. IGH) GO TO 840
C
         DO 820 J = I, N
  820    Z(I,J) = H(I,J)
C
  840 CONTINUE
C     .......... MULTIPLY BY TRANSFORMATION MATRIX TO GIVE
C                VECTORS OF ORIGINAL FULL MATRIX.
C                FOR J=N STEP -1 UNTIL LOW DO -- ..........
      DO 880 JJ = LOW, N
         J = N + LOW - JJ
         M = MIN0(J,IGH)
C
         DO 880 I = LOW, IGH
            ZZ = 0.0E0
C
            DO 860 K = LOW, M
  860       ZZ = ZZ + Z(I,K) * H(K,J)
C
            Z(I,J) = ZZ
  880 CONTINUE
C
      GO TO 1001
C     .......... SET ERROR -- NO CONVERGENCE TO AN
C                EIGENVALUE AFTER 30*N ITERATIONS ..........
 1000 IERR = EN
 1001 RETURN
      END
      SUBROUTINE HSECDF(X,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE HYPERBOLIC SECANT DISTRIBUTION 
C              WITH MEAN = 0 AND STANDARD DEVIATION = PI/SQRT(3).
C              THIS DISTRIBUTION IS DEFINED FOR ALL X AND HAS
C              THE PROBABILITY DENSITY FUNCTION
C              F(X) = EXP(X)/(1+EXP(X)).
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C     OUTPUT ARGUMENTS--CDF    = THE SINGLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE CDF.
C     PRINTING--NONE.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--EXP.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN. 
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--2, 1994, PAGE 147
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE:  301-975-2855
C     ORIGINAL VERSION--OCTOBER   1995. 
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DATA PI / 3.1415926535/
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS.
C     NO INPUT ARGUMENT ERRORS POSSIBLE 
C     FOR THIS DISTRIBUTION.
C
C-----START POINT-----------------------------------------------------
C
      IF(X.GT.80.0)THEN
        CDF=1.0
        GOTO9999
      ELSEIF(X.LT.-80.0)THEN
        CDF=0.0
        GOTO9999
      ELSE
        ARG=X/2.0
        TERM1=(EXP(ARG)-EXP(-ARG))/(EXP(ARG)+EXP(-ARG))
        CDF=0.5 + (2.0/PI)*ATAN(TERM1)
      ENDIF
C
 9999 CONTINUE
      RETURN
      END 
      SUBROUTINE HSEPDF(X,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE HYPERBOLIC SECANT DISTRIBUTION 
C              THIS DISTRIBUTION IS DEFINED FOR ALL X AND HAS
C              THE PROBABILITY DENSITY FUNCTION
C              F(X) = SECH(X)/PI
C                   = (1/PI)*(2/(EXP(X) + EXP(-X))
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C     OUTPUT ARGUMENTS--PDF    = THE SINGLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE PDF.
C     PRINTING--NONE.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--EXP.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN. 
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--2, 1994, PAGE 147
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE:  301-975-2899
C     ORIGINAL VERSION--OCTOBER   1995. 
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX, DPDF, DPI
C
      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 DPI / 3.1415926535 8979323846 2643383279 503 D0 /
C
C---------------------------------------------------------------------
C
      DX=DBLE(X)
      IF(DABS(DX).GT.500.0D0)THEN
        PDF=0.0
      ELSE
        DPDF=2.0D0/(DEXP(DX) + DEXP(-DX))
        PDF=SNGL(DPDF/DPI)
      ENDIF
C
      RETURN
      END 
      SUBROUTINE HSEPPF(P,PPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE HYPERBOLIC SECANT DISTRIBUTION
C              THE PROBABILITY DENSITY FUNCTION IS
C              F(X) = SECH(X)/PI
C                   = (1/PI)*(2/(EXP(X) + EXP(-X))
C              NOTE THAT THE PERCENT POINT FUNCTION OF A DISTRIBUTION
C              IS IDENTICALLY THE SAME AS THE INVERSE CUMULATIVE
C              DISTRIBUTION FUNCTION OF THE DISTRIBUTION.
C     INPUT  ARGUMENTS--P      = THE SINGLE PRECISION VALUE
C                                (BETWEEN 0.0 AND 1.0)
C                                AT WHICH THE PERCENT POINT
C                                FUNCTION IS TO BE EVALUATED.
C     OUTPUT ARGUMENTS--PPF    = THE SINGLE PRECISION PERCENT
C                                POINT FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PERCENT POINT
C             FUNCTION VALUE PPF.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--P SHOULD BE BETWEEN 0.0 AND 1.0, EXCLUSIVELY.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--EXP.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C               --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--2, 1994, PAGE 147
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           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.10
C     ORIGINAL VERSION--OCTOBER   1995.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DARG
      DOUBLE PRECISION DPI
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DPPF
C
      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 DPI / 3.1415926535 8979323846 2643383279 503 D0 /
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(P.LE.0.0.OR.P.GE.1.0)GOTO50
      GOTO90
   50 WRITE(ICOUT,1)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)P
      CALL DPWRST('XXX','BUG ')
      RETURN
   90 CONTINUE
    1 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ',
     1'HSEPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
      DARG=DPI*(DBLE(P)-0.5D0)/2.0D0
      DTERM1=DTAN(DARG)
      DPPF=DLOG((1.0+DTERM1)/(1.0D0-DTERM1))
      PPF=SNGL(DPPF)
C
      RETURN
      END
      SUBROUTINE HSERAN(N,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE HYPERBOLIC SECANT DISTRIBUTION
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST N)
C                                INTO WHICH THE GENERATED
C                                RANDOM SAMPLE WILL BE PLACED.
C     OUTPUT--A RANDOM SAMPLE OF SIZE N
C             FROM THE HYPERBOLIC SECANT DISTRIBUTION
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           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               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--2001/10
C     ORIGINAL VERSION--OCTOBER   2001.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
C
C---------------------------------------------------------------------
C
      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)GOTO50
      GOTO90
   50 WRITE(ICOUT, 5)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,47)N
      CALL DPWRST('XXX','BUG ')
      RETURN
   90 CONTINUE
    5 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ',
     1'HSERAN SUBROUTINE IS NON-POSITIVE *****')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
C
C     GENERATE N UNIFORM (0,1) RANDOM NUMBERS;
C
      CALL UNIRAN(N,ISEED,X)
C
C     GENERATE N HYPERBOLIC SECANT RANDOM NUMBERS
C     USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD.
C
      DO100I=1,N
      CALL HSEPPF(X(I),XTEMP)
      X(I)=XTEMP
  100 CONTINUE
C
      RETURN
      END
      SUBROUTINE HSNINT(NR,N,A,SX,METHOD)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C PURPOSE
C -------
C PROVIDE INITIAL HESSIAN WHEN USING SECANT UPDATES
C
C PARAMETERS
C ----------
C NR           --> ROW DIMENSION OF MATRIX
C N            --> DIMENSION OF PROBLEM
C A(N,N)      <--  INITIAL HESSIAN (LOWER TRIANGULAR MATRIX)
C SX(N)        --> DIAGONAL SCALING MATRIX FOR X
C METHOD       --> ALGORITHM TO USE TO SOLVE MINIMIZATION PROBLEM
C                    =1,2 FACTORED SECANT METHOD USED
C                    =3   UNFACTORED SECANT METHOD USED
C
      DIMENSION A(NR,1),SX(N)
C
      DO 100 J=1,N
        IF(METHOD.EQ.3) A(J,J)=SX(J)*SX(J)
        IF(METHOD.NE.3) A(J,J)=SX(J)
        IF(J.EQ.N) GO TO 100
        JP1=J+1
        DO 90 I=JP1,N
          A(I,J)=0.
   90   CONTINUE
  100 CONTINUE
      RETURN
      END
      SUBROUTINE HTTSQ1(AMAT1,AMAT2,MAXROM,MAXCOM,NR1,NC1,
     1TSTAT,ASIG90,ASIG95,ASIG99,ASG995,
     1DMEAN,Y1,Y2,Y3,INDEX,
     1IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE
C              1-SAMPLE HOTELLING T-SQUARE STATISTIC.
C              HO: U = U0
C              T2=N*(XBAR-U0)'*SINV*(XBAR-U0)
C     INPUT  ARGUMENTS--AMAT1  = THE ORIGINAL SINGLE PRECISION MATRIX
C                     --MAXROM = THE INTEGER ROW DIMENSION OF AMAT1
C                     --MAXCOM = THE INTEGER COUMN DIMENSION OF AMAT1
C                     --NR1    = THE INTEGER NUMBER OF ROWS OF AMAT1
C                     --NC1    = THE INTEGER NUMBER OF COLUMNS OF AMAT1
C                     --Y1     = VECTOR CONTAINING HYPOTHESIZED MEANS
C                     --Y2     = DUMMY VECTOR CONTAINING SAMPLE MEANS
C     OUTPUT ARGUMENTS--AMAT2  = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED INVERTED VARIANCE-COVARIANCE
C                                MATRIX
C                     --TSTAT  = VALUE OF HOTELLING T-SQUARE
C                     --ASIG90 = CRITICAL VALUE FOR ALPHA = .90
C                     --ASIG95 = CRITICAL VALUE FOR ALPHA = .95
C                     --ASIG99 = CRITICAL VALUE FOR ALPHA = .99
C                     --ASG995= CRITICAL VALUE FOR ALPHA = .995
C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
C             HOTELLING T-SQUARE VALUE
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     LANGUAGE--ANSI FORTRAN (1977)
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           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.7
C     ORIGINAL VERSION--JULY      1998.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 ICASE
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
C
      DIMENSION AMAT1(MAXROM,MAXCOM)
      DIMENSION AMAT2(MAXROM,MAXCOM)
      DIMENSION Y1(*)
      DIMENSION Y2(*)
      DIMENSION Y3(*)
      DIMENSION INDEX(*)
      DOUBLE PRECISION DMEAN(*)
C
C---------------------------------------------------------------------
C
      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='HOTT'
      ISUBN2='SQ  '
C
      IWRITE='OFF'
      IERROR='NO'
C
      IF(IBUGA3.EQ.'OFF')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF HTTSQ1--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)IBUGA3
   52 FORMAT('IBUGA3 = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)NR1,NC1
   53 FORMAT('NR1, NC1 = ',2I8)
      CALL DPWRST('XXX','BUG ')
      DO55I=1,NC1
      WRITE(ICOUT,56)I,Y1(I)
   56 FORMAT('I,Y(I) = ',I8,E15.7)
      CALL DPWRST('XXX','BUG ')
   55 CONTINUE
   90 CONTINUE
C
C               **********************************
C               **  COMPUTE HOTELLING T-SQUARE  **
C               **********************************
C
      ICASE='COLU'
      CALL VARCOV(AMAT1,AMAT2,MAXROM,MAXCOM,NR1,NC1,DMEAN,
     1            ICASE,IBUGA3,IERROR)
      CALL SGECO(AMAT2,MAXROM,NC1,INDEX,RCOND,Y2)
C
      IF(1.0+RCOND.EQ.1.0)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,5171)
        CALL DPWRST('XXX','ERRO ')
        WRITE(ICOUT,5172)
        CALL DPWRST('XXX','ERRO ')
        WRITE(ICOUT,5173)
        CALL DPWRST('XXX','ERRO ')
        IERROR='YES'
        GOTO9000
      ENDIF
 5171 FORMAT('*** ERROR FROM HTTSQ1: UNABLE TO COMPUTE THE INVERSE OF ',
     1       'THE COVARIANCE MATRIX.')
 5172 FORMAT('    PROBLEM: SOME COLUMNS ARE LINEARLY DEPDENDENT ON ',
     1       ' OTHER COLUMNS.')
 5173 FORMAT('    SUGGESTED SOLUTION: WORK WITH A SUBSET OF THE ',
     1       'ORIGINAL COLUMNS.')
C
      IJOB=1
      CALL SGEDI(AMAT2,MAXROM,NC1,INDEX,Y2,Y3,IJOB)
C
      DO6000I=1,NC1
        DO6110J=1,NR1
          Y2(J)=AMAT1(J,I)
 6110   CONTINUE
        CALL MEAN(Y2,NR1,IWRITE,XMEAN,IBUGA3,IERROR)
        Y3(I)=XMEAN-Y1(I)
 6000 CONTINUE
      CALL QUAFRM(AMAT2,MAXROM,MAXCOM,NC1,NC1,Y3,IWRITE,
     1            XQUAD,IBUGA3,IERROR)
      TSTAT=REAL(NR1)*XQUAD
C
      AFACT=REAL(NC1*(NR1-1)/(NR1-NC1))
      CALL FPPF(0.90,NC1,NR1-NC1,ATEMP1)
      ASIG90=AFACT*ATEMP1
      CALL FPPF(0.95,NC1,NR1-NC1,ATEMP1)
      ASIG95=AFACT*ATEMP1
      CALL FPPF(0.99,NC1,NR1-NC1,ATEMP1)
      ASIG99=AFACT*ATEMP1
      CALL FPPF(0.995,NC1,NR1-NC1,ATEMP1)
      ASG995=AFACT*ATEMP1
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'OFF')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF HTTSQ1--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IBUGA3,IERROR
 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE HTTSQ2(AMAT1,AMAT2,AMAT3,MAXROM,MAXCOM,NR1,NR2,NC1,
     1TSTAT,ASIG90,ASIG95,ASIG99,ASG995,
     1DMEAN,Y1,Y2,Y3,INDEX,
     1IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE
C              2-SAMPLE HOTELLING T-SQUARE STATISTIC.
C              HO: U1 = U2
C              T2=N1*N2*(XBAR1-XBAR2)'*SINV*(XBAR1-XBAR2)/(N1+N2)
C              WHERE SINV IS THE INVERSE OF THE POOLED COVARIANCE
C              MATRIX.
C     INPUT  ARGUMENTS--AMAT1  = THE SAMPLE 1 SINGLE PRECISION MATRIX
C                     --AMAT2  = THE SAMPLE 2 SINGLE PRECISION MATRIX
C                     --MAXROM = THE INTEGER ROW DIMENSION OF AMAT1
C                     --MAXCOM = THE INTEGER COUMN DIMENSION OF AMAT1
C                     --NR1    = THE INTEGER NUMBER OF ROWS OF AMAT1
C                     --NR2    = THE INTEGER NUMBER OF ROWS OF AMAT2
C                     --NC1    = THE INTEGER NUMBER OF COLUMNS OF AMAT1
C                     --Y1     = DUMMY VECTOR CONTAINING SAMPLE 1 MEANS
C                     --Y2     = DUMMY VECTOR CONTAINING SAMPLE 2 MEANS
C     OUTPUT ARGUMENTS--AMAT3  = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED INVERTED VARIANCE-COVARIANCE
C                                MATRIX
C                     --TSTAT  = VALUE OF HOTELLING T-SQUARE
C                     --ASIG90 = CRITICAL VALUE FOR ALPHA = .90
C                     --ASIG95 = CRITICAL VALUE FOR ALPHA = .95
C                     --ASIG99 = CRITICAL VALUE FOR ALPHA = .99
C                     --ASG995= CRITICAL VALUE FOR ALPHA = .995
C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
C             HOTELLING T-SQUARE VALUE
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     LANGUAGE--ANSI FORTRAN (1977)
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           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.7
C     ORIGINAL VERSION--JULY      1998.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
C
      DIMENSION AMAT1(MAXROM,MAXCOM)
      DIMENSION AMAT2(MAXROM,MAXCOM)
      DIMENSION AMAT3(MAXROM,MAXCOM)
      DIMENSION Y1(*)
      DIMENSION Y2(*)
      DIMENSION Y3(*)
      DIMENSION INDEX(*)
      DOUBLE PRECISION DMEAN(*)
C
C---------------------------------------------------------------------
C
      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='HTTS'
      ISUBN2='Q2  '
C
      IWRITE='OFF'
      IERROR='NO'
C
      IF(IBUGA3.EQ.'OFF')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF HTTSQ2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)IBUGA3
   52 FORMAT('IBUGA3 = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)NR1,NR2,NC1
   53 FORMAT('NR1, NR2, NC1 = ',3I8)
      CALL DPWRST('XXX','BUG ')
   90 CONTINUE
C
C               **********************************
C               **  COMPUTE HOTELLING T-SQUARE  **
C               **********************************
C
      CALL VARPOO(AMAT1,AMAT2,AMAT3,MAXROM,MAXCOM,NR1,NC1,NR2,
     1            DMEAN,IBUGA3,IERROR)
      CALL SGECO(AMAT3,MAXROM,NC1,INDEX,RCOND,Y1)
C
      IF(1.0+RCOND.EQ.1.0)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,5171)
        CALL DPWRST('XXX','ERRO ')
        WRITE(ICOUT,5172)
        CALL DPWRST('XXX','ERRO ')
        WRITE(ICOUT,5173)
        CALL DPWRST('XXX','ERRO ')
        IERROR='YES'
        GOTO9000
      ENDIF
 5171 FORMAT('*** ERROR FROM HTTSQ2: UNABLE TO COMPUTE THE INVERSE OF ',
     1       'THE POOLED COVARIANCE MATRIX.')
 5172 FORMAT('    PROBLEM: SOME COLUMNS ARE LINEARLY DEPDENDENT ON ',
     1       ' OTHER COLUMNS.')
 5173 FORMAT('    SUGGESTED SOLUTION: WORK WITH A SUBSET OF THE ',
     1       'ORIGINAL COLUMNS.')
C
      IJOB=1
      CALL SGEDI(AMAT3,MAXROM,NC1,INDEX,Y1,Y2,IJOB)
C
      DO6000I=1,NC1
        DO6110J=1,NR1
          Y1(J)=AMAT1(J,I)
 6110   CONTINUE
        DO6120J=1,NR2
          Y2(J)=AMAT2(J,I)
 6120   CONTINUE
        CALL MEAN(Y1,NR1,IWRITE,XMEAN1,IBUGA3,IERROR)
        CALL MEAN(Y2,NR2,IWRITE,XMEAN2,IBUGA3,IERROR)
        Y3(I)=XMEAN1-XMEAN2
 6000 CONTINUE
      CALL QUAFRM(AMAT3,MAXROM,MAXCOM,NC1,NC1,Y3,IWRITE,
     1            XQUAD,IBUGA3,IERROR)
      TSTAT=REAL(NR1*NR2)*XQUAD/REAL(NR1+NR2)
C
      AFACT=REAL((Nr1+NR2-NC1-1)/((NR1+NR2-2)*NC1))
      CALL FPPF(0.90,NC1,NR1+NR2-NC1-1,ATEMP1)
      ASIG90=AFACT*ATEMP1
      CALL FPPF(0.95,NC1,NR1+NR2-NC1-1,ATEMP1)
      ASIG95=AFACT*ATEMP1
      CALL FPPF(0.99,NC1,NR1+NR2-NC1-1,ATEMP1)
      ASIG99=AFACT*ATEMP1
      CALL FPPF(0.995,NC1,NR1+NR2-NC1-1,ATEMP1)
      ASG995=AFACT*ATEMP1
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'OFF')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF HTTSQ2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IBUGA3,IERROR
 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE HYGFX(A,B,C,X,HF,IERROR)
C
C       ====================================================
C       Purpose: Compute hypergeometric function F(a,b,c,x)
C       Input :  a --- Parameter
C                b --- Parameter
C                c --- Parameter, c <> 0,-1,-2,...
C                x --- Argument   ( x < 1 )
C       Output:  HF --- F(a,b,c,x)
C                IERROR--ERROR FLAG
C       Routines called:
C            (1) GAMMA for computing gamma function
C            (2) PSI for computing psi function
C       ====================================================
C
        IMPLICIT DOUBLE PRECISION (A-H,O-Z)
        LOGICAL L0,L1,L2,L3,L4,L5
        PI=3.141592653589793D0
        EL=.5772156649015329D0
        L0=C.EQ.INT(C).AND.C.LT.0.0
        L1=1.0D0-X.LT.1.0D-15.AND.C-A-B.LE.0.0
        L2=A.EQ.INT(A).AND.A.LT.0.0
        L3=B.EQ.INT(B).AND.B.LT.0.0
        L4=C-A.EQ.INT(C-A).AND.C-A.LE.0.0
        L5=C-B.EQ.INT(C-B).AND.C-B.LE.0.0
        IF (L0) THEN
           IERROR=1
CCCCC      WRITE(*,*)'The hypergeometric series is divergent'
           RETURN
        ENDIF
        IF (L1) THEN
           IERROR=2
CCCCC      WRITE(*,*)'The hypergeometric series is divergent'
           RETURN
        ENDIF
        EPS=1.0D-15
        IF (X.GT.0.95) EPS=1.0D-8
        IF (X.EQ.0.0.OR.A.EQ.0.0.OR.B.EQ.0.0) THEN
           HF=1.0D0
           RETURN
        ELSE IF (1.0D0-X.EQ.EPS.AND.C-A-B.GT.0.0) THEN
CCCCC USE CMLIB DGAMMA ROUTINE
CCCCC      CALL GAMMA(C,GC)
CCCCC      CALL GAMMA(C-A-B,GCAB)
CCCCC      CALL GAMMA(C-A,GCA)
CCCCC      CALL GAMMA(C-B,GCB)
           GC=DGAMMA(C)
           GCAB=DGAMMA(C-A-B)
           GCA=DGAMMA(C-A)
           GCB=DGAMMA(C-B)
           HF=GC*GCAB/(GCA*GCB)
           RETURN
        ELSE IF (1.0D0+X.LE.EPS.AND.DABS(C-A+B-1.0).LE.EPS) THEN
           G0=DSQRT(PI)*2.0D0**(-A)
CCCCC USE CMLIB DGAMMA ROUTINE
CCCCC      CALL GAMMA(C,G1)
CCCCC      CALL GAMMA(1.0D0+A/2.0-B,G2)
CCCCC      CALL GAMMA(0.5D0+0.5*A,G3)
           G1=DGAMMA(C)
           G2=DGAMMA(1.0D0+A/2.0-B)
           G3=DGAMMA(0.5D0+0.5*A)
           HF=G0*G1/(G2*G3)
           RETURN
        ELSE IF (L2.OR.L3) THEN
           IF (L2) NM=INT(ABS(A))
           IF (L3) NM=INT(ABS(B))
           HF=1.0D0
           R=1.0D0
           DO 10 K=1,NM
              R=R*(A+K-1.0D0)*(B+K-1.0D0)/(K*(C+K-1.0D0))*X
10            HF=HF+R
           RETURN
        ELSE IF (L4.OR.L5) THEN
           IF (L4) NM=INT(ABS(C-A))
           IF (L5) NM=INT(ABS(C-B))
           HF=1.0D0
           R=1.0D0
           DO 15 K=1,NM
              R=R*(C-A+K-1.0D0)*(C-B+K-1.0D0)/(K*(C+K-1.0D0))*X
15            HF=HF+R
           HF=(1.0D0-X)**(C-A-B)*HF
           RETURN
        ENDIF
        AA=A
        BB=B
        X1=X
        IF (X.LT.0.0D0) THEN
           X=X/(X-1.0D0)
           IF (C.GT.A.AND.B.LT.A.AND.B.GT.0.0) THEN
              A=BB
              B=AA
           ENDIF
           B=C-B
        ENDIF
        IF (X.GE.0.75D0) THEN
           GM=0.0D0
           IF (DABS(C-A-B-INT(C-A-B)).LT.1.0D-15) THEN
              M=INT(C-A-B)
CCCCC USE CMLIB DGAMMA ROUTINE
CCCCC         CALL GAMMA(A,GA)
CCCCC         CALL GAMMA(B,GB)
CCCCC         CALL GAMMA(C,GC)
CCCCC         CALL GAMMA(A+M,GAM)
CCCCC         CALL GAMMA(B+M,GBM)
              GA=DGAMMA(A)
              GB=DGAMMA(B)
              GC=DGAMMA(C)
              GAM=DGAMMA(A+M)
              GBM=DGAMMA(B+M)
CCCCC USE CMLIB DPSI ROUTINE
CCCCC         CALL PSI(A,PA)
CCCCC         CALL PSI(B,PB)
              PA=DPSI(A)
              PB=DPSI(B)
              IF (M.NE.0) GM=1.0D0
              DO 30 J=1,ABS(M)-1
30               GM=GM*J
              RM=1.0D0
              DO 35 J=1,ABS(M)
35               RM=RM*J
              F0=1.0D0
              R0=1.0D0
              R1=1.0D0
              SP0=0.D0
              SP=0.0D0
              IF (M.GE.0) THEN
                 C0=GM*GC/(GAM*GBM)
                 C1=-GC*(X-1.0D0)**M/(GA*GB*RM)
                 DO 40 K=1,M-1
                    R0=R0*(A+K-1.0D0)*(B+K-1.0)/(K*(K-M))*(1.0-X)
40                  F0=F0+R0
                 DO 45 K=1,M
45                  SP0=SP0+1.0D0/(A+K-1.0)+1.0/(B+K-1.0)-1.0/K
                 F1=PA+PB+SP0+2.0D0*EL+DLOG(1.0D0-X)
                 DO 55 K=1,250
                    SP=SP+(1.0D0-A)/(K*(A+K-1.0))+(1.0-B)/(K*(B+K-1.0))
                    SM=0.0D0
                    DO 50 J=1,M
50                     SM=SM+(1.0D0-A)/((J+K)*(A+J+K-1.0))+1.0/
     &                    (B+J+K-1.0)
                    RP=PA+PB+2.0D0*EL+SP+SM+DLOG(1.0D0-X)
                    R1=R1*(A+M+K-1.0D0)*(B+M+K-1.0)/(K*(M+K))*(1.0-X)
                    F1=F1+R1*RP
                    IF (DABS(F1-HW).LT.DABS(F1)*EPS) GO TO 60
55                  HW=F1
60               HF=F0*C0+F1*C1
              ELSE IF (M.LT.0) THEN
                 M=-M
                 C0=GM*GC/(GA*GB*(1.0D0-X)**M)
                 C1=-(-1)**M*GC/(GAM*GBM*RM)
                 DO 65 K=1,M-1
                    R0=R0*(A-M+K-1.0D0)*(B-M+K-1.0)/(K*(K-M))*(1.0-X)
65                  F0=F0+R0
                 DO 70 K=1,M
70                  SP0=SP0+1.0D0/K
                 F1=PA+PB-SP0+2.0D0*EL+DLOG(1.0D0-X)
                 DO 80 K=1,250
                    SP=SP+(1.0D0-A)/(K*(A+K-1.0))+(1.0-B)/(K*(B+K-1.0))
                    SM=0.0D0
                    DO 75 J=1,M
75                     SM=SM+1.0D0/(J+K)
                    RP=PA+PB+2.0D0*EL+SP-SM+DLOG(1.0D0-X)
                    R1=R1*(A+K-1.0D0)*(B+K-1.0)/(K*(M+K))*(1.0-X)
                    F1=F1+R1*RP
                    IF (DABS(F1-HW).LT.DABS(F1)*EPS) GO TO 85
80                  HW=F1
85               HF=F0*C0+F1*C1
              ENDIF
           ELSE
CCCCC USE CMLIB DGAMMA ROUTINE
CCCCC         CALL GAMMA(A,GA)
CCCCC         CALL GAMMA(B,GB)
CCCCC         CALL GAMMA(C,GC)
CCCCC         CALL GAMMA(C-A,GCA)
CCCCC         CALL GAMMA(C-B,GCB)
CCCCC         CALL GAMMA(C-A-B,GCAB)
CCCCC         CALL GAMMA(A+B-C,GABC)
              GA=DGAMMA(A)
              GB=DGAMMA(B)
              GC=DGAMMA(C)
              GCA=DGAMMA(C-A)
              GCB=DGAMMA(C-B)
              GCAB=DGAMMA(C-A-B)
              GABC=DGAMMA(A+B-C)
              C0=GC*GCAB/(GCA*GCB)
              C1=GC*GABC/(GA*GB)*(1.0D0-X)**(C-A-B)
              HF=0.0D0
              R0=C0
              R1=C1
              DO 90 K=1,250
                 R0=R0*(A+K-1.0D0)*(B+K-1.0)/(K*(A+B-C+K))*(1.0-X)
                 R1=R1*(C-A+K-1.0D0)*(C-B+K-1.0)/(K*(C-A-B+K))
     &              *(1.0-X)
                 HF=HF+R0+R1
                 IF (DABS(HF-HW).LT.DABS(HF)*EPS) GO TO 95
90               HW=HF
95            HF=HF+C0+C1
           ENDIF
        ELSE
           A0=1.0D0
           IF (C.GT.A.AND.C.LT.2.0D0*A.AND.
     &         C.GT.B.AND.C.LT.2.0D0*B) THEN
              A0=(1.0D0-X)**(C-A-B)
              A=C-A
              B=C-B
           ENDIF
           HF=1.0D0
           R=1.0D0
           DO 100 K=1,250
              R=R*(A+K-1.0D0)*(B+K-1.0D0)/(K*(C+K-1.0D0))*X
              HF=HF+R
              IF (DABS(HF-HW).LE.DABS(HF)*EPS) GO TO 105
100           HW=HF
105        HF=A0*HF
        ENDIF
        IF (X1.LT.0.0D0) THEN
           X=X1
           C0=1.0D0/(1.0D0-X)**AA
           HF=C0*HF
        ENDIF
        A=AA
        B=BB
        IF (K.GT.120) THEN
CCCCC     WRITE(*,115)
C115      FORMAT(1X,'Warning! You should check the accuracy')
          IERROR=3
        ENDIF
        RETURN
        END
      SUBROUTINE HYPCDF(LL,KK,NN,MM,POINT,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE AT THE INTEGER VALUE LL
C              FOR THE HYPERGEOMETRIC DISTRIBUTION.
C              THE HYPERGEOMETRIC DISTRIBUTION IS THE PROBABILITY OF
C              SELECTING LL MARKED ITEMS WHEN A RANDOM SAMPLE OF SIZE
C              KK IS TAKEN WITHOUT REPLACEMENT FROM A POPULATION OF
C              MM ITEMS, NN OF WHICH ARE MARKED.  IT HAS CDF OF:
C                 CDF = P(X<= LL | KK, NN, MM)
C     INPUT  ARGUMENTS--LL     = THE INTEGER VALUE
C                                AT WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C                                IT SHOULD BE INTEGRAL-VALUED,
C                                AND BETWEEN 0.0 (INCLUSIVELY)
C                                AND MM (INCLUSIVELY).
C                     --KK     = THE INTEGER VALUE INDICATING THE
C                                SAMPLE SIZE.
C                     --NN     = THE NUMBER OF MARKED ITEMS IN THE
C                                POPULATION.
C                     --MM     = THE POPULATION SIZE.
C                     --POINT  = LOGICAL VARIABLE THAT SPECIFIES 
C                                WHETHER THE CDF OR PDF SHOULD BE
C                                COMPUTED.
C     OUTPUT ARGUMENTS--CDF    = THE SINGLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--LL SHOULD BE INTEGRAL-VALUED,
C                   AND BETWEEN 0 AND MM (INCLUSIVELY)
C                 --KK SHOULD BE A POSITIVE INTEGER BETWEEN 1 AND MM.
C                 --NN SHOULD BE A POSITIVE INTEGER BETWEEN 1 AND MM.
C     OTHER SUBROUTINES NEEDED--NORCDF, DLNGAM
C     LANGUAGE--ANSI FORTRAN (1977)
C     COMMENT--THIS ROUTINE USES ALGORITHM AS R77 FROM THE
C              APPLIED STATISTICS JOURNAL. CODE RETRIEVED FROM STATLIB.
C
C     ALGORITHM AS R77  APPL. STATIST. (1989), VOL.38, NO.1
C     Replaces AS 59 and AS 152
C     Incorporates AS R86 from vol.40(2)
C
C     Auxiliary routines required: ALNFAC (AS 245), ALNORM (AS 66)
C
C     REFERENCES--HASTINGS AND PEACOCK, STATISTICAL
C                 DISTRIBUTIONS--A HANDBOOK FOR
C                 STUDENTS AND PRACTITIONERS, 1975,
C               --JOHNSON AND KOTZ, DISCRETE
C                 DISTRIBUTIONS, 1969.
C               --REMARK AS R77, AS152, AND AS59 FROM THE APPLIED
C                 STATISTICS JOURNAL.
C               --"THE ACCURACY OF PIEZER APPROXIMATIONS TO THE 
C                 HYPERGEOMETRIC DISTRIBUTION, WITH COMPARISONS TO
C                 SOME OTHER APPROXIMATIONS", LING AND PRATT, JASA, 
C                 MARCH, 1984.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           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--94/9
C     ORIGINAL VERSION--SEPTEMBER 1994.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      INTEGER  KK, LL, MM, NN, K, L, M, N, I, J, NL, KL,
     *         MNKL, MVBIG, MBIG
CCCCC DOUBLE PRECISION ZERO, ONE, P, PT, HALF, DLNGAM, ELIMIT, MEAN, 
CCCCC*                 SIG, SXTEEN, SCALE, ROOTPI, ARG, HUNDRD, DCDF,
      DOUBLE PRECISION ZERO, ONE, P, PT, HALF, DLNGAM, ELIMIT,
     *                 SXTEEN, SCALE, ROOTPI, HUNDRD, DCDF,
     *                 XMAX,XMAXT,DTERM1,
     *                 DTERM2,DTERM3,DTERM4,DTERM5,DTERM6,DTERM7,DTERM8
      DOUBLE PRECISION P1, P2, A, B, C, D
      LOGICAL   POINT, DIR
      PARAMETER (ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0, MVBIG = 1000,
     *           MBIG = 600, SXTEEN = 16.0D0,
     *           ROOTPI = 2.50662 82746 31001D0,
     *           HUNDRD = 100.0D0)
C
C---------------------------------------------------------------------
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
C-----DATA STATEMENTS-------------------------------------------------
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(NN.LE.0.OR.NN.GT.MM)THEN
        WRITE(ICOUT,11)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,12)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)NN
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        RETURN
      ENDIF
   11 FORMAT('***** FATAL ERROR--THE THIRD INPUT ARGUMENT TO THE ',
     1' HYPCDF SUBROUTINE (THE NUMBER OF MARKED ITEMS) ')
   12 FORMAT('      IS LESS THAN ZERO OR GREATER THAN THE POULATION ',
     1'SIZE.')
      IF(KK.LE.0.OR.KK.GT.MM)THEN
        WRITE(ICOUT,21)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,22)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)KK
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        RETURN
      ENDIF
   21 FORMAT('***** FATAL ERROR--THE 2ND INPUT ARGUMENT TO THE ',
     1' HYPCDF SUBROUTINE (THE SAMPLE SIZE) ')
   22 FORMAT('      IS LESS THAN ZERO OR GREATER THAN THE POULATION ',
     1'SIZE.')
      IF(LL.LT.0.OR.KK-LL.GT.MM-NN)THEN
        WRITE(ICOUT,31)MM-NN
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)LL
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        RETURN
      ENDIF
   31 FORMAT('***** NON-FATAL DIAGNOSTIC--THE 1ST INPUT ARGUMENT TO ',
     1'THE HYPCDF SUBROUTINE IS OUTSIDE THE (0,',I8,') INTERVAL.')
      IF(LL.GT.NN.OR.LL.GT.KK)THEN
        WRITE(ICOUT,41)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,42)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)LL
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        IF(.NOT.POINT)CDF=1.0
        RETURN
      ENDIF
   41 FORMAT('***** NON-FATAL DIAGNOSTIC--THE 1ST INPUT ARGUMENT TO ',
     1'THE HYPCDF SUBROUTINE IS GREATER THAN THE SAMPLE SIZE ')
   42 FORMAT('      OR GREATER THAN THE NUMBER OF MARKED ITEMS.')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
C
   90 CONTINUE
C
C  CALCULATE EXPONENTIAL LIMIT FOR UNDERFLOW
C
      XMAXT = -DLOG(D1MACH(1))
      XMAX = XMAXT - 0.5D0*XMAXT*DLOG(XMAXT)/(XMAXT+0.5D0) - 0.01D0
      ELIMIT=-XMAX
      SCALE = D1MACH(1) + 1000.D0*D1MACH(3)
C
C     TREAT IMMEDIATELY THE SPECIAL CASES WHICH RETURN A VALUE OF 
C     0 OR 1.
C
      K = KK + 1
      L = LL + 1
      M = MM + 1
      N = NN + 1
      DIR = .TRUE.
      DCDF = ONE
      IF (K .EQ. 1 .OR. K .EQ. M .OR. N .EQ. 1 .OR. N .EQ. M) GOTO9999
      IF (.NOT. POINT .AND. LL .EQ. MIN(KK, NN)) GOTO9999
C
      P = DBLE(NN) / DBLE(MM - NN)
C
C     Use a normal approximation for sufficently large arguments
C
C     THE NORMAL APPROXIMATION HERE DOES NOT SEEM TO PRODUCE
C     PARTICULARLY ACCURATE RESULTS.  USE A BINOMIAL APPROXIMATION
C     INSTEAD (TAKEN FROM LING AND PRATT ARTICLE IN REFERENCE).
CCCCC IF (DBLE(MIN(KK, MM-KK)) .GT. SXTEEN * MAX(P, ONE/P) .AND.
CCCCC*   MM .GT. MVBIG .AND. ELIMIT .GT. -HUNDRD) THEN
      IF (DBLE(MIN(KK, MM-KK)) .GT. SXTEEN * MAX(P, ONE/P) .AND.
     *   MM .GT. MVBIG ) THEN
        K=KK
        M=MM
        N=NN
        L=LL
        IF (MIN(K-1, M-K) .GT. MIN(N-1, M-N)) THEN
          I = K
          K = N
          N = I
        END IF
        IF (M-K .LT. K-1) THEN
          DIR = .NOT. DIR
          L = N - L + 1
          K = M - K + 1
        END IF
CCCCC   MEAN = DBLE(K) * DBLE(N) / DBLE(M)
CCCCC   SIG = DSQRT(MEAN*(DBLE(M-N)/DBLE(M))*(DBLE(M-K)/(DBLE(M-1))))
CCCCC   IF (POINT) THEN
CCCCC     ARG = -HALF * (((DBLE(L) - MEAN) / SIG)**2)
CCCCC     DCDF = ZERO
CCCCC     IF (ARG .GE. ELIMIT) DCDF = DEXP(ARG)/(SIG*ROOTPI)
CCCCC   ELSE
CCCCC     DTERM1=(DBLE(L)+HALF-MEAN)/SIG
CCCCC     CALL NORCDF(SNGL(DTERM1),CDF)
CCCCC     DCDF = DBLE(CDF)
CCCCC     IF(.NOT.DIR)DCDF=1.0D0 - DCDF
CCCCC   END IF
C
C     BINOMIAL APPROXIMATION.
C
        A=DBLE(L)
        B=DBLE(K-L)
        C=DBLE(N-L)
        D=DBLE(M+L-N-K)
        P1=DBLE(2*N-L)/DBLE(2*M-K+1)
        DTERM1=DBLE(K+1)*(A*P1-(B-1.0D0)*(1.0D0-P1))
        DTERM2=-A*(A+2.0D0)/P1 + (B**2-1.0D0)/(1.0D0-P1)
        DTERM3=6.0D0*(2.0D0*DBLE(M)-DBLE(K)+1.0D0)**2
        P2=P1+(DTERM1+DTERM2)/DTERM3
        AP1=SNGL(P1)
        AP2=SNGL(P2)
        AX=REAL(L)
        IF (POINT) THEN
          CALL BINCDF(AX,AP2,K,CDF)
          IF(AX.LE.0.1)THEN
            DCDF=DBLE(CDF)
          ELSE
            AX=AX-1.0
            CALL BINCDF(AX,AP2,K,CDF2)
            DCDF=DBLE(CDF-CDF2)
          ENDIF
        ELSE
          CALL BINCDF(AX,AP2,K,CDF)
          DCDF=DBLE(CDF)
          IF(.NOT.DIR) DCDF=1.0D0-DCDF
        ENDIF
C
C     Calculate exact hypergeometric probabilities.
C     Interchange K and N if this saves calculations.
C
      ELSE
        IF (MIN(K-1, M-K) .GT. MIN(N-1, M-N)) THEN
          I = K
          K = N
          N = I
        END IF
        IF (M-K .LT. K-1) THEN
          DIR = .NOT. DIR
          L = N - L + 1
          K = M - K + 1
        END IF
        IF (MM .GT. MBIG) THEN
C
C     Take logarithms of factorials.
C     Use fact that GAMMA(N)=(N-1)!.  USE DLNGAM function.
C
CCCCC     P = ALNFAC(NN) - ALNFAC(MM) + ALNFAC(MM-KK) + ALNFAC(KK) +
CCCCC*        ALNFAC(MM-NN)-ALNFAC(LL)-ALNFAC(NN-LL)-ALNFAC(KK-LL)
CCCCC*        - ALNFAC(MM-NN-KK+LL)
CCCCC     P = DLNGAM(DBLE(NN-1)) - DLNGAM(DBLE(MM-1)) + 
CCCCC*        DLNGAM(DBLE(MM-KK-1)) + DLNGAM(DBLE(KK-1)) +
CCCCC*        DLNGAM(DBLE(MM-NN-1)) - DLNGAM(DBLE(LL-1)) - 
CCCCC*        DLNGAM(DBLE(NN-LL-1)) - DLNGAM((KK-LL-1)) -
CCCCC*        DLNGAM(DBLE(MM-NN-KK+LL-1))
          DTERM1=DLNGAM(DBLE(NN+1))
          DTERM2=DLNGAM(DBLE(MM+1))
          DTERM3=DLNGAM(DBLE(MM-KK+1))
          DTERM4=DLNGAM(DBLE(KK+1))
          DTERM5=DLNGAM(DBLE(MM-NN+1))
          DTERM6=DLNGAM(DBLE(LL+1))
          DTERM7=DLNGAM(DBLE(NN-LL+1))
          DTERM8=DLNGAM(DBLE(KK-LL+1))
          DTERM9=DLNGAM(DBLE(MM-NN-KK+LL+1))
          P=DTERM1-DTERM2+DTERM3+DTERM4+DTERM5-
     *      DTERM6-DTERM7-DTERM8-DTERM9
          DCDF = ZERO
          IF (P .GE. ELIMIT) DCDF = DEXP(P)
C
C     Use Freeman/Lund algorithm
C
        ELSE
          DO 3 I = 1, L-1
            DCDF= DCDF*DBLE(K-I)*DBLE(N-I)/(DBLE(L-I)*DBLE(M-I))
    3     CONTINUE
          IF (L .NE. K) THEN
            J = M - N + L
            DO 5 I = L, K-1
              DCDF = DCDF * DBLE(J-I) / DBLE(M-I)
    5       CONTINUE
          END IF
C
        END IF
C
        IF (POINT) GOTO9999
C
C     We must recompute the point probability since it has underflowed.
C
        IF (DCDF .EQ. ZERO) THEN
          IF (MM.LE.MBIG)
     *      P = DLNGAM(DBLE(NN+1)) - DLNGAM(DBLE(MM+1)) + 
     *      DLNGAM(DBLE(KK+1)) + DLNGAM(DBLE(MM-NN+1)) - 
     *      DLNGAM(DBLE(LL+1)) - DLNGAM(DBLE(NN-LL+1)) - 
     *      DLNGAM(DBLE(KK-LL+1)) - DLNGAM(DBLE(MM-NN-KK+LL+1)) + 
     *      DLNGAM(DBLE(MM-KK+1))
          P = P + DLOG(SCALE)
          IF (P .LT. ELIMIT) THEN
            WRITE(ICOUT,51)
            CALL DPWRST('XXX','BUG ')
            IF (LL .GT. DBLE(NN*KK + NN + KK +1)/(MM +2)) DCDF = ONE
            GOTO9999
          ELSE
            P = DEXP(P)
          END IF
   51 FORMAT('***** NON-FATAL DIAGNOSTIC--UNDERFLOW DETECTED.  RESULT',
     1' MAY BE IN ERROR.')
        ELSE
C
C     Scale up at this point.
C
          P = DCDF * SCALE
        END IF
C
        PT = ZERO
        NL = N - L
        KL = K - L
        MNKL = M - N - KL + 1
        IF (L .LE. KL) THEN
          DO 7 I = 1, L-1
            P = P * DBLE(L-I) * DBLE(MNKL-I) /(DBLE(NL+I) * DBLE(KL+I))
            PT = PT + P
    7     CONTINUE
          IF (P .EQ. ZERO) THEN
            WRITE(ICOUT,51)
            CALL DPWRST('XXX','BUG ')
          ENDIF
        ELSE
          DIR = .NOT. DIR
          DO 9 J = 0, KL-1
            P=P*DBLE(NL-J)*DBLE(KL-J)/(DBLE(L+J)*DBLE(MNKL+J))
            PT = PT + P
    9     CONTINUE
          IF (P .EQ. ZERO) THEN
            WRITE(ICOUT,51)
            CALL DPWRST('XXX','BUG ')
          ENDIF
        END IF
C
        IF (DIR) THEN
          DCDF = DCDF + (PT / SCALE)
        ELSE
          DCDF = ONE - (PT / SCALE)
        END IF
C
      END IF
C
 9999 CONTINUE
      CDF=SNGL(DCDF)
      RETURN
      END
      SUBROUTINE HYPPPF(P,K,N,M,PPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE AT THE SINGLE PRECISION VALUE P
C              FOR THE HYPERGEOMETRIC DISTRIBUTION
C              THE HYPERGEOMETRIC DISTRIBUTION IS THE PROBABILITY OF
C              SELECTING LL MARKED ITEMS WHEN A RANDOM SAMPLE OF SIZE
C              KK IS TAKEN WITHOUT REPLACEMENT FROM A POPULATION OF
C              MM ITEMS, NN OF WHICH ARE MARKED.  IT HAS CDF OF:
C                 CDF = P(X<= LL | KK, NN, MM)
C     INPUT  ARGUMENTS--P      = THE SINGLE PRECISION VALUE
C                                AT WHICH THE PERCENT POINT
C                                FUNCTION IS TO BE EVALUATED.
C                                IT SHOULD BE IN THE INTERVAL (0,1).
C                     --KK     = THE INTEGER VALUE INDICATING THE
C                                SAMPLE SIZE.
C                     --NN     = THE NUMBER OF MARKED ITEMS IN THE
C                                POPULATION.
C                     --MM     = THE POPULATION SIZE.
C     OUTPUT ARGUMENTS--CDF    = THE SINGLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--P SHOULD BE BETWEEN 0 and 1 (INCLUSIVELY).
C                 --KK SHOULD BE A POSITIVE INTEGER BETWEEN 1 AND MM.
C                 --NN SHOULD BE A POSITIVE INTEGER BETWEEN 1 AND MM.
C     OUTPUT ARGUMENTS--PPF    = THE SINGLE PRECISION PERCENT
C                                POINT FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PERCENT POINT  .
C             FUNCTION VALUE PPF
C             FOR THE HYPERGEOMETRIC DISTRIBUTION
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--PPAR SHOULD BE BETWEEN 0.0 (EXCLUSIVELY)
C                   AND 1.0 (EXCLUSIVELY).
C                 --N SHOULD BE A POSITIVE INTEGER.
C                 --P SHOULD BE BETWEEN 0.0 (INCLUSIVELY)
C                   AND 1.0 (INCLUSIVELY).
C     OTHER DATAPAC   SUBROUTINES NEEDED--NORPPF, HYPCDF.
C     MODE OF INTERNAL OPERATIONS--SINGLE AND DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     COMMENT--NOTE THAT EVEN THOUGH THE OUTPUT
C              FROM THIS DISCRETE DISTRIBUTION
C              PERCENT POINT FUNCTION
C              SUBROUTINE MUST NECESSARILY BE A
C              DISCRETE INTEGER VALUE,
C              THE OUTPUT VARIABLE PPF IS SINGLE
C              PRECISION IN MODE.
C              PPF HAS BEEN SPECIFIED AS SINGLE
C              PRECISION SO AS TO CONFORM WITH THE DATAPAC
C              CONVENTION THAT ALL OUTPUT VARIABLES FROM ALL
C              DATAPAC SUBROUTINES ARE SINGLE PRECISION.
C              THIS CONVENTION IS BASED ON THE BELIEF THAT
C              1) A MIXTURE OF MODES (FLOATING POINT
C              VERSUS INTEGER) IS INCONSISTENT AND
C              AN UNNECESSARY COMPLICATION
C              IN A DATA ANALYSIS; AND
C              2) FLOATING POINT MACHINE ARITHMETIC
C              (AS OPPOSED TO INTEGER ARITHMETIC)
C              IS THE MORE NATURAL MODE FOR DOING
C              DATA ANALYSIS.
C     REFERENCES--JOHNSON AND KOTZ, DISCRETE
C                 DISTRIBUTIONS, 1969.
C               --HASTINGS AND PEACOCK, STATISTICAL
C                 DISTRIBUTIONS--A HANDBOOK FOR
C                 STUDENTS AND PRACTITIONERS, 1975,
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           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--94/9
C     ORIGINAL VERSION--SEPTEMBER 1994.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      LOGICAL POINT
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.GT.1.0)THEN
        WRITE(ICOUT,1)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)P
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
      ENDIF
    1 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ',
     1' HYPPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL')
      IF(N.LE.0.OR.N.GT.M)THEN
        WRITE(ICOUT,11)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,12)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)N
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
        RETURN
      ENDIF
   11 FORMAT('***** FATAL ERROR--THE THIRD INPUT ARGUMENT TO THE ',
     1' HYPPPF SUBROUTINE (THE NUMBER OF MARKED ITEMS) ')
   12 FORMAT('      IS LESS THAN ZERO OR GREATER THAN THE POULATION ',
     1'SIZE.')
      IF(K.LE.0.OR.K.GT.M)THEN
        WRITE(ICOUT,21)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,22)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)K
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
        RETURN
      ENDIF
   21 FORMAT('***** FATAL ERROR--THE 2ND INPUT ARGUMENT TO THE ',
     1' HYPPPF SUBROUTINE (THE SAMPLE SIZE) ')
   22 FORMAT('      IS LESS THAN ZERO OR GREATER THAN THE POULATION ',
     1'SIZE.')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
C
      PPF=0.0
      IX0=0
      IX1=0
      IX2=0
      P0=0.0
      P1=0.0
      P2=0.0
C
C     TREAT CERTAIN SPECIAL CASES IMMEDIATELY--
C     1) P = 0.0 OR 1.0
C
      IF(P.EQ.0.0)GOTO110
      IF(P.EQ.1.0)GOTO120
      GOTO190
  110 PPF=0.0
      RETURN
  120 PPF=REAL(MIN(N,K))
      RETURN
  190 CONTINUE
C
C     DETERMINE AN INITIAL APPROXIMATION TO THE HYPERGEOMETRIC
C     PERCENT POINT BY USE OF THE BINOMIAL APPROXIMATION
C     TO THE HYPERGEOMETRIC.
C
      PPAR=REAL(N)/REAL(M)
      IF(PPAR.LT.0.0.OR.PPAR.GT.1.0)PPAR=0.5
      CALL BINPPF(P,PPAR,K,ZPPF)
      IX2=ZPPF
C
C     CHECK AND MODIFY (IF NECESSARY) THIS INITIAL
C     ESTIMATE OF THE PERCENT POINT
C     TO ASSURE THAT IT BE IN THE CLOSED INTERVAL 0 TO MIN(N,K).
C
      ITERM=MIN(N,K)
      IF(IX2.LT.0)IX2=0
      IF(IX2.GT.ITERM)IX2=ITERM
C
C     DETERMINE UPPER AND LOWER BOUNDS ON THE DESIRED
C     PERCENT POINT BY ITERATING OUT (BOTH BELOW AND ABOVE)
C     FROM THE ORIGINAL APPROXIMATION AT STEPS
C     OF 1 STANDARD DEVIATION.
C     THE RESULTING BOUNDS WILL BE AT MOST
C     1 STANDARD DEVIATION APART.
C
      IX0=0
      IX1=N
      SD=(REAL(M-K)/REAL(M-1))*REAL(K)*(REAL(N)/REAL(M))*
     1(1.0-REAL(N)/REAL(M))
      ISD=SD+1.0
      POINT=.FALSE.
      CALL HYPCDF(IX2,K,N,M,POINT,P2)
C
      IF(P2.LT.P)GOTO210
      GOTO250
C
  210 CONTINUE
      IX0=IX2
      I=1
  215 CONTINUE
      IX2=IX0+ISD
      IF(IX2.GE.IX1)GOTO275
      CALL HYPCDF(IX2,K,N,M,POINT,P2)
      IF(P2.GE.P)GOTO230
      IX0=IX2
  220 CONTINUE
      I=I+1
      IF(I.LE.1000000)GOTO215
      WRITE(ICOUT,249)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,222)
      CALL DPWRST('XXX','BUG ')
      GOTO950
  230 IX1=IX2
      GOTO275
C
  250 CONTINUE
      IX1=IX2
      I=1
  255 CONTINUE
      IX2=IX1-ISD
      IF(IX2.LE.IX0)GOTO275
      CALL HYPCDF(IX2,K,N,M,POINT,P2)
      IF(P2.LT.P)GOTO270
      IX1=IX2
  260 CONTINUE
      I=I+1
      IF(I.LE.1000000)GOTO255
      WRITE(ICOUT,249)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,262)
      CALL DPWRST('XXX','BUG ')
      GOTO950
  270 IX0=IX2
C
  275 IF(IX0.EQ.IX1)GOTO280
      GOTO295
  280 IF(IX0.EQ.0)GOTO285
      IF(IX0.EQ.N)GOTO290
      WRITE(ICOUT,249)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,282)
      CALL DPWRST('XXX','BUG ')
      GOTO950
  285 IX1=IX1+1
      GOTO295
  290 IX0=IX0-1
  295 CONTINUE
C
C     COMPUTE HYPERGEOMETRIC PROBABILITIES FOR THE
C     DERIVED LOWER AND UPPER BOUNDS.
C
      CALL HYPCDF(IX0,K,N,M,POINT,P0)
      CALL HYPCDF(IX1,K,N,M,POINT,P1)
C
C     CHECK THE PROBABILITIES FOR PROPER ORDERING
C
      IF(P0.LT.P.AND.P.LE.P1)GOTO490
      IF(P0.EQ.P)GOTO410
      IF(P1.EQ.P)GOTO420
      IF(P0.GT.P1)GOTO430
      IF(P0.GT.P)GOTO440
      IF(P1.LT.P)GOTO450
      WRITE(ICOUT,249)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,401)
      CALL DPWRST('XXX','BUG ')
      GOTO950
  410 PPF=IX0
      RETURN
  420 PPF=IX1
      RETURN
  430 WRITE(ICOUT,249)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,431)
      CALL DPWRST('XXX','BUG ')
      GOTO950
  440 WRITE(ICOUT,249)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,441)
      CALL DPWRST('XXX','BUG ')
      GOTO950
  450 WRITE(ICOUT,249)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,451)
      CALL DPWRST('XXX','BUG ')
      GOTO950
  490 CONTINUE
C
C     THE STOPPING CRITERION IS THAT THE LOWER BOUND
C     AND UPPER BOUND ARE EXACTLY 1 UNIT APART.
C     CHECK TO SEE IF IX1 = IX0 + 1;
C     IF SO, THE ITERATIONS ARE COMPLETE;
C     IF NOT, THEN BISECT, COMPUTE PROBABILIIES,
C     CHECK PROBABILITIES, AND CONTINUE ITERATING
C     UNTIL IX1 = IX0 + 1.
C
  300 IX0P1=IX0+1
      IF(IX1.EQ.IX0P1)GOTO690
      IX2=(IX0+IX1)/2
      IF(IX2.EQ.IX0)GOTO610
      IF(IX2.EQ.IX1)GOTO620
      CALL HYPCDF(IX2,K,N,M,POINT,P2)
      IF(P0.LT.P2.AND.P2.LT.P1)GOTO630
      IF(P2.LE.P0)GOTO640
      IF(P2.GE.P1)GOTO650
  610 WRITE(ICOUT,249)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,611)
      CALL DPWRST('XXX','BUG ')
      GOTO950
  620 WRITE(ICOUT,249)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,611)
      CALL DPWRST('XXX','BUG ')
      GOTO950
  630 IF(P2.LE.P)GOTO635
      IX1=IX2
      P1=P2
      GOTO300
  635 IX0=IX2
      P0=P2
      GOTO300
  640 WRITE(ICOUT,249)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,641)
      CALL DPWRST('XXX','BUG ')
      GOTO950
  650 WRITE(ICOUT,249)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,651)
      CALL DPWRST('XXX','BUG ')
      GOTO950
  690 PPF=IX1
      IF(P0.EQ.P)PPF=IX0
      RETURN
C
  950 WRITE(ICOUT,240)IX0,P0
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,241)IX1,P1
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,242)IX2,P2
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,244)P
      CALL DPWRST('XXX','BUG ')
C
  222 FORMAT(43HNO UPPER BOUND FOUND AFTER 10**7 ITERATIONS)
  240 FORMAT(7HIX0  = ,I8,10X,5HP0 = ,F14.7)
  241 FORMAT(7HIX1  = ,I8,10X,5HP1 = ,F14.7)
  242 FORMAT(7HIX2  = ,I8,10X,5HP2 = ,F14.7)
  244 FORMAT(7HP    = ,F14.7)
  249 FORMAT('***** INTERNAL ERROR IN HYPPPF SUBROUTINE *****')
  262 FORMAT(43HNO LOWER BOUND FOUND AFTER 10**7 ITERATIONS)
  282 FORMAT(31HLOWER AND UPPER BOUND IDENTICAL)
  401 FORMAT(39HIMPOSSIBLE BRANCH CONDITION ENCOUNTERED)
  431 FORMAT(42HLOWER BOUND PROBABILITY (P0) GREATER THAN ,
     1 28HUPPER BOUND PROBABILITY (P1))
  441 FORMAT(42HLOWER BOUND PROBABILITY (P0) GREATER THAN ,
     1 21HINPUT PROBABILITY (P))
  451 FORMAT(42HUPPER BOUND PROBABILITY (P1) LESS    THAN ,
     1 21HINPUT PROBABILITY (P))
  611 FORMAT(39HBISECTION VALUE (X2) = LOWER BOUND (X0))
  621 FORMAT(39HBISECTION VALUE (X2) = UPPER BOUND (X1))
  641 FORMAT(33HBISECTION VALUE PROBABILITY (P2) ,
     1 38HLESS THAN LOWER BOUND PROBABILITY (P0))
  651 FORMAT(33HBISECTION VALUE PROBABILITY (P2) ,
     1 41HGREATER THAN UPPER BOUND PROBABILITY (P1))
C
      RETURN
      END
      SUBROUTINE HYPRAN(KK,NN1,NN2,ISEED,JX)
CCCCC SUBROUTINE H2PEC(KK,NN1,NN2,ISEED,JX)
C
C      ALGORITHM 668, COLLECTED ALGORITHMS FROM ACM.
C      THIS WORK PUBLISHED IN TRANSACTIONS ON MATHEMATICAL SOFTWARE,
C      VOL. 14, NO. 4, PP. 397-398.
C
C
C     HYPERGEOMETRIC RANDOM VARIATE GENERATOR
C
C     METHOD
C        IF (MODE - MAX(0,KK-NN2) .LT. 10), USE THE INVERSE CDF.
C           OTHERWISE, USE ALGORITHM H2PE: ACCEPTANCE-REJECTION VIA
C           THREE REGION COMPOSITION.  THE THREE REGIONS ARE A
C           RECTANGLE, AND EXPONENTIAL LEFT AND RIGHT TAILS.
C        H2PE  REFERS TO HYPERGEOMETRIC-2 POINTS-EXPONENTIAL TAILS.
C        H2PEC REFERS TO H2PE AND "COMBINED."  THUS H2PE IS THE
C           RESEARCH RESULT AND H2PEC IS THE IMPLEMENTATION OF A
C           COMPLETE USABLE ALGORITHM.
C
C     REFERENCE
C        VORATAS KACHITVICHYANUKUL AND BRUCE SCHMEISER,
C
C        "COMPUTER GENERATION OF HYPERGEOMETRIC RANDOM VARIATES,"
C        JOURNAL OF STATISTICAL COMPUTATION AND SIMULATION,
C        22(1985), 2, 1985, 127-145.
C
C     REQUIRED SUBPROGRAMS
C        AFC() : A DOUBLE-PRECISION FUNCTION TO EVALUATE
C                   THE LOGARITHM OF THE FACTORIAL.
C        RAND(): A UNIFORM (0,1) RANDOM NUMBER GENERATOR.
C
C     ARGUMENTS
C        NN1   : NUMBER OF WHITE BALLS          (INPUT)
C        NN2   : NUMBER OF BLACK BALLS          (INPUT)
C        KK    : NUMBER OF BALLS TO BE DRAWN    (INPUT)
C        ISEED : RANDOM NUMBER SEED  (INPUT AND OUTPUT)
C        JX    : NUMBER OF WHITE BALLS DRAWN   (OUTPUT)
C
C     STRUCTURAL VARIABLES
C        REJECT: LOGICAL FLAG TO REJECT THE VARIATE GENERATE BY H2PE.
C        SETUP1: LOGICAL FLAG TO SETUP FOR NEW VALUES OF NN1 OR NN2.
C        SETUP2: LOGICAL FLAG TO SETUP FOR NEW VALUES OF KK.
C        IX    : INTEGER CANDIDATE VALUE.
C        M     : DISTRIBUTION MODE.
C        MINJX : DISTRIBUTION LOWER BOUND.
C        MAXJX : DISTRIBUTION UPPER BOUND.
C        KS    : SAVED VALUE OF KK FROM THE LAST CALL TO H2PEC.
C        N1S   : SAVED VALUE OF NN1 FROM THE LAST CALL TO H2PEC.
C        N2S   : SAVED VALUE OF NN2 FROM THE LAST CALL TO H2PEC.
C        K,N1,N2: ALTERNATE VARIABLES FOR KK, NN1, AND NN2
C                   (ALWAYS (N1 .LE. N2) AND (K .LE. (N1+N2)/2)).
C        TN    : TOTAL NUMBER OF WHITE AND BLACK BALLS
C
C     INVERSE-TRANSFORMATION VARIABLES
C        CON   : NATURAL LOGARITHM  OF SCALE.
C        P     : CURRENT SCALED PROBABILITY FOR THE INVERSE CDF.
C        SCALE : A BIG CONSTANT (1.E25) USED TO SCALE THE
C                   PROBABILITY TO AVOID NUMERICAL UNDERFLOW
C        U     : THE UNIFORM VARIATE BETWEEN (0, 1.E25).
C        W     : SCALED HYPERGEOMETRIC PROBABILITY OF MINJX.
C
C     H2PE VARIABLES
C        S     : DISTRIBUTION STANDARD DEVIATION.
C        D     : HALF THE AREA OF THE RECTANGLE.
C        XL    : LEFT END OF THE RECTANGLE.
C        XR    : RIGHT END OF THE RECTANGLE.
C        A     : A SCALING CONSTANT.
C        KL    : HIGHEST POINT OF THE LEFT-TAIL REGION.
C        KR    : HIGHEST POINT OF THE RIGHT-TAIL REGION.
C        LAMDL : RATE FOR THE LEFT EXPONENTIAL TAIL.
C        LAMDR : RATE FOR THE RIGHT EXPONENTIAL TAIL.
C        P1    : AREA OF THE RECTANGLE.
C        P2    : AREA OF THE LEFT EXPONENTIAL TAIL PLUS P1.
C        P3    : AREA OF THE RIGHT EXPONENTIAL TAIL PLUS P2.
C        U     : A UNIFORM (0,P3) RANDOM VARIATE USED FIRST TO SELECT
C                   ONE OF THE THREE REGIONS AND THEN CONDITIONALLY TO
C                   GENERATE A VALUE FROM THE REGION.
C        V     : U(0,1) RANDOM NUMBER USED TO GENERATE THE RANDOM
C                   VALUE OR TO ACCEPT OR REJECT THE CANDIDATE VALUE.
C        F     : THE HEIGHT OF THE SCALED DENSITY FUNCTION USED IN THE
C                   ACCEPT/REJECT DECISION WHEN BOTH M AND IX ARE SMALL.
C        I     : INDEX FOR EXPLICIT CALCULATION OF F FOR H2PE.
C
C   THE FOLLOWING VARIABLES ARE TEMPORARY VARIABLES USED IN
C   COMPUTING THE UPPER AND LOWER BOUNDS OF THE NATURAL LOGARITHM
C   OF THE SCALED DENSITY.  THE DETAILED DESCRIPTION IS GIVEN IN
C   PROPOSITIONS 2 AND 3 OF THE APPENDIX IN THE REFERENCE.
C              Y, Y1, YM, YN, YK, NK, R, S, T, E, G, DG, GU, GL, XM,
C              XN, XK, NM
C
C        Y     : PRELIMINARY CONTINUOUS CANDIDATE VALUE, FLOAT(IX)
C        UB    : UPPER BOUND FOR THE NATURAL LOGARITHM OF THE SCALED
C                   DENSITY.
C        ALV   : NATURAL LOGARITHM OF THE ACCEPT/REJECT VARIATE V.
C        DR, DS, DT, DE: ONE OF MANY TERMS SUBTRACTED FROM THE UPPER
C                   BOUND TO OBTAIN THE LOWER BOUND ON THE NATURAL
C                   LOGARITHM OF THE SCALED DENSITY.
C        DELTAU: A CONSTANT, THE VALUE 0.0034 IS OBTAINED BY SETTING
C                   N1 = N2 = 200, K = 199, M = 100, AND Y = 50 IN
C                   THE FUNCTION DELTA_U IN LEMMA 1 AND ROUNDING THE
C                   VALUE TO FOUR DECIMAL PLACES.
C        DELTAL: A CONSTANT, THE VALUE 0.0078 IS OBTAINED BY SETTING
C                   N1 = N2 = 200, K = 199, M = 100, AND Y = 50 IN
C                   THE FUNCTION DELTA_L IN LEMMA 1 AND ROUNDING THE
C                   VALUE TO FOUR DECIMAL PLACES.
C
      SAVE
CCCCC SEPTEMBER 1995.  USE DLNGAM FUNCTION IN PLACE OF AFC
CCCCC DOUBLE PRECISION AFC,CON,P,SCALE,U,W,A,XL,XR
      DOUBLE PRECISION DLNGAM,CON,P,SCALE,U,W,A,XL,XR
      REAL KL,KR,LAMDL,LAMDR,NK,NM
CCCCC AUGUST 1995.  ADD FOLLOWING ARRAY FOR DATAPLOT
CCCCC UNIFORM RANDOM NUMBER GENERATOR.
      REAL XTEMP(1)
C
      LOGICAL REJECT,SETUP1,SETUP2
      DATA KS,N1S,N2S/-1,-1,-1/
      DATA CON,DELTAL,DELTAU,SCALE/57.56462733D0,0.0078,0.0034,1.D25/
C
C*****CHECK PARAMETER VALIDITY
C
      IF (  (NN1 .LT. 0)  .OR.
     $      (NN2 .LT. 0)  .OR.
     $      (KK  .LT. 0)  .OR.
     $      (KK  .GT. NN1 + NN2 )  ) THEN
         JX     = -1
         RETURN
      ENDIF
C
C*****IF NEW PARAMETER VALUES, INITIALIZE
C
      REJECT = .TRUE.
      SETUP1 = .FALSE.
      SETUP2 = .FALSE.
      IF ((NN1 .NE. N1S) .OR. (NN2 .NE. N2S))  THEN
            SETUP1 = .TRUE.
            SETUP2 = .TRUE.
      ELSEIF (KK .NE. KS)  THEN
            SETUP2 = .TRUE.
      ENDIF
C
      IF (SETUP1)  THEN
         N1S   = NN1
         N2S   = NN2
         TN    = NN1 + NN2
         IF (NN1 .LE. NN2)  THEN
            N1 = NN1
            N2 = NN2
         ELSE
            N1 = NN2
            N2 = NN1
         ENDIF
      ENDIF
C
      IF (SETUP2)  THEN
         KS    = KK
         IF (KK+KK .GE. TN)  THEN
            K  = TN - KK
         ELSE
            K  = KK
         ENDIF
      ENDIF
C
      IF (SETUP1 .OR. SETUP2)  THEN
         M     = INT ((K+1.) * (N1+1.) / (TN+2.))
         MINJX = MAX (0, K-N2)
         MAXJX = MIN (N1, K)
      ENDIF
C
C*****GENERATE RANDOM VARIATE
C
      IF (MINJX .EQ. MAXJX)  THEN
C
C        ...DEGENERATE DISTRIBUTION...
C
         IX      = MAXJX
         RETURN
      ELSEIF (M-MINJX .LT. 10)  THEN
C
C        ...INVERSE TRANSFORMATION...
C
         IF (SETUP1 .OR. SETUP2)  THEN
            IF (K .LT. N2) THEN
CCCCC SEPTEMBER 1995.  USE DLNGAM INSTEAD OF AFC
CCCCC          W = EXP (CON + AFC(N2) + AFC(N1+N2-K)
CCCCC$                       - AFC(N2-K) - AFC(N1+N2))
               W = EXP (CON + DLNGAM(DBLE(N2+1))+DLNGAM(DBLE(N1+N2-K+1))
     $                 - DLNGAM(DBLE(N2-K+1)) - DLNGAM(DBLE(N1+N2+1)))
            ELSE
CCCCC SEPTEMBER 1995.  USE DLNGAM INSTEAD OF AFC
CCCCC          W = EXP (CON + AFC(N1) + AFC(K)
CCCCC$                       - AFC(K-N2) - AFC(N1+N2))
               W = EXP (CON + DLNGAM(DBLE(N1+1)) + DLNGAM(DBLE(K+1))
     $                 - DLNGAM(DBLE(K-N2+1)) - DLNGAM(DBLE(N1+N2+1)))
            ENDIF
         ENDIF
C
   10    P  = W
         IX = MINJX
CCCCC SEPTEMBER 1995.  REPLACE RAND WITH DATAPLOT UNIFORM RANDOM
CCCCC NUMBER GENERATOR.
         NTEMP=1
         CALL UNIRAN(NTEMP,ISEED,XTEMP)
         U = XTEMP(1)*SCALE
CCCCCC   U  = RAND (ISEED) * SCALE
   20    IF (U .GT. P)  THEN
            U  = U - P
            P  = P * (N1-IX)*(K-IX)
            IX = IX + 1
            P  = P / IX / (N2-K+IX)
            IF (IX .GT. MAXJX)  GO TO 10
            GO TO 20
         ENDIF
      ELSE
C
C        ...H2PE...
C
         IF (SETUP1 .OR. SETUP2)  THEN
            S     = SQRT ((TN-K) * K * N1 * N2 / (TN-1) / TN /TN)
C
C           ...REMARK:  D IS DEFINED IN REFERENCE WITHOUT INT.
C           THE TRUNCATION CENTERS THE CELL BOUNDARIES AT 0.5
C
            D     = INT (1.5*S) + .5
            XL    = M - D + .5
            XR    = M + D + .5
CCCCC SEPTEMBER 1995.  USE DLNGAM INSTEAD OF AFC
CCCCC       A     = AFC(M) + AFC(N1-M) + AFC(K-M) + AFC(N2-K+M)
CCCCC       KL    = EXP (A - AFC(INT(XL)) - AFC(INT(N1-XL))
CCCCC$                  - AFC(INT(K-XL)) - AFC(INT(N2-K+XL)))
CCCCC       KR    = EXP (A - AFC(INT(XR-1)) - AFC(INT(N1-XR+1))
CCCCC$                  - AFC(INT(K-XR+1)) - AFC(INT(N2-K+XR-1)))
            A     = DLNGAM(DBLE(M+1)) + DLNGAM(DBLE(N1-M+1)) + 
     1              DLNGAM(DBLE(K-M+1)) + DLNGAM(DBLE(N2-K+M+1))
            KL    = EXP (A - DLNGAM(DBLE(INT(XL)+1)) - 
     1              DLNGAM(DBLE(INT(N1-XL)+1))
     1              - DLNGAM(DBLE(INT(K-XL)+1)) - 
     1              DLNGAM(DBLE(INT(N2-K+XL)+1)))
            KR    = EXP(A-DLNGAM(DBLE(INT(XR-1)+1)) - 
     1              DLNGAM(DBLE(INT(N1-XR+1)+1))
     1              - DLNGAM(DBLE(INT(K-XR+1)+1)) - 
     1              DLNGAM(DBLE(INT(N2-K+XR-1)+1)))
            LAMDL = -LOG (XL * (N2-K+XL) / (N1-XL+1) / (K-XL+1))
            LAMDR = -LOG ((N1-XR+1) * (K-XR+1) / XR / (N2-K+XR))
            P1    = D + D
            P2    = P1 + KL / LAMDL
            P3    = P2 + KR / LAMDR
         ENDIF
C
 30      CONTINUE
CCCCC AUGUST 1995.  REPLACE RAND WITH DATAPLOT UNIFORM RANDOM
CCCCC NUMBER GENERATOR.
         NTEMP=1
         CALL UNIRAN(NTEMP,ISEED,XTEMP)
         U = XTEMP(1) * P3
         CALL UNIRAN(NTEMP,ISEED,XTEMP)
         V = XTEMP(1)
CCC30    U     = RAND (ISEED) * P3
CCCCC    V     = RAND (ISEED)
         IF (U .LT. P1)  THEN
C
C           ...RECTANGULAR REGION...
C
            IX    = XL + U
         ELSEIF (U .LE. P2)  THEN
C
C           ...LEFT TAIL...
C
            IX    = XL + LOG(V)/LAMDL
            IF (IX .LT. MINJX)  GO TO 30
            V     = V * (U-P1) * LAMDL
         ELSE
C
C           ...RIGHT TAIL...
C
            IX    = XR - LOG(V)/LAMDR
            IF (IX .GT. MAXJX)  GO TO 30
            V     = V * (U-P2) * LAMDR
         ENDIF
C
C        ...ACCEPTANCE/REJECTION TEST...
C
         IF (M .LT. 100 .OR. IX .LE. 50)  THEN
C
C           ...EXPLICIT EVALUATION...
C
            F     = 1.0
            IF (M .LT. IX)  THEN
               DO 40 I = M+1,IX
   40          F      = F * (N1-I+1) * (K-I+1) / (N2-K+I) / I
            ELSEIF (M .GT. IX)  THEN
               DO 50 I = IX+1,M
   50          F      = F * I * (N2-K+I) / (N1-I) / (K-I)
            ENDIF
            IF (V .LE. F)  THEN
               REJECT = .FALSE.
            ENDIF
         ELSE
C
C        ...SQUEEZE USING UPPER AND LOWER BOUNDS...
C
            Y   = IX
            Y1  = Y + 1.
            YM  = Y - M
            YN  = N1 - Y + 1.
            YK  = K - Y + 1.
            NK  = N2 - K + Y1
            R   = -YM / Y1
            S   = YM / YN
            T   = YM / YK
            E   = -YM / NK
            G   = YN * YK / (Y1*NK) - 1.
            DG  = 1.
            IF (G .LT. 0.)  DG = 1.+G
            GU  = G * (1.+G*(-.5+G/3.))
            GL  = GU - .25 * (G*G)**2 / DG
            XM  = M + .5
            XN  = N1 - M + .5
            XK  = K - M + .5
            NM  = N2 - K + XM
            UB  = Y * GU - M * GL + DELTAU
     $              + XM * R * (1.+R*(-.5+R/3.))
     $              + XN * S * (1.+S*(-.5+S/3.))
     $              + XK * T * (1.+T*(-.5+T/3.))
     $              + NM * E * (1.+E*(-.5+E/3.))
C
C           ...TEST AGAINST UPPER BOUND...
C
            ALV = LOG(V)
            IF (ALV .GT. UB)  THEN
               REJECT = .TRUE.
            ELSE
C
C              ...TEST AGAINST LOWER BOUND...
C
               DR = XM * (R*R)**2
               IF (R .LT. 0.)  DR = DR / (1.+R)
               DS = XN * (S*S)**2
               IF (S .LT. 0.)  DS = DS / (1.+S)
               DT = XK * (T*T)**2
               IF (T .LT. 0.)  DT = DT / (1.+T)
               DE = NM * (E*E)**2
               IF (E .LT. 0.)  DE = DE / (1.+E)
               IF (ALV .LT. UB-.25*(DR+DS+DT+DE)
     $                         +(Y+M)*(GL-GU)-DELTAL)  THEN
                  REJECT = .FALSE.
               ELSE
C
C                 ...STIRLING'S FORMULA TO MACHINE ACCURACY...
C
CCCCC SEPTEMBER 1995.  USE DLNGAM INSTEAD OF AFC
CCCCC             IF (ALV .LE. (A - AFC(IX) - AFC(N1-IX)
CCCCC$                       - AFC(K-IX) - AFC(N2-K+IX)) )  THEN
                  IF (ALV .LE.(A-DLNGAM(DBLE(IX+1)) -
     $                        DLNGAM(DBLE(N1-IX+1))
     $                        - DLNGAM(DBLE(K-IX+1)) 
     $                        - DLNGAM(DBLE(N2-K+IX+1))))
     $            THEN
                     REJECT = .FALSE.
                  ELSE
                     REJECT = .TRUE.
                  ENDIF
               ENDIF
            ENDIF
         ENDIF
         IF (REJECT)  GO TO 30
      ENDIF
 
C
C*****RETURN APPROPRIATE VARIATE
C
      IF (KK + KK .GE. TN)  THEN
         IF (NN1 .GT. NN2)  THEN
            IX = KK - NN2 + IX
         ELSE
            IX =  NN1 - IX
         ENDIF
      ELSE
         IF (NN1 .GT. NN2)  IX = KK - IX
      ENDIF
      JX = IX
      RETURN
      END
      DOUBLE PRECISION FUNCTION I0INT(XVALUE)
C
C   DESCRIPTION:
C      This program computes the integral of the modified Bessel
C      function I0(x) using the definition
C
C         I0INT(x) = {integral 0 to x} I0(t) dt
C
C      The program uses Chebyshev expansions, the coefficients of
C      which are given to 20 decimal places.
C
C
C   ERROR RETURNS:
C      If |XVALUE| larger than a certain limit, the value of 
C      I0INT would cause an overflow. If such a situation occurs
C      the programs prints an error message, and returns the 
C      value sign(XVALUE)*XMAX, where XMAX is the largest
C      acceptable floating-pt. value.
C
C
C   MACHINE-DEPENDENT CONSTANTS:
C
C      NTERM1 - The no. of terms to be used from the array ARI01.
C                The recommended value is such that
C                    ABS(ARI01(NTERM1)) < EPS/100
C
C      NTERM2 - The no. of terms to be used from the array ARI0A.
C                The recommended value is such that
C                    ABS(ARI0A(NTERM2)) < EPS/100
C
C      XLOW - The value below which I0INT(x) = x, to machine precision.
C             The recommended value is 
C                  sqrt(12*EPS).
C
C      XHIGH - The value above which overflow will occur. The
C              recommended value is
C                  ln(XMAX) + 0.5*ln(ln(XMAX)) + ln(2).
C
C      For values of EPS and XMAX refer to the file MACHCON.TXT.
C
C      The machine-dependent constants are computed internally by
C      using the D1MACH subroutine.
C
C
C   INTRINSIC FUNCTIONS USED:
C
C      EXP , LOG , SQRT
C
C
C   OTHER MISCFUN SUBROUTINES USED:
C
C          CHEVAL , ERRPRN, D1MACH
C
C
C   AUTHOR:
C
C      Dr. Allan J. MacLeod,
C      Dept. of Mathematics and Statistics,
C      University of Paisley,
C      High St.,
C      Paisley,
C      SCOTLAND
C      PA1 2BE
C
C      (e-mail :   macl_ms0@paisley.ac.uk )
C
C
C   LATEST REVISION:
C                   23 January, 1996
C
      INTEGER IND,NTERM1,NTERM2
      DOUBLE PRECISION ARI01(0:28),ARI0A(0:33),
     1     ATEEN,CHEVAL,HALF,LNR2PI,ONEHUN,T,TEMP,THREE,THIRT6,
     2     X,XHIGH,XLOW,XVALUE,ZERO
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOMC.INC'
      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 CHARACTER FNNAME*6,ERRMSG*26
CCCCC DATA FNNAME/'I0INT '/
CCCCC DATA ERRMSG/'SIZE OF ARGUMENT TOO LARGE'/
      DATA ZERO,HALF,THREE/ 0.0 D 0 , 0.5 D 0 , 3.0 D 0 /
      DATA ATEEN,THIRT6,ONEHUN/ 18.0 D 0 , 36.0 D 0 , 100.0 D 0/
      DATA LNR2PI/0.91893 85332 04672 74178 D 0/
      DATA ARI01(0)/  0.41227 90692 67815 16801  D    0/
      DATA ARI01(1)/ -0.34336 34515 00815 19562  D    0/
      DATA ARI01(2)/  0.22667 58871 57512 42585  D    0/
      DATA ARI01(3)/ -0.12608 16471 87422 60032  D    0/
      DATA ARI01(4)/  0.60124 84628 77799 0271   D   -1/
      DATA ARI01(5)/ -0.24801 20462 91335 8248   D   -1/
      DATA ARI01(6)/  0.89277 33895 65563 897    D   -2/
      DATA ARI01(7)/ -0.28325 37299 36696 605    D   -2/
      DATA ARI01(8)/  0.79891 33904 17129 94     D   -3/
      DATA ARI01(9)/ -0.20053 93366 09648 90     D   -3/
      DATA ARI01(10)/ 0.44168 16783 01431 3      D   -4/
      DATA ARI01(11)/-0.82237 70422 46068        D   -5/
      DATA ARI01(12)/ 0.12005 97942 19015        D   -5/
      DATA ARI01(13)/-0.11350 86500 4889         D   -6/
      DATA ARI01(14)/ 0.69606 01446 6            D   -9/
      DATA ARI01(15)/ 0.18062 27728 36           D   -8/
      DATA ARI01(16)/-0.26039 48137 0            D   -9/
      DATA ARI01(17)/-0.16618 8103               D  -11/
      DATA ARI01(18)/ 0.51050 0232               D  -11/
      DATA ARI01(19)/-0.41515 879                D  -12/
      DATA ARI01(20)/-0.73681 38                 D  -13/
      DATA ARI01(21)/ 0.12793 23                 D  -13/
      DATA ARI01(22)/ 0.10324 7                  D  -14/
      DATA ARI01(23)/-0.30379                    D  -15/
      DATA ARI01(24)/-0.1789                     D  -16/
      DATA ARI01(25)/ 0.673                      D  -17/
      DATA ARI01(26)/ 0.44                       D  -18/
      DATA ARI01(27)/-0.14                       D  -18/
      DATA ARI01(28)/-0.1                        D  -19/
      DATA ARI0A(0)/  2.03739 65457 11432 87070  D    0/
      DATA ARI0A(1)/  0.19176 31647 50331 0248   D   -1/
      DATA ARI0A(2)/  0.49923 33451 92881 47     D   -3/
      DATA ARI0A(3)/  0.22631 87103 65981 5      D   -4/
      DATA ARI0A(4)/  0.15868 21082 85561        D   -5/
      DATA ARI0A(5)/  0.16507 85563 6318         D   -6/
      DATA ARI0A(6)/  0.23850 58373 640          D   -7/
      DATA ARI0A(7)/  0.39298 51823 04           D   -8/
      DATA ARI0A(8)/  0.46042 71419 9            D   -9/
      DATA ARI0A(9)/ -0.70725 58172              D  -10/
      DATA ARI0A(10)/-0.67471 83961              D  -10/
      DATA ARI0A(11)/-0.20269 62001              D  -10/
      DATA ARI0A(12)/-0.87320 338                D  -12/
      DATA ARI0A(13)/ 0.17552 0014               D  -11/
      DATA ARI0A(14)/ 0.60383 944                D  -12/
      DATA ARI0A(15)/-0.39779 83                 D  -13/
      DATA ARI0A(16)/-0.80490 48                 D  -13/
      DATA ARI0A(17)/-0.11589 55                 D  -13/
      DATA ARI0A(18)/ 0.82731 8                  D  -14/
      DATA ARI0A(19)/ 0.28229 0                  D  -14/
      DATA ARI0A(20)/-0.77667                    D  -15/
      DATA ARI0A(21)/-0.48731                    D  -15/
      DATA ARI0A(22)/ 0.7279                     D  -16/
      DATA ARI0A(23)/ 0.7873                     D  -16/
      DATA ARI0A(24)/-0.785                      D  -17/
      DATA ARI0A(25)/-0.1281                     D  -16/
      DATA ARI0A(26)/ 0.121                      D  -17/
      DATA ARI0A(27)/ 0.214                      D  -17/
      DATA ARI0A(28)/-0.27                       D  -18/
      DATA ARI0A(29)/-0.36                       D  -18/
      DATA ARI0A(30)/ 0.7                        D  -19/
      DATA ARI0A(31)/ 0.6                        D  -19/
      DATA ARI0A(32)/-0.2                        D  -19/
      DATA ARI0A(33)/-0.1                        D  -19/
C
C   Start computation
C
      IND = 1
      X = XVALUE
      IF ( XVALUE .LT. ZERO ) THEN
         IND = -1
         X = -X
      ENDIF
C
C   Compute the machine-dependent constants.
C
      T = LOG(D1MACH(2))
      XHIGH = T + LOG(T)*HALF - LOG(HALF)
C
C   Error test
C
      IF ( X .GT. XHIGH ) THEN
CCCCC    CALL ERRPRN(FNNAME,ERRMSG)
         WRITE(ICOUT,999)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,101)X
         CALL DPWRST('XXX','BUG ')
         I0INT = EXP ( XHIGH - LNR2PI - HALF * LOG(XHIGH) )
         IF ( IND .EQ. -1 ) I0INT = -I0INT
         RETURN
      ENDIF
  999 FORMAT(1X)
  101 FORMAT('***** ERROR FROM I0INT--SIZE OF THE INPUT ARGUMENT ',
     1        'IS TOO LARGE, ARGUMENT = ',G15.7)
C
C   Continue with machine-constants
C
      TEMP = D1MACH(3)
      T = TEMP / ONEHUN
      IF ( X .LE. ATEEN ) THEN
         DO 10 NTERM1 = 28 , 0 , -1
            IF ( ABS(ARI01(NTERM1)) .GT. T ) GOTO 19
 10      CONTINUE
 19      XLOW = SQRT ( THIRT6 * TEMP / THREE )
      ELSE
         DO 40 NTERM2 = 33 , 0 , -1
            IF ( ABS(ARI0A(NTERM2)) .GT. T ) GOTO 49
 40      CONTINUE
 49   ENDIF
C
C   Code for 0 <= |x| <= 18
C
      IF ( X .LE. ATEEN ) THEN
         IF ( X .LT. XLOW ) THEN
            I0INT = X
         ELSE
            T = ( THREE * X - ATEEN ) / ( X + ATEEN )
            I0INT = X * EXP(X) * CHEVAL(NTERM1,ARI01,T)
         ENDIF
      ELSE
C
C   Code for |x| > 18
C
         T = ( THIRT6 / X - HALF ) - HALF
         TEMP = X - HALF*LOG(X) - LNR2PI + LOG(CHEVAL(NTERM2,ARI0A,T))
         I0INT = EXP(TEMP)
      ENDIF
      IF ( IND .EQ. -1 ) I0INT = -I0INT
      RETURN
      END
      DOUBLE PRECISION FUNCTION I0ML0(XVALUE)
C
C   DESCRIPTION:
C
C      This program calculates the function I0ML0 defined as
C
C                I0ML0(x) = I0(x) - L0(x)
C
C      where I0(x) is the modified Bessel function of the first kind of
C      order 0, and L0(x) is the modified Struve function of order 0.
C
C      The code uses Chebyshev expansions with the coefficients 
C      given to an accuracy of 20D.
C
C
C   ERROR RETURNS:
C
C      The coefficients are only suitable for XVALUE >= 0.0. If
C      XVALUE < 0.0, an error message is printed and the function
C      returns the value 0.0
C
C
C   MACHINE-DEPENDENT PARAMETERS:
C
C      NTERM1 - INTEGER - The number of terms required for the array
C                         AI0L0. The recommended value is such that
C                              ABS(AI0L0(NTERM1)) < EPS/100
C
C      NTERM2 - INTEGER - The number of terms required for the array
C                         AI0L0A. The recommended value is such that
C                              ABS(AI0L0A(NTERM2)) < EPS/100
C
C      XLOW - DOUBLE PRECISION - The value below which I0ML0(x) = 1 to machine
C                    precision. The recommended value is
C                               EPSNEG
C
C      XHIGH - DOUBLE PRECISION - The value above which I0ML0(x) = 2/(pi*x) to 
C                     machine precision. The recommended value is
C                               SQRT(800/EPS) 
C
C      For values of EPS, and EPSNEG see the file MACHCON.TXT
C
C      The machine-dependent constants are computed internally by
C      using the D1MACH subroutine.
C
C
C   INTRINSIC FUNCTIONS USED:
C
C      SQRT  
C
C
C   OTHER MISCFUN SUBROUTINES USED:
C
C          CHEVAL , ERRPRN, D1MACH
C
C
C   AUTHOR:
C          Dr. Allan J. MacLeod
C          Dept. of Mathematics and Statistics
C          University of Paisley
C          High St.
C          Paisley
C          SCOTLAND
C          PA1 2BE
C
C          ( e-mail: macl_ms0@paisley.ac.uk ) 
C
C
C   LATEST REVISION:
C                    23 January, 1996
C
      INTEGER NTERM1,NTERM2
      DOUBLE PRECISION AI0L0(0:23),AI0L0A(0:23),ATEHUN,CHEVAL,
     1     FORTY,ONE,ONEHUN,SIX,SIXTEN,T,TWOBPI,TWO88,X,XHIGH,
     2     XLOW,XSQ,XVALUE,ZERO
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOMC.INC'
      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 CHARACTER FNNAME*6,ERRMSG*14
CCCCC DATA FNNAME/'I0ML0 '/
CCCCC DATA ERRMSG/'ARGUMENT < 0.0'/
      DATA ZERO,ONE/ 0.0 D 0 , 1.0 D 0 /
      DATA SIX,SIXTEN/ 6.0 D 0 , 16.0 D 0 /
      DATA FORTY,ONEHUN/ 40.0 D 0 , 100.0 D 0 /
      DATA TWO88,ATEHUN/ 288.0 D 0 , 800.0 D 0 /
      DATA TWOBPI/0.63661 97723 67581 34308 D 0/
      DATA AI0L0(0)/  0.52468 73679 14855 99138  D    0/
      DATA AI0L0(1)/ -0.35612 46069 96505 86196  D    0/
      DATA AI0L0(2)/  0.20487 20286 40099 27687  D    0/
      DATA AI0L0(3)/ -0.10418 64052 04026 93629  D    0/
      DATA AI0L0(4)/  0.46342 11095 54842 9228   D   -1/
      DATA AI0L0(5)/ -0.17905 87192 40349 8630   D   -1/
      DATA AI0L0(6)/  0.59796 86954 81143 177    D   -2/
      DATA AI0L0(7)/ -0.17177 75476 93565 429    D   -2/
      DATA AI0L0(8)/  0.42204 65446 91714 22     D   -3/
      DATA AI0L0(9)/ -0.87961 78522 09412 5      D   -4/
      DATA AI0L0(10)/ 0.15354 34234 86922 3      D   -4/
      DATA AI0L0(11)/-0.21978 07695 84743        D   -5/
      DATA AI0L0(12)/ 0.24820 68393 6666         D   -6/
      DATA AI0L0(13)/-0.20327 06035 607          D   -7/
      DATA AI0L0(14)/ 0.90984 19842 1            D   -9/
      DATA AI0L0(15)/ 0.25617 93929              D  -10/
      DATA AI0L0(16)/-0.71060 9790               D  -11/
      DATA AI0L0(17)/ 0.32716 960                D  -12/
      DATA AI0L0(18)/ 0.23002 15                 D  -13/
      DATA AI0L0(19)/-0.29210 9                  D  -14/
      DATA AI0L0(20)/-0.3566                     D  -16/
      DATA AI0L0(21)/ 0.1832                     D  -16/
      DATA AI0L0(22)/-0.10                       D  -18/
      DATA AI0L0(23)/-0.11                       D  -18/
      DATA AI0L0A(0)/ 2.00326 51024 11606 43125  D    0/
      DATA AI0L0A(1)/ 0.19520 68515 76492 081    D   -2/
      DATA AI0L0A(2)/ 0.38239 52356 99083 28     D   -3/
      DATA AI0L0A(3)/ 0.75342 80817 05443 6      D   -4/
      DATA AI0L0A(4)/ 0.14959 57655 89707 8      D   -4/
      DATA AI0L0A(5)/ 0.29994 05312 10557        D   -5/
      DATA AI0L0A(6)/ 0.60769 60482 2459         D   -6/
      DATA AI0L0A(7)/ 0.12399 49554 4506         D   -6/
      DATA AI0L0A(8)/ 0.25232 62552 649          D   -7/
      DATA AI0L0A(9)/ 0.50463 48573 32           D   -8/
      DATA AI0L0A(10)/0.97913 23623 0            D   -9/
      DATA AI0L0A(11)/0.18389 11524 1            D   -9/
      DATA AI0L0A(12)/0.33763 09278              D  -10/
      DATA AI0L0A(13)/0.61117 9703               D  -11/
      DATA AI0L0A(14)/0.10847 2972               D  -11/
      DATA AI0L0A(15)/0.18861 271                D  -12/
      DATA AI0L0A(16)/0.32803 45                 D  -13/
      DATA AI0L0A(17)/0.56564 7                  D  -14/
      DATA AI0L0A(18)/0.93300                    D  -15/
      DATA AI0L0A(19)/0.15881                    D  -15/
      DATA AI0L0A(20)/0.2791                     D  -16/
      DATA AI0L0A(21)/0.389                      D  -17/
      DATA AI0L0A(22)/0.70                       D  -18/
      DATA AI0L0A(23)/0.16                       D  -18/
C
C   Start computation
C
      X = XVALUE
C
C   Error test
C
      IF ( X .LT. ZERO ) THEN
CCCCC    CALL ERRPRN(FNNAME,ERRMSG)
         WRITE(ICOUT,999)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,101)X
         CALL DPWRST('XXX','BUG ')
         I0ML0 = ZERO
         RETURN
      ENDIF
  999 FORMAT(1X)
  101 FORMAT('***** ERROR FROM I0ML0--ARGUMENT MUST BE ',
     1        'NON-NEGATIVE, ARGUMENT = ',G15.7)
C
C   Compute the machine-dependent constants.
C
      XSQ = D1MACH(3)
      T = XSQ / ONEHUN
      IF ( X .LE. SIXTEN ) THEN
         DO 10 NTERM1 = 23 , 0 , -1
            IF ( ABS(AI0L0(NTERM1)) .GT. T ) GOTO 19
 10      CONTINUE
 19      XLOW = XSQ
      ELSE
         DO 40 NTERM2 = 23 , 0 , -1
            IF ( ABS(AI0L0A(NTERM2)) .GT. T ) GOTO 49
 40      CONTINUE
 49      XHIGH = SQRT ( ATEHUN / XSQ )
      ENDIF
C
C   Code for x <= 16
C
      IF ( X .LE. SIXTEN ) THEN
         IF ( X .LT. XLOW ) THEN
            I0ML0 = ONE 
            RETURN
         ELSE
            T = ( SIX * X - FORTY ) / ( X + FORTY )
            I0ML0 = CHEVAL(NTERM1,AI0L0,T)
            RETURN
         ENDIF
      ELSE
C
C   Code for x > 16
C
         IF ( X .GT. XHIGH ) THEN
            I0ML0 = TWOBPI / X
         ELSE
            XSQ = X * X
            T = ( ATEHUN - XSQ ) / ( TWO88 + XSQ )
            I0ML0 = CHEVAL(NTERM2,AI0L0A,T) * TWOBPI / X
         ENDIF
      ENDIF
      RETURN
      END
      DOUBLE PRECISION FUNCTION I1ML1(XVALUE)
C
C   DESCRIPTION:
C
C      This program calculates the function I1ML1 defined as
C
C                I1ML1(x) = I1(x) - L1(x)
C
C      where I1(x) is the modified Bessel function of the first kind of
C      order 1, and L1(x) is the modified Struve function of order 1.
C
C      The code uses Chebyshev expansions with the coefficients 
C      given to an accuracy of 20D.
C
C
C   ERROR RETURNS:
C
C      The coefficients are only suitable for XVALUE >= 0.0. If
C      XVALUE < 0.0, an error message is printed and the function
C      returns the value 0.0
C
C
C   MACHINE-DEPENDENT PARAMETERS:
C
C      NTERM1 - INTEGER - The number of terms required for the array
C                         AI1L1. The recommended value is such that
C                              ABS(AI1L1(NTERM1)) < EPS/100
C
C      NTERM2 - INTEGER - The number of terms required for the array
C                         AI1L1A. The recommended value is such that
C                              ABS(AI1L1A(NTERM2)) < EPS/100
C
C      XLOW - DOUBLE PRECISION - The value below which I1ML1(x) = x/2 to machine
C                    precision. The recommended value is
C                               2*EPSNEG
C
C      XHIGH - DOUBLE PRECISION - The value above which I1ML1(x) = 2/pi to 
C                     machine precision. The recommended value is
C                               SQRT(800/EPS) 
C
C      For values of EPS, and EPSNEG see the file MACHCON.TXT
C
C      The machine-dependent constants are computed internally by
C      using the D1MACH subroutine.
C
C
C   INTRINSIC FUNCTIONS USED:
C
C      ABS , SQRT  
C
C
C   OTHER MISCFUN SUBROUTINES USED:
C
C          CHEVAL , ERRPRN, D1MACH
C
C
C   AUTHOR:
C          Dr. Allan J. MacLeod
C          Dept. of Mathematics and Statistics
C          University of Paisley
C          High St.
C          Paisley
C          SCOTLAND
C          PA1 2BE
C
C          (e-mail: macl_ms0@paisley.ac.uk )
C
C
C   LATEST REVISION:
C                    23 January, 1996
C
      INTEGER NTERM1,NTERM2
      DOUBLE PRECISION AI1L1(0:23),AI1L1A(0:25),ATEHUN,CHEVAL,
     1     FORTY,ONE,ONEHUN,SIX,SIXTEN,T,TWO,TWOBPI,TWO88,
     2     X,XHIGH,XLOW,XSQ,XVALUE,ZERO
CCCCC CHARACTER FNNAME*6,ERRMSG*14
CCCCC DATA FNNAME/'I1ML1 '/
CCCCC DATA ERRMSG/'ARGUMENT < 0.0'/
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOMC.INC'
      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,ONE,TWO/ 0.0 D 0 , 1.0 D 0 , 2.0 D 0 /
      DATA SIX,SIXTEN,FORTY/ 6.0 D 0 , 16.0 D 0 , 40.0 D 0 /
      DATA ONEHUN,TWO88,ATEHUN/ 100.0 D 0 , 288.0 D 0 , 800.0 D 0 /
      DATA TWOBPI/0.63661 97723 67581 34308 D 0/
      DATA AI1L1(0)/  0.67536 36906 23505 76137  D    0/
      DATA AI1L1(1)/ -0.38134 97109 72665 59040  D    0/
      DATA AI1L1(2)/  0.17452 17077 51339 43559  D    0/
      DATA AI1L1(3)/ -0.70621 05887 23502 5061   D   -1/
      DATA AI1L1(4)/  0.25173 41413 55880 3702   D   -1/
      DATA AI1L1(5)/ -0.78709 85616 06423 321    D   -2/
      DATA AI1L1(6)/  0.21481 43686 51922 006    D   -2/
      DATA AI1L1(7)/ -0.50862 19971 79062 36     D   -3/
      DATA AI1L1(8)/  0.10362 60828 04423 30     D   -3/
      DATA AI1L1(9)/ -0.17954 47212 05724 7      D   -4/
      DATA AI1L1(10)/ 0.25978 82745 15414        D   -5/
      DATA AI1L1(11)/-0.30442 40632 4667         D   -6/
      DATA AI1L1(12)/ 0.27202 39894 766          D   -7/
      DATA AI1L1(13)/-0.15812 61441 90           D   -8/
      DATA AI1L1(14)/ 0.18162 09172              D  -10/
      DATA AI1L1(15)/ 0.64796 7659               D  -11/
      DATA AI1L1(16)/-0.54113 290                D  -12/
      DATA AI1L1(17)/-0.30831 1                  D  -14/
      DATA AI1L1(18)/ 0.30563 8                  D  -14/
      DATA AI1L1(19)/-0.9717                     D  -16/
      DATA AI1L1(20)/-0.1422                     D  -16/
      DATA AI1L1(21)/ 0.84                       D  -18/
      DATA AI1L1(22)/ 0.7                        D  -19/
      DATA AI1L1(23)/-0.1                        D  -19/
      DATA AI1L1A(0)/  1.99679 36189 67891 36501  D    0/
      DATA AI1L1A(1)/ -0.19066 32614 09686 132    D   -2/
      DATA AI1L1A(2)/ -0.36094 62241 01744 81     D   -3/
      DATA AI1L1A(3)/ -0.68418 47304 59982 0      D   -4/
      DATA AI1L1A(4)/ -0.12990 08228 50942 6      D   -4/
      DATA AI1L1A(5)/ -0.24715 21887 05765        D   -5/
      DATA AI1L1A(6)/ -0.47147 83969 1972         D   -6/
      DATA AI1L1A(7)/ -0.90208 19982 592          D   -7/
      DATA AI1L1A(8)/ -0.17304 58637 504          D   -7/
      DATA AI1L1A(9)/ -0.33232 36701 59           D   -8/
      DATA AI1L1A(10)/-0.63736 42173 5            D   -9/
      DATA AI1L1A(11)/-0.12180 23975 6            D   -9/
      DATA AI1L1A(12)/-0.23173 46832              D  -10/
      DATA AI1L1A(13)/-0.43906 8833               D  -11/
      DATA AI1L1A(14)/-0.82847 110                D  -12/
      DATA AI1L1A(15)/-0.15562 249                D  -12/
      DATA AI1L1A(16)/-0.29131 12                 D  -13/
      DATA AI1L1A(17)/-0.54396 5                  D  -14/
      DATA AI1L1A(18)/-0.10117 7                  D  -14/
      DATA AI1L1A(19)/-0.18767                    D  -15/
      DATA AI1L1A(20)/-0.3484                     D  -16/
      DATA AI1L1A(21)/-0.643                      D  -17/
      DATA AI1L1A(22)/-0.118                      D  -17/
      DATA AI1L1A(23)/-0.22                       D  -18/
      DATA AI1L1A(24)/-0.4                        D  -19/
      DATA AI1L1A(25)/-0.1                        D  -19/
C
C   Start computation
C
      X = XVALUE
C
C   Error test
C
      IF ( X .LT. ZERO ) THEN
CCCCC    CALL ERRPRN(FNNAME,ERRMSG)
         WRITE(ICOUT,999)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,101)X
         CALL DPWRST('XXX','BUG ')
         I1ML1 = ZERO
         RETURN
      ENDIF
  999 FORMAT(1X)
  101 FORMAT('***** ERROR FROM I1ML1--ARGUMENT MUST BE ',
     1        'NON-NEGATIVE, ARGUMENT = ',G15.7)
C
C   Compute the machine-dependent constants.
C
      XSQ = D1MACH(3)
      T = XSQ / ONEHUN
      IF ( X .LE. SIXTEN ) THEN
         DO 10 NTERM1 = 23 , 0 , -1
            IF ( ABS(AI1L1(NTERM1)) .GT. T ) GOTO 19
 10      CONTINUE
 19      XLOW = XSQ + XSQ
      ELSE
         DO 40 NTERM2 = 25 , 0 , -1
            IF ( ABS(AI1L1A(NTERM2)) .GT. T ) GOTO 49
 40      CONTINUE
 49      XHIGH = SQRT ( ATEHUN / XSQ )
      ENDIF
C
C   Code for x <= 16
C
      IF ( X .LE. SIXTEN ) THEN
         IF ( X .LT. XLOW ) THEN
            I1ML1 = X / TWO 
            RETURN
         ELSE
            T = ( SIX * X - FORTY ) / ( X + FORTY )
            I1ML1 = CHEVAL(NTERM1,AI1L1,T) * X / TWO
            RETURN
         ENDIF
      ELSE
C
C   Code for x > 16
C
         IF ( X .GT. XHIGH ) THEN
            I1ML1 = TWOBPI 
         ELSE
            XSQ = X * X
            T = ( ATEHUN - XSQ ) / ( TWO88 + XSQ )
            I1ML1 = CHEVAL(NTERM2,AI1L1A,T) * TWOBPI 
         ENDIF
      ENDIF
      RETURN
      END
      SUBROUTINE IBCDF(X,ALPHA,BETA,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE INVERTED BETA DISTRIBUTION
C              WITH SHAPE PARAMETERS ALPHA AND BETA.
C              THIS DISTRIBUTION IS DEFINED FOR ALL X AND HAS
C              THE PROBABILITY DENSITY FUNCTION
C              IBPDF(X,A,B) = X**(ALPHA-1)/
C                             [BETA(ALPHA,BETA)*(1+X)**(ALPHA+BETA),
C                             X, ALPHA, BETA > 0
C              THE CUMULATIVE DISTRIBUTION IS COMPUTED BY
C              ALPHAMERICALLY INTEGRATING THE PDF FUNCTION.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C                     --ALPHA  = THE DEGREES OF FREEDOM PARAMETER
C                     --BETA   = THE SKEWNESS PARAMETER
C     OUTPUT ARGUMENTS--CDF    = THE SINGLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE CDF FOR THE INVERTED BETA DISTRIBUTION
C             WITH SHAPE PARAMETERS ALPHA AND BETA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--DQAGI.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME II", SECOND EDITION,
C                 JOHN WILEY, 1994.
C               --EVANS, HASTINGS, AND PEACOCK, "STATISTICAL
C                 DISTRIBUTIONS", THIRD EDITION, JOHN WILEY, 2000.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           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--2003.12
C     ORIGINAL VERSION--DECEMBER  2003.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      INTEGER LIMIT
      INTEGER LENW
      PARAMETER(LIMIT=200)
      PARAMETER(LENW=4*LIMIT)
      INTEGER INF
      INTEGER NEVAL
      INTEGER IER
      INTEGER LAST
      INTEGER IWORK(LIMIT)
      REAL ALPHA
      REAL BETA
      REAL X
      REAL CDF
      DOUBLE PRECISION EPSABS
      DOUBLE PRECISION EPSREL
      DOUBLE PRECISION RESULT
      DOUBLE PRECISION DCDF
      DOUBLE PRECISION DX
      DOUBLE PRECISION DA
      DOUBLE PRECISION ABSERR
      DOUBLE PRECISION WORK(LENW)
C
      DOUBLE PRECISION IBFUN
      EXTERNAL IBFUN
C
      DOUBLE PRECISION DALPHA
      DOUBLE PRECISION DBETA
      COMMON/IBCOM/DALPHA,DBETA
C
C---------------------------------------------------------------------
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
      CDF=0.0
      IF(ALPHA.LE.0.0)THEN
        WRITE(ICOUT,101)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,102)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,104)ALPHA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
      IF(BETA.LE.0.0)THEN
        WRITE(ICOUT,103)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,102)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,104)BETA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
      IF(X.LE.0.0)THEN
        WRITE(ICOUT,106)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,104)X
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
  101 FORMAT('***** ERROR--THE FIRST SHAPE PARAMETER, ALPHA, TO THE')
  102 FORMAT('      IBCDF ROUTINE IS NON-POSITIVE.')
  103 FORMAT('***** ERROR--THE SECOND SHAPE PARAMETER, BETA, TO THE')
  104 FORMAT('      THE VALUE OF THE ARGUMENT IS ',E15.7,' ******')
  106 FORMAT('***** ERROR--THE FIRST ARGUMENT TO THE IBCDF ROUTINE ',
     1       'IS NON-POSITIVE.')
C
C
C               ************************************
C               **  STEP 1--                      **
C               **  COMPUTE THE DENSITY FUNCTION  **
C               ************************************
C
      INF=+1
      EPSABS=1.0D-7
      EPSREL=1.0D-7
      IER=0
      IKEY=3
      CDF=0.0D0
C
      DA=1.0D-7
      DX=DBLE(X)
      DALPHA=DBLE(ALPHA)
      DBETA=DBLE(BETA)
C
CCCCC REPLACE WITH A CODE FOR DEFINITE INTEGRAL.
CCCCC CALL DQAGI(IBFUN,DX,INF,EPSABS,EPSREL,DCDF,ABSERR,NEVAL,
CCCCC1          IER,LIMIT,LENW,LAST,IWORK,WORK)
C
CCCCC DCDF=1.0D0 - DCDF
C
      CALL DQAG(IBFUN,DA,DX,EPSABS,EPSREL,IKEY,DCDF,ABSERR,NEVAL,
     1          IER,LIMIT,LENW,LAST,IWORK,WORK)
      CDF=REAL(DCDF)
C
      IF(IER.EQ.1)THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,111)
  111   FORMAT('***** ERROR FROM IBCDF--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,113)
  113   FORMAT('      MAXIMUM NUMBER OF SUBDIVISIONS EXCEEDED.')
        CALL DPWRST('XXX','BUG ')
      ELSEIF(IER.EQ.2)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,121)
  121   FORMAT('***** ERROR FROM IBCDF--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,123)
  123   FORMAT('      ROUNDOFF ERROR PREVENTS REQUESTED TOLERANCE ',
     1         'FROM BEING ACHIEVED.')
        CALL DPWRST('XXX','BUG ')
      ELSEIF(IER.EQ.3)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,131)
  131   FORMAT('***** ERROR FROM IBCDF--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,133)
  133   FORMAT('      BAD INTEGRAND BEHAVIOUR DETECTED.')
        CALL DPWRST('XXX','BUG ')
      ELSEIF(IER.EQ.4)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,141)
  141   FORMAT('***** ERROR FROM IBCDF--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,143)
  143   FORMAT('      INTEGRATION DID NOT CONVERGE.')
        CALL DPWRST('XXX','BUG ')
      ELSEIF(IER.EQ.5)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,151)
  151   FORMAT('***** ERROR FROM IBCDF--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,153)
  153   FORMAT('      THE INTEGRATION IS PROBABLY DIVERGENT.')
        CALL DPWRST('XXX','BUG ')
      ELSEIF(IER.EQ.6)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,161)
  161   FORMAT('***** ERROR FROM IBCDF--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,163)
  163   FORMAT('      INVALID INPUT TO THE INTEGRATION ROUTINE.')
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      DOUBLE PRECISION FUNCTION IBFUN(DX)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE INVERTED BETA DISTRIBUTION
C              WITH SHAPE PARAMETERS ALPHA AND BETA.
C              THIS DISTRIBUTION IS DEFINED FOR X > 0 AND HAS
C              THE PROBABILITY DENSITY FUNCTION
C              IBPDF(X,A,B) = X**(ALPHA-1)/
C                             [BETA(ALPHA,BETA)*(1+X)**(ALPHA+BETA),
C                             X, ALPHA, BETA > 0
C              IDENTICAL TO IBPDF,
C              BUT DEFINE AS FUNCTION TO BE USED FOR INTEGRATION
C              CODE CALLED BY IBCDF.
C     INPUT  ARGUMENTS--DX     = THE DOUBLE PRECISION VALUE AT
C                                WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C     OUTPUT ARGUMENTS--IBFUN  = THE DOUBLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE PDF FOR THE SKEW-T DISTRIBUTION
C             WITH SHAPE PARAMETERS ALPHA AND BETA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--DLBETA.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME II", SECOND EDITION,
C                 JOHN WILEY, 1994.
C               --EVANS, HASTINGS, AND PEACOCK, "STATISTICAL
C                 DISTRIBUTIONS", THIRD EDITION, JOHN WILEY, 2000.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           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
      EXTERNAL DLBETA
C
      DOUBLE PRECISION DLBETA
      DOUBLE PRECISION DX
      DOUBLE PRECISION DPDF
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
C
      DOUBLE PRECISION DALPHA
      DOUBLE PRECISION DBETA
      COMMON/IBCOM/DALPHA,DBETA
C
C---------------------------------------------------------------------
C
      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
      DTERM1=(DALPHA-1.0D0)*DLOG(DX)
      DTERM2=DLBETA(DALPHA,DBETA)
      DTERM3=(DALPHA+DBETA)*DLOG(1.0D0+DX)
C
      DPDF=DTERM1 - DTERM2 - DTERM3
      IF(DPDF.LT.LOG(CPUMAX))THEN
        DPDF=DEXP(DPDF)
      ELSE
        WRITE(ICOUT,501)
        CALL DPWRST('XXX','BUG ')
        DPDF=LOG(CPUMAX)
      ENDIF
  501 FORMAT('***** WARNING FROM INVERTED BETA PDF--OVERFLOW ',
     1       'DETECTED.')
C
 9000 CONTINUE
      IBFUN=DPDF
      RETURN
      END
      REAL FUNCTION IBFU2(X)
C
C     PURPOSE--IBPPF CALLS FZERO TO FIND A ROOT FOR THE PERCENT
C              POINT FUNCTION.  IBFU2 IS THE FUNCTION FOR WHICH
C              THE ZERO IS FOUND.  IT IS:
C                 P - IBCDF(X,LAMBDA)
C              WHERE P IS THE DESIRED PERCENT POINT.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C     OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE IBFU2.
C     PRINTING--NONE.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--IBCDF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME I", SECOND EDITION,
C                 JOHN WILEY, 1994, PAGE 454.
C               --AZZALINI HAS AUTHORED A NUMBER OF PAPERS ON THIS
C                 DISTRIBUTION.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           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
      COMMON/IB2COM/P
C
      DOUBLE PRECISION DALPHA
      DOUBLE PRECISION DBETA
      COMMON/IBCOM/DALPHA,DBETA
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 IBCDF(X,REAL(DALPHA),REAL(DBETA),CDF)
      IBFU2=P - CDF
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE IBPDF(X,ALPHA,BETA,PDF)
C
C     NOTE--INVERTED BETA PDF IS:
C              IBPDF(X,A,B) = X**(ALPHA-1)/
C                             [BETA(ALPHA,BETA)*(1+X)**(ALPHA+BETA),
C                             X > 0
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2899
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME II", SECOND EDITION,
C                 JOHN WILEY, 1994.
C               --EVANS, HASTINGS, AND PEACOCK, "STATISTICAL
C                 DISTRIBUTIONS", THIRD EDITION, JOHN WILEY, 2000.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2003/5
C     ORIGINAL VERSION--MAY       2003.
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      EXTERNAL DLBETA
C
      DOUBLE PRECISION DLBETA
      DOUBLE PRECISION DX
      DOUBLE PRECISION DALPHA
      DOUBLE PRECISION DBETA
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
      DOUBLE PRECISION DPDF
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      PDF=0.0
      IF(ALPHA.LE.0.0)THEN
        WRITE(ICOUT,101)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,102)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,104)ALPHA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
      IF(BETA.LE.0.0)THEN
        WRITE(ICOUT,103)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,102)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,104)BETA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
      IF(X.LE.0.0)THEN
        WRITE(ICOUT,106)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,104)X
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
  101 FORMAT('***** ERROR--THE FIRST SHAPE PARAMETER, ALPHA, TO THE')
  102 FORMAT('      IBPDF ROUTINE IS NON-POSITIVE.')
  103 FORMAT('***** ERROR--THE SECOND SHAPE PARAMETER, BETA, TO THE')
  104 FORMAT('      THE VALUE OF THE ARGUMENT IS ',E15.7,' ******')
  106 FORMAT('***** ERROR--THE FIRST ARGUMENT TO THE IBPDF ROUTINE ',
     1       'IS NON-POSITIVE.')
C
      DX=DBLE(X)
      DALPHA=DBLE(ALPHA)
      DBETA=DBLE(BETA)
C
      DTERM1=(DALPHA-1.0D0)*LOG(DX)
      DTERM2=DLBETA(DALPHA,DBETA)
      DTERM3=(DALPHA+DBETA)*LOG(1.0D0+DX)
C
      DPDF=DTERM1 - DTERM2 - DTERM3
      IF(DPDF.LT.LOG(CPUMAX))THEN
        DPDF=DEXP(DPDF)
      ELSE
        WRITE(ICOUT,501)
        CALL DPWRST('XXX','BUG ')
        DPDF=LOG(CPUMAX)
      ENDIF
  501 FORMAT('***** WARNING FROM INVERTED BETA PDF--OVERFLOW ',
     1       'DETECTED.')
      PDF=REAL(DPDF)
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE IBPPF(P,ALPHA,BETA,PPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE INVERTED BETA DISTRIBUTION
C              WITH SHAPE PARAMETERS ALPHA AND BETA.
C              THIS DISTRIBUTION IS DEFINED FOR POSITIVE X AND THE
C              PERCENT POINT FUNCTION IS COMPUTED BY
C              NUMERICALLY INVERTING THE CDF FUNCTION.
C     INPUT  ARGUMENTS--P      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE PERCENT POINT
C                                FUNCTION IS TO BE EVALUATED.
C                     --ALPHA  = THE FIRST SHAPE PARAMETER
C                     --BETA   = THE SECOND SHAPE PARAMETER
C     OUTPUT ARGUMENTS--PPF    = THE SINGLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PERCENT POINT
C             FUNCTION VALUE PPF.
C     PRINTING--NONE.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--FZERO.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME II", SECOND EDITION,
C                 JOHN WILEY, 1994.
C               --EVANS, HASTINGS, AND PEACOCK, "STATISTICAL
C                 DISTRIBUTIONS", THIRD EDITION, JOHN WILEY, 2000.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           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--2003.12
C     ORIGINAL VERSION--DECEMBER  2003.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      REAL PPF
C
      REAL IBFU2
      EXTERNAL IBFU2
C
      REAL P2
      COMMON/IB2COM/P2
C
      DOUBLE PRECISION DALPHA
      DOUBLE PRECISION DBETA
      COMMON/IBCOM/DALPHA,DBETA
C
      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
      PPF=0.0
      IF(ALPHA.LE.0.0)THEN
        WRITE(ICOUT,101)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,102)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,104)ALPHA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
      IF(BETA.LE.0.0)THEN
        WRITE(ICOUT,103)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,102)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,104)BETA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
  101 FORMAT('***** ERROR--THE FIRST SHAPE PARAMETER, ALPHA, TO THE')
  102 FORMAT('      IBPPF ROUTINE IS NON-POSITIVE.')
  103 FORMAT('***** ERROR--THE SECOND SHAPE PARAMETER, BETA, TO THE')
  104 FORMAT('      THE VALUE OF THE ARGUMENT IS ',E15.7,' ******')
  106 FORMAT('***** ERROR--THE FIRST ARGUMENT TO THE IBPPF ROUTINE ',
     1       'IS NON-POSITIVE.')
C
C
      IF(P.LT.0.0.OR.P.GE.1.0)THEN
         WRITE(ICOUT,61)
   61    FORMAT('***** ERROR--THE FIRST  INPUT ARGUMENT ',
     1          'TO THE IBPPF SUBROUTINE ')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,62)
   62    FORMAT('      IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL ***')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,63)P
   63    FORMAT('      VALUE OF ARGUMENT = ',G15.7)
         CALL DPWRST('XXX','BUG ')
         PPF=0.0
         GOTO9000
      ENDIF
C
      IF(P.EQ.0.0)THEN
        PPF=0.0
        GOTO9000
      ENDIF
C
C  STEP 1: FIND BRACKETING INTERVAL.  LOWER BOUND IS ZERO.  START WITH
C          10 AS GUESS FOR UPPER BOUND.  MULTIPLY BY 10 UNTIL
C          BRACKETING INTERVAL FOUND.
C
      XLOW=0.0000001
      XUP2=10.0
  200 CONTINUE
        CALL IBCDF(XUP2,ALPHA,BETA,PTEMP)
        IF(PTEMP.GT.P)THEN
          XUP=XUP2
        ELSE
          XUP2=XUP2*10.0
          IF(XUP2.GT.CPUMAX/100.)THEN
            WRITE(ICOUT,201)
  201       FORMAT('***** ERROR FROM IBPPF--UNABLE TO FIND A ',
     1             'BRACKETING INTERVAL')
            CALL DPWRST('XXX','BUG ')
            GOTO9000
          ENDIF
          GOTO200
        ENDIF
C
  300 CONTINUE
      AE=1.E-6
      RE=1.E-6
      P2=P
      DALPHA=DBLE(ALPHA)
      DBETA=DBLE(BETA)
      CALL FZERO(IBFU2,XLOW,XUP,XUP,RE,AE,IFLAG)
C
      PPF=XLOW
C
      IF(IFLAG.EQ.2)THEN
C
C  NOTE: SUPPRESS THIS MESSAGE FOR NOW.
CCCCC   WRITE(ICOUT,999)
  999   FORMAT(1X)
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   WRITE(ICOUT,111)
CC111   FORMAT('***** WARNING FROM IBPPF--')
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   WRITE(ICOUT,113)
CC113   FORMAT('      PPF VALUE MAY NOT BE COMPUTED TO DESIRED ',
CCCCC1         'TOLERANCE.')
CCCCC   CALL DPWRST('XXX','BUG ')
      ELSEIF(IFLAG.EQ.3)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,121)
  121   FORMAT('***** WARNING FROM IBPPF--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,123)
  123   FORMAT('      PPF VALUE MAY BE NEAR A SINGULAR POINT.')
        CALL DPWRST('XXX','BUG ')
      ELSEIF(IFLAG.EQ.4)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,131)
  131   FORMAT('***** ERROR FROM IBPPF--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,133)
  133   FORMAT('      APPROPRIATE BRACKETING INTERVAL NOT FOUND.')
        CALL DPWRST('XXX','BUG ')
      ELSEIF(IFLAG.EQ.5)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,141)
  141   FORMAT('***** WARNING FROM IBPPF--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,143)
  143   FORMAT('      MAXIMUM ITERATIONS EXCEEDED.')
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE IBRAN(N,ALPHA,BETA,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE INVERTED BETA DISTRIBUTION
C              WITH SINGLE PRECISION SHAPE PARAMETERS = ALPHA AND BETA.
C              THE PROTOTYPE INVERTED BETA DISTRIBUTION USED
C              HEREIN CAN BE EXPRESSED AS THE RATIO OF TWO INDEPENDENT
C              GAMMA DISTRIBUTIONS WITH SHAPE PARAMETERS ALPHA AND
C              BETA, RESPECTIVELY.
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --ALPHA  = THE SINGLE PRECISION VALUE OF THE
C                                FIRST  SHAPE PARAMETER.
C                                ALPHA SHOULD BE GREATER THAN 0.0.
C                     --BETA   = THE SINGLE PRECISION VALUE OF THE
C                                SECOND SHAPE PARAMETER.
C                                BETA  SHOULD BE GREATER THAN 0.0.
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST N)
C                                INTO WHICH THE GENERATED
C                                RANDOM SAMPLE WILL BE PLACED.
C     OUTPUT--A RANDOM SAMPLE OF SIZE N
C             FROM THE INVERTED BETA DISTRIBUTION
C             WITH SHAPE PARAMETER VALUES = ALPHA AND BETA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C                 --ALPHA SHOULD BE GREATER THAN
C                   OR EQUAL TO 0.0.
C                 --BETA  SHOULD BE GREATER THAN
C                   OR EQUAL TO 0.0.
C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN, GAMRAN.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--EVANS, HASTINGS AND PEACOCK, "STATISTICAL
C                 DISTRIBUTIONS--THIRD EDITION", WILEY, 2000.
C                 PAGES 41-42.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2899
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           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--HOLLARITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--2003.5
C     ORIGINAL VERSION--MAY       2003.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
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(ALPHA.LE.0.0)THEN
        WRITE(ICOUT,16)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ALPHA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
      IF(BETA.LT.0.0)THEN
        WRITE(ICOUT,26)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)BETA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
    5 FORMAT('***** FATAL ERROR--THE NUMBER OF REQUESTED INVERTED ',
     1'BETA RANDOM NUMBERS IS NON-POSITIVE.')
   16 FORMAT('***** FATAL ERROR--THE FIRST SHAPE PARAMETER FOR THE ',
     1'INVERTED BETA IS LESS THAN 0.0 *****')
   26 FORMAT('***** FATAL ERROR--THE SECOND SHAPE PARAMETER FOR THE ',
     1'INVERTED BETA IS LESS THAN 0.0 *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
C
C     GENERATE N BETA RANDOM NUMBERS BY USING THE FACT THAT THE
C     INVERTED BETA IS A RATIO OF TWO INDEPENDENT GAMMA VARIATES.
C
      NTEMP=1
      DO100I=1,N
C
      CALL GAMRAN(NTEMP,ALPHA,ISEED,XG1)
      CALL GAMRAN(NTEMP,BETA,ISEED,XG2)
      X(I)=0.0
      IF(XG2.GT.0.0)X(I)=XG1/XG2
C
  100 CONTINUE
C
 9000 CONTINUE
      RETURN
      END
      INTEGER FUNCTION IDAMAX(N,DX,INCX)
C***BEGIN PROLOGUE  IDAMAX
C***DATE WRITTEN   791001   (YYMMDD)
C***REVISION DATE  820801   (YYMMDD)
C***CATEGORY NO.  D1A2
C***KEYWORDS  BLAS,DOUBLE PRECISION,LINEAR ALGEBRA,MAXIMUM COMPONENT,
C             VECTOR
C***AUTHOR  LAWSON, C. L., (JPL)
C           HANSON, R. J., (SNLA)
C           KINCAID, D. R., (U. OF TEXAS)
C           KROGH, F. T., (JPL)
C***PURPOSE  Find largest component of d.p. vector
C***DESCRIPTION
C
C                B L A S  Subprogram
C    Description of Parameters
C
C     --Input--
C        N  number of elements in input vector(s)
C       DX  double precision vector with N elements
C     INCX  storage spacing between elements of DX
C
C     --Output--
C   IDAMAX  smallest index (zero if N .LE. 0)
C
C     Find smallest index of maximum magnitude of double precision DX.
C     IDAMAX =  first I, I = 1 to N, to minimize  ABS(DX(1-INCX+I*INCX)
C***REFERENCES  LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T.,
C                 *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*,
C                 ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL
C                 SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323
C***ROUTINES CALLED  (NONE)
C***END PROLOGUE  IDAMAX
C
      DOUBLE PRECISION DX(1),DMAX,XMAG
C***FIRST EXECUTABLE STATEMENT  IDAMAX
      IDAMAX = 0
      IF(N.LE.0) RETURN
      IDAMAX = 1
      IF(N.LE.1)RETURN
      IF(INCX.EQ.1)GOTO 20
C
C        CODE FOR INCREMENTS NOT EQUAL TO 1.
C
      DMAX = DABS(DX(1))
      NS = N*INCX
      II = 1
          DO 10 I = 1,NS,INCX
          XMAG = DABS(DX(I))
          IF(XMAG.LE.DMAX) GO TO 5
          IDAMAX = II
          DMAX = XMAG
    5     II = II + 1
   10     CONTINUE
      RETURN
C
C        CODE FOR INCREMENTS EQUAL TO 1.
C
   20 DMAX = DABS(DX(1))
      DO 30 I = 2,N
          XMAG = DABS(DX(I))
          IF(XMAG.LE.DMAX) GO TO 30
          IDAMAX = I
          DMAX = XMAG
   30 CONTINUE
      RETURN
      END
      SUBROUTINE IGACDF(X,ALPHA,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE INVERTED GAMMA DISTRIBUTION
C              WITH POSITIVE SHAPE PARAMETER ALPHA.
C              THIS DISTRIBUTION IS DEFINED FOR ALL POSITIVE X.
C              THE PROBABILITY DENSITY FUNCTION IS GIVEN
C              IN THE REFERENCES BELOW.
C              THE CDF FOR THE STANDARD FORM OF THE DISTRIBUTION IS
C                  F(X,ALPHA) = GAMMAIP(1/X,ALPHA)
C              WHERE GAMMAIP = GAMMAI(ALPHA,X)/GAMMA(ALPHA).
C              THE CDF IS CAN BE COMPUTED WITH THE SLATEC ROUTINE
C              DGAMIC.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE NON-NEGATIVE.
C                     --ALPHA  = A POSITIVE SHAPE PARAMETER
C     OUTPUT ARGUMENTS--CDF    = THE SINGLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE CDF FOR THE INVERTED GAMMA DISTRIBUTION
C             WITH SHAPE PARAMETER ALPHA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE NON-NEGATIVE.
C                 --ALPHA SHOULD BE A POSITIVE NUMBER.
C     OTHER DATAPAC   SUBROUTINES NEEDED--GAMMIP.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--EVANS, HASTINGS, AND PEACOCK, "STATISTICAL
C                DISTRIBUTIONS", THIRD EDITION, WILEY, 2000,
C                GAMMA CHAPTER.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           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. PREVIOUSLY IMPLEMENTED
C                                       AS SPECIAL CASE OF GGDCDF
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DALPHA
      DOUBLE PRECISION 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.LE.0.0)THEN
        WRITE(ICOUT,4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ENDIF
      IF(ALPHA.LE.0)THEN
        WRITE(ICOUT,15)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ALPHA
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ENDIF
    4 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT ',
     1'TO THE IGACDF SUBROUTINE IS NON-POSITIVE *****')
   15 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO THE ',
     1'IGACDF SUBROUTINE IS NON-POSITIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
C
      IF(X.LE.R1MACH(1))THEN
        CDF=0.0
        RETURN
      ENDIF
C
      DX=DBLE(X)
      DALPHA=DBLE(ALPHA)
C
      DCDF=1.0D0 - DGAMIP(DALPHA,1.0D0/DX)
      CDF=REAL(DCDF)
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE IGAPDF(X,ALPHA,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE INVERTED GAMMA DISTRIBUTION
C              WITH POSITIVE SHAPE PARAMETER ALPHA.
C              THIS DISTRIBUTION IS DEFINED FOR ALL POSITIVE X.
C              THE PDF FOR THE STANDARD FORM OF THE DISTRIBUTION IS
C                  F(X,ALPHA) = X**(-(ALPHA+1))*EXP(-1/X)/GAMMA(ALPHA)
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE NON-NEGATIVE.
C                     --ALPHA  = A POSITIVE SHAPE PARAMETER
C     OUTPUT ARGUMENTS--PDF    = THE SINGLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE PDF FOR THE INVERTED GAMMA DISTRIBUTION
C             WITH SHAPE PARAMETER ALPHA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE NON-NEGATIVE.
C                 --ALPHA AND X SHOULD BE POSITIVE NUMBERS.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--EVANS, HASTINGS, AND PEACOCK, "STATISTICAL
C                DISTRIBUTIONS", THIRD EDITION, WILEY, 2000,
C                GAMMA CHAPTER.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           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. PREVIOUSLY COMPUTED USING
C                                       GENERALIZED GAMMA WITH C=-1
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DALPHA
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
      DOUBLE PRECISION DTERM4
      DOUBLE PRECISION DPDF
      DOUBLE PRECISION DLNGAM
C
C---------------------------------------------------------------------
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.LE.0.0)THEN
        WRITE(ICOUT,4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ENDIF
      IF(ALPHA.LE.0)THEN
        WRITE(ICOUT,15)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ALPHA
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ENDIF
    4 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT ',
     1'TO THE IGAPDF SUBROUTINE IS NON-POSITIVE *****')
   15 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO THE ',
     1'IGAPDF SUBROUTINE IS NON-POSITIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
      IF(X.LE.R1MACH(1))THEN
        PDF=0.0
        RETURN
      ENDIF
C
      DX=DBLE(X)
      DALPHA=DBLE(ALPHA)
C
      DTERM1=-(DALPHA+1.0D0)*DLOG(DX)
      DTERM2=-1.0D0/DX
      DTERM3=DLNGAM(DALPHA)
      DTERM4=DTERM1+DTERM2-DTERM3
      DPDF=0.0D0
      IF(DTERM4.GE.-80.0D0)DPDF=DEXP(DTERM4)
      PDF=REAL(DPDF)
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE IGAPPF(P,ALPHA,PPF)
C
C     PURPOSE   --PERCENT POINT FUNCTION FOR THE INVERTED GAMMA
C                 DISTRIBUTION.  USES A BISECTION METHOD.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           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. PREVIOUSLY IMPLEMENTED AS
C                                       SPECIAL CASE OF GGDPPF
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DP
      DOUBLE PRECISION DALPHA
      DOUBLE PRECISION EPS
      DOUBLE PRECISION SIG
      DOUBLE PRECISION ZERO
      DOUBLE PRECISION DMEAN
      DOUBLE PRECISION DSD
      DOUBLE PRECISION 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
      DOUBLE PRECISION DGAMIP
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 /5000/
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(P.LT.0.0.OR.P.GE.1.0)THEN
        WRITE(ICOUT,1)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)P
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
        GOTO9999
      ENDIF
C
      IF(ALPHA.LE.0.0)THEN
        WRITE(ICOUT,15)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ALPHA
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ENDIF
      IF(ALPHA.LT.0.1)THEN
        WRITE(ICOUT,25)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ALPHA
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ENDIF
    1 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO THE ',
     1' IGAPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1] INTERVAL.')
   15 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO THE ',
     1'IGAPDF SUBROUTINE IS NON-POSITIVE *****')
   25 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO THE ',
     1'IGAPDF SUBROUTINE IS < 0.1')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
      IF(P.EQ.0.)THEN
        PPF=0.
        GOTO9999
      ENDIF
C
C  FIND BRACKETING INTERVAL.
C
      DP=DBLE(P)
      DALPHA=DBLE(ALPHA)
C
      XL=0.0D0
      IF(ALPHA.GT.1.0)THEN
        DMEAN=1.0D0/(DALPHA-1.0D0)
      ELSE
        IF(ALPHA.GE.0.9)THEN
          DMEAN=10.0
        ELSEIF(ALPHA.GE.0.5)THEN
          DMEAN=50.0
        ELSEIF(ALPHA.GE.0.1)THEN
          DMEAN=100.0
          IF(P.GT.0.75)DMEAN=10000
        ELSE
          DMEAN=500.0
          IF(P.GT.0.75)DMEAN=100000
        ENDIF
      ENDIF
      IF(ALPHA.GT.2.0)THEN
        DSD=DSQRT(1.0D0/((DALPHA-1.0D0)**2*(DALPHA-2.0)))
      ELSEIF(ALPHA.GE.0.9)THEN
        DSD=3.0
      ELSEIF(ALPHA.GE.0.5)THEN
        DSD=10.0
      ELSEIF(ALPHA.GE.0.1)THEN
        IF(P.LE.0.75)THEN
          DSD=1000.0
        ELSE
          DSD=10000.0
        ENDIF
      ELSE
        IF(P.LE.0.75)THEN
          DSD=1000.0
        ELSE
          DSD=5000.0
        ENDIF
      ENDIF
C
      XR=DMEAN
      XINC=DSD
      ICOUNT=0
      MAXCNT=10000
C
   91 CONTINUE
      IF(XL.LE.0.0D0)THEN
        CDFL=0.0D0
      ELSE
        CDFL=1.0D0 - DGAMIP(DALPHA,1.0D0/XL)
      ENDIF
      IF(XR.LE.0.0D0)XR=XL+DMEAN
      CDFR=1.0D0 - DGAMIP(DALPHA,1.0D0/XR)
      IF(CDFL.LT.DP .AND. CDFR.LT.DP)THEN
        XL=XR
        XR=XL+XINC
      ELSEIF(CDFL.GT.DP .AND. CDFR.GT.DP)THEN
        XL=XL-XINC
        IF(XL.LT.0.0D0)XL=0.0D0
      ELSE
        GOTO99
      ENDIF
      ICOUNT=ICOUNT+1
      IF(ICOUNT.GT.MAXCNT)THEN
        WRITE(ICOUT,96)
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
        GOTO9999
      ENDIF
   96 FORMAT('***** FATAL ERROR--IGAPPF UNABLE TO FIND BRACKETING ',
     *       'INTERVAL. *****')
      GOTO91
C
C  BISECTION METHOD
C
   99 CONTINUE
      IC = 0
      FXL = -DP
      FXR = 1.0D0 - DP
  105 CONTINUE
      X = (XL+XR)*0.5D0
      DCDF=1.0D0 - DGAMIP(DALPHA,1.0D0/X)
      P1=DCDF
      PPF=REAL(X)
      FCS = P1 - DP
      IF(FCS*FXL.GT.ZERO)GOTO110
      XR = X
      FXR = FCS 
      GOTO115
  110 CONTINUE
      XL = X
      FXL = FCS
  115 CONTINUE
      XRML = XR - XL
      IF(XRML.LE.SIG .AND. ABS(FCS).LE.EPS)GOTO9999
      IC = IC + 1
      IF(IC.LE.MAXIT)GOTO105
      WRITE(ICOUT,130)
      CALL DPWRST('XXX','BUG ')
  130 FORMAT('***** FATAL ERROR--IGAPPF ROUTINE DID NOT CONVERGE. ***')
      GOTO9999
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE IGARAN(N,GAMMA,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE INVERTED GAMMA DISTRIBUTION
C              WITH TAIL LENGTH PARAMETER VALUE = GAMMA.
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --GAMMA  = THE SINGLE PRECISION VALUE OF THE
C                                TAIL LENGTH PARAMETER.
C                                GAMMA SHOULD BE POSITIVE.
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST N)
C                                INTO WHICH THE GENERATED
C                                RANDOM SAMPLE WILL BE PLACED.
C     OUTPUT--A RANDOM SAMPLE OF SIZE N
C             FROM THE INVERTED GAMMA DISTRIBUTION
C             WITH TAIL LENGTH PARAMETER VALUE = GAMMA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C                 --GAMMA SHOULD BE POSITIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--ALOG.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--XX
C               --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 2ND. ED., 1994.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           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.10
C     ORIGINAL VERSION--OCTOBER   2001.
C     UPDATED  VERSION--JANUARY   2005. BUG IF ROUTINE CALLED MORE
C                                       THAN ONCE, RESET AA AND AAA
C                                       AND STORE IN COMMON
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
C
      COMMON/SGAMM/AA,AAA
C
C---------------------------------------------------------------------
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'IGARAN SUBROUTINE IS NON-POSITIVE *****')
   15 FORMAT('***** FATAL ERROR--THE 2ND INPUT ARGUMENT TO THE ',
     1'IGARAN SUBROUTINE IS NON-POSITIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
C
C     GENERATE N UNIFORM (0,1) RANDOM NUMBERS;
C
CCCCC CALL UNIRAN(N,ISEED,X)
      AA=0.0
      AAA=0.0
C
C     GENERATE N INVERTED GAMMA DISTRIBUTION RANDOM NUMBERS
C     USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD.
C
C     NOTE 6/2004: USE RELATIONSHIP TO GAMMA DISTRIBUTION.
C
CCCCC C=-1.0
      DO100I=1,N
        ATEMP=SGAMMA(ISEED,GAMMA)
        X(I)=1.0/ATEMP
CCCCC   CALL GGDPPF(X(I),GAMMA,C,XTEMP)
CCCCC   X(I)=XTEMP
  100 CONTINUE
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE IGCDF(X,GAMMA,AMU,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE INVERSE GAUSSIAN DISTRIBUTION
C              WITH TAIL LENGTH PARAMETER = GAMMA
C              AND SHAPE PARAMETER = MU.
C              THE INVERSE GAUSSIAN DISTRIBUTION USED
C              HEREIN IS DEFINED FOR ALL NON-NEGATIVE X,
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C              AS GIVEN IN VOLUME 4, PAGE 246, BOTTOM
C              OF ENCYCLOPEDIA OF STATISTICAL SCIENCES
C              AND GENERAL CUMULATIVE DISTRIBUTION FUNCTION
C              AS GIVEN IN VOLUME 4, PAGE 247, COLUMN 1
C              OF ENCYCLOPEDIA OF STATISTICAL SCIENCES
C     NOTE--THE GENERAL INVERSE GAUSSIAN DISTRIBUTION--
C              GOES FROM 0 TO INFINITY
C              HAS MEAN = MU
C              HAS STANDARD DEVIATION = SQRT((MU**3)/GAMMA)
C              HAS SHAPE PARAMETER = GAMMA
C              IS HIGHLY-SKEWED AND LONG-TAILED FOR SMALL GAMMA
C              IS SYMMETRIC AND MODERATE-TAILED FOR KARGE GAMMA
C              APPROACHES NORMALITY AS GAMMA APPROACHES INFINITY
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE NON-NEGATIVE.
C                     --GAMMA  = THE SHAPE PARAMETER
C                                GAMMA SHOULD BE POSITIVE.
C                     --AMU    = THE SHAPE PARAMETER
C                                AMU 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 INVERSE GAUSSIAN DISTRIBUTION
C             WITH TAIL LENGTH PARAMETER = GAMMA
C             AND WITH SHAPE PARAMETER = MU
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE NON-NEGATIVE.
C                 --GAMMA AND AMU SHOULD BE POSITIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NORCDF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--EXP.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--KOTZ & JOHNSON, ENCYCLOPEDIA OF STAT SCIENCES
C                 VOLUME 4, PAGE 247, COLUMN 1.
C     WRITTEN BY--JAMES J. FILLIBEN
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--90.6
C     ORIGINAL VERSION--MAY       1990.
C     UPDATED         --JANUARY   1995. NEW CDF DEFINITION & REWRITTEN
C     UPDATED         --DECEMBER  1998. USE DOUBLE PRECISION
C     UPDATED         --OCTOBER   2001. BUG FIX.  MISSING SOME
C                                       DOUBLE PRECISION DECLARATIONS
C     UPDATED         --DECEMBER  2003. GENERAL CASE FOR MU (I.E.,
C                                       DON'T ASSUME MU=1)
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DCDF
      DOUBLE PRECISION DGAMMA
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
CCCCC OCTOBER 2001.  ADD FOLLOWING 3 LINES
      DOUBLE PRECISION DTERM4
      DOUBLE PRECISION DTERM5
      DOUBLE PRECISION DTERM6
      DOUBLE PRECISION DTRM12
      DOUBLE PRECISION DTRM14
      DOUBLE PRECISION DMU
      DOUBLE PRECISION DPI
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.LE.0)THEN
         WRITE(ICOUT,51)
   51    FORMAT('***** ERROR--THE FIRST SHAPE PARAMETER ',
     1          'TO THE IGCDF SUBROUTINE IS NON-POSITIVE *****')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,52)GAMMA
   52    FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
         CALL DPWRST('XXX','BUG ')
         CDF=0.0
         GOTO9000
      ENDIF
C
      IF(AMU.LE.0)THEN
         WRITE(ICOUT,71)
   71    FORMAT('***** ERROR--THE SECOND SHAPE PARAMETER ',
     1          'TO THE IGCDF SUBROUTINE IS NON-POSITIVE *****')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,52)GAMMA
         CALL DPWRST('XXX','BUG ')
         CDF=0.0
         GOTO9000
      ENDIF
C
      DX=DBLE(X)
      DGAMMA=DBLE(GAMMA)
C
      IF(DX.LE.0.0D0)THEN
         CDF=0.0
      ELSEIF(DX.GT.0.0)THEN
         DMU=DBLE(AMU)
         DPI=3.1415926535 8979323846 2643383279 503 D0
         DTERM1=DSQRT(DGAMMA/DX)
         DTERM2=(-1.0D0+DX/DMU)
         DTERM3=2.0D0*DGAMMA/DMU
         DTERM4=(1.0D0+DX/DMU)
         DTRM12=DTERM1*DTERM2
         DTRM14=(-DTERM1*DTERM4)
         CALL NODCDF(DTRM12,DTERM5)
         CALL NODCDF(DTRM14,DTERM6)
         DCDF=DTERM5+DEXP(DTERM3)*DTERM6
         CDF=REAL(DCDF)
         GOTO9000
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE IGCDF2(DX,DGAMMA,DMU,DCDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE INVERSE GAUSSIAN DISTRIBUTION
C              WITH TAIL LENGTH PARAMETER = GAMMA
C              AND LOCATION PARAMETER = 1.
C              THE INVERSE GAUSSIAN DISTRIBUTION USED
C              HEREIN IS DEFINED FOR ALL NON-NEGATIVE X,
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C              AS GIVEN IN VOLUME 4, PAGE 246, BOTTOM
C              OF ENCYCLOPEDIA OF STATISTICAL SCIENCES
C                 WITH MU = 1
C              AND GENERAL CUMULATIVE DISTRIBUTION FUNCTION
C              AS GIVEN IN VOLUME 4, PAGE 247, COLUMN 1
C              OF ENCYCLOPEDIA OF STATISTICAL SCIENCES
C                 WITH MU = 1
C     NOTE--THE GENERAL INVERSE GAUSSIAN DISTRIBUTION--
C              GOES FROM 0 TO INFINITY
C              HAS MEAN = MU (HERE = 1)
C              HAS STANDARD DEVIATION = SQRT((MU**3)/GAMMA)
C              HAS SHAPE PARAMETER = GAMMA
C              IS HIGHLY-SKEWED AND LONG-TAILED FOR SMALL GAMMA
C              IS SYMMETRIC AND MODERATE-TAILED FOR KARGE GAMMA
C              APPROACHES NORMALITY AS GAMMA APPROACHES INFINITY
C     NOTE--TO OBTAIN THE CDF FOR GENERAL MU,
C           COMPUTE THE CDF FOR X AROUND 1, AND THEN
C           SIMPLY SCALE UP THE HORIZONTAL AXIS X BY THE DESIRED MU
C           AS IN Y2 = MU*Y
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE NON-NEGATIVE.
C                     --GAMMA  = THE SHAPE PARAMETER
C                                GAMMA SHOULD BE POSITIVE.
C                     --MU     = THE SHAPE PARAMETER
C                                MU 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 INVERSE GAUSSIAN DISTRIBUTION
C             WITH TAIL LENGTH PARAMETER = GAMMA
C             AND WITH SHAPE PARAMETER = MU
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE NON-NEGATIVE.
C                 --GAMMA SHOULD BE POSITIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NORCDF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--EXP.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--KOTZ & JOHNSON, ENCYCLOPEDIA OF STAT SCIENCES
C                 VOLUME 4, PAGE 247, COLUMN 1.
C     WRITTEN BY--JAMES J. FILLIBEN
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--90.6
C     ORIGINAL VERSION--MAY       1990.
C     UPDATED         --JANUARY   1995. NEW CDF DEFINITION & REWRITTEN
C     UPDATED         --DECEMBER  1998. USE DOUBLE PRECISION
C     UPDATED         --DECEMBER  2003. FULL SUPPORT FOR MU
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DCDF
      DOUBLE PRECISION DGAMMA
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
      DOUBLE PRECISION DTERM5
      DOUBLE PRECISION DTERM6
      DOUBLE PRECISION DTRM12
      DOUBLE PRECISION DTRM14
      DOUBLE PRECISION DMU
      DOUBLE PRECISION DPI
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(DGAMMA.LE.0D0)THEN
         WRITE(ICOUT,51)
   51    FORMAT('***** ERROR--THE FIRST SHAPE PARAMETER ',
     1          'TO THE IGCDF2 SUBROUTINE IS NON-POSITIVE *****')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,52)DGAMMA
   52    FORMAT('***** THE VALUE OF THE ARGUMENT IS ',D15.8,' *****')
         CALL DPWRST('XXX','BUG ')
         DCDF=0.0D0
         GOTO9000
      ENDIF
C
      IF(DMU.LE.0D0)THEN
         WRITE(ICOUT,61)
   61    FORMAT('***** ERROR--THE SECOND SHAPE PARAMETER ',
     1          'TO THE IGCDF2 SUBROUTINE IS NON-POSITIVE *****')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,52)DMU
         CALL DPWRST('XXX','BUG ')
         DCDF=0.0D0
         GOTO9000
      ENDIF
C
      IF(DX.LE.0.0D0)THEN
         DCDF=0.0
      ELSEIF(DX.GT.0.0)THEN
         DPI=3.1415926535 8979323846 2643383279 503 D0
         DTERM1=DSQRT(DGAMMA/DX)
         DTERM2=(-1.0D0+DX/DMU)
         DTERM3=2.0D0*DGAMMA/DMU
         DTERM4=(1.0D0+DX/DMU)
         DTRM12=DTERM1*DTERM2
         DTRM14=(-DTERM1*DTERM4)
         CALL NODCDF(DTRM12,DTERM5)
         CALL NODCDF(DTRM14,DTERM6)
         DCDF=DTERM5+DEXP(DTERM3)*DTERM6
         GOTO9000
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE IGCHA(X,GAMMA,AMU,HAZ)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE HAZARD
C              FUNCTION VALUE FOR THE INVERSE GAUSSIAN DISTRIBUTION
C              WITH TAIL LENGTH PARAMETER = GAMMA
C              AND SHAPE PARAMETER = MU.
C              THE INVERSE GAUSSIAN DISTRIBUTION USED
C              HEREIN IS DEFINED FOR ALL POSITIVE X,
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C              AS GIVEN IN VOLUME 4, PAGE 246, BOTTOM
C              OF ENCYCLOPEDIA OF STATISTICAL SCIENCES
C     NOTE--THE GENERAL INVERSE GAUSSIAN DISTRIBUTION--
C              GOES FROM 0 TO INFINITY
C              HAS MEAN = MU
C              HAS STANDARD DEVIATION = SQRT((MU**3)/GAMMA)
C              HAS SHAPE PARAMETER = GAMMA
C              IS HIGHLY-SKEWED AND LONG-TAILED FOR SMALL GAMMA
C              IS SYMMETRIC AND MODERATE-TAILED FOR KARGE GAMMA
C              APPROACHES NORMALITY AS GAMMA APPROACHES INFINITY
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE CUMULATIVE HAZARD
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE POSITIVE.
C                     --GAMMA  = THE SHAPE PARAMETER
C                                GAMMA SHOULD BE POSITIVE.
C                     --AMU    = THE SHAPE PARAMETER
C                                AMU SHOULD BE POSITIVE.
C     OUTPUT ARGUMENTS--HAZ    = THE SINGLE PRECISION CUMULATIVE HAZARD
C                                FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION CUMULATIVE HAZARD
C             FUNCTION VALUE FOR THE INVERSE GAUSSIAN DISTRIBUTION
C             WITH TAIL LENGTH PARAMETER = GAMMA
C             AND WITH SHAPE PARAMETER = MU
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE POSITIVE.
C                 --GAMMA AND MU SHOULD BE POSITIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--EXP.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--KOTZ & JOHNSON, ENCYCLOPEDIA OF STAT SCIENCES
C                 VOLUME 4, PAGE 246, BOTTOM.
C     WRITTEN BY--JAMES J. FILLIBEN
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--98.4
C     ORIGINAL VERSION--APRIL     1998.
C     UPDATED         --DECEMBER  2003.
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(GAMMA.LE.0)THEN
         WRITE(ICOUT,51)
   51    FORMAT('***** ERROR--THE FIRST SHAPE PARAMETER FOR THE ',
     1          'IGCHA SUBROUTINE IS NON-POSITIVE *****')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,52)GAMMA
   52    FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
         CALL DPWRST('XXX','BUG ')
         HAZ=0.0
         GOTO9000
      ENDIF
C
      IF(AMU.LE.0)THEN
         WRITE(ICOUT,71)
   71    FORMAT('***** ERROR--THE SECOND SHAPE PARAMETER FOR THE ',
     1          'IGCHA SUBROUTINE IS NON-POSITIVE *****')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,52)AMU
         CALL DPWRST('XXX','BUG ')
         HAZ=0.0
         GOTO9000
      ENDIF
C
      IF(X.LT.0.0)THEN
         WRITE(ICOUT,61)
   61    FORMAT('***** ERROR--THE FIRST  INPUT ',
     1   'ARGUMENT TO THE IGCHA SUBROUTINE IS NON-POSITIVE *****')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,52)X
         CALL DPWRST('XXX','BUG ')
         HAZ=0.0
         GOTO9000
      ENDIF
C
      IF(X.EQ.0.0)THEN
         HAZ=0.0
         GOTO9000
      ENDIF
C
      IF(X.GT.0.0)THEN
         CALL IGCDF(X,GAMMA,AMU,CDF)
         CDF=1.0-CDF
         IF(CDF.GT.0.0)THEN
           HAZ=-LOG(CDF)
         ELSE
           WRITE(ICOUT,162)X
  162      FORMAT('***** FOR THE VALUE OF THE ARGUMENT ',E15.8,
     1     ' THE CDF IS ESSENTIALLY 1, CUMULATIVE HAZARD SET TO 0.')
         CALL DPWRST('XXX','BUG ')
         HAZ=0.0
         ENDIF
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      CHARACTER*1 FUNCTION IGET(ICURS, ISTRNG, LNGTH)
C  PART OF ACM 591 FOR ANOVA
C  ****************************** IGET ******************************   IGE   10
C                                                                       IGE   20
C  USED BY THE MAIN PROGRAM AND SCAN TO SEQUENTIALLY RETRIEVE CHARAC-   IGE   30
C  TERS FROM THE INPUT BUFFER.                                          IGE   40
C                                                                       IGE   50
C  ARGUMENTS - ICURS = POSITION IN CHARACTER STRING; ISTRNG = CHARAC-   IGE   60
C              TER STRING (INPUT BUFFER); LNGTH = LENGTH OF STRING.     IGE   70
C                                                                       IGE   80
C  ******************************************************************   IGE   90
      DIMENSION ISTRNG(LNGTH)
      CHARACTER*1 IBLANK, IPLUS, ICOMMA, ISTRNG
      DATA IBLANK /1H /, IPLUS /1H+/, ICOMMA /1H,/
   10 IGET = ISTRNG(ICURS)
      ICURS = ICURS + 1
      IF (ICURS.GT.LNGTH) RETURN
      IF (IGET.EQ.IBLANK .OR. IGET.EQ.IPLUS) GO TO 10
      IF (IGET.EQ.ICOMMA) GO TO 10
      RETURN
      END
      SUBROUTINE IGHAZ(X,GAMMA,AMU,HAZ)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE HAZARD
C              FUNCTION VALUE FOR THE INVERSE GAUSSIAN DISTRIBUTION
C              WITH TAIL LENGTH PARAMETER = GAMMA
C              AND SHAPE PARAMETER = MU.
C              THE INVERSE GAUSSIAN DISTRIBUTION USED
C              HEREIN IS DEFINED FOR ALL POSITIVE X,
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C              AS GIVEN IN VOLUME 4, PAGE 246, BOTTOM
C              OF ENCYCLOPEDIA OF STATISTICAL SCIENCES
C     NOTE--THE GENERAL INVERSE GAUSSIAN DISTRIBUTION--
C              GOES FROM 0 TO INFINITY
C              HAS MEAN = MU (HERE = 1)
C              HAS STANDARD DEVIATION = SQRT((MU**3)/GAMMA)
C              HAS SHAPE PARAMETER = GAMMA
C              IS HIGHLY-SKEWED AND LONG-TAILED FOR SMALL GAMMA
C              IS SYMMETRIC AND MODERATE-TAILED FOR KARGE GAMMA
C              APPROACHES NORMALITY AS GAMMA APPROACHES INFINITY
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE POSITIVE.
C                     --GAMMA  = THE SHAPE PARAMETER
C                                GAMMA SHOULD BE POSITIVE.
C                     --MU     = THE SHAPE PARAMETER
C                                MU SHOULD BE POSITIVE.
C     OUTPUT ARGUMENTS--HAZ    = THE SINGLE PRECISION HAZARD
C                                FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION HAZARD
C             FUNCTION VALUE FOR THE INVERSE GAUSSIAN DISTRIBUTION
C             WITH TAIL LENGTH PARAMETER = GAMMA
C             AND WITH SHAPE PARAMETER = MU
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE POSITIVE.
C                 --GAMMA AND MU SHOULD BE POSITIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--EXP.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--KOTZ & JOHNSON, ENCYCLOPEDIA OF STAT SCIENCES
C                 VOLUME 4, PAGE 246, BOTTOM.
C     WRITTEN BY--JAMES J. FILLIBEN
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--98.4
C     ORIGINAL VERSION--APRIL     1998.
C     UPDATED  VERSION--DECEMBER  2003.
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(GAMMA.LE.0)THEN
         WRITE(ICOUT,51)
   51    FORMAT('***** ERROR--THE FIRST SHAPE PARAMETER FOR THE ',
     1          'IGHAZ SUBROUTINE IS NON-POSITIVE *****')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,52)GAMMA
   52    FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
         CALL DPWRST('XXX','BUG ')
         HAZ=0.0
         GOTO9000
      ENDIF
C
      IF(AMU.LE.0)THEN
         WRITE(ICOUT,71)
   71    FORMAT('***** ERROR--THE SECOND SHAPE PARAMETER FOR THE ',
     1          'IGHAZ SUBROUTINE IS NON-POSITIVE *****')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,52)AMU
         CALL DPWRST('XXX','BUG ')
         HAZ=0.0
         GOTO9000
      ENDIF
C
      IF(X.LT.0.0)THEN
         WRITE(ICOUT,61)
   61    FORMAT('***** ERROR--THE FIRST  INPUT ',
     1   'ARGUMENT TO THE IGHAZ SUBROUTINE IS NON-POSITIVE *****')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,52)X
         CALL DPWRST('XXX','BUG ')
         HAZ=0.0
         GOTO9000
      ENDIF
C
      IF(X.EQ.0.0)THEN
         HAZ=0.0
         GOTO9000
      ENDIF
C
      IF(X.GT.0.0)THEN
         CALL IGPDF(X,GAMMA,AMU,PDF)
         CALL IGCDF(X,GAMMA,AMU,CDF)
         CDF=1.0-CDF
         IF(CDF.GT.0.0)THEN
           HAZ=PDF/CDF
         ELSE
           WRITE(ICOUT,162)X
  162      FORMAT('***** FOR THE VALUE OF THE ARGUMENT, ',
     1          E15.8,', THE CDF IS ESSENTIALLY 1, HAZARD SET TO 0.')
           CALL DPWRST('XXX','BUG ')
           HAZ=0.0
         ENDIF
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE IGPDF(X,GAMMA,AMU,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE INVERSE GAUSSIAN DISTRIBUTION
C              WITH TAIL LENGTH PARAMETER = GAMMA
C              AND LOCATION PARAMETER = MU.
C              THE INVERSE GAUSSIAN DISTRIBUTION USED
C              HEREIN IS DEFINED FOR ALL POSITIVE X,
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C              AS GIVEN IN VOLUME 4, PAGE 246
C              OF ENCYCLOPEDIA OF STATISTICAL SCIENCES
C     NOTE--THE GENERAL INVERSE GAUSSIAN DISTRIBUTION--
C              GOES FROM 0 TO INFINITY
C              HAS MEAN = MU
C              HAS STANDARD DEVIATION = SQRT((MU**3)/GAMMA)
C              HAS SHAPE PARAMETER = GAMMA
C              IS HIGHLY-SKEWED AND LONG-TAILED FOR SMALL GAMMA
C              IS SYMMETRIC AND MODERATE-TAILED FOR KARGE GAMMA
C              APPROACHES NORMALITY AS GAMMA APPROACHES INFINITY
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE POSITIVE.
C                     --GAMMA  = THE SHAPE PARAMETER
C                                GAMMA SHOULD BE POSITIVE.
C                     --MU     = THE SHAPE PARAMETER MU.
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 INVERSE GAUSSIAN DISTRIBUTION
C             WITH TAIL LENGTH PARAMETER = GAMMA
C             AND WITH SHAPE PARAMETER = MU
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X, GAMMA, M SHOULD BE POSITIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--EXP.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--KOTZ & JOHNSON, ENCYCLOPEDIA OF STAT SCIENCES
C                 VOLUME 4, PAGE 246, BOTTOM.
C     WRITTEN BY--JAMES J. FILLIBEN
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--90.6
C     ORIGINAL VERSION--MAY       1990.
C     UPDATED         --JANUARY   1995. NEW PDF DEFINITION AND
C                                       REWRITTEN
C     UPDATED         --DECEMBER  2003. USE GENERAL VALUE OF MU
C                                       INSTEAD OF ASSUMING MU=1
C
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
      DOUBLE PRECISION DPI
      DOUBLE PRECISION DX
      DOUBLE PRECISION DGAMMA
      DOUBLE PRECISION DMU
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
      DOUBLE PRECISION DPDF
C
      DATA DPI / 3.1415926535 8979323846 2643383279 503 D0 /
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(GAMMA.LE.0)THEN
         WRITE(ICOUT,51)
   51    FORMAT('***** ERROR--THE FIRST SHAPE PARAMETER FOR THE ',
     1          'IGPDF SUBROUTINE IS NON-POSITIVE *****')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,52)GAMMA
   52    FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
         CALL DPWRST('XXX','BUG ')
         PDF=0.0
         GOTO9000
      ENDIF
C
      IF(AMU.LE.0)THEN
         WRITE(ICOUT,71)
   71    FORMAT('***** ERROR--THE SECOND SHAPE PARAMETER FOR THE ',
     1          'IGPDF SUBROUTINE IS NON-POSITIVE *****')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,52)AMU
         CALL DPWRST('XXX','BUG ')
         PDF=0.0
         GOTO9000
      ENDIF
C
      IF(X.LT.0.0)THEN
         WRITE(ICOUT,61)
   61    FORMAT('***** ERROR--THE FIRST  INPUT ARGUMENT TO THE ',
     1          'IGPDF SUBROUTINE IS NON-POSITIVE *****')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,52)X
         CALL DPWRST('XXX','BUG ')
         PDF=0.0
         GOTO9000
      ENDIF
C
      IF(X.EQ.0.0)THEN
         PDF=0.0
         GOTO9000
      ENDIF
C
      IF(X.GT.0.0)THEN
         DMU=DBLE(AMU)
         DX=DBLE(X)
         DGAMMA=DBLE(GAMMA)
         DTERM1=0.5D0*DLOG(DGAMMA/(2.0D0*DPI*DX**3))
         DTERM2=(-DGAMMA/(2.0D0*DMU*DMU*DX))
         DTERM3=(DX-DMU)**2
         DPDF=DTERM1 + DTERM2*DTERM3
         DPDF=DEXP(DPDF)
         PDF=REAL(DPDF)
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE IGPPF(P,GAMMA,AMU,PPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE INVERSE GAUSSIAN DISTRIBUTION
C              WITH TAIL LENGTH PARAMETER = GAMMA
C              AND SHAPE PARAMETER = MU.
C              THE INVERSE GAUSSIAN DISTRIBUTION USED
C              HEREIN IS DEFINED FOR ALL POSITIVE X,
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C              AS GIVEN IN VOLUME 4, PAGE 246, BOTTOM
C              OF ENCYCLOPEDIA OF STATISTICAL SCIENCES
C     NOTE--THE GENERAL INVERSE GAUSSIAN DISTRIBUTION--
C              GOES FROM 0 TO INFINITY
C              HAS MEAN = MU (HERE = 1)
C              HAS STANDARD DEVIATION = SQRT((MU**3)/GAMMA)
C              HAS SHAPE PARAMETER = GAMMA
C              IS HIGHLY-SKEWED AND LONG-TAILED FOR SMALL GAMMA
C              IS SYMMETRIC AND MODERATE-TAILED FOR KARGE GAMMA
C              APPROACHES NORMALITY AS GAMMA APPROACHES INFINITY
C     THE PERCENT POINT FUNCTION IS NOT IN CLOSED FORM
C     INPUT  ARGUMENTS--P      = THE SINGLE PRECISION VALUE
C                                (BETWEEN 0.0 AND 1.0)
C                                AT WHICH THE PERCENT POINT
C                                FUNCTION IS TO BE EVALUATED.
C                     --GAMMA  = THE SHAPE PARAMETER
C                                GAMMA SHOULD BE POSITIVE.
C                     --AMU    = THE SHAPE PARAMETER
C                                AMU SHOULD BE POSITIVE.
C     OUTPUT ARGUMENTS--PPF    = THE SINGLE PRECISION PERCENT POINT
C                                FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PERCENT POINT
C             FUNCTION VALUE PPF FOR THE INVERSE GAUSSIAN DISRIBUTION
C             WITH SHAPE PARAMETER GAMMA
C             AND SHAPE PARAMETER MU
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--P SHOULD BE BETWEEN
C                   0.0 (INCLUSIVELY) AND 1.0 (EXCLUSIVELY).
C                 --GAMMA SHOULD BE POSITIVE
C     OTHER DATAPAC   SUBROUTINES NEEDED--IGCDF, NORCDF
C     FORTRAN LIBRARY SUBROUTINES NEEDED--
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--KOTZ & JOHNSON, ENCYCLOPEDIA OF STAT SCIENCES
C                 VOLUME 4, PAGE 247, COLUMN 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     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--90.6
C     ORIGINAL VERSION--MAY       1990.
C     UPDATED         --JANUARY   1995. NEW CDF DEFINITION & REWRITTEN
C     UPDATED         --DECEMBER  2003. SUPPORT FOR MU NOT EQUAL 1
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DGAMMA
      DOUBLE PRECISION DMU
      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(GAMMA.LE.0)THEN
         WRITE(ICOUT,51)
   51    FORMAT('***** ERROR--THE FIRST SHAPE PARAMETER ',
     1          'TO THE IGPPF SUBROUTINE IS NON-POSITIVE *****')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,52)GAMMA
   52    FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
         CALL DPWRST('XXX','BUG ')
         PPF=0.0
         GOTO9000
      ENDIF
C
      IF(AMU.LE.0)THEN
         WRITE(ICOUT,71)
   71    FORMAT('***** ERROR--THE SECOND SHAPE PARAMETER ',
     1          'TO THE IGPPF SUBROUTINE IS NON-POSITIVE *****')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,52)AMU
         CALL DPWRST('XXX','BUG ')
         PPF=0.0
         GOTO9000
      ENDIF
C
      IF(P.LT.0.0.OR.P.GE.1.0)THEN
         WRITE(ICOUT,61)
   61    FORMAT('***** ERROR--THE FIRST  INPUT ARGUMENT ',
     1          'TO THE IGPPF SUBROUTINE ')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,62)
   62    FORMAT('      IS OUTSIDE THE ALLOWABLE [0,1) INTERVAL ***')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,52)P
         CALL DPWRST('XXX','BUG ')
         PPF=0.0
         GOTO9000
      ENDIF
C
      IBUG=0.0
C
      TOL=0.000001
      MAXIT=500
      XMIN=0.0
C
      IF(P.EQ.0.0)THEN
         PPF=XMIN
         GOTO9000
      ENDIF
C
C     FROM THE KARLIN-STUDDEN INEQUALITY (PATEL/KAPADIA/OWEN, P. 30)
C     (BUT TRUE ONLY FOR X >= 1.5*MU)
C     FOR THE PROTOTYPE INVERSE GAUSSIAN DISTRIBUTION,
C     MU = MU (AND HERE MU = 1)
CCCCC XMAX=10.0**30
      SD=SQRT(AMU**3/GAMMA)
      XMAX=AMU/(2.0*(1.0-P))
C
      DGAMMA=DBLE(GAMMA)
      DMU=DBLE(AMU)
C
      XLOW=XMIN
      XUP=XMAX
C
CCCCC HOPEFULLY, SAM SAUNDERS CAN GIVE ME A BETTER
CCCCC FIRST APPROXIMATION TO G(P) THAN MY 1.0   !
CCCCC XMID=1.0
      XMID=AMU
      IF(IBUG.EQ.1)THEN
        WRITE(ICOUT,101)XMID,AMU,SD
  101   FORMAT('XMID,AMU,SD = ',3E15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      ICOUNT=0
C
  200 CONTINUE
      X=XMID
      DX=DBLE(X)
      CALL IGCDF2(DX,DGAMMA,DMU,DCDF)
      PCALC=REAL(DCDF)
C
      IF(PCALC.EQ.P)THEN
        PPF=XMID
        GOTO9000
      ELSEIF(PCALC.GT.P)THEN
C
  220   CONTINUE
        XUP=XMID
        X=XMID/2.0
        IF(X.LE.XLOW)GOTO221
          XMID=X
          IF(IBUG.EQ.1)THEN
            WRITE(ICOUT,101)XMID
            CALL DPWRST('XXX','BUG ')
          ENDIF
          DX=DBLE(X)
          CALL IGCDF2(DX,DGAMMA,DMU,DCDF)
          PCALC=REAL(DCDF)
          IF(PCALC.EQ.P)THEN
            PPF=XMID
            GOTO9000
          ENDIF
          IF(PCALC.GT.P)GOTO220
          XLOW=X
  221   CONTINUE
        XMID=(XLOW+XUP)/2.0
        IF(IBUG.EQ.1)THEN
          WRITE(ICOUT,101)XMID
          CALL DPWRST('XXX','BUG ')
        ENDIF
C
      ELSE
C
  210   CONTINUE
        XLOW=XMID
        X=XMID*2.0
        IF(X.GE.XUP)GOTO211
          XMID=X
          IF(IBUG.EQ.1)THEN
            WRITE(ICOUT,101)XMID
            CALL DPWRST('XXX','BUG ')
          ENDIF
          DX=DBLE(X)
          CALL IGCDF2(DX,DGAMMA,DMU,DCDF)
          PCALC=REAL(DCDF)
          IF(PCALC.EQ.P)THEN
            PPF=XMID
            GOTO9000
          ENDIF
          IF(PCALC.LT.P)GOTO210
          XUP=X
  211   CONTINUE
        XMID=(XLOW+XUP)/2.0
        IF(IBUG.EQ.1)THEN
          WRITE(ICOUT,101)XMID
          CALL DPWRST('XXX','BUG ')
        ENDIF
      ENDIF
C
      XDEL=ABS(XMID-XLOW)
      ICOUNT=ICOUNT+1
      IF(XDEL.LT.TOL.OR.ICOUNT.GT.MAXIT)THEN
        PPF=XMID
        GOTO9000
      ENDIF
      GOTO200
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE IGRAN(N,GAMMA,AMU,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE INVERSE GAUSSIAN DISTRIBUTION
C              WITH SHAPE PARAMETER VALUE = GAMMA
C              AND LOCATION PARAMETER MU = 1.
C              THE PROTOTYPE INVERSE GAUSSIAN DISTRIBUTION USED
C              HEREIN IS DEFINED FOR ALL POSITIVE X,
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C              AS GIVEN IN VOLUME 4, PAGE 246, BOTTOM
C              OF ENCYCLOPEDIA OF STATISTICAL SCIENCES
C                 WITH MU = 1
C     NOTE--THE GENERAL INVERSE GAUSSIAN DISTRIBUTION--
C              GOES FROM 0 TO INFINITY
C              HAS MEAN = MU (HERE = 1)
C              HAS STANDARD DEVIATION = SQRT((MU**3)/GAMMA)
C              HAS SHAPE PARAMETER = GAMMA
C              IS HIGHLY-SKEWED AND LONG-TAILED FOR SMALL GAMMA
C              IS SYMMETRIC AND MODERATE-TAILED FOR KARGE GAMMA
C              APPROACHES NORMALITY AS GAMMA APPROACHES INFINITY
C     NOTE--TO OBTAIN THE PDF FOR GENERAL MU,
C           COMPUTE THE PDF FOR X AROUND 1, AND THEN
C           SIMPLY SCALE UP THE HORIZONTAL AXIS X BY THE DESIRED MU
C           AS IN Y2 = MU*Y
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --GAMMA  = THE SINGLE PRECISION VALUE OF THE
C                                TAIL LENGTH PARAMETER.
C                                GAMMA SHOULD BE POSITIVE.
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST N)
C                                INTO WHICH THE GENERATED
C                                RANDOM SAMPLE WILL BE PLACED.
C     OUTPUT--A RANDOM SAMPLE OF SIZE N
C             FROM THE INVERSE GAUSSIAN DISTRIBUTION
C             WITH TAIL LENGTH PARAMETER VALUE = GAMMA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C                 --GAMMA SHOULD BE POSITIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE HEREIN.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--KOTZ & JOHNSON, ENCYCLOPEDIA OF STAT SCIENCES
C                 VOLUME 4, PAGE 247, COLUMN 1 (FOR CDF).
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           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--90.6
C     ORIGINAL VERSION--MAY       1990.
C     UPDATED         --JANUARY   1995. NEW CDF DEFINITION & REWRITTEN
C     UPDATED         --NOVEMBER  2003. USE MICHEAL/SCHUCANY/HAAS
C                                       METHOD (FROM JAMES GENTLE
C                                       "RANDOM NUMBER GENERATION AND
C                                       MONTE CARLO METHODS", SECOND
C                                       EDITION, SPRINGER-VARLANG,
C                                       2003, P. 193.
C
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,51)
   51    FORMAT('***** FATAL ERROR--THE REQUESTED NUMBER OF INVERSE ',
     1          'GAUSSIAN RANDOM NUMBERS IS NON-POSITIVE  *****')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,52)N
   52    FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
         CALL DPWRST('XXX','BUG ')
         GOTO9000
      ENDIF
C
      IF(GAMMA.LE.0.0)THEN
         WRITE(ICOUT,61)
   61    FORMAT('***** FATAL ERROR--THE GAMMA SHAPE PARAMETER FOR THE',
     1          ' INVERSE GAUSSIAN')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,62)
   62    FORMAT('      RANDOM NUMBERS IS NON-POSITIVE  *****')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,63)GAMMA
   63    FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
         CALL DPWRST('XXX','BUG ')
         GOTO9000
      ENDIF
C
      IF(AMU.LE.0.0)THEN
         WRITE(ICOUT,71)
   71    FORMAT('***** FATAL ERROR--THE MU SHAPE PARAMETER FOR THE',
     1          ' INVERSE GAUSSIAN')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,72)
   72    FORMAT('      RANDOM NUMBERS IS NON-POSITIVE  *****')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,63)AMU
         CALL DPWRST('XXX','BUG ')
         GOTO9000
      ENDIF
C
C     GENERATE N UNIFORM (0,1) RANDOM NUMBERS;
C
CCCCC CALL UNIRAN(N,ISEED,X)
C
C     GENERATE N INVERSE GAUSSIAN DISTRIBUTION RANDOM NUMBERS
C     USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD.
C
CCCCC DO100I=1,N
CCCCC XI=X(I)
CCCCC CALL IGPPF(XI,GAMMA,X(I))
C 100 CONTINUE
C
C     MICHEAL/SCHUCANY/HAAS ALGORITHM.
C
C     GENERATE N NORMAL (0,1) RANDOM NUMBERS;
C
      CALL NORRAN(N,ISEED,X)
C
      NTEMP=1
      DO100I=1,N
        Y=X(I)*X(I)
        X1=AMU + AMU*AMU*Y/(2.0*GAMMA) -
     1     (AMU/(2.0*GAMMA))*SQRT(4.0*AMU*GAMMA*Y + AMU*AMU*Y*Y)
        CALL UNIRAN(NTEMP,ISEED,X(I))
        U=X(I)
        IF(U.LE.AMU/(AMU+X1))THEN
          X(I)=X1
        ELSE
          X(I)=AMU*AMU/X1
        ENDIF
  100 CONTINUE
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE IMTQL2(NM,N,D,E,Z,IERR)
C***BEGIN PROLOGUE  IMTQL2
C***DATE WRITTEN   760101   (YYMMDD)
C***REVISION DATE  830518   (YYMMDD)
C***CATEGORY NO.  D4A5,D4C2A
C***KEYWORDS  EIGENVALUES,EIGENVECTORS,EISPACK
C***AUTHOR  SMITH, B. T., ET AL.
C***PURPOSE  Computes eigenvalues and eigenvectors of symmetric
C            tridiagonal matrix using implicit QL method.
C***DESCRIPTION
C
C     This subroutine is a translation of the ALGOL procedure IMTQL2,
C     NUM. MATH. 12, 377-383(1968) by Martin and Wilkinson,
C     as modified in NUM. MATH. 15, 450(1970) by Dubrulle.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 241-248(1971).
C
C     This subroutine finds the eigenvalues and eigenvectors
C     of a SYMMETRIC TRIDIAGONAL matrix by the implicit QL method.
C     The eigenvectors of a FULL SYMMETRIC matrix can also
C     be found if  TRED2  has been used to reduce this
C     full matrix to tridiagonal form.
C
C     On INPUT
C
C        NM must be set to the row dimension of two-dimensional
C          array parameters as declared in the calling program
C          dimension statement.
C
C        N is the order of the matrix.
C
C        D contains the diagonal elements of the input matrix.
C
C        E contains the subdiagonal elements of the input matrix
C          in its last N-1 positions.  E(1) is arbitrary.
C
C        Z contains the transformation matrix produced in the
C          reduction by  TRED2, if performed.  If the eigenvectors
C          of the tridiagonal matrix are desired, Z must contain
C          the identity matrix.
C
C      On OUTPUT
C
C        D contains the eigenvalues in ASCENDING order.  If an
C          error exit is made, the eigenvalues are correct but
C          UNORDERED for indices 1,2,...,IERR-1.
C
C        E has been destroyed.
C
C        Z contains orthonormal eigenvectors of the symmetric
C          tridiagonal (or full) matrix.  If an error exit is made,
C          Z contains the eigenvectors associated with the stored
C          eigenvalues.
C
C        IERR is set to
C          ZERO       for normal return,
C          J          if the J-th eigenvalue has not been
C                     determined after 30 iterations.
C
C     Calls PYTHAG(A,B) for sqrt(A**2 + B**2).
C
C     Questions and comments should be directed to B. S. Garbow,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C     ------------------------------------------------------------------
C***REFERENCES  B. T. SMITH, J. M. BOYLE, J. J. DONGARRA, B. S. GARBOW,
C                 Y. IKEBE, V. C. KLEMA, C. B. MOLER, *MATRIX EIGEN-
C                 SYSTEM ROUTINES - EISPACK GUIDE*, SPRINGER-VERLAG,
C                 1976.
C***ROUTINES CALLED  PYTHAG
C***END PROLOGUE  IMTQL2
C
      INTEGER I,J,K,L,M,N,II,NM,MML,IERR
      REAL D(N),E(N),Z(NM,N)
      REAL B,C,F,G,P,R,S,S1,S2
      REAL PYTHAG
C
C***FIRST EXECUTABLE STATEMENT  IMTQL2
      IERR = 0
      IF (N .EQ. 1) GO TO 1001
C
      DO 100 I = 2, N
  100 E(I-1) = E(I)
C
      E(N) = 0.0E0
C
      DO 240 L = 1, N
         J = 0
C     .......... LOOK FOR SMALL SUB-DIAGONAL ELEMENT ..........
  105    DO 110 M = L, N
            IF (M .EQ. N) GO TO 120
            S1 = ABS(D(M)) + ABS(D(M+1))
            S2 = S1 + ABS(E(M))
            IF (S2 .EQ. S1) GO TO 120
  110    CONTINUE
C
  120    P = D(L)
         IF (M .EQ. L) GO TO 240
         IF (J .EQ. 30) GO TO 1000
         J = J + 1
C     .......... FORM SHIFT ..........
         G = (D(L+1) - P) / (2.0E0 * E(L))
         R = PYTHAG(G,1.0E0)
         G = D(M) - P + E(L) / (G + SIGN(R,G))
         S = 1.0E0
         C = 1.0E0
         P = 0.0E0
         MML = M - L
C     .......... FOR I=M-1 STEP -1 UNTIL L DO -- ..........
         DO 200 II = 1, MML
            I = M - II
            F = S * E(I)
            B = C * E(I)
            IF (ABS(F) .LT. ABS(G)) GO TO 150
            C = G / F
            R = SQRT(C*C+1.0E0)
            E(I+1) = F * R
            S = 1.0E0 / R
            C = C * S
            GO TO 160
  150       S = F / G
            R = SQRT(S*S+1.0E0)
            E(I+1) = G * R
            C = 1.0E0 / R
            S = S * C
  160       G = D(I+1) - P
            R = (D(I) - G) * S + 2.0E0 * C * B
            P = S * R
            D(I+1) = G + P
            G = C * R - B
C     .......... FORM VECTOR ..........
            DO 180 K = 1, N
               F = Z(K,I+1)
               Z(K,I+1) = S * Z(K,I) + C * F
               Z(K,I) = C * Z(K,I) - S * F
  180       CONTINUE
C
  200    CONTINUE
C
         D(L) = D(L) - P
         E(L) = G
         E(M) = 0.0E0
         GO TO 105
  240 CONTINUE
C     .......... ORDER EIGENVALUES AND EIGENVECTORS ..........
      DO 300 II = 2, N
         I = II - 1
         K = I
         P = D(I)
C
         DO 260 J = II, N
            IF (D(J) .GE. P) GO TO 260
            K = J
            P = D(J)
  260    CONTINUE
C
         IF (K .EQ. I) GO TO 300
         D(K) = D(I)
         D(I) = P
C
         DO 280 J = 1, N
            P = Z(J,I)
            Z(J,I) = Z(J,K)
            Z(J,K) = P
  280    CONTINUE
C
  300 CONTINUE
C
      GO TO 1001
C     .......... SET ERROR -- NO CONVERGENCE TO AN
C                EIGENVALUE AFTER 30 ITERATIONS ..........
 1000 IERR = L
 1001 RETURN
      END
      SUBROUTINE INITDA(IBUGIN)
C
C     PURPOSE--THIS IS SUBROUTING INITDA.
C              (THE   DA    AT THE END OF    INITDA   STANDS FOR   DATA)
C              THIS SUBROUTINE INITIALIZES DATA VARIABLES
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--82/7
C     ORIGINAL VERSION--NOVEMBER  1980.
C     UPDATED         --AUGUST    1981.
C     UPDATED         --MAY       1982.
C     UPDATED         --FEBRUARY  1989.  SOFT-CODING (ALAN)
C     UPDATED         --JULY      1989.  MAXCP1/2/3/4/5/6
C     UPDATED         --JANUARY   1998.  ADD MAXROM, MAXCOM
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IBLANK
      CHARACTER*4 IBUGIN
C
C---------------------------------------------------------------------
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOPA.INC'
      INCLUDE 'DPCODA.INC'
CCCCC THE FOLLOWING LINE WAS ADDED JULY 1989
      INCLUDE 'DPCOM2.INC'
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(IBUGIN.EQ.'OFF')GOTO99
      WRITE(ICOUT,90)
   90 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,95)
   95 FORMAT('***** AT THE BEGINNING OF INITDA--')
      CALL DPWRST('XXX','BUG ')
   99 CONTINUE
C
      IBLANK=' '
      IZERO=0
      ZERO=0.0
C
C               *****************************************************
C               **  INITIALIZE                                     **
C               **  THE MAXIMUM TOTAL NUMBER OF OBSERVATIONS, AND  **
C               **  THE TOTAL NUMBER OF OBSERVATIONS               **
C               *****************************************************
C
CCCCC MAXNK=10000
      MAXNK=MAXOBW
      NK=0
C
C               ************************************************************
C               **  INITIALIZE                                            **
C               **  THE MAXIMUM NUMBER OF OBSERVATIONS PER VARIABLE, AND  **
C               **  THE NUMBER OF OBSERVATIONS PER VARIABLE               **
C               ************************************************************
C
CCCCC IDEMXN=1000        ALAN HAS THIS ON THE CYBER
      IDEMXN=MAXOBV
      MAXN=IDEMXN
      N=0
C
C               ********************************************
C               **  INITIALIZE                            **
C               **  THE MAXIMUM NUMBER OF VARIABLES, AND  **
C               **  THE NUMBER OF VARIABLES (COLUMNS)     **
C               ********************************************
C
CCCCC IDEMXC=10
CCCCC IDEMXC=MAXNK/IDEMXN   ALAN HAS THIS ON THE CYBER
      IDEMXC=MAXOBW/MAXOBV
      MAXCOL=IDEMXC
      NUMCOL=0
C
CCCCC THE FOLLOWING 6 LINES WERE ADDED JULY 1989
      MAXCP1=MAXCOL+1
      MAXCP2=MAXCOL+2
      MAXCP3=MAXCOL+3
      MAXCP4=MAXCOL+4
      MAXCP5=MAXCOL+5
      MAXCP6=MAXCOL+6
C
C               ****************************************************************
C               **  INITIALIZE
C               **  THE MAXIMUM TOTAL NUMBER OF CHARACTERS FOR ALL FUNCTIONS, AN
C               **  THE TOTAL NUMBER OF CHARACTERS FOR ALL FUNCTIONS
C               ****************************************************************
C
CCCCC MAXCHF=1000
      MAXCHF=MAXF1
      NUMCHF=0
C
C               ********************************************
C               **  INITIALIZE                            **
C               **  THE MAXIMUM NUMBER OF FUNCTIONS, AND  **
C               **  THE NUMBER OF FUNCTIONS               **
C               ********************************************
C
CCCCC MAXFUN=100
      MAXFUN=MAXFN2
      NUMFUN=0
C
C               **********************************************
C               **  INITIALIZE THE MAXIMUM TOTAL NUMBER OF  **
C               **  CHARACTERS (THAT WILL BE PRINTED)       **
C               **  (IN THE    STATUS    COMMAND OUTPUT)    **
C               **  FOR THE LAST MODEL FITTED.              **
C               **********************************************
C
CCCCC MAXCHM=200
      MAXCHM=MAXF3
      NUMCHM=0
C
C               **********************************************
C               **  INITIALIZE                              **
C               **  THE MAXIMUM NUMBER OF CONSTRAINTS, AND  **
C               **  THE NUMBER OF CONSTRAINTS               **
C               **********************************************
C
      MAXCON=100
      NUMCON=0
C
CCCCC FOLLOWING SECTION ADDED JANUARY 1998.
C               **********************************************
C               **  INITIALIZE                              **
C               **  THE MAXIMUM NUMBER OF ROWS AND COLUMNS  **
C               **  IN A MATRIX                             **
C               **********************************************
C
      MAXCOM=100
      MAXROM=(46*MAXOBV/3)/100
C
C               *******************************
C               **  EXIT AND RETURN TO MAIN  **
C               *******************************
C
 9000 CONTINUE
      IF(IBUGIN.EQ.'OFF')GOTO9090
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9911)
 9911 FORMAT('***** AT THE END       OF INITDA--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)MAXN,N
 9012 FORMAT('MAXN,N = ',2I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)MAXCOL,NUMCOL
 9013 FORMAT('MAXCOL,NUMCOL = ',2I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9014)MAXNK,NK
 9014 FORMAT('MAXNK,NK      = ',2I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9015)MAXCHF,NUMCHF
 9015 FORMAT('MAXCHF,NUMCHF = ',2I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9016)MAXCHM,NUMCHM
 9016 FORMAT('MAXCHM,NUMCHM = ',2I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9017)MAXCON,NUMCON
 9017 FORMAT('MAXCON,NUMCON = ',2I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9021)MAXOBV,MAXOBW
 9021 FORMAT('MAXOBV,MAXOBW = ',2I8)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE INITDB
C
C     PURPOSE--THIS IS SUBROUTING INITDB.
C              (THE   DB    AT THE END OF    INITDB   STANDS FOR   DEBUGGI
C              THIS SUBROUTINE INITIALIZES DEBUGGING VARIABLES AND PARAMETERS
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--82/7
C     ORIGINAL VERSION--NOVEMBER  1980.
C     UPDATED         --AUGUST    1981.
C     UPDATED         --MAY       1982.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOMC.INC'
      INCLUDE 'DPCODB.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(IBUGIN.EQ.'OFF')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF INITDB--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)
   52 FORMAT('      NOTE--SINCE    IBUGIN   WILL BE SET TO    OFF ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)
   53 FORMAT('      WITHIN THIS SUBROUTINE, THERE WILL BE ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,54)
   54 FORMAT('      NO MESSAGE AT THE END OF THIS SUBROUTINE.')
      CALL DPWRST('XXX','BUG ')
   90 CONTINUE
C
C               ***********************************************
C               **  INITIALIZE THE BUG VECTOR                **
C               **  (THE VECTOR WHERE THE BUG PARAMETERS     **
C               **  ARE PLACED)                              **
C               ***********************************************
C
      MAXBUG=100
      NUMBUG=0
C
      DO100I=1,MAXBUG
      IH1BUG(I)='OFF'
CCCCC IH1BUG(I)='ON'
  100 CONTINUE
C
C               *******************************
C               **  EXIT AND RETURN TO MAIN  **
C               *******************************
C
 9000 CONTINUE
      IF(IBUGIN.EQ.'OFF')GOTO9999
      WRITE(ICOUT,9990)
 9990 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9995)
 9995 FORMAT('***** AT THE END       OF INITDB--')
      CALL DPWRST('XXX','BUG ')
 9999 CONTINUE
C
      RETURN
      END
      SUBROUTINE INITDE(IBUGIN)
C
C     PURPOSE--THIS IS SUBROUTING INITDE.
C              (THE   DE    AT THE END OF    INITDE
C              STANDS FOR DESIGN OF EXPERIMENTS
C              THIS SUBROUTINE INITIALIZES DESIGN-OF-EXPERIMENT
C              PARAMETERS
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--89/6
C     ORIGINAL VERSION--MAY 1989.
C     UPDATED         --AUGUST    1993. BUG FIX
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IBUGIN
CCCCC AUGUST 1993.  COMPILE ERROR ON RS-6000, ADD FOLLOWING LINE
      CHARACTER*4 ITEXT
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCODE.INC'
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(IBUGIN.EQ.'OFF')GOTO99
      WRITE(ICOUT,90)
   90 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,95)
   95 FORMAT('***** AT THE BEGINNING OF INITDE--')
      CALL DPWRST('XXX','BUG ')
   99 CONTINUE
C
C               ***********************************************
C               **  SET THE DESIGN OF EXPERIMENT SETTINGS    **
C               **     IDEXDE = DEPTH INTO INTERACTION TERMS **
C               **              1 = MAIN EFFECTS ONLY        **
C               **              2 = UP TO 2-TERM INTERACTIONS**
C               **              ETC.                         **
C               **     DEXWID = WIDTH ON THE PLOT ACROSS     **
C               **              ALL LEVELS WITHIN A FACTOR   **
C               **     IDEXHA = HORIZONTAL AXIS VARIABLE     **
C               **              DEFAULT = 'FACT'             **
C               **              CAN ALSO HAVE 'TERM'         **
C               ***********************************************
C
      IDEDED=1
      DEFDEW=0.4
      IDEFHA='FACT'
C
      IDEXDE=1
      DEXWID=0.4
      IDEXHA='FACT'
C
C               **************************************************
C               **  INITIALIZE EXPERIMENTAL SIMULATION SETTINGS **
C               **************************************************
 
C               **************************************************
C               **  INITIALIZE EXPERIMENTAL SIMULATION SETTINGS **
C               **     GMEAN     = GRAND MEAN                   **
C               **     NUMB      = TOTAL NUMBER OF COEFFICIENTS **(EXCLUDING GRA
C               **     INDEXB(.) = INDEX FOR COEFFICIENTS (EXCLU**DING GRAND MEA
C               **     B(.)      = COEFFICIENTS (EXCLUDING GRAND** MEAN)
C               **     GSD       = GENERAL STANDARD DEVIATION   **
C               **               = SD OF ERROR IN Y = GRAND MEAN** + ERROR
C               **     NUMS      = XX                           **
C               **     BMINT     = INTERCEPT FOR GRAND MEAN DRIF**T IN TIME
C               **     BMSLOP    = SLOPE     FOR GRAND MEAN DRIF**T IN TIME
C               **     DSINT     = INTERCEPT FOR SD         DRIF**T IN TIME
C               **     DSSLOP    = SLOPE     FOR SD         DRIF**T IN TIME
C               **************************************************
C
      ISIMID=0
      IAUTH='BOXB'
      ITEXT='TECH'
      IPAGE=17
C
      GMEAN=71.25
      NUMB=7
      INDEXB(1)=1
      INDEXB(2)=2
      INDEXB(3)=3
      INDEXB(4)=12
      INDEXB(5)=13
      INDEXB(6)=23
      INDEXB(7)=123
      B(1)=23.0
      B(2)=(-5.0)
      B(3)=1.5
      B(4)=1.5
      B(5)=10.0
      B(6)=0.0
      B(7)=0.5
C
CCCCC GSD=0.1
      GSD=0.0
      NUMS=0
C
      BMINT=0.0
      BMSLOP=0.0
C
      DSINT=0.0
      DSSLOP=0.0
C
C               *******************************
C               **  EXIT AND RETURN TO MAIN  **
C               *******************************
C
 9000 CONTINUE
      IF(IBUGIN.EQ.'OFF')GOTO9999
      WRITE(ICOUT,9990)
 9990 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9995)
 9995 FORMAT('***** AT THE END       OF INITDE--')
      CALL DPWRST('XXX','BUG ')
 9999 CONTINUE
C
      RETURN
      END
      FUNCTION INITDS (OS, NOS, ETA)
C***BEGIN PROLOGUE  INITDS
C***PURPOSE  Determine the number of terms needed in an orthogonal
C            polynomial series so that it meets a specified accuracy.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C3A2
C***TYPE      DOUBLE PRECISION (INITS-S, INITDS-D)
C***KEYWORDS  CHEBYSHEV, FNLIB, INITIALIZE, ORTHOGONAL POLYNOMIAL,
C             ORTHOGONAL SERIES, SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C  Initialize the orthogonal series, represented by the array OS, so
C  that INITDS is the number of terms needed to insure the error is no
C  larger than ETA.  Ordinarily, ETA will be chosen to be one-tenth
C  machine precision.
C
C             Input Arguments --
C   OS     double precision array of NOS coefficients in an orthogonal
C          series.
C   NOS    number of coefficients in OS.
C   ETA    single precision scalar containing requested accuracy of
C          series.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770601  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   891115  Modified error message.  (WRB)
C   891115  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C***END PROLOGUE  INITDS
      DOUBLE PRECISION OS(*)
C
C---------------------------------------------------------------------
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***FIRST EXECUTABLE STATEMENT  INITDS
      IF (NOS .LT. 1) THEN
        WRITE(ICOUT,11)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,12)
        CALL DPWRST('XXX','BUG ')
        INITDS = 0.D0
        RETURN
      ENDIF
   11 FORMAT('***** ERROR FROM INITDS.  THE NUMBER OF ')
   12 FORMAT('      COEFFICIENTS IS LESS THAN 1.      *****')
C
      ERR = 0.
      DO 10 II = 1,NOS
        I = NOS + 1 - II
        ERR = ERR + ABS(REAL(OS(I)))
        IF (ERR.GT.ETA) GO TO 20
   10 CONTINUE
C
   20 IF (I .EQ. NOS) THEN
      WRITE(ICOUT,21)
 21   FORMAT('***** ERROR FROM INITDS.  CHEBYSHEV SERIES TOO ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,22)
 22   FORMAT('      SHORT FOR SPECIFIED ACCURACY.             *****')
      CALL DPWRST('XXX','BUG ')
      ENDIF
      INITDS = I
C
      RETURN
      END
      BLOCK DATA INITD1
C
C     PURPOSE--THIS IS BLOCK DATA ROUTINE INITD20
C              THIS INITIALIZES THE REAL DATA ARRAYS (ONCE).  USE BLOCK
C              DATA FOR SPEED (DONE AT LOAD TIME, NOT AT RUN TIME)
C              THIS SUBROUTINE INITIALIZES DATA VARIABLES
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           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     UPDATED         --OCTOBER   1993.  DIFFERENT SYNTAX (SGI VERSION
C                                        BOMBS ON OLD SYNTAX)
C
C---------------------------------------------------------------------
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOPA.INC'
      INCLUDE 'DPCODA.INC'
C
C-----START POINT-----------------------------------------------------
C
CCCCC DATA (ISUB(I),I=1,MAXOBV) /MAXOBV*0/
CCCCC DATA (I1DATA(I),I=1,100) /100*0/
C
CCCCC DATA (PARLIM(I),I=1,100) /100*0./
C
      DATA ISUB /MAXOBV*0/
      DATA I1DATA /100*0/
C
      DATA PARLIM /100*0./
C
      END
      BLOCK DATA INITD2
C
C     PURPOSE--THIS IS BLOCK DATA ROUTINE INITD20
C              THIS INITIALIZES THE REAL DATA ARRAYS (ONCE).  USE BLOCK
C              DATA FOR SPEED (DONE AT LOAD TIME, NOT AT RUN TIME)
C              THIS SUBROUTINE INITIALIZES DATA VARIABLES
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--82/7
C     ORIGINAL VERSION--OCTOBER   1991.
C     UPDATED         --OCTOBER   1993.  DIFFERENT SYNTAX (SGI VERSION
C                                        BOMBS ON OLD SYNTAX)
C
C---------------------------------------------------------------------
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOPA.INC'
      INCLUDE 'DPCODA.INC'
C
C-----START POINT-----------------------------------------------------
C
CCCCC DATA (PRED(I),I=1,MAXOBV) /MAXOBV*0./
CCCCC DATA (RES(I),I=1,MAXOBV) /MAXOBV*0./
C
      DATA PRED /MAXOBV*0./
      DATA RES /MAXOBV*0./
C
      END
      BLOCK DATA INITD3
C
C     PURPOSE--THIS IS BLOCK DATA ROUTINE INITD21
C              THIS INITIALIZES THE REAL DATA ARRAYS (ONCE).  USE BLOCK
C              DATA FOR SPEED (DONE AT LOAD TIME, NOT AT RUN TIME)
C              THIS SUBROUTINE INITIALIZES DATA VARIABLES
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--82/7
C     ORIGINAL VERSION--OCTOBER   1991.
C     UPDATED         --OCTOBER   1993.  DIFFERENT SYNTAX (SGI VERSION
C                                        BOMBS ON OLD SYNTAX)
C
C---------------------------------------------------------------------
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOPA.INC'
      INCLUDE 'DPCODA.INC'
C
C-----START POINT-----------------------------------------------------
C
CCCCC DATA (X(I),I=1,MAXPOP) /MAXPOP*0./
      DATA X /MAXPOP*0./
C
      END
      BLOCK DATA INITD4
C
C     PURPOSE--THIS IS BLOCK DATA ROUTINE INITD22
C              THIS INITIALIZES THE REAL DATA ARRAYS (ONCE).  USE BLOCK
C              DATA FOR SPEED (DONE AT LOAD TIME, NOT AT RUN TIME)
C              THIS SUBROUTINE INITIALIZES DATA VARIABLES
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--82/7
C     ORIGINAL VERSION--OCTOBER   1991.
C     UPDATED         --OCTOBER   1993.  DIFFERENT SYNTAX (SGI VERSION
C                                        BOMBS ON OLD SYNTAX)
C
C---------------------------------------------------------------------
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOPA.INC'
      INCLUDE 'DPCODA.INC'
C
C-----START POINT-----------------------------------------------------
C
C
CCCCC DATA (YPLOT(I),I=1,MAXPOP) /MAXPOP*0./
      DATA YPLOT /MAXPOP*0./
C
      END
      BLOCK DATA INITD5
C
C     PURPOSE--THIS IS BLOCK DATA ROUTINE INITD23
C              THIS INITIALIZES THE REAL DATA ARRAYS (ONCE).  USE BLOCK
C              DATA FOR SPEED (DONE AT LOAD TIME, NOT AT RUN TIME)
C              THIS SUBROUTINE INITIALIZES DATA VARIABLES
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--82/7
C     ORIGINAL VERSION--OCTOBER   1991.
C     UPDATED         --OCTOBER   1993.  DIFFERENT SYNTAX (SGI VERSION
C                                        BOMBS ON OLD SYNTAX)
C
C---------------------------------------------------------------------
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOPA.INC'
      INCLUDE 'DPCODA.INC'
C
C-----START POINT-----------------------------------------------------
C
CCCCC DATA ((AMATR1(I,J),I=1,100),J=1,100) /10000*0./
      DATA AMATR1 /10000*0./
C
      END
      BLOCK DATA INITD6
C
C     PURPOSE--THIS IS BLOCK DATA ROUTINE INITD21
C              THIS INITIALIZES THE REAL DATA ARRAYS (ONCE).  USE BLOCK
C              DATA FOR SPEED (DONE AT LOAD TIME, NOT AT RUN TIME)
C              THIS SUBROUTINE INITIALIZES DATA VARIABLES
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--82/7
C     ORIGINAL VERSION--OCTOBER   1991.
C     UPDATED         --OCTOBER   1993.  DIFFERENT SYNTAX (SGI VERSION
C                                        BOMBS ON OLD SYNTAX)
C
C---------------------------------------------------------------------
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOPA.INC'
      INCLUDE 'DPCODA.INC'
C
C-----START POINT-----------------------------------------------------
C
CCCCC DATA (X3D(I),I=1,MAXPOP) /MAXPOP*0./
      DATA X3D /MAXPOP*0./
C
      END
      BLOCK DATA INID7A
C
C     PURPOSE--THIS IS BLOCK DATA ROUTINE INID7A
C              THIS INITIALIZES THE REAL DATA ARRAY D(.).
C              BLOCK DATA IS USED FOR SPEED
C              SINCE DONE AT LOAD TIME--NOT AT RUN TIME.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--92/10
C     ORIGINAL VERSION--SEPTEMBER 1992.
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOPA.INC'
      INCLUDE 'DPCODA.INC'
C
C-----START POINT-----------------------------------------------------
C
CCCCC DATA (D(I),I=1,MAXPOP) /MAXPOP*0./
      DATA D /MAXPOP*0./
C
      END
      BLOCK DATA INID7B
C
C     PURPOSE--THIS IS BLOCK DATA ROUTINE INID7B
C              THIS INITIALIZES THE REAL DATA ARRAY DSIZE(.).
C              BLOCK DATA IS USED FOR SPEED
C              SINCE DONE AT LOAD TIME--NOT AT RUN TIME.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--92/10
C     ORIGINAL VERSION--SEPTEMBER 1992.
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOPA.INC'
      INCLUDE 'DPCODA.INC'
C
C-----START POINT-----------------------------------------------------
C
CCCCC DATA (DSIZE(I),I=1,MAXPOP) /MAXPOP*0./
      DATA DSIZE /MAXPOP*0./
C
      END
      BLOCK DATA INID7C
C
C     PURPOSE--THIS IS BLOCK DATA ROUTINE INID7C
C              THIS INITIALIZES THE REAL DATA ARRAY DSYMB(.).
C              BLOCK DATA IS USED FOR SPEED
C              SINCE DONE AT LOAD TIME--NOT AT RUN TIME.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--92/10
C     ORIGINAL VERSION--SEPTEMBER 1992.
C     UPDATED         --OCTOBER   1993.  DIFFERENT SYNTAX (SGI VERSION
C                                        BOMBS ON OLD SYNTAX)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOPA.INC'
      INCLUDE 'DPCODA.INC'
C
C-----START POINT-----------------------------------------------------
C
CCCCC DATA (DSYMB(I),I=1,MAXPOP) /MAXPOP*0./
      DATA DSYMB /MAXPOP*0./
C
      END
      BLOCK DATA INID7D
C
C     PURPOSE--THIS IS BLOCK DATA ROUTINE INID7D
C              THIS INITIALIZES THE REAL DATA ARRAY DCOLOR(.).
C              BLOCK DATA IS USED FOR SPEED
C              SINCE DONE AT LOAD TIME--NOT AT RUN TIME.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--92/10
C     ORIGINAL VERSION--SEPTEMBER 1992.
C     UPDATED         --OCTOBER   1993.  DIFFERENT SYNTAX (SGI VERSION
C                                        BOMBS ON OLD SYNTAX)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOPA.INC'
      INCLUDE 'DPCODA.INC'
C
C-----START POINT-----------------------------------------------------
C
CCCCC DATA (DCOLOR(I),I=1,MAXPOP) /MAXPOP*0./
      DATA DCOLOR /MAXPOP*0./
C
      END
      BLOCK DATA INID7E
C
C     PURPOSE--THIS IS BLOCK DATA ROUTINE INID7E
C              THIS INITIALIZES THE REAL DATA ARRAY DFILL(.).
C              BLOCK DATA IS USED FOR SPEED
C              SINCE DONE AT LOAD TIME--NOT AT RUN TIME.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--92/10
C     ORIGINAL VERSION--SEPTEMBER 1992.
C     UPDATED         --OCTOBER   1993.  DIFFERENT SYNTAX (SGI VERSION
C                                        BOMBS ON OLD SYNTAX)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOPA.INC'
      INCLUDE 'DPCODA.INC'
C
C-----START POINT-----------------------------------------------------
C
CCCCC DATA (DFILL(I),I=1,MAXPOP) /MAXPOP*0./
      DATA DFILL /MAXPOP*0./
C
      END
      BLOCK DATA INITD8
C
C     PURPOSE--THIS IS BLOCK DATA ROUTINE INITD22
C              THIS INITIALIZES THE REAL DATA ARRAYS (ONCE).  USE BLOCK
C              DATA FOR SPEED (DONE AT LOAD TIME, NOT AT RUN TIME)
C              THIS SUBROUTINE INITIALIZES DATA VARIABLES
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--82/7
C     ORIGINAL VERSION--OCTOBER   1991.
C     UPDATED         --OCTOBER   1993.  DIFFERENT SYNTAX (SGI VERSION
C                                        BOMBS ON OLD SYNTAX)
C
C---------------------------------------------------------------------
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOPA.INC'
      INCLUDE 'DPCODA.INC'
C
C-----START POINT-----------------------------------------------------
C
C
CCCCC DATA (X2PLOT(I),I=1,MAXPOP) /MAXPOP*0./
      DATA X2PLOT /MAXPOP*0./
C
      END
      BLOCK DATA INITD9
C
C     PURPOSE--THIS IS BLOCK DATA ROUTINE INITD22
C              THIS INITIALIZES THE REAL DATA ARRAYS (ONCE).  USE BLOCK
C              DATA FOR SPEED (DONE AT LOAD TIME, NOT AT RUN TIME)
C              THIS SUBROUTINE INITIALIZES DATA VARIABLES
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--82/7
C     ORIGINAL VERSION--OCTOBER   1991.
C     UPDATED         --OCTOBER   1993.  DIFFERENT SYNTAX (SGI VERSION
C                                        BOMBS ON OLD SYNTAX)
C
C---------------------------------------------------------------------
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOPA.INC'
      INCLUDE 'DPCODA.INC'
C
C-----START POINT-----------------------------------------------------
C
C
CCCCC DATA (XPLOT(I),I=1,MAXPOP) /MAXPOP*0./
      DATA XPLOT /MAXPOP*0./
C
      END
      BLOCK DATA INITDZ
C
C     PURPOSE--THIS IS BLOCK DATA ROUTINE INITD22
C              THIS INITIALIZES THE REAL DATA ARRAYS (ONCE).  USE BLOCK
C              DATA FOR SPEED (DONE AT LOAD TIME, NOT AT RUN TIME)
C              THIS SUBROUTINE INITIALIZES DATA VARIABLES
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--82/7
C     ORIGINAL VERSION--OCTOBER   1991.
C     UPDATED         --OCTOBER   1993.  DIFFERENT SYNTAX (SGI VERSION
C                                        BOMBS ON OLD SYNTAX)
C
C---------------------------------------------------------------------
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOPA.INC'
      INCLUDE 'DPCODA.INC'
C
C-----START POINT-----------------------------------------------------
C
C
CCCCC DATA (TAGPLO(I),I=1,MAXPOP) /MAXPOP*0./
      DATA TAGPLO /MAXPOP*0./
C
      END
      SUBROUTINE INITH2(IHNAME,IHNAM2,IUSE,IN,IVSTAR,IVSTOP,
     1IVALUE,VALUE,NUMNAM,MAXN,MAXCOL,IBUGIN)
C
C     PURPOSE--ENTER INFORMATION ABOUT THE
C              PRED (= PREDICTED VALUES) VECTOR AND
C              RES  (= RESIDUALS       ) VECTOR
C              INTO THE HOUEKEEPING TABLES.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--82/7
C     ORIGINAL VERSION--NOVEMBER  1980.
C     UPDATED         --AUGUST    1981.
C     UPDATED         --MAY       1982.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IHNAME
      CHARACTER*4 IHNAM2
      CHARACTER*4 IUSE
      CHARACTER*4 IBUGIN
C
C---------------------------------------------------------------------
C
      DIMENSION IHNAME(*)
      DIMENSION IHNAM2(*)
      DIMENSION IUSE(*)
      DIMENSION IN(*)
      DIMENSION IVSTAR(*)
      DIMENSION IVSTOP(*)
      DIMENSION IVALUE(*)
      DIMENSION VALUE(*)
C
C---------------------------------------------------------------------
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(IBUGIN.EQ.'OFF')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF INITH2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)NUMNAM,MAXCOL,MAXN,CPUMAX
   52 FORMAT('NUMNAM,MAXCOL,MAXN,CPUMAX = ',3I8,E15.7)
      CALL DPWRST('XXX','BUG ')
   90 CONTINUE
C
      NUMNAM=NUMNAM+1
      IHNAME(NUMNAM)='PRED'
      IHNAM2(NUMNAM)='    '
      IUSE(NUMNAM)='V'
      IVALUE(NUMNAM)=MAXCOL+1
      VALUE(NUMNAM)=IVALUE(NUMNAM)
      IN(NUMNAM)=MAXN
      N=IN(NUMNAM)
      ICOLVJ=IVALUE(NUMNAM)
      IVSTAR(NUMNAM)=MAXN*(ICOLVJ-1)+1
      IVSTOP(NUMNAM)=MAXN*(ICOLVJ-1)+N
C
      NUMNAM=NUMNAM+1
      IHNAME(NUMNAM)='RES'
      IHNAM2(NUMNAM)='    '
      IUSE(NUMNAM)='V'
      IVALUE(NUMNAM)=MAXCOL+2
      VALUE(NUMNAM)=IVALUE(NUMNAM)
      IN(NUMNAM)=MAXN
      N=IN(NUMNAM)
      ICOLVJ=IVALUE(NUMNAM)
      IVSTAR(NUMNAM)=MAXN*(ICOLVJ-1)+1
      IVSTOP(NUMNAM)=MAXN*(ICOLVJ-1)+N
C
      NUMNAM=NUMNAM+1
      IHNAME(NUMNAM)='INFI'
      IHNAM2(NUMNAM)='NITY'
      IUSE(NUMNAM)='P'
      VALUE(NUMNAM)=CPUMAX
CCCCC ITEMP=2**(NUMBPW-2)
CCCCC ITEMP2=ITEMP-1
CCCCC IVALUE(NUMNAM)=ITEMP2+ITEMP
      IVALUE(NUMNAM)=999999
      IN(NUMNAM)=1
C
      NUMNAM=NUMNAM+1
      IHNAME(NUMNAM)='PI  '
      IHNAM2(NUMNAM)='    '
      IUSE(NUMNAM)='P'
      VALUE(NUMNAM)=3.1415926535898
      IVALUE(NUMNAM)=VALUE(NUMNAM)
      IN(NUMNAM)=1
C
      NUMNAM=NUMNAM+1
      IHNAME(NUMNAM)='YPLO'
      IHNAM2(NUMNAM)='T   '
      IUSE(NUMNAM)='V'
      IVALUE(NUMNAM)=MAXCOL+3
      VALUE(NUMNAM)=IVALUE(NUMNAM)
      IN(NUMNAM)=MAXN
      N=IN(NUMNAM)
      ICOLVJ=IVALUE(NUMNAM)
      IVSTAR(NUMNAM)=MAXN*(ICOLVJ-1)+1
      IVSTOP(NUMNAM)=MAXN*(ICOLVJ-1)+N
C
      NUMNAM=NUMNAM+1
      IHNAME(NUMNAM)='XPLO'
      IHNAM2(NUMNAM)='T   '
      IUSE(NUMNAM)='V'
      IVALUE(NUMNAM)=MAXCOL+4
      VALUE(NUMNAM)=IVALUE(NUMNAM)
      IN(NUMNAM)=MAXN
      N=IN(NUMNAM)
      ICOLVJ=IVALUE(NUMNAM)
      IVSTAR(NUMNAM)=MAXN*(ICOLVJ-1)+1
      IVSTOP(NUMNAM)=MAXN*(ICOLVJ-1)+N
C
      NUMNAM=NUMNAM+1
      IHNAME(NUMNAM)='X2PL'
      IHNAM2(NUMNAM)='OT  '
      IUSE(NUMNAM)='V'
      IVALUE(NUMNAM)=MAXCOL+5
      VALUE(NUMNAM)=IVALUE(NUMNAM)
      IN(NUMNAM)=MAXN
      N=IN(NUMNAM)
      ICOLVJ=IVALUE(NUMNAM)
      IVSTAR(NUMNAM)=MAXN*(ICOLVJ-1)+1
      IVSTOP(NUMNAM)=MAXN*(ICOLVJ-1)+N
C
      NUMNAM=NUMNAM+1
      IHNAME(NUMNAM)='TAGP'
      IHNAM2(NUMNAM)='LOT '
      IUSE(NUMNAM)='V'
      IVALUE(NUMNAM)=MAXCOL+6
      VALUE(NUMNAM)=IVALUE(NUMNAM)
      IN(NUMNAM)=MAXN
      N=IN(NUMNAM)
      ICOLVJ=IVALUE(NUMNAM)
      IVSTAR(NUMNAM)=MAXN*(ICOLVJ-1)+1
      IVSTOP(NUMNAM)=MAXN*(ICOLVJ-1)+N
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
 9000 CONTINUE
      IF(IBUGIN.EQ.'OFF')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF INITH2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)NUMNAM,MAXCOL,MAXN,CPUMAX
 9012 FORMAT('NUMNAM,MAXCOL,MAXN,CPUMAX = ',3I8,E15.7)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE INITOD(IBUGIN)
C
C     PURPOSE--THIS IS SUBROUTING INITOD.
C              (THE   OD    AT THE END OF    INITOD   STANDS FOR   OUTPUT
C              THIS SUBROUTINE INITIALIZES OUTPUT DEVICE VARIABLES AND PARAMETER
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           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.6
C     ORIGINAL VERSION--SEPTEMBER 1980.
C     UPDATED         --AUGUST    1981.
C     UPDATED         --MARCH     1982.
C     UPDATED         --MAY       1982.
C     UPDATED         --FEBRUARY  1989.  SOFT-CODE SETTINGS (ALAN)
C     UPDATED         --FEBRUARY  1989.  DEVICE ... OFFSET (ALAN)
C     UPDATED         --FEBRUARY  1989.  DEVICE-DEPENDENT COMMON (ALAN)
C     UPDATED         --MARCH     1990.  X11 DEVICE COMMON
C     UPDATED         --MAY       1990.  DEVICE DEPENDENT COMMON UPDATES
C     UPDATED         --NOVEMBER  1990.  POSTSCRIPT MARGINS (ALAN)
C     UPDATED         --JANUARY   1991.  DEFINE REGIS COLOR TABLES (ALAN)
C     UPDATED         --MAY       1991.  TURBO-C SETTINGS (JJF)
C     UPDATED         --MAY       1991.  COSMETIC BLOCKING (JJF)
C     UPDATED         --OCTOBER   1991.  ADDED POSTSCRIPT SPACE (ALAN)
C     UPDATED         --MAY       1992.  POSTCRIPT INITIAL BLANK PAGE
C     UPDATED         --MAY       1992.  ADD IBM/TURBOC COMMENT LINES
C     UPDATED         --MAY       1992.  (RE)ADD ICOMLI AND NCOMLI
C     UPDATED         --MAY       1992.  IDCODE(.) TO AVOID UNDEF. IN PLOTG2
C     UPDATED         --JUNE      1992.ICOMLI/NCOMLI => PLOTFC/NPLOTF
C     UPDATED         --JULY      1992.TCPLFI & TCTEFI: OFF => CLOS
C     UPDATED         --SEPTEMBER 1993. DECLARE DUMMY ISUBRO
C     UPDATED         --JUNE      1994. HARDWARE FILL SWITCHES
C     UPDATED         --FEBRUARY  1996. MOVE CALL TCINCO BACK TO MAIN
C     UPDATED         --JULY      1996. LAHEY DEVICE DRIVER
C     UPDATED         --JULY      1996. DEVICE ... FONT
C     UPDATED         --NOVEMBER  1996. MICROSOFT QWIN DEVICE DRIVER
C     UPDATED         --APRIL     1997. CHANGE IX11PM DEFAULT
C     UPDATED         --APRIL     1997. ADD DPCOPM
C     UPDATED         --OCTOBER   1997. IX11W2
C     UPDATED         --DECEMBER  1997. IGENFA
C     UPDATED         --FEBRUARY  1998. IPRNTR
C     UPDATED         --MARCH     2002. SVG DEVICE
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IBUGIN
C
CCCCC THE FOLLOWING LINE WAS ADDED    SEPTEMBER 1993
      CHARACTER*4 ISUBRO
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOPA.INC'
      INCLUDE 'DPCOSU.INC'
      INCLUDE 'DPCOPC.INC'
      INCLUDE 'DPCODV.INC'
      INCLUDE 'DPCOST.INC'
CCCCC THE FOLLOWING INCLUDE STATEMENT WAS INSERTED FEBRUARY 1989
      INCLUDE 'DPCOGR.INC'
CCCCC THE FOLLOWING INCLUDE STATEMENT WAS INSERTED APRIL 1997
      INCLUDE 'DPCOPM.INC'
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
CCCCC THE FOLLOWING LINE WAS ADDED    SEPTEMBER 1993
CCCCC TO ALLOW AN ARGUMENT MATCH      SEPTEMBER 1993
CCCCC IN THE CALL TO TCINCO(ISUBRO)   SEPTEMBER 1993
      ISUBRO='DUMM'
C
      IF(IBUGIN.EQ.'OFF')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF INITOD--')
      CALL DPWRST('XXX','BUG ')
   90 CONTINUE
C
C               ****************************************
C               **  TREAT THE NUMBER OF DEVICES CASE  **
C               ****************************************
C
CCCCC THE FOLLOWING SINGLE LINE FIX WAS INSERTED FEBRUARY 1989
CCCCC MAXDEV=10
      MAXDEV=MAXDV
      NUMDEV=1
C
C               **********************************************
C               **  TREAT THE DEVICE ... MANUFACTURER CASE  **
C               **********************************************
C
      IDEFMA='TEKT'
      IDEFMO='4014'
      IDEFM2='    '
      IDEFM3='    '
C
      DO1110I=1,MAXDEV
      IDMANU(I)='    '
      IDMODE(I)='    '
      IDMOD2(I)='    '
      IDMOD3(I)='    '
 1110 CONTINUE
C
      IDMANU(1)=IDEFMA
      IDMODE(1)=IDEFMO
      IDMOD2(1)=IDEFM2
      IDMOD3(1)=IDEFM3
C
C               **************************************
C               **  TREAT THE DEVICE ... POWER CASE **
C               **************************************
C
      IDEFPO='ON'
C
      DO1210I=1,MAXDEV
      IDPOWE(I)='OFF'
 1210 CONTINUE
C
      IDPOWE(1)=IDEFPO
C
C               ********************************************
C               **  TREAT THE DEVICE ... CONTINUOUS CASE  **
C               ********************************************
C
      IDEFCN='ON'
C
      DO1310I=1,MAXDEV
      IDCONT(I)='ON'
 1310 CONTINUE
C
      IDCONT(1)=IDEFCN
C
C               ********************************************
C               **  TREAT THE DEVICE ... COLOR      CASE  **
C               ********************************************
C
      IDEFDC='OFF'
C
      DO1410I=1,MAXDEV
      IDCOLO(I)='OFF'
 1410 CONTINUE
C
      IDCOLO(1)=IDEFDC
C
C               *************************************************
C               **  TREAT THE DEVICE ... PICTURE POINTS CASE   **
C               *************************************************
C
      IDEFVP=3124
      IDEFHP=4096
CCCCC IDEFVP=781
CCCCC IDEFHP=1024
C
      DO1510I=1,MAXDEV
      IDNVPP(I)=(-999)
      IDNHPP(I)=(-999)
 1510 CONTINUE
C
      IDNVPP(1)=IDEFVP
      IDNHPP(1)=IDEFHP
C
C               ********************************************
C               **  TREAT THE DEVICE ... UNIT NUMBER CASE **
C               ********************************************
C
CCCCC IDEFUN=6
CCCCC THE FOLLOWING SINGLE LINE FIX WAS INSERTED FEBRUARY 1989
CCCCC IDEFUN=IPR
      IDEFUN=IPRGR
C
      DO1610I=1,MAXDEV
      IDUNIT(I)=IDEFUN
CCCCC THE FOLLOWING LINE WAS ADDED TO AVOID PLOTG2 UNDEFINED ERROR MAY 1992
CCCCC THE FOLLOWING LINE WAS CHANGED FROM CHAR TO INT   OCTOBER 1992
CCCCC IDCODE(I)='JUNK'
      IDCODE(I)=0
 1610 CONTINUE
C
C               **************************************************************
C               **  TREAT THE DEVICE ... OFFSET      CASE    FEBRUARY 1989  **
C               **************************************************************
C
CCCCC IDEFUN=6
      IDEFOV=0
      IDEFOH=0
C
      DO1620I=1,MAXDEV
      IDNVOF(I)=IDEFOV
      IDNHOF(I)=IDEFOH
 1620 CONTINUE
C
C               ********************************************
C               **  TREAT THE DEVICE ... BAUD RATE CASE   **
C               ********************************************
C
      IDEFBA=1200
C
      DO1710I=1,MAXDEV
      IDBAUD(I)=IDEFBA
 1710 CONTINUE
CCCCC ADD FOLLOWING SECTION JULY 1996.
C
C               ********************************************
C               **  TREAT THE DEVICE ... FONT       CASE  **
C               ********************************************
C
      IDEFFN='OFF'
C
      DO1810I=1,MAXDEV
      IDFONT(I)=IDEFFN
 1810 CONTINUE
C
C               ********************************************
C               **  TREAT THE HARDCOPY             CASE   **
C               ********************************************
C
      ICOPSW='OFF'
      NUMCOP=1
C
C               ********************************************
C               **  TREAT THE SET PRINTER          CASE   **
C               ********************************************
C
      IPRNTR=' '
      NCPRNT=0
C
C               *********************************************
C               **  TREAT THE FILE CASE                    **
C               **  (FILE, CALCOMP, VERSATEC, ZETA, ETC.)  **
C               *********************************************
C
C               *******************************
C               **  TREAT THE METAFILE CASE  **
C               *******************************
C
C               **************************************************************
C               **  TREAT THE DEVICE-DEPENDENT COMMON CASE    FEBRUARY 1989 **
C               **************************************************************
C
C----------CALCOMP----------
C
      ICALSW='OFF'
      ICALCL=4
      ICALCC=-999
      PCALTH=0.05
C  FOLLOWING LINES ADDED FOR CALCOMP MAY, 1990.
      ICALPF='OFF'
      ICALPM(1)='BLAC'
      ICALPM(2)='RED'
      ICALPM(3)='BLUE'
      ICALPM(4)='GREE'
      ICALPM(5)='BLAC'
      ICALPM(6)='RED'
      ICALPM(7)='BLUE'
      ICALPM(8)='GREE'
      ICALPM(9)='BLAC'
      ICALPM(10)='RED'
      ICALPM(11)='BLUE'
      ICALPM(12)='GREE'
      ICALPM(13)='BLAC'
      ICALPM(14)='RED'
      ICALPM(15)='BLUE'
      ICALPM(16)='GREE'
C
CCCCC ADD LAHEY DEVICE INITIALIZATION JULY 1996.
C----------CALCOMP----------
C
      ILAHSW='OFF'
      ILAHPA='OFF'
      ILAHGR='DIRE'
      ILAHCL='OFF'
      ILAHSW='OFF'
      ILAHNC=8
      ILAHCC=-999
      PLAHTH=0.05
C  FOLLOWING LINES ADDED FOR LAHCOMP MAY, 1990.
      ILAHPF='OFF'
      ILAHPM(1)='BLAC'
      ILAHPM(2)='RED'
      ILAHPM(3)='BLUE'
      ILAHPM(4)='GREE'
      ILAHPM(5)='BLAC'
      ILAHPM(6)='RED'
      ILAHPM(7)='BLUE'
      ILAHPM(8)='GREE'
      ILAHPM(9)='BLAC'
      ILAHPM(10)='RED'
      ILAHPM(11)='BLUE'
      ILAHPM(12)='GREE'
      ILAHPM(13)='BLAC'
      ILAHPM(14)='RED'
      ILAHPM(15)='BLUE'
      ILAHPM(16)='GREE'
C
CCCCC ADD MICROSOFT QWIN DEVICE INITIALIZATION NOVEMBER 1996.
C----------QUICK-WIN----------
C
      IQWNF2=15
      IQWNBC=0
      IQWNFC='TEXT'
CCCCC MARCH 2002: SET COLOR MODE IN MSFORT.F (ALLOW TO BE SET
CCCCC VIA COMMAND LINE ARGUMENT
CCCCC IQWNCL='VGA'
      IQWNFZ='COURIER'
      IQWNPF='OFF'
      IQWNPM(1)='BLAC'
      IQWNPM(2)='RED'
      IQWNPM(3)='BLUE'
      IQWNPM(4)='GREE'
      IQWNPM(5)='BLAC'
      IQWNPM(6)='RED'
      IQWNPM(7)='BLUE'
      IQWNPM(8)='GREE'
      IQWNPM(9)='BLAC'
      IQWNPM(10)='RED'
      IQWNPM(11)='BLUE'
      IQWNPM(12)='GREE'
      IQWNPM(13)='BLAC'
      IQWNPM(14)='RED'
      IQWNPM(15)='BLUE'
      IQWNPM(16)='GREE'
C
CCCCC ADD LAHEY WINTERACTOR DEVICE INITIALIZATION NOVEMBER 1996.
C----------QUICK-WIN----------
C
      IWINFN='FIXE'
      IWINCL='RGB'
      IWINHP=600
      IWINVP=450
C
C----------ZETA----------
C
      IZETSW='OFF'
      IZETCL=4
      IZETCC=-999
      PZETTH=0.05
C  FOLLOWING LINES ADDED FOR ZETA MAY, 1990.
      IZETPF='OFF'
      IZETPM(1)='BLAC'
      IZETPM(2)='RED'
      IZETPM(3)='BLUE'
      IZETPM(4)='GREE'
      IZETPM(5)='BLAC'
      IZETPM(6)='RED'
      IZETPM(7)='BLUE'
      IZETPM(8)='GREE'
      IZETPM(9)='BLAC'
      IZETPM(10)='RED'
      IZETPM(11)='BLUE'
      IZETPM(12)='GREE'
      IZETPM(13)='BLAC'
      IZETPM(14)='RED'
      IZETPM(15)='BLUE'
      IZETPM(16)='GREE'
C
C----------HP PCL----------
C
      IPCLLM=60
      IPCLRM=60
      IPCLTM=50
      IPCLBM=100
      IPC2LM=50
      IPC2RM=100
      IPC2TM=60
      IPC2BM=60
      PCLPPI=300.
      IPCLFN='COUR'
      IPCLFC='COUR'
C
C----------QUIC----------
C
      IQUILM=85
      IQUIRM=25
      IQUITM=100
      IQUIBM=25
      IQU2LM=70
      IQU2RM=25
      IQU2TM=60
      IQU2BM=25
      QUIPPI=300.
      IQUIFN=10
      IQUIFC=10
C
C----------POSTSCRIPT----------
C
      PSTPPI=300.
C  NOVEMBER, 1990.  MARGIN DEFAULTS CHANGED (PREVIOUSLY HARDCODED TO 75, SET
C  TO 1/4 INCH PLUS A SMALL FUDGE FACTOR).
      IDEFMG=INT(PSTPPI/4.0)+10
      IPSTLM=IDEFMG
      IPSTRM=IDEFMG
      IPSTTM=IDEFMG
      IPSTBM=IDEFMG
      IPS2LM=IDEFMG
      IPS2RM=IDEFMG
      IPS2TM=IDEFMG
      IPS2BM=IDEFMG
CCCCC IPSTFN='TROM'
CCCCC IPSTFC='TROM'
CCCCC ABOVE TWO LINES FIXED JULY 1989
      IPSTFN='HELB'
      IPSTFC='HELB'
      IPSTPS=12
      IPSTPC=12
CCCCC JUNE 1994.  FOLLOWING LINE ADDED.
      IPSTFS='ON'
C  FOLLOWING LINES ADDED OCTOBER 1991
C  MAKE POSTSCRIPT FONTS TABLE DRIVEN FOR EASIER UPDATING
      IPSTSP='OFF'
      IPSTMF=34
      IPSTT1( 1)='TROM'
      IPSTT2( 1)='Times-Roman'
      IPSTT1( 2)='TITA'
      IPSTT2( 2)='Times-Italic'
      IPSTT1( 3)='TBOL'
      IPSTT2( 3)='Times-Bold'
      IPSTT1( 4)='TBIT'
      IPSTT2( 4)='Times-BoldItalic'
      IPSTT1( 5)='HELV'
      IPSTT2( 5)='Helvetica'
      IPSTT1( 6)='HELO'
      IPSTT2( 6)='Helvetica-Oblique'
      IPSTT1( 7)='HELB'
      IPSTT2( 7)='Helvetica-Bold'
      IPSTT1( 8)='HEBO'
      IPSTT2( 8)='Helvetica-BoldOblique'
      IPSTT1( 9)='COUR'
      IPSTT2( 9)='Courier'
      IPSTT1(10)='COBL'
      IPSTT2(10)='Courier-Oblique'
      IPSTT1(11)='CBOL'
      IPSTT2(11)='Courier-Bold'
      IPSTT1(12)='CBOB'
      IPSTT2(12)='Courier-BoldOblique'
      IPSTT1(13)='AGBK'
      IPSTT2(13)='AvantGarde-Book'
      IPSTT1(14)='AGBO'
      IPSTT2(14)='AvantGarde-BookOblique'
      IPSTT1(15)='AGDE'
      IPSTT2(15)='AvantGarde-Demi'
      IPSTT1(16)='AGDO'
      IPSTT2(16)='AvantGarde-DemiOblique'
      IPSTT1(17)='BKDE'
      IPSTT2(17)='Bookman-Demi'
      IPSTT1(18)='BKDI'
      IPSTT2(18)='Bookman-DemiItalic'
      IPSTT1(19)='BKLT'
      IPSTT2(19)='Bookman-Light'
      IPSTT1(20)='BKLI'
      IPSTT2(20)='Bookman-LightItalic'
      IPSTT1(21)='HELN'
      IPSTT2(21)='Helvetica-Narrow'
      IPSTT1(22)='HENB'
      IPSTT2(22)='Helvetica-Narrow-Bold'
      IPSTT1(23)='HNBO'
      IPSTT2(23)='Helvetica-Narrow-BoldOblique'
      IPSTT1(24)='HENO'
      IPSTT2(24)='Helvetica-Narrow-Oblique'
      IPSTT1(25)='NCSR'
      IPSTT2(25)='NewCenturySchlbk-Roman'
      IPSTT1(26)='NCSB'
      IPSTT2(26)='NewCenturySchlbk-Bold'
      IPSTT1(27)='NCSI'
      IPSTT2(27)='NewCenturySchlbk-Italic'
      IPSTT1(28)='CSBI'
      IPSTT2(28)='NewCenturySchlbk-BoldItalic'
      IPSTT1(29)='PALR'
      IPSTT2(29)='Palatino-Roman'
      IPSTT1(30)='PALB'
      IPSTT2(30)='Palatino-Bold'
      IPSTT1(31)='PALI'
      IPSTT2(31)='Palatino-Italic'
      IPSTT1(32)='PABI'
      IPSTT2(32)='Palatino-BoldItalic'
      IPSTT1(33)='ZAPF'
      IPSTT2(33)='ZapfChancery-MediumItalic'
      IPSTT1(34)='SYMB'
      IPSTT2(34)='Symbol'
      DO910I=IPSTMF+1,100
      IPSTT1(I)=' '
      IPSTT2(I)=' '
 910  CONTINUE
C  END OF CHANGE
CCCCC THE FOLLOWING LINE WAS ADDED MAY 1992 (JJF)
CCCCC SEE ALSO DPCODV.INC          MAY 1992
      IPSTBP='OFF'
C
C----------SUN----------
C
CCCCC IVSNAM=0
      ISUNCL=0
      PSUNTH=0.1
C
C----------CGM----------
C
      ICGMSW='OFF'
C
C----------GENERAL----------
C
      IGENFA=1
C
C
C----------DEC REGIS----------
C
      PREGTH=0.1
CCCCC ABOVE COLOR DEFINITIONS FOR REGIS ADDED JANUARY, 1991.
      IRGHUE(1)= 260
      IRGHUE(2)= 280
      IRGHUE(3)=   0
      IRGHUE(4)=   0
      IRGHUE(5)= 300
      IRGHUE(6)=   0
      IRGHUE(7)=  40
      IRGHUE(8)= 300
      IRGHUE(9)=   0
      IRGHUE(10)=  0
      IRGHUE(11)= 30
      IRGHUE(12)=  0
      IRGHUE(13)=  0
      IRGHUE(14)=320
      IRGHUE(15)=330
      IRGHUE(16)=320
      IRGHUE(17)=150
      IRGHUE(18)=300
      IRGHUE(19)=120
      IRGHUE(20)=160
      IRGHUE(21)=180
      IRGHUE(22)=180
      IRGHUE(23)=240
      IRGHUE(24)=240
      IRGHUE(25)=180
      IRGHUE(26)=240
      IRGHUE(27)=240
      IRGHUE(28)=200
      IRGHUE(29)=240
      IRGHUE(30)=210
      IRGHUE(31)=240
      IRGHUE(32)=280
      IRGHUE(33)=270
      IRGHUE(34)=200
      IRGHUE(35)=300
      IRGHUE(36)=  0
      IRGHUE(37)=  0
      IRGHUE(38)=180
      IRGHUE(39)= 60
      IRGHUE(40)= 80
      IRGHUE(41)=120
      IRGHUE(42)= 60
      IRGHUE(43)= 40
      IRGHUE(44)= 20
      IRGHUE(45)=120
      IRGHUE(46)= 60
      IRGHUE(47)=120
      IRGHUE(48)=120
      IRGHUE(49)=100
      IRGHUE(50)= 90
      IRGHUE(51)= 80
      IRGHUE(52)=120
      IRGHUE(53)=160
      IRGHUE(54)=140
      IRGHUE(55)= 60
      IRGHUE(56)=300
      IRGHUE(57)=340
      IRGHUE(58)=300
      IRGHUE(59)= 60
      IRGHUE(60)= 60
      IRGHUE(61)=180
      IRGHUE(62)=  0
      IRGHUE(63)=180
      IRGHUE(64)=220
      IRGLGT(1)=  65
      IRGLGT(2)=  50
      IRGLGT(3)=   0
      IRGLGT(4)=  50
      IRGLGT(5)=  50
      IRGLGT(6)=  35
      IRGLGT(7)=  35
      IRGLGT(8)=  80
      IRGLGT(9)=  65
      IRGLGT(10)= 50
      IRGLGT(11)= 50
      IRGLGT(12)= 25
      IRGLGT(13)= 35
      IRGLGT(14)= 50
      IRGLGT(15)= 50
      IRGLGT(16)= 35
      IRGLGT(17)= 50
      IRGLGT(18)= 50
      IRGLGT(19)= 35
      IRGLGT(20)= 50
      IRGLGT(21)= 65
      IRGLGT(22)= 80
      IRGLGT(23)= 50
      IRGLGT(24)= 25
      IRGLGT(25)= 25
      IRGLGT(26)= 35
      IRGLGT(27)= 50
      IRGLGT(28)= 35
      IRGLGT(29)= 35
      IRGLGT(30)= 50
      IRGLGT(31)= 65
      IRGLGT(32)= 35
      IRGLGT(33)= 50
      IRGLGT(34)= 50
      IRGLGT(35)= 25
      IRGLGT(36)= 33
      IRGLGT(37)= 66
      IRGLGT(38)= 50
      IRGLGT(39)= 50
      IRGLGT(40)= 35
      IRGLGT(41)= 50
      IRGLGT(42)= 65
      IRGLGT(43)= 50
      IRGLGT(44)= 65
      IRGLGT(45)= 65
      IRGLGT(46)= 80
      IRGLGT(47)= 50
      IRGLGT(48)= 25
      IRGLGT(49)= 65
      IRGLGT(50)= 50
      IRGLGT(51)= 50
      IRGLGT(52)= 35
      IRGLGT(53)= 35
      IRGLGT(54)= 65
      IRGLGT(55)= 80
      IRGLGT(56)= 80
      IRGLGT(57)= 65
      IRGLGT(58)= 65
      IRGLGT(59)= 25
      IRGLGT(60)= 50
      IRGLGT(61)= 80
      IRGLGT(62)= 99
      IRGLGT(63)= 50
      IRGLGT(64)= 65
      IRGSAT(1)=  60
      IRGSAT(2)=  60
      IRGSAT(3)=   0
      IRGSAT(4)= 100
      IRGSAT(5)=  25
      IRGSAT(6)=  25
      IRGSAT(7)=  60
      IRGSAT(8)=  25
      IRGSAT(9)=  25
      IRGSAT(10)= 60
      IRGSAT(11)=100
      IRGSAT(12)= 25
      IRGSAT(13)= 60
      IRGSAT(14)= 60
      IRGSAT(15)=100
      IRGSAT(16)= 60
      IRGSAT(17)=100
      IRGSAT(18)=100
      IRGSAT(19)= 60
      IRGSAT(20)= 60
      IRGSAT(21)= 60
      IRGSAT(22)= 60
      IRGSAT(23)=100
      IRGSAT(24)= 25
      IRGSAT(25)= 25
      IRGSAT(26)= 60
      IRGSAT(27)= 60
      IRGSAT(28)= 60
      IRGSAT(29)= 25
      IRGSAT(30)=100
      IRGSAT(31)= 25
      IRGSAT(32)= 60
      IRGSAT(33)=100
      IRGSAT(34)= 60
      IRGSAT(35)= 25
      IRGSAT(36)=  0
      IRGSAT(37)=  0
      IRGSAT(38)= 25
      IRGSAT(39)=100
      IRGSAT(40)= 60
      IRGSAT(41)= 60
      IRGSAT(42)= 60
      IRGSAT(43)= 60
      IRGSAT(44)= 60
      IRGSAT(45)= 25
      IRGSAT(46)= 60
      IRGSAT(47)=100
      IRGSAT(48)= 25
      IRGSAT(49)= 60
      IRGSAT(50)=100
      IRGSAT(51)= 60
      IRGSAT(52)= 25
      IRGSAT(53)= 60
      IRGSAT(54)= 60
      IRGSAT(55)= 25
      IRGSAT(56)= 60
      IRGSAT(57)= 60
      IRGSAT(58)= 60
      IRGSAT(59)= 25
      IRGSAT(60)= 25
      IRGSAT(61)= 25
      IRGSAT(62)=  0
      IRGSAT(63)=100
      IRGSAT(64)= 60
C
C  VT-240 ALLOWS 4 ACTIVE COLOR MAPS.  RESERVE 0 FOR THE BACKGROUND COLOR
C  AND 1-3 FOR THE FOREGROUND COLORS.  I DON'T HAVE ANY VT-340 DOCUMENTATION
C  SO NOT SURE IF VT-340 ALLOWS MORE.  FOR NOW, SET MAXIMUM FOREGROUND COLORS
C  TO 3 (AND SET DEFAULT TO WHITE, YELLOW, AND RED (BACKGROUND IS BLUE).
C  NOTE: 340 ALLOWS 16 COLORS (BUT ONE RESERVED FOR BACKGROUND).
C
      IREGMC=3
      IREGPM(1)=62
      IREGPM(2)=63
      IREGPM(3)=47
      IREGPM(4)=3
      IREGPM(5)=23
      IREGPM(6)=18
      IREGPM(7)=4
      IREGPM(8)=41
      IREGPM(9)=59
      IREGPM(10)=39
      IREGPM(11)=64
      IREGPM(12)=54
      IREGPM(13)=20
      IREGPM(14)=51
      IREGPM(15)=37
      IREGPM(16)=35
C  END CHANGE
C
C----------HP 2622------------
C
      P262TH=0.1
C
C----------HP 7221------------
C
      P722TH=0.1
C
C----------HP-GL--------------
C
      PHPGTH=0.1
C ADDED FOLLOWING LINES FOR HP MAY, 1990.
      IHPGSW='OFF'
      IHPGPF='OFF'
      IHPGCL=4
      IHPGPM(1)='BLAC'
      IHPGPM(2)='RED'
      IHPGPM(3)='BLUE'
      IHPGPM(4)='GREE'
      IHPGPM(5)='BLAC'
      IHPGPM(6)='RED'
      IHPGPM(7)='BLUE'
      IHPGPM(8)='GREE'
      IHPGPM(9)='BLAC'
      IHPGPM(10)='RED'
      IHPGPM(11)='BLUE'
      IHPGPM(12)='GREE'
      IHPGPM(13)='BLAC'
      IHPGPM(14)='RED'
      IHPGPM(15)='BLUE'
      IHPGPM(16)='GREE'
C
C----------TEKTRONIX----------
C
      PTEKTH=0.1
C
C----------GENERAL------------
C
C  ADDED FOLLOWING LINES JANUARY, 1990 (PREVIOUSLY DONE IN MAIN)
CCCCC JANUARY 1995.  MODIFY DEFAULT FOR FRONTEND
CCCCC IJUSSW='OFF'
      IJUSSW='ON'
      IRFLSW='OFF'
      IFNTSW='OFF'
      IPTHSW='OFF'
      PPENSW=0.1
C
C----------X11 CASE-----------
C
C  ADDED FOLLOWING LINES MARCH, 1990 FOR X11
      IX11CS='BUTT'
      IX11JS='MITER'
CCCCC CHANGE DEFAULT.  APRIL 1997
CCCCC IX11PM='OFF'
      IX11PM='ON'
      IX11FN='8X13'
      IX11OF='OFF'
      IX11PA='OFF '
      IX11DN='DEFAULT'
CCCCC JUNE 1994.  FOLLOWING LINE ADDED.
      IX11FS='ON'
C
CCCCC ADD FOLLOWING SECTION.  APRIL 1997
      NUMPXM=0
      ICURPM=0
      IPXMFL='OFF'
      IPXMFB='pixmap.'
      IPXMNC=7
      DO1010I=1,MAXPM
      IPXMFN(I)=' '
      IPXMCM(I)=' '
 1010 CONTINUE
CCCCC ADD FOLLOWING SECTION.  OCTOBER 1997
      IX11W2=' '
C
C----------TURBO-C FOR IBM-PC-------------
C
CCCCC THE INITIALIZATION OF THE TURBO-C DRIVER FOR IBM-PC  MAY 1993
CCCCC WAS MOVED TO    TCINCO.FOR    WITHIN    TCDRIV.FOR   MAY 1993
CCCCC THE CALL TO TCINCO WAS MOVED BACK TO MAIN      FEBRUARY 1996
CCCCC CALL TCINCO(ISUBRO)
C
CCCCC ADD LAHEY WINTERACTOR DEVICE INITIALIZATION NOVEMBER 1996.
C
C----------SVG (SCALABLE VECTOR GRAPHICS)------
C
      ISVGOS='OFF'
      ISVGCS='PIXE'
      ISVGCA='BUTT'
      ISVGJS='MITE'
      ISVGFS='NONZ'
      ISVGSS='INTE'
      ISVGST='norm'
      ISVGFW='bold'
      ISVGFN='sans-serif'
      ISVGSS='INTE'
      ISVGSN='dataplot.css'
      ISVGCN=0
C
C----------LATEX-------------------------------
C
      ILATOS='OFF'
      ILATCO='OFF'
      ILATFS='OFF'
      ILATLT='HARD'
C
C               *******************************
C               **  EXIT AND RETURN TO MAIN  **
C               *******************************
C
 9000 CONTINUE
      IF(IBUGIN.EQ.'OFF')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF INITOD--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)MAXDEV,NUMDEV
 9012 FORMAT('MAXDEV,NUMDEV = ',2I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)IDEFMA,IDEFMO,IDEFM2,IDEFM3
 9013 FORMAT('IDEFMA,IDEFMO,IDEFM2,IDEFM3 = ',A4,2X,A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9014)IDEFPO,IDEFCN,IDEFDC
 9014 FORMAT('IDEFPO,IDEFCN,IDEFDC = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9015)IDEFVP,IDEFHP,IDEFUN
 9015 FORMAT('IDEFVP,IDEFHP,IDEFUN = ',3I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9016)ICOPSW,NUMCOP
 9016 FORMAT('ICOPSW,NUMCOP = ',A4,I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9017)IDMANU(1)
 9017 FORMAT('IDMANU(1) = ',A4)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE INITSU(IBUGIN)
C
C     PURPOSE--THIS IS SUBROUTING INITSU.
C              (THE   SU    AT THE END OF    INITSU   STANDS FOR   SUPPORT
C              THIS SUBROUTINE INITIALIZES SUPPORT VARIABLES AND PARAMETERS
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           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.6
C     ORIGINAL VERSION--NOVEMBER  1980.
C     UPDATED         --MARCH     1981.
C     UPDATED         --AUGUST    1981.
C     UPDATED         --MAY       1982.
C     UPDATED         --MAY       1990.  COMMENT CHARACTER
C     UPDATED         --AUGUST    1992.  VECTOR PLOT PARAMETERS
C     UPDATED         --OCTOBER   1992.  CHANGE ICOMFL TO ICOMSW
C     UPDATED         --NOVEMBER  1992.  ANDREWS PLOT PARAM. (ALAN)
C     UPDATED         --MAY       1993.  MINMAX FOR EV1/EV2/WEIB DIST.
C     UPDATED         --JULY      1993.  FRACTAL ITERATIONS, FRACTAL
C                                        TYPE, PRINCIPLE COMPONENT TYPE
C     UPDATED         --JANUARY   1994.  WEIB MINMAX TO DPCOS2.INC
C     UPDATED         --FEBRUARY  1994.  DEFAULT FOR FITSD
C     UPDATED         --JUNE      1994.  OPTIMIZATION TOLERANCE
C     UPDATED         --FEBRUARY  1995.  OPTIMIZATION METHOD
C     UPDATED         --JULY      1995.  FIT ADDITIVE CONSTANT
C     UPDATED         --APRIL     1997.  SET NETSCAPE <OLD/NEW>
C     UPDATED         --APRIL     1997.  SET CONTROL CHART <DATA/PRIOR>
C     UPDATED         --APRIL     1997.  SET CONTROL CHART WEIGHT <CENTER/RIGHT>
C     UPDATED         --AUGUST    1997.  3 SWITCHES FOR RECIPE
C     UPDATED         --APRIL     1998.  RECIPE FIT FACTORS
C     UPDATED         --MAY       1998.  KAPLAN-MEIER <RELI/CDF>
C     UPDATED         --MAY       1998.  CENSORING TYPE <1/2>
C     UPDATED         --JUNE      1998.  MATRIX SCALE <NONE/SD/RANGE/Z-SC>
C     UPDATED         --SEPTEMBER 1998.  PERCENT POINT PLOT BINNED/UNBINNED
C     UPDATED         --SEPTEMBER 1998.  QUANTILE-QUANTILE PLOT BINNED/UNBINNED
C     UPDATED         --MARCH     1999.  SET WEB HANDBOOK
C     UPDATED         --SEPTEMBER 1999.  SET SCATTER PLOT MATRIX OPTIONS
C     UPDATED         --NOVEMBER  1999.  SET PARAMETER EXPANSION OPTION
C     UPDATED         --JANUARY   2000.  SET SORT DIRECTION
C     UPDATED         --OCTOBER   2000.  SET MANDEL PAULE
C     UPDATED         --MARCH     2001.  SET SUPERSCRIPT HORI SCALE
C     UPDATED         --MARCH     2001.  SET SUPERSCRIPT VERT SCALE
C     UPDATED         --APRIL     2001.  SET ORTHOGONAL DISTANCE
C                                            TRUST REGION RADIUS
C     UPDATED         --APRIL     2001.  SET ORTHOGONAL DISTANCE
C                                            STOP TOLERANCE
C     UPDATED         --APRIL     2001.  SET ORTHOGONAL DISTANCE
C                                            PARAMETER TOLERANCE
C     UPDATED         --APRIL     2001.  SET ORTHOGONAL DISTANCE
C                                            PRINT OPTION
C     UPDATED         --JULY      2001.  SET KERNEL DENSITY OPTIONS
C     UPDATED         --MARCH     2002.  SET BOX PLOT WIDTH
C     UPDATED         --MAY       2002.  SET RANDOM NUMBER GENERATOR
C     UPDATED         --JUNE      2002.  SET NUMBER OF CP
C     UPDATED         --JUNE      2002.  ICAPTY
C     UPDATED         --JULY      2002.  SET COVARIANCE TYPE
C     UPDATED         --JULY      2002.  SET CORRELATION TYPE
C     UPDATED         --JULY      2002.  SET FILE TYPE QUOTE
C     UPDATED         --JULY      2002.  SET BOOTSTRAP FIT METHOD
C     UPDATED         --NOVEMBER  2002.  SET QWIN SYSTEM
C     UPDATED         --NOVEMBER  2002.  SET GHOSTVIEW PRINTER ON
C     UPDATED         --NOVEMBER  2002.  SET GHOSTVIEW PATH
C     UPDATED         --JANUARY   2003.  SET GHOSTSCRIPT PATH
C     UPDATED         --JANUARY   2003.  SET POSTSCRIPT BOUNDING BOX
C     UPDATED         --JANUARY   2003.  SET POSTSCRIPT CONVERT
C     UPDATED         --JANUARY   2003.  SET HTML HEADER FILE
C     UPDATED         --JANUARY   2003.  SET HTML FOOTER FILE
C     UPDATED         --FEBRUARY  2003.  SET MAXIMUM RECORD LENGTH
C     UPDATED         --FEBRUARY  2003.  SET AUTOCOREELATION LAG ZERO
C     UPDATED         --MARCH     2003.  SET PARALLEL COORDINATES
C                                        STANDARDIZE
C     UPDATED         --MARCH     2003.  SET BOOTSTRAP GROUPS
C     UPDATED         --SEPTEMBER 2003.  SET TABLE TITLE
C     UPDATED         --SEPTEMBER 2003.  SET TABLE BORDER
C     UPDATED         --SEPTEMBER 2003.  SET TABLE SPACING
C     UPDATED         --SEPTEMBER 2003.  SET TABLE WIDTH
C     UPDATED         --SEPTEMBER 2003.  SET TABLE HEIGHT
C     UPDATED         --JANUARY   2004.  SET READ VARIABLE LABEL
C     UPDATED         --JANUARY   2004.  SET CONVERT CHARACTER
C     UPDATED         --JANUARY   2004.  SET READ DELIMITER
C     UPDATED         --JANUARY   2004.  SET READ MISSING VALUE
C     UPDATED         --JUNE      2004.  SET DEFAULT POSTSCRIPT COLOR
C     UPDATED         --JUNE      2004.  SET ASYMMETRIC LAPLACE
C                                        DEFINITION
C     UPDATED         --JULY      2004.  SET GOMPERTZ-MAKEHAM
C                                        DEFINITION
C     UPDATED         --AUGUST    2004.  GIVE MINMAX DEFAULT VALUE
C     UPDATED         --AUGUST    2004.  SET BESSEL I FUNCTION
C                                        DEFINITION
C     UPDATED         --AUGUST    2004.  SET BESSEL K FUNCTION
C                                        DEFINITION
C     UPDATED         --SEPTEMBER 2004.  SET PROBABILITY PLOT DATA
C                                        POINTS
C     UPDATED         --SEPTEMBER 2004.  SET PPCC PLOT DATA POINTS
C     UPDATED         --SEPTEMBER 2004.  SET PPCC PLOT AXIS POINTS
C     UPDATED         --SEPTEMBER 2004.  SET PPCC PLOT AXIS ORDER
C     UPDATED         --SEPTEMBER 2004.  SET HISTOGRAM CLASS WIDTH
C     UPDATED         --SEPTEMBER 2004.  SET ASH WEIGHTING
C     UPDATED         --OCTOBER   2004.  SET READ PAD MISSING COLUMNS
C     UPDATED         --OCTOBER   2004.  SET READ SUBSET
C     UPDATED         --OCTOBER   2004.  SET CENSORED PROBABILITY PLOT
C     UPDATED         --OCTOBER   2004.  SET CENSORED PPCC PLOT
C     UPDATED         --OCTOBER   2004.  SET MAXIMUM LIKELIHOOD PERCENTILES
C     UPDATED         --OCTOBER   2004.  SET EXPONENTIAL BIAS CORRECTED
C     UPDATED         --NOVEMBER  2004.  SET WEIBULL BIAS CORRECTED
C     UPDATED         --NOVEMBER  2004.  SET GUMBELL BIAS CORRECTED
C     UPDATED         --NOVEMBER  2004.  SET MATRIX CORRELATION DIRECTION
C     UPDATED         --NOVEMBER  2004.  SET MATRIX COVARIANCE DIRECTION
C     UPDATED         --DECEMBER  2004.  SET GUI
C     UPDATED         --DECEMBER  2004.  SET MAXIMUM LIKELIHOOD RELIABILITY
C     UPDATED         --FEBRUARY  2005.  SET DISTRIBUTIONAL BOOTSTRAP
C     UPDATED         --FEBRUARY  2005.  SET RTF POINT SIZE
C     UPDATED         --FEBRUARY  2005.  SET RTF FIXED FONT
C     UPDATED         --FEBRUARY  2005.  SET RTF PROPORTIONAL FONT
C     UPDATED         --MARCH     2005.  SET LINE PRINTER COLUMNS
C     UPDATED         --APRIL     2005.  SET DECIMAL POINT
C     UPDATED         --APRIL     2005.  SET PEAKS OVER THRESHOLD
C                                            METHOD
C     UPDATED         --APRIL     2005.  SET PEAKS OVER THRESHOLD
C                                            DISTRIBUTION
C     UPDATED         --APRIL     2005.  SET PEAKS OVER THRESHOLD
C                                            ITERATIONS
C     UPDATED         --APRIL     2005.  SET PEAKS OVER THRESHOLD
C                                            NUMBER POINTS
C     UPDATED         --APRIL     2005.  SET PEAKS OVER THRESHOLD
C                                            INITIAL THRESHOLD
C     UPDATED         --APRIL     2005.  SET PEAKS OVER THRESHOLD
C                                            INCREMENT
C     UPDATED         --APRIL     2005.  SET PEAKS OVER THRESHOLD
C                                            PERIOD
C     UPDATED         --APRIL     2005.  SET PEAKS OVER THRESHOLD
C                                            TOLERANCE
C     UPDATED         --APRIL     2005.  SET PEAKS OVER THRESHOLD
C                                            LOAD FACTOR
C     UPDATED         --APRIL     2005.  SET PEAKS OVER THRESHOLD
C                                            X AXIS
C     UPDATED         --MAY       2005.  SET FRECHET BIAS CORRECTION
C     UPDATED         --JULY      2005.  SET LOG GAMMA DEFINITION
C     UPDATED         --JULY      2005.  SET SKEW NORMAL DEFINITION
C     UPDATED         --SEPTEMBER 2005.  IMACSC
C     UPDATED         --SEPTEMBER 2005.  NMACAG
C     UPDATED         --SEPTEMBER 2005.  IMACAR
C     UPDATED         --JANUARY   2006.  ICAPSC
C     UPDATED         --FEBRUARY  2006.  IGLDDF
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IBUGIN
C
C---------------------------------------------------------------------
C
C-----COMMON----------------------------------------------------------
C
      CHARACTER*1 IBASLC
C
      INCLUDE 'DPCOPA.INC'
      INCLUDE 'DPCOMC.INC'
      INCLUDE 'DPCOHK.INC'
      INCLUDE 'DPCODG.INC'
      INCLUDE 'DPCOSU.INC'
CCCCC THE FOLLOWING LINE (FOR WEIBULL MINMAX) WAS ADDED JANUARY 1994
      INCLUDE 'DPCOS2.INC'
      INCLUDE 'DPCOGR.INC'
CCCCC THE FOLLOWING LINE (FOR SET NETSCAPE) WAS ADDED APRIL 1997
      INCLUDE 'DPCOST.INC'
      INCLUDE 'DPCOHO.INC'
C
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(IBUGIN.EQ.'OFF')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,55)
   55 FORMAT('***** AT THE BEGINNING OF INITSU--')
      CALL DPWRST('XXX','BUG ')
   90 CONTINUE
C
C               ******************************
C               **  TREAT THE ADD     CASE  **
C               **  TREAT THE CALL    CASE  **
C               **  TREAT THE EXECUTE CASE  **
C               **  TREAT THE RUN     CASE  **
C               ******************************
C
C
C               ****************************
C               **  TREAT THE ANGLE CASE  **
C               ****************************
C     THESE HAVE BEEN COMMENTED OUT BECAUSE
C     THE ANGLE WILL BE SET IN SUBROUTINE INITDG
C
CCCCC DEFANG=0.0
CCCCC ANGLE=DEFANG
C
C               **********************************
C               **  TREAT THE ANGLE UNITS CASE  **
C               **********************************
C     THESE HAVE BEEN COMMENTED OUT BECAUSE
C     THE ANGLE UNITS WILL BE SET IN SUBROUTINE INITDG
C
CCCCC IDEANU='RADI'
CCCCC IANGLU=IDEANU
C
C               ***************************
C               **  TREAT THE BAUD CASE  **
C               ***************************
C
CCCCC IDEFBA=1200
C     IDEFBA IS SET IN SUBROUTINE INITOD
C     BECAUSE MAININ CALLS INITOD BEFORE CALLING INITSU
      IBAUD=IDEFBA
      IGBAUD=IBAUD
C
C               **************************************
C               **  TREAT THE CLASS ... LOWER CASE  **
C               **************************************
C
      CLLIMI(1)=CPUMIN
      CLLIMI(3)=CPUMIN
C
C               **************************************
C               **  TREAT THE CLASS ... UPPER CASE  **
C               **************************************
C
      CLLIMI(2)=CPUMAX
      CLLIMI(4)=CPUMAX
C
C               **************************************
C               **  TREAT THE CLASS ... WIDTH CASE  **
C               **************************************
C
      CLWIDT(1)=CPUMIN
      CLWIDT(2)=CPUMIN
C
C               ********************************************
C               **  TREAT THE MAXIMUM RECORD LENGTH CASE  **
C               **  NOTE: THIS SHOULD COME BEFORE COLUMN  **
C               **        LIMITS CASE                     **
C               ********************************************
C
      IDEFRL=255
      NUMRCM=IDEFRL
C
C               ************************************
C               **  TREAT THE COLUMN LIMITS CASE  **
C               ************************************
C
      IDEFC1=1
CCCCC IDEFC2=132
      IDEFC2=IDEFRL
      IFCOL1=IDEFC1
      IFCOL2=IDEFC2
      DO3010I=1,50
        IFCOLL(I)=-1
        IFCOLU(I)=-1
 3010 CONTINUE
C
C               ******************************
C               **  TREAT THE COMMENT CASE  **
C               ******************************
C
C               ***************************
C               **  TREAT THE COPY CASE  **
C               ***************************
C
C
C               **********************************
C               **  TREAT THE CURSOR SIZE CASE  **
C               **********************************
C
      DEFCSZ=1.0
      ACURSZ=DEFCSZ
C
C               ******************************
C               **  TREAT THE DEGREES CASE  **
C               ******************************
C
C
C               ********************************
C               **  TREAT THE DIMENSION CASE  **
C               ********************************
C
C               **********************************
C               **  TREAT THE ERASE DELAY CASE  **
C               **********************************
C
      DEFERD=1.0
      ERASDE=DEFERD
      AGERDE=ERASDE
C
C               **************************************
C               **  TREAT THE HARDCOPY DELAY CASE   **
C               **************************************
C
      DEFHAD=1.0
      HARDDE=DEFERD
      AGCODE=HARDDE
C
C               *****************************
C               **  TREAT THE DELETE CASE  **
C               *****************************
C
C
C               ***************************************
C               **  TREAT THE DOUBLE PRECISION CASE  **
C               ***************************************
C
C
C               ***************************
C               **  TREAT THE ECHO CASE  **
C               ***************************
C
      IECHO='OFF'
C
C               ****************************
C               **  TRE***** AT THE END   CASE  **
C               **  TREAT THE EXIT  CASE  **
C               **  TREAT THE HALT  CASE  **
C               **  TREAT THE STOP  CASE  **
C               ****************************
C
C
C               *******************************
C               **  TREAT THE ERASE CASE     **
C               **  TREAT THE PAGE CASE      **
C               **  TREAT THE NEW PAGE CASE  **
C               *******************************
C
C
C               *********************************************
C               **  TREAT THE DEMODULATION FREQUENCY CASE  **
C               *********************************************
C
      DEFDMF=-1.0
      DEMOFR=DEFDMF
C
C               ****************************
C               **  TREAT THE GRADS CASE  **
C               ****************************
C
C
C               ***************************
C               **  TREAT THE HELP CASE  **
C               ***************************
C
C
C               ***************************
C               **  TREAT THE HOST CASE  **
C               ***************************
C
      DO300I=1,10
      IDEFHO(I)='    '
  300 CONTINUE
C     NOTE--THE SPECIFICATION OF THE HOST
C           HAS BEEN MOVED TO THE MAIN ROUTINE.
C           SEARCH FOR    IHOST1=      AND IHOST2=
C           IN THE MAIN ROUTINE AND CHANGE IT TO YOUR HOST.
CCCCC IDEFHO(1)='VAX '
CCCCC IDEFHO(2)='11/7'
CCCCC IDEFHO(3)='80  '
CCCCC IDEFHO(4)='VMS '
CCCCC IDEFHO(5)='    '
C
      DO500I=1,10
      IHOST(I)=IDEFHO(I)
  500 CONTINUE
C
C               **************************************
C               **  TREAT THE FIT CONSTRAINTS CASE  **
C               **************************************
C
C               *********************************************
C               **  TREAT THE FIT STANDARD DEVIATION CASE  **
C               *********************************************
C
CCCCC CHANGE DEFAULT TO MATCH DPFIT2.  FEBRUARY 1994.
CCCCC DEFFSD=0.000005
      DEFFSD=0.0000001
      FITSD=DEFFSD
C
C               *************************************
C               **  TREAT THE FIT ITERATIONS CASE  **
C               *************************************
C
      IDEFNI=50
      IFITIT=IDEFNI
C
C               ********************************
C               **  TREAT THE FIT POWER CASE  **
C               ********************************
C
      DEFFPW=2.0
      FITPOW=DEFFPW
C
CCCCC THE FOLLOWING SECTION WAS ADDED       JULY 1995
C               **********************************************
C               **  TREAT THE FIT ADDITIVE CONSTANT CASE    **
C               **********************************************
C
      IFITAC='ON'
C
C
C               ****************************
C               **  TREAT THE KNOTS CASE  **
C               ****************************
C
      IKNOTS='OFF'
      IDEFK1='    '
      IDEFK2='    '
      IKNOT1=IDEFK1
      IKNOT2=IDEFK2
C
C               *******************************
C               **  TREAT THE MESSAGE  CASE  **
C               **  TREAT THE CONSOLE  CASE  **
C               **  TREAT THE OPERAT0R CASE  **
C               *******************************
C
C
C               ****************************
C               **  TREAT THE MACRO CASE  **
C               ****************************
C
C
C               ***************************
C               **  TREAT THE NAME CASE  **
C               ***************************
C
C
C               ****************************************
C               **  TREAT THE POLYNOMIAL DEGREE CASE  **
C               ****************************************
C
      IDEFDG=1
      IDEG=IDEFDG
C
C               ********************************
C               **  TREAT THE PRECISION CASE  **
C               ********************************
C
      IDEFPR='SING'
      IHMXPR='SING'
      IPREC=IDEFPR
C
C               ********************************
C               **  TREAT THE PRE-ERASE CASE  **
C               ********************************
C
      IPREER='ON'
C
C               *******************************
C               **  TREAT THE PRINTING CASE  **
C               *******************************
C
      IPRINT='ON'
      IPRIN2=IPRINT
C
C               ******************************************
C               **  TREAT THE QUADRUPLE PRECISION CASE  **
C               ******************************************
C
C
C               ******************************
C               **  TREAT THE RADIANS CASE  **
C               ******************************
C
C
C               ***************************
C               **  TREAT THE READ CASE  **
C               ***************************
C
C
C               ****************************
C               **  TREAT THE RESET CASE  **
C               ****************************
C
C
C               ******************************
C               **  TREAT THE RESTORE CASE  **
C               ******************************
C
C
C               *****************************
C               **  TREAT THE RETAIN CASE  **
C               **  TREAT THE PACK   CASE  **
C               *****************************
C
C               ********************************
C               **  TREAT THE RING BELL CASE  **
C               ********************************
C
C
C               *********************************
C               **  TREAT THE ROW LIMITS CASE  **
C               *********************************
C
      IDEFR1=1
      IDEFR2=I1MACH(9)
      IFROW1=IDEFR1
      IFROW2=IDEFR2
C
C               ***************************
C               **  TREAT THE SAVE CASE  **
C               ***************************
C
C
C               ******************************************
C               **  TREAT THE SEPARATOR CHARACTOR CASE  **
C               ******************************************
C
      IDEFTC=';'
      ITERCH=IDEFTC
C
C               ******************************************
C               **  TREAT THE CONTINUE  CHARACTER CASE  **
C               ******************************************
C
      IDEFCC='... '
      ICONCH=IDEFCC
C
C               ******************************************
C               **  TREAT THE COMMENT   CHARACTER CASE  **
C               ******************************************
C
      IDEFCZ='.   '
      ICOMCH=IDEFCZ
CCCCC THE FOLLOWING LINE WAS CHANGED OCTOBER 1992
CCCCC ICOMFL='OFF '
      ICOMSW='OFF '
CCCCC FOLLOWING BLOCK OF CODE ADDED AUGUST 1992.
C
C               ******************************************
C               **  TREAT THE VECTOR FORMAT       CASE  **
C               **  TREAT THE VECTOR ARROW        CASE  **
C               ******************************************
C
      IDEFVF='ANGL'
      IVCFMT=IDEFVF
      IDEFVA='FIXE'
      IVCARR=IDEFVA
      IDEFVO='CLOS'
      IVCOPN=IDEFVO
C
CCCCC FOLLOWING BLOCK OF CODE ADDED NOVEMBER 1992.
C
C               ******************************************
C               **  TREAT THE ANDREW INCREMENT    CASE  **
C               ******************************************
C
      DEFAIN=0.1
      ANDINC=DEFAIN
C
CCCCC FOLLOWING BLOCK OF CODE ADDED JULY 1993
C               ******************************************
C               **  TREAT THE FRACTAL ITERATIONS  CASE  **
C               **  TREAT THE FRACTAL TYPE        CASE  **
C               ******************************************
C
      IDEFFT='BARN'
      IFRATY=IDEFVF
      IDEFFI=MAXPOP
      IFRAIT=IDEFFI
C
CCCCC FOLLOWING BLOCK OF CODE ADDED JULY 1993
C               ***********************************************
C               **  TREAT THE PRINCIPLE COMPONENTS TYPE CASE **
C               ***********************************************
C
      IDEFPT='DACR'
      IPCMTY=IDEFPT
C
C               **********************************
C               **  TREAT THE SERIAL READ CASE  **
C               **********************************
C
C
C               ***************************************
C               **  TREAT THE SINGLE PRECISION CASE  **
C               ***************************************
C
C
C               ***************************
C               **  TREAT THE SKIP CASE  **
C               ***************************
C
      IDEFSK=0
      ISKIP=IDEFSK
C
C               *****************************
C               **  TREAT THE STATUS CASE  **
C               *****************************
C
C
C               **************************************
C               **  TREAT THE SUBSET MESSAGES CASE  **
C               **************************************
C
      ISUBMS='ON'
C
C               ****************************
C               **  TREAT THE TIME  CASE  **
C               **  TREAT THE CLOCK CASE  **
C               ****************************
C
      DO700I=1,10
      ICLOCK(I)=0
  700 CONTINUE
C
C               ***************************************
C               **  TREAT THE TRIPLE PRECISION CASE  **
C               ***************************************
C
C
C               ******************************
C               **  TREAT THE WEIGHTS CASE  **
C               ******************************
C
      IWEIGH='OFF'
      IDEFW1='    '
      IDEFW2='    '
      IWEIG1=IDEFW1
      IWEIG2=IDEFW2
C
C               ****************************
C               **  TREAT THE WRITE CASE  **
C               **  TREAT THE PRINT CASE  **
C               ****************************
C
C
C               ************************
C               **  TREAT THE . CASE  **
C               ************************
C
C               ***********************************
C               **  TREAT THE FILTER WIDTH CASE  **
C               ***********************************
C
      DEFFW=3.0
      FILWID=DEFFW
C
C               *******************************
C               **  TREAT THE FEEDBACK CASE  **
C               *******************************
C
      IFEEDB='ON'
      IFEED2=IFEEDB
C
C               ************************************
C               **  TREAT THE ROOT ACCURACY CASE  **
C               ************************************
C
      DEFRAC=0.000001
      ROOTAC=DEFRAC
C
C               *********************************************
C               **  TREAT THE OPTIMIZATION TOLERANCE CASE  **
C               *********************************************
C
      DEFOAC=0.00001
      OPTACC=DEFOAC
C
C               *********************************************
C               **  TREAT THE OPTIMIZATION METHOD    CASE  **
C               *********************************************
C
      IDEFOM='LINE'
      IOPTME=IDEFOM
      IDEFHS='FINI'
      IOPTHE=IDEFHS
C
CCCCC THE FOLLOWING SECTION WAS ADDED    MAY 1993
CCCCC AUGUST 2004: SET DEFAULT TO 1 (THIS IS THE MORE COMMON
CCCCC              CASE FOR THE WEIBULL DISTRIBUTION)
C
C               ***************************************
C               **  TREAT THE EV1/EV2/WEIBULL        **
C               **  DISTRIBUTION SPECIFICATION CASE  **
C               ***************************************
C
      MINMAX=0
CCCCC MINMAX=1
C
CCCCC THE FOLLOWING SECTION WAS ADDED    APRIL 1997
C
C               ***************************************
C               **  TREAT THE SET NETSCAPE <OLD/NEW> **
C               **  CASE                             **
C               ***************************************
C
      INETSW='NEW'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    APRIL 1997
C
C               ***************************************
C               **  TREAT THE SET CONTROL CHART      **
C               **  <DATA/PRIOR> CASE                **
C               ***************************************
C
      ICCHPR='DATA'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    APRIL 1997
C
C               *******************************************
C               **  TREAT THE SET CONTROL CHART WEIGHTING *
C               **  <CENTER/RIGHT> CASE                  **
C               *******************************************
C
      ICCHWT='RIGH'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    AUGUST 1997
C
C               *************************************************
C               **  TREAT THE RECIPE SATTERWAITE APPROXIMATION **
C               **  <ON/OFF> CASE                              **
C               *************************************************
C
      IDEFSA='ON'
      IRECSA=IDEFSA
C
CCCCC THE FOLLOWING SECTION WAS ADDED    AUGUST 1997
C
C               *************************************************
C               **  TREAT THE RECIPE OUTPUT                    **
C               **  <ON/OFF> CASE                              **
C               *************************************************
C
      IDEFTN='TOL'
      IRECTN=IDEFTN
C
CCCCC THE FOLLOWING SECTION WAS ADDED    AUGUST 1997
C
C               *************************************************
C               **  TREAT THE RECIPE PROBABILITY CONTENT <VAL> **
C               *************************************************
C
      DEFRPC=0.90
      RECIPC=DEFRPC
C
CCCCC THE FOLLOWING SECTION WAS ADDED    AUGUST 1997
C
C               *************************************************
C               **  TREAT THE RECIPE CONFIDENCE          <VAL> **
C               *************************************************
C
      DEFRCO=0.95
      RECICO=DEFRCO
C
CCCCC THE FOLLOWING SECTION WAS ADDED    AUGUST 1997
C
C               *************************************************
C               **  TREAT THE RECIPE DEGREE              <VAL> **
C               *************************************************
C
      DEFRDG=1.0
      RECIDG=DEFRDG
C
CCCCC THE FOLLOWING SECTION WAS ADDED    AUGUST 1997
C
C               *************************************************
C               **  TREAT THE RECIPE FACTORS             <VAL> **
C               *************************************************
C
      DEFRFA=0.
      RECIFA=DEFRFA
C
CCCCC THE FOLLOWING SECTION WAS ADDED    APRIL 1998
C
C               *************************************************
C               **  TREAT THE RECIPE FACTORS             <VAL> **
C               *************************************************
C
      DEFRFF=0.
      RECIFF=DEFRFF
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1997
C
C               *************************************************
C               **  TREAT THE RECIPE SIMCOV REPLICATES   <VAL> **
C               *************************************************
C
      IDEFR7=10000
      IRECR1=IDEFR7
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1997
C
C               *************************************************
C               **  TREAT THE RECIPE SIMPVT REPLICATES   <VAL> **
C               *************************************************
C
      IDEFR8=10000
      IRECR2=IDEFR8
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1997
C
C               *************************************************
C               **  TREAT THE RECIPE CORRELATIONS        <VAL> **
C               *************************************************
C
      IDEFR9=11
      IRECC1=IDEFR9
C
CCCCC THE FOLLOWING SECTION WAS ADDED    MAY 1998
C
C               *******************************************
C               **  TREAT THE SET KAPLAN-MEIER           **
C               **  <RELI/CDF >    CASE                  **
C               *******************************************
C
      IKAPSW='RELI'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    MAY 1998
C
C               *******************************************
C               **  TREAT THE SET CENSORING TYPE         **
C               **  <1/2 >    CASE                       **
C               *******************************************
C
      ICENTY='NONE'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JUNE 1998
C
C               *******************************************
C               **  TREAT THE SET MATRIX SCALE           **
C               **  <NONE/SD/RANGE/Z-SCORE>  CASE        **
C               *******************************************
C
      IMATSC='NONE'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1998
C
C               *******************************************
C               **  TREAT THE SET PERCENT POINT PLOT     **
C               **  <BINNED/UNBINNED/INTERPOLATED> CASE  **
C               *******************************************
C
      IPPTBI='BINN'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1998
C
C               *******************************************
C               **  TREAT THE SET QUANTILE-QUANTILE PLOT **
C               **  <BINNED/UNBINNED/INTERPOLATED> CASE  **
C               *******************************************
C
      IQQPBI='BINN'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    MARCH 1999
C
C               *******************************************
C               **  TREAT THE SET HANDBOOK URL           **
C               *******************************************
C
      NCHURL=40
      IHBURL(1:40)='http://www.itl.nist.gov/div898/handbook/'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JULY 1999
C
C               *******************************************
C               **  TREAT THE SET AUTOCORRELATION BAND   **
C               **  <WHITE NOISE/BOX-JENKINS>      CASE  **
C               *******************************************
C
      IAUTCP='WHIT'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    FEBRUARY 2003
C
C               *******************************************
C               **  TREAT THE SET AUTOCORRELATION LAG    **
C               **  ZERO <ON/OFF>                  CASE  **
C               *******************************************
C
      IAUTL0='ON'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    MARCH 2003
C
C               *******************************************
C               **  TREAT THE SET PARALLEL COORDINATES   **
C               **  STANDARDIZE <NONE/USCORE/ZSCORE> CASE**
C               *******************************************
C
      IPCCST='USCO'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    MARCH 2003
C
C               *******************************************
C               **  TREAT THE SET BOOTSTRAP GROUPS       **
C               **  <INDEPENDENT/DEPENDENT>   CASE       **
C               *******************************************
C
      IBOOGR='INDE'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    MAY 2003
C
C               *******************************************
C               **  TREAT THE SET MULTIVARIATE NORMAL    **
C               **  <SADMVN/RANMVN/KROMVN/SPHMVN>  CASE  **
C               *******************************************
C
      IMVNTY='SADM'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    MARCH 2002
C
C               *******************************************
C               **  TREAT THE SET BOX PLOT WIDTH         **
C               **  <VARIABLE/FIXED>               CASE  **
C               *******************************************
C
      IBXPWI='VARI'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    MARCH 2002
C
C               *******************************************
C               **  TREAT THE SET 4-PLOT MULTIPLOT       **
C               **  <ON/OFF>                       CASE  **
C               *******************************************
C
      I4PLMC='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    MARCH 2002
C
C               *******************************************
C               **  TREAT THE SET 6-PLOT MULTIPLOT       **
C               **  <ON/OFF>                       CASE  **
C               *******************************************
C
      I6PLMC='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    MAY 2002
C
C               *******************************************
C               **  TREAT THE SET RANDOM NUMBER GENERATOR**
C               **  <DATAPLOT/BLUE/RUNIF>          CASE  **
C               *******************************************
C
      IRANAL='FIBO'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JANUARY 2000
C
C               **************************************************
C               **  TREAT THE SET CROSS TABULATE PLOT DIMENSION **
C               **  <1/2>                          CASE         **
C               **************************************************
C
      ICTBDI='1'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    NOVEMBER 1999
C
C               *******************************************
C               **  TREAT THE SET PARAMETER EXPANSION    **
C               **  <NUMERIC/EXPONENTIAL>          CASE  **
C               *******************************************
C
      IEXPPA='NUME'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JANUARY 2000
C
C               *******************************************
C               **  TREAT THE SET SORT DIRECTION         **
C               **  <ASCENDING/DESCENDING>         CASE  **
C               *******************************************
C
      ISORDI='ASCE'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    FEBRUARY 2000
C
C               ************************************************
C               **  TREAT THE SET DEX CONTOUR PLOT DIRECTION  **
C               **  <MINIMUMUN/MAXIMUM>             CASE      **
C               ************************************************
C
      IDCPDI='MAXI'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    OCTOBER 2000
C
C               ****************************************************
C               **  TREAT THE SET MANDEL PAULE <MODIFIED/REGULAR> **
C               ****************************************************
C
      IMANPA='REGU'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    MARCH 2001
C
C               ****************************************************
C               **  TREAT THE SET LOCATION STATISTIC <MEAN/MEDIAN/**
C               **        MIDMEAN/TRIMMED MEAN>                   **
C               ****************************************************
C
      ISTALO='MEAN'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    MARCH 2001
C
C               ****************************************************
C               **  TREAT THE SET SCALE    STATISTIC <SD/AAD/MAD> **
C               ****************************************************
C
      ISTASC='SD  '
C
CCCCC THE FOLLOWING SECTION WAS ADDED    MARCH 2001
C
C               ****************************************************
C               **  TREAT THE SET SUPERSCRIPT HORI SCALE <SIZE>   **
C               ****************************************************
C
      PSUPXS=0.5
C
CCCCC THE FOLLOWING SECTION WAS ADDED    MARCH 2001
C
C               ****************************************************
C               **  TREAT THE SET SUPERSCRIPT VERT SCALE <SIZE>   **
C               ****************************************************
C
      PSUPYS=0.5
C
CCCCC THE FOLLOWING SECTION WAS ADDED    APRIL 2001
C
C               ****************************************************
C               **  TREAT THE SET ORTHOGONAL DISTANCE TRUST       **
C               **        REGION RADIUS  <VAL>                    **
C               ****************************************************
C
      PODRTF=-1.0
C
CCCCC THE FOLLOWING SECTION WAS ADDED    APRIL 2001
C
C               ****************************************************
C               **  TREAT THE SET ORTHOGONAL DISTANCE STOP        **
C               **        TOLERANCE  <VAL>                        **
C               ****************************************************
C
      PODRST=-1.0
C
CCCCC THE FOLLOWING SECTION WAS ADDED    APRIL 2001
C
C               ****************************************************
C               **  TREAT THE SET ORTHOGONAL DISTANCE             **
C               **        PARAMETER TOLERANCE  <VAL>              **
C               ****************************************************
C
      PODRPT=-1.0
C
CCCCC THE FOLLOWING SECTION WAS ADDED    APRIL 2001
C
C               ****************************************************
C               **  TREAT THE SET ORTHOGONAL DISTANCE             **
C               **        PRINT OPTION <DEFAULT/FULL>             **
C               ****************************************************
C
      IODRPO='DEFA'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    APRIL 2001
C
C               ****************************************************
C               **  TREAT THE ORTHOGONAL DISTANCE DELTA VARIABLES **
C               ****************************************************
C
      DO7993I=1,20
        IODRD1(I)='OFF '
        IODRD2(I)='    '
        IODRD3(I)='OFF '
        IODRD4(I)='    '
        IODRE1(I)='ON  '
        IODRE2(I)='    '
        IWEIN1(I)='OFF '
        IWEIN2(I)='    '
 7993 CONTINUE
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JULY 2001
C
C               ****************************************************
C               **  TREAT THE KERNEL DENSITY OPTIONS:             **
C               **        KERNEL DENSITY WINDOW  <VALUE>          **
C               **        KERNEL DENSITY POINTS  <VALUE>          **
C               **        KERNEL DENSITY TYPE    <FUNC>           **
C               ****************************************************
C
      IDEFKF='GAUS'
      IKDETY=IDEFKF
      IDEFKN=256
      IKDENP=IDEFKN
      DEFKWI=CPUMIN
      PKDEWI=DEFKWI
C
CCCCC THE FOLLOWING SECTION WAS ADDED    FEBRUARY 2000
C
C               ************************************************
C               **  TREAT THE SET DEX CONTOUR PLOT MODEL      **
C               **  <LINEAR/QUADRATIC>              CASE      **
C               ************************************************
C
      IDCPFI='LINE'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JUNE 2002
C
C               ************************************************
C               **  TREAT THE ICAPTY SWITCH                   **
C               ************************************************
C
      ICAPTY='TEXT'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1999
C
C               ***********************************************
C               **  TREAT THE SET SCATTER PLOT MATRIX LABELS **
C               **  <ON/OFF>                           CASE  **
C               ***********************************************
C
      ISPMLA='ON'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1999
C
C               ***********************************************
C               **  TREAT THE SET SCATTER PLOT MATRIX DIAGONAL*
C               **  <ON/OFF>                           CASE  **
C               ***********************************************
C
      ISPMDI='BLAN'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1999
C
C               ***********************************************
C               **  TREAT THE SET SCATTER PLOT MATRIX FIT    **
C               **  <NONE/LOWESS/LINEAR/QUADRATIC>     CASE  **
C               ***********************************************
C
      ISPMFI='NONE'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1999
C
C               *******************************************************
C               **  TREAT THE SET SCATTER PLOT MATRIX LOWER DIAGONAL **
C               **  <ON/OFF>                           CASE          **
C               *******************************************************
C
      ISPMLD='ON'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1999
C
C               *******************************************************
C               **  TREAT THE SET SCATTER PLOT MATRIX TAG            **
C               **  <ON/OFF>                           CASE          **
C               *******************************************************
C
      ISPMTA='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1999
C
C               *******************************************************
C               **  TREAT THE SET SCATTER PLOT MATRIX PLOT TYPE      **
C               **  <PLOT/QQPLOT/BIHIST>               CASE          **
C               *******************************************************
C
      ISPMPT='PLOT'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1999
C
C               *******************************************************
C               **  TREAT THE SET SCATTER PLOT MATRIX FRAME          **
C               **  <DEFAULT/USER>                     CASE          **
C               *******************************************************
C
      ISPMFR='DEFA'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1999
C
C               *******************************************************
C               **  TREAT THE SET SCATTER PLOT MATRIX X AXIS         **
C               **  <LEFT/RIGHT/ALTERNATE>             CASE          **
C               *******************************************************
C
      ISPMXA='ALTE'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1999
C
C               *******************************************************
C               **  TREAT THE SET SCATTER PLOT MATRIX Y AXIS         **
C               **  <LEFT/RIGHT/ALTERNATE>             CASE          **
C               *******************************************************
C
      ISPMYA='ALTE'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1999
C
C               *******************************************************
C               **  TREAT THE SET SCATTER PLOT MATRIX STATISTIC TYPE **
C               **  <XXXX>                             CASE          **
C               *******************************************************
C
      ISPMST='MEAN'
      ISPMS2='    '
      ISPMS3='    '
      ISPMS4='    '
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1999
C
C               *******************************************************
C               **  TREAT THE SET SCATTER PLOT MATRIX LIMITS         **
C               **  <XXXX>                             CASE          **
C               *******************************************************
C
      DO8001I=1,25
        PSPLLL(I)=CPUMIN
        PSPLUL(I)=CPUMIN
        PSPLSL(I)=CPUMIN
        PSPLSU(I)=CPUMIN
 8001 CONTINUE
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1999
C
C               *******************************************************
C               **  TREAT THE SET MATRIX PLOT  TIC LABEL DISPLACEMENT**
C               **  <XXXX>                             CASE          **
C               *******************************************************
C
      PSPMTD=CPUMIN
      ISPMTD='NORM'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1999
C
C               ***********************************************
C               **  TREAT THE SET SCATTER PLOT MATRIX CORRELAT*
C               **  <ON/OFF>                           CASE  **
C               ***********************************************
C
      ISPMCC='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1999
C
C               ***********************************************
C               **  TREAT THE SET SCATTER PLOT MATRIX X2LABEL*
C               **  <CORR/....>                        CASE  **
C               ***********************************************
C
      ISPX2L='OFF'
      ISPX2P='DEFAULT'
      ISPX2S='DEFAULT'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1999
C
C               *******************************************************
C               **  TREAT THE SET CONDITIONING PLOT LABEL            **
C               **  <ON/OFF>                           CASE          **
C               *******************************************************
C
      ICPLLA='ON'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1999
C
C               *******************************************************
C               **  TREAT THE SET CONDITIONING PLOT TAG              **
C               **  <ON/OFF>                           CASE          **
C               *******************************************************
C
      ICPLTA='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1999
C
C               *******************************************************
C               **  TREAT THE SET CONDITIONING PLOT PLOT TYPE        **
C               **  <PLOT/HIST/PERC/RUNS/BOXN>         CASE          **
C               *******************************************************
C
      ICPLPT='PLOT'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1999
C
C               *******************************************************
C               **  TREAT THE SET CONDITIONING PLOT FIT              **
C               **  <NONE/LOWESS/LINEAR/SMOOTH>        CASE          **
C               *******************************************************
C
      ICPLFI='NONE'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1999
C
C               *******************************************************
C               **  TREAT THE SET CONDITIONING PLOT FRAME            **
C               **  <DEFAULT/USER>                     CASE          **
C               *******************************************************
C
      ICPLFR='DEFA'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1999
C
C               *******************************************************
C               **  TREAT THE SET CONDITIONING PLOT MATRIX X AXIS    **
C               **  <LEFT/RIGHT/ALTERNATE>             CASE          **
C               *******************************************************
C
      ICPLXA='ALTE'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1999
C
C               *******************************************************
C               **  TREAT THE SET CONDITIONING  PLOT MATRIX Y AXIS   **
C               **  <LEFT/RIGHT/ALTERNATE>             CASE          **
C               *******************************************************
C
      ICPLYA='ALTE'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1999
C
C               *******************************************************
C               **  TREAT THE SET CONDITIONING PLOT PRE-SORT         **
C               **  <ON/OFF>                           CASE          **
C               *******************************************************
C
CCCCC THIS OPTION WAS REMOVED.
CCCCC ICPLPS='ON'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1999
C
C               *******************************************************
C               **  TREAT THE SET CONDITIONING PLOT  STATISTIC TYPE  **
C               **  <XXXX>                             CASE          **
C               *******************************************************
C
      ICPLST='MEAN'
      ICPLS2='    '
      ICPLS3='    '
      ICPLS4='    '
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1999
C
C               *******************************************************
C               **  TREAT THE SET CONDITION    PLOT  NAME OF         **
C               **  PROBABILITY PLOT                   CASE          **
C               *******************************************************
C
      ICPLP1='    '
      ICPLP2='    '
      ICPLP3='    '
      ICPLP4='    '
      ICPLP5='    '
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1999
C
C               *******************************************************
C               **  TREAT THE SET CONDITION    PLOT  NAME OF         **
C               **  PPCC        PLOT                   CASE          **
C               *******************************************************
C
      ICPLC1='    '
      IcPLC2='    '
      ICPLC3='    '
      ICPLC4='    '
      ICPLC5='    '
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1999
C
C               *******************************************************
C               **  TREAT THE SET CONDITION PLOT CORRELATION         **
C               **  <ON/OFF>                           CASE          **
C               *******************************************************
C
      ICPLCC='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1999
C
C               ***********************************************
C               **  TREAT THE SET CONDITION PLOT X2LABEL     **
C               **  <CORR/....>                        CASE  **
C               ***********************************************
C
      ICPX2L='OFF'
C
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1999
C
C               *******************************************************
C               **  TREAT THE SET CONDITION PLOT  RESPONSE VARIABLES **
C               **  <XXXX>                             CASE          **
C               *******************************************************
C
      PCPLRV=1.0
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1999
C
C               *******************************************************
C               **  TREAT THE SET CONDIT PLOT  TIC LABEL DISPLACEMENT**
C               **  <XXXX>                             CASE          **
C               *******************************************************
C
      PCPLTD=CPUMIN
      ICPLTD='NORM'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1999
C
C               *******************************************************
C               **  TREAT THE SET CONDITION PLOT  TAG      VARIABLES **
C               **  <XXXX>                             CASE          **
C               *******************************************************
C
      PCPLTV=1.0
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1999
C
C               *******************************************************
C               **  TREAT THE SET CONDITION PLOT  LIMITS             **
C               **  <XXXX>                             CASE          **
C               *******************************************************
C
      DO8013I=1,25
        PCPXLL(I)=CPUMIN
        PCPXUL(I)=CPUMIN
        PCPYLL(I)=CPUMIN
        PCPYUL(I)=CPUMIN
 8013 CONTINUE
C
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1999
C
C               *******************************************************
C               **  TREAT THE SET FACTOR       PLOT LABEL            **
C               **  <ON/OFF>                           CASE          **
C               *******************************************************
C
      IFPLLA='ON'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1999
C
C               *******************************************************
C               **  TREAT THE SET FACTOR  PLOT CORRELATION           **
C               **  <ON/OFF>                           CASE          **
C               *******************************************************
C
      IFPLCC='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1999
C
C               *******************************************************
C               **  TREAT THE SET FACTOR       PLOT TAG              **
C               **  <ON/OFF>                           CASE          **
C               *******************************************************
C
      IFPLTA='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1999
C
C               *******************************************************
C               **  TREAT THE SET FACTOR       PLOT PLOT TYPE        **
C               **  <PLOT/HIST/PERC/RUNS/BOXN>         CASE          **
C               *******************************************************
C
      IFPLPT='PLOT'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1999
C
C               *******************************************************
C               **  TREAT THE SET FACTOR       PLOT FIT              **
C               **  <NONE/LOWESS/LINEAR/SMOOTH>        CASE          **
C               *******************************************************
C
      IFPLFI='NONE'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1999
C
C               *******************************************************
C               **  TREAT THE SET FACTOR       PLOT FRAME            **
C               **  <DEFAULT/USER>                     CASE          **
C               *******************************************************
C
      IFPLFR='USER'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1999
C
C               *******************************************************
C               **  TREAT THE SET FACTOR  PLOT MATRIX X AXIS         **
C               **  <LEFT/RIGHT/ALTERNATE>             CASE          **
C               *******************************************************
C
      IFPLXA='ALTE'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1999
C
C               *******************************************************
C               **  TREAT THE SET FACTOR  PLOT MATRIX Y AXIS         **
C               **  <LEFT/RIGHT/ALTERNATE>             CASE          **
C               *******************************************************
C
      IFPLYA='ALTE'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1999
C
C               *******************************************************
C               **  TREAT THE SET FACTOR       PLOT PRE-SORT         **
C               **  <ON/OFF>                           CASE          **
C               *******************************************************
C
CCCCC THIS OPTION WAS REMOVED.
CCCCC IFPLPS='ON'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1999
C
C               *******************************************************
C               **  TREAT THE SET FACTOR       PLOT  STATISTIC TYPE  **
C               **  <XXXX>                             CASE          **
C               *******************************************************
C
      IFPLST='MEAN'
      IFPLS2='    '
      IFPLS3='    '
      IFPLS4='    '
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1999
C
C               *******************************************************
C               **  TREAT THE SET FACTOR    PLOT  RESPONSE VARIABLES **
C               **  <XXXX>                             CASE          **
C               *******************************************************
C
      PFPLRV=1.0
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1999
C
C               *******************************************************
C               **  TREAT THE SET FACTOR PLOT  TIC LABEL DISPLACEMENT**
C               **  <XXXX>                             CASE          **
C               *******************************************************
C
      PFPLTD=CPUMIN
      IFPLTD='NORM'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1999
C
C               *******************************************************
C               **  TREAT THE SET FACTOR    PLOT  LIMITS             **
C               **  <XXXX>                             CASE          **
C               *******************************************************
C
      DO8003I=1,25
        PFPXLL(I)=CPUMIN
        PFPXUL(I)=CPUMIN
        PFPYLL(I)=CPUMIN
        PFPYUL(I)=CPUMIN
 8003 CONTINUE
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1999
C
C               *******************************************************
C               **  TREAT THE SET FACTOR       PLOT  CORRELATION     **
C               **  <ON/OFF>                           CASE          **
C               *******************************************************
C
      IFPLCC='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1999
C
C               ***********************************************
C               **  TREAT THE SET FACTOR    PLOT X2LABEL     **
C               **  <CORR/....>                        CASE  **
C               ***********************************************
C
      IFPX2L='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1999
C
C               *******************************************************
C               **  TREAT THE SET FACTOR       PLOT  NAME OF         **
C               **  PROBABILITY PLOT                   CASE          **
C               *******************************************************
C
      IFPLP1='    '
      IFPLP2='    '
      IFPLP3='    '
      IFPLP4='    '
      IFPLP5='    '
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1999
C
C               *******************************************************
C               **  TREAT THE SET FACTOR       PLOT  NAME OF         **
C               **  PPCC        PLOT                   CASE          **
C               *******************************************************
C
      IFPLC1='    '
      IFPLC2='    '
      IFPLC3='    '
      IFPLC4='    '
      IFPLC5='    '
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JUNE 2002
C
C               ***********************************************
C               **  TREAT THE SET NUMBER OF CP <VALUE>  CASE **
C               ***********************************************
C
      INUMCP=10
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JUNE 2002
C
C               ***********************************************
C               **  TREAT THE SET CAPTURE LINES <VALUE> CASE **
C               ***********************************************
C
      DO8110I=1,MAXCLI
      ICAPLI(1)=25
 8110 CONTINUE
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JUNE 2002
C
C               ***********************************************
C               **  TREAT THE SET CAPTURE BOX <ON/OFF>  CASE **
C               ***********************************************
C
      ICAPBX='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JUNE 2002
C
C               **************************************************
C               **  TREAT THE SET CAPTURE NUMBER <ON/OFF>  CASE **
C               **************************************************
C
      ICAPNM='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JULY 2002
C
C               **************************************************
C               **  TREAT THE SET QUANTILE METHOD <ORDER/HD> CASE*
C               **************************************************
C
      IQUAME='ORDE'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JULY 2002
C
C               **************************************************
C               **  TREAT THE SET QUANTILE STANDARD ERROR METHOD *
C               **  <MJ/KDEN>                                    *
C               **************************************************
C
      IQUASE='MJ'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JULY 2002
C
C               **************************************************
C               **  TREAT THE SET COVARIANCE TYPE                *
C               **  <DEFAULT/BIWEIGHT/WINSORIZED/RANK/           *
C               **  PERCENTAGE BEND>                             *
C               **************************************************
C
      ICOVTY='DEFAU'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JULY 2002
C
C               **************************************************
C               **  TREAT THE SET CORRELATION TYPE               *
C               **  <DEFAULT/WINSORIZED/RANK>                    *
C               **************************************************
C
      ICORTY='DEFA'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JULY 2002
C
C               **************************************************
C               **  TREAT THE SET FILE NAME QUOTE                *
C               **  <ON/OFF>                                     *
C               **************************************************
C
      IFILQU='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JULY 2002
C
C               **************************************************
C               **  TREAT THE SET BOOTSTRAP FIT METHOD           *
C               **  <RESIDUALS/DATA>                             *
C               **************************************************
C
      IBOOME='RESI'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    NOVEMBER 2002
C
C               **************************************************
C               **  TREAT THE SET QWIN SYSTEM <SYSTEMQQ/WINEXEC> *
C               **************************************************
C
      IQWNSY='SYST'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    NOVEMBER 2002
C
C               **************************************************
C               **  TREAT THE SET GHOSTVIEW PRINTER <ON/OFF>     *
C               **************************************************
C
      IPRNGS='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JANUARY 2003
C
C               **************************************************
C               **  TREAT THE SET POSTSCRIPT BOUNDING BOX        *
C               **  <FIXED/FLOAT>                                *
C               **************************************************
C
      IPSTBB='FLOA'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JANUARY 2003
C
C               **************************************************
C               **  TREAT THE SET POSTSCRIPT CONVERT             *
C               **  <JPEG/PDF/TIFF/PBM/PNG/PNM/PPM>              *
C               **************************************************
C
      IPSTDV='NULL'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    NOVEMBER 2002
C
C               **************************************************
C               **  TREAT THE SET GHOSTVIEW PATH  <PATH>         *
C               **************************************************
C  FOR UNIX, "\" IS ESCAPE CHARACTER, SO DON'T INSERT THIS CHARACTER
C  DIRECTLY (CAN GET COMPILE ERRORS).
C
      CALL DPCONA(92,IBASLC)
      NCGSPA=19
      IGSVPA='C: GHOSTGUM GSVIEW '
      IGSVPA(3:3)=IBASLC
      IGSVPA(12:12)=IBASLC
      IGSVPA(19:19)=IBASLC
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JANUARY 2003
C
C               **************************************************
C               **  TREAT THE SET GHOSTSCRIPT PATH  <PATH>       *
C               **************************************************
C
C  FOR UNIX, "\" IS ESCAPE CHARACTER, SO DON'T INSERT THIS CHARACTER
C  DIRECTLY (CAN GET COMPILE ERRORS).
C
      CALL DPCONA(92,IBASLC)
      IF(IHOST1.EQ.'IBM-')THEN
        NCGHPA=17
        IGSTPA='C: GS GS7.04 BIN '
        IGSTPA(3:3)=IBASLC
        IGSTPA(6:6)=IBASLC
        IGSTPA(13:13)=IBASLC
        IGSTPA(17:17)=IBASLC
      ELSE
        IGSTPA=' '
        NCGHPA=0
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JANUARY 2003
C
C               **************************************************
C               **  TREAT THE SET HTML HEADER FILE <FILE>        *
C               **************************************************
C
      IHTMHE='NULL'
      NCHTMH=-1
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JANUARY 2003
C
C               **************************************************
C               **  TREAT THE SET HTML FOOTER FILE <FILE>        *
C               **************************************************
C
      IHTMFO='NULL'
      NCHTMF=-1
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 2003
C
C               **************************************************
C               **  TREAT THE SET LATEX HEADER FILE <FILE>       *
C               **************************************************
C
      ILATHE='NULL'
      NCLATH=-1
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 2003
C
C               **************************************************
C               **  TREAT THE SET LATEX FOOTER FILE <FILE>       *
C               **************************************************
C
      ILATFO='NULL'
      NCLATF=-1
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 2003
C
C               **************************************************
C               **  TREAT THE SET TABLE BORDER <ON/OFF/RULE/COLS>*
C               **************************************************
C
      ITABBR='RULE'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 2003
C
C               **************************************************
C               **  TREAT THE SET TABLE SPACING <VALUE>          *
C               **************************************************
C
      ITABSP=0
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 2003
C
C               **************************************************
C               **  TREAT THE SET TABLE WIDTH   <VALUE>          *
C               **************************************************
C
      ITABWD=0
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 2003
C
C               **************************************************
C               **  TREAT THE SET TABLE HEIGHT   <VALUE>         *
C               **************************************************
C
      ITABHT=0
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 2003
C
C               **************************************************
C               **  TREAT THE SET TABLE TITLE <VALUE>            *
C               **************************************************
C
      ITABTI=' '
      NCTABT=0
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JANUARY 2004
C
C               *****************************************************
C               **  TREAT THE SET READ VARIAVLE LABEL <ON/OFF/ROW> **
C               *****************************************************
C
      IVARLA='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JANUARY 2004
C
C               *****************************************************
C               **  TREAT THE SET CONVERT CHARACTER <NUMERIC/GROUP **
C               **  IGNORE>                                        **
C               *****************************************************
C
      IGRPAU='ERRO'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JANUARY 2004
C
C               *****************************************************
C               **  TREAT THE SET READ DELIMITER <VALUE>           **
C               *****************************************************
C
      IREADL=','
C
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JANUARY 2004
C
C               *****************************************************
C               **  TREAT THE SET READ MISSING VALUE <VALUE>       **
C               *****************************************************
C
      PREAMV=0.0
C
CCCCC THE FOLLOWING SECTION WAS ADDED    MARCH 2004
C
C               *****************************************************
C               **  TREAT THE SET GEOMETRIC DEFINITION             **
C               **        <JOHNSON AND KOTZ/DLMF>                  **
C               *****************************************************
C
      IGEODF='KOTZ'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    MARCH 2004
C
C               *****************************************************
C               **  TREAT THE SET PPCC PLOT                        **
C               **        <LINEAR/BIWEIGHT/RANK>                   **
C               *****************************************************
C
      IPPCCC='LINE'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    MAY 2004
C
C               *****************************************************
C               **  TREAT THE SET PPCC FORMAT                      **
C               **        <3D/TRACE>                               **
C               *****************************************************
C
      IPPCFO='TRAC'
C
C
CCCCC THE FOLLOWING SECTION WAS ADDED    MARCH 2004
C
C               *****************************************************
C               **  TREAT THE SET HYPERGEOMETRIC MAXIMUM LIKELIHOOD**
C               **        <ACCEPTANCE SAMPLING/CAPTURE RECAPTURE>  **
C               *****************************************************
C
      IHYPTY='ACCE'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JUNE 2004
C
C               *****************************************************
C               **  TREAT THE SET POSTSCRIPT DEFAULT COLOR         **
C               **        <ON/OFF>                                 **
C               *****************************************************
C
      IPSTDC='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JUNE 2004
C
C               *****************************************************
C               **  TREAT THE SET ASYMMETRIC LAPLACE DEFINITION    **
C               **        <K/MU>                                   **
C               *****************************************************
C
      IADEDF='K'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JUNE 2004
C
C               *****************************************************
C               **  TREAT THE SET GENERALIZED PARETO DEFINITION    **
C               **        <JOHNSON AND KOTZ/SIMIU>                 **
C               *****************************************************
C
      IGEPDF='SIMI'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    OCTOBER 2005
C
C               *****************************************************
C               **  TREAT THE SET GENERALIZED PARETO MLE STARTING  **
C               **        VALUES <MOMENT/L MOMENTS/                **
C               **        ELEMENTAL PERCENTILES/USER SPECIFIED>    **
C               *****************************************************
C
      IGEPSV='EPER'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JULY 2004
C
C               *****************************************************
C               **  TREAT THE SET GOMPERTZ-MAKEM   O DEFINITION    **
C               **        <DLMF/MEEKER/REPARAMETERIZED MEEKER>     **
C               *****************************************************
C
      IMAKDF='REPA'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    AUGUST 2004
C
C               *****************************************************
C               **  TREAT THE SET BESSEL I FUNCTION  DEFINITION    **
C               **        <1/2>                                    **
C               *****************************************************
C
      IBEIDF='1'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    AUGUST 2004
C
C               *****************************************************
C               **  TREAT THE SET BESSEL K FUNCTION  DEFINITION    **
C               **        <1/2>                                    **
C               *****************************************************
C
      IBEKDF='1'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    AUGUST 2004
C
C               *****************************************************
C               **  TREAT THE SET PROBABILITY PLOT DATA POINTS     **
C               **        <VALUE>                                  **
C               *****************************************************
C
      IPPLDP=0
C
CCCCC THE FOLLOWING SECTION WAS ADDED    AUGUST 2004
C
C               *****************************************************
C               **  TREAT THE SET PPCC        PLOT DATA POINTS     **
C               **        <VALUE>                                  **
C               *****************************************************
C
      IPPCDP=0
C
CCCCC THE FOLLOWING SECTION WAS ADDED    AUGUST 2004
C
C               *****************************************************
C               **  TREAT THE SET PPCC PLOT AXIS POINTS            **
C               **        <VALUE1> <VALUE2>                        **
C               *****************************************************
C
      IPPCAP(1)=0
      IPPCAP(2)=0
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 2004
C
C               *****************************************************
C               **  TREAT THE SET PPCC PLOT AXIS ORDER             **
C               **        <DEFAULT/REVERSE>                        **
C               *****************************************************
C
      IPPCAO='DEFA'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 2004
C
C               *****************************************************
C               **  TREAT THE SET HISTOGRAM CLASS WIDTH            **
C               **        <DEFAULT/NORMAL/NORMAL CORRECTED/SD/     **
C               **        STANDARD DEVIATION/IQ/INTERQUARTILE RANG>**
C               *****************************************************
C
      IHSTCW='DEFA'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 2004
C
C               *****************************************************
C               **  TREAT THE SET ASH WEIGHTING                    **
C               **        <TRIANGULAR/BIWEIGHT>                    **
C               *****************************************************
C
      IASHWT='TRIA'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    OCTOBER 2004
C
C               *****************************************************
C               **  TREAT THE SET READ PAD MISSING COLUMNS         **
C               **        <ON/OFF>                                 **
C               *****************************************************
C
      IREAPD='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    OCTOBER 2004
C
C               *****************************************************
C               **  TREAT THE SET READ SUBSET                      **
C               **        <PACK/DISPERSE>  <PACK/DISPERSE>         **
C               *****************************************************
C
      IREASB='P-D'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    OCTOBER 2004
C
C               *****************************************************
C               **  TREAT THE SET PROBABILITY PLOT                 **
C               **  <KAPLAN-MEIER/UNIFORM ORDER STATISTC MEDIANS>  **
C               *****************************************************
C
      IPPLCN='UNIM'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    OCTOBER 2004
C
C               *****************************************************
C               **  TREAT THE SET PPCC PLOT                        **
C               **  <KAPLAN-MEIER/UNIFORM ORDER STATISTC MEDIANS>  **
C               *****************************************************
C
      IPPCCN='UNIM'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    OCTOBER 2004
C
C               *****************************************************
C               **  TREAT THE SET MAXIMUM LIKELIHOOD QUANTILE      **
C               **  <NONE/DEFUALT/VARIABLE NAME>                   **
C               *****************************************************
C
      IQUAVR='NONE'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    DECEMBER 2004
C
C               *****************************************************
C               **  TREAT THE SET MAXIMUM LIKELIHOOD RELIABILITY   **
C               **  <NONE/DEFUALT/VARIABLE NAME>                   **
C               *****************************************************
C
      IRELVR='NONE'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    OCTOBER 2004
C
C               *****************************************************
C               **  TREAT THE SET EXPONENTIAL BIAS CORRECTED       **
C               **  <ON/OFF>                                       **
C               *****************************************************
C
      IEXPBC='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    NOVEMBER 2004
C
C               *****************************************************
C               **  TREAT THE SET WEIBULL     BIAS CORRECTED       **
C               **  <ON/OFF>                                       **
C               *****************************************************
C
      IWEIBC='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    NOVEMBER 2004
C
C               *****************************************************
C               **  TREAT THE SET GUMBEL      BIAS CORRECTED       **
C               **  <ON/OFF>                                       **
C               *****************************************************
C
      IGUMBC='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    NOVEMBER 2004
C
C               *****************************************************
C               **  TREAT THE SET MATRIX CORRELATION DIRECTION     **
C               **  <ROW/COLUMN>                                   **
C               *****************************************************
C
      ICORDI='COLU'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    NOVEMBER 2004
C
C               *****************************************************
C               **  TREAT THE SET MATRIX COVARIANCE  DIRECTION     **
C               **  <ROW/COLUMN>                                   **
C               *****************************************************
C
      ICOVDI='COLU'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    DECEMBER 2004
C
C               *****************************************************
C               **  TREAT THE SET GUI <ON/OFF>                     **
C               *****************************************************
C
      IGUIFL='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    FEBRUARY 2005
C
C               *****************************************************
C               **  TREAT THE SET DISTRIBUTIONAL BOOTSTRAP         **
C               **            <NONPARAMETRIC/PARAMETRIC>           **
C               *****************************************************
C
      IBOOPA='NONP'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    FEBRUARY 2005
C
C               *****************************************************
C               **  TREAT THE SET RTF POINT SIZE <VALUE>           **
C               *****************************************************
C
      IRTFPS=20
C
CCCCC THE FOLLOWING SECTION WAS ADDED    FEBRUARY 2005
C
C               *****************************************************
C               **  TREAT THE SET RTF FIXED FONT <FONT NAME>       **
C               *****************************************************
C
      IRTFFF='Courier New'
      NCRTF1=11
C
CCCCC THE FOLLOWING SECTION WAS ADDED    FEBRUARY 2005
C
C               *****************************************************
C               **  TREAT THE SET RTF PROPORTIONAL FONT <FONT NAME>**
C               *****************************************************
C
      IRTFFP='Times New Roman'
      NCRTF1=15
C
CCCCC THE FOLLOWING SECTION WAS ADDED    FEBRUARY 2005
C
C               *****************************************************
C               **  TREAT THE SET PARAMETER EXPAND DIGIT <VALUE>   **
C               *****************************************************
C
      IEXPDI=-1
C
CCCCC THE FOLLOWING SECTION WAS ADDED    MARCH 2005
C
C               *****************************************************
C               **  TREAT THE SET LINE PRINTER COLUMNS <80/130>    **
C               *****************************************************
C
      ILPRCO=80
C
CCCCC THE FOLLOWING SECTION WAS ADDED    APRIL 2005
C
C               *****************************************************
C               **  TREAT THE SET DECIMAL POINT <value>            **
C               *****************************************************
C
      IDECPT='.'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    APRIL 2005
C
C               *****************************************************
C               **  TREAT THE SET PEAKS OVER THRESHOLD METHOD <val> *
C               *****************************************************
C
      IPOTME='DEHA'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    APRIL 2005
C
C               *****************************************************
C               **  TREAT THE SET PEAKS OVER THRESHOLD LOAD FACTOR **
C               **                <ON/OFF>                         **
C               *****************************************************
C
      IPOTLF='OFF '
C
CCCCC THE FOLLOWING SECTION WAS ADDED    APRIL 2005
C
C               *****************************************************
C               **  TREAT THE SET PEAKS OVER THRESHOLD X AXIS      **
C               **                <POINTS/THRESHOLD>               **
C               *****************************************************
C
      IPOTAX='POIN'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    APRIL 2005
C
C               *****************************************************
C               **  TREAT THE SET PEAKS OVER THRESHOLD DISTRIBUTION *
C               **  <GENERALIZED PARETO/WEIBULL/FRECHET/GUMBEL>     *
C               *****************************************************
C
      IPOTDI='GPAR'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    APRIL 2005
C
C               *****************************************************
C               **  TREAT THE SET PEAKS OVER THRESHOLD ITERATIONS   *
C               **  <value>                                         *
C               *****************************************************
C
      IPOTIT=30
C
CCCCC THE FOLLOWING SECTION WAS ADDED    APRIL 2005
C
C               *****************************************************
C               **  TREAT THE SET PEAKS OVER THRESHOLD INITIAL      *
C               **  POINTS <value>                                  *
C               *****************************************************
C
      IPOTNP=-1
C
CCCCC THE FOLLOWING SECTION WAS ADDED    APRIL 2005
C
C               *****************************************************
C               **  TREAT THE SET PEAKS OVER THRESHOLD INITIAL      *
C               **  THRESHOLD <value>                               *
C               *****************************************************
C
      PPOTTH=CPUMIN
C
CCCCC THE FOLLOWING SECTION WAS ADDED    APRIL 2005
C
C               *****************************************************
C               **  TREAT THE SET PEAKS OVER THRESHOLD INCREMENT    *
C               **            <value>                               *
C               *****************************************************
C
      PPOTIN=-1.0
C
CCCCC THE FOLLOWING SECTION WAS ADDED    APRIL 2005
C
C               *****************************************************
C               **  TREAT THE SET PEAKS OVER THRESHOLD PERIOD       *
C               **            <value>                               *
C               *****************************************************
C
      PPOTPE=-1.0
C
CCCCC THE FOLLOWING SECTION WAS ADDED    APRIL 2005
C
C               *****************************************************
C               **  TREAT THE SET PEAKS OVER THRESHOLD TOLERANCE    *
C               **            <value>                               *
C               *****************************************************
C
      PPOTTO=0.05
C
CCCCC THE FOLLOWING SECTION WAS ADDED    MAY      2005
C
C               *****************************************************
C               **  TREAT THE SET FRECHET     BIAS CORRECTED       **
C               **  <ON/OFF>                                       **
C               *****************************************************
C
      IFREBC='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    MAY      2005
C
C               *****************************************************
C               **  TREAT THE SET GRUBBS ONE SIDED <ON/OFF>        **
C               *****************************************************
C
      IGRU1S='ON'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JULY 2005
C
C               *****************************************************
C               **  TREAT THE SET LOG GAMMA          DEFINITION    **
C               **        <DEFAULT/REPARAMETERIZED>                **
C               *****************************************************
C
      ILGADF='DEFA'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JULY 2005
C
C               *****************************************************
C               **  TREAT THE SET SKEW NORMAL        DEFINITION    **
C               **        <DEFAULT/REPARAMETERIZED>                **
C               *****************************************************
C
      ISKNDF='DEFA'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JANUARY 2006
C
C               *****************************************************
C               **  TREAT THE CAPTURE SCREEN <ON/OFF>              **
C               *****************************************************
C
      ICAPSC='OFF '
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 2005
C
C               *****************************************************
C               **  INITIATILE MACCRO ARGUMENTS                    **
C               *****************************************************
C
      NMACAG=0
      IDEFMS='$'
      IMACSC=IDEFMS
      IMACAR(1)=' '
      IMACAR(2)=' '
      IMACAR(3)=' '
      IMACAR(4)=' '
      IMACAR(5)=' '
      IMACAR(6)=' '
      IMACAR(7)=' '
      IMACAR(8)=' '
      IMACAR(9)=' '
      IMACAR(10)=' '
C
CCCCC THE FOLLOWING SECTION WAS ADDED    FEBRUARY 2006
C
C               *****************************************************
C               **  TREAT THE SET GENERALIZED TUKEY-LAMBDA         **
C               **  DEFINITION:   <FMKL/RAMB>                      **
C               *****************************************************
C
      IGLDDF='FMKL'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    MARCH    2006
C
C               *****************************************************
C               **  TREAT THE SET LOCAL FILES <PID/IGNORE>         **
C               *****************************************************
C
      ITMPFI='PID'
C
C               *******************************
C               **  EXIT AND RETURN TO MAIN  **
C               *******************************
C
 9000 CONTINUE
      IF(IBUGIN.EQ.'OFF')GOTO9999
      WRITE(ICOUT,9990)
 9990 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9995)
 9995 FORMAT('***** AT THE END       OF INITSU--')
      CALL DPWRST('XXX','BUG ')
 9999 CONTINUE
C
      RETURN
      END
      SUBROUTINE INIT3D(IBUGIN)
C
C     PURPOSE--THIS IS SUBROUTING INIT3D.
C              (THE   3D    AT THE END OF    INIT3D   STANDS FOR   3-DIMENSION)
C              THIS SUBROUTINE INITIALIZES 3-D VARIABLES AND PARAMETERS
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--88/10
C     ORIGINAL VERSION--SEPTEMBER 1988.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IBUGIN
C
CCCCC CHARACTER*4 IDEFGC
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOPA.INC'
      INCLUDE 'DPCOMC.INC'
      INCLUDE 'DPCO3D.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(IBUGIN.EQ.'OFF')GOTO99
      WRITE(ICOUT,90)
   90 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,95)
   95 FORMAT('***** AT THE BEGINNING OF INIT3D--')
      CALL DPWRST('XXX','BUG ')
   99 CONTINUE
C
C               **************************************************
C               **  SET THE 3-D GENERAL SETTINGS                **
C               **************************************************
C
      IVISSW='ON'
      I3DPRO='PERS'
C
      AEYEXC=CPUMIN
      AEYEYC=CPUMIN
      AEYEZC=CPUMIN
C
      AORIXC=CPUMIN
      AORIYC=CPUMIN
      AORIZC=CPUMIN
C
C               **************************************************
C               **  SET THE 3-D PEDESTAL ATTRIBUTES             **
C               **************************************************
C
      IDEPGC='WHIT'
      IDEPGP='SOLI'
      IDEPGR='OFF'
      IDEPCO='BLUE'
C
      IPEDGC=IDEPGC
      IPEDGP=IDEPGP
      IPEDGR=IDEPGR
      IPEDCO=IDEPCO
      IPEDSW='OFF'
C
      ADEPBA=CPUMIN
      ADEPSZ=CPUMIN
C
      APEDBA=ADEPBA
      APEDSZ=ADEPSZ
C
C               **************************************************
C               **  SET THE 3-D BASEPLANE ATTRIBUTES            **
C               **************************************************
C
      IDBSGC='WHIT'
      IDBSGP='SOLI'
      IDBSGR='OFF'
      IDBSCO='BLUE'
C
      IBSPGC=IDBSGC
      IBSPGP=IDBSGP
      IBSPGR=IDBSGR
      IBSPCO=IDBSCO
      IBSPSW='OFF'
C
C               **************************************************
C               **  SET THE 3-D BACKPLANE ATTRIBUTES            **
C               **************************************************
C
      IDBKGC='WHIT'
      IDBKGP='SOLI'
      IDBKGR='OFF'
      IDBKCO='BLUE'
C
      IBKPGC=IDBKGC
      IBKPGP=IDBKGP
      IBKPGR=IDBKGR
      IBKPCO=IDBKCO
      IBKPSW='OFF'
C
C               **************************************************
C               **  SET THE 3-D SIDEFACE ATTRIBUTES             **
C               **************************************************
C
      IDSDGC='WHIT'
      IDSDGP='SOLI'
      IDSDGR='OFF'
      IDSDCO='BLUE'
C
      ISDFGC=IDSDGC
      ISDFGP=IDSDGP
      ISDFGR=IDSDGR
      ISDFCO=IDSDCO
      ISDFSW='OFF'
C
C               **************************************************
C               **  SET THE RAW 3-D DATA                        **
C               **************************************************
C
      X3DMIN=CPUMIN
      Y3DMIN=CPUMIN
      Z3DMIN=CPUMIN
C
      X3DMAX=CPUMIN
      Y3DMAX=CPUMIN
      Z3DMAX=CPUMIN
C
      X3DMID=CPUMIN
      Y3DMID=CPUMIN
      Z3DMID=CPUMIN
C
      X3DRAN=CPUMIN
      Y3DRAN=CPUMIN
      Z3DRAN=CPUMIN
C
      X3DEYE=CPUMIN
      Y3DEYE=CPUMIN
      Z3DEYE=CPUMIN
C
      X3DORI=CPUMIN
      Y3DORI=CPUMIN
      Z3DORI=CPUMIN
C
      D3DCXX=CPUMIN
      D3DCXY=CPUMIN
      D3DCXZ=CPUMIN
      D3DCYX=CPUMIN
      D3DCYY=CPUMIN
      D3DCYZ=CPUMIN
      D3DCZX=CPUMIN
      D3DCZY=CPUMIN
      D3DCZZ=CPUMIN
C
C               *******************************
C               **  EXIT AND RETURN TO MAIN  **
C               *******************************
C
 9000 CONTINUE
      IF(IBUGIN.EQ.'OFF')GOTO9999
      WRITE(ICOUT,9990)
 9990 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9995)
 9995 FORMAT('***** AT THE END       OF INIT3D--')
      CALL DPWRST('XXX','BUG ')
 9999 CONTINUE
C
      RETURN
      END
      FUNCTION INITS (OS, NOS, ETA)
C***BEGIN PROLOGUE  INITS
C***PURPOSE  Determine the number of terms needed in an orthogonal
C            polynomial series so that it meets a specified accuracy.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C3A2
C***TYPE      SINGLE PRECISION (INITS-S, INITDS-D)
C***KEYWORDS  CHEBYSHEV, FNLIB, INITIALIZE, ORTHOGONAL POLYNOMIAL,
C             ORTHOGONAL SERIES, SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C  Initialize the orthogonal series, represented by the array OS, so
C  that INITS is the number of terms needed to insure the error is no
C  larger than ETA.  Ordinarily, ETA will be chosen to be one-tenth
C  machine precision.
C
C             Input Arguments --
C   OS     single precision array of NOS coefficients in an orthogonal
C          series.
C   NOS    number of coefficients in OS.
C   ETA    single precision scalar containing requested accuracy of
C          series.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770401  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   891115  Modified error message.  (WRB)
C   891115  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C***END PROLOGUE  INITS
      REAL OS(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOMC.INC'
      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***FIRST EXECUTABLE STATEMENT  INITS
      IF (NOS .LT. 1) THEN
        WRITE(ICOUT,11)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,12)
        CALL DPWRST('XXX','BUG ')
        INITS = 0.0
        RETURN
      ENDIF
   11 FORMAT('***** ERROR FROM INITS.  THE NUMBER OF ')
   12 FORMAT('      COEFFICIENTS IS LESS THAN 1.      *****')
C
      ERR = 0.
      DO 10 II = 1,NOS
        I = NOS + 1 - II
        ERR = ERR + ABS(OS(I))
        IF (ERR.GT.ETA) GO TO 20
   10 CONTINUE
C
   20 IF (I .EQ. NOS) THEN
      WRITE(ICOUT,21)
 21   FORMAT('***** ERROR FROM INITS.  CHEBYSHEV SERIES TOO ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,22)
 22   FORMAT('      SHORT FOR SPECIFIED ACCURACY.             *****')
      CALL DPWRST('XXX','BUG ')
      ENDIF
      INITS = I
C
      RETURN
      END
      SUBROUTINE INOUT(XA,YA,X,Y,NP,IO)
C
C     PURPOSE--XX
C
C     WRITTEN BY--DAVID W. BEHRINGER NOAA/AOML (MIAMI).
C                 AS PART OF NOAA'S CONCX V.3   MARCH 1988.
C     ORIGINAL VERSION (IN DATAPLOT)--AUGUST    1988.
C     UPDATED         --JANUARY   1989.  MORE CHANGES TO STANDARD FORTRAN 77--
C                                        CHANGED DO WHILE/END DO
C                                        AND ATAN2D TO ATAN2
C                                        (ATAN2D IS A VAX DOUB. PREC. ATAN2)
C                                        (ALAN HECKERT).
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
      DIMENSION Y(*)
C
C-----START POINT-----------------------------------------------------
C
      AS=0.
      XX=X(1)-XA
      YY=Y(1)-YA
CCCCC A0=ATAN2D(YY,XX)
      A0=ATAN2(YY,XX)
      DO 10 N=2,NP+1
        M=MOD(N-1,NP)+1
        XX=X(M)-XA
        YY=Y(M)-YA
CCCCC   A=ATAN2D(YY,XX)
        A=ATAN2(YY,XX)
        DA=A-A0
        IF (DA.LT.-180.) DA=DA+360.
        IF (DA.GT.180.)  DA=DA-360.
        AS=AS+DA
        A0=A
 10   CONTINUE
      IF (ABS(AS).LT.180.) THEN
        IO=0
      ELSE
        IO=1
      END IF
      RETURN
      END
      SUBROUTINE INTARR(X,NX,IWRITE,Y,NY,IBUGA3,IERROR)
C
C     PURPOSE--COMPUTE INTERARRIVAL TIMES OF A SERIES OF FAILURE
C              TIMES.
C              SORT FAILURE TIMES
C              Y(1) = X(1)
C              Y(2) = X(2)-X(1)
C              Y(2) = X(3)-X(2)
C              Y(3) = X(4)-X(3)
C              ETC.
C     NOTE--IT IS PERMISSIBLE TO HAVE THE OUTPUT VECTOR Y(.)
C           BEING IDENTICAL TO THE INPUT VECTOR X(.).
C     WRITTEN BY--JAMES J. FILLIBEN
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--98/5
C     ORIGINAL VERSION--MAY       1998.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
      DIMENSION Y(*)
C
C---------------------------------------------------------------------
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='INTA'
      ISUBN2='RR  '
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 INTARR--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)IBUGA3
   52 FORMAT('IBUGA3 = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)NX
   53 FORMAT('NX = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO55I=1,NX
      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 SEQUENTIAL DIFFERENCE.  **
C               **************************************
C
      CALL SORT(X,NX,X)
      NXM1=NX-1
      IF(NXM1.LT.1)GOTO150
      DO100I=NX,2,-1
      IP1=I-1
      Y(I)=X(I)-X(IP1)
  100 CONTINUE
      Y(1)=X(1)
      NY=NX
      GOTO190
C
  150 CONTINUE
      IERROR='YES'
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,151)
  151 FORMAT('***** ERROR IN INTARR--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,152)
  152 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,153)
  153 FORMAT('      IN THE VARIABLE FOR WHICH')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,154)
  154 FORMAT('      THE INTERARRIVAL TIMES ARE TO BE COMPUTED')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,155)
  155 FORMAT('      MUST BE 2 OR LARGER.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,156)
  156 FORMAT('      SUCH WAS NOT THE CASE HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,157)NX
  157 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8,
     1'.')
      CALL DPWRST('XXX','BUG ')
C
  190 CONTINUE
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
C
      IF(IBUGA3.EQ.'OFF')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF INTARR--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IBUGA3,IERROR
 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)NX,NY
 9013 FORMAT('NX,NY = ',2I8)
      CALL DPWRST('XXX','BUG ')
      DO9015I=1,NX
      WRITE(ICOUT,9016)I,X(I),Y(I)
 9016 FORMAT('I,X(I),Y(I) = ',I8,2E15.7)
      CALL DPWRST('XXX','BUG ')
 9015 CONTINUE
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE INTERP(Y,X,N,X2,N2,IWRITE,Y2,IBUGG3,ISUBRO,IERROR)
CCCCC ADD ISUBRO ARGUMENT MAY, 1994.
CCCCC SUBROUTINE INTERP(Y,X,N,X2,N2,IWRITE,Y2,IBUGG3,IERROR)
C
C     PURPOSE--COMPUTE SPLINE INTERPOLATION OF A VARIABLE
C              (GENERATE INTERPOLATED POINTS).
C     INPUT  ARGUMENTS--Y      = SINGLE PRECISION VARIABLE
C                                CONTAINING THE ORIGINAL
C                                VERTICAL AXIS DATA POINTS.
C                     --X      = SINGLE PRECISION VARIABLE
C                                CONTAINING THE ORIGINAL
C                                HORIZONTAL AXIS DATA POINTS.
C                     --X2     = SINGLE PRECISION VARIABLE
C                                CONTAINING THE DESIRED
C                                HORIZONTAL AXIS INTERPOLATION
C                                POINTS.
C     OUTPUT ARGUMENTS--Y2     = SINGLE PRECISION VARIABLE
C                                CONTAINING THE COMPUTED
C                                VERTICAL AXIS INTERPOLATION
C                                POINTS.
C     NOTE--IT IS PROBABLY NOT PERMISSIBLE TO HAVE THE OUTPUT VECTOR Y2(.)
C           BEING IDENTICAL TO THE INPUT VECTOR Y(.)
C     NOTE--THIS SUBROUTINE DOES NOT ASSUME THAT THE INPUT
C           DATA IS ALREADY SORTED ACCORDING TO THE
C           HORIZONTAL AXIS VARIABLE.
C           SUCH SORTING IS DOEN HEREIN.
C     CAUTION--THE INPUT VECTORS Y AND X ARE SORTED HEREIN
C              AND SO MAY BE DIFFERENT UPON LEAVING THIS SUBROUTINE
C              THAN UPON ENTERING THIS SUBROUTINE.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--87/4
C     ORIGINAL VERSION--APRIL     1987.
C     UPDATED         --MAY       1989.  SORT THE INPUT DATA
C     UPDATED         --JUNE      1990. TEMPORARY ARRAYS TO GARBAGE COMMON.
C                                       ARRAY DECLARATIONS MOVED FROM INTER2
C     UPDATED         --MAY       1994. ADD ISUBRO ARGUMENT
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGG3
      CHARACTER*4 ISUBRO
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 ISTEPN
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOPA.INC'
C
      DIMENSION Y(*)
      DIMENSION X(*)
      DIMENSION X2(*)
      DIMENSION Y2(*)
C
      DIMENSION YTEMP(MAXOBV)
      DIMENSION YDIST(MAXOBV)
      DIMENSION XDIST(MAXOBV)
C
      DIMENSION DELX(MAXOBV)
      DIMENSION DELY(MAXOBV)
      DIMENSION DERIV(MAXOBV)
      DIMENSION DELX6(MAXOBV)
      DIMENSION P(MAXOBV)
      DIMENSION B(MAXOBV)
      DIMENSION Z(MAXOBV)
      DIMENSION C(4,MAXOBV)
      DIMENSION A(MAXOBV,3)
CCCCC FOLLOWING LINES ADDED JUNE, 1990
      INCLUDE 'DPCOZZ.INC'
      INCLUDE 'DPCOZ2.INC'
      EQUIVALENCE (G2RBAG(IGAR11),YTEMP(1))
      EQUIVALENCE (G2RBAG(IGAR12),YDIST(1))
      EQUIVALENCE (G2RBAG(IGAR13),XDIST(1))
      EQUIVALENCE (G2RBAG(IGAR14),DELX(1))
      EQUIVALENCE (G2RBAG(IGAR15),DELY(1))
      EQUIVALENCE (G2RBAG(IGAR16),DERIV(1))
      EQUIVALENCE (G2RBAG(IGAR17),DELX6(1))
      EQUIVALENCE (G2RBAG(IGAR18),P(1))
      EQUIVALENCE (G2RBAG(IGAR19),B(1))
      EQUIVALENCE (G2RBAG(IGAR20),Z(1))
      EQUIVALENCE (G2RBAG(IGAR21),C(1,1))
      EQUIVALENCE (G2RBAG(IGAR25),A(1,1))
CCCCC END CHANGE
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='INTE'
      ISUBN2='RP  '
C
      IERROR='NO'
C
      IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'TERP')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF INTERP--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)N
   52 FORMAT('N = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO55I=1,N
      WRITE(ICOUT,56)I,Y(I),X(I)
   56 FORMAT('I,Y(I),X(I) = ',I8,2E15.7)
      CALL DPWRST('XXX','BUG ')
   55 CONTINUE
      WRITE(ICOUT,62)N2
   62 FORMAT('N2 = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO65I=1,N2
      WRITE(ICOUT,66)I,X2(I)
   66 FORMAT('I,X2(I) = ',I8,E15.7)
      CALL DPWRST('XXX','BUG ')
   65 CONTINUE
   90 CONTINUE
C
C               ****************************************
C               **  STEP 11--                         **
C               **  SORT THE INPUT DATA ACCORDING     **
C               **  TO THE HORIZONTAL AXIS VARIABLE   **
C               ****************************************
C
CCCCC THE FOLLOWING LINE WAS INSERTED MAY 1989
      CALL SORTC(X,Y,N,X,Y)
C
C               ********************************************************
C               **  STEP 12--                                         **
C               **  DETERMINE THE NUMBER OF DISTINCT X VALUES         **
C               ********************************************************
C
      ISTEPN='12'
      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'TERP')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      NDIST=0
      DO1210I=1,N
      IF(NDIST.EQ.0)GOTO1220
      DO1215I2=1,NDIST
      IF(X(I).EQ.XDIST(I2))GOTO1210
 1215 CONTINUE
 1220 CONTINUE
      NDIST=NDIST+1
      XDIST(NDIST)=X(I)
 1210 CONTINUE
C
      CALL SORT(XDIST,NDIST,XDIST)
C
C               *****************************************************
C               **  STEP 13--                                      **
C               **  IF ALL DISTINCT (THAT IS, NO REPLICATION),     **
C               **  (THAT IS, HAVE NO REPLICATION),                **
C               **  THEN COPY OVER Y VALUES.                       **
C               **  IF NOT ALL DISTINCT                            **
C               **  (THAT IS, HAVE SOME REPLICATION),              **
C               **  THEN COMPUTE A MEAN VALUE OVER THE REPLICATES  **
C               **  AND TREAT THAT AS THE COMMON VALUE.            **
C               **  THE CORE OF THE INTERPOLATION CODE             **
C               **  IS EXPECTING SORTED, DISTINCT X VALUES.        **
C               *****************************************************
C
      IF(NDIST.EQ.N)GOTO1310
      GOTO1320
C
 1310 CONTINUE
      DO1311K=1,NDIST
      YDIST(K)=Y(K)
 1311 CONTINUE
      GOTO1390
C
 1320 CONTINUE
      DO1321K=1,NDIST
      TAG=XDIST(K)
      J=0
      DO1322I=1,N
      IF(X(I).EQ.TAG)GOTO1323
      GOTO1322
 1323 CONTINUE
      J=J+1
      YTEMP(J)=Y(I)
 1322 CONTINUE
      NI=J
      CALL MEAN(YTEMP,NI,IWRITE,YMEAN,IBUGG3,IERROR)
      YDIST(K)=YMEAN
 1321 CONTINUE
      GOTO1390
C
 1390 CONTINUE
C
C               ********************************************
C               **  STEP 14--                             **
C               **  COMPUTE INTERPOLATED VALUES           **
C               ********************************************
C
CCCCC THE REMAINDER OF THIS SUBROUTINE WAS REPLACED    MAY 1989
CCCCC BY A CALL TO INTER2                              MAY 1989
C
CCCCC JUNE, 1990.  MOVE SOME DIMENSIONING FROM INTER2 TO INTERP
      CALL INTER2(YDIST,XDIST,NDIST,X2,N2,Y2,
     1DELX,DELY,DERIV,DELX6,P,B,Z,C,A,MAXOBV,
CCCCC ADD ISUBRO ARGUMENT  MAY, 1994.
CCCCC1IBUGG3,IERROR)
     1IBUGG3,ISUBRO,IERROR)
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'TERP')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF INTERP--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)N,N2
 9012 FORMAT('N,N2 = ',2I8)
      CALL DPWRST('XXX','BUG ')
      DO9015I=1,N
      WRITE(ICOUT,9016)A(I,1),A(I,2),A(I,3)
 9016 FORMAT('A(I,1),A(I,2),A(I,3)        = ',3E15.7)
      CALL DPWRST('XXX','BUG ')
 9015 CONTINUE
      DO9025I=1,N
      WRITE(ICOUT,9026)DELX(I),DELY(I),DERIV(I),DELX6(I),B(I),Z(I)
 9026 FORMAT('DELX(I),DELY(I),DERIV(I),DELX6(I),B(I),Z(I) = ',
     16F10.5)
      CALL DPWRST('XXX','BUG ')
 9025 CONTINUE
      DO9035I=1,N
      WRITE(ICOUT,9036)C(1,I),C(2,I),C(3,I),C(4,I)
 9036 FORMAT('C(1,I),C(2,I),C(3,I),C(4,I) = ',4F10.5)
      CALL DPWRST('XXX','BUG ')
 9035 CONTINUE
      WRITE(ICOUT,9041)N2
 9041 FORMAT('N2 = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO9042I=1,N2
      WRITE(ICOUT,9043)I,X2(I),Y2(I)
 9043 FORMAT('I,X2(I),Y2(I) = ',I8,2E15.7)
      CALL DPWRST('XXX','BUG ')
 9042 CONTINUE
      WRITE(ICOUT,9051)NDIST
 9051 FORMAT('NDIST = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO9052I=1,NDIST
      WRITE(ICOUT,9053)I,XDIST(I),YDIST(I)
 9053 FORMAT('I,XDIST(I),YDIST(I) = ',I8,2E15.7)
      CALL DPWRST('XXX','BUG ')
 9052 CONTINUE
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE INTER2(Y,X,N,X2,N2,Y2,
     1DELX,DELY,DERIV,DELX6,P,B,Z,C,A,MAXOBV,
     1IBUGG3,ISUBRO,IERROR)
CCCCC1IBUGG3,IERROR)
CCCCC MAY, 1994.  ADD ISUBRO ARGUMENT
CCCCC JUNE, 1990.  SOME DIMENSIONING MOVED FROM INTER2 TO INTERP
C
C     PURPOSE--COMPUTE SPLINE INTERPOLATION OF A VARIABLE
C              (GENERATE INTERPOLATED POINTS).
C     INPUT  ARGUMENTS--Y      = SINGLE PRECISION VARIABLE
C                                CONTAINING THE ORIGINAL
C                                VERTICAL AXIS DATA POINTS.
C                     --X      = SINGLE PRECISION VARIABLE
C                                CONTAINING THE ORIGINAL
C                                HORIZONTAL AXIS DATA POINTS.
C                     --X2     = SINGLE PRECISION VARIABLE
C                                CONTAINING THE DESIRED
C                                HORIZONTAL AXIS INTERPOLATION
C                                POINTS.
C     OUTPUT ARGUMENTS--Y2     = SINGLE PRECISION VARIABLE
C                                CONTAINING THE COMPUTED
C                                VERTICAL AXIS INTERPOLATION
C                                POINTS.
C     NOTE--IT IS PROBABLY NOT PERMISSIBLE TO HAVE THE OUTPUT VECTOR Y2(.)
C           BEING IDENTICAL TO THE INPUT VECTOR Y(.)
C     NOTE--THIS SUBROUTINE DOES NOT ASSUME THAT THE INPUT
C           DATA IS ALREADY SORTED ACCORDING TO THE
C           HORIZONTAL AXIS VARIABLE.
C           SUCH SORTING IS DOEN HEREIN.
C     CAUTION--THE INPUT VECTORS Y AND X ARE SORTED HEREIN
C              AND SO MAY BE DIFFERENT UPON LEAVING THIS SUBROUTINE
C              THAN UPON ENTERING THIS SUBROUTINE.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--87/4
C     ORIGINAL VERSION--APRIL     1987.
C     UPDATED         --MAY       1989.  SORT THE INPUT DATA
C     UPDATED         --JUNE      1990.  MOVE DIMENSIONS FROM INTER2 TO INTERP
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IBUGG3
      CHARACTER*4 ISUBRO
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
CCCCC CHARACTER*4 ISTEPN
C
C---------------------------------------------------------------------
C
CCCCC JUNE, 1990.  FOLLOWING INCLUDE FILE NO LONGER NEEDED
CCCCC      INCLUDE 'DPCOPA.INC'
C
      DIMENSION Y(*)
      DIMENSION X(*)
      DIMENSION X2(*)
      DIMENSION Y2(*)
C
CCCCC JUNE, 1990.  FOLLOWING DIMENSIONS NOW DONE IN INTERP
CCCCC DIMENSION DELX(MAXOBV)
CCCCC DIMENSION DELY(MAXOBV)
CCCCC DIMENSION DERIV(MAXOBV)
CCCCC DIMENSION DELX6(MAXOBV)
CCCCC DIMENSION P(MAXOBV)
CCCCCCDIMENSION B(MAXOBV)
CCCCC DIMENSION Z(MAXOBV)
      DIMENSION DELX(*)
      DIMENSION DELY(*)
      DIMENSION DERIV(*)
      DIMENSION DELX6(*)
      DIMENSION P(*)
      DIMENSION B(*)
      DIMENSION Z(*)
      DIMENSION C(4,MAXOBV)
      DIMENSION A(MAXOBV,3)
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
      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='INTE'
      ISUBN2='RP  '
C
      IERROR='NO'
C
      IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'TER2')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF INTER2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)N
   52 FORMAT('N = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO55I=1,N
      WRITE(ICOUT,56)I,Y(I),X(I)
   56 FORMAT('I,Y(I),X(I) = ',I8,2E15.7)
      CALL DPWRST('XXX','BUG ')
   55 CONTINUE
      WRITE(ICOUT,62)N2
   62 FORMAT('N2 = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO65I=1,N2
      WRITE(ICOUT,66)I,X2(I)
   66 FORMAT('I,X2(I) = ',I8,E15.7)
      CALL DPWRST('XXX','BUG ')
   65 CONTINUE
   90 CONTINUE
C
      NM1=N-1
      NM2=N-2
C
C               ********************************************
C               **  STEP 21--                             **
C               **  FORM FIRST DIFFERENCES AND THE RATIOS **
C               ********************************************
C
      DO2100I=1,NM1
      IP1=I+1
      DELX(I)=X(IP1)-X(I)
      DELY(I)=Y(IP1)-Y(I)
      DERIV(I)=DELY(I)/DELX(I)
      DELX6(I)=DELX(I)/6.0
 2100 CONTINUE
C
C               **********************************
C               **  STEP 22--                   **
C               **  FORM DIFFERENCES OF RATIOS  **
C               **********************************
C
      DO2200I=2,NM1
      IM1=I-1
      B(I)=DERIV(I)-DERIV(IM1)
 2200 CONTINUE
C
C               **********************
C               **  STEP 23--
C               **********************
C
      A(1,2)=(-1.0-DELX(1)/DELX(2))
      A(1,3)=DELX(1)/DELX(2)
      A(2,3)=DELX6(2)-DELX6(1)*A(1,3)
      A(2,2)=2.0*(DELX6(1)+DELX6(2))-DELX6(1)*A(1,2)
      A(2,3)=A(2,3)/A(2,2)
      B(2)=B(2)/A(2,2)
C
C               ****************************************
C               **  STEP 24--
C               ****************************************
C
      DO2400I=3,NM1
      IM1=I-1
      A(I,2)=2.0*(DELX6(IM1)+DELX6(I))-DELX6(IM1)*A(IM1,3)
      B(I)=B(I)-DELX6(IM1)*B(IM1)
      A(I,3)=DELX6(I)/A(I,2)
      B(I)=B(I)/A(I,2)
 2400 CONTINUE
C
C               ****************************************
C               **  STEP 25--
C               ****************************************
C
      Q=DELX(NM2)/DELX(NM1)
      A(N,1)=1.0+Q+A(NM2,3)
      A(N,2)=(-Q-A(N,1)*A(NM1,3))
      B(N)=B(NM2)-A(N,1)*B(NM1)
      Z(N)=B(N)/A(N,2)
C
C               ****************************************
C               **  STEP 26--
C               ****************************************
C
      DO2600I=1,NM2
      K=N-I
      KP1=K+1
      Z(K)=B(K)-A(K,3)*Z(KP1)
 2600 CONTINUE
      Z(1)=(-A(1,2)*Z(2)-A(1,3)*Z(3))
C
C               ****************************************
C               **  STEP 27--                         **
C               ****************************************
C
      DO2700I=1,NM1
      IP1=I+1
      Q=1.0/(6.0*DELX(I))
      C(1,I)=Z(I)*Q
      C(2,I)=Z(IP1)*Q
      C(3,I)=Y(I)/DELX(I)-Z(I)*DELX6(I)
      C(4,I)=Y(IP1)/DELX(I)-Z(IP1)*DELX6(I)
 2700 CONTINUE
C
C               ****************************************
C               **  STEP 28--
C               **  PRINT OUT Z'S
C               ****************************************
C
      IF(IBUGG3.EQ.'OFF')GOTO2890
      DO2800I=1,N
      WRITE(ICOUT,2810)I,Z(I)
 2810 FORMAT('I,Z(I) = ',I8,E15.7)
      CALL DPWRST('XXX','BUG ')
 2800 CONTINUE
 2890 CONTINUE
C
C               ****************************************
C               **  STEP 31--
C               **  COMPUTE INTERPOLATION VALUES
C               ****************************************
C
      DO3100J=1,N2
      XT=X2(J)
      IF(X(1).GT.XT)GOTO3110
      GOTO3119
C
 3110 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3111)
 3111 FORMAT('***** ERROR IN INTER2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3112)
 3112 FORMAT('      AN ATTEMPT WAS MADE TO COMPUTE')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3113)
 3113 FORMAT('      A SMOOTHED VALUE BEYOND THE RANGE')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3114)
 3114 FORMAT('      OF THE DATA--SUCH EXTRAPOLATION')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3115)
 3115 FORMAT('      IS UNRELIABLE AND NOT PERMITTED.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3116)X(1)
 3116 FORMAT('         SMALLEST DATA POINT X(1)      = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3117)XT
 3117 FORMAT('         ATTEMPTED EXTRAPOLATION POINT = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
 3119 CONTINUE
C
      DO3200I=1,N
      I2=I
      IF(X(I).EQ.XT)GOTO3210
      IF(X(I).GT.XT)GOTO3220
 3200 CONTINUE
C
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3201)
 3201 FORMAT('***** ERROR IN INTER2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3202)
 3202 FORMAT('      AN ATTEMPT WAS MADE TO COMPUTE')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3203)
 3203 FORMAT('      A SMOOTHED VALUE BEYOND THE RANGE')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3204)
 3204 FORMAT('      OF THE DATA--SUCH EXTRAPOLATION')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3205)
 3205 FORMAT('      IS UNRELIABLE AND NOT PERMITTED.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3206)X(1)
 3206 FORMAT('         LARGEST  DATA POINT X(1)      = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3207)XT
 3207 FORMAT('         ATTEMPTED EXTRAPOLATION POINT = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
C
 3210 CONTINUE
      Y2(J)=Y(I2)
      GOTO3100
C
 3220 CONTINUE
      K=I2-1
      KP1=K+1
      DELU=X(KP1)-XT
      DELL=XT-X(K)
      TERM1=DELU*(C(1,K)*DELU**2+C(3,K))
      TERM2=DELL*(C(2,K)*DELL**2+C(4,K))
      Y2(J)=TERM1+TERM2
 3100 CONTINUE
C
C               ****************************************
C               **  STEP 41--
C               **  IF CALLED FOR,
C               **  WRITE OUT INTERPOLATION VALUES
C               ****************************************
C
      IF(IBUGG3.EQ.'OFF')GOTO4190
      DO4100J=1,N2
      WRITE(ICOUT,4110)X2(J),Y2(J)
      CALL DPWRST('XXX','BUG ')
 4110 FORMAT('X2(J),Y2(J) = ',2E15.7)
 4100 CONTINUE
 4190 CONTINUE
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'TER2')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF INTER2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)N,N2
 9012 FORMAT('N,N2 = ',2I8)
      CALL DPWRST('XXX','BUG ')
      DO9015I=1,N
      WRITE(ICOUT,9016)A(I,1),A(I,2),A(I,3)
 9016 FORMAT('A(I,1),A(I,2),A(I,3)        = ',3E15.7)
      CALL DPWRST('XXX','BUG ')
 9015 CONTINUE
      DO9025I=1,N
      WRITE(ICOUT,9026)DELX(I),DELY(I),DERIV(I),DELX6(I),B(I),Z(I)
 9026 FORMAT('DELX(I),DELY(I),DERIV(I),DELX6(I),B(I),Z(I) = ',
     16F10.5)
      CALL DPWRST('XXX','BUG ')
 9025 CONTINUE
      DO9035I=1,N
      WRITE(ICOUT,9036)C(1,I),C(2,I),C(3,I),C(4,I)
 9036 FORMAT('C(1,I),C(2,I),C(3,I),C(4,I) = ',4F10.5)
      CALL DPWRST('XXX','BUG ')
 9035 CONTINUE
      WRITE(ICOUT,9041)N2
 9041 FORMAT('N2 = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO9042I=1,N2
      WRITE(ICOUT,9043)I,X2(I),Y2(I)
 9043 FORMAT('I,X2(I),Y2(I) = ',I8,2E15.7)
      CALL DPWRST('XXX','BUG ')
 9042 CONTINUE
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE INTRV(XT,LXT,X,ILO,ILEFT,MFLAG)
C***BEGIN PROLOGUE  INTRV
C***DATE WRITTEN   800901   (YYMMDD)
C***REVISION DATE  820801   (YYMMDD)
C***CATEGORY NO.  E3,K6
C***KEYWORDS  B-SPLINE,DATA FITTING,INTERPOLATION,SPLINE
C***AUTHOR  AMOS, D. E., (SNLA)
C***PURPOSE  Computes the largest integer ILEFT in 1.LE.ILEFT.LE.LXT
C            such that XT(ILEFT).LE.X where XT(*) is a subdivision
C            of the X interval.
C***DESCRIPTION
C
C     Written by Carl de Boor and modified by D. E. Amos
C
C     Reference
C         SIAM J. Numerical Analysis, 14, No. 3, June 1977, pp. 441-472.
C
C     Abstract
C         INTRV is the INTERV routine of the reference.
C
C         INTRV computes the largest integer ILEFT in 1 .LE. ILEFT .LE.
C         LXT such that XT(ILEFT) .LE. X where XT(*) is a subdivision of
C         the X interval.  Precisely,
C
C                      X .LT. XT(1)                1         -1
C         if  XT(I) .LE. X .LT. XT(I+1)  then  ILEFT=I  , MFLAG=0
C           XT(LXT) .LE. X                         LXT        1,
C
C         That is, when multiplicities are present in the break point
C         to the left of X, the largest index is taken for ILEFT.
C
C     Description of Arguments
C         Input
C          XT      - XT is a knot or break point vector of length LXT
C          LXT     - length of the XT vector
C          X       - argument
C          ILO     - an initialization parameter which must be set
C                    to 1 the first time the spline array XT is
C                    processed by INTRV.
C
C         Output
C          ILO     - ILO contains information for efficient process-
C                    ing after the initial call, and ILO must not be
C                    changed by the user.  Distinct splines require
C                    distinct ILO parameters.
C          ILEFT   - largest integer satisfying XT(ILEFT) .LE. X
C          MFLAG   - signals when X lies out of bounds
C
C     Error Conditions
C         None
C***REFERENCES  C. DE BOOR, *PACKAGE FOR CALCULATING WITH B-SPLINES*,
C                 SIAM JOURNAL ON NUMERICAL ANALYSIS, VOLUME 14, NO. 3,
C                 JUNE 1977, PP. 441-472.
C***ROUTINES CALLED  (NONE)
C***END PROLOGUE  INTRV
C
C
      INTEGER IHI, ILEFT, ILO, ISTEP, LXT, MFLAG, MIDDLE
      REAL X, XT
      DIMENSION XT(LXT)
C***FIRST EXECUTABLE STATEMENT  INTRV
      IHI = ILO + 1
      IF (IHI.LT.LXT) GO TO 10
      IF (X.GE.XT(LXT)) GO TO 110
      IF (LXT.LE.1) GO TO 90
      ILO = LXT - 1
      IHI = LXT
C
   10 IF (X.GE.XT(IHI)) GO TO 40
      IF (X.GE.XT(ILO)) GO TO 100
C
C *** NOW X .LT. XT(IHI) . FIND LOWER BOUND
      ISTEP = 1
   20 IHI = ILO
      ILO = IHI - ISTEP
      IF (ILO.LE.1) GO TO 30
      IF (X.GE.XT(ILO)) GO TO 70
      ISTEP = ISTEP*2
      GO TO 20
   30 ILO = 1
      IF (X.LT.XT(1)) GO TO 90
      GO TO 70
C *** NOW X .GE. XT(ILO) . FIND UPPER BOUND
   40 ISTEP = 1
   50 ILO = IHI
      IHI = ILO + ISTEP
      IF (IHI.GE.LXT) GO TO 60
      IF (X.LT.XT(IHI)) GO TO 70
      ISTEP = ISTEP*2
      GO TO 50
   60 IF (X.GE.XT(LXT)) GO TO 110
      IHI = LXT
C
C *** NOW XT(ILO) .LE. X .LT. XT(IHI) . NARROW THE INTERVAL
   70 MIDDLE = (ILO+IHI)/2
      IF (MIDDLE.EQ.ILO) GO TO 100
C     NOTE. IT IS ASSUMED THAT MIDDLE = ILO IN CASE IHI = ILO+1
      IF (X.LT.XT(MIDDLE)) GO TO 80
      ILO = MIDDLE
      GO TO 70
   80 IHI = MIDDLE
      GO TO 70
C *** SET OUTPUT AND RETURN
   90 MFLAG = -1
      ILEFT = 1
      RETURN
  100 MFLAG = 0
      ILEFT = ILO
      RETURN
  110 MFLAG = 1
      ILEFT = LXT
      RETURN
      END
      SUBROUTINE INTVEC(Y,X,N,NUMVAR,IWRITE,XYINT,IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE
C              INTEGRAL OF THE DATA IN THE INPUT VECTOR Y (IF NUMVAR = 1)
C              OR OF THE INTEGRAL OF Y (VERTICALLY)
C              WITH RESPECT TO X (HORIZONTALLY) (IF NUMVAR = 2).
C     NOTE--WHEN NUMVAR = 1, IT IS ASSUMED THAT THE
C           HORIZONTAL AXIS VARIABLE IS EQUALLY-SPACED
C           WITH UNIT SPACING.
C     NOTE--THE TRAPEZOID RULE IS USED.
C     INPUT  ARGUMENTS--Y      = THE SINGLE PRECISION VECTOR OF
C                                VERTICAL AXIS OBSERVATIONS.
C                     --X      = THE SINGLE PRECISION VECTOR OF
C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR X.
C     OUTPUT ARGUMENTS--XYINT  = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED SAMPLE INTEGRAL.
C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
C             SAMPLE INTEGRAL.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           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.6
C     ORIGINAL VERSION--JANUARY   1979.
C     UPDATED         --JUNE      1979.
C     UPDATED         --JULY      1979.
C     UPDATED         --AUGUST    1981.
C     UPDATED         --MAY       1982.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DXI
      DOUBLE PRECISION DYI
      DOUBLE PRECISION DXIM1
      DOUBLE PRECISION DYIM1
      DOUBLE PRECISION DDELX
      DOUBLE PRECISION DDELY
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DSUM
C
      DIMENSION X(*)
      DIMENSION Y(*)
C
C---------------------------------------------------------------------
C
      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='INTV'
      ISUBN2='EC  '
C
      IERROR='NO'
C
      DXI=0.0D0
      DYI=0.0D0
      DXIM1=0.0D0
      DYIM1=0.0D0
C
      IF(IBUGA3.EQ.'OFF')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF INTVEC--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)IBUGA3
   52 FORMAT('IBUGA3 = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)N,NUMVAR
   53 FORMAT('N,NUMVAR = ',2I8)
      CALL DPWRST('XXX','BUG ')
      DO55I=1,N
      WRITE(ICOUT,56)I,X(I),Y(I)
   56 FORMAT('I,X(I),Y(I) = ',I8,2E15.7)
      CALL DPWRST('XXX','BUG ')
   55 CONTINUE
   90 CONTINUE
C
C               *******************************************
C               **  COMPUTE     (NUMERICAL) INTEGRAL     **
C               *******************************************
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      AN=N
C
      IF(N.GE.1)GOTO119
      IERROR='YES'
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,111)
  111 FORMAT('***** ERROR IN INTVEC--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,112)
  112 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,113)
  113 FORMAT('      IN THE VARIABLE FOR WHICH')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,114)
  114 FORMAT('      THE INTEGRAL IS TO BE')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,115)
  115 FORMAT('      COMPUTED, MUST BE 1 OR LARGER.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,116)
  116 FORMAT('      SUCH WAS NOT THE CASE HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,117)N
  117 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8,
     1'.')
      CALL DPWRST('XXX','BUG ')
      GOTO9000
  119 CONTINUE
C
      IF(N.EQ.1)GOTO120
      GOTO129
  120 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,121)
  121 FORMAT('***** NON-FATAL DIAGNOSTIC IN INTVEC--',
     1'THE THIRD INPUT ARGUMENT (N) HAS THE VALUE 1')
      CALL DPWRST('XXX','BUG ')
      XYINT=0.0
      GOTO9000
  129 CONTINUE
C
      IF(NUMVAR.EQ.1.OR.NUMVAR.EQ.2)GOTO139
      IERROR='YES'
  130 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,131)
  131 FORMAT('***** INTERNAL ERROR IN INTVEC--',
     1'THE FOURTH INPUT ARGUMENT (NUMVAR) HAS VALUE OTHER THAN 1 OR 2')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,132)NUMVAR
  132 FORMAT('      NUMVAR = ',I8)
      CALL DPWRST('XXX','BUG ')
      GOTO9000
  139 CONTINUE
C
      HOLD=Y(1)
      DO145I=2,N
      IF(Y(I).NE.HOLD)GOTO149
  145 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,146)HOLD
  146 FORMAT('***** NON-FATAL DIAGNOSTIC IN INTVEC--',
     1'THE FIRST  INPUT ARGUMENT (A VECTOR Y) HAS ALL ELEMENTS = ',
     1E15.7)
      CALL DPWRST('XXX','BUG ')
      GOTO190
  149 CONTINUE
C
      IF(NUMVAR.LE.1)GOTO159
      HOLD=X(1)
      DO155I=2,N
      IF(Y(I).NE.HOLD)GOTO159
  155 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,156)HOLD
  156 FORMAT('***** NON-FATAL DIAGNOSTIC IN INTVEC--',
     1'THE SECOND INPUT ARGUMENT (A VECTOR X) HAS ALL ELEMENTS = ',
     1E15.7)
      CALL DPWRST('XXX','BUG ')
      XYINT=0.0
      GOTO9000
  159 CONTINUE
C
  190 CONTINUE
C
C               ****************************************
C               **  STEP 2--                          **
C               **  COMPUTE THE (NUMERICAL) INTEGRAL  **
C               ****************************************
C
      DSUM=0.0D0
      I=1
      IF(NUMVAR.EQ.1)DXI=I
      IF(NUMVAR.EQ.2)DXI=X(I)
      DYI=Y(1)
      DO200I=2,N
      DXIM1=DXI
      DYIM1=DYI
      IF(NUMVAR.EQ.1)DXI=I
      IF(NUMVAR.EQ.2)DXI=X(I)
      DYI=Y(I)
      DDELX=DXI-DXIM1
      DDELY=DYI-DYIM1
      DTERM1=DYIM1*DDELX
      DTERM2=DDELY*DDELX/2.0D0
      DSUM=DSUM+DTERM1+DTERM2
  200 CONTINUE
      XYINT=DSUM
C
C               *******************************
C               **  STEP 3--                 **
C               **  WRITE OUT A LINE         **
C               **  OF SUMMARY INFORMATION.  **
C               *******************************
C
      IF(IFEEDB.EQ.'OFF')GOTO890
      IF(IWRITE.EQ.'OFF')GOTO890
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,811)N,XYINT
  811 FORMAT('THE (TRAPEZOID RULE) INTEGRAL OF THE ',I8,
     1' OBSERVATIONS = ',E15.7)
      CALL DPWRST('XXX','BUG ')
  890 CONTINUE
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'OFF')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF INTVEC--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IBUGA3,IERROR
 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)N
 9013 FORMAT('N = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9014)DXI,DYI,DXIM1,DYIM1
 9014 FORMAT('DXI,DYI,DXIM1,DYIM1 = ',4D15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9015)XYINT
 9015 FORMAT('XYINT = ',E15.7)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE INT2D(Z,Y,X,N,Y2,NY,X2,NX,IWRITE,Z2,N2,
     1IBUGG3,ISUBRO,IERROR)
C
C     PURPOSE--COMPUTE BIVARIATE INTERPOLATION OF SCATTERED DATA.
C              THE INTERPOLATION IS GENERATED ON A GRID.  
C              THE BILINEAR INTERPOLATION WORKS ON DATA THAT FORMS A
C              GRID TO POINTS NOT ON THE GRID WHILE THIS ROUTINE
C              INTERPOLATES NON-GRIDDED DATA TO FORM A GRID.
C              A TYPICAL USE OF THIS ROUTINE IS TO GENERATE A CONTOUR
C              PLOT FROM NON-GRIDDED DATA.
C              (GENERATE INTERPOLATED POINTS).
C     INPUT  ARGUMENTS--Z      = SINGLE PRECISION VARIABLE
C                                CONTAINING THE ORIGINAL
C                                Z AXIS DATA POINTS.
C                     --Y      = SINGLE PRECISION VARIABLE
C                                CONTAINING THE ORIGINAL
C                                VERTICAL AXIS DATA POINTS.
C                     --X      = SINGLE PRECISION VARIABLE
C                                CONTAINING THE ORIGINAL
C                                HORIZONTAL AXIS DATA POINTS.
C                     --Y2     = SINGLE PRECISION VARIABLE
C                                CONTAINING THE DESIRED
C                                VERTICAL AXIS INTERPOLATION
C                     --X2     = SINGLE PRECISION VARIABLE
C                                CONTAINING THE DESIRED
C                                HORIZONTAL AXIS INTERPOLATION
C                                POINTS.
C     OUTPUT ARGUMENTS--Z2     = SINGLE PRECISION VARIABLE
C                                CONTAINING THE COMPUTED
C                                Z AXIS INTERPOLATION
C                                POINTS.
C     NOTE--IT IS PROBABLY NOT PERMISSIBLE TO HAVE THE OUTPUT VECTOR
C           Y2(.) BEING IDENTICAL TO THE INPUT VECTOR Y(.)
C     NOTE--THIS SUBROUTINE DOES NOT ASSUME THAT THE INPUT
C           DATA IS ALREADY SORTED ACCORDING TO THE
C           HORIZONTAL AXIS VARIABLE.
C           SUCH SORTING IS DOEN HEREIN.
C     CAUTION--THE INPUT VECTORS Y AND X ARE SORTED HEREIN
C              AND SO MAY BE DIFFERENT UPON LEAVING THIS SUBROUTINE
C              THAN UPON ENTERING THIS SUBROUTINE.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           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--94/5
C     ORIGINAL VERSION--MAY       1994.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGG3
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 ISTEPN
      CHARACTER*4 ISUBRO
C
      CHARACTER*4 IHP
      CHARACTER*4 IHP2
      CHARACTER*4 IHWUSE
      CHARACTER*4 MESSAG
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOPA.INC'
C
      DIMENSION Z(*)
      DIMENSION Y(*)
      DIMENSION X(*)
      DIMENSION X2(*)
      DIMENSION Y2(*)
      DIMENSION Z2(*)
C
      DIMENSION YTEMP(MAXOBV)
      DIMENSION XTEMP(MAXOBV)
      DIMENSION YDIST(MAXOBV)
      DIMENSION XDIST(MAXOBV)
      DIMENSION ZDIST(MAXOBV)
      DIMENSION ZTEMP2(MAXOBV)
      DIMENSION ZTEMP(MAXOBV)
      DIMENSION XNEW(MAXOBV)
      DIMENSION YNEW(MAXOBV)
      DIMENSION IWORK(7*MAXOBV)
      DIMENSION WORK(7*MAXOBV)
C
      INCLUDE 'DPCOZZ.INC'
      INCLUDE 'DPCOZ2.INC'
      INCLUDE 'DPCOZI.INC'
      EQUIVALENCE (G2RBAG(IGAR11),YTEMP(1))
      EQUIVALENCE (G2RBAG(IGAR12),YDIST(1))
      EQUIVALENCE (G2RBAG(IGAR13),XDIST(1))
      EQUIVALENCE (G2RBAG(IGAR14),ZDIST(1))
      EQUIVALENCE (G2RBAG(IGAR15),ZTEMP2(1))
      EQUIVALENCE (G2RBAG(IGAR16),ZTEMP(1))
      EQUIVALENCE (G2RBAG(IGAR17),XTEMP(1))
      EQUIVALENCE (G2RBAG(IGAR18),XNEW(1))
      EQUIVALENCE (G2RBAG(IGAR19),YNEW(1))
      EQUIVALENCE (G2RBAG(IGAR20),WORK(1))
      EQUIVALENCE (IGARBG(1),IWORK(1))
CCCCC END CHANGE
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
      INCLUDE 'DPCOHK.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
      ISUBN1='INT2'
      ISUBN2='D   '
C
      IERROR='NO'
C
      IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'NT2D')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF INT2D--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)N
   52 FORMAT('N = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO55I=1,N
      WRITE(ICOUT,56)I,Z(I),Y(I),X(I)
   56 FORMAT('I,Z(I),Y(I),X(I) = ',I8,3E15.7)
      CALL DPWRST('XXX','BUG ')
   55 CONTINUE
      WRITE(ICOUT,62)NX,NY
   62 FORMAT('NX, NY = ',2I8)
      CALL DPWRST('XXX','BUG ')
      DO65I=1,NX
      WRITE(ICOUT,66)I,X2(I)
   66 FORMAT('I,X2(I) = ',I8,E15.7)
      CALL DPWRST('XXX','BUG ')
   65 CONTINUE
      DO75I=1,NY
      WRITE(ICOUT,76)I,Y2(I)
   76 FORMAT('I,Y2(I) = ',I8,E15.7)
      CALL DPWRST('XXX','BUG ')
   75 CONTINUE
   90 CONTINUE
C
C               ****************************************
C               **  STEP 11--                         **
C               **  SORT THE INPUT DATA ACCORDING     **
C               **  TO THE HORIZONTAL AXIS VARIABLE   **
C               ****************************************
C
      ISTEPN='11'
      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'NT2D')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      DO1010,I=1,N
      XTEMP(I)=X(I)
 1010 CONTINUE
C
      CALL SORTC(X,Y,N,X,Y)
      CALL SORTC(XTEMP,Z,N,XTEMP,Z)
C
C               *******************************************************
C               **  STEP 12--                                        **
C               **  DETERMINE THE NUMBER OF DISTINCT X VALUES        **
C               *******************************************************
C
      ISTEPN='12'
      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'NT2D')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      NDISTX=0
      DO1210I=1,N
      IF(NDISTX.EQ.0)GOTO1220
      DO1215I2=1,NDISTX
      IF(X(I).EQ.XDIST(I2))GOTO1210
 1215 CONTINUE
 1220 CONTINUE
      NDISTX=NDISTX+1
      XDIST(NDISTX)=X(I)
 1210 CONTINUE
C
      CALL SORT(XDIST,NDISTX,XDIST)
C
C               *******************************************************
C               **  STEP 13--                                        **
C               **  DETERMINE THE NUMBER OF DISTINCT Y VALUES        **
C               *******************************************************
C
      ISTEPN='13'
      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'NT2D')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      NDISTY=0
      DO1310I=1,N
      IF(NDISTY.EQ.0)GOTO1320
      DO1315I2=1,NDISTY
      IF(Y(I).EQ.YDIST(I2))GOTO1310
 1315 CONTINUE
 1320 CONTINUE
      NDISTY=NDISTY+1
      YDIST(NDISTY)=Y(I)
 1310 CONTINUE
C
      CALL SORT(YDIST,NDISTY,YDIST)
C
C               *******************************************************
C               **  STEP 14--                                        **
C               **  SORT Y ASSOCIATED WITH EACH DISTINCT X VALUE     **
C               **  CHECK FOR REPLICATION OF POINTS                  **
C               **  IF ALL DISTINCT (THAT IS, NO REPLICATION),     **
C               **  (THAT IS, HAVE NO REPLICATION),                **
C               **  THEN COPY OVER Z VALUES.                       **
C               **  IF NOT ALL DISTINCT                            **
C               **  (THAT IS, HAVE SOME REPLICATION),              **
C               **  THEN COMPUTE A MEAN VALUE OVER THE REPLICATES  **
C               **  AND TREAT THAT AS THE COMMON VALUE.            **
C               *******************************************************
C
      ISTEPN='14'
      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'NT2D')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      NUMZ=0
      ISTART=1
      DO1410I=1,NDISTX
        XT=XDIST(I)
        ICOUNT=0
        DO1420J=ISTART,N
        IF(X(J).EQ.XT)THEN
          IF(ICOUNT.EQ.0)IFRST=J
          ICOUNT=ICOUNT+1
          YTEMP(ICOUNT)=Y(J)
          ZTEMP(ICOUNT)=Z(J)
          ILAST=J
        ELSEIF(X(J).GT.XT)THEN
          GOTO1421
        ENDIF
 1420   CONTINUE
 1421   CONTINUE
C
        ISTART=ILAST+1
        CALL SORTC(YTEMP,ZTEMP,ICOUNT,YTEMP,ZTEMP)
        DO1471K=1,NDISTY
          TAG=YDIST(K)
          J=0
          DO1472II=1,ICOUNT
            IF(YTEMP(II).EQ.TAG)THEN
              J=J+1
              ZTEMP2(J)=ZTEMP(II)
            END IF
 1472     CONTINUE
          NI=J
          IF(NI.EQ.1)THEN
            NUMZ=NUMZ+1
            ZDIST(NUMZ)=ZTEMP2(1)
            XNEW(NUMZ)=XT
            YNEW(NUMZ)=TAG
          ELSE IF(NI.GT.1)THEN
            CALL MEAN(ZTEMP2,NI,IWRITE,ZMEAN,IBUGG3,IERROR)
            NUMZ=NUMZ+1
            ZDIST(NUMZ)=ZMEAN
            XNEW(NUMZ)=XT
            YNEW(NUMZ)=TAG
          ENDIF
 1471   CONTINUE
C
 1410 CONTINUE
C
C               *******************************************************
C               **  STEP 15--                                        **
C               **  DETERMINE THE NUMBER OF DISTINCT X VALUES        **
C               **  FOR THE INTERPOLATION POINTS                     **
C               *******************************************************
C
      ISTEPN='15'
      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'NT2D')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      NDISTX=0
      DO1510I=1,NX
      IF(NDISTX.EQ.0)GOTO1520
      DO1515I2=1,NDISTX
      IF(X2(I).EQ.XDIST(I2))GOTO1510
 1515 CONTINUE
 1520 CONTINUE
      NDISTX=NDISTX+1
      XDIST(NDISTX)=X2(I)
 1510 CONTINUE
C
      CALL SORT(XDIST,NDISTX,XDIST)
C
C               *******************************************************
C               **  STEP 16--                                        **
C               **  DETERMINE THE NUMBER OF DISTINCT Y VALUES        **
C               **  FOR THE INTERPOLATION POINTS                     **
C               *******************************************************
C
      ISTEPN='16'
      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'NT2D')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      NDISTY=0
      DO1610I=1,NY
      IF(NDISTY.EQ.0)GOTO1620
      DO1615I2=1,NDISTY
      IF(Y2(I).EQ.YDIST(I2))GOTO1610
 1615 CONTINUE
 1620 CONTINUE
      NDISTY=NDISTY+1
      YDIST(NDISTY)=Y2(I)
 1610 CONTINUE
C
      CALL SORT(YDIST,NDISTY,YDIST)
C
      N2=NDISTX*NDISTY
      IF(N2.LE.MAXOBV)GOTO1699
C
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1651)
 1651 FORMAT('***** ERROR IN INT2D--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1652)
 1652 FORMAT('      THE NUMBER OF REQUESTED INTERPOLATION POINTS')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1653)MAXOBV
 1653 FORMAT('      WILL EXCEED THE MAXIMUM ALLOWABLE OF ',I8,'.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1654)
 1654 FORMAT('      THE NUMBER OF DISTINCT X AND Y INTERPOLATION')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1655)NDISTX,NDISTY
 1655 FORMAT('      IS ',I8,' AND ',I8,' RESPECTIVELY.          *****')
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
C
 1699 CONTINUE
C
C               ********************************************
C               **  STEP 17--                             **
C               **  CHECK FOR USER PARAMETER NPPR         **
C               ********************************************
C
 1700 CONTINUE
      NPPR=10
C
      ANPPR=10.0
      IHP='NPPR'
      IHP2='    '
      IHWUSE='P'
      MESSAG='NO'
      CALL CHECKN(IHP,IHP2,IHWUSE,
     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
     1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR)
      IF(IERROR.EQ.'YES')GOTO1710
      ANPPR=VALUE(ILOCP)
 1710 CONTINUE
C
      NPPR=INT(ANPPR+0.5)
      IF(NPPR.GE.3)GOTO1719
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1711)
 1711 FORMAT('***** ERROR IN INT2D--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1712)
 1712 FORMAT('      THE AVERAGE NUMBER OF POINTS PER REGION MUST')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1714)
 1714 FORMAT('      BE GREATER THAN OR EQUAL TO 3;')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1715)
 1715 FORMAT('      SUCH WAS NOT THE CASE HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1716)NPPR
 1716 FORMAT('      THE CURRENT VALUE OF NPPR IS ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1717)
 1717 FORMAT('      A VALUE OF 10 WILL BE USED')
      CALL DPWRST('XXX','BUG ')
      NPPR=10
 1719 CONTINUE
C
C
C
C               ********************************************
C               **  STEP 18--                             **
C               **  COMPUTE INTERPOLATED VALUES           **
C               ********************************************
C
      NIWK=7*MAXOBV
      NWK=7*MAXOBV
      CALL INT2D2(ZDIST,YNEW,XNEW,N,YDIST,NY,XDIST,NX,Z2,N2,
     1NPPR,NIWK,NWK,WORK,IWORK,
     1IBUGG3,ISUBRO,IERROR)
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'NT2D')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF INT2D--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)N,N2
 9012 FORMAT('N,N2 = ',2I8)
      CALL DPWRST('XXX','BUG ')
      DO9042I=1,N2
      WRITE(ICOUT,9043)I,X2(I),Y2(I),Z2(I)
 9043 FORMAT('I,X2(I),Y2(I),Z2(I) = ',I8,3E15.7)
      CALL DPWRST('XXX','BUG ')
 9042 CONTINUE
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE INT2D2(Z,Y,X,N,Y2,NY,X2,NX,Z2,N2,
     1NPPR,NIWK,NWK,WORK,IWORK,
     1IBUGG3,ISUBRO,IERROR)
C
C     PURPOSE--COMPUTE BI-VARIATE INTERPOLATION OF A VARIABLE
C              (GENERATE INTERPOLATED POINTS).
C              THIS ROUTINE STARTS FROM SCATTERED DATA AND INTERPOLATES
C              POINTS ON A GRID.  NOTE THAT X2 AND Y2 DEFINE THE GRID
C              TO INTERPOLATE OVER.
C              THIS ROUTINE USES THE LOTPS ROUTINE WRITTEN BY RICHARD
C              FRANKE OF THE NAVAL POSTGRADUATE SCHOOL.
C     INPUT  ARGUMENTS--Z      = SINGLE PRECISION VARIABLE
C                                CONTAINING THE ORIGINAL
C                                Z AXIS DATA POINTS.
C                     --Y      = SINGLE PRECISION VARIABLE
C                                CONTAINING THE ORIGINAL
C                                VERTICAL AXIS DATA POINTS.
C                     --X      = SINGLE PRECISION VARIABLE
C                                CONTAINING THE ORIGINAL
C                                HORIZONTAL AXIS DATA POINTS.
C                     --Y2     = SINGLE PRECISION VARIABLE
C                                CONTAINING THE DESIRED
C                                VERTICAL AXIS INTERPOLATION
C                     --X2     = SINGLE PRECISION VARIABLE
C                                CONTAINING THE DESIRED
C                                HORIZONTAL AXIS INTERPOLATION
C                                POINTS.
C     OUTPUT ARGUMENTS--Z2     = SINGLE PRECISION VARIABLE
C                                CONTAINING THE COMPUTED
C                                VERTICAL AXIS INTERPOLATION
C                                POINTS.
C     NOTE--IT IS PROBABLY NOT PERMISSIBLE TO HAVE THE OUTPUT VECTOR 
C           Z2(.) BEING IDENTICAL TO THE INPUT VECTOR Z(.)
C     NOTE--THE X AND Y POINTS ARE ASSUMED TO LIE ON A RECTANGULAR GRID
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           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--94/5
C     ORIGINAL VERSION--MAY       1994.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IBUGG3
      CHARACTER*4 ISUBRO
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
C
      DIMENSION Z(*)
      DIMENSION Y(*)
      DIMENSION X(*)
      DIMENSION Z2(*)
      DIMENSION Y2(*)
      DIMENSION X2(*)
      DIMENSION WORK(*)
      DIMENSION IWORK(*)
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
      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='INT2'
      ISUBN2='D2  '
C
      IERROR='NO'
C
      DO10I=1,N2
      Z2(I)=0.0
 10   CONTINUE
C
      IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'T2D2')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF INT2D2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)NX,NY
   52 FORMAT('NX, NY = ',2I8)
      CALL DPWRST('XXX','BUG ')
      DO54I=1,N
      WRITE(ICOUT,53)I,X(I),Y(I),Z(I)
      CALL DPWRST('XXX','BUG ')
 53   FORMAT('I,X(I),Y(I),Z(I) = ',I8,3E15.7)
      CALL DPWRST('XXX','BUG ')
 54   CONTINUE
      WRITE(ICOUT,62)N2
   62 FORMAT('N2 = ',I8)
      CALL DPWRST('XXX','BUG ')
   90 CONTINUE
C
C               ****************************************
C               **  STEP 31--
C               **  COMPUTE INTERPOLATION VALUES
C               ****************************************
C
      IMODE=1
      CALL LOTPS(IMODE,NPPR,N,X,Y,Z,NX,X2,NY,Y2,IWORK,NIWK,NIWKU,
     1WORK,NWK,NWKU,Z2,KERR)
      IF(KERR.GT.0)THEN
        IERROR='YES'
        GOTO9000
      ENDIF
C
 3100 CONTINUE
C
C               ****************************************
C               **  STEP 41--
C               **  IF CALLED FOR,
C               **  WRITE OUT INTERPOLATION VALUES
C               ****************************************
C
      IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'T2D2')GOTO4190
      J1=0
      DO4100I=1,NX
      DO4110J=1,NY
      J1=J1+1
      WRITE(ICOUT,4112)X2(I),Y2(J),Z2(J1)
      CALL DPWRST('XXX','BUG ')
 4112 FORMAT('I,J,X2(I),Y2(J),Z2(I,J) = ',2I8,3E15.7)
 4110 CONTINUE
 4100 CONTINUE
 4190 CONTINUE
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'T2D2')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF INT2D2--')
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      INTEGER FUNCTION ISAMAX(N,SX,INCX)
C***BEGIN PROLOGUE  ISAMAX
C***DATE WRITTEN   791001   (YYMMDD)
C***REVISION DATE  820801   (YYMMDD)
C***CATEGORY NO.  D1A2
C***KEYWORDS  BLAS,LINEAR ALGEBRA,MAXIMUM COMPONENT,VECTOR
C***AUTHOR  LAWSON, C. L., (JPL)
C           HANSON, R. J., (SNLA)
C           KINCAID, D. R., (U. OF TEXAS)
C           KROGH, F. T., (JPL)
C***PURPOSE  Find largest component of s.p. vector
C***DESCRIPTION
C
C                B L A S  Subprogram
C    Description of Parameters
C
C     --Input--
C        N  number of elements in input vector(s)
C       SX  single precision vector with N elements
C     INCX  storage spacing between elements of SX
C
C     --Output--
C   ISAMAX  smallest index (zero if N .LE. 0)
C
C     Find smallest index of maximum magnitude of single precision SX.
C     ISAMAX =  first I, I = 1 to N, to minimize  ABS(SX(1-INCX+I*INCX)
C***REFERENCES  LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T.,
C                 *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*,
C                 ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL
C                 SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323
C***ROUTINES CALLED  (NONE)
C***END PROLOGUE  ISAMAX
C
      REAL SX(*),SMAX,XMAG
C***FIRST EXECUTABLE STATEMENT  ISAMAX
      ISAMAX = 0
      IF(N.LE.0) RETURN
      ISAMAX = 1
      IF(N.LE.1)RETURN
      IF(INCX.EQ.1)GOTO 20
C
C        CODE FOR INCREMENTS NOT EQUAL TO 1.
C
      SMAX = ABS(SX(1))
      NS = N*INCX
      II = 1
          DO 10 I=1,NS,INCX
          XMAG = ABS(SX(I))
          IF(XMAG.LE.SMAX) GO TO 5
          ISAMAX = II
          SMAX = XMAG
    5     II = II + 1
   10     CONTINUE
      RETURN
C
C        CODE FOR INCREMENTS EQUAL TO 1.
C
   20 SMAX = ABS(SX(1))
      DO 30 I = 2,N
         XMAG = ABS(SX(I))
         IF(XMAG.LE.SMAX) GO TO 30
         ISAMAX = I
         SMAX = XMAG
   30 CONTINUE
      RETURN
      END
      subroutine isort (n, ix)
c-----------------------------------------------------------------------
c  Name:       ISORT  (Used by Fisher Exact Test)
c
c  Purpose:    Shell sort for an integer vector.
c
c  Usage:      CALL ISORT (N, IX)
c
c  Arguments:
c     N      - Lenth of vector IX.  (Input)
c     IX     - Vector to be sorted.  (Input/output)
c-----------------------------------------------------------------------
c                                  SPECIFICATIONS FOR ARGUMENTS
      integer    n, ix(*)
c                                  SPECIFICATIONS FOR LOCAL VARIABLES
      integer    i, ikey, il(10), it, iu(10), j, kl, ku, m
c                                  SPECIFICATIONS FOR SUBROUTINES
CCCCC external   prterr
c                                  Sort IX
      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
      m = 1
      i = 1
      j = n
   10 if (i .ge. j) go to 40
      kl   = i
      ku   = j
      ikey = i
      j    = j + 1
c                                  Find element in first half
   20 i = i + 1
      if (i .lt. j) then
         if (ix(ikey) .gt. ix(i)) go to 20
      end if
c                                  Find element in second half
   30 j = j - 1
      if (ix(j) .gt. ix(ikey)) go to 30
c                                  Interchange
      if (i .lt. j) then
         it    = ix(i)
         ix(i) = ix(j)
         ix(j) = it
         go to 20
      end if
      it       = ix(ikey)
      ix(ikey) = ix(j)
      ix(j)    = it
c                                  Save upper and lower subscripts of
c                                  the array yet to be sorted
      if (m .lt. 11) then
         if (j-kl .lt. ku-j) then
            il(m) = j + 1
            iu(m) = ku
            i     = kl
            j     = j - 1
         else
            il(m) = kl
            iu(m) = j - 1
            i     = j + 1
            j     = ku
         end if
         m = m + 1
         go to 10
      else
CCCCC    call prterr (20, 'This should never occur.')
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** ERROR FROM ISORT--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)
 9013 FORMAT('      This should never occur.')
      CALL DPWRST('XXX','BUG ')
      end if
c                                  Use another segment
   40 m = m - 1
      if (m .eq. 0) go to 9000
      i = il(m)
      j = iu(m)
      go to 10
c
 9000 return
      end
      SUBROUTINE IWECDF(X,GAMMA,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE INVERTED WEIBULL
C              DISTRIBUTION WITH SINGLE PRECISION
C              TAIL LENGTH PARAMETER = GAMMA.
C              THE INVERTED WEIBULL DISTRIBUTION USED
C              HEREIN IS DEFINED FOR ALL POSITIVE X,
C              AND HAS THE CUMULATIVE DISTRIBUTION  FUNCTION
C              F(X) = EXP(-(X**(-GAMMA))).
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE NON-NEGATIVE.
C                     --GAMMA  = THE SHAPE PARAMETER
C                                GAMMA SHOULD BE POSITIVE.
C     OUTPUT ARGUMENTS--CDF    = THE SINGLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE CDF FOR THE WEIBULL DISTRIBUTION
C             WITH TAIL LENGTH PARAMETER = GAMMA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE NON-NEGATIVE.
C                 --GAMMA SHOULD BE POSITIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--EXP.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--XX
C               --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, XX.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           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.9
C     ORIGINAL VERSION--SEPTEMBER 2001.
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DGAMMA
      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
      CDF=0.0
C
      IF(GAMMA.LE.0)THEN
        WRITE(ICOUT,15)
   15   FORMAT('***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE ',
     1         'IWECDF SUBROUTINE IS NON-POSITIVE *****')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)GAMMA
   46   FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9000
      ENDIF
C
      IF(X.LE.0.0)THEN
        CDF=0.0
      ELSE
        DGAMMA=DBLE(GAMMA)
        DX=DBLE(X)
        DCDF=DEXP(-(DX**(-DGAMMA)))
        CDF=REAL(DCDF)
      ENDIF
C
 9000 CONTINUE
C
      RETURN
      END
      SUBROUTINE IWEPDF(X,GAMMA,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE INVERTED WEIBULL
C              DISTRIBUTION WITH SINGLE PRECISION
C              TAIL LENGTH PARAMETER = GAMMA.
C              THE INVERTED WEIBULL DISTRIBUTION USED
C              HEREIN IS DEFINED FOR ALL POSITIVE X,
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C              F(X) = GAMMA*(X**(-GAMMA-1))*EXP(-(X**(-GAMMA))).
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                     --GAMMA  = THE SHAPE PARAMETER
C                                GAMMA SHOULD BE POSITIVE.
C     OUTPUT ARGUMENTS--PDF    = THE SINGLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE PDF FOR THE WEIBULL DISTRIBUTION
C             WITH TAIL LENGHT PARAMETER = GAMMA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--GAMMA SHOULD BE POSITIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--EXP.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--XX
C               --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, XX.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           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.9
C     ORIGINAL VERSION--SEPTEMBER 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(GAMMA.LE.0)THEN
        WRITE(ICOUT,15)
   15   FORMAT('***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE ',
     1         'IWEPDF SUBROUTINE IS NON-POSITIVE *****')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)GAMMA
   46   FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9000
      ENDIF
C
      IF(X.LE.0.0)THEN
        PDF=0.0
      ELSE
        DGAMMA=DBLE(GAMMA)
        DX=DBLE(X)
        DPDF=DGAMMA*(DX**(-DGAMMA-1.0D0))*DEXP(-(DX**(-DGAMMA)))
        PDF=REAL(DPDF)
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE IWEPPF(P,GAMMA,PPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE INVERTED WEIBULL
C              DISTRIBUTION WITH SINGLE PRECISION
C              TAIL LENGTH PARAMETER = GAMMA.
C              THE INVERTED WEIBULL DISTRIBUTION USED
C              HEREIN IS DEFINED FOR ALL POSITIVE X,
C              AND HAS THE PERCENT POINT FUNCTION
C              G(P) = -[LOG(P)]**(-1/GAMMA)
C              NOTE THAT THE PERCENT POINT FUNCTION OF A DISTRIBUTION
C              IS IDENTICALLY THE SAME AS THE INVERSE CUMULATIVE
C              DISTRIBUTION FUNCTION OF THE DISTRIBUTION.
C     INPUT  ARGUMENTS--P      = THE SINGLE PRECISION VALUE
C                                (BETWEEN 0.0 (INCLUSIVELY)
C                                AND 1.0 (EXCLUSIVELY))
C                                AT WHICH THE PERCENT POINT
C                                FUNCTION IS TO BE EVALUATED.
C                     --GAMMA  = THE SINGLE PRECISION VALUE
C                                OF THE TAIL LENGTH PARAMETER.
C                                GAMMA SHOULD BE POSITIVE.
C     OUTPUT ARGUMENTS--PPF    = THE SINGLE PRECISION PERCENT
C                                POINT FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PERCENT POINT FUNCTION .
C             VALUE PPF FOR THE WEIBULL DISTRIBUTION
C             WITH TAIL LENGTH PARAMETER VALUE = GAMMA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--GAMMA SHOULD BE POSITIVE.
C                 --P SHOULD BE BETWEEN 0.0 (INCLUSIVELY)
C                   AND 1.0 (EXCLUSIVELY).
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--ALOG.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--XX
C               --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, XX.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           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.9
C     ORIGINAL VERSION--SEPTEMBER 2001.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DOUBLE PRECISION DP
      DOUBLE PRECISION DGAMMA
      DOUBLE PRECISION DPPF
C
C---------------------------------------------------------------------
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
      PPF=0.0
C
      IF(P.LT.0.0.OR.P.GE.1.0)THEN
        WRITE(ICOUT,1)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)P
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
        GOTO9000
      ENDIF
      IF(GAMMA.LE.0.0)THEN
        WRITE(ICOUT,15)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)GAMMA
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
        GOTO9000
      ENDIF
    1 FORMAT('***** FATAL ERROR--THE FIRST INPUT ARGUMENT TO THE ',
     1'IWEPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL')
   15 FORMAT('***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE ',
     1'IWEPPF SUBROUTINE IS NON-POSITIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
      DGAMMA=DBLE(GAMMA)
      DP=DBLE(P)
      DTERM1=-DLOG(DP)
      DTERM2=-1.0D0/DGAMMA
      DPPF=DTERM1**DTERM2
      PPF=REAL(DPPF)
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE IWERAN(N,GAMMA,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE INVERTED WEIBULL DISTRIBUTION
C              WITH TAIL LENGTH PARAMETER VALUE = GAMMA.
C              THE PROTOTYPE WEIBULL DISTRIBUTION USED
C              HEREIN IS DEFINED FOR ALL POSITIVE X,
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C              F(X) = GAMMA * (X**(-GAMMA-1)) * EXP(-(X**-GAMMA)).
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --GAMMA  = THE SINGLE PRECISION VALUE OF THE
C                                TAIL LENGTH PARAMETER.
C                                GAMMA SHOULD BE POSITIVE.
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST N)
C                                INTO WHICH THE GENERATED
C                                RANDOM SAMPLE WILL BE PLACED.
C     OUTPUT--A RANDOM SAMPLE OF SIZE N
C             FROM THE INVERTED WEIBULL DISTRIBUTION
C             WITH TAIL LENGTH PARAMETER VALUE = GAMMA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C                 --GAMMA SHOULD BE POSITIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--ALOG.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--XX
C               --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 2ND. ED., 1994.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           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.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
      IF(GAMMA.LE.0.0)THEN
        WRITE(ICOUT,15)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)GAMMA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
    5 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ',
     1'IWERAN SUBROUTINE IS NON-POSITIVE *****')
   15 FORMAT('***** FATAL ERROR--THE 2ND INPUT ARGUMENT TO THE ',
     1'IWERAN SUBROUTINE IS NON-POSITIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
C
C     GENERATE N UNIFORM (0,1) RANDOM NUMBERS;
C
      CALL UNIRAN(N,ISEED,X)
C
C     GENERATE N INVERTED WEIBULL DISTRIBUTION RANDOM NUMBERS
C     USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD.
C
      DO100I=1,N
        CALL IWEPPF(X(I),GAMMA,XTEMP)
        X(I)=XTEMP
  100 CONTINUE
C
 9000 CONTINUE
      RETURN
      END
      integer function iwork (iwkmax, iwkpt, number, itype)
c-----------------------------------------------------------------------
c  Name:       IWORK
c
c  Purpose:    Routine for allocating workspace.
c
c  Usage:      IWORK (IWKMAX, IWKPT, NUMBER, ITYPE)
c
c  Arguments:
c     IWKMAX - Maximum length of workspace.  (Input)
c     IWKPT  - Amount of workspace currently allocated.  (Input/output)
c     NUMBER - Number of elements of workspace desired.  (Input)
c     ITYPE  - Worspace type.  (Input)
c              ITYPE  TYPE
c                2    Integer
c                3    Real
c                4    Double Precision
c     IWORK  - Index in RWRK, DWRK, or IWRK of the beginning of the
c              first element in the workspace array.  (Output)
c-----------------------------------------------------------------------
c                                  SPECIFICATIONS FOR ARGUMENTS
      integer    iwkmax, iwkpt, number, itype
c                                  SPECIFICATIONS FOR INTRINSICS
      intrinsic  mod
      integer    mod
c                                  SPECIFICATIONS FOR SUBROUTINES
CCCCC external   prterr
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
      iwork = iwkpt
      if (itype.eq.2 .or. itype.eq.3) then
         iwkpt = iwkpt + number
      else
         if (mod(iwork,2) .ne. 0) iwork = iwork + 1
         iwkpt = iwkpt + 2*number
         iwork = iwork/2
      end if
      if (iwkpt .gt. iwkmax+1) then
CCCCC    call prterr (40, 'Out of workspace.')
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** ERROR FROM IWORK--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)
 9013 FORMAT('      Out of workspace.')
      CALL DPWRST('XXX','BUG ')
      end if
      return
      end
      DOUBLE PRECISION FUNCTION J1FUN(DX)
C
C     PURPOSE--THIS FUNCTION COMPUTES THE FOLLOWING FUNCTION:
C                 J(X,A) = INTEGRAL[0 to X][T**(A-1)*LOG(T)*EXP(-T)]dt
C              THIS FUNCTION IS USED IN COMPUTING MAXIMUM LIKELIHOOD
C              ESTIMATES FOR THE GAMMA DISTRIBUTION FOR MULTIPLY
C              CENSORED DATA.
C     INPUT  ARGUMENTS--DX     = THE DOUBLE PRECISION VALUE AT
C                                WHICH THE J(X,A) FUNCTION IS TO BE
C                                EVALUATED.
C     OUTPUT ARGUMENTS--J1FUN  = THE DOUBLE PRECISION FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION VALUE FOR THE J(X,A) FUNCTION.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--DLOG.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCE--KARL BURY, "STATISTICAL DISTRIBUTIONS IN
C                ENGINEERING", CAMBRIDGE UNIVERSITY PRESS,
C                1999, CHAPTER 13.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           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-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
C
      DOUBLE PRECISION DX
C
      DOUBLE PRECISION DA
      COMMON/J1COM/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
      J1FUN=DX**(DA-1.0D0)*DLOG(DX)*DEXP(-DX)
C
      RETURN
      END
      DOUBLE PRECISION FUNCTION J2FUN(DX)
C
C     PURPOSE--THIS FUNCTION COMPUTES THE FOLLOWING FUNCTION:
C                 J(X,A) = INTEGRAL[0 to X]
C                          [T**(A-1)*(LOG(T)**2)**EXP(-T)]dt
C              THIS FUNCTION IS USED IN COMPUTING THE STANDARD
C              ERRORS OF THE MAXIMUM LIKELIHOOD ESTIMATES FOR THE
C              GAMMA DISTRIBUTION FOR MULTIPLY CENSORED DATA.
C     INPUT  ARGUMENTS--DX     = THE DOUBLE PRECISION VALUE AT
C                                WHICH THE J(X,A) FUNCTION IS TO BE
C                                EVALUATED.
C     OUTPUT ARGUMENTS--J2FUN  = THE DOUBLE PRECISION FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION VALUE FOR THE J(X,A) FUNCTION.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--DLOG.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCE--KARL BURY, "STATISTICAL DISTRIBUTIONS IN
C                ENGINEERING", CAMBRIDGE UNIVERSITY PRESS,
C                1999, CHAPTER 13.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           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-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
C
      DOUBLE PRECISION DX
C
      DOUBLE PRECISION DA
      COMMON/J1COM/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
      J2FUN=DX**(DA-1.0D0)*(DLOG(DX)**2)*DEXP(-DX)
C
      RETURN
      END
      DOUBLE PRECISION FUNCTION J0INT(XVALUE)
C
C   DESCRIPTION:
C
C      This function calculates the integral of the Bessel
C      function J0, defined as
C
C        J0INT(x) = {integral 0 to x} J0(t) dt
C
C      The code uses Chebyshev expansions whose coefficients are
C      given to 20 decimal places.
C
C
C   ERROR RETURNS:
C
C      If the value of |x| is too large, it is impossible to 
C      accurately compute the trigonometric functions used. An
C      error message is printed, and the function returns the
C      value 1.0.
C
C
C   MACHINE-DEPENDENT CONSTANTS:
C
C      NTERM1 - The no. of terms to be used from the array
C                ARJ01. The recommended value is such that
C                   ABS(ARJ01(NTERM1)) < EPS/100, provided that
C
C      NTERM2 - The no. of terms to be used from the array
C                ARJ0A1. The recommended value is such that
C                   ABS(ARJ0A1(NTERM2)) < EPS/100, provided that
C
C      NTERM3 - The no. of terms to be used from the array
C                ARJ0A2. The recommended value is such that
C                   ABS(ARJ0A2(NTERM3)) < EPS/100, provided that
C
C      XLOW - The value of |x| below which J0INT(x) = x to
C             machine-precision. The recommended value is
C                 sqrt(12*EPSNEG)
C
C      XHIGH - The value of |x| above which it is impossible
C              to calculate (x-pi/4) accurately. The recommended
C              value is      1/EPSNEG
C
C      For values of EPS and EPSNEG for various machine/compiler
C      combinations refer to the file MACHCON.TXT.
C
C      The machine-dependent constants are computed internally by
C      using the D1MACH subroutine.
C
C
C   INTRINSIC FUNCTIONS USED:
C
C      COS , SIN , SQRT
C
C
C   OTHER MISCFUN SUBROUTINES USED:
C
C          CHEVAL , ERRPRN, D1MACH
C
C
C   AUTHOR:
C          Dr. Allan J. MacLeod,
C          Dept. of Mathematics and Statistics,
C          University of Paisley,
C          Paisley,
C          SCOTLAND
C          PA1 2BE
C
C          (e-mail:   macl_ms0@paisley.ac.uk )
C
C
C   LATEST REVISION:
C                    23 January, 1996
C
      INTEGER IND,NTERM1,NTERM2,NTERM3
      DOUBLE PRECISION ARJ01(0:23),ARJ0A1(0:21),ARJ0A2(0:18),
     1     CHEVAL,FIVE12,ONE,ONEHUN,ONE28,PIB41,PIB411,PIB412,
     2     PIB42,RT2BPI,SIXTEN,T,TEMP,TWELVE,X,XHIGH,XLOW,
     3     XMPI4,XVALUE,ZERO
CCCCC CHARACTER FNNAME*6,ERRMSG*26
CCCCC DATA FNNAME/'J0INT '/
CCCCC DATA ERRMSG/'ARGUMENT TOO LARGE IN SIZE'/
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOMC.INC'
      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,ONE/ 0.0 D 0 , 1.0 D 0 /
      DATA TWELVE,SIXTEN/ 12.0 D 0 , 16.0 D 0 /
      DATA ONEHUN,ONE28,FIVE12/ 100.0 D 0 , 128.0 D 0 , 512 D 0 /
      DATA RT2BPI/0.79788 45608 02865 35588 D 0/
      DATA PIB411,PIB412/ 201.0 D 0 , 256.0 D 0/
      DATA PIB42/0.24191 33974 48309 61566 D -3/      
      DATA ARJ01(0)/  0.38179 27932 16901 73518  D    0/
      DATA ARJ01(1)/ -0.21275 63635 05053 21870  D    0/
      DATA ARJ01(2)/  0.16754 21340 72157 94187  D    0/
      DATA ARJ01(3)/ -0.12853 20977 21963 98954  D    0/
      DATA ARJ01(4)/  0.10114 40545 57788 47013  D    0/
      DATA ARJ01(5)/ -0.91007 95343 20156 8859   D   -1/
      DATA ARJ01(6)/  0.64013 45264 65687 3103   D   -1/
      DATA ARJ01(7)/ -0.30669 63029 92675 4312   D   -1/
      DATA ARJ01(8)/  0.10308 36525 32506 4201   D   -1/
      DATA ARJ01(9)/ -0.25567 06503 99956 918    D   -2/
      DATA ARJ01(10)/ 0.48832 75580 57983 04     D   -3/
      DATA ARJ01(11)/-0.74249 35126 03607 7      D   -4/
      DATA ARJ01(12)/ 0.92226 05637 30861        D   -5/
      DATA ARJ01(13)/-0.95522 82830 7083         D   -6/
      DATA ARJ01(14)/ 0.83883 55845 986          D   -7/
      DATA ARJ01(15)/-0.63318 44888 58           D   -8/
      DATA ARJ01(16)/ 0.41560 50422 1            D   -9/
      DATA ARJ01(17)/-0.23955 29307              D  -10/
      DATA ARJ01(18)/ 0.12228 6885               D  -11/
      DATA ARJ01(19)/-0.55697 11                 D  -13/
      DATA ARJ01(20)/ 0.22782 0                  D  -14/
      DATA ARJ01(21)/-0.8417                     D  -16/
      DATA ARJ01(22)/ 0.282                      D  -17/
      DATA ARJ01(23)/-0.9                        D  -19/
      DATA ARJ0A1(0)/  1.24030 13303 75189 70827  D    0/
      DATA ARJ0A1(1)/ -0.47812 53536 32280 693    D   -2/
      DATA ARJ0A1(2)/  0.66131 48891 70667 8      D   -4/
      DATA ARJ0A1(3)/ -0.18604 27404 86349        D   -5/
      DATA ARJ0A1(4)/  0.83627 35565 080          D   -7/
      DATA ARJ0A1(5)/ -0.52585 70367 31           D   -8/
      DATA ARJ0A1(6)/  0.42606 36325 1            D   -9/
      DATA ARJ0A1(7)/ -0.42117 61024              D  -10/
      DATA ARJ0A1(8)/  0.48894 6426               D  -11/
      DATA ARJ0A1(9)/ -0.64834 929                D  -12/
      DATA ARJ0A1(10)/ 0.96172 34                 D  -13/
      DATA ARJ0A1(11)/-0.15703 67                 D  -13/
      DATA ARJ0A1(12)/ 0.27871 2                  D  -14/
      DATA ARJ0A1(13)/-0.53222                    D  -15/
      DATA ARJ0A1(14)/ 0.10844                    D  -15/
      DATA ARJ0A1(15)/-0.2342                     D  -16/
      DATA ARJ0A1(16)/ 0.533                      D  -17/
      DATA ARJ0A1(17)/-0.127                      D  -17/
      DATA ARJ0A1(18)/ 0.32                       D  -18/
      DATA ARJ0A1(19)/-0.8                        D  -19/
      DATA ARJ0A1(20)/ 0.2                        D  -19/
      DATA ARJ0A1(21)/-0.1                        D  -19/
      DATA ARJ0A2(0)/  1.99616 09630 13416 75339  D    0/
      DATA ARJ0A2(1)/ -0.19037 98192 46668 161    D   -2/
      DATA ARJ0A2(2)/  0.15397 10927 04422 6      D   -4/
      DATA ARJ0A2(3)/ -0.31145 08832 8103         D   -6/
      DATA ARJ0A2(4)/  0.11108 50971 321          D   -7/
      DATA ARJ0A2(5)/ -0.58666 78712 3            D   -9/
      DATA ARJ0A2(6)/  0.41399 26949              D  -10/
      DATA ARJ0A2(7)/ -0.36539 8763               D  -11/
      DATA ARJ0A2(8)/  0.38557 568                D  -12/
      DATA ARJ0A2(9)/ -0.47098 00                 D  -13/
      DATA ARJ0A2(10)/ 0.65022 0                  D  -14/
      DATA ARJ0A2(11)/-0.99624                    D  -15/
      DATA ARJ0A2(12)/ 0.16700                    D  -15/
      DATA ARJ0A2(13)/-0.3028                     D  -16/
      DATA ARJ0A2(14)/ 0.589                      D  -17/
      DATA ARJ0A2(15)/-0.122                      D  -17/
      DATA ARJ0A2(16)/ 0.27                       D  -18/
      DATA ARJ0A2(17)/-0.6                        D  -19/
      DATA ARJ0A2(18)/ 0.1                        D  -19/
C
C   Start computation
C
      X = XVALUE
      IND = 1
      IF ( X .LT. ZERO ) THEN
         X = -X
         IND = -1
      ENDIF
C
C   Compute the machine-dependent constants.
C
      TEMP = D1MACH(3)
      XHIGH = ONE / TEMP
C
C   Error test
C
      IF ( X .GT. XHIGH ) THEN
CCCCC    CALL ERRPRN(FNNAME,ERRMSG)
         WRITE(ICOUT,999)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,101)X
         CALL DPWRST('XXX','BUG ')
         J0INT = ONE
         IF ( IND .EQ. -1 ) J0INT = -J0INT
         RETURN
      ENDIF
  999 FORMAT(1X)
  101 FORMAT('***** ERROR FROM J0INT--SIZE OF THE INPUT ARGUMENT ',
     1        'IS TOO LARGE, ARGUMENT = ',G15.7)
C
C   continue with constants
C
      T = TEMP / ONEHUN
      IF ( X .LE. SIXTEN ) THEN
         DO 10 NTERM1 = 23 , 0 , -1
            IF ( ABS(ARJ01(NTERM1)) .GT. T ) GOTO 19
 10      CONTINUE
 19      XLOW = SQRT ( TWELVE * TEMP )
      ELSE
         DO 40 NTERM2 = 21 , 0 , -1
            IF ( ABS(ARJ0A1(NTERM2)) .GT. T ) GOTO 49
 40      CONTINUE
 49      DO 50 NTERM3 = 18 , 0 , -1
            IF ( ABS(ARJ0A2(NTERM3)) .GT. T ) GOTO 59
 50      CONTINUE
 59   ENDIF
C
C   Code for 0 <= |x| <= 16
C
      IF ( X .LE. SIXTEN ) THEN
         IF ( X .LT. XLOW ) THEN
            J0INT = X
         ELSE
            T = X * X / ONE28 - ONE
            J0INT = X * CHEVAL(NTERM1,ARJ01,T)
         ENDIF
      ELSE
C
C   Code for |x| > 16
C
         T = FIVE12 / ( X * X ) - ONE
         PIB41 = PIB411 / PIB412
         XMPI4 = ( X - PIB41 ) - PIB42
         TEMP = COS(XMPI4) * CHEVAL(NTERM2,ARJ0A1,T) / X
         TEMP = TEMP - SIN(XMPI4) * CHEVAL(NTERM3,ARJ0A2,T)
         J0INT = ONE - RT2BPI * TEMP / SQRT(X)
      ENDIF
      IF ( IND .EQ. -1 ) J0INT = -J0INT
      RETURN
      END
      SUBROUTINE JACELL(AX,AMC,SNR,CNR,DNR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE JACOBIAN ELLIPTIC
C              FUNCTIONS.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION INPUT ARGUMENT
C                       AMC    = THE SINGLE PRECISION VALUE FOR THE
C                                PARAMETER OF THE FUNCTIONS
C     OUTPUT ARGUMENTS--SN     = THE SINGLE PRECISION VALUE OF THE SN
C                                FUNCTION.
C                     --CN     = THE SINGLE PRECISION VALUE OF THE CN
C                                FUNCTION.
C                     --DN     = THE SINGLE PRECISION VALUE OF THE DN
C                                FUNCTION.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 
C     RESTRICTIONS--
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN. 
C     REFERENCES--"NUMERICAL CALCULATION OF ELLIPTIC INTEGRALS AND
C                 ELLIPTIC FUNCTIONS", BULIRSCH, NUMERISCHE MATHEMATIK,
C                 VOL. 7, PP. 78-90, 1965.
C                 THE ROUTINE HERE IS A FORTRAN TRANSLATION OF THE
C                 ALGOL-60 CODE GIVEN IN THE REFERENCE.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE:  301-975-2855
C     ORIGINAL VERSION--NOVEMBER   1994. 
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOMC.INC'
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
      PARAMETER (MAXELE=13)
      LOGICAL B0
      DOUBLE PRECISION AM(MAXELE)
      DOUBLE PRECISION AN(MAXELE)
      DOUBLE PRECISION MC, C1, CA, X, A, B, C, D
      DOUBLE PRECISION SN, DN, CN
C
      DATA C1 / 3.96825396825D-4/
      DATA CA / 0.0001D0 /
C
C---------------------------------------------------------------------
C
C-----START POINT-----------------------------------------------------
C
      X=DBLE(AX)
      MC=DBLE(AMC)
      DO10I=1,MAXELE
        AN(I)=0.0D0
        AM(I)=0.0D0
 10   CONTINUE
C
      IF(MC.EQ.0.0D0)GOTO1000
      B0=.TRUE.
      IF(MC.LT.0.0D0)THEN
        B0=.TRUE.
      ELSE
        B0=.FALSE.
      ENDIF
      IF(B0)THEN
        D=1.0D0-MC
        MC=-MC/D
        D=SQRT(D)
        X=D*X
      ENDIF
      DN=1.0D0
      A=1.0D0
      DO100I=1,MAXELE
        L=I
        AM(I)=A
        MC=DSQRT(MC)
        AN(I)=MC
        C=0.5D0*(A+MC)
        IF(DABS(A-MC).LE.CA*A)GOTO199
        MC=A*MC
        A=C
 100  CONTINUE
 199  CONTINUE
      X=C*X
      SN=DSIN(X)
      CN=DCOS(X)
      IF(SN.EQ.0.0D0)GOTO299
      A=CN/SN
      C=A*C
      DO200I=L,1,-1
        B=AM(I)
        A=C*A
        C=DN*C
        DN=(AN(I)+A)/(B+A)
        A=C/B
 200  CONTINUE
      A=1.0D0/DSQRT(C*C+1.0D0)
      IF(SN.LT.0.0D0)THEN
        SN=-A
      ELSE
        SN=A
      ENDIF
      CN=C*SN
 299  CONTINUE
      IF(B0)THEN
        A=DN
        DN=CN
        CN=A
        SN=SN/D
      ENDIF
      GOTO9999
C
 1000 CONTINUE
      D=DEXP(X)
      A=1.0D0/D
      B=A+D
      CN=2.0D0/B
      DN=2.0D0/B
      IF(DABS(X).LT.0.3D0)THEN
        D=X*X*X
        SN=CN*(D*((1.0D0/3.0D0)+D*X*C1)+DSIN(X))
      ELSE
        SN=(D-A)/B
      ENDIF
      GOTO9999
C
 9999 CONTINUE
      SNR=SNGL(SN)
      CNR=SNGL(CN)
      DNR=SNGL(DN)
      RETURN
      END 
      SUBROUTINE JACKIN(A1,A2,IWRITE,
     1Y3,N3,IBUGA3,ISUBRO,IERROR)
C
C     PURPOSE--GENERATE A JACKNIFE INDEX
C              THIS WILL BE SEQUENCE 1 1 N WITH A SINGLE ELEMENT
C              DELETED
C     INPUT  ARGUMENTS--A1     =  ELEMENT TO DELETE
C                     --A2     =  SIZE OF SEQUENCE
C     OUTPUT ARGUMENTS--Y3     =  JACKNIFE INDEX
C
C      NOTE--IF A2 IS SMALLER THAN 1 OR LARGER THAN A1,
C            THEN THIS WILL BE INTERPRETED AS A NON-OPERATION.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           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--OCTOBER  1993.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGA3
      CHARACTER*4 ISUBRO
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DIMENSION Y3(*)
C
C
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='JACK'
      ISUBN2='IN  '
C
      IERROR='NO'
C
      IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'CKIN')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF JACKIN--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)IBUGA3,ISUBRO,IWRITE
   52 FORMAT('IBUGA3,ISUBRO,IWRITE = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)A1,A2
   53 FORMAT('A1,A2 = ',2F8.2)
      CALL DPWRST('XXX','BUG ')
   90 CONTINUE
C
C               *************************************
C               **  CONSTRUCT A   JACKNIFE INDEX   **
C               *************************************
C
C               ********************************************
C               **  STEP 11--                             **
C               **  CHECK NUMBER OF INPUT OBSERVATIONS.   **
C               ********************************************
C
      NSKIP=A1+0.5
      N1=A2+0.5
      IF(NSKIP.LT.1.OR.NSKIP.GT.N1)GOTO1110
      GOTO1119
C
 1110 CONTINUE
      IERROR='YES'
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1111)
 1111 FORMAT('***** ERROR IN JACKIN--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1112)
 1112 FORMAT('      THE ELEMENT TO SKIP MUST BE')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1113)N1
 1113 FORMAT('      BETWEEN 1 AND ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1116)
 1116 FORMAT('      SUCH WAS NOT THE CASE HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1117)NSKIP
 1117 FORMAT('      THE ELEMENT TO SKIP IS = ',I8,'.')
      CALL DPWRST('XXX','BUG ')
      GOTO9000
 1119 CONTINUE
C
      DO1300I=1,N1
      Y3(I)=REAL(I)
 1300 CONTINUE
      Y3(NSKIP)=0.0
      N3=N1
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
C
      IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'PARI')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF JACKIN--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IBUGA3,ISUBRO,IWRITE
 9012 FORMAT('IBUGA3,ISUBRO,IWRITE = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)IERROR
 9013 FORMAT('IERROR = ',A4)
      CALL DPWRST('XXX','BUG ')
CCCCC WRITE(ICOUT,9017)N1,N2,N3
C9017 FORMAT('N1,N2,N3 = ',3I8)
      WRITE(ICOUT,9017)N1,N3
 9017 FORMAT('N1,N3 = ',2I8)
      CALL DPWRST('XXX','BUG ')
      IF(N3.LE.0)GOTO9043
      DO9041I=1,N3
      WRITE(ICOUT,9042)I,Y3(I)
 9042 FORMAT('I,Y3(I) = ',I8,E13.5)
      CALL DPWRST('XXX','BUG ')
 9041 CONTINUE
 9043 CONTINUE
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE JACOBP(DEGREE,ALFA,BETA,X,F,FD,E,ED,FLAGF,FLAGD)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE JACOBI
C              POLYNOMIAL OF ORDER N.
C     INPUT  ARGUMENTS--DEGREE = THE INTEGER VALUE FOR THE ORDER OF
C                                THE POLYNOMIAL
C                       ALPHA  = THE DOUBLE PRECISION VALUE FOR THE
C                                FIRST SHAPE PARAMETER
C                       BETA   = THE DOUBLE PRECISION VALUE FOR THE
C                                SECOND SHAPE PARAMETER
C                       X      = THE DOUBLE PRECISION VALUE FOR THE
C                                INPUT ARGUMENT
C     OUTPUT ARGUMENTS--F      = THE DOUBLE PRECISION VALUE OF THE
C                                JACOBI POLYNOMIAL.
C                       FD     = THE DOUBLE PRECISION VALUE OF THE
C                                DERIVATIVE OF THE JACOBI POLYNOMIAL.
C                       E      = THE SINGLE PRECISION VALUE OF THE
C                                RELATIVE ERROR OF F
C                       ED     = THE SINGLE PRECISION VALUE OF THE
C                                RELATIVE ERROR OF FD
C                       FLAGF  = THE INTEGER VALUE WHICH SPECIFIES
C                                WHETHER F IS RELATIVE OR ABSOLUTE ERROR
C                       FLAGD  = THE INTEGER VALUE WHICH SPECIFIES
C                                WHETHER FD IS RELATIVE OR ABSOLUTE ERROR
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 
C     RESTRICTIONS--
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE
C     MODE OF INTERNAL OPERATIONS--SOME DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN. 
C     REFERENCES--"HANDBOOK OF MATHEMATICAL FUNCTIONS, AMS 55", 
C                 ABRAMOWITZ AND STEGUM.
C                 "ALGORITHM 332.  JACOBI POLYNOMIALS", WITTE,
C                 COMMUNICATIONS OF THE ACM, VOL. 11, 1968.
C                 FOLLOWING CODE USES ACM ALGORTHM 332
C     ORIGINAL VERSION--JULY       1995. 
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
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
      DOUBLE PRECISION A, ALF, ALFA, B, BET, BETA
      DOUBLE PRECISION C, D, F, FD, G, H, P, PD, Q, QD
      DOUBLE PRECISION T1, T2, U, V, W, X
C
      REAL E, ED, EG, E1, E2, S, Y
C
      INTEGER I, J, K, M, N, DEGREE, FLAGF, FLAGD
C
      DIMENSION U(25), V(25), W(25), P(25), PD(25), Q(25), QD(25)
C
      DATA M /-2/
      DATA ALF /-2.0D0/
      DATA BET /-2.0D0/
CCCCC DATA Y /3.0E-26/
      DATA RMXINT /134217727. /
C
C-----START POINT-----------------------------------------------------
C
CCCCC IF(X.LT.-1.0.OR.X.GT.1.0)THEN
CCCCC   WRITE(ICOUT,104)
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   WRITE(ICOUT,46)X
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   GOTO9999
CCCCC ENDIF
CC104 FORMAT('***** NON-FATAL DIAGNOSTIC--THE 1ST INPUT ARGUMENT ',
CCCCC1'TO THE JACOBP SUBROUTINE IS OUTSIDE THE (-1,1) INTERVAL *****')
CCC46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
      IF(DEGREE.LT.0 .OR. DEGREE.GT.25)THEN
        WRITE(ICOUT,106)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
        CALL DPWRST('XXX','BUG ')
        GOTO12
      ENDIF
  106 FORMAT('***** NON-FATAL DIAGNOSTIC--THE 2ND INPUT ARGUMENT ',
     1'TO THE JACOBP SUBROUTINE IS OUTSIDE THE (0,25) INTERVAL *****')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
C
      CALL SPDIV(RMXINT,2.0,IND,RESULT)
      ETA=RESULT+1.0
      CALL SPDIV(1.0,ETA,IND,ETA)
      Y=ETA
C
      IF(DEGREE.EQ.0)THEN
        F=1.0D0
        E=0.0
        FD=0.0D0
        ED=0.0
        FLAGF=2
        FLAGD=2
        GOTO12
      ENDIF
C
C  CALCULATE THE U(J), V(J), W(J), IN THE RECURRENCE RELATION.
C  P(J) = P(J-1)*(U(J)+V(J)*X)-P(J-2)*W(J)
C
      M = DEGREE
      ALF = ALFA
      BET = BETA
      A = ALF+BET
      B = ALF-BET
      U(1) = B/2.0D0
      V(1) = 1.0D0+A/2.0D0
      W(1) = 0.0D0
C
      IF(DEGREE.EQ.1)GOTO5
C
      U(2) = A*B*(A+3.0D0)/(4.0D0*(A+2.0D0)**2)
      V(2) = (A+3.0D0)*(A+4.0D0)/(4.0D0*(A+2.0D0))
      W(2) = (1.0D0 + ALF)*(1.0D0 + BET)*(A+4.0D0)
      W(2) = W(2)/(2.0D0*(A+2.0D0)**2)
      I = 2
      K = DEGREE - 1
C
      IF((DEGREE.EQ.2) .OR. (I.GT.K))GOTO5
C
      DO4J=I,K
        A = DBLE(2*J+2)
        D = ALF+BET
        A = A+D
        B = D*(A-1.0D0)*(ALF-BET)
        C = DBLE(J+1)
        C = 2.0D0*C*(A-2.0D0)*(C+D)
        U(J+1) = B/C
        D = A*(A-1.0D0)*(A-2.0D0)
        V(J+1) = D/C
        D = J
        A = 2.0D0*(D+ALF)*(D+BET)*A
        W(J+1) = A/C
    4 CONTINUE
C
C  FIND THE STARTING VALUES FOR J=1 AND J=2 FOR USE IN THE RECURSION.
C
    5 CONTINUE
      T1 = V(1)*X
      P(1) = U(1)+T1
      S = Y*DMAX1(DABS(U(1)),DABS(T1))
      Q(1) = P(1)+S
      PD(1) = V(1)
      QD(1) = V(1)
C
      IF(DEGREE.EQ.1)GOTO7
C
      T1 = V(2)*X
      G = U(2)+T1
      EG = Y*DMAX1(DABS(U(2)),DABS(T1))
      H = G+EG
      T1 = G*P(1)
      E1 = DABS(EG*P(1))
      P(2) = T1 - W(2)
      S = Y*DABS(W(2))
      S = AMAX1(E1,S)
      Q(2) = H*Q(1)-W(2)+S
      PD(2) = G*PD(1)+V(2)*P(1)
      QD(2) = H*QD(1)+V(2)*Q(1)
C
      IF(DEGREE.EQ.2)GOTO7
C
C  USE THE RECURSION
C
      DO6J=3,DEGREE
        T2 = V(J)*X
        G = U(J)+T2
        EG = Y*DMAX1(DABS(U(J)),DABS(T2))
        H = G+EG
        T1 = G*P(J-1)
        T2 = W(J)*P(J-2)
        E1 = DABS(EG*P(J-1))
        E2 = DABS(T2)*Y
        P(J) = T1 - T2
        S = AMAX1(E1,E2)
        Q(J) = H*Q(J-1)-W(J)*Q(J-2)+S
        PD(J) = G*PD(J-1)-W(J)*PD(J-2)
        QD(J) = H*QD(J-1)-W(J)*QD(J-2)
        PD(J) = PD(J)+V(J)*P(J-1)
        QD(J) = QD(J)+V(J)*Q(J-1)
    6 CONTINUE
C
C  PREPARE THE OUTPUT
C
    7 CONTINUE
      N = DEGREE
      F = P(N)
      IF(DABS(F).LT.Y)THEN
        E=DABS(F-Q(N))
        FLAGF = 1
      ELSE
        E=DABS(1.0D0-Q(N)/F)
        FLAGF = 0
      ENDIF
      FD = PD(N)
      IF(DABS(FD).LT.Y)THEN
        ED=DABS(FD-QD(N))
        FLAGD=1
      ELSE
        ED=DABS(1.0D0-QD(N)/FD)
        FLAGD=0
      ENDIF
      GOTO12
C
   12 CONTINUE
      RETURN
      END 
      SUBROUTINE JAIRY (X, RX, C, AI, DAI)
C***BEGIN PROLOGUE  JAIRY
C***SUBSIDIARY
C***PURPOSE  Subsidiary to BESJ and BESY
C***LIBRARY   SLATEC
C***TYPE      SINGLE PRECISION (JAIRY-S, DJAIRY-D)
C***AUTHOR  Amos, D. E., (SNLA)
C           Daniel, S. L., (SNLA)
C           Weston, M. K., (SNLA)
C***DESCRIPTION
C
C                  JAIRY computes the Airy function AI(X)
C                   and its derivative DAI(X) for ASYJY
C
C                                   INPUT
C
C         X - Argument, computed by ASYJY, X unrestricted
C        RX - RX=SQRT(ABS(X)), computed by ASYJY
C         C - C=2.*(ABS(X)**1.5)/3., computed by ASYJY
C
C                                  OUTPUT
C
C        AI - Value of function AI(X)
C       DAI - Value of the derivative DAI(X)
C
C***SEE ALSO  BESJ, BESY
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   750101  DATE WRITTEN
C   891009  Removed unreferenced variable.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900328  Added TYPE section.  (WRB)
C   910408  Updated the AUTHOR section.  (WRB)
C***END PROLOGUE  JAIRY
C
      INTEGER I, J, M1, M1D, M2, M2D, M3, M3D, M4, M4D, N1, N1D, N2,
     1 N2D, N3, N3D, N4, N4D
      REAL A, AI, AJN, AJP, AK1, AK2, AK3, B, C, CCV, CON2, CON3,
     1 CON4, CON5, CV, DA, DAI, DAJN, DAJP, DAK1, DAK2, DAK3, DB, EC,
     2 E1, E2, FPI12, F1, F2, RTRX, RX, SCV, T, TEMP1, TEMP2, TT, X
      DIMENSION AJP(19), AJN(19), A(15), B(15)
      DIMENSION AK1(14), AK2(23), AK3(14)
      DIMENSION DAJP(19), DAJN(19), DA(15), DB(15)
      DIMENSION DAK1(14), DAK2(24), DAK3(14)
      SAVE N1, N2, N3, N4, M1, M2, M3, M4, FPI12, CON2,
     1 CON3, CON4, CON5,AK1, AK2, AK3, AJP, AJN, A, B,
     2 N1D, N2D, N3D, N4D, M1D, M2D, M3D, M4D,
     3 DAK1, DAK2, DAK3, DAJP, DAJN, DA, DB
      DATA N1,N2,N3,N4/14,23,19,15/
      DATA M1,M2,M3,M4/12,21,17,13/
      DATA FPI12,CON2,CON3,CON4,CON5/
     1 1.30899693899575E+00, 5.03154716196777E+00, 3.80004589867293E-01,
     2 8.33333333333333E-01, 8.66025403784439E-01/
      DATA AK1(1), AK1(2), AK1(3), AK1(4), AK1(5), AK1(6), AK1(7),
     1     AK1(8), AK1(9), AK1(10),AK1(11),AK1(12),AK1(13),
     2     AK1(14)         / 2.20423090987793E-01,-1.25290242787700E-01,
     3 1.03881163359194E-02, 8.22844152006343E-04,-2.34614345891226E-04,
     4 1.63824280172116E-05, 3.06902589573189E-07,-1.29621999359332E-07,
     5 8.22908158823668E-09, 1.53963968623298E-11,-3.39165465615682E-11,
     6 2.03253257423626E-12,-1.10679546097884E-14,-5.16169497785080E-15/
      DATA AK2(1), AK2(2), AK2(3), AK2(4), AK2(5), AK2(6), AK2(7),
     1     AK2(8), AK2(9), AK2(10),AK2(11),AK2(12),AK2(13),AK2(14),
     2     AK2(15),AK2(16),AK2(17),AK2(18),AK2(19),AK2(20),AK2(21),
     3     AK2(22),AK2(23) / 2.74366150869598E-01, 5.39790969736903E-03,
     4-1.57339220621190E-03, 4.27427528248750E-04,-1.12124917399925E-04,
     5 2.88763171318904E-05,-7.36804225370554E-06, 1.87290209741024E-06,
     6-4.75892793962291E-07, 1.21130416955909E-07,-3.09245374270614E-08,
     7 7.92454705282654E-09,-2.03902447167914E-09, 5.26863056595742E-10,
     8-1.36704767639569E-10, 3.56141039013708E-11,-9.31388296548430E-12,
     9 2.44464450473635E-12,-6.43840261990955E-13, 1.70106030559349E-13,
     1-4.50760104503281E-14, 1.19774799164811E-14,-3.19077040865066E-15/
      DATA AK3(1), AK3(2), AK3(3), AK3(4), AK3(5), AK3(6), AK3(7),
     1     AK3(8), AK3(9), AK3(10),AK3(11),AK3(12),AK3(13),
     2     AK3(14)         / 2.80271447340791E-01,-1.78127042844379E-03,
     3 4.03422579628999E-05,-1.63249965269003E-06, 9.21181482476768E-08,
     4-6.52294330229155E-09, 5.47138404576546E-10,-5.24408251800260E-11,
     5 5.60477904117209E-12,-6.56375244639313E-13, 8.31285761966247E-14,
     6-1.12705134691063E-14, 1.62267976598129E-15,-2.46480324312426E-16/
      DATA AJP(1), AJP(2), AJP(3), AJP(4), AJP(5), AJP(6), AJP(7),
     1     AJP(8), AJP(9), AJP(10),AJP(11),AJP(12),AJP(13),AJP(14),
     2     AJP(15),AJP(16),AJP(17),AJP(18),
     3     AJP(19)         / 7.78952966437581E-02,-1.84356363456801E-01,
     4 3.01412605216174E-02, 3.05342724277608E-02,-4.95424702513079E-03,
     5-1.72749552563952E-03, 2.43137637839190E-04, 5.04564777517082E-05,
     6-6.16316582695208E-06,-9.03986745510768E-07, 9.70243778355884E-08,
     7 1.09639453305205E-08,-1.04716330588766E-09,-9.60359441344646E-11,
     8 8.25358789454134E-12, 6.36123439018768E-13,-4.96629614116015E-14,
     9-3.29810288929615E-15, 2.35798252031104E-16/
      DATA AJN(1), AJN(2), AJN(3), AJN(4), AJN(5), AJN(6), AJN(7),
     1     AJN(8), AJN(9), AJN(10),AJN(11),AJN(12),AJN(13),AJN(14),
     2     AJN(15),AJN(16),AJN(17),AJN(18),
     3     AJN(19)         / 3.80497887617242E-02,-2.45319541845546E-01,
     4 1.65820623702696E-01, 7.49330045818789E-02,-2.63476288106641E-02,
     5-5.92535597304981E-03, 1.44744409589804E-03, 2.18311831322215E-04,
     6-4.10662077680304E-05,-4.66874994171766E-06, 7.15218807277160E-07,
     7 6.52964770854633E-08,-8.44284027565946E-09,-6.44186158976978E-10,
     8 7.20802286505285E-11, 4.72465431717846E-12,-4.66022632547045E-13,
     9-2.67762710389189E-14, 2.36161316570019E-15/
      DATA A(1),   A(2),   A(3),   A(4),   A(5),   A(6),   A(7),
     1     A(8),   A(9),   A(10),  A(11),  A(12),  A(13),  A(14),
     2     A(15)           / 4.90275424742791E-01, 1.57647277946204E-03,
     3-9.66195963140306E-05, 1.35916080268815E-07, 2.98157342654859E-07,
     4-1.86824767559979E-08,-1.03685737667141E-09, 3.28660818434328E-10,
     5-2.57091410632780E-11,-2.32357655300677E-12, 9.57523279048255E-13,
     6-1.20340828049719E-13,-2.90907716770715E-15, 4.55656454580149E-15,
     7-9.99003874810259E-16/
      DATA B(1),   B(2),   B(3),   B(4),   B(5),   B(6),   B(7),
     1     B(8),   B(9),   B(10),  B(11),  B(12),  B(13),  B(14),
     2     B(15)           / 2.78593552803079E-01,-3.52915691882584E-03,
     3-2.31149677384994E-05, 4.71317842263560E-06,-1.12415907931333E-07,
     4-2.00100301184339E-08, 2.60948075302193E-09,-3.55098136101216E-11,
     5-3.50849978423875E-11, 5.83007187954202E-12,-2.04644828753326E-13,
     6-1.10529179476742E-13, 2.87724778038775E-14,-2.88205111009939E-15,
     7-3.32656311696166E-16/
      DATA N1D,N2D,N3D,N4D/14,24,19,15/
      DATA M1D,M2D,M3D,M4D/12,22,17,13/
      DATA DAK1(1), DAK1(2), DAK1(3), DAK1(4), DAK1(5), DAK1(6),
     1     DAK1(7), DAK1(8), DAK1(9), DAK1(10),DAK1(11),DAK1(12),
     2    DAK1(13),DAK1(14)/ 2.04567842307887E-01,-6.61322739905664E-02,
     3-8.49845800989287E-03, 3.12183491556289E-03,-2.70016489829432E-04,
     4-6.35636298679387E-06, 3.02397712409509E-06,-2.18311195330088E-07,
     5-5.36194289332826E-10, 1.13098035622310E-09,-7.43023834629073E-11,
     6 4.28804170826891E-13, 2.23810925754539E-13,-1.39140135641182E-14/
      DATA DAK2(1), DAK2(2), DAK2(3), DAK2(4), DAK2(5), DAK2(6),
     1     DAK2(7), DAK2(8), DAK2(9), DAK2(10),DAK2(11),DAK2(12),
     2     DAK2(13),DAK2(14),DAK2(15),DAK2(16),DAK2(17),DAK2(18),
     3     DAK2(19),DAK2(20),DAK2(21),DAK2(22),DAK2(23),
     4     DAK2(24)        / 2.93332343883230E-01,-8.06196784743112E-03,
     5 2.42540172333140E-03,-6.82297548850235E-04, 1.85786427751181E-04,
     6-4.97457447684059E-05, 1.32090681239497E-05,-3.49528240444943E-06,
     7 9.24362451078835E-07,-2.44732671521867E-07, 6.49307837648910E-08,
     8-1.72717621501538E-08, 4.60725763604656E-09,-1.23249055291550E-09,
     9 3.30620409488102E-10,-8.89252099772401E-11, 2.39773319878298E-11,
     1-6.48013921153450E-12, 1.75510132023731E-12,-4.76303829833637E-13,
     2 1.29498241100810E-13,-3.52679622210430E-14, 9.62005151585923E-15,
     3-2.62786914342292E-15/
      DATA DAK3(1), DAK3(2), DAK3(3), DAK3(4), DAK3(5), DAK3(6),
     1     DAK3(7), DAK3(8), DAK3(9), DAK3(10),DAK3(11),DAK3(12),
     2    DAK3(13),DAK3(14)/ 2.84675828811349E-01, 2.53073072619080E-03,
     3-4.83481130337976E-05, 1.84907283946343E-06,-1.01418491178576E-07,
     4 7.05925634457153E-09,-5.85325291400382E-10, 5.56357688831339E-11,
     5-5.90889094779500E-12, 6.88574353784436E-13,-8.68588256452194E-14,
     6 1.17374762617213E-14,-1.68523146510923E-15, 2.55374773097056E-16/
      DATA DAJP(1), DAJP(2), DAJP(3), DAJP(4), DAJP(5), DAJP(6),
     1     DAJP(7), DAJP(8), DAJP(9), DAJP(10),DAJP(11),DAJP(12),
     2     DAJP(13),DAJP(14),DAJP(15),DAJP(16),DAJP(17),DAJP(18),
     3     DAJP(19)        / 6.53219131311457E-02,-1.20262933688823E-01,
     4 9.78010236263823E-03, 1.67948429230505E-02,-1.97146140182132E-03,
     5-8.45560295098867E-04, 9.42889620701976E-05, 2.25827860945475E-05,
     6-2.29067870915987E-06,-3.76343991136919E-07, 3.45663933559565E-08,
     7 4.29611332003007E-09,-3.58673691214989E-10,-3.57245881361895E-11,
     8 2.72696091066336E-12, 2.26120653095771E-13,-1.58763205238303E-14,
     9-1.12604374485125E-15, 7.31327529515367E-17/
      DATA DAJN(1), DAJN(2), DAJN(3), DAJN(4), DAJN(5), DAJN(6),
     1     DAJN(7), DAJN(8), DAJN(9), DAJN(10),DAJN(11),DAJN(12),
     2     DAJN(13),DAJN(14),DAJN(15),DAJN(16),DAJN(17),DAJN(18),
     3     DAJN(19)        / 1.08594539632967E-02, 8.53313194857091E-02,
     4-3.15277068113058E-01,-8.78420725294257E-02, 5.53251906976048E-02,
     5 9.41674060503241E-03,-3.32187026018996E-03,-4.11157343156826E-04,
     6 1.01297326891346E-04, 9.87633682208396E-06,-1.87312969812393E-06,
     7-1.50798500131468E-07, 2.32687669525394E-08, 1.59599917419225E-09,
     8-2.07665922668385E-10,-1.24103350500302E-11, 1.39631765331043E-12,
     9 7.39400971155740E-14,-7.32887475627500E-15/
      DATA DA(1),  DA(2),  DA(3),  DA(4),  DA(5),  DA(6),  DA(7),
     1     DA(8),  DA(9),  DA(10), DA(11), DA(12), DA(13), DA(14),
     2     DA(15)          / 4.91627321104601E-01, 3.11164930427489E-03,
     3 8.23140762854081E-05,-4.61769776172142E-06,-6.13158880534626E-08,
     4 2.87295804656520E-08,-1.81959715372117E-09,-1.44752826642035E-10,
     5 4.53724043420422E-11,-3.99655065847223E-12,-3.24089119830323E-13,
     6 1.62098952568741E-13,-2.40765247974057E-14, 1.69384811284491E-16,
     7 8.17900786477396E-16/
      DATA DB(1),  DB(2),  DB(3),  DB(4),  DB(5),  DB(6),  DB(7),
     1     DB(8),  DB(9),  DB(10), DB(11), DB(12), DB(13), DB(14),
     2     DB(15)          /-2.77571356944231E-01, 4.44212833419920E-03,
     3-8.42328522190089E-05,-2.58040318418710E-06, 3.42389720217621E-07,
     4-6.24286894709776E-09,-2.36377836844577E-09, 3.16991042656673E-10,
     5-4.40995691658191E-12,-5.18674221093575E-12, 9.64874015137022E-13,
     6-4.90190576608710E-14,-1.77253430678112E-14, 5.55950610442662E-15,
     7-7.11793337579530E-16/
C***FIRST EXECUTABLE STATEMENT  JAIRY
      IF (X.LT.0.0E0) GO TO 90
      IF (C.GT.5.0E0) GO TO 60
      IF (X.GT.1.20E0) GO TO 30
      T = (X+X-1.2E0)*CON4
      TT = T + T
      J = N1
      F1 = AK1(J)
      F2 = 0.0E0
      DO 10 I=1,M1
        J = J - 1
        TEMP1 = F1
        F1 = TT*F1 - F2 + AK1(J)
        F2 = TEMP1
   10 CONTINUE
      AI = T*F1 - F2 + AK1(1)
C
      J = N1D
      F1 = DAK1(J)
      F2 = 0.0E0
      DO 20 I=1,M1D
        J = J - 1
        TEMP1 = F1
        F1 = TT*F1 - F2 + DAK1(J)
        F2 = TEMP1
   20 CONTINUE
      DAI = -(T*F1-F2+DAK1(1))
      RETURN
C
   30 CONTINUE
      T = (X+X-CON2)*CON3
      TT = T + T
      J = N2
      F1 = AK2(J)
      F2 = 0.0E0
      DO 40 I=1,M2
        J = J - 1
        TEMP1 = F1
        F1 = TT*F1 - F2 + AK2(J)
        F2 = TEMP1
   40 CONTINUE
      RTRX = SQRT(RX)
      EC = EXP(-C)
      AI = EC*(T*F1-F2+AK2(1))/RTRX
      J = N2D
      F1 = DAK2(J)
      F2 = 0.0E0
      DO 50 I=1,M2D
        J = J - 1
        TEMP1 = F1
        F1 = TT*F1 - F2 + DAK2(J)
        F2 = TEMP1
   50 CONTINUE
      DAI = -EC*(T*F1-F2+DAK2(1))*RTRX
      RETURN
C
   60 CONTINUE
      T = 10.0E0/C - 1.0E0
      TT = T + T
      J = N1
      F1 = AK3(J)
      F2 = 0.0E0
      DO 70 I=1,M1
        J = J - 1
        TEMP1 = F1
        F1 = TT*F1 - F2 + AK3(J)
        F2 = TEMP1
   70 CONTINUE
      RTRX = SQRT(RX)
      EC = EXP(-C)
      AI = EC*(T*F1-F2+AK3(1))/RTRX
      J = N1D
      F1 = DAK3(J)
      F2 = 0.0E0
      DO 80 I=1,M1D
        J = J - 1
        TEMP1 = F1
        F1 = TT*F1 - F2 + DAK3(J)
        F2 = TEMP1
   80 CONTINUE
      DAI = -RTRX*EC*(T*F1-F2+DAK3(1))
      RETURN
C
   90 CONTINUE
      IF (C.GT.5.0E0) GO TO 120
      T = 0.4E0*C - 1.0E0
      TT = T + T
      J = N3
      F1 = AJP(J)
      E1 = AJN(J)
      F2 = 0.0E0
      E2 = 0.0E0
      DO 100 I=1,M3
        J = J - 1
        TEMP1 = F1
        TEMP2 = E1
        F1 = TT*F1 - F2 + AJP(J)
        E1 = TT*E1 - E2 + AJN(J)
        F2 = TEMP1
        E2 = TEMP2
  100 CONTINUE
      AI = (T*E1-E2+AJN(1)) - X*(T*F1-F2+AJP(1))
      J = N3D
      F1 = DAJP(J)
      E1 = DAJN(J)
      F2 = 0.0E0
      E2 = 0.0E0
      DO 110 I=1,M3D
        J = J - 1
        TEMP1 = F1
        TEMP2 = E1
        F1 = TT*F1 - F2 + DAJP(J)
        E1 = TT*E1 - E2 + DAJN(J)
        F2 = TEMP1
        E2 = TEMP2
  110 CONTINUE
      DAI = X*X*(T*F1-F2+DAJP(1)) + (T*E1-E2+DAJN(1))
      RETURN
C
  120 CONTINUE
      T = 10.0E0/C - 1.0E0
      TT = T + T
      J = N4
      F1 = A(J)
      E1 = B(J)
      F2 = 0.0E0
      E2 = 0.0E0
      DO 130 I=1,M4
        J = J - 1
        TEMP1 = F1
        TEMP2 = E1
        F1 = TT*F1 - F2 + A(J)
        E1 = TT*E1 - E2 + B(J)
        F2 = TEMP1
        E2 = TEMP2
  130 CONTINUE
      TEMP1 = T*F1 - F2 + A(1)
      TEMP2 = T*E1 - E2 + B(1)
      RTRX = SQRT(RX)
      CV = C - FPI12
      CCV = COS(CV)
      SCV = SIN(CV)
      AI = (TEMP1*CCV-TEMP2*SCV)/RTRX
      J = N4D
      F1 = DA(J)
      E1 = DB(J)
      F2 = 0.0E0
      E2 = 0.0E0
      DO 140 I=1,M4D
        J = J - 1
        TEMP1 = F1
        TEMP2 = E1
        F1 = TT*F1 - F2 + DA(J)
        E1 = TT*E1 - E2 + DB(J)
        F2 = TEMP1
        E2 = TEMP2
  140 CONTINUE
      TEMP1 = T*F1 - F2 + DA(1)
      TEMP2 = T*E1 - E2 + DB(1)
      E1 = CCV*CON5 + 0.5E0*SCV
      E2 = SCV*CON5 - 0.5E0*CCV
      DAI = (TEMP1*E1-TEMP2*E2)*RTRX
      RETURN
      END
      SUBROUTINE JNSN(XBAR, SD, RB1, BB2, ITYPE, GAMMA, DELTA,
     $  XLAM, XI, IFAULT)
CSTART OF AS 99
C
C        ALGORITHM AS 99  APPL. STATIST. (1976) VOL.25, P.180
C
C        FINDS TYPE AND PARAMETERS OF A JOHNSON CURVE
C        WITH GIVEN FIRST FOUR MOMENTS
C
      REAL XBAR, SD, RB1, BB2, GAMMA, DELTA, XLAM, XI, TOL,
     $  B1, B2, Y, X, U, W, ZERO, ONE, TWO, THREE, FOUR, HALF,
     $  QUART, ZABS, ZEXP, ZLOG, ZSIGN, ZSQRT
      LOGICAL FAULT
C
      DATA TOL /0.01/
      DATA ZERO, QUART, HALF, ONE, TWO, THREE, FOUR
     $     /0.0,  0.25,  0.5, 1.0, 2.0,   3.0,  4.0/
C
      ZABS(X) = ABS(X)
      ZEXP(X) = EXP(X)
      ZLOG(X) = ALOG(X)
      ZSIGN(X, Y) = SIGN(X, Y)
      ZSQRT(X) = SQRT(X)
C
      IFAULT = 1
      IF (SD .LT. ZERO) RETURN
      IFAULT = 0
      XI = ZERO
      XLAM = ZERO
      GAMMA = ZERO
      DELTA = ZERO
      IF (SD .GT. ZERO) GOTO 10
      ITYPE = 5
      XI = XBAR
      RETURN
   10 B1 = RB1 * RB1
      B2 = BB2
      FAULT = .FALSE.
C
C        TEST WHETHER LOGNORMAL (OR NORMAL) REQUESTED
C
      IF (B2 .GE. ZERO) GOTO 30
   20 IF (ZABS(RB1) .LE. TOL) GOTO 70
      GOTO 80
C
C        TEST FOR POSITION RELATIVE TO BOUNDARY LINE
C
   30 IF (B2 .GT. B1 + TOL + ONE) GOTO 60
      IF (B2 .LT. B1 + ONE) GOTO 50
C
C        ST DISTRIBUTION
C
   40 ITYPE = 5
      Y = HALF + HALF * ZSQRT(ONE - FOUR / (B1 + FOUR))
      IF (RB1 .GT. ZERO) Y = ONE - Y
      X = SD / ZSQRT(Y * (ONE - Y))
      XI = XBAR - Y * X
      XLAM = XI + X
      DELTA = Y
      RETURN
   50 IFAULT = 2
      RETURN
   60 IF (ZABS(RB1) .GT. TOL .OR. ZABS(B2 - THREE) .GT. TOL) GOTO 80
C
C        NORMAL DISTRIBUTION
C
   70 ITYPE = 4
      DELTA = ONE / SD
      GAMMA = -XBAR / SD
      RETURN
C
C        TEST FOR POSITION RELATIVE TO LOGNORMAL LINE
C
   80 X = HALF * B1 + ONE
      Y = ZABS(RB1) * ZSQRT(QUART * B1 + ONE)
      U = (X + Y) ** (ONE / THREE)
      W = U + ONE / U - ONE
      U = W * W * (THREE + W * (TWO + W)) - THREE
      IF (B2 .LT. ZERO .OR. FAULT) B2 = U
      X = U - B2
      IF (ZABS(X) .GT. TOL) GOTO 90
C
C        LOGNORMAL (SL) DISTRIBUTION
C
      ITYPE = 1
      XLAM = ZSIGN(ONE, RB1)
      U = XLAM * XBAR
      X = ONE / ZSQRT(ZLOG(W))
      DELTA = X
      Y = HALF * X * ZLOG(W * (W - ONE) / (SD * SD))
      GAMMA = Y
      XI = XLAM * (U - ZEXP((HALF / X - Y) / X))
      RETURN
C
C        SB OR SU DISTRIBUTION
C
   90 IF (X .GT. ZERO) GOTO 100
      ITYPE = 2
      CALL SUFIT(XBAR, SD, RB1, B2, GAMMA, DELTA, XLAM, XI)
      RETURN
  100 ITYPE = 3
      CALL SBFIT(XBAR, SD, RB1, B2, GAMMA, DELTA, XLAM, XI, FAULT)
      IF (.NOT. FAULT) RETURN
C
C        FAILURE - TRY TO FIT APPROXIMATE RESULT
C
      IFAULT = 3
      IF (B2 .GT. B1 + TWO) GOTO 20
      GOTO 40
      END
      SUBROUTINE JSBCDF(X,ALPHA1,ALPHA2,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE JOHNSON SB SYSTEM DISTRIBUTION.
C              THIS DISTRIBUTION CAN BE DEFINED IN TERMS OF THE
C              NORMAL DISTRIBUTION:
C              F(X) = NORCDF(ALPHA1 + ALPHA2*LOG(X/(1-X))
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE 
C                                AT WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE POSITIVE.
C                     --ALPHA1 = FIRST SHAPE PARAMETER
C                     --ALPHA2 = SECOND SHAPE PARAMETER
C     OUTPUT ARGUMENTS--CDF    = THE SINGLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE CDF FOR THE JOHNSON SB
C             DISTRIBUTION.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 
C     RESTRICTIONS--X SHOULD BE POSITIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NORCDF. 
C     FORTRAN LIBRARY SUBROUTINES NEEDED--ALOG.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN. 
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 2ND ED., 1994, PAGE 34.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE:  301-975-2855
C     ORIGINAL VERSION--SEPTEMBER 2001. 
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DOUBLE PRECISION DARG
      DOUBLE PRECISION DCDF
C
C---------------------------------------------------------------------
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(X.LE.0.0)THEN
        CDF=0.0
        GOTO9000
      ENDIF
      IF(X.GE.1.0)THEN
        CDF=1.0
        GOTO9000
      ENDIF
C
      IF(ALPHA2.LE.0.0)THEN
        WRITE(ICOUT,14)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,15)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ALPHA1
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9000
      ENDIF
C
   14 FORMAT('***** ERROR--THE THIRD INPUT ARGUMENT TO THE JSBCDF ')
   15 FORMAT('      SUBROUTINE IS NON-POSITIVE.')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
C-----START POINT-----------------------------------------------------
C
      CDF=0.0
C
      ARG=ALPHA1 + ALPHA2*ALOG(X/(1.0-X))
      DARG=DBLE(ARG)
      CALL NODCDF(DARG,DCDF)
      CDF=REAL(DCDF)
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE JSBPDF(X,ALPHA1,ALPHA2,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE JOHNSON SB SYSTEM DISTRIBUTION.
C              THIS DISTRIBUTION CAN BE DEFINED IN TERMS OF THE
C              NORMAL DISTRIBUTION:
C              F(X) = (ALPHA2/(X*(1-X))*
C                     NORPDF(ALPHA1 + ALPHA2*LOG(X/(1-X))
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE 
C                                AT WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE POSITIVE.
C                     --ALPHA1 = FIRST SHAPE PARAMETER
C                     --ALPHA2 = SECOND SHAPE PARAMETER
C     OUTPUT ARGUMENTS--CDF    = THE SINGLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE PDF FOR THE JOHNSON SB
C             DISTRIBUTION.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 
C     RESTRICTIONS--X SHOULD BE POSITIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NORPDF. 
C     FORTRAN LIBRARY SUBROUTINES NEEDED--ALOG.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN. 
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 2ND ED., 1994, PAGE 34.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE:  301-975-2855
C     ORIGINAL VERSION--SEPTEMBER 2001. 
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DOUBLE PRECISION DARG
      DOUBLE PRECISION DX
      DOUBLE PRECISION DPDF
C
C---------------------------------------------------------------------
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(X.LE.0.0 .OR. X.GE.1.0)THEN
        WRITE(ICOUT,4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9000
      ENDIF
C
      IF(ALPHA2.LE.0.0)THEN
        WRITE(ICOUT,14)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,15)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ALPHA1
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9000
      ENDIF
C
    4 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO THE JSBPDF ')
    5 FORMAT('      SUBROUTINE IS OUTSIDE THE (0,1) INTERVAL.')
   14 FORMAT('***** ERROR--THE THIRD INPUT ARGUMENT TO THE JSBPDF ')
   15 FORMAT('      SUBROUTINE IS NON-POSITIVE.')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
C-----START POINT-----------------------------------------------------
C
      PDF=0.0
C
      ARG=ALPHA1 + ALPHA2*ALOG(X/(1.0-X))
      DARG=DBLE(ARG)
      CALL NODPDF(DARG,DPDF)
      DX=DBLE(X)
      DPDF=(DBLE(ALPHA2)/(DX*(1.0D0-DX)))*DPDF
      PDF=REAL(DPDF)
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE JSBPPF(P,ALPHA1,ALPHA2,PPF)
C
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           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
      DOUBLE PRECISION DCDF
      DOUBLE PRECISION DALPH1
      DOUBLE PRECISION DALPH2
      DOUBLE PRECISION DX
      DOUBLE PRECISION DARG
      DOUBLE PRECISION DP
      DOUBLE PRECISION EPS
      DOUBLE PRECISION SIG
      DOUBLE PRECISION ZERO
      DOUBLE PRECISION A
      DOUBLE PRECISION B
      DOUBLE PRECISION AB
      DOUBLE PRECISION XL
      DOUBLE PRECISION XR
      DOUBLE PRECISION XRML
      DOUBLE PRECISION FXL
      DOUBLE PRECISION FXR
      DOUBLE PRECISION FCS
C
C------------------------------------------------------------------
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 /1.0D-6/
      DATA SIG /1.0D-5/
      DATA ZERO /0.D0/
      DATA MAXIT /3000/
C
C-----START POINT---------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(P.LE.0.0)THEN
        PPF=0.0
        GOTO9999
      ELSEIF(P.GE.1.0)THEN
        PPF=1.0
        GOTO9999
      ENDIF
C
      IF(ALPHA2.LE.0.0)THEN
        WRITE(ICOUT,14)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,15)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ALPHA1
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
        GOTO9999
      ENDIF
C
    4 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO THE JSBPPF ')
    5 FORMAT('      SUBROUTINE IS NON-POSITIVE.')
   14 FORMAT('***** ERROR--THE THIRD INPUT ARGUMENT TO THE JSBPPF ')
   15 FORMAT('      SUBROUTINE IS NON-POSITIVE.')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
      A = ALPHA1
      B = ALPHA2
      DP = DBLE(P)
C
      IERR=0
      IC = 0
      AB = A/B
      XL = 0.0D0
      XR = 1.0D0
      FXL = -DP
      FXR = 1.0D0 - DP
C
      IF(FXL*FXR .GT. ZERO)THEN
        WRITE(ICOUT,4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)P
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
        GOTO9999
      ENDIF
C
C  BISECTION METHOD
C
  105 CONTINUE
      DX = (XL+XR)*0.5D0
      DALPH1=DBLE(A)
      DALPH2=DBLE(B)
      DARG=DALPH1 + DALPH2*DLOG(DX/(1.0D0-DX))
      CALL NODCDF(DARG,DCDF)
      P1=DCDF
      PPF=REAL(DX)
C
      FCS = P1 - DP
      IF(FCS*FXL.GT.ZERO)GOTO110
      XR = DX
      FXR = FCS 
      GOTO115
  110 CONTINUE
      XL = DX
      FXL = FCS
  115 CONTINUE
      XRML = XR - XL
      IF(XRML.LE.SIG .AND. ABS(FCS).LE.EPS)GOTO9999
      IC = IC + 1
      IF(IC.LE.MAXIT)GOTO105
      WRITE(ICOUT,130)
      CALL DPWRST('XXX','BUG ')
  130 FORMAT('***** FATAL ERROR--JSBPPF ROUTINE DID NOT CONVERGE. ',
     1       '***')
      GOTO9999
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE JSBRAN(N,ALPHA1,ALPHA2,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE JOHNSON SB DISTRIBUTION
C              WITH SHAPE PARAMETER VALUES = ALPHA1, ALPHA2.
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --ALPHA1  = THE SINGLE PRECISION VALUE OF THE
C                                FIRST SHAPE PARAMETER.
C                                ALPHA1 SHOULD BE POSITIVE.
C                     --ALPHA2  = THE SINGLE PRECISION VALUE OF THE
C                                SECOND SHAPE PARAMETER.
C                                ALPHA2 SHOULD BE POSITIVE.
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST N)
C                                INTO WHICH THE GENERATED
C                                RANDOM SAMPLE WILL BE PLACED.
C     OUTPUT--A RANDOM SAMPLE OF SIZE N
C             FROM THE JOHNSON SB DISTRIBUTION
C             WITH SHAPE PARAMETER VALUES = ALPHA1 AND ALPHA2.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C                 --ALPHA2 SHOULD BE POSITIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           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
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'JSBRAN SUBROUTINE IS NON-POSITIVE *****')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
C
C     GENERATE N STANDARD NORMAL RANDOM NUMBERS;
C
      CALL NORRAN(N,ISEED,X)
C
C     GENERATE N JOHNSON SB DISTRIBUTION RANDOM NUMBERS
C     USING APPLIED STATISTICS ALGORITHM AS100.
C
      ITYPE=3
      ALOC=0.0
      SCALE=1.0
      DO100I=1,N
        XTEMP=X(I)
        XTEMP2=AJV(XTEMP,ITYPE,ALPHA1,ALPHA2,SCALE,ALOC,IFAULT)
        X(I)=XTEMP2
  100 CONTINUE
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE JSUCDF(X,ALPHA1,ALPHA2,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE JOHNSON SU SYSTEM DISTRIBUTION.
C              THIS DISTRIBUTION CAN BE DEFINED IN TERMS OF THE
C              NORMAL DISTRIBUTION:
C              F(X) = NORCDF(ALPHA1 + ALPHA2*LOG(X + SQRT(x**2+1))
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE 
C                                AT WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE POSITIVE.
C                     --ALPHA1 = FIRST SHAPE PARAMETER
C                     --ALPHA2 = SECOND SHAPE PARAMETER
C     OUTPUT ARGUMENTS--CDF    = THE SINGLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE CDF FOR THE JOHNSON SU
C             DISTRIBUTION.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 
C     RESTRICTIONS--X SHOULD BE POSITIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NORCDF. 
C     FORTRAN LIBRARY SUBROUTINES NEEDED--ALOG.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN. 
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 2ND ED., 1994, PAGE 34.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE:  301-975-2855
C     ORIGINAL VERSION--SEPTEMBER 2001. 
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DOUBLE PRECISION DARG
      DOUBLE PRECISION DCDF
C
C---------------------------------------------------------------------
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(ALPHA2.LE.0.0)THEN
        WRITE(ICOUT,14)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,15)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ALPHA1
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9000
      ENDIF
C
   14 FORMAT('***** ERROR--THE THIRD INPUT ARGUMENT TO THE JSUCDF ')
   15 FORMAT('      SUBROUTINE IS NON-POSITIVE.')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
C-----START POINT-----------------------------------------------------
C
      CDF=0.0
C
      ARG=ALPHA1 + ALPHA2*ALOG(X + SQRT(X**2+1))
      DARG=DBLE(ARG)
      CALL NODCDF(DARG,DCDF)
      CDF=REAL(DCDF)
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE JSUPDF(X,ALPHA1,ALPHA2,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE JOHNSON SU SYSTEM DISTRIBUTION.
C              THIS DISTRIBUTION CAN BE DEFINED IN TERMS OF THE
C              NORMAL DISTRIBUTION:
C              F(X) = (ALPHA2/SQRT(X**2 + 1))*
C                     NORPDF(ALPHA1 + ALPHA2*LOG(X + SQRT(X**2+1)))
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE 
C                                AT WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE POSITIVE.
C                     --ALPHA1 = FIRST SHAPE PARAMETER
C                     --ALPHA2 = SECOND SHAPE PARAMETER
C     OUTPUT ARGUMENTS--CDF    = THE SINGLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE PDF FOR THE JOHNSON SU
C             DISTRIBUTION.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 
C     RESTRICTIONS--X SHOULD BE POSITIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NORPDF. 
C     FORTRAN LIBRARY SUBROUTINES NEEDED--ALOG.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN. 
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 2ND ED., 1994, PAGE 34.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE:  301-975-2855
C     ORIGINAL VERSION--SEPTEMBER 2001. 
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DOUBLE PRECISION DARG
      DOUBLE PRECISION DX
      DOUBLE PRECISION DPDF
C
C---------------------------------------------------------------------
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(ALPHA2.LE.0.0)THEN
        WRITE(ICOUT,14)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,15)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ALPHA1
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9000
      ENDIF
C
   14 FORMAT('***** ERROR--THE THIRD INPUT ARGUMENT TO THE JSUPDF ')
   15 FORMAT('      SUBROUTINE IS NON-POSITIVE.')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
C-----START POINT-----------------------------------------------------
C
      PDF=0.0
C
      ARG=ALPHA1 + ALPHA2*ALOG(X + SQRT(X**2+1.0))
      DARG=DBLE(ARG)
      CALL NODPDF(DARG,DPDF)
      DX=DBLE(X)
      DPDF=(DBLE(ALPHA2)/DSQRT(DX*DX+1.0D0))*DPDF
      PDF=REAL(DPDF)
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE JSUPPF(P,ALPHA1,ALPHA2,PPF)
C
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--THE PERCENT POINT FUNCTION FOR THE JOHNSON SU
C           FUNCTION IS:
C           G(P,ALPHA1,ALPHA2) = SINH[(NORPPF(P) - ALPHA1)/ALPHA2]
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           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     UPDATED         --NOVEMBER  2003. USE CLOSED FORMULA BASED
C                                       ON NORPPF
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES----------------
C
      DOUBLE PRECISION DPPF
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
CCCCC DOUBLE PRECISION DCDF
CCCCC DOUBLE PRECISION DALPH1
CCCCC DOUBLE PRECISION DALPH2
CCCCC DOUBLE PRECISION DX
CCCCC DOUBLE PRECISION DARG
CCCCC DOUBLE PRECISION EPS
CCCCC DOUBLE PRECISION SIG
CCCCC DOUBLE PRECISION ZERO
CCCCC DOUBLE PRECISION XL
CCCCC DOUBLE PRECISION XR
CCCCC DOUBLE PRECISION XINC
CCCCC DOUBLE PRECISION DP
CCCCC DOUBLE PRECISION A
CCCCC DOUBLE PRECISION B
CCCCC DOUBLE PRECISION AB
CCCCC DOUBLE PRECISION FXL
CCCCC DOUBLE PRECISION FXR
CCCCC DOUBLE PRECISION FCS
CCCCC DOUBLE PRECISION P1
CCCCC DOUBLE PRECISION XRML
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
CCCCC DATA EPS /1.0D-6/
CCCCC DATA SIG /1.0D-5/
CCCCC DATA ZERO /0./
CCCCC DATA MAXIT /3000/
C
C-----START POINT---------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(P.LE.0.0)THEN
        PPF=0.0
        GOTO9999
      ELSEIF(P.GE.1.0)THEN
        PPF=0.0
        GOTO9999
      ENDIF
C
      IF(ALPHA2.LE.0.0)THEN
        WRITE(ICOUT,14)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,15)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ALPHA1
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
        GOTO9999
      ENDIF
C
    4 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO THE JSUPPF ')
    5 FORMAT('      SUBROUTINE IS NON-POSITIVE.')
   14 FORMAT('***** ERROR--THE THIRD INPUT ARGUMENT TO THE JSUPPF ')
   15 FORMAT('      SUBROUTINE IS NON-POSITIVE.')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
C  NOTE: NOVEMBER 2003.  USE CLOSED FORM SOLUTION FOR PPF FUNCTION.
C
      CALL NODPPF(DBLE(P),DTERM1)
      DTERM2=(DTERM1 - DBLE(ALPHA1))/DBLE(ALPHA2)
      DTERM3=(DEXP(DTERM2) - DEXP(-DTERM2))/2.0D0
      PPF=REAL(DTERM3)
C
C  FIND BRACKETING INTERVAL.
C
CCCCC IF(ALPHA1.GE.-1.0)THEN
CCCCC   XL=-20.0D0
CCCCC   XINC=20.0D0
CCCCC ELSEIF(ALPHA1.GE.-1.0)THEN
CCCCC   XL=-50.0D0
CCCCC   XINC=50.0D0
CCCCC ELSE
CCCCC   XL=-100.0D0
CCCCC   XINC=100.0D0
CCCCC ENDIF
CCCCC XR=XL+XINC
CCCCC ICOUNT=0
CCCCC MAXCNT=50000
C
CCC91 CONTINUE
CCCCC CALL JSUCDF(REAL(XL),ALPHA1,ALPHA2,CDFL)
CCCCC CALL JSUCDF(REAL(XR),ALPHA1,ALPHA2,CDFR)
CCCCC IF(CDFL.LT.P .AND. CDFR.LT.P)THEN
CCCCC   XR=XR + XINC
CCCCC ELSEIF(CDFL.GT.P .AND. CDFR.GT.P)THEN
CCCCC   XL=XL - XINC
CCCCC ELSE
CCCCC   GOTO99
CCCCC ENDIF
CCCCC ICOUNT=ICOUNT+1
CCCCC IF(ICOUNT.GT.MAXCNT)THEN
CCCCC   WRITE(ICOUT,96)
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   PPF=0.0
CCCCC   GOTO9999
CCCCC ENDIF
CCC96 FORMAT('***** FATAL ERROR--JSUPPF UNABLE TO FIND BRACKETING ',
CCCCC*       'INTERVAL. *****')
CCCCC GOTO91
C
CCC99 CONTINUE
CCCCC A = DBLE(ALPHA1)
CCCCC B = DBLE(ALPHA2)
CCCCC DP=DBLE(P)
C
CCCCC IERR=0
CCCCC IC = 0
CCCCC AB = A/B
CCCCC FXL = -DP
CCCCC FXR = 1.0D0 - DP
C
CCCCC IF(FXL*FXR .GT. ZERO)THEN
CCCCC   WRITE(ICOUT,4)
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   WRITE(ICOUT,5)
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   WRITE(ICOUT,46)P
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   PPF=0.0
CCCCC   GOTO9999
CCCCC ENDIF
C
C  BISECTION METHOD
C
CC105 CONTINUE
CCCCC DX = (XL+XR)*0.5D0
CCCCC DALPH1=DBLE(A)
CCCCC DALPH2=DBLE(B)
CCCCC DARG=DALPH1 + DALPH2*DLOG(DX + DSQRT(DX**2 + 1.0D0))
CCCCC CALL NODCDF(DARG,DCDF)
CCCCC P1=REAL(DCDF)
CCCCC PPF=REAL(DX)
C
CCCCC FCS = P1 - DP
CCCCC IF(FCS*FXL.GT.ZERO)GOTO110
CCCCC XR = DX
CCCCC FXR = FCS 
CCCCC GOTO115
CC110 CONTINUE
CCCCC XL = DX
CCCCC FXL = FCS
CC115 CONTINUE
CCCCC XRML = XR - XL
CCCCC IF(XRML.LE.SIG .AND. ABS(FCS).LE.EPS)GOTO9999
CCCCC IC = IC + 1
CCCCC IF(IC.LE.MAXIT)GOTO105
CCCCC WRITE(ICOUT,130)
CCCCC CALL DPWRST('XXX','BUG ')
CC130 FORMAT('***** FATAL ERROR--JSUPPF ROUTINE DID NOT CONVERGE. ',
CCCCC1       '***')
CCCCC GOTO9999
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE JSURAN(N,ALPHA1,ALPHA2,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE JOHNSON SU DISTRIBUTION
C              WITH SHAPE PARAMETER VALUES = ALPHA1, ALPHA2.
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --ALPHA1  = THE SINGLE PRECISION VALUE OF THE
C                                FIRST SHAPE PARAMETER.
C                                ALPHA1 SHOULD BE POSITIVE.
C                     --ALPHA2  = THE SINGLE PRECISION VALUE OF THE
C                                SECOND SHAPE PARAMETER.
C                                ALPHA2 SHOULD BE POSITIVE.
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST N)
C                                INTO WHICH THE GENERATED
C                                RANDOM SAMPLE WILL BE PLACED.
C     OUTPUT--A RANDOM SAMPLE OF SIZE N
C             FROM THE JOHNSON SU DISTRIBUTION
C             WITH SHAPE PARAMETER VALUES = ALPHA1 AND ALPHA2.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C                 --ALPHA2 SHOULD BE POSITIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           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
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'JSURAN SUBROUTINE IS NON-POSITIVE *****')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
C
C     GENERATE N STANDARD NORMAL RANDOM NUMBERS;
C
      CALL NORRAN(N,ISEED,X)
C
C     GENERATE N JOHNSON SU DISTRIBUTION RANDOM NUMBERS
C     USING APPLIED STATISTICS ALGORITHM.
C
C     GENERATE N JOHNSON SU DISTRIBUTION RANDOM NUMBERS
C     USING APPLIED STATISTICS ALGORITHM AS100.
C
      ITYPE=2
      ALOC=0.0
      SCALE=1.0
      DO100I=1,N
        XTEMP=X(I)
        XTEMP2=AJV(XTEMP,ITYPE,ALPHA1,ALPHA2,SCALE,ALOC,IFAULT)
        X(I)=XTEMP2
  100 CONTINUE
C
 9000 CONTINUE
      RETURN
      END
      DOUBLE PRECISION FUNCTION K0INT(XVALUE)
C
C   DESCRIPTION:
C
C      This function calculates the integral of the modified Bessel function
C      defined by
C
C         K0INT(x) = {integral 0 to x} K0(t) dt
C
C      The code uses Chebyshev expansions, whose coefficients are
C      given to 20 decimal places.
C
C
C   ERROR RETURNS:
C
C      If XVALUE < 0.0, the function is undefined. An error message is
C      printed and the function returns the value 0.0.
C
C
C   MACHINE-DEPENDENT CONSTANTS:
C
C      NTERM1 - The no. of terms to be used in the array AK0IN1. The 
C                recommended value is such that
C                   ABS(AK0IN1(NTERM1)) < EPS/100, 
C
C      NTERM2 - The no. of terms to be used in the array AK0IN2. The 
C                recommended value is such that
C                   ABS(AK0IN2(NTERM2)) < EPS/100,
C
C      NTERM3 - The no. of terms to be used in the array AK0INA. The 
C                recommended value is such that
C                   ABS(AK0INA(NTERM3)) < EPS/100, 
C
C      XLOW - The value below which K0INT = x * ( const - ln(x) ) to
C             machine precision. The recommended value is
C                   sqrt (18*EPSNEG).
C
C      XHIGH - The value above which K0INT = pi/2 to machine precision.
C              The recommended value is
C                   - log (2*EPSNEG)
C
C      For values of EPS and EPSNEG refer to the file MACHCON.TXT.
C
C      The machine-dependent constants are computed internally by
C      using the D1MACH subroutine.
C
C
C   INTRINSIC FUNCTIONS USED:
C
C      EXP , LOG , SQRT
C
C
C   OTHER MISCFUN SUBROUTINES USED:
C
C          CHEVAL , ERRPRN, D1MACH
C
C
C   AUTHOR:
C         Dr. Allan J. MacLeod,
C         Dept. of Mathematics and Statistics,
C         University of Paisley,
C         High St.,
C         Paisley,
C         SCOTLAND
C
C         (e-mail: macl_ms0@paisley.ac.uk )
C
C
C   LATEST REVISION:
C                   23 January, 1996
C
      INTEGER NTERM1,NTERM2,NTERM3
      DOUBLE PRECISION AK0IN1(0:15),AK0IN2(0:15),AK0INA(0:27),
     1     CHEVAL,CONST1,CONST2,EIGHTN,FVAL,HALF,
     2     ONEHUN,PIBY2,RT2BPI,SIX,T,TEMP,TWELVE,X,
     3     XHIGH,XLOW,XVALUE,ZERO
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOMC.INC'
      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 CHARACTER FNNAME*8,ERRMSG*14
CCCCC DATA FNNAME/'K0INT '/
CCCCC DATA ERRMSG/'ARGUMENT < 0.0'/
      DATA ZERO,HALF,SIX/ 0.0 D 0 , 0.5 D 0 , 6.0 D 0 /
      DATA TWELVE,EIGHTN,ONEHUN/ 12.0 D 0 , 18.0 D 0 , 100.0 D 0 /
      DATA CONST1/1.11593 15156 58412 44881 D 0/
      DATA CONST2/-0.11593 15156 58412 44881 D 0/
      DATA PIBY2/1.57079 63267 94896 61923 D 0/
      DATA RT2BPI/0.79788 45608 02865 35588 D 0/
      DATA AK0IN1/16.79702 71446 47109 59477  D    0,
     1             9.79134 68767 68894 07070  D    0,
     2             2.80501 31604 43379 39300  D    0,
     3             0.45615 62053 18885 02068  D    0,
     4             0.47162 24457 07476 0784   D   -1,
     5             0.33526 51482 69698 289    D   -2,
     6             0.17335 18119 38747 27     D   -3,
     7             0.67995 18893 64702        D   -5,
     8             0.20900 26835 9924         D   -6,
     9             0.51660 38469 76           D   -8,
     X             0.10485 70833 1            D   -9,
     1             0.17782 9320               D  -11,
     2             0.25568 44                 D  -13,
     3             0.31557                    D  -15,
     4             0.338                      D  -17,
     5             0.3                        D  -19/
      DATA AK0IN2/10.76266 55822 78091 74077  D    0,
     1             5.62333 47984 99975 11550  D    0,
     2             1.43543 66487 92908 67158  D    0,
     3             0.21250 41014 37438 96043  D    0,
     4             0.20365 37393 10000 9554   D   -1,
     5             0.13602 35840 95623 632    D   -2,
     6             0.66753 88699 20909 3      D   -4,
     7             0.25043 00357 07337        D   -5,
     8             0.74064 23741 728          D   -7,
     9             0.17697 47043 14           D   -8,
     X             0.34857 75254              D  -10,
     1             0.57544 785                D  -12,
     2             0.80748 1                  D  -14,
     3             0.9747                     D  -16,
     4             0.102                      D  -17,
     5             0.1                        D  -19/
      DATA AK0INA(0)/  1.91172 06544 50604 53895  D    0/
      DATA AK0INA(1)/ -0.41830 64565 76958 1085   D   -1/
      DATA AK0INA(2)/  0.21335 25080 68147 486    D   -2/
      DATA AK0INA(3)/ -0.15859 49728 45041 81     D   -3/
      DATA AK0INA(4)/  0.14976 24699 85835 1      D   -4/
      DATA AK0INA(5)/ -0.16795 59553 22241        D   -5/
      DATA AK0INA(6)/  0.21495 47247 8804         D   -6/
      DATA AK0INA(7)/ -0.30583 56654 790          D   -7/
      DATA AK0INA(8)/  0.47494 64133 43           D   -8/
      DATA AK0INA(9)/ -0.79424 66043 2            D   -9/
      DATA AK0INA(10)/ 0.14156 55532 5            D   -9/
      DATA AK0INA(11)/-0.26678 25359              D  -10/
      DATA AK0INA(12)/ 0.52814 9717               D  -11/
      DATA AK0INA(13)/-0.10926 3199               D  -11/
      DATA AK0INA(14)/ 0.23518 838                D  -12/
      DATA AK0INA(15)/-0.52479 91                 D  -13/
      DATA AK0INA(16)/ 0.12101 91                 D  -13/
      DATA AK0INA(17)/-0.28763 2                  D  -14/
      DATA AK0INA(18)/ 0.70297                    D  -15/
      DATA AK0INA(19)/-0.17631                    D  -15/
      DATA AK0INA(20)/ 0.4530                     D  -16/
      DATA AK0INA(21)/-0.1190                     D  -16/
      DATA AK0INA(22)/ 0.319                      D  -17/
      DATA AK0INA(23)/-0.87                       D  -18/
      DATA AK0INA(24)/ 0.24                       D  -18/
      DATA AK0INA(25)/-0.7                        D  -19/
      DATA AK0INA(26)/ 0.2                        D  -19/
      DATA AK0INA(27)/-0.1                        D  -19/
C
C   Start computation
C
      X = XVALUE
C
C   Error test
C
      IF ( X .LT. ZERO ) THEN
CCCCC    CALL ERRPRN(FNNAME,ERRMSG)
         WRITE(ICOUT,999)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,101)X
         CALL DPWRST('XXX','BUG ')
         K0INT = ZERO
         RETURN
      ENDIF
  999 FORMAT(1X)
  101 FORMAT('***** ERROR FROM I0INT--ARGUMENT MUST BE ',
     1        'NON-NEGATIVE, ARGUMENT = ',G15.7)
C
C   Compute the machine-dependent constants.
C
      TEMP = D1MACH(3)
      T = TEMP / ONEHUN
      IF ( X .LE. SIX ) THEN
         DO 10 NTERM1 = 15 , 0 , -1
            IF ( ABS(AK0IN1(NTERM1)) .GT. T ) GOTO 19
 10      CONTINUE
 19      DO 20 NTERM2 = 15 , 0 , -1
            IF ( ABS(AK0IN2(NTERM2)) .GT. T ) GOTO 29
 20      CONTINUE
 29      XLOW = SQRT ( EIGHTN * TEMP )
      ELSE
         DO 40 NTERM3 = 27 , 0 , -1
            IF ( ABS(AK0INA(NTERM3)) .GT. T ) GOTO 49
 40      CONTINUE
 49      XHIGH = - LOG ( TEMP + TEMP )
      ENDIF
C
C   Code for 0 <= XVALUE <= 6
C
      IF ( X .LE. SIX ) THEN
         IF ( X .LT. XLOW ) THEN
            FVAL = X
            IF ( X .GT. ZERO ) THEN
               FVAL = FVAL * ( CONST1 - LOG(X) )
            ENDIF
            K0INT = FVAL
         ELSE
            T = ( ( X * X ) / EIGHTN - HALF ) - HALF
            FVAL = ( CONST2 + LOG(X) ) * CHEVAL(NTERM2,AK0IN2,T)
            K0INT = X * ( CHEVAL(NTERM1,AK0IN1,T) - FVAL )
         ENDIF
C
C   Code for x > 6
C
      ELSE
         FVAL = PIBY2
         IF ( X .LT. XHIGH ) THEN
            T = ( TWELVE / X - HALF ) - HALF
            TEMP = EXP(-X) * CHEVAL(NTERM3,AK0INA,T)
            FVAL = FVAL - TEMP / ( SQRT(X) * RT2BPI)
         ENDIF
         K0INT = FVAL
      ENDIF
      RETURN
      END
      SUBROUTINE KAPCDF(X,AK,BETA,THETA,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DENSITY
C              FUNCTION VALUE FOR THE MIELKE'S BETA-KAPPA DISTRIBUTION
C              WITH POSITIVE SHAPE PARAMETERS K, BETA, AND THETA.
C              THIS DISTRIBUTION IS DEFINED FOR X > 0.
C              THE PDF FOR THE DISTRIBUTION IS
C                  F(X) = (K/B)*(X/B)**(K-1)/[1+(X/B)**T]**(1+(K/T))
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE POSITIVE
C                     --AK     = A POSITIVE SHAPE PARAMETER
C                     --BETA   = A POSITIVE SHAPE PARAMETER
C                     --THETA  = 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 MIELKE'S BETA-KAPPA
C             DISTRIBUTION
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE POSITIVE.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--2, 2ND ED, 1994, PAGE 351.
C     WRITTEN BY--JAMES J. FILLIBEN
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--96/1
C     ORIGINAL VERSION--JANUARY   1996.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX, DK, DT, DB
CCCCC DOUBLE PRECISION DTERM1, DTERM2, DTERM3
      DOUBLE PRECISION DTERM1, DTERM2
      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-----DATA STATEMENTS-------------------------------------------------
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(X.LE.0)THEN
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9999
      ENDIF
    5 FORMAT('***** FATAL ERROR--THE FIRST INPUT ARGUMENT TO THE ',
     1'KAPCDF SUBROUTINE IS NON-POSITIVE *****')
      IF(AK.LE.0)THEN
        WRITE(ICOUT,15)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)AK
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9999
      ENDIF
   15 FORMAT('***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE ',
     1'KAPCDF SUBROUTINE IS NON-POSITIVE *****')
      IF(BETA.LE.0)THEN
        WRITE(ICOUT,25)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)BETA
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9999
      ENDIF
   25 FORMAT('***** FATAL ERROR--THE THIRD INPUT ARGUMENT TO THE ',
     1'KAPCDF SUBROUTINE IS NON-POSITIVE *****')
      IF(THETA.LE.0)THEN
        WRITE(ICOUT,35)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)THETA
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9999
      ENDIF
   35 FORMAT('***** FATAL ERROR--THE THIRD INPUT ARGUMENT TO THE ',
     1'KAPCDF SUBROUTINE IS NON-POSITIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
      DX=DBLE(X)
      DK=DBLE(AK)
      DB=DBLE(BETA)
      DT=DBLE(THETA)
C
      DTERM1=DT*DLOG(DX/DB) - DLOG(1.0D0+(DX/DB)**DT)
      DTERM2=(DK/DT)*DTERM1
      DCDF=0.0D0
      IF(DTERM2.GE.-80.0D0)DCDF=DEXP(DTERM2)
      CDF=REAL(DCDF)
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE KAPPDF(X,AK,BETA,THETA,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE MIELKE'S BETA-KAPPA DISTRIBUTION
C              WITH POSITIVE SHAPE PARAMETERS K, BETA, AND THETA.
C              THIS DISTRIBUTION IS DEFINED FOR X > 0.
C              THE PDF FOR THE STANDARD FORM OF THE DISTRIBUTION IS
C                  F(X) = (K/B)*(X/B)**(K-1)/[1+(X/B)**T]**(1+(K/T))
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                     --AK     = A POSITIVE SHAPE PARAMETER
C                     --BETA   = A POSITIVE SHAPE PARAMETER
C                     --THETA  = 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 MIELKE'S BETA-KAPPA
C             DISTRIBUTION
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE POSITIVE.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--2, 2ND ED, 1994, PAGE 351.
C     WRITTEN BY--JAMES J. FILLIBEN
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--96/1
C     ORIGINAL VERSION--JANUARY   1996.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX, DK, DT, DB
      DOUBLE PRECISION DTERM1, DTERM2, DTERM3
      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-----DATA STATEMENTS-------------------------------------------------
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(X.LE.0)THEN
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ENDIF
    5 FORMAT('***** FATAL ERROR--THE FIRST INPUT ARGUMENT TO THE ',
     1'KAPPDF SUBROUTINE IS NON-POSITIVE *****')
      IF(AK.LE.0)THEN
        WRITE(ICOUT,15)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)AK
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ENDIF
   15 FORMAT('***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE ',
     1'KAPPDF SUBROUTINE IS NON-POSITIVE *****')
      IF(BETA.LE.0)THEN
        WRITE(ICOUT,25)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)BETA
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ENDIF
   25 FORMAT('***** FATAL ERROR--THE THIRD INPUT ARGUMENT TO THE ',
     1'KAPPDF SUBROUTINE IS NON-POSITIVE *****')
      IF(THETA.LE.0)THEN
        WRITE(ICOUT,35)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)THETA
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ENDIF
   35 FORMAT('***** FATAL ERROR--THE THIRD INPUT ARGUMENT TO THE ',
     1'KAPPDF SUBROUTINE IS NON-POSITIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
      DX=DBLE(X)
      DK=DBLE(AK)
      DB=DBLE(BETA)
      DT=DBLE(THETA)
C
      DTERM1=DLOG(DK) + (DK-1.0D0)*DLOG(DX/DB)
      DTERM2=DLOG(DB) + (1.0D0 + (DK/DT))*DLOG(1.0D0 + (DX/DB)**DT)
      DTERM3=DTERM1-DTERM2
      DPDF=0.0D0
      IF(DTERM3.GE.-80.0D0)DPDF=DEXP(DTERM3)
      PDF=REAL(DPDF)
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE KAPPPF(P,AK,BETA,THETA,PPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE MIELKE'S BETA-KAPPA DISTRIBUTION
C              WITH POSITIVE SHAPE PARAMETERS K, BETA, AND THETA.
C              THIS DISTRIBUTION IS DEFINED FOR X > 0.
C              THE PDF FOR THE STANDARD FORM OF THE DISTRIBUTION IS
C                  F(X) = (K/B)*(X/B)**(K-1)/[1+(X/B)**T]**(1+(K/T))
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                     --AK     = A POSITIVE SHAPE PARAMETER
C                     --BETA   = A POSITIVE SHAPE PARAMETER
C                     --THETA  = 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 MIELKE'S BETA-KAPPA
C             DISTRIBUTION
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE POSITIVE.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--2, 2ND ED, 1994, PAGE 351.
C                 THE JOHNSON AND KOTZ BOOK APPEARS TO HAVE AN
C                 ERROR IN THE PPF FORMULA
C     WRITTEN BY--JAMES J. FILLIBEN
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
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DP, DK, DT, DB
      DOUBLE PRECISION DTERM1, DTERM2, DTERM3, DTERM4, DTERM5
      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,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' KAPPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL.')
      IF(AK.LE.0)THEN
        WRITE(ICOUT,15)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)AK
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ENDIF
   15 FORMAT('***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE ',
     1'KAPPPF SUBROUTINE IS NON-POSITIVE *****')
      IF(BETA.LE.0)THEN
        WRITE(ICOUT,25)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)BETA
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ENDIF
   25 FORMAT('***** FATAL ERROR--THE THIRD INPUT ARGUMENT TO THE ',
     1'KAPPPF SUBROUTINE IS NON-POSITIVE *****')
      IF(THETA.LE.0)THEN
        WRITE(ICOUT,35)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)THETA
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ENDIF
   35 FORMAT('***** FATAL ERROR--THE THIRD INPUT ARGUMENT TO THE ',
     1'KAPPPF SUBROUTINE IS NON-POSITIVE *****')
C
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
      DP=DBLE(P)
      DK=DBLE(AK)
      DB=DBLE(BETA)
      DT=DBLE(THETA)
C
      DTERM1=DLOG(DB)
      DTERM2=(1.0D0/DT)
      DTERM3=DP**(DT/DK)
      DTERM4=DLOG(-DTERM3/(DTERM3-1.0D0))
      DTERM5=DTERM1 + DTERM2*DTERM4
      DPPF=0.0D0
      IF(DTERM5.GE.-80.0D0)DPPF=DEXP(DTERM5)
      PPF=REAL(DPPF)

C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE KAPRAN(N,AK,BETA,THETA,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE MIELKE'S BETA-KAPPA DISTRIBUTION
C              WITH SHAPE PARAMETERs = K, BETA, THETA.
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --K      = THE SINGLE PRECISION VALUE OF THE
C                                K SHAPE PARAMETER.
C                                ANU SHOULD BE A POSITIVE INTEGER.
C                     --BETA   = THE SINGLE PRECISION VALUE OF THE
C                                BETA SHAPE PARAMETER.
C                     --THETA  = THE SINGLE PRECISION VALUE OF THE
C                                THETA 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 MIELKE'S BETA-KAPPA DISTRIBUTION
C             WITH DEGREES OF FREEDOM PARAMETER VALUE = ANU.
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 MIELKE ',
     1       'BETA-KAPPA RANDOM NUMBERS IS NON-POSITIVE.')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8)
C
      IF(AK.LE.0)THEN
        WRITE(ICOUT,15)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)AK
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ENDIF
   15 FORMAT('***** FATAL ERROR--THE FIRST SHAPE PARAMETER (K) FOR ',
     1'THE  MIELKE BETA-KAPPA RANDOM NUMBERS IS NON-POSITIVE')
      IF(BETA.LE.0)THEN
        WRITE(ICOUT,25)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)BETA
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ENDIF
   25 FORMAT('***** FATAL ERROR--THE SECOND SHAPE PARAMETER (BETA) ',
     1'FOR THE  MIELKE BETA-KAPPA RANDOM NUMBERS IS NON-POSITIVE')
      IF(THETA.LE.0)THEN
        WRITE(ICOUT,35)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)THETA
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ENDIF
   35 FORMAT('***** FATAL ERROR--THE THIRD SHAPE PARAMETER (THETA) ',
     1'FOR THE  MIELKE BETA-KAPPA RANDOM NUMBERS 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 MIELKE'S BETA-KAPPA DISTRIBUTION RANDOM
C     NUMBERS USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD.
C
      DO100I=1,N
        CALL KAPPPF(X(I),AK,BETA,THETA,XTEMP)
        X(I)=XTEMP
  100 CONTINUE
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE KCONS(Y,X,XIDTEM,TEMP,N,IWRITE,YOUT,NUMSET,
     1ISUBRO,IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE K CONSISTENCY STATISTIC
C              OF THE DATA IN THE INPUT VECTOR Y WITH LAB ID
C              VECTOR X.  THE K CONSISTENCY STATISTIC IS DEFINED AS:
C             
C                 K(i) = SD(i)/Sr
C
C              WITH SD(i) DENOTING THE STANDARD DEVIATION OF
C              LAB i AND THE REPEATABILITY STANDARD DEVIATION,
C              RESPECTIVELY.  THE REPEATABILITY STANDARD
C              DEVIATION IS DEFINED AS:
C
C                 Sr = SQRT(SUM[i=1 to p][s(i)**2/p]
C
C              WITH
C                 p      = NUMBER OF LABS
C                 s(i)   = STANDARD DEVIATION OF GROUP i.
C
C     INPUT  ARGUMENTS--Y      = THE SINGLE PRECISION VECTOR OF
C                                (UNSORTED OR SORTED) OBSERVATIONS.
C                     --X      = THE SINGLE PRECISION VECTOR OF
C                                GROUP ID's.
C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR Y.
C     OUTPUT ARGUMENTS--YOUT   = THE SINGLE PRECISION VECTOR OF THE
C                                COMPUTED SAMPLE K CONSISTENCY
C                                STATISTIC.
C                     --NUMSET = THE INTEGER VALUE CONTAINING THE
C                                NUMBER OF GROUPS IN X
C     OUTPUT--THE COMPUTED SINGLE PRECISION VECTOR OF THE
C             SAMPLE K CONSISTENCY STATISTIC.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--SORT, DISTIN, SD.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--SQRT.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--"Standard Practice for Conducting an
C                 Interlaboratory Study to Determine the Precision
C                 of a Test Method", ASTM International,
C                 100 Barr Harbor Drive, PO BOX C700,
C                 West Conshohoceken, PA 19428-2959, USA.
C                 This document is in support of
C                 ASTM Standard E 691 - 99.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2005.2
C     ORIGINAL VERSION--FEBRUARY  2005.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGA3
      CHARACTER*4 ISUBRO
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DSUM
C
      DIMENSION Y(*)
      DIMENSION X(*)
      DIMENSION YOUT(*)
      DIMENSION XIDTEM(*)
      DIMENSION TEMP(*)
C
C---------------------------------------------------------------------
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='KCON'
      ISUBN2='S   '
C
      IERROR='NO'
C
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CONS')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,51)
   51   FORMAT('***** AT THE BEGINNING OF KCONS--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,52)IBUGA3,ISUBRO,N
   52   FORMAT('IBUGA3,ISUBRO,N = ',A4,1X,A4,1X,I8)
        CALL DPWRST('XXX','BUG ')
        DO55I=1,N
          WRITE(ICOUT,56)I,Y(I),X(I)
   56     FORMAT('I,Y(I),X(I) = ',I8,2E15.7)
          CALL DPWRST('XXX','BUG ')
   55   CONTINUE
      ENDIF
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      AN=N
C
      IF(N.LE.1)THEN
        IERROR='YES'
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,111)
  111   FORMAT('***** ERROR IN COMPUTING K CONSISTENCY STATISTIC--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,112)
  112   FORMAT('      THE INPUT NUMBER OF OBSERVATIONS IN THE')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,114)
  114   FORMAT('      VARIABLES FOR WHICH THE K CONSISTENCY ',
     1         'STATISTIC')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,115)
  115   FORMAT('      IS TO BE COMPUTED MUST BE 2 OR LARGER.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,116)
  116   FORMAT('      SUCH WAS NOT THE CASE HERE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,117)N
  117   FORMAT('      THE INPUT NUMBER OF OBSERVATIONS = ',I8,'.')
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        GOTO9000
      ENDIF
C
C               ****************************************************
C               **  STEP 2--                                      **
C               **  COMPUTE THE K CONSISTENCY STATISTIC           **
C               ****************************************************
C
      IWRITE='OFF'
      CALL DISTIN(X,N,IWRITE,XIDTEM,NUMSET,IBUGA3,IERROR)
      CALL SORT(XIDTEM,NUMSET,XIDTEM)
C
      IF(NUMSET.LT.1)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,111)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,192)
  192   FORMAT('      NUMBER OF LABS    NUMSET < 1')
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        GOTO9000
      ENDIF
C
      DSUM=0.0D0
      J=0
      DO1110ISET1=1,NUMSET
        K=0
        DO1130I=1,N
          IF(XIDTEM(ISET1).EQ.X(I))THEN
            K=K+1
            TEMP(K)=Y(I)
          ENDIF
 1130   CONTINUE
        NTEMP=K 
        CALL SD(TEMP,NTEMP,IWRITE,XSD,IBUGA3,IERROR)
        DSUM=DSUM + DBLE(XSD)**2
        YOUT(ISET1)=XSD
        IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CONS')THEN
          WRITE(ICOUT,1131)NUMSET,XSD
 1131     FORMAT('***** GROUP ',I8,' SD = ',G15.7)
          CALL DPWRST('XXX','BUG ')
        ENDIF
 1110 CONTINUE
C
      XREP=REAL(DSQRT(DSUM/DBLE(NUMSET)))
      DO1150I=1,NUMSET
        YOUT(I)=YOUT(I)/XREP
 1150 CONTINUE
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CONS')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END       OF KCONS--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9012)IBUGA3,ISUBRO,IERROR
 9012   FORMAT('IBUGA3,ISUBRO,IERROR = ',A4,2X,A4,2X,A4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9013)N,NUMSET
 9013   FORMAT('N,NUMSET = ',I8,1X,I8)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9015)XREP
 9015   FORMAT('XREP = ',E15.7)
        CALL DPWRST('XXX','BUG ')
        DO9018I=1,NUMSET
          WRITE(ICOUT,9019)I,YOUT(I)
 9019     FORMAT('I,YOUT(I) = ',I8,E15.7)
          CALL DPWRST('XXX','BUG ')
 9018   CONTINUE
      ENDIF
C
      RETURN
      END
      SUBROUTINE KCONS2(Y,X1,X2,XIDTEM,XIDTE2,TEMP,N,
     1IWRITE,YOUT,TAG,NOUT,
     1ISUBRO,IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE K CONSISTENCY STATISTIC
C              OF THE DATA IN THE INPUT VECTOR Y WITH LAB ID
C              VECTOR X.  THE K CONSISTENCY STATISTIC IS DEFINED AS:
C             
C                 K(i) = SD(i)/Sr
C
C              WITH SD(i) DENOTING THE STANDARD DEVIATION OF
C              LAB i AND THE REPEATABILITY STANDARD DEVIATION,
C              RESPECTIVELY.  THE REPEATABILITY STANDARD
C              DEVIATION IS DEFINED AS:
C
C                 Sr = SQRT(SUM[i=1 to p][s(i)**2/p]
C
C              WITH
C                 p      = NUMBER OF LABS
C                 s(i)   = STANDARD DEVIATION OF GROUP i.
C
C              THE DISTINCTION BETWEEN KCONS AND KCONS2 IS THAT
C              KCONS IS USED TO COMPUTE THE K CONSISTENCY STATISTIC
C              FOR A SINGLE MATERIAL WHILE KCONS2 COMPUTES THE
C              K CONSISTENCY STATISTIC FOR MULTIPLE MATERIALS.
C
C     INPUT  ARGUMENTS--Y      = THE SINGLE PRECISION VECTOR OF
C                                (UNSORTED OR SORTED) OBSERVATIONS.
C                     --X1     = THE SINGLE PRECISION VECTOR OF
C                                GROUP ID's.
C                     --X2     = THE SINGLE PRECISION VECTOR OF
C                                MATERIAL ID's.
C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR Y.
C     OUTPUT ARGUMENTS--YOUT   = THE SINGLE PRECISION VECTOR OF THE
C                                COMPUTED SAMPLE K CONSISTENCY
C                                STATISTIC.
C                     --TAG    = THE SINGLE PRECISION VECTOR OF THE
C                                MATERIAL ID's.
C                     --NOUT   = THE INTEGER VALUE CONTAINING THE
C                                NUMBER OF VALUES IN YOUT
C     OUTPUT--THE COMPUTED SINGLE PRECISION VECTOR OF THE
C             SAMPLE K CONSISTENCY STATISTIC.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--SORT, DISTIN, SD.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--SQRT.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--"Standard Practice for Conducting an
C                 Interlaboratory Study to Determine the Precision
C                 of a Test Method", ASTM International,
C                 100 Barr Harbor Drive, PO BOX C700,
C                 West Conshohoceken, PA 19428-2959, USA.
C                 This document is in support of
C                 ASTM Standard E 691 - 99.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2005.2
C     ORIGINAL VERSION--FEBRUARY  2005.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGA3
      CHARACTER*4 ISUBRO
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DSUM
C
      DIMENSION Y(*)
      DIMENSION X1(*)
      DIMENSION X2(*)
      DIMENSION YOUT(*)
      DIMENSION TAG(*)
      DIMENSION XIDTEM(*)
      DIMENSION XIDTE2(*)
      DIMENSION TEMP(*)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='KCON'
      ISUBN2='S2  '
C
      IERROR='NO'
C
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'ONS2')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,51)
   51   FORMAT('***** AT THE BEGINNING OF KCONS--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,52)IBUGA3,ISUBRO,N
   52   FORMAT('IBUGA3,ISUBRO,N = ',A4,1X,A4,1X,I8)
        CALL DPWRST('XXX','BUG ')
        DO55I=1,N
          WRITE(ICOUT,56)I,Y(I),X1(I),X2(I)
   56     FORMAT('I,Y(I),X1(I),X2(I) = ',I8,3G15.7)
          CALL DPWRST('XXX','BUG ')
   55   CONTINUE
      ENDIF
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      AN=N
C
      IF(N.LE.1)THEN
        IERROR='YES'
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,111)
  111   FORMAT('***** ERROR IN COMPUTING K CONSISTENCY STATISTIC--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,112)
  112   FORMAT('      THE INPUT NUMBER OF OBSERVATIONS IN THE')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,114)
  114   FORMAT('      VARIABLES FOR WHICH THE K CONSISTENCY ',
     1         'STATISTIC')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,115)
  115   FORMAT('      IS TO BE COMPUTED MUST BE 2 OR LARGER.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,116)
  116   FORMAT('      SUCH WAS NOT THE CASE HERE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,117)N
  117   FORMAT('      THE INPUT NUMBER OF OBSERVATIONS = ',I8,'.')
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        GOTO9000
      ENDIF
C
C               ****************************************************
C               **  STEP 2--                                      **
C               **  COMPUTE THE K CONSISTENCY STATISTIC           **
C               ****************************************************
C
      IWRITE='OFF'
      CALL DISTIN(X1,N,IWRITE,XIDTEM,NUMSE1,IBUGA3,IERROR)
      CALL SORT(XIDTEM,NUMSE1,XIDTEM)
      CALL DISTIN(X2,N,IWRITE,XIDTE2,NUMSE2,IBUGA3,IERROR)
      CALL SORT(XIDTE2,NUMSE2,XIDTEM)
C
      IF(NUMSE1.LT.1)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,111)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,192)
  192   FORMAT('      NUMBER OF LABS    NUMSE1 < 1')
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        GOTO9000
      ENDIF
C
      IF(NUMSE2.LT.1)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,111)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,194)
  194   FORMAT('      NUMBER OF MATERIALS    NUMSE2 < 1')
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        GOTO9000
      ENDIF
C
      J=0
      DO1110ISET2=1,NUMSE2
C
        DSUM=0.0D0
        DO1130ISET1=1,NUMSE1
C
          K=0
          DO1140I=1,N
            IF(XIDTEM(ISET1).EQ.X1(I).AND.XIDTE2(ISET2).EQ.X2(I))THEN
              K=K+1
              TEMP(K)=Y(I)
            ENDIF
 1140     CONTINUE
          NTEMP=K
C
          CALL SD(TEMP,NTEMP,IWRITE,XSD,IBUGA3,IERROR)
          DSUM=DSUM + DBLE(XSD)**2
          NOUT=(ISET2-1)*NUMSE1 + ISET1
          YOUT(NOUT)=XSD
          IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'ONS2')THEN
            WRITE(ICOUT,1141)NUMSE1,NUMSE2,XSD
 1141       FORMAT('***** GROUP ',I8,' SD = ',G15.7)
            CALL DPWRST('XXX','BUG ')
          ENDIF
 1130   CONTINUE
C
        XREP=REAL(DSQRT(DSUM/DBLE(NUMSE1)))
        DO1150I=(ISET2-1)*NUMSE1+1,ISET2*NUMSE1
          YOUT(I)=YOUT(I)/XREP
 1150   CONTINUE
C
 1110 CONTINUE
      NOUT=NUMSE1*NUMSE2
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'ONS2')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END       OF KCONS--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9012)IBUGA3,ISUBRO,IERROR
 9012   FORMAT('IBUGA3,ISUBRO,IERROR = ',A4,2X,A4,2X,A4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9013)N,NUMSE1,NUMSE2,XREP
 9013   FORMAT('N,NUMSE1,NUMSE2,XREP = ',I8,1X,I8,1X,I8,G15.7)
        CALL DPWRST('XXX','BUG ')
        DO9018I=1,NOUT
          WRITE(ICOUT,9019)I,TAG(I),YOUT(I)
 9019     FORMAT('I,TAG(I),YOUT(I) = ',I8,2G15.7)
          CALL DPWRST('XXX','BUG ')
 9018   CONTINUE
      ENDIF
C
      RETURN
      END
      SUBROUTINE KENTAU(X,Y,N,IWRITE,XTEMP,YTEMP,MAXNXT,XYKTAU,
     1IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE KENDELL'S TAU COEFFICIENT
C              BETWEEN THE 2 SETS OF DATA IN THE INPUT VECTORS X AND Y.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF
C                                (UNSORTED OR SORTED) OBSERVATIONS
C                                WHICH CONSTITUTE THE FIRST SET
C                                OF DATA.
C                     --Y      = THE SINGLE PRECISION VECTOR OF
C                                (UNSORTED OR SORTED) OBSERVATIONS
C                                WHICH CONSTITUTE THE SECOND SET
C                                OF DATA.
C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR X, OR EQUIVALENTLY,
C                                THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR Y.
C     OUTPUT ARGUMENTS--XYKTAU = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED KENDELL'S TAU
C                                COEFFICIENT BETWEEN THE 2 SETS OF
C                                DATA IN THE INPUT VECTORS X AND Y.
C                                THIS SINGLE PRECISION VALUE
C                                WILL BE BETWEEN -1.0 AND 1.0
C                                (INCLUSIVELY).
C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
C             KENDELL'S TAU BETWEEN THE 2 SETS
C             OF DATA IN THE INPUT VECTORS X AND Y.
C     OTHER DATAPAC   SUBROUTINES NEEDED--SORTC.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--DSQRT.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--W. J. CONOVER, "PRACTICAL NON-PARAMETRIC
C                 STATISTICS", THIRD EDITION, WILEY, 1999,
C                 PP. 318-322.
C     WRITTEN BY--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/10
C     ORIGINAL VERSION--OCTOBER   2004.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 IWRIT2
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
      DIMENSION Y(*)
C
      DIMENSION XTEMP(*)
      DIMENSION YTEMP(*)
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='KENT'
      ISUBN2='AU  '
C
      IERROR='NO'
C
      IF(IBUGA3.EQ.'ON')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,51)
   51   FORMAT('***** AT THE BEGINNING OF KENTAU--')
        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),Y(I)
   56     FORMAT('I,X(I),Y(I) = ',I8,2E15.7)
          CALL DPWRST('XXX','BUG ')
   55   CONTINUE
       ENDIF
C
C               ********************************************
C               **  COMPUTE RANK CORRELATION COEFFICIENT  **
C               ********************************************
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      AN=N
C
      IF(N.LT.1.OR.N.GT.MAXNXT)THEN
        IERROR='YES'
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,111)
  111   FORMAT('***** ERROR IN KENDELLS TAU--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,112)
  112   FORMAT('      THE INPUT NUMBER OF OBSERVATIONS IN THE ',
     1         'VARIABLES FOR')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,114)
  114   FORMAT('      WHICH THE KENDELLS TAU COEFFICIENT IS TO BE ',
     1         'COMPUTED')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,115)MAXNXT
  115   FORMAT('      MUST BE BETWEEN 1 AND ',I8,' (INCLUSIVELY).')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,116)
  116   FORMAT('      SUCH WAS NOT THE CASE HERE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,117)N
  117   FORMAT('      THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8,
     1         '.')
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
      IF(N.EQ.1)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,121)
  121   FORMAT('***** WARNING IN KENDELLS TAU--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,123)
  123   FORMAT('      THE NUMBER OF PAIRS (N) HAS THE VALUE 1.')
        CALL DPWRST('XXX','BUG ')
        XYKTAU=1.0
        GOTO9000
      ENDIF
C
C               *************************************************
C               **  STEP 2--                                   **
C               **  COMPUTE THE RANK CORRELATION COEFFICIENT.  **
C               *************************************************
C
      CALL SORTC(X,Y,N,XTEMP,YTEMP)
C
      ANC=0.0
      AND=0.0
C
      NM1=N-1
      DO200J=1,NM1
        M=J+1
        DO300I=M,N
          ANUM=Y(J) - Y(I)
          ADENOM=X(J) - X(I)
          IF(ADENOM.NE.0.0)THEN
            RATIO=ANUM/ADENOM
            IF(RATIO.GT.0.0)THEN
              ANC=ANC+1.0
            ELSEIF(RATIO.LT.0.0)THEN
              AND=AND+1.0
            ELSE
              ANC=ANC+0.5
              AND=AND+0.5
            ENDIF
          ENDIF
  300   CONTINUE
  200 CONTINUE
      XYKTAU=(ANC-AND)/(ANC+AND)
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,XYKTAU
  811 FORMAT('THE KENDELLS TAU COEFFICIENT 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.'ON')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END       OF KENTAU--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9012)IBUGA3,IERROR
 9012   FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9013)N
 9013   FORMAT('N = ',I8)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9014)ANC,AND
 9014   FORMAT('ANC,AND = ',2G15.7)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9015)XYKTAU
 9015   FORMAT('XYKTAU = ',E15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      RETURN
      END
      SUBROUTINE KLVNA(X,BER,BEI,GER,GEI,DER,DEI,HER,HEI)
C
C       ======================================================
C       Purpose: Compute Kelvin functions ber x, bei x, ker x
C                and kei x, and their derivatives  ( x > 0 )
C       Input :  x   --- Argument of Kelvin functions
C       Output:  BER --- ber x
C                BEI --- bei x
C                GER --- ker x
C                GEI --- kei x
C                DER --- ber'x
C                DEI --- bei'x
C                HER --- ker'x
C                HEI --- kei'x
C       ================================================
C
        IMPLICIT DOUBLE PRECISION (A-H,O-Z)
        PI=3.141592653589793D0
        EL=.5772156649015329D0
        EPS=1.0D-15
        IF (X.EQ.0.0D0) THEN
           BER=1.0D0
           BEI=0.0D0
           GER=1.0D+300
           GEI=-0.25D0*PI
           DER=0.0D0
           DEI=0.0D0
           HER=-1.0D+300
           HEI=0.0D0
           RETURN
        ENDIF
        X2=0.25D0*X*X
        X4=X2*X2
        IF (DABS(X).LT.10.0D0) THEN
           BER=1.0D0
           R=1.0D0
           DO 10 M=1,60
              R=-0.25D0*R/(M*M)/(2.0D0*M-1.0D0)**2*X4
              BER=BER+R
              IF (DABS(R).LT.DABS(BER)*EPS) GO TO 15
10         CONTINUE
15         BEI=X2
           R=X2
           DO 20 M=1,60
              R=-0.25D0*R/(M*M)/(2.0D0*M+1.0D0)**2*X4
              BEI=BEI+R
              IF (DABS(R).LT.DABS(BEI)*EPS) GO TO 25
20         CONTINUE
25         GER=-(DLOG(X/2.0D0)+EL)*BER+0.25D0*PI*BEI
           R=1.0D0
           GS=0.0D0
           DO 30 M=1,60
              R=-0.25D0*R/(M*M)/(2.0D0*M-1.0D0)**2*X4
              GS=GS+1.0D0/(2.0D0*M-1.0D0)+1.0D0/(2.0D0*M)
              GER=GER+R*GS
              IF (DABS(R*GS).LT.DABS(GER)*EPS) GO TO 35
30         CONTINUE
35         GEI=X2-(DLOG(X/2.0D0)+EL)*BEI-0.25D0*PI*BER
           R=X2
           GS=1.0D0
           DO 40 M=1,60
              R=-0.25D0*R/(M*M)/(2.0D0*M+1.0D0)**2*X4
              GS=GS+1.0D0/(2.0D0*M)+1.0D0/(2.0D0*M+1.0D0)
              GEI=GEI+R*GS
              IF (DABS(R*GS).LT.DABS(GEI)*EPS) GO TO 45
40         CONTINUE
45         DER=-0.25D0*X*X2
           R=DER
           DO 50 M=1,60
              R=-0.25D0*R/M/(M+1.0D0)/(2.0D0*M+1.0D0)**2*X4
              DER=DER+R
              IF (DABS(R).LT.DABS(DER)*EPS) GO TO 55
50         CONTINUE
55         DEI=0.5D0*X
           R=DEI
           DO 60 M=1,60
              R=-0.25D0*R/(M*M)/(2.D0*M-1.D0)/(2.D0*M+1.D0)*X4
              DEI=DEI+R
              IF (DABS(R).LT.DABS(DEI)*EPS) GO TO 65
60            CONTINUE
65         R=-0.25D0*X*X2
           GS=1.5D0
           HER=1.5D0*R-BER/X-(DLOG(X/2.D0)+EL)*DER+0.25*PI*DEI
           DO 70 M=1,60
              R=-0.25D0*R/M/(M+1.0D0)/(2.0D0*M+1.0D0)**2*X4
              GS=GS+1.0D0/(2*M+1.0D0)+1.0D0/(2*M+2.0D0)
              HER=HER+R*GS
              IF (DABS(R*GS).LT.DABS(HER)*EPS) GO TO 75
70         CONTINUE
75         R=0.5D0*X
           GS=1.0D0
           HEI=0.5D0*X-BEI/X-(DLOG(X/2.D0)+EL)*DEI-0.25*PI*DER
           DO 80 M=1,60
              R=-0.25D0*R/(M*M)/(2*M-1.0D0)/(2*M+1.0D0)*X4
              GS=GS+1.0D0/(2.0D0*M)+1.0D0/(2*M+1.0D0)
              HEI=HEI+R*GS
              IF (DABS(R*GS).LT.DABS(HEI)*EPS) RETURN
80         CONTINUE
        ELSE
           PP0=1.0D0
           PN0=1.0D0
           QP0=0.0D0
           QN0=0.0D0
           R0=1.0D0
           KM=18
           IF (DABS(X).GE.40.0) KM=10
           FAC=1.0D0
           DO 85 K=1,KM
              FAC=-FAC
              XT=0.25D0*K*PI-INT(0.125D0*K)*2.0D0*PI
              CS=COS(XT)
              SS=SIN(XT)
              R0=0.125D0*R0*(2.0D0*K-1.0D0)**2/K/X
              RC=R0*CS
              RS=R0*SS
              PP0=PP0+RC
              PN0=PN0+FAC*RC
              QP0=QP0+RS
85            QN0=QN0+FAC*RS
           XD=X/DSQRT(2.0D0)
           XE1=DEXP(XD)
           XE2=DEXP(-XD)
           XC1=1.D0/DSQRT(2.0D0*PI*X)
           XC2=DSQRT(.5D0*PI/X)
           CP0=DCOS(XD+0.125D0*PI)
           CN0=DCOS(XD-0.125D0*PI)
           SP0=DSIN(XD+0.125D0*PI)
           SN0=DSIN(XD-0.125D0*PI)
           GER=XC2*XE2*(PN0*CP0-QN0*SP0)
           GEI=XC2*XE2*(-PN0*SP0-QN0*CP0)
           BER=XC1*XE1*(PP0*CN0+QP0*SN0)-GEI/PI
           BEI=XC1*XE1*(PP0*SN0-QP0*CN0)+GER/PI
           PP1=1.0D0
           PN1=1.0D0
           QP1=0.0D0
           QN1=0.0D0
           R1=1.0D0
           FAC=1.0D0
           DO 90 K=1,KM
              FAC=-FAC
              XT=0.25D0*K*PI-INT(0.125D0*K)*2.0D0*PI
              CS=DCOS(XT)
              SS=DSIN(XT)
              R1=0.125D0*R1*(4.D0-(2.0D0*K-1.0D0)**2)/K/X
              RC=R1*CS
              RS=R1*SS
              PP1=PP1+FAC*RC
              PN1=PN1+RC
              QP1=QP1+FAC*RS
              QN1=QN1+RS
90         CONTINUE
           HER=XC2*XE2*(-PN1*CN0+QN1*SN0)
           HEI=XC2*XE2*(PN1*SN0+QN1*CN0)
           DER=XC1*XE1*(PP1*CP0+QP1*SP0)-HEI/PI
           DEI=XC1*XE1*(PP1*SP0-QP1*CP0)+HER/PI
        ENDIF
        RETURN
        END
      SUBROUTINE KROBOV( NDIM, MINVLS, MAXVLS, FUNCTN, ABSEPS, RELEPS,
     &                   ABSERR, FINEST, INFORM )
*
*  Automatic Multidimensional Integration Subroutine
*               
*         AUTHOR: Alan Genz
*                 Department of Mathematics
*                 Washington State University
*                 Pulman, WA 99164-3113
*                 Email: AlanGenz@wsu.edu
*
*         Last Change: 4/15/98
*
*  KROBOV computes an approximation to the integral
*
*      1  1     1
*     I  I ... I       F(X)  dx(NDIM)...dx(2)dx(1)
*      0  0     0
*
*
*  KROBOV uses randomized Korobov rules. The primary references are
*  "Randomization of Number Theoretic Methods for Multiple Integration"
*   R. Cranley and T.N.L. Patterson, SIAM J Numer Anal, 13, pp. 904-14,
*  and 
*   "Optimal Parameters for Multidimensional Integration", 
*    P. Keast, SIAM J Numer Anal, 10, pp.831-838.
*   
***************  Parameters ********************************************
****** Input parameters
*  NDIM    Number of variables, must exceed 1, but not exceed 40
*  MINVLS  Integer minimum number of function evaluations allowed.
*          MINVLS must not exceed MAXVLS.  If MINVLS < 0 then the
*          routine assumes a previous call has been made with 
*          the same integrand and continues that calculation.
*  MAXVLS  Integer maximum number of function evaluations allowed.
*  FUNCTN  EXTERNALly declared user defined function to be integrated.
*          It must have parameters (NDIM,Z), where Z is a real array
*          of dimension NDIM.
*  ABSEPS  Required absolute accuracy.
*  RELEPS  Required relative accuracy.
****** Output parameters
*  MINVLS  Actual number of function evaluations used.
*  ABSERR  Estimated absolute accuracy of FINEST.
*  FINEST  Estimated value of integral.
*  INFORM  INFORM = 0 for normal exit, when 
*                     ABSERR <= MAX(ABSEPS, RELEPS*ABS(FINEST))
*                  and 
*                     INTVLS <= MAXCLS.
*          INFORM = 1 If MAXVLS was too small to obtain the required 
*          accuracy. In this case a value FINEST is returned with 
*          estimated absolute accuracy ABSERR.
************************************************************************
      EXTERNAL FUNCTN
      INTEGER NDIM, MINVLS, MAXVLS, INFORM, NP, PLIM, NLIM, 
     &        SAMPLS, I, INTVLS, MINSMP
      PARAMETER ( PLIM = 20, NLIM = 100, MINSMP = 6 )
      INTEGER C(PLIM,NLIM), P(PLIM)
      DOUBLE PRECISION FUNCTN, ABSEPS, RELEPS, FINEST, ABSERR, DIFINT, 
     &       FINVAL, VARSQR, VAREST, VARPRD, VALUE
      DOUBLE PRECISION ALPHA(NLIM), X(NLIM), VK(NLIM), ONE
      PARAMETER ( ONE = 1 )
      SAVE P, C, SAMPLS, NP, VAREST
C
      DATA P( 1), ( C( 1,I), I = 1, 99 ) /    113,
     &     42,    54,    55,    32,    13,    26,    26,    13,    26,
     &     14,    13,    26,    35,     2,     2,     2,     2,    56,
     &     28,     7,     7,    28,     4,    49,     4,    40,    48,
     &      5,    35,    27,    16,    16,     2,     2,     7,    28,
     &      4,    49,     4,    56,     8,     2,     2,    56,     7,
     &     16,    28,     7,     7,    28,     4,    49,     4,    37,
     &     55,    21,    33,    40,    16,    16,    28,     7,    16,
     &     28,     4,    49,     4,    56,    35,     2,     2,     2,
     &     16,    16,    28,     4,    16,    28,     4,    49,     4,
     &     40,    40,     5,    42,    27,    16,    16,    28,     4,
     &     16,    28,     4,    49,     4,     8,     8,     2,     2/
      DATA P( 2), ( C( 2,I), I = 1, 99 ) /    173,
     &     64,    34,    57,     9,    72,    86,    16,    75,    75,
     &     70,    42,     2,    86,    62,    62,    30,    30,     5,
     &     42,    70,    70,    70,    53,    70,    70,    53,    42,
     &     62,    53,    53,    53,    69,    75,     5,    53,    86,
     &      2,     5,    30,    75,    59,     2,    69,     5,     5,
     &     63,    62,     5,    69,    30,    44,    30,    86,    86,
     &      2,    69,     5,     5,     2,     2,    61,    69,    17,
     &      2,     2,     2,    53,    69,     2,     2,    86,    69,
     &     13,     2,     2,    37,    43,    65,     2,     2,    30,
     &     86,    45,    16,    32,    18,    86,    86,    86,     9,
     &     63,    63,    11,    76,    76,    76,    63,    60,    70/
      DATA P( 3), ( C( 3,I), I = 1, 99 ) /    263,
     &    111,    67,    98,    36,    48,   110,     2,   131,     2,
     &      2,   124,   124,    48,     2,     2,   124,   124,    70,
     &     70,    48,   126,    48,   126,    56,    65,    48,    48,
     &     70,     2,    92,   124,    92,   126,   131,   124,    70,
     &     70,    70,    20,   105,    70,     2,     2,    27,   108,
     &     27,    39,     2,   131,   131,    92,    92,    48,     2,
     &    126,    20,   126,     2,     2,   131,    38,   117,     2,
     &    131,    68,    58,    38,    90,    38,   108,    38,     2,
     &    131,   131,   131,    68,    14,    94,   131,   131,   131,
     &    108,    18,   131,    56,    85,   117,   117,     9,   131,
     &    131,    55,    92,    92,    92,   131,   131,    48,    48/
      DATA P( 4), ( C( 4,I), I = 1, 99 ) /    397,
     &    151,   168,    46,   197,    69,    64,     2,   198,   191,
     &    134,   134,   167,   124,    16,   124,   124,   124,   124,
     &    141,   134,   128,     2,     2,    32,    32,    32,    31,
     &     31,    64,    64,    99,     4,     4,   167,   124,   124,
     &    124,   124,   124,   124,   107,    85,    79,    85,   111,
     &     85,   128,    31,    31,    31,    31,    64,   167,     4,
     &    107,   167,   124,   124,   124,   124,   124,   124,   107,
     &    183,     2,     2,     2,    62,    32,    31,    31,    31,
     &     31,    31,   167,     4,   107,   167,   124,   124,   124,
     &    124,   124,   124,   107,   142,   184,   184,    65,    65,
     &    183,    31,    31,    31,    31,    31,   167,     4,   107/
      DATA P( 5), ( C( 5,I), I = 1, 99 ) /    593,
     &    229,    40,   268,    42,   153,   294,    71,     2,   130,
     &    199,   199,   199,   149,   199,   149,   153,   130,   149,
     &    149,    15,   119,   294,    31,    82,   260,   122,   209,
     &    209,   122,   296,   130,   130,   260,   260,    30,   206,
     &     94,   209,    94,   122,   209,   209,   122,   122,   209,
     &    130,     2,   130,   130,    38,    38,    79,    82,    94,
     &     82,   122,   122,   209,   209,   122,   122,   168,   220,
     &     62,    60,   168,   282,   282,    82,   209,   122,    94,
     &    209,   122,   122,   122,   122,   258,   148,   286,   256,
     &    256,    62,    62,    82,   122,    82,    82,   122,   122,
     &    122,   209,   122,    15,    79,    79,    79,    79,   168/
      DATA P( 6), ( C( 6,I), I = 1, 99 ) /    907,
     &    264,   402,   406,   147,   452,   153,   224,     2,     2,
     &    224,   224,   449,   101,   182,   449,   101,   451,   181,
     &    181,   101,   101,   377,    85,   453,   453,   453,    85,
     &    197,   451,     2,     2,   101,   449,   449,   449,   173,
     &    173,     2,   453,   453,     2,   426,    66,   367,   426,
     &    101,   453,     2,    32,    32,    32,   101,     2,     2,
     &    453,   223,   147,   449,   290,     2,   453,     2,    83,
     &    223,   101,   453,     2,    83,    83,   147,     2,   453,
     &    147,   147,   147,   147,   147,   147,   147,   453,   153,
     &    153,   147,     2,   224,   290,   320,   453,   147,   431,
     &    383,   290,   290,     2,   162,   162,   147,     2,   162/
      DATA P( 7), ( C( 7,I), I = 1, 99 ) /   1361,
     &    505,   220,   195,   410,   199,   248,   460,   471,     2,
     &    331,   662,   547,   209,   547,   547,   209,     2,   680,
     &    680,   629,   370,   574,    63,    63,   259,   268,   259,
     &    547,   209,   209,   209,   547,   547,   209,   209,   547,
     &    547,   108,    63,    63,   108,    63,    63,   108,   259,
     &    268,   268,   547,   209,   209,   209,   209,   547,   209,
     &    209,   209,   547,   108,    63,    63,    63,   405,   285,
     &    234,   259,   259,   259,   259,   209,   209,   209,   209,
     &    209,   209,   209,   209,   547,   289,   289,   234,   285,
     &    316,     2,   410,   259,   259,   259,   268,   209,   209,
     &    209,   209,   547,   547,   209,   209,   209,   285,   316/
      DATA P( 8), ( C( 8,I), I = 1, 99 ) /   2053,
     &    468,   635,   849,   687,   948,    37,  1014,   513,     2,
     &      2,     2,     2,     2,  1026,     2,     2,  1026,   201,
     &    201,     2,  1026,   413,  1026,  1026,     2,     2,   703,
     &    703,     2,     2,   393,   393,   678,   413,  1026,     2,
     &      2,  1026,  1026,     2,   405,   953,     2,  1026,   123,
     &    123,   953,   953,   123,   405,   794,   123,   647,   613,
     &   1026,   647,   768,   953,   405,   953,   405,   918,   918,
     &    123,   953,   953,   918,   953,   536,   405,    70,   124,
     &   1005,   529,   207,   405,   405,   953,   953,   123,   918,
     &    918,   953,   405,   918,   953,   468,   405,   794,   794,
     &    647,   613,   548,   405,   953,   405,   953,   123,   918/
      DATA P( 9), ( C( 9,I), I = 1, 99 ) /   3079,
     &   1189,  1423,   287,   186,   341,    77,   733,   733,  1116,
     &      2,  1539,     2,     2,     2,     2,     2,  1116,   847,
     &   1174,     2,   827,   713,   910,   944,   139,  1174,  1174,
     &   1539,  1397,  1397,  1174,   370,    33,  1210,     2,   370,
     &   1423,   370,   370,  1423,  1423,  1423,   434,  1423,   901,
     &    139,  1174,   427,   427,   200,  1247,   114,   114,  1441,
     &    139,   728,  1116,  1174,   139,   113,   113,   113,  1406,
     &   1247,   200,   200,   200,   200,  1247,  1247,    27,   427,
     &    427,  1122,  1122,   696,   696,   427,  1539,   435,  1122,
     &    758,  1247,  1247,  1247,   200,   200,   200,  1247,   114,
     &     27,   118,   118,   113,   118,   453,   453,  1084,  1406/
      DATA P(10), ( C(10,I), I = 1, 99 ) /   4621,
     &   1764,  1349,  1859,   693,    78,   438,   531,    68,  2234,
     &   2310,  2310,  2310,     2,  2310,  2310,  2102,  2102,   178,
     &    314,   921,  1074,  1074,  1074,  2147,   314,  1869,   178,
     &    178,  1324,  1324,   510,  2309,  1541,  1541,  1541,  1541,
     &    342,  1324,  1324,  1324,  1324,   510,   570,   570,  2197,
     &    173,  1202,   998,  1324,  1324,   178,  1324,  1324,  1541,
     &   1541,  1541,   342,  1541,   886,   178,  1324,  1324,  1324,
     &    510,   784,   784,   501,   652,  1541,  1541,  1324,   178,
     &   1324,   178,  1324,  1541,   342,  1541,  2144,   784,  2132,
     &   1324,  1324,  1324,  1324,   510,   652,  1804,  1541,  1541,
     &   1541,  2132,  1324,  1324,  1324,   178,   510,  1541,   652/
      DATA P(11), ( C(11,I), I = 1, 99 ) /   6947,
     &   2872,  1238,   387,  2135,   235,  1565,   221,  1515,  2950,
     &    486,  3473,     2,  2950,   982,  2950,  3122,  2950,  3172,
     &   2091,  2091,     9,  3449,  3122,  2846,  3122,  3122,  1947,
     &   2846,  3122,   772,  1387,  2895,  1387,     3,     3,     3,
     &   1320,  1320,  2963,  2963,  1320,  1320,  2380,   108,  1284,
     &    702,  1429,   907,  3220,  3125,  1320,  2963,  1320,  1320,
     &   2963,  1320,  1639,  3168,  1660,  2895,  2895,  2895,  2895,
     &   1639,  1297,  1639,   404,  3168,  2963,  2943,  2943,   550,
     &   1387,  1387,  2895,  2895,  2895,  1387,  2895,  1387,  2895,
     &   1320,  1320,  2963,  1320,  1320,  1320,  2963,  1320,     2,
     &   3473,     2,  3473,   772,  2550,     9,  1320,  2963,  1320/
      DATA P(12), ( C(12,I), I = 1, 99 ) /  10427,
     &   4309,  2339,  4154,  4480,  4967,   630,  5212,  2592,  4715,
     &   1808,  1808,  5213,     2,   216,  4014,  3499,  3499,  4204,
     &   2701,  2701,  5213,  4157,  1209,  4157,  4460,   335,  4460,
     &   1533,  4575,  4013,  4460,  1881,  2701,  4030,  4030,  1881,
     &   4030,  1738,   249,   335,    57,  2561,  2561,  2561,  1533,
     &   1533,  1533,  4013,  4013,  4013,  4013,  4013,  1533,   856,
     &    856,   468,   468,   468,  2561,   468,  2022,  2022,  2434,
     &    138,  4605,  1100,  2561,  2561,    57,    57,  3249,   468,
     &    468,   468,    57,   468,  1738,   313,   856,     6,  3877,
     &    468,   557,   468,    57,   468,  4605,  2022,     2,  4605,
     &    138,  1100,    57,  2561,    57,    57,  2022,  5213,  3249/
      DATA P(13), ( C(13,I), I = 1, 99 ) /  15641,
     &   6610,  1658,  3022,  2603,  5211,   265,  4985,     3,  4971,
     &   2127,  1877,  1877,     2,  2925,  3175,  3878,  1940,  1940,
     &   1940,  5117,  5117,  5771,  5117,  5117,  5117,  5117,  5117,
     &   5771,  5771,  5117,  3658,  3658,  3658,  3658,  3658,  3658,
     &   5255,  2925,  2619,  1714,  4100,  6718,  6718,  4100,  2322,
     &    842,  4100,  6718,  5119,  4728,  5255,  5771,  5771,  5771,
     &   5117,  5771,  5117,  5117,  5117,  5117,  5117,  5117,  5771,
     &   5771,  1868,  4483,  4728,  3658,  5255,  3658,  5255,  3658,
     &   3658,  5255,  5255,  3658,  6718,  6718,   842,  2322,  6718,
     &   4100,  6718,  4100,  4100,  5117,  5771,  5771,  5117,  5771,
     &   5771,  5771,  5771,  5117,  5117,  5117,  5771,  5771,  1868/
      DATA P(14), ( C(14,I), I = 1, 99 ) /  23473,
     &   9861,  7101,  6257,  7878, 11170, 11638,  7542,  2592,  2591,
     &   6074,  1428,  8925, 11736,  8925,  5623,  5623,  1535,  6759,
     &   9953,  9953, 11459,  9953,  7615,  7615, 11377, 11377,  2762,
     &  11734, 11459,  6892,  1535,  6759,  4695,  1535,  6892,     2,
     &      2,  6892,  6892,  4177,  4177,  6339,  6950,  1226,  1226,
     &   1226,  4177,  6892,  6890,  3640,  3640,  1226, 10590, 10590,
     &   6950,  6950,  6950,  1226,  6950,  6950,  7586,  7586,  7565,
     &   7565,  3640,  3640,  6950,  7565,  6950,  3599,  3599,  3599,
     &   2441,  4885,  4885,  4885,  7565,  7565,  1226,  1226,  1226,
     &   6950,  7586,  1346,  2441,  6339,  3640,  6950, 10590,  6339,
     &   6950,  6950,  6950,  1226,  1226,  6950,   836,  6891,  7565/
      DATA P(15), ( C(15,I), I = 1, 99 ) /  35221,
     &  13482,  5629,  6068, 11974,  4732, 14946, 12097, 17609, 11740,
     &  15170, 10478, 10478, 17610,     2,     2,  7064,  7064,  7064,
     &   5665,  1771,  2947,  4453, 12323, 17610, 14809, 14809,  5665,
     &   5665,  2947,  2947,  2947,  2947, 12323, 12323,  4453,  4453,
     &   2026, 11772,  2026, 11665, 12323, 12323,  3582,  2940,  2940,
     &   6654,  4449,  9254, 11470,   304,   304, 11470,   304, 11470,
     &   6156,  9254, 11772,  6654, 11772,  6156, 11470, 11470, 11772,
     &  11772, 11772, 11470, 11470,   304, 11470, 11470,   304, 11470,
     &    304, 11470,   304,   304,   304,  6654, 11508,   304,   304,
     &   6156,  3582, 11470, 11470, 11470, 17274,  6654,  6654,  6744,
     &   6711,  6654,  6156,  3370,  6654, 12134,  3370,  6654,  3582/
      DATA P(16), ( C(16,I), I = 1, 99 ) /  52837,
     &  13482,  5629,  6068, 11974,  4732, 14946, 12097, 17609, 11740,
     &  15170, 10478, 10478, 17610,     2,     2,  7064,  7064,  7064,
     &   5665,  1771,  2947,  4453, 12323, 17610, 14809, 14809,  5665,
     &   5665,  2947,  2947,  2947,  2947, 12323, 12323,  4453,  4453,
     &   2026, 11772,  2026, 11665, 12323, 12323,  3582,  2940,  2940,
     &   6654,  4449,  9254, 11470,   304,   304, 11470,   304, 11470,
     &   6156,  9254, 11772,  6654, 11772,  6156, 11470, 11470, 11772,
     &  11772, 11772, 11470, 11470,   304, 11470, 11470,   304, 11470,
     &    304, 11470,   304,   304,   304,  6654, 11508,   304,   304,
     &   6156,  3582, 11470, 11470, 11470, 17274,  6654,  6654,  6744,
     &   6711,  6654,  6156,  3370,  6654, 12134,  3370,  6654,  3582/
      DATA P(17), ( C(17,I), I = 1, 99 ) /  79259,
     &  34566, 38838, 23965, 17279, 35325, 33471,   330, 36050, 26419,
     &   3012, 38428, 36430, 36430, 36755, 39629,  5749,  5749, 36755,
     &   5749, 14353, 14353, 14353, 32395, 32395, 32395, 32395, 32396,
     &  32396, 32396, 32396, 27739, 14353, 36430, 36430, 36430, 15727,
     &  38428, 28987, 28987, 27739, 38428, 27739, 18786, 14353, 15727,
     &  28987, 19151, 19757, 19757, 19757, 14353, 22876, 19151, 24737,
     &  24737,  4412, 30567, 30537, 19757, 30537, 19757, 30537, 30537,
     &   4412, 24737, 28987, 19757, 19757, 19757, 30537, 30537, 33186,
     &   4010,  4010,  4010, 17307, 15217, 32789, 37709,  4010,  4010,
     &   4010, 33186, 33186,  4010, 11057, 39388, 33186,  1122, 15089,
     &  39629,     2,     2, 23899, 16466, 16466, 17038,  9477,  9260/
      DATA P(18), ( C(18,I), I = 1, 99 ) / 118891,
     &  31929, 40295,  2610,  5177, 17271, 23770,  9140,   952, 39631,
     &      3, 11424, 49719, 38267, 25172,     2,     2, 59445,     2,
     &  59445, 38267, 44358, 14673, 53892, 14674, 14673, 14674, 41368,
     &  17875, 17875, 30190, 20444, 55869, 15644, 25499, 15644, 20983,
     &  44358, 15644, 15644,   485, 41428,   485,   485,   485, 41428,
     &  53798, 50230, 53798, 50253, 50253, 35677, 35677, 17474,  7592,
     &   4098, 17474,   485, 41428,   485, 41428,   485, 41428,   485,
     &  41428, 41428, 41428, 41428, 41428,  9020, 22816,  4098,  4098,
     &   4098,  7592, 42517,   485, 50006, 50006, 22816, 22816,  9020,
     &    485, 41428, 41428, 41428, 41428, 50006,   485, 41428, 41428,
     &  41428, 41428, 22816, 41428, 41428,   485,   485,   485,  9020/
      DATA P(19), ( C(19,I), I = 1, 99 ) / 178349,
     &  73726, 16352, 16297, 74268, 60788,  8555,  1077, 25486, 86595,
     &  59450, 19958, 62205, 62205,  4825,  4825, 89174, 89174, 62205,
     &  19958, 62205, 19958, 27626, 63080, 62205, 62205, 62205, 19958,
     &   8914, 83856, 30760, 47774, 47774, 19958, 62205, 39865, 39865,
     &  74988, 75715, 75715, 74988, 34522, 74988, 74988, 25101, 44621,
     &  44621, 44621, 25101, 25101, 25101, 44621, 47768, 41547, 44621,
     &  10273, 74988, 74988, 74988, 74988, 74988, 74988, 34522, 34522,
     &  67796, 67796, 30208,     2, 67062, 18500, 29251, 29251,     2,
     &  67796, 67062, 38649, 59302,  6225, 67062,  6475,  6225, 46772,
     &  38649, 67062, 46772, 46772, 67062, 46772, 25372, 67062,  6475,
     &  25372, 67062, 67062, 67062,  6225, 67062, 67062, 68247, 80676/
      DATA P(20), ( C(20,I), I = 1, 99 )/ 267523,
     & 103650, 50089, 70223, 41805, 74847,112775, 40889, 64866, 44053,
     &   1754,129471, 13630, 53467, 53467, 61378,133761,     2,133761,
     &      2,133761,133761, 65531, 65531, 65531, 38080,133761,133761,
     & 131061,  5431, 65531, 78250, 11397, 38841, 38841,107233,107233,
     & 111286, 19065, 38841, 19065, 19065, 16099,127638, 82411, 96659,
     &  96659, 82411, 96659, 82411, 51986,101677, 39264, 39264,101677,
     &  39264, 39264, 47996, 96659, 82411, 47996, 10971, 10004, 82411,
     &  96659, 82411, 82411, 82411, 96659, 96659, 96659, 82411, 96659,
     &  51986,110913, 51986, 51986,110913, 82411, 54713, 54713, 22360,
     & 117652, 22360, 78250, 78250, 91996, 22360, 91996, 97781, 91996,
     &  97781, 91996, 97781, 97781, 91996, 97781, 97781, 36249, 39779/
C
      INFORM = 1
      INTVLS = 0
      IF ( MINVLS .GE. 0 ) THEN
         FINEST = 0
         VAREST = 0
         SAMPLS = MINSMP 
         DO 100 I = 1, PLIM
            NP = I
            IF ( MINVLS .LT. 2*SAMPLS*P(I) ) GO TO 10
 100     CONTINUE
         SAMPLS = MAX( MINSMP, MINVLS/( 2*P(NP) ) )
      ENDIF
 10   VK(1) = ONE/P(NP)
      DO 200 I = 2, NDIM
         VK(I) = MOD( C(NP,NDIM-1)*VK(I-1), ONE )
 200  CONTINUE
      FINVAL = 0
      VARSQR = 0
      DO 300 I = 1, SAMPLS
         CALL KROSUM( NDIM, VALUE, P(NP), VK, FUNCTN, ALPHA, X )
         DIFINT = ( VALUE - FINVAL )/I
         FINVAL = FINVAL + DIFINT
         VARSQR = ( I - 2 )*VARSQR/I + DIFINT**2
 300  CONTINUE
      INTVLS = INTVLS + 2*SAMPLS*P(NP)
      VARPRD = VAREST*VARSQR
      FINEST = FINEST + ( FINVAL - FINEST )/( 1 + VARPRD )
      IF ( VARSQR .GT. 0 ) VAREST = ( 1 + VARPRD )/VARSQR
      ABSERR = 3*SQRT( VARSQR/( 1 + VARPRD ) )
      IF ( ABSERR .GT. MAX( ABSEPS, ABS(FINEST)*RELEPS ) ) THEN
         IF ( NP .LT. PLIM ) THEN
            NP = NP + 1
         ELSE
            SAMPLS = MIN( 3*SAMPLS/2, ( MAXVLS - INTVLS )/( 2*P(NP) ) ) 
            SAMPLS = MAX( MINSMP, SAMPLS )
         ENDIF
         IF ( INTVLS + 2*SAMPLS*P(NP) .LE. MAXVLS ) GO TO 10
      ELSE
         INFORM = 0
      ENDIF
      MINVLS = INTVLS
C
      RETURN
      END
      SUBROUTINE KROMVN( N, LOWER, UPPER, INFIN, CORREL, MAXPTS,
     &                   ABSEPS, RELEPS, ERROR, VALUE, INFORM )
*
*     A subroutine for computing multivariate normal probabilities.
*     This subroutine uses an algorithm given in the paper
*     "Numerical Computation of Multivariate Normal Probabilities", in
*     J. of Computational and Graphical Stat., 1(1992), pp. 141-149, by
*          Alan Genz 
*          Department of Mathematics
*          Washington State University 
*          Pullman, WA 99164-3113
*          Email : AlanGenz@wsu.edu
*
*  Parameters
*
*     N      INTEGER, the number of variables.
*     LOWER  REAL, array of lower integration limits.
*     UPPER  REAL, array of upper integration limits.
*     INFIN  INTEGER, array of integration limits flags:
*            if INFIN(I) < 0, Ith limits are (-infinity, infinity);
*            if INFIN(I) = 0, Ith limits are (-infinity, UPPER(I)];
*            if INFIN(I) = 1, Ith limits are [LOWER(I), infinity);
*            if INFIN(I) = 2, Ith limits are [LOWER(I), UPPER(I)].
*     CORREL REAL, array of correlation coefficients; the correlation
*            coefficient in row I column J of the correlation matrix
*            should be stored in CORREL( J + ((I-2)*(I-1))/2 ), for J < I.
*     MAXPTS INTEGER, maximum number of function values allowed. This 
*            parameter can be used to limit the time. A sensible 
*            strategy is to start with MAXPTS = 1000*N, and then
*            increase MAXPTS if ERROR is too large.
*     ABSEPS REAL absolute error tolerance.
*     RELEPS REAL relative error tolerance.
*     ERROR  REAL estimated absolute error, with 99% confidence level.
*     VALUE  REAL estimated value for the integral
*     INFORM INTEGER, termination status parameter:
*            if INFORM = 0, normal completion with ERROR < EPS;
*            if INFORM = 1, completion with ERROR > EPS and MAXPTS 
*                           function vaules used; increase MAXPTS to 
*                           decrease ERROR;
*            if INFORM = 2, N > 100 or N < 1.
*
      EXTERNAL MVNFNC
      INTEGER N, INFIN(*), MAXPTS, INFORM, INFIS, IVLS
      DOUBLE PRECISION CORREL(*), LOWER(*), UPPER(*), RELEPS, ABSEPS,
     &       ERROR, VALUE, E, D, MVNNIT, MVNFNC
      IF ( N .GT. 100 .OR. N .LT. 1 ) THEN
         INFORM = 2
         VALUE = 0
         ERROR = 1
      ELSE
         INFORM = MVNNIT(N, CORREL, LOWER, UPPER, INFIN, INFIS, D, E)
         IF ( N-INFIS .EQ. 0 ) THEN
            VALUE = 1
            ERROR = 0
         ELSE IF ( N-INFIS .EQ. 1 ) THEN
            VALUE = E - D
            ERROR = 2E-16
         ELSE
*
*        Call the lattice rule integration subroutine
*
            IVLS = 0
            CALL KROBOV( N-INFIS-1, IVLS, MAXPTS, MVNFNC, 
     &                   ABSEPS, RELEPS, ERROR, VALUE, INFORM )
         ENDIF
      ENDIF
      END
      SUBROUTINE KROMVT(N, NU, LOWER, UPPER, INFIN, CORREL, MAXPTS,
     *      ABSEPS, RELEPS, ERROR, VALUE, INFORM)
*
*     A subroutine for computing multivariate t probabilities.
*          Alan Genz 
*          Department of Mathematics
*          Washington State University 
*          Pullman, WA 99164-3113
*          Email : AlanGenz@wsu.edu
*
*  Parameters
*
*     N      INTEGER, the number of variables.
*     NU     INTEGER, the number of degrees of freedom.
*     LOWER  REAL, array of lower integration limits.
*     UPPER  REAL, array of upper integration limits.
*     INFIN  INTEGER, array of integration limits flags:
*            if INFIN(I) < 0, Ith limits are (-infinity, infinity);
*            if INFIN(I) = 0, Ith limits are (-infinity, UPPER(I)];
*            if INFIN(I) = 1, Ith limits are [LOWER(I), infinity);
*            if INFIN(I) = 2, Ith limits are [LOWER(I), UPPER(I)].
*     CORREL REAL, array of correlation coefficients; the correlation
*            coefficient in row I column J of the correlation matrix
*            should be stored in CORREL( J + ((I-2)*(I-1))/2 ), for J < I.
*     MAXPTS INTEGER, maximum number of function values allowed. This 
*            parameter can be used to limit the time. A sensible 
*            strategy is to start with MAXPTS = 1000*N, and then
*            increase MAXPTS if ERROR is too large.
*     ABSEPS    REAL absolute error tolerance.
*     RELEPS    REAL relative error tolerance.
*     ERROR  REAL estimated absolute error, with 99% confidence level.
*     VALUE  REAL estimated value for the integral
*     INFORM INTEGER, termination status parameter:
*            if INFORM = 0, normal completion with ERROR < EPS;
*            if INFORM = 1, completion with ERROR > EPS and MAXPTS 
*                           function vaules used; increase MAXPTS to 
*                           decrease ERROR;
*            if INFORM = 2, N > 20 or N < 1.
*
      EXTERNAL FNCMVT
      INTEGER N, NU, INFIN(*), MAXPTS, INFORM, INFIS, IVLS
      DOUBLE PRECISION
     *     CORREL(*), LOWER(*), UPPER(*), RELEPS, ABSEPS,
     *     ERROR, VALUE, E, D, MVTNIT
      IF ( N .GT. 20 .OR. N .LT. 1 ) THEN
         INFORM = 2
         VALUE = 0
         ERROR = 1
         RETURN
      ENDIF
      INFORM = MVTNIT( N, NU, CORREL, LOWER, UPPER, INFIN, INFIS, D, E )
      IF ( N-INFIS .EQ. 0 ) THEN
         VALUE = 1
         ERROR = 0
      ELSE IF ( N-INFIS .EQ. 1 ) THEN
         VALUE = E - D
         ERROR = 2E-16
      ELSE
*
*        Call the lattice rule integration integration subroutine
*
         IVLS = 0
         CALL KROBOV( N-INFIS-1, IVLS, MAXPTS, FNCMVT, ABSEPS, RELEPS, 
     *                ERROR, VALUE, INFORM )
      ENDIF
      RETURN
      END
      SUBROUTINE KROSUM( NDIM, SUMKRO, PRIME, VK, FUNCTN, ALPHA, X )
      EXTERNAL FUNCTN
      INTEGER NDIM, PRIME, K, J
      DOUBLE PRECISION SUMKRO, VK(*), FUNCTN, ALPHA(*), X(*), ONE, UNI
      PARAMETER ( ONE = 1 )
      SUMKRO = 0
      DO 100 J = 1, NDIM
         ALPHA(J) = UNI()
 100  CONTINUE
      DO 200 K = 1, PRIME
         DO 300 J = 1, NDIM
            X(J) = MOD( K*VK(J) + ALPHA(J), ONE )
            X(J) = ABS( 2*X(J) - 1 )
 300     CONTINUE
         SUMKRO = SUMKRO + ( FUNCTN(NDIM,X) - SUMKRO )/( 2*K - 1 )
         DO 400 J = 1, NDIM
            X(J) = 1 - X(J)
 400     CONTINUE
         SUMKRO = SUMKRO + ( FUNCTN(NDIM,X) - SUMKRO )/( 2*K )
 200  CONTINUE
C
      RETURN
      END
      SUBROUTINE L1DIS(AMAT,AMAT2,MAXROM,MAXCOM,NR1,NC1,ICASE,IWRITE,
     1IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE
C              L1 NORM DISTANCE OF A MATRIX.  THE FORMULA IS:
C                 Dij=SUM|(Xik - Xjk)|
C              THE SUMMATION IS K = 1 TO P (WHERE THERE ARE P
C              COLUMNS IN THE MATRIX).  FOR EXAMPLE, D23 IS
C              THE DISTANCE BETWEEN THE SECOND AND THIRD ROWS.
C              (ALTERNATIVELY, THE DISTANCE CAN BE CALCULATED
C              ACROSS COLUMNS).
C     INPUT  ARGUMENTS--AMAT   = THE SINGLE PRECISION MATRIX
C                     --MAXROM = THE INTEGER ROW DIMENSION OF AMAT
C                     --MAXCOM = THE INTEGER COUMN DIMENSION OF AMAT
C                     --NR1    = THE INTEGER NUMBER OF ROWS OF AMAT
C                     --NC1    = THE INTEGER NUMBER OF COLUMNS OF AMAT
C     OUTPUT ARGUMENTS--AMAT2    = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED SAMPLE L1 NORM DISTANCES.
C     OUTPUT--MATRIX OF L1 NORM DISTANCES
C     NOTE--THIS ROUTINE ASSUMES THE ERROR CHECKING (FOR EQUAL
C           ROWS AND COLUMNS, MATCHING DIMENSIONS FOR X AND AMAT)
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     LANGUAGE--ANSI FORTRAN (1977)
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           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.7
C     ORIGINAL VERSION--JULY      1998.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 ICASE
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DSUM
      DOUBLE PRECISION DYM1
      DOUBLE PRECISION DYM2
C
      DIMENSION AMAT(MAXROM,MAXCOM)
      DIMENSION AMAT2(MAXROM,MAXCOM)
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='L1NO'
      ISUBN2='RM  '
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 L1DIS--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)IBUGA3
   52 FORMAT('IBUGA3 = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)NR1,NC1
   53 FORMAT('NR1, NC1 = ',2I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,54)ICASE
   54 FORMAT('ICASE = ',A4)
      CALL DPWRST('XXX','BUG ')
   90 CONTINUE
C
C               ********************************
C               **  COMPUTE L1 NORM DISTANCE *
C               ********************************
C
      IF(ICASE.EQ.'ROW ')THEN
        DO5861I=1,NR1
          DO5863J=1,I
            IF(I.EQ.J)THEN
              AMAT2(I,I)=0.0
            ELSE
              DSUM=0.0D0
              DO5865K=1,NC1
                DYM1=AMAT(I,K)
                DYM2=AMAT(J,K)
                DSUM=DSUM+DABS(DYM1-DYM2)
 5865         CONTINUE
              AMAT2(I,J)=REAL(DSUM)
              AMAT2(J,I)=AMAT2(I,J)
            ENDIF
 5863     CONTINUE
 5861   CONTINUE
      ELSEIF(ICASE.EQ.'COLU')THEN
        DO5961I=1,NC1
          DO5963J=1,I
            IF(I.EQ.J)THEN
              AMAT2(I,I)=0.0
            ELSE
              DSUM=0.0D0
              DO5965K=1,NR1
                DYM1=AMAT(K,I)
                DYM2=AMAT(K,J)
                DSUM=DSUM+DABS(DYM1-DYM2)
 5965         CONTINUE
              AMAT2(I,J)=REAL(DSUM)
              AMAT2(J,I)=AMAT2(I,J)
            ENDIF
 5963     CONTINUE
 5961   CONTINUE
      ENDIF
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)
  811 FORMAT('THE L1 NORM DISTANCE MATRIX HAS BEEN CALCULATED.')
      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 L1DIS--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IBUGA3,IERROR
 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE LABEL(NO, ICHAR, LIST, IOUT, N, LV, LOA)               LAB  260
C  ROUTINE FROM ACM 591 FOR ANOVA
C  ****************************** LABEL *****************************   LAB   10
C                                                                       LAB   20
C  DETERMINES THE SUBSCRIPTS OF THE PRIMARY ARRAY; CALCULATES COEFFI-   LAB   30
C  CIENTS FOR MAPPING THE SECONDARY ARRAY INTO THE PRIMARY ARRAY.       LAB   40
C  ALSO PREPARES LABELS FOR THE G-INVERSE SOLUTION AND CLASSIFICATION   LAB   50
C  MEANS; EACH LABEL IS AN ALPHANUMERIC ARRAY OF SIZE 10.               LAB   60
C                                                                       LAB   70
C                                                                       LAB   80
C                      (OUT)    ARGUMENTS      (IN)                     LAB   90
C                                                                       LAB  100
C                       LOA              NO   ICHAR  LIST               LAB  110
C                                                                       LAB  120
C               PRIMARY SUBSCRIPTS     M-I+1    0    LLIM               LAB  130
C               MAP COEFFICIENTS       M-I+1    0    LLIM               LAB  140
C               MODEL TERM LABEL       LER(I) BLANK   LE                LAB  150
C               SUBSCRIPTS LABEL       M-I+1    .     LS                LAB  160
C                                                                       LAB  170
C               IN COMPUTING NO, I IS THE POSITION OF THE               LAB  180
C               ARRAY WITHIN THE M ARRAYS (IN VECTOR A OF               LAB  190
C               W) OR, FOR MODEL TERM LABELS, THE VALUE                 LAB  200
C               OF THE E/R LIST (ARRAY LER) FOR THAT TERM               LAB  210
C                                                                       LAB  220
C  (SEE MAIN PROGRAM COMMENTS FOR DESCRIPTION OF OTHER ARGUMENTS)       LAB  230
C                                                                       LAB  240
C  ******************************************************************   LAB  250
      DIMENSION LIST(N), LV(N), LOA(10)
      CHARACTER*1 IBLANK
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 IBLANK /1H /
C
C MAP COEFFICIENTS: (NO=2**N-I+1,ICHAR=0,LIST=LLIM)
C LABELS: MODEL TERM (NO=LER(I),ICHAR= ,LIST=LE)
C         SUBSCRIPTS (NO=2**N-I+1,ICHAR=.,LIST=LS)
C
      NUM = NO - 1
      DO 10 I=N,10
CNIST   LOA(I) = IBLANK
        LOA(I) = -1
   10 CONTINUE
      DO 20 I=1,N
        LOA(I) = ICHAR
   20 CONTINUE
      IF (NUM.EQ.0) GO TO 60
      I = 0
      J = 0
   30 I = I + 1
   40 J = J + 1
      NUM = NUM - LV(J)
      IF (NUM.GE.0) GO TO 50
      NUM = NUM + LV(J)
CNIST IF (ICHAR.NE.IBLANK) GO TO 30
      IF (ICHAR.NE.-1) GO TO 30
      GO TO 40
   50 LOA(I) = LIST(J)
      IF (NUM.NE.0) GO TO 30
   60 IF (ICHAR.EQ.0) GO TO 70
CNIST WRITE (ICOUT,99999) (LOA(K),K=1,10)
99999 FORMAT (1H , 10A1)
      CALL DPWRST('XXX','BUG ')
      RETURN
   70 DO 90 I=1,N
        IF (LOA(I).EQ.0) GO TO 90
        LOA(I) = 1
        DO 80 J=I,N
          IF (LOA(J).EQ.0) GO TO 80
          LOA(I) = IABS(LOA(I)*LOA(J))
   80   CONTINUE
   90 CONTINUE
      RETURN
      END
      SUBROUTINE LAGUE(X,AN,ALN)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE LAGUERRE POLYNOMIAL OF
C              ORDER N.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION INPUT ARGUMENT
C                       AN     = THE SINGLE PRECISION VALUE FOR THE
C                                ORDER OF THE FUNCTION (SHOULD BE
C                                NON-NEGATIVE ORDER)
C     OUTPUT ARGUMENTS--ALN    = THE SINGLE PRECISION VALUE OF THE
C                                LAGUERRE POLYNOMIAL.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 
C     RESTRICTIONS--
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE
C     MODE OF INTERNAL OPERATIONS--SOME DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN. 
C     REFERENCES--"HANDBOOK OF MATHEMATICAL FUNCTIONS, AMS 55", 
C                 ABRAMOWITZ AND STEGUM.
C                 USE FOLLOWING RECURRENCE FORMULA:
C                    L(N+1) = (((2.*N+1)-x)*L(n)-N*L(N-1))/(N+1)
C                 FIRST FEW TERMS ARE FROM TABLE 22.10 OF ABRAMOWITZ
C                 AND STEGUM.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE:  301-975-2855
C     ORIGINAL VERSION--JULY       1995. 
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
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
      DOUBLE PRECISION DX
      DOUBLE PRECISION DN, DN2
      DOUBLE PRECISION DLN, DLN1, DLN2
C
C-----START POINT-----------------------------------------------------
C
      IF(X.LT.0.0)THEN
        WRITE(ICOUT,4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
    4 FORMAT('***** NON-FATAL DIAGNOSTIC--THE 1ST INPUT ARGUMENT ',
     1'TO THE LAGUERRE SUBROUTINE IS NEGATIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
      N=INT(AN+0.5)
      IF(N.LT.0)THEN
        WRITE(ICOUT,6)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
    6 FORMAT('***** NON-FATAL DIAGNOSTIC--THE 2ND INPUT ARGUMENT ',
     1'TO THE LAGUERRE SUBROUTINE IS NEGATIVE *****')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
C
      DX=DBLE(X)
      DN=DBLE(N)
C
      IF(N.LE.0)THEN
        ALN=1.0
      ELSEIF(N.EQ.1)THEN
        ALN=-X+1.0
      ELSEIF(N.EQ.2)THEN
        ALN=0.5*(X**2 - 4.0*X + 2.0)
      ELSEIF(N.EQ.3)THEN
        DLN=(-DX**3 + 9.0D0*DX**2 -18.0D0*DX + 6.0D0)/6.0D0
        ALN=REAL(DLN)
      ELSE
        DLN1=(-DX**3 + 9.0D0*DX**2 -18.0D0*DX + 6.0D0)/6.0D0
        DLN2=0.5D0*(DX**2 - 4.0D0*DX + 2.0D0)
        DO1000I=4,N
          DN2=DBLE(I)-1.0D0
          DLN=(((2.0D0*DN2+1.0D0)-DX)*DLN1-DN2*DLN2)/(DN2+1.0D0)
          DLN2=DLN1
          DLN1=DLN
 1000   CONTINUE
        ALN=REAL(DLN)
      ENDIF
C
 9999 CONTINUE
      RETURN
      END 
      SUBROUTINE LAGUEL(X,AN,ALPHA,IFLAG,ALN)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE GENERALIZED LAGUERRE
C              POLYNOMIAL OF ORDER N.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION INPUT ARGUMENT
C                       AN     = THE SINGLE PRECISION VALUE FOR THE
C                                ORDER OF THE FUNCTION (SHOULD BE
C                                NON-NEGATIVE ORDER)
C                       ALPHA  = THE SINGLE PRECISION VALUE FOR THE
C                                PARAMETER OF THE FUNCTION (SHOULD BE
C                       IFLAG  = "NORM" FOR NORMALIZED, "UNNO" FOR 
C                                UNNORMALIZED
C     OUTPUT ARGUMENTS--ALN    = THE SINGLE PRECISION VALUE OF THE
C                                LAGUERRE POLYNOMIAL.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 
C     RESTRICTIONS--
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE
C     MODE OF INTERNAL OPERATIONS--SOME DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN. 
C     REFERENCES--"HANDBOOK OF MATHEMATICAL FUNCTIONS, AMS 55", 
C                 ABRAMOWITZ AND STEGUM.
C                 USE FOLLOWING RECURRENCE FORMULA:
C                    L(N+1) = (((2.*N+1)-x)*L(n)-N*L(N-1))/(N+1)
C                 FIRST FEW TERMS ARE FROM TABLE 22.10 OF ABRAMOWITZ
C                 AND STEGUM.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE:  301-975-2855
C     ORIGINAL VERSION--JULY       1995. 
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
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
      CHARACTER*4 IFLAG
      DOUBLE PRECISION DX
      DOUBLE PRECISION DALPHA
      DOUBLE PRECISION DN, DN2
      DOUBLE PRECISION DLN, DLN1, DLN2
      DOUBLE PRECISION AJ, BJ, CJ
      DOUBLE PRECISION DFACT
      DOUBLE PRECISION DGAMR
C
C-----START POINT-----------------------------------------------------
C
      IF(X.LT.0.0)THEN
        WRITE(ICOUT,4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
    4 FORMAT('***** NON-FATAL DIAGNOSTIC--THE 1ST INPUT ARGUMENT ',
     1'TO THE LAGUERRE SUBROUTINE IS NEGATIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
      N=INT(AN+0.5)
      IF(N.LT.0)THEN
        WRITE(ICOUT,6)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
    6 FORMAT('***** NON-FATAL DIAGNOSTIC--THE 2ND INPUT ARGUMENT ',
     1'TO THE LAGUERRE SUBROUTINE IS NEGATIVE *****')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
C
      DX=DBLE(X)
      DALPHA=DBLE(ALPHA)
      DN=DBLE(N)
C
      IF(IFLAG.EQ.'NORM')GOTO2000
      IF(N.LE.0)THEN
        DLN=1.0D0
      ELSEIF(N.EQ.1)THEN
        DLN=-DX+DALPHA+1.0D0
      ELSEIF(N.EQ.2)THEN
        DLN=0.5D0*
     1   (2.D0+3.D0*DALPHA+DALPHA*DALPHA-4.D0*DX-2.D0*DALPHA*DX+DX*DX)
      ELSE
        DLN1=0.5D0*
     1   (2.D0+3.D0*DALPHA+DALPHA*DALPHA-4.D0*DX-2.D0*DALPHA*DX+DX*DX)
        DLN2=-DX+DALPHA+1.0D0
        DO1000I=3,N
          DN2=DBLE(I)-1.0D0
          DLN=(((2.0D0*DN2+DALPHA+1.0D0)-DX)*DLN1-(DN2+DALPHA)*DLN2)/
     1        (DN2+1.0D0)
CCCCC     DN2=DBLE(I)
CCCCC     AJ=(2.D0*DN2-1.0D0+DALPHA)/DN2
CCCCC     BJ=-1.D0/DN2
CCCCC     CJ=(DN2-1.0D0+DALPHA)/DN2
CCCCC     DLN=(AJ+BJ*DX)*DLN1 - CJ*DLN2
          DLN2=DLN1
          DLN1=DLN
 1000   CONTINUE
      ENDIF
      ALN=REAL(DLN)
      GOTO9999
C
 2000 CONTINUE
      IF(N.LE.0)THEN
        DLN=1.0D0
      ELSEIF(N.EQ.1)THEN
        DLN=-DX+DALPHA+1.0D0
        DFACT=(-1.0D0)**1/DGAMR(2.0D0)
        DLN=DLN/DFACT
      ELSEIF(N.EQ.2)THEN
        DLN=2.D0+3.D0*DALPHA+DALPHA*DALPHA-4.D0*DX-2.D0*DALPHA*DX+DX*DX
        DFACT=(-1.0D0)**2/DGAMR(3.0D0)
        DLN=DLN/DFACT
      ELSE
        DLN1=0.5D0*
     1   (2.D0+3.D0*DALPHA+DALPHA*DALPHA-4.D0*DX-2.D0*DALPHA*DX+DX*DX)
        DLN2=-DX+DALPHA+1.0D0
        DO2100I=3,N
          DN2=DBLE(I)
          AJ=(2.D0*DN2-1.0D0+DALPHA)/DN2
          BJ=-1.D0/DN2
          CJ=(DN2-1.0D0+DALPHA)/DN2
          DLN=(AJ+BJ*DX)*DLN1 - CJ*DLN2
          DLN2=DLN1
          DLN1=DLN
 2100   CONTINUE
      ENDIF
        DFACT=(-1.0D0)**N/DGAMR(DN+1.0D0)
        DLN=DLN/DFACT
      ALN=REAL(DLN)
      GOTO9999
C
 9999 CONTINUE
      RETURN
      END 
      SUBROUTINE LAGUER(A,M,X,EPS,POLISH)
C
C     SOURCE--NUMERICAL RECIPES,
C             PRESS, FLANNERY, TEUKOLSKY, AND VETTERLING,
C             CAMBRIDGE UNIVERSITY PRESS, 1986.
C
      COMPLEX A(*),X,DX,X1,B,D,F,G,H,SQ,GP,GM,G2,ZERO,XX,WW
      LOGICAL POLISH
      PARAMETER (ZERO=(0.,0.),TINY=1.E-15,MAXIT=100)
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 (POLISH) THEN
        DXOLD=CABS(X)
        NPOL=0
      ENDIF
C
      DO 12 ITER=1,MAXIT
        B=A(M+1)
        D=ZERO
        F=ZERO
        DO 11 J=M,1,-1
          F=X*F+D
          D=X*D+B
          B=X*B+A(J)
11      CONTINUE
        IF(CABS(B).LE.TINY) THEN
          DX=ZERO
        ELSE IF(CABS(D).LE.TINY.AND.CABS(F).LE.TINY)THEN
          DX=CMPLX(CABS(B/A(M+1))**(1./M),0.)
        ELSE
          G=D/B
          G2=G*G
          H=G2-2.*F/B
        XX=(M-1)*(M*H-G2)
        YY=ABS(REAL(XX))
        ZZ=ABS(AIMAG(XX))
        IF(YY.LT.TINY.AND.ZZ.LT.TINY) THEN
          SQ=ZERO
        ELSE IF (YY.GE.ZZ) THEN
          WW=(1.0/YY)*XX
          SQ=SQRT(YY)*CSQRT(WW)
        ELSE
          WW=(1.0/ZZ)*XX
          SQ=SQRT(ZZ)*CSQRT(WW)
        ENDIF
          GP=G+SQ
          GM=G-SQ
          IF(CABS(GP).LT.CABS(GM)) GP=GM
          DX=M/GP
        ENDIF
        X1=X-DX
        IF(X.EQ.X1)RETURN
        X=X1
        IF (POLISH) THEN
          NPOL=NPOL+1
          CDX=CABS(DX)
          IF(NPOL.GT.9.AND.CDX.GE.DXOLD)RETURN
          DXOLD=CDX
        ELSE
          IF(CABS(DX).LE.EPS*CABS(X))RETURN
        ENDIF
12    CONTINUE
C
      WRITE(ICOUT,555)
  555 FORMAT('ERROR IN LAGUER--TOO MANY ITERATIONS')
      CALL DPWRST('XXX','BUG ')
C
      RETURN
      END
      SUBROUTINE LAMCDF(X,ALAMBA,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE (TUKEY) LAMBDA DISTRIBUTION
C              WITH TAIL LENGTH PARAMETER VALUE = ALAMBA.
C              IN GENERAL, THE PROBABILITY DENSITY FUNCTION 
C              FOR THIS DISTRIBUTION IS NOT SIMPLE.
C              THE PERCENT POINT FUNCTION FOR THIS DISTRIBUTION IS
C              G(P) = ((P**ALAMBA)-((1-P)**ALAMBA))/ALAMBA
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C                     --ALAMBA = THE SINGLE PRECISION VALUE OF LAMBDA 
C                                (THE TAIL LENGTH PARAMETER).
C     OUTPUT ARGUMENTS--CDF    = THE SINGLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE CDF FOR THE TUKEY LAMBDA DISTRIBUTION
C             WITH TAIL LENGTH PARAMETER = ALAMBA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 
C     RESTRICTIONS--FOR ALAMBA NON-POSITIVE, NO RESTRICTIONS ON X.
C                 --FOR ALAMBA POSITIVE, X SHOULD BE BETWEEN (-1/ALAMBA)
C                   AND (+1/ALAMBA), INCLUSIVELY. 
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN. 
C     REFERENCES--HASTINGS, MOSTELLER, TUKEY, AND WINDSOR,
C                 'LOW MOMENTS FOR SMALL SAMPLES:  A COMPARATIVE
C                 STUDY OF ORDER STATISTICS', ANNALS OF
C                 MATHEMATICAL STATISTICS, 18, 1947,
C                 PAGES 413-426.
C               --FILLIBEN, SIMPLE AND ROBUST LINEAR ESTIMATION
C                 OF THE LOCATION PARAMETER OF A SYMMETRIC
C                 DISTRIBUTION (UNPUBLISHED PH.D. DISSERTATION,
C                 PRINCETON UNIVERSITY), 1969, PAGES 42-44, 53-58.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE:  301-921-2315
C     ORIGINAL VERSION--APRIL     1994. 
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
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(ALAMBA.LE.0.0)GOTO90 
      XMAX=1.0/ALAMBA
      XMIN=-XMAX
      IF(X.LT.XMIN.OR.X.GT.XMAX)GOTO50
      GOTO90
   50 CONTINUE
      WRITE(ICOUT,2)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)X
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3)
      CALL DPWRST('XXX','BUG ')
      IF(X.LT.XMIN)CDF=0.0
      IF(X.GT.XMAX)CDF=1.0
      RETURN
   90 CONTINUE
    2 FORMAT('***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENNT')
    3 FORMAT('      TO THE LAMCDF SUBROUTINE IS OUTSIDE THE USUAL')
    4 FORMAT('      +-(1/ALAMBA) INTERVAL *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
C-----START POINT-----------------------------------------------------
C
      IF(ALAMBA.GT.0.0)GOTO110
      GOTO120
C
  110 XMAX=1.0/ALAMBA
      XMIN=-XMAX
      IF(X.LE.XMIN)CDF=0.0
      IF(X.GE.XMAX)CDF=1.0
      IF(X.LE.XMIN.OR.X.GE.XMAX)RETURN
C
  120 CONTINUE
      IF(-0.001.LT.ALAMBA.AND.ALAMBA.LT.0.001)GOTO150
      GOTO170
  150 IF(X.GE.0.0)GOTO160
      CDF=EXP(X)/(1.0+EXP(X)) 
      RETURN
  160 CDF=1.0/(1.0+EXP(-X))
      RETURN
C
  170 IF(-0.001.LT.ALAMBA.AND.ALAMBA.LT.0.001)GOTO150
      PMIN=0.0
      PMID=0.5
      PMAX=1.0
      PLOWER=PMIN
      PUPPER=PMAX
      ICOUNT=0
  210 XCALC=(PMID**ALAMBA-(1.0-PMID)**ALAMBA)/ALAMBA
      IF(XCALC.EQ.X)GOTO240
      IF(XCALC.GT.X)GOTO220
      PLOWER=PMID
      PMID=(PMID+PUPPER)/2.0
      GOTO230
  220 PUPPER=PMID
      PMID=(PMID+PLOWER)/2.0
  230 PDEL=ABS(PMID-PLOWER)
      ICOUNT=ICOUNT+1
      IF(PDEL.LT.0.000001.OR.ICOUNT.GT.30)GOTO240 
      GOTO210
  240 CDF=PMID
      RETURN
C
      END 
      SUBROUTINE LAMN(N,X,NM,BL1,DL1,IERROR)
C
C       =========================================================
C       Purpose: Compute lambda functions and their derivatives
C       Input:   x --- Argument of lambda function
C                n --- Order of lambda function
C       Output:  BL(n) --- Lambda function of order n
C                DL(n) --- Derivative of lambda function
C                NM --- Highest order computed
C       Routines called:
C                MSTA1 and MSTA2 for computing the start
C                point for backward recurrence
C       =========================================================
C
        PARAMETER(MAXORD=500)
        IMPLICIT DOUBLE PRECISION (A-H,O-Z)
        DIMENSION BL(0:MAXORD),DL(0:MAXORD)
        CHARACTER*4 IERROR
C
        IF(N.GT.MAXORD)THEN
          IERROR='YES'
          RETURN
        ENDIF
C
        NM=N
        IF (DABS(X).LT.1.0D-100) THEN
           DO 10 K=0,N
              BL(K)=0.0D0
10            DL(K)=0.0D0
           BL(0)=1.0D0
           DL(1)=0.5D0
           GOTO9999
        ENDIF
        IF (X.LE.12.0D0) THEN
           X2=X*X
           DO 25 K=0,N
              BK=1.0D0
              R=1.0D0
              DO 15 I=1,50
                 R=-0.25D0*R*X2/(I*(I+K))
                 BK=BK+R
                 IF (DABS(R).LT.DABS(BK)*1.0D-15) GO TO 20
15            CONTINUE
20            BL(K)=BK
25            IF (K.GE.1) DL(K-1)=-0.5D0*X/K*BK
           UK=1.0D0
           R=1.0D0
           DO 30 I=1,50
              R=-0.25D0*R*X2/(I*(I+N+1.0D0))
              UK=UK+R
              IF (DABS(R).LT.DABS(UK)*1.0D-15) GO TO 35
30            CONTINUE
35         DL(N)=-0.5D0*X/(N+1.0D0)*UK
           GOTO9999
        ENDIF
        IF (N.EQ.0) NM=1          
        M=MSTA1(X,200)
        IF (M.LT.NM) THEN
           NM=M
        ELSE
           M=MSTA2(X,NM,15)
        ENDIF
        BS=0.0D0
        F0=0.0D0
        F1=1.0D-100
        DO 40 K=M,0,-1
           F=2.0D0*(K+1.0D0)*F1/X-F0
           IF (K.LE.NM) BL(K)=F
           IF (K.EQ.2*INT(K/2)) BS=BS+2.0D0*F
           F0=F1
40         F1=F
        BG=BS-F
        DO 45 K=0,NM
45         BL(K)=BL(K)/BG
        R0=1.0D0
        DO 50 K=1,NM
           R0=2.0D0*R0*K/X
50         BL(K)=R0*BL(K)
        DL(0)=-0.5D0*X*BL(1)
        DO 55 K=1,NM
55         DL(K)=2.0D0*K/X*(BL(K-1)-BL(K))
C
 9999   CONTINUE
        BL1=BL(NM)
        DL1=DL(NM)
        RETURN
        END
      SUBROUTINE LAMPDF(X,ALAMBA,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE (TUKEY) LAMBDA DISTRIBUTION
C              WITH TAIL LENGTH PARAMETER VALUE = ALAMBA.
C              IN GENERAL, THE PROBABILITY DENSITY FUNCTION 
C              FOR THIS DISTRIBUTION IS NOT SIMPLE.
C              THE PERCENT POINT FUNCTION FOR THIS DISTRIBUTION IS
C              G(P) = ((P**ALAMBA)-((1-P)**ALAMBA))/ALAMBA
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                     --ALAMBA = THE SINGLE PRECISION VALUE OF LAMBDA 
C                                (THE TAIL LENGTH PARAMETER).
C     OUTPUT ARGUMENTS--PDF    = THE SINGLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE PDF FOR THE TUKEY LAMBDA DISTRIBUTION
C             WITH TAIL LENGTH PARAMETER = ALAMBA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 
C     RESTRICTIONS--FOR ALAMBA NON-POSITIVE, NO RESTRICTIONS ON X.
C                 --FOR ALAMBA POSITIVE, X SHOULD BE BETWEEN (-1/ALAMBA)
C                   AND (+1/ALAMBA), INCLUSIVELY. 
C     OTHER DATAPAC   SUBROUTINES NEEDED--LAMCDF. 
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN. 
C     REFERENCES--HASTINGS, MOSTELLER, TUKEY, AND WINDSOR,
C                 'LOW MOMENTS FOR SMALL SAMPLES:  A COMPARATIVE
C                 STUDY OF ORDER STATISTICS', ANNALS OF
C                 MATHEMATICAL STATISTICS, 18, 1947,
C                 PAGES 413-426.
C               --FILLIBEN, SIMPLE AND ROBUST LINEAR ESTIMATION
C                 OF THE LOCATION PARAMETER OF A SYMMETRIC
C                 DISTRIBUTION (UNPUBLISHED PH.D. DISSERTATION,
C                 PRINCETON UNIVERSITY), 1969, PAGES 42-44, 53-58.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE:  301-921-2315
C     ORIGINAL VERSION--APRIL     1994. 
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
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(ALAMBA.LE.0.0)GOTO90 
      XMAX=1.0/ALAMBA
      XMIN=-XMAX
      IF(X.LT.XMIN.OR.X.GT.XMAX)GOTO50
      GOTO90
   50 CONTINUE
      WRITE(ICOUT,2)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)X
      CALL DPWRST('XXX','BUG ')
      IF(X.LT.XMIN)PDF=0.0
      IF(X.GT.XMAX)PDF=1.0
      RETURN
   90 CONTINUE
    2 FORMAT('***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENNT')
    3 FORMAT('      TO THE LAMPDF SUBROUTINE IS OUTSIDE THE USUAL')
    4 FORMAT('      +-(1/ALAMBA) INTERVAL *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
C-----START POINT-----------------------------------------------------
C
      IF(ALAMBA.GT.0.0)GOTO110
      GOTO150
  110 XMAX=1.0/ALAMBA
      XMIN=-XMAX
      IF(X.GT.XMIN.AND.X.LT.XMAX)GOTO150
      IF(X.LT.XMIN.OR.X.GT.XMAX)PDF=0.0 
      IF(X.EQ.XMIN.AND.ALAMBA.LT.1.0)PDF=0.0
      IF(X.EQ.XMAX.AND.ALAMBA.LT.1.0)PDF=0.0
      IF(X.EQ.XMIN.AND.ALAMBA.EQ.1.0)PDF=0.5
      IF(X.EQ.XMAX.AND.ALAMBA.EQ.1.0)PDF=0.5
      IF(X.EQ.XMIN.AND.ALAMBA.GT.1.0)PDF=1.0
      IF(X.EQ.XMAX.AND.ALAMBA.GT.1.0)PDF=1.0
      RETURN
C
  150 CALL LAMCDF(X,ALAMBA,CDF)
      SF =CDF**(ALAMBA-1.0)+(1.0-CDF)**(ALAMBA-1.0)
      PDF=1.0/SF
      RETURN
C
      END 
      SUBROUTINE LAMPPC(X,N,ALAMBA,IWRITE,Y,W,MAXNYW,PPCC,IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE TUKEY LAMBDA
C              PROBABILITY PLOT CORRELATION COEFFICIENT
C              (WITH TAIL LENGTH PARAMETER VALUE = ALAMBA).
C              IN GENERAL, THE PROBABILITY DENSITY FUNCTION
C              FOR THIS DISTRIBUTION IS NOT SIMPLE.
C              THE PERCENT POINT FUNCTION FOR THIS DISTRIBUTION IS
C              G(P) = ((P**ALAMBA)-((1-P)**ALAMBA)) / ALAMBA
C              AS USED HEREIN, A PROBABILITY PLOT FOR A DISTRIBUTION
C              IS A PLOT OF THE ORDERED OBSERVATIONS VERSUS
C              THE ORDER STATISTIC MEDIANS FOR THAT DISTRIBUTION.
C              THE LAMBDA PROBABILITY PLOT IS USEFUL IN
C              GRAPHICALLY TESTING THE COMPOSITE (THAT IS,
C              LOCATION AND SCALE PARAMETERS NEED NOT BE SPECIFIED)
C              HYPOTHESIS THAT THE UNDERLYING DISTRIBUTION
C              FROM WHICH THE DATA HAVE BEEN RANDOMLY DRAWN
C              IS THE LAMBDA DISTRIBUTION
C              WITH TAIL LENGTH PARAMETER VALUE = ALAMBA.
C              IF THE HYPOTHESIS IS TRUE, THE PROBABILITY PLOT
C              SHOULD BE NEAR-LINEAR.
C              A MEASURE OF SUCH LINEARITY IS GIVEN BY THE
C              CALCULATED PROBABILITY PLOT CORRELATION COEFFICIENT.
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                     --ALAMBA = THE SINGLE PRECISION VALUE OF LAMBDA
C                                (THE TAIL LENGTH PARAMETER).
C     OUTPUT ARGUMENTS--PPCC   = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED TUKEY LAMBDA PPCC.
C     OUTPUT--NONE.
C     PRINTING--YES.
C     OTHER DATAPAC   SUBROUTINES NEEDED--SORT, UNIMED.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--ALOG.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--FILLIBEN, 'TECHNIQUES FOR TAIL LENGTH ANALYSIS',
C                 PROCEEDINGS OF THE EIGHTEENTH CONFERENCE
C                 ON THE DESIGN OF EXPERIMENTS IN ARMY RESEARCH
C                 DEVELOPMENT AND TESTING (ABERDEEN, MARYLAND,
C                 OCTOBER, 1972), PAGES 425-450.
C               --HAHN AND SHAPIRO, STATISTICAL METHODS IN ENGINEERING,
C                 1967, PAGES 260-308.
C               --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1970, PAGES 154-165.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           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.6
C     ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--JULY      1972.
C     UPDATED         --JULY      1981.
C     UPDATED         --AUGUST    1981.
C     UPDATED         --NOVEMBER  1981.
C     UPDATED         --MAY       1982.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
      DIMENSION Y(*)
      DIMENSION W(*)
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
      INCLUDE 'DPCOPA.INC'
C
      ISUBN1='LAMP'
      ISUBN2='PC  '
C
      IERROR='NO'
      IUPPER=MAXOBV
C
      SUM1=0.0
      SUM2=0.0
      SUM3=0.0
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 LAMPPC--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)IBUGA3
   52 FORMAT('IBUGA3 = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)N,ALAMBA
   53 FORMAT('N,ALAMBA = ',I8,E15.7)
      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 TUKEY LAMBDA                      **
C               **  PROBABILITY PLOT CORRELATION COEFFICIENT  **
C               ************************************************
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      AN=N
C
      IF(1.LE.N.AND.N.LE.IUPPER)GOTO119
      IERROR='YES'
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,111)
  111 FORMAT('***** ERROR IN LAMPPC--')
      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 TUKEY LAMBDA PROBABILITY PLOT')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,115)
  115 FORMAT('      CORRELATION COEFFICIENT IS TO BE COMPUTED')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,116)IUPPER
  116 FORMAT('      MUST BE BETWEEN 1 AND ',I8,' (INCLUSIVELY).')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,117)
  117 FORMAT('      SUCH WAS NOT THE CASE HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,118)N
  118 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
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,121)
  121 FORMAT('***** NON-FATAL DIAGNOSTIC IN LAMPPC--',
     1'THE SECOND INPUT ARGUMENT (N) HAS THE VALUE 1')
      CALL DPWRST('XXX','BUG ')
      PPCC=0.0
      GOTO9000
  129 CONTINUE
C
      HOLD=X(1)
      DO135I=2,N
      IF(X(I).NE.HOLD)GOTO139
  135 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,136)HOLD
  136 FORMAT('***** NON-FATAL DIAGNOSTIC IN LAMPPC--',
     1'THE FIRST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      PPCC=0.0
      GOTO9000
  139 CONTINUE
C
  190 CONTINUE
C
C               *************************************************
C               **  STEP 2--                                   **
C               **  COMPUTE THE TUKEY LAMBDA                   **
C               **  PROBABILITY PLOT CORRELATION COEFFICIENT.  **
C               *************************************************
C
      CALL SORT(X,N,Y)
C
      CALL UNIMED(N,W)
C
      IF(-0.001.LT.ALAMBA.AND.ALAMBA.LT.0.001)GOTO210
      GOTO220
  210 CONTINUE
      DO215I=1,N
      Q=W(I)
      W(I)=ALOG(1/(1.0-Q))
  215 CONTINUE
      GOTO290
  220 CONTINUE
      DO225I=1,N
      Q=W(I)
      W(I)=(Q**ALAMBA-(1.0-Q)**ALAMBA)/ALAMBA
  225 CONTINUE
      GOTO290
  290 CONTINUE
C
      SUM1=0.0
      DO300I=1,N
      SUM1=SUM1+Y(I)
  300 CONTINUE
      YBAR=SUM1/AN
      WBAR=0.0
C
      SUM1=0.0
      SUM2=0.0
      SUM3=0.0
      DO400I=1,N
      SUM1=SUM1+(Y(I)-YBAR)*(Y(I)-YBAR)
      SUM2=SUM2+(W(I)-WBAR)*(Y(I)-YBAR)
      SUM3=SUM3+(W(I)-WBAR)*(W(I)-WBAR)
  400 CONTINUE
      PPCC=SUM2/SQRT(SUM3*SUM1)
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)ALAMBA
  811 FORMAT('THE TUKEY LAMBDA ',F10.5,' PROBABILITY PLOT ',
     1'CORRELATION COEFFICIENT')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,812)N,PPCC
  812 FORMAT('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 LAMPPC--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IBUGA3,IERROR
 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)N,ALAMBA
 9013 FORMAT('N,ALAMBA = ',I8,E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9014)SUM1,SUM2,SUM3
 9014 FORMAT('SUM1,SUM2,SUM3 = ',3E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9015)PPCC
 9015 FORMAT('PPCC = ',E15.7)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE LAMPPF(P,ALAMBA,PPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE (TUKEY) LAMBDA DISTRIBUTION
C              WITH TAIL LENGTH PARAMETER VALUE = ALAMBA.
C              IN GENERAL, THE PROBABILITY DENSITY FUNCTION
C              FOR THIS DISTRIBUTION IS NOT SIMPLE.
C              THE PERCENT POINT FUNCTION FOR THIS DISTRIBUTION IS
C              G(P) = ((P**ALAMBA)-((1-P)**ALAMBA))/ALAMBA
C              NOTE THAT THE PERCENT POINT FUNCTION OF A DISTRIBUTION
C              IS IDENTICALLY THE SAME AS THE INVERSE CUMULATIVE
C              DISTRIBUTION FUNCTION OF THE DISTRIBUTION.
C     INPUT  ARGUMENTS--P      = THE SINGLE PRECISION VALUE
C                                (BETWEEN 0.0 AND 1.0)
C                                AT WHICH THE PERCENT POINT
C                                FUNCTION IS TO BE EVALUATED.
C                     --ALAMBA = THE SINGLE PRECISION VALUE OF LAMBDA
C                                (THE TAIL LENGTH PARAMETER).
C     OUTPUT ARGUMENTS--PPF    = THE SINGLE PRECISION PERCENT
C                                POINT FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PERCENT POINT
C             FUNCTION VALUE PPF FOR THE TUKEY LAMBDA DISTRIBUTION
C             WITH TAIL LENGTH PARAMETER = ALAMBA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--IF ALAMBA IS POSITIVE,
C                   THEN P SHOULD BE BETWEEN 0.0 AND 1.0, INCLUSIVELY.
C                   IF ALAMBA IS NON-POSITIVE,
C                   THEN P SHOULD BE BETWEEN 0.0 AND 1.0, EXCLUSIVELY.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--ALOG.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--FILLIBEN, SIMPLE AND ROBUST LINEAR ESTIMATION
C                 OF THE LOCATION PARAMETER OF A SYMMETRIC
C                 DISTRIBUTION (UNPUBLISHED PH.D. DISSERTATION,
C                 PRINCETON UNIVERSITY), 1969, PAGES 21-44, 229-231,
C                 PAGES 53-58.
C               --FILLIBEN, 'THE PERCENT POINT FUNCTION',
C                 (UNPUBLISHED MANUSCRIPT), 1970, PAGES 28-31.
C               --HASTINGS, MOSTELLER, TUKEY, AND WINDSOR,
C                 'LOW MOMENTS FOR SMALL SAMPLES:  A COMPARATIVE
C                 STUDY OF ORDER STATISTICS', ANNALS OF
C                 MATHEMATICAL STATISTICS, 18, 1947,
C                 PAGES 413-426.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           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.6
C     ORIGINAL VERSION--JUNE      1972.
C     UPDATED         --SEPTEMBER 1975.
C     UPDATED         --NOVEMBER  1975.
C     UPDATED         --DECEMBER  1981.
C     UPDATED         --MAY       1982.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      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(ALAMBA.LE.0.0.AND.P.LE.0.0)GOTO50
      IF(ALAMBA.LE.0.0.AND.P.GE.1.0)GOTO50
      IF(ALAMBA.GT.0.0.AND.P.LT.0.0)GOTO50
      IF(ALAMBA.GT.0.0.AND.P.GT.1.0)GOTO50
      GOTO90
   50 WRITE(ICOUT,1)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)P
      CALL DPWRST('XXX','BUG ')
      RETURN
   90 CONTINUE
    1 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ',
     1'LAMPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
      IF(-0.001.LT.ALAMBA.AND.ALAMBA.LT.0.001)GOTO150
      GOTO250
  150 PPF=ALOG(P/(1.0-P))
      RETURN
C
  250 PPF= (P**ALAMBA-(1.0-P)**ALAMBA)/ALAMBA
      RETURN
C
      END
      SUBROUTINE LAMRAN(N,ALAMBA,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE (TUKEY) LAMBDA DISTRIBUTION
C              WITH TAIL LENGTH PARAMETER VALUE = ALAMBA.
C              IN GENERAL, THE PROBABILITY DENSITY FUNCTION
C              FOR THIS DISTRIBUTION IS NOT SIMPLE.
C              THE PERCENT POINT FUNCTION FOR THIS DISTRIBUTION IS
C              G(P) = ((P**ALAMBA)-((1-P)**ALAMBA))/ALAMBA
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --ALAMBA = THE SINGLE PRECISION VALUE OF LAMBDA
C                                (THE TAIL LENGTH PARAMETER).
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST N)
C                                INTO WHICH THE GENERATED
C                                RANDOM SAMPLE WILL BE PLACED.
C     OUTPUT--A RANDOM SAMPLE OF SIZE N
C             FROM THE (TUKEY) LAMBDA DISTRIBUTION
C             WITH TAIL LENGTH PARAMETER VALUE = ALAMBA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--ALOG.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--TOCHER, THE ART OF SIMULATION,
C                 1963, PAGES 14-15.
C               --HAMMERSLEY AND HANDSCOMB, MONTE CARLO METHODS,
C                 1964, PAGE 36.
C               --FILLIBEN, SIMPLE AND ROBUST LINEAR ESTIMATION
C                 OF THE LOCATION PARAMETER OF A SYMMETRIC
C                 DISTRIBUTION (UNPUBLISHED PH.D. DISSERTATION,
C                 PRINCETON UNIVERSITY), 1969, PAGES 21-44, 53-58.
C               --FILLIBEN, 'THE PERCENT POINT FUNCTION',
C                 (UNPUBLISHED MANUSCRIPT), 1970, PAGES 28-31.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           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.6
C     ORIGINAL VERSION--JUNE      1972.
C     UPDATED         --SEPTEMBER 1975.
C     UPDATED         --NOVEMBER  1975.
C     UPDATED         --DECEMBER  1981.
C     UPDATED         --MAY       1982.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
C
C---------------------------------------------------------------------
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
      ALAMB2=ALAMBA
      IF(N.LT.1)GOTO50
      GOTO90
   50 WRITE(ICOUT, 5)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,47)N
      CALL DPWRST('XXX','BUG ')
      RETURN
   90 CONTINUE
    5 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ',
     1'LAMRAN SUBROUTINE IS NON-POSITIVE *****')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
C
C     GENERATE N UNIFORM (0,1) RANDOM NUMBERS;
C
      CALL UNIRAN(N,ISEED,X)
C
C     GENERATE N LAMBDA DISTRIBUTION RANDOM NUMBERS
C     USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD.
C
      DO100I=1,N
      Q=X(I)
      IF(-0.001.LT.ALAMB2.AND.ALAMB2.LT.0.001)X(I)=ALOG(Q/(1.0-Q))
      IF(-0.001.LT.ALAMB2.AND.ALAMB2.LT.0.001)GOTO100
      X(I)=(Q**ALAMB2-(1.0-Q)**ALAMB2)/ALAMB2
  100 CONTINUE
C
      RETURN
      END
      SUBROUTINE LAMSF(P,ALAMBA,SF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE SPARSITY
C              FUNCTION VALUE FOR THE (TUKEY) LAMBDA DISTRIBUTION
C              WITH TAIL LENGTH PARAMETER VALUE = ALAMBA.
C              IN GENERAL, THE PROBABILITY DENSITY FUNCTION 
C              FOR THIS DISTRIBUTION IS NOT SIMPLE.
C              THE PERCENT POINT FUNCTION FOR THIS DISTRIBUTION IS
C              G(P) = ((P**ALAMBA)-((1-P)**ALAMBA))/ALAMBA
C              NOTE THAT THE SPARSITY FUNCTION OF A DISTRIBUTION
C              IS THE DERIVATIVE OF THE PERCENT POINT FUNCTION,
C              AND ALSO IS THE RECIPROCAL OF THE PROBABILITY
C              DENSITY FUNCTION (BUT IN UNITS OF P RATHER THAN X).
C     INPUT  ARGUMENTS--P      = THE SINGLE PRECISION VALUE 
C                                (BETWEEN 0.0 AND 1.0)
C                                AT WHICH THE SPARSITY
C                                FUNCTION IS TO BE EVALUATED.
C                     --ALAMBA = THE SINGLE PRECISION VALUE OF LAMBDA 
C                                (THE TAIL LENGTH PARAMETER).
C     OUTPUT ARGUMENTS--SF     = THE SINGLE PRECISION
C                                SPARSITY FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION SPARSITY
C             FUNCTION VALUE SF FOR THE TUKEY LAMBDA DISTRIBUTION
C             WITH TAIL LENGTH PARAMETER = ALAMBA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 
C     RESTRICTIONS--IF ALAMBA IS POSITIVE,
C                   THEN P SHOULD BE BETWEEN 0.0 AND 1.0, INCLUSIVELY.
C                   IF ALAMBA IS NON-POSITIVE,
C                   THEN P SHOULD BE BETWEEN 0.0 AND 1.0, EXCLUSIVELY.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN. 
C     REFERENCES--FILLIBEN, SIMPLE AND ROBUST LINEAR ESTIMATION
C                 OF THE LOCATION PARAMETER OF A SYMMETRIC
C                 DISTRIBUTION (UNPUBLISHED PH.D. DISSERTATION,
C                 PRINCETON UNIVERSITY), 1969, PAGES 21-44, 229-231,
C                 PAGES 53-58.
C               --FILLIBEN, 'THE PERCENT POINT FUNCTION',
C                 (UNPUBLISHED MANUSCRIPT), 1970, PAGES 28-31.
C               --HASTINGS, MOSTELLER, TUKEY, AND WINDSOR,
C                 'LOW MOMENTS FOR SMALL SAMPLES:  A COMPARATIVE
C                 STUDY OF ORDER STATISTICS', ANNALS OF
C                 MATHEMATICAL STATISTICS, 18, 1947,
C                 PAGES 413-426.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE:  301-921-2315
C     ORIGINAL VERSION--APRIL     1994. 
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
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(ALAMBA.LE.0.0.AND.P.LE.0.0)GOTO50
      IF(ALAMBA.LE.0.0.AND.P.GE.1.0)GOTO50
      IF(ALAMBA.GT.0.0.AND.P.LT.0.0)GOTO50
      IF(ALAMBA.GT.0.0.AND.P.GT.1.0)GOTO50
      GOTO90
   50 CONTINUE
      WRITE(ICOUT,1)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)P
      CALL DPWRST('XXX','BUG ')
      RETURN
   90 CONTINUE
    1 FORMAT(
     1'***** FATAL ERROR--THE FIRST  INPUT ARGUMENT TO THE LAMSF')
    2 FORMAT(
     1'      SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
C-----START POINT-----------------------------------------------------
C
      SF=P**(ALAMBA-1.0)+(1.0-P)**(ALAMBA-1.0)
C
      RETURN
      END 
      SUBROUTINE LAMV(V,X,VM,VL1,DL1,IERROR)
C
C       =========================================================
C       Purpose: Compute lambda function with arbitrary order v,
C                and their derivative
C       Input :  x --- Argument of lambda function
C                v --- Order of lambda function 
C       Output:  VL(n) --- Lambda function of order n+v0
C                DL(n) --- Derivative of lambda function 
C                VM --- Highest order computed
C       Routines called:
C            (1) MSTA1 and MSTA2 for computing the starting 
C                point for backward recurrence
C            (2) GAM0 for computing gamma function (|x|   1)
C                (USE SLATEC VERSION: DGAMMA)
C       =========================================================
C
      PARAMETER(MAXORD=500)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION VL(0:MAXORD),DL(0:MAXORD)
      CHARACTER*4 IERROR
C
        IF(V.GT.REAL(MAXORD))THEN
          IERROR='YES'
          RETURN
        ENDIF
C
      PI=3.141592653589793D0
      RP2=0.63661977236758D0
      X=DABS(X)
      X2=X*X
      N=INT(V)
      V0=V-N
      VM=V
      IF (X.LE.12.0D0) THEN
         DO 25 K=0,N
            VK=V0+K
            BK=1.0D0
            R=1.0D0
            DO 10 I=1,50
              R=-0.25D0*R*X2/(I*(I+VK))
              BK=BK+R
              IF (DABS(R).LT.DABS(BK)*1.0D-15) GO TO 15
10          CONTINUE
15          CONTINUE
            VL(K)=BK
            UK=1.0D0
            R=1.0D0
            DO 20 I=1,50
              R=-0.25D0*R*X2/(I*(I+VK+1.0D0))
              UK=UK+R
              IF (DABS(R).LT.DABS(UK)*1.0D-15) GO TO 25
20          CONTINUE
25          DL(K)=-0.5D0*X/(VK+1.0D0)*UK
         GOTO9999
      ENDIF
      K0=11
      IF (X.GE.35.0D0) K0=10
      IF (X.GE.50.0D0) K0=8
      DO 40 J=0,1
         VV=4.0D0*(J+V0)*(J+V0)
         PX=1.0D0
         RP=1.0D0
         DO 30 K=1,K0
            RP=-0.78125D-2*RP*(VV-(4.0*K-3.0)**2.0)*(VV-
     &            (4.0*K-1.0)**2.0)/(K*(2.0*K-1.0)*X2)
30            PX=PX+RP
         QX=1.0D0
         RQ=1.0D0
         DO 35 K=1,K0
            RQ=-0.78125D-2*RQ*(VV-(4.0*K-1.0)**2.0)*(VV-
     &            (4.0*K+1.0)**2.0)/(K*(2.0*K+1.0)*X2)
35            QX=QX+RQ
         QX=0.125D0*(VV-1.0D0)*QX/X
         XK=X-(0.5D0*(J+V0)+0.25D0)*PI
         A0=DSQRT(RP2/X)
         CK=DCOS(XK)
         SK=DSIN(XK)
         IF (J.EQ.0) BJV0=A0*(PX*CK-QX*SK)
         IF (J.EQ.1) BJV1=A0*(PX*CK-QX*SK)
40    CONTINUE
      IF (V0.EQ.0.0D0) THEN
        GA=1.0D0
      ELSE
CCCCC USE SLATEC GAMMA FUNCTION
CCCCC   CALL GAM0(V0,GA)
        GA=DGAMMA(V0)
        GA=V0*GA
      ENDIF
      FAC=(2.0D0/X)**V0*GA
      VL(0)=BJV0
      DL(0)=-BJV1+V0/X*BJV0
      VL(1)=BJV1
      DL(1)=BJV0-(1.0D0+V0)/X*BJV1
      R0=2.0D0*(1.0D0+V0)/X
      IF (N.LE.1) THEN
         VL(0)=FAC*VL(0)
         DL(0)=FAC*DL(0)-V0/X*VL(0)
         VL(1)=FAC*R0*VL(1)
         DL(1)=FAC*R0*DL(1)-(1.0D0+V0)/X*VL(1)
         GOTO9999
      ENDIF
      IF (N.GE.2.AND.N.LE.INT(0.9*X)) THEN
         F0=BJV0
         F1=BJV1
         DO 45 K=2,N
            F=2.0D0*(K+V0-1.0D0)/X*F1-F0
            F0=F1
            F1=F
45            VL(K)=F
      ELSE IF (N.GE.2) THEN
         M=MSTA1(X,200)
         IF (M.LT.N) THEN
            N=M
         ELSE
            M=MSTA2(X,N,15)
         ENDIF
         F2=0.0D0
         F1=1.0D-100
         DO 50 K=M,0,-1
            F=2.0D0*(V0+K+1.0D0)/X*F1-F2
            IF (K.LE.N) VL(K)=F
            F2=F1
50            F1=F
         IF (DABS(BJV0).GT.DABS(BJV1)) CS=BJV0/F
         IF (DABS(BJV0).LE.DABS(BJV1)) CS=BJV1/F2
         DO 55 K=0,N
55            VL(K)=CS*VL(K)
      ENDIF
      VL(0)=FAC*VL(0)
      DO 65 J=1,N
         RC=FAC*R0
         VL(J)=RC*VL(J)
         DL(J-1)=-0.5D0*X/(J+V0)*VL(J)
65         R0=2.0D0*(J+V0+1)/X*R0
      DL(N)=2.0D0*(V0+N)*(VL(N-1)-VL(N))/X
      VM=N+V0
C
 9999 CONTINUE
      VL1=VL(N)
      DL1=DL(N)
      RETURN
      END
      DOUBLE PRECISION FUNCTION LANCDF(X)
* From CERNLIB, remame DISLAN to LANCDF
*
* $Id: dislan.F,v 1.1.1.1 1996/04/01 15:02:43 mclareni Exp $
*
* $Log: dislan.F,v $
* Revision 1.1.1.1  1996/04/01 15:02:43  mclareni
* Mathlib gen
*
*

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
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
      DIMENSION F(6:982)

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

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

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

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

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

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

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

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

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

      DATA (F(I),I=901,982)
     A/11.762390,11.877664,11.995170,12.114979,12.237161,12.361791,
     B 12.488946,12.618708,12.751161,12.886394,13.024498,13.165570,
     C 13.309711,13.457026,13.607625,13.761625,13.919145,14.080314,
     D 14.245263,14.414134,14.587072,14.764233,14.945778,15.131877,
     E 15.322712,15.518470,15.719353,15.925570,16.137345,16.354912,
     F 16.578520,16.808433,17.044929,17.288305,17.538873,17.796967,
     G 18.062943,18.337176,18.620068,18.912049,19.213574,19.525133,
     H 19.847249,20.180480,20.525429,20.882738,21.253102,21.637266,
     I 22.036036,22.450278,22.880933,23.329017,23.795634,24.281981,
     J 24.789364,25.319207,25.873062,26.452634,27.059789,27.696581,
     K 28.365274,29.068370,29.808638,30.589157,31.413354,32.285060,
     L 33.208568,34.188705,35.230920,36.341388,37.527131,38.796172,
     M 40.157721,41.622399,43.202525,44.912465,46.769077,48.792279,
     N 51.005773,53.437996,56.123356,59.103894/

      IF(X.LT.0.000001D0 .OR. X.GT.0.999999D0)THEN
        WRITE(ICOUT, 5)
 5      FORMAT('**** ERROR IN LANPPF: ARGUMENT NOT IN THE ',
     1         '(0.000001,0.999999) INTERVAL')
        CALL DPWRST('XXX','BUG ')
        RETURN
      ENDIF
      U=1000.0D0*X
      I=U
      U=U-I
      IF(I .GE. 70 .AND. I .LE. 800) THEN
        LANPPF=F(I)+U*(F(I+1)-F(I))
      ELSEIF(I .GE.  7 .AND. I .LE. 980) THEN
        LANPPF=
     1  F(I)+U*(F(I+1)-F(I)-0.25D0*
     1  (1.0D0-U)*(F(I+2)-F(I+1)-F(I)+F(I-1)))
      ELSEIF(I. LT. 7) THEN
        V=LOG(X)
        U=1.0D0/V
        LANPPF=((0.99858950D0+(3.45213058D1+1.70854528D1*U)*U)/
     1         (1.0D0     +(3.41760202D1+4.01244582D0  *U)*U))*
     2         (-LOG(-0.91893853D0-V)-1.0D0)
      ELSE
C
C  NOTE: I HAD A BIT OF A PROBLEM WITH LAST CASE.  RECODE
C  SLIGHTLY.
C
        X=X*10**6 + 0.1
        I=X
        I=1000000-I
        U=I
        U=U/(1.0D0*10**6)
CCCCC   U=1.0D0-X
        V=U**2
        IF(X .LE. 0.999D0) THEN
          LANPPF=(1.00060006D0+2.63991156D2*U+4.37320068D3*V)/
     1    ((1.0D0     +2.57368075D2*U+3.41448018D3*V)*U)
        ELSE
CCCCC      print *,'u,v=',u,v
           D1 = 1.00001538D0
           D2 = 6.075141193D0*10**3
           D3 = 7.34266409D0*10**5
           D4 = 6.06511919D0*10**3
           D5 = 6.94021044D0*10**5
           DNUM = D1 + D2*U + D3*V
           DDEN = (1.0D0 + D4*U + D5*V)*U
           LANPPF = DNUM/DDEN
CCCCC     LANPPF=(1.00001538D0+6.07514119D3*U+7.34266409D5*V)/
CCCCC1           ((1.0D0     +6.06511919D3*U+6.94021044D5*V)*U)
        ENDIF
      ENDIF
      RETURN
      END
      SUBROUTINE LANRAN(N,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE LANDAU DISTRIBUTION
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST N)
C                                INTO WHICH THE GENERATED
C                                RANDOM SAMPLE WILL BE PLACED.
C     OUTPUT--A RANDOM SAMPLE OF SIZE N
C             FROM THE LANDAU DISTRIBUTION
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           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.4
C     ORIGINAL VERSION--APRIL     2003.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
      DOUBLE PRECISION LANPPF
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'LANRAN 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 LANDAU DISTRIBUTION RANDOM NUMBERS
C     USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD.
C
      DO100I=1,N
  105   CONTINUE
        IF(X(I).LT.0.000001 .OR. X(I).GT.0.999999)THEN
          CALL UNIRAN(1,ISEED,X(I))
          IF(X(I).LT.0.000001 .OR. X(I).GT.0.999999)GOTO105
        ENDIF
        XTEMP=REAL(LANPPF(DBLE(X(I))))
        X(I)=XTEMP
  100 CONTINUE
C
 9000 CONTINUE
      RETURN
      END
      DOUBLE PRECISION FUNCTION LANXM1(X)
* From CERNLIB, rename XM1LAN to LANXM1
*
* $Id: xm1lan.F,v 1.1.1.1 1996/04/01 15:02:44 mclareni Exp $
*
* $Log: xm1lan.F,v $
* Revision 1.1.1.1  1996/04/01 15:02:44  mclareni
* Mathlib gen
*
*

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

      V=X
      IF(V .LT. -4.5D0) THEN
       U=EXP(V+1.0D0)
       LANXM2=V**2-2.0D0*U**2*
     1        (V/U+A2(0)*V+A3(0)+(A2(1)*V+A3(1)+(A2(2)*V+A3(2)+
     2        (A2(3)*V+A3(3))*U)*U)*U)/
     3        (1.0D0+(A1(1)+(A1(2)+A1(3)*U)*U)*U)
      ELSEIF(V .LT. -2.0D0) THEN
       LANXM2=(P1(0)+(P1(1)+(P1(2)+(P1(3)+P1(4)*V)*V)*V)*V)/
     1        (Q1(0)+(Q1(1)+(Q1(2)+(Q1(3)+Q1(4)*V)*V)*V)*V)
      ELSEIF(V .LT. 2.0D0) THEN
       LANXM2=(P2(0)+(P2(1)+(P2(2)+(P2(3)+P2(4)*V)*V)*V)*V)/
     1        (Q2(0)+(Q2(1)+(Q2(2)+(Q2(3)+Q2(4)*V)*V)*V)*V)
      ELSEIF(V .LT. 5.0D0) THEN
       U=1.0D0/V
       LANXM2=V*(P3(0)+(P3(1)+(P3(2)+P3(3)*U)*U)*U)/
     1          (Q3(0)+(Q3(1)+(Q3(2)+Q3(3)*U)*U)*U)
      ELSEIF(V .LT. 50.0D0) THEN
       U=1.0D0/V
       LANXM2=V*(P4(0)+(P4(1)+(P4(2)+(P4(3)+P4(4)*U)*U)*U)*U)/
     1          (Q4(0)+(Q4(1)+(Q4(2)+(Q4(3)+Q4(4)*U)*U)*U)*U)
      ELSEIF(V .LT. 200.0D0) THEN
       U=1.0D0/V
       LANXM2=V*(P5(0)+(P5(1)+(P5(2)+P5(3)*U)*U)*U)/
     1          (Q5(0)+(Q5(1)+(Q5(2)+Q5(3)*U)*U)*U)
      ELSE
       U=V-V*LOG(V)/(V+1.0D0)
       V=1.0D0/(U-U*(U+LOG(U)-V)/(U+1.0D0))
       U=-LOG(V)
       LANXM2=(1.0D0/V+U**2+A0(0)+A0(1)*U+(-U**2+A0(2)*U+A0(3)+
     1   (A0(4)*U**2+A0(5)*U+A0(6))*V)*V)/(1.0D0-(1.0D0-A0(4)*V)*V)
      ENDIF
      RETURN
      END
      Function lcmrnd(ix)
C
C  THIS FUNCTION USED BY THE "R250" RANDOM NUMBER GENERATOR
C
C     The minimal standard PRNG for 31 bit unsigned integers
C     designed with automatic overflow protection  
C     uses ix as the seed value if it is greater than zero
C     otherwise it is ignored
      Integer*4 ix
      Integer*4 a, b, m, q, r
      Integer*4 hi, lo, test
      Integer*4 x
      SAVE x
      Parameter (a = 16807, b = 0, m = 2147483647)
      Parameter (q = 127773, r = 2836)
C
      If ( ix .gt. 0 ) x = ix
C
      hi = x / q
      lo = mod( x, q )
      test = a * lo - r * hi
      if ( test .gt. 0 ) then
          x = test
      else
          x = test + m
      endif
C
      lcmrnd = x
C
      return
      End
      SUBROUTINE LATCON(IA,IWIDTH,IB,IWIDT2,MAXWID,ISUBRO,IERROR)
C
C     PURPOSE--CONVERT DATAPLOT SPECIAL CHARACTERS (E.G., GREEK
C              CHARACTERS, SUBSCRIPTS, SUPERSCRIPTS, MATH SYMBOLS)
C              FROM DATAPLOT CODING TO COMPARABLE LATEX CODING.
C
C     INPUT  ARGUMENTS--IA     = INITIAL CHARACTER STRING
C                       IWIDTH = NUMBER OF CHARACTERS IN IA
C                       ISUBRO = BUG TRACE VARIABLE
C     OUTPUT ARGUMENTS--IB     = OUTPUT CHARACTER STRING
C                       IWIDT2 = NUMBER OF CHARACTERS IN IB
C                       IERROR = HOLLERITH VARIABLE
C
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           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
      CHARACTER*(*) IA
      CHARACTER*(*) IB
C
      CHARACTER*4 ICASFL
      CHARACTER*4 IBASLC
C
      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(ISUBRO.EQ.'ON')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,51)
   51   FORMAT('***** AT THE BEGINNING OF LATCON--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,52)IWIDTH,MAXWID,ISUBRO,IERROR
   52   FORMAT('IWIDTH,MAXWID,ISUBRO,IERROR = ',I8,2X,I8,2X,A4,2X,A4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,53)(IA(I:I),I=1,MIN(100,IWIDTH))
   53   FORMAT('(IA(I),I=1,IWIDTH) = ',100A1)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      IBASLC=CHAR(92)
C
C               *****************************************************
C               **  THE FOLLOWING CODE WILL SEARCH FOR DATAPLOT'S  **
C               **  SPECIAL CHARACTER CODES AND CONVERT THEM TO    **
C               **  EQUIVALENT LATEX CODES.                        **
C               *****************************************************
C
C
C     UC()   = UPPER CASE
C     LC()   = LOWER CASE
C     MU()   = GREEK MU
C     NU()   = GREEK NU
C     XI()   = GREEK XI
C     PI()   = GREEK PI
C     LT()   = LESS THAN
C     GT()   = GREATER THAN
C     +-()   = + OR -
C     -+()   = - OR +
C     SP()   = SPACE
C     SUB()  = ENTER SUBSCRIPT MODE
C     SUP()  = ENTER SUPERSCRIPT MODE
C     ETA()  = GREEK ETA
C     RHO()  = GREEK RHO
C     TAU()  = GREEK TAU
C     PHI()  = GREEK PHI
C     CHI()  = GREEK CHI
C     PSI()  = GREEK PSI
C     DEL()  = VECTOR PRODUCT
C     UNSB() = LEAVE SUBSCRIPT MODE
C     UNSP() = LEAVE SUPERSCRIPT MODE
C     ALPH() = GREEK ALPHA
C     BETA() = GREEK BETA
C     GAMM() = GREEK GAMMA
C     DELT() = GREEK DELTA
C     EPSI() = GREEK EPSILON
C     ZETA() = GREEK ZETA
C     THET() = GREEK THETA
C     IOTA() = GREEK IOTA
C     KAPP() = GREEK KAPPA
C     LAMB() = GREEK LAMBDA
C     OMIC() = GREEK OMICON
C     SIGM() = GREEK SIGMA
C     UPSI() = GREEK UPSILON
C     OMEG() = GREEK OMEGA
C     PART() = PARTIAL DERIVATIVE
C     INTE() = INTEGRAL
C     CINT() = CIRCULAR INTEGRAL
C     SUMM() = SUMMATION
C     PROD() = PRODUCT
C     INFI() = INFINITY
C     TIME() = TIMES
C     DOTP() = DOT PRODUCT
C     DIVI() = DIVISION
C     LTEQ() = LESS THAN OR EQUAL TO
C     GTEQ() = GREATER THAN OR EQUAL TO
C     NOT=() = NOT EQUAL
C     APPR() = APPROXIMATELY EQUAL TO
C     EQUI() = EQUIVALENCE
C     VARI() = VARIES
C     TILD() = TILDE
C     CARA() = CARAT
C     PRIM() = PRIME
C     RADI() = RADICAL
C     LRAD() = LARGE RADICAL
C     SUBS() = SUBSET
C     SUPE() = SUPERSET
C     UNIO() = UNION
C     INTR() = INTERSECTION
C     ELEM() = IS AN ELEMENT OF
C     THEX() = THERE EXISTS
C     THFO() = THEREFORE
C     LAPO() = LEFT APOSTROPHE
C     RAPO() = RIGHT APOSTROPHE
C     LBRA() = LEFT BRACKET
C     RBRA() = RIGHT BRACKET
C     LCBR() = LEFT CURLY BRACKET
C     RCBR() = RIGHT CURLY BRACKET
C     LELB() = LEFT ELBOW
C     RELB() = RIGHT ELBOW
C     LACC() = LEFT ACCENT
C     BREV() = BREVE
C     RQUO() = RIGHT QUOTE
C     LQUO() = LEFT QUOTE
C     NASP() = NORMAL ASPIRATE    (NOT CURRENTLY SUPPORTED)
C     IASP() = INVERTED ASPIRATE  (NOT CURRENTLY SUPPORTED)
C     RARR() = RIGHT ARROW
C     LARR() = LEFT ARROW
C     UARR() = UP ARROW
C     DARR() = DOWN ARROW
C     PARA() = PARAGRAPH
C     DAGG() = DAGGER
C     DDAG() = DOUBLE DAGGER
C     VBAR() = VERTICAL BAR
C     DVBA() = DOUBLE VERTICAL BAR
C     LVBA() = LONG VERTICAL BAR
C     HBAR() = HORIZONTAL BAR
C     LHBA() = LONG HORIZONTAL BAR
C     DEGR() = DEGREE
C
      IWIDT2=0
      IB(1:MAXWID)=' '
      ICASFL='UPPE'
      ISUBFL=0
      ISUPFL=0
      NSKIP=0
C
      IF(IWIDTH.GE.4)THEN
        NTEMP=IWIDTH-3
        DO100I=1,NTEMP
C
          IF(ISUBRO.EQ.'TCON')THEN
            WRITE(ICOUT,151)I,IWIDT2,NSKIP,IA(I:I)
  151       FORMAT('I,IWIDT2,NSKIP,IA(I:I) = ',3I8,A1)
            CALL DPWRST('XXX','BUG ')
          ENDIF
C
          IF(NSKIP.GT.0)THEN
            NSKIP=NSKIP-1
            GOTO100
          ENDIF
C
C         SET UPPER CASE FLAG
C
          IF((IA(I:I).EQ.'U'.OR.IA(I:I).EQ.'u') .AND.
     1       (IA(I+1:I+1).EQ.'C'.OR.IA(I+1:I+1).EQ.'c') .AND.
     1       IA(I+2:I+2).EQ.'(' .AND. IA(I+3:I+3).EQ.')')THEN
            ICASFL='UPPE'
            NSKIP=3
C
C         SET LOWER CASE FLAG
C
          ELSEIF((IA(I:I).EQ.'L'.OR.IA(I:I).EQ.'l') .AND.
     1       (IA(I+1:I+1).EQ.'C'.OR.IA(I+1:I+1).EQ.'c') .AND.
     1       IA(I+2:I+2).EQ.'(' .AND. IA(I+3:I+3).EQ.')')THEN
            ICASFL='UPPE'
            NSKIP=3
C
C         SET SPACE
C
          ELSEIF((IA(I:I).EQ.'S'.OR.IA(I:I).EQ.'s') .AND.
     1       (IA(I+1:I+1).EQ.'P'.OR.IA(I+1:I+1).EQ.'p') .AND.
     1       IA(I+2:I+2).EQ.'(' .AND. IA(I+3:I+3).EQ.')')THEN
            IWIDT2=IWIDT2+1
            IB(IWIDT2:IWIDT2)=' '
            NSKIP=3
C
C         SET GREEK MU = $\mu$
C
          ELSEIF((IA(I:I).EQ.'M'.OR.IA(I:I).EQ.'m') .AND.
     1           (IA(I+1:I+1).EQ.'U'.OR.IA(I+1:I+1).EQ.'u') .AND.
     1           IA(I+2:I+2).EQ.'(' .AND. IA(I+3:I+3).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+4
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$ mu$'
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+4
            NSKIP=3
C
C         SET GREEK NU = $\nu$
C
          ELSEIF((IA(I:I).EQ.'N'.OR.IA(I:I).EQ.'n') .AND.
     1           (IA(I+1:I+1).EQ.'U'.OR.IA(I+1:I+1).EQ.'u') .AND.
     1           IA(I+2:I+2).EQ.'(' .AND. IA(I+3:I+3).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+4
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$ nu$'
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+4
            NSKIP=3
C
C         SET GREEK XI = $\xi$ OR $\XI$
C
          ELSEIF((IA(I:I).EQ.'X'.OR.IA(I:I).EQ.'x') .AND.
     1           (IA(I+1:I+1).EQ.'i'.OR.IA(I+1:I+1).EQ.'i') .AND.
     1           IA(I+2:I+2).EQ.'(' .AND. IA(I+3:I+3).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+4
            IF(NLAST.GT.MAXWID)GOTO8010
            IF(ICASFL.EQ.'UPPE')THEN
              IB(IWIDT2:NLAST)='$ Xi$'
            ELSE
              IB(IWIDT2:NLAST)='$ xi$'
            ENDIF
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+4
            NSKIP=3
C
C         SET GREEK PI = $\pi$ OR $\PI$
C
          ELSEIF((IA(I:I).EQ.'P'.OR.IA(I:I).EQ.'p') .AND.
     1           (IA(I+1:I+1).EQ.'I'.OR.IA(I+1:I+1).EQ.'i') .AND.
     1           IA(I+2:I+2).EQ.'(' .AND. IA(I+3:I+3).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+4
            IF(NLAST.GT.MAXWID)GOTO8010
            IF(ICASFL.EQ.'UPPE')THEN
              IB(IWIDT2:NLAST)='$ Pi$'
            ELSE
              IB(IWIDT2:NLAST)='$ pi$'
            ENDIF
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+4
            NSKIP=3
C
C         SET LESS THAN = <
C
          ELSEIF((IA(I:I).EQ.'L'.OR.IA(I:I).EQ.'L') .AND.
     1           (IA(I+1:I+1).EQ.'T'.OR.IA(I+1:I+1).EQ.'t') .AND.
     1           IA(I+2:I+2).EQ.'(' .AND. IA(I+3:I+3).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='<'
            NSKIP=3
C
C         SET GREATER THAN = >
C
          ELSEIF((IA(I:I).EQ.'G'.OR.IA(I:I).EQ.'g') .AND.
     1           (IA(I+1:I+1).EQ.'T'.OR.IA(I+1:I+1).EQ.'t') .AND.
     1           IA(I+2:I+2).EQ.'(' .AND. IA(I+3:I+3).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='>'
            NSKIP=3
C
C         SET +/-  = $\pm$
C
          ELSEIF(IA(I:I).EQ.'+' .AND. IA(I+1:I+1).EQ.'-' .AND.
     1           IA(I+2:I+2).EQ.'(' .AND. IA(I+3:I+3).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+4
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$ pm$'
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+4
            NSKIP=3
C
C         SET -/+  = $\mp$
C
          ELSEIF(IA(I:I).EQ.'-' .AND. IA(I+1:I+1).EQ.'+' .AND.
     1           IA(I+2:I+2).EQ.'(' .AND. IA(I+3:I+3).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+4
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$ mp$'
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+4
            NSKIP=3
C
C         SET SUBSCRIPT MODE = $_{
C
          ELSEIF(I.LE.IWIDTH-4.AND.
     1           (IA(I:I).EQ.'S'.OR.IA(I:I).EQ.'s') .AND.
     1           (IA(I+1:I+1).EQ.'U'.OR.IA(I+1:I+1).EQ.'u') .AND.
     1           (IA(I+2:I+2).EQ.'B'.OR.IA(I+2:I+2).EQ.'b') .AND.
     1           IA(I+3:I+3).EQ.'(' .AND. IA(I+4:I+4).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+2
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$_{'
            IWIDT2=IWIDT2+2
            ISUBFL=ISUBFL+1
            NSKIP=4
C
C         SET SUPERSCRIPT MODE = $^{
C
          ELSEIF(I.LE.IWIDTH-4.AND.
     1           (IA(I:I).EQ.'S'.OR.IA(I:I).EQ.'s') .AND.
     1           (IA(I+1:I+1).EQ.'U'.OR.IA(I+1:I+1).EQ.'u') .AND.
     1           (IA(I+2:I+2).EQ.'P'.OR.IA(I+2:I+2).EQ.'p') .AND.
     1           IA(I+3:I+3).EQ.'(' .AND. IA(I+4:I+4).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+2
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$^{'
            IWIDT2=IWIDT2+2
            ISUPFL=ISUPFL+1
            NSKIP=4
C
C         SET GREEK ETA = $\eta$
C
          ELSEIF(I.LE.IWIDTH-4.AND.
     1           (IA(I:I).EQ.'E'.OR.IA(I:I).EQ.'e') .AND.
     1           (IA(I+1:I+1).EQ.'T'.OR.IA(I+1:I+1).EQ.'t') .AND.
     1           (IA(I+2:I+2).EQ.'A'.OR.IA(I+2:I+2).EQ.'a') .AND.
     1           IA(I+3:I+3).EQ.'(' .AND. IA(I+4:I+4).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+5
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$ eta$'
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+5
            NSKIP=4
C
C         SET GREEK RHO = $\rho$
C
          ELSEIF(I.LE.IWIDTH-4.AND.
     1           (IA(I:I).EQ.'R'.OR.IA(I:I).EQ.'r') .AND.
     1           (IA(I+1:I+1).EQ.'H'.OR.IA(I+1:I+1).EQ.'h') .AND.
     1           (IA(I+2:I+2).EQ.'O'.OR.IA(I+2:I+2).EQ.'o') .AND.
     1           IA(I+3:I+3).EQ.'(' .AND. IA(I+4:I+4).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+5
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$ rho$'
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+5
            NSKIP=4
C
C         SET GREEK TAU = $\tau$
C
          ELSEIF(I.LE.IWIDTH-4.AND.
     1           (IA(I:I).EQ.'T'.OR.IA(I:I).EQ.'t') .AND.
     1           (IA(I+1:I+1).EQ.'A'.OR.IA(I+1:I+1).EQ.'a') .AND.
     1           (IA(I+2:I+2).EQ.'U'.OR.IA(I+2:I+2).EQ.'u') .AND.
     1           IA(I+3:I+3).EQ.'(' .AND. IA(I+4:I+4).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+5
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$ tau$'
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+5
            NSKIP=4
C
C         SET GREEK PHI = $\phi$ or $\Ph$}
C
          ELSEIF(I.LE.IWIDTH-4.AND.
     1           (IA(I:I).EQ.'P'.OR.IA(I:I).EQ.'p') .AND.
     1           (IA(I+1:I+1).EQ.'H'.OR.IA(I+1:I+1).EQ.'h') .AND.
     1           (IA(I+2:I+2).EQ.'I'.OR.IA(I+2:I+2).EQ.'i') .AND.
     1           IA(I+3:I+3).EQ.'(' .AND. IA(I+4:I+4).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+5
            IF(NLAST.GT.MAXWID)GOTO8010
            IF(ICASFL.EQ.'UPPE')THEN
              IB(IWIDT2:NLAST)='$ Phi$'
            ELSE
              IB(IWIDT2:NLAST)='$ phi$'
            ENDIF
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+5
            NSKIP=4
C
C         SET GREEK CHI = $\chi$
C
          ELSEIF(I.LE.IWIDTH-4.AND.
     1           (IA(I:I).EQ.'P'.OR.IA(I:I).EQ.'p') .AND.
     1           (IA(I+1:I+1).EQ.'H'.OR.IA(I+1:I+1).EQ.'h') .AND.
     1           (IA(I+2:I+2).EQ.'I'.OR.IA(I+2:I+2).EQ.'i') .AND.
     1           IA(I+3:I+3).EQ.'(' .AND. IA(I+4:I+4).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+5
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$ chi$'
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+5
            NSKIP=4
C
C         SET GREEK PSI = $\psi$ or $\Psi$
C
          ELSEIF(I.LE.IWIDTH-4.AND.
     1           (IA(I:I).EQ.'P'.OR.IA(I:I).EQ.'p') .AND.
     1           (IA(I+1:I+1).EQ.'S'.OR.IA(I+1:I+1).EQ.'s') .AND.
     1           (IA(I+2:I+2).EQ.'I'.OR.IA(I+2:I+2).EQ.'i') .AND.
     1           IA(I+3:I+3).EQ.'(' .AND. IA(I+4:I+4).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+5
            IF(NLAST.GT.MAXWID)GOTO8010
            IF(ICASFL.EQ.'UPPE')THEN
              IB(IWIDT2:NLAST)='$ Psi$'
            ELSE
              IB(IWIDT2:NLAST)='$ psi$'
            ENDIF
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+5
            NSKIP=4
C
C         SET VECTOR PRODUCT = I DON'T KNOW IF THERE IS A LATEX
C                              EQUIVALENT
C
CCCCC     ELSEIF((IA(I:I).EQ.'D'.OR.IA(I:I).EQ.'d') .AND.
CCCCC1           (IA(I+1:I+1).EQ.'E'.OR.IA(I+1:I+1).EQ.'e') .AND.
CCCCC1           (IA(I+2:I+2).EQ.'L'.OR.IA(I+2:I+2).EQ.'l') .AND.
CCCCC1           IA(I+3:I+3).EQ.'(' .AND. IA(I+4:I+4).EQ.')')THEN
CCCCC       IWIDT2=IWIDT2+1
CCCCC       NLAST=IWIDT2+5
CCCCC       IF(NLAST.GT.MAXWID)GOTO8010
CCCCC       IB(IWIDT2:NLAST)='$ chi$'
CCCCC       IB(IWIDT2+1:IWIDT2+1)=IBASLC
CCCCC       IWIDT2=IWIDT2+5
CCCCC       NSKIP=4
C
C         SET UNSUBSCRIPT MODE = }$
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'U'.OR.IA(I:I).EQ.'u') .AND.
     1           (IA(I+1:I+1).EQ.'N'.OR.IA(I+1:I+1).EQ.'n') .AND.
     1           (IA(I+2:I+2).EQ.'S'.OR.IA(I+2:I+2).EQ.'s') .AND.
     1           (IA(I+3:I+3).EQ.'B'.OR.IA(I+3:I+3).EQ.'b') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+1
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='}$'
            IWIDT2=IWIDT2+1
            ISUBFL=ISUBFL-1
            NSKIP=5
C
C         SET UNSUPERSCRIPT MODE = }$
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'U'.OR.IA(I:I).EQ.'u') .AND.
     1           (IA(I+1:I+1).EQ.'N'.OR.IA(I+1:I+1).EQ.'n') .AND.
     1           (IA(I+2:I+2).EQ.'S'.OR.IA(I+2:I+2).EQ.'s') .AND.
     1           (IA(I+3:I+3).EQ.'P'.OR.IA(I+3:I+3).EQ.'p') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+1
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='}$'
            IWIDT2=IWIDT2+1
            ISUPFL=ISUPFL-1
            NSKIP=5
C
C         SET GREEK ALPHA = $\alpha$
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'A'.OR.IA(I:I).EQ.'a') .AND.
     1           (IA(I+1:I+1).EQ.'L'.OR.IA(I+1:I+1).EQ.'l') .AND.
     1           (IA(I+2:I+2).EQ.'P'.OR.IA(I+2:I+2).EQ.'p') .AND.
     1           (IA(I+3:I+3).EQ.'H'.OR.IA(I+3:I+3).EQ.'h') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+7
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$ alpha$'
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+7
            NSKIP=5
C
C         SET GREEK BETA = $\beta$
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'B'.OR.IA(I:I).EQ.'b') .AND.
     1           (IA(I+1:I+1).EQ.'E'.OR.IA(I+1:I+1).EQ.'e') .AND.
     1           (IA(I+2:I+2).EQ.'T'.OR.IA(I+2:I+2).EQ.'t') .AND.
     1           (IA(I+3:I+3).EQ.'A'.OR.IA(I+3:I+3).EQ.'a') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+6
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$ beta$'
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+6
            NSKIP=5
C
C         SET GREEK GAMMA = $\gamma$ or $\Gamma$
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'G'.OR.IA(I:I).EQ.'g') .AND.
     1           (IA(I+1:I+1).EQ.'A'.OR.IA(I+1:I+1).EQ.'a') .AND.
     1           (IA(I+2:I+2).EQ.'M'.OR.IA(I+2:I+2).EQ.'m') .AND.
     1           (IA(I+3:I+3).EQ.'M'.OR.IA(I+3:I+3).EQ.'m') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+7
            IF(NLAST.GT.MAXWID)GOTO8010
            IF(ICASFL.EQ.'UPPE')THEN
              IB(IWIDT2:NLAST)='$ Gamma$'
            ELSE
              IB(IWIDT2:NLAST)='$ gamma$'
            ENDIF
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+7
            NSKIP=5
C
C         SET GREEK DELTA = $\delta$ or $\Delta$
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'D'.OR.IA(I:I).EQ.'d') .AND.
     1           (IA(I+1:I+1).EQ.'E'.OR.IA(I+1:I+1).EQ.'e') .AND.
     1           (IA(I+2:I+2).EQ.'L'.OR.IA(I+2:I+2).EQ.'l') .AND.
     1           (IA(I+3:I+3).EQ.'T'.OR.IA(I+3:I+3).EQ.'t') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+7
            IF(NLAST.GT.MAXWID)GOTO8010
            IF(ICASFL.EQ.'UPPE')THEN
              IB(IWIDT2:NLAST)='$ Delta$'
            ELSE
              IB(IWIDT2:NLAST)='$ delta$'
            ENDIF
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+7
            NSKIP=5
C
C         SET GREEK EPSILON = $\epsilon$
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'E'.OR.IA(I:I).EQ.'e') .AND.
     1           (IA(I+1:I+1).EQ.'P'.OR.IA(I+1:I+1).EQ.'p') .AND.
     1           (IA(I+2:I+2).EQ.'S'.OR.IA(I+2:I+2).EQ.'s') .AND.
     1           (IA(I+3:I+3).EQ.'I'.OR.IA(I+3:I+3).EQ.'i') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+9
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$ epsilon$'
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+9
            NSKIP=5
C
C         SET GREEK ZETA = $\zeta$
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'Z'.OR.IA(I:I).EQ.'z') .AND.
     1           (IA(I+1:I+1).EQ.'E'.OR.IA(I+1:I+1).EQ.'e') .AND.
     1           (IA(I+2:I+2).EQ.'T'.OR.IA(I+2:I+2).EQ.'t') .AND.
     1           (IA(I+3:I+3).EQ.'A'.OR.IA(I+3:I+3).EQ.'a') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+6
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$ zeta$'
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+6
            NSKIP=5
C
C         SET GREEK THETA = $\theta$ or $\Theta$
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'T'.OR.IA(I:I).EQ.'t') .AND.
     1           (IA(I+1:I+1).EQ.'H'.OR.IA(I+1:I+1).EQ.'h') .AND.
     1           (IA(I+2:I+2).EQ.'E'.OR.IA(I+2:I+2).EQ.'e') .AND.
     1           (IA(I+3:I+3).EQ.'T'.OR.IA(I+3:I+3).EQ.'t') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+7
            IF(NLAST.GT.MAXWID)GOTO8010
            IF(ICASFL.EQ.'UPPE')THEN
              IB(IWIDT2:NLAST)='$ Theta$'
            ELSE
              IB(IWIDT2:NLAST)='$ theta$'
            ENDIF
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+7
            NSKIP=5
C
C         SET GREEK IOTA = $\iota$
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'I'.OR.IA(I:I).EQ.'i') .AND.
     1           (IA(I+1:I+1).EQ.'O'.OR.IA(I+1:I+1).EQ.'o') .AND.
     1           (IA(I+2:I+2).EQ.'T'.OR.IA(I+2:I+2).EQ.'t') .AND.
     1           (IA(I+3:I+3).EQ.'A'.OR.IA(I+3:I+3).EQ.'a') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+6
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$ iota$'
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+6
            NSKIP=5
C
C         SET GREEK KAPPA = $\kappa$
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'K'.OR.IA(I:I).EQ.'k') .AND.
     1           (IA(I+1:I+1).EQ.'A'.OR.IA(I+1:I+1).EQ.'a') .AND.
     1           (IA(I+2:I+2).EQ.'P'.OR.IA(I+2:I+2).EQ.'p') .AND.
     1           (IA(I+3:I+3).EQ.'P'.OR.IA(I+3:I+3).EQ.'p') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+7
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$ kappa$'
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+7
            NSKIP=5
C
C         SET GREEK LAMBDA = $\lambda$ or $\Lambda$
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'L'.OR.IA(I:I).EQ.'l') .AND.
     1           (IA(I+1:I+1).EQ.'A'.OR.IA(I+1:I+1).EQ.'a') .AND.
     1           (IA(I+2:I+2).EQ.'M'.OR.IA(I+2:I+2).EQ.'m') .AND.
     1           (IA(I+3:I+3).EQ.'B'.OR.IA(I+3:I+3).EQ.'b') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+8
            IF(NLAST.GT.MAXWID)GOTO8010
            IF(ICASFL.EQ.'UPPE')THEN
              IB(IWIDT2:NLAST)='$ Lambda$'
            ELSE
              IB(IWIDT2:NLAST)='$ lambda$'
            ENDIF
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+8
            NSKIP=5
C
C         SET GREEK OMICON = $\omicon$
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'O'.OR.IA(I:I).EQ.'o') .AND.
     1           (IA(I+1:I+1).EQ.'M'.OR.IA(I+1:I+1).EQ.'m') .AND.
     1           (IA(I+2:I+2).EQ.'I'.OR.IA(I+2:I+2).EQ.'i') .AND.
     1           (IA(I+3:I+3).EQ.'C'.OR.IA(I+3:I+3).EQ.'c') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+8
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$ omicon$'
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+8
            NSKIP=5
C
C         SET GREEK SIGMA = $\sigma$ or $\Sigma$
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'S'.OR.IA(I:I).EQ.'s') .AND.
     1           (IA(I+1:I+1).EQ.'I'.OR.IA(I+1:I+1).EQ.'i') .AND.
     1           (IA(I+2:I+2).EQ.'G'.OR.IA(I+2:I+2).EQ.'g') .AND.
     1           (IA(I+3:I+3).EQ.'M'.OR.IA(I+3:I+3).EQ.'m') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+7
            IF(NLAST.GT.MAXWID)GOTO8010
            IF(ICASFL.EQ.'UPPE')THEN
              IB(IWIDT2:NLAST)='$ Sigma$'
            ELSE
              IB(IWIDT2:NLAST)='$ sigma$'
            ENDIF
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+7
            NSKIP=5
C
C         SET GREEK UPSILON = $\upsilon$ or $\Upsilon$
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'U'.OR.IA(I:I).EQ.'u') .AND.
     1           (IA(I+1:I+1).EQ.'P'.OR.IA(I+1:I+1).EQ.'p') .AND.
     1           (IA(I+2:I+2).EQ.'S'.OR.IA(I+2:I+2).EQ.'s') .AND.
     1           (IA(I+3:I+3).EQ.'I'.OR.IA(I+3:I+3).EQ.'i') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+10
            IF(NLAST.GT.MAXWID)GOTO8010
            IF(ICASFL.EQ.'UPPE')THEN
              IB(IWIDT2:NLAST)='$ Upsilon$'
            ELSE
              IB(IWIDT2:NLAST)='$ upsilon$'
            ENDIF
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+10
            NSKIP=5
C
C         SET GREEK OMEGA = $\omega$ or $\Omega$
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'O'.OR.IA(I:I).EQ.'o') .AND.
     1           (IA(I+1:I+1).EQ.'M'.OR.IA(I+1:I+1).EQ.'m') .AND.
     1           (IA(I+2:I+2).EQ.'E'.OR.IA(I+2:I+2).EQ.'e') .AND.
     1           (IA(I+3:I+3).EQ.'G'.OR.IA(I+3:I+3).EQ.'g') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+7
            IF(NLAST.GT.MAXWID)GOTO8010
            IF(ICASFL.EQ.'UPPE')THEN
              IB(IWIDT2:NLAST)='$ Omega$'
            ELSE
              IB(IWIDT2:NLAST)='$ omega$'
            ENDIF
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+7
            NSKIP=5
C
C         SET PARTIAL DERIVATIVE = $\partial$
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'P'.OR.IA(I:I).EQ.'p') .AND.
     1           (IA(I+1:I+1).EQ.'A'.OR.IA(I+1:I+1).EQ.'a') .AND.
     1           (IA(I+2:I+2).EQ.'R'.OR.IA(I+2:I+2).EQ.'r') .AND.
     1           (IA(I+3:I+3).EQ.'T'.OR.IA(I+3:I+3).EQ.'t') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+9
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$ partial$'
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+9
            NSKIP=5
C
C         SET INTEGRAL = $\int$
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'I'.OR.IA(I:I).EQ.'i') .AND.
     1           (IA(I+1:I+1).EQ.'N'.OR.IA(I+1:I+1).EQ.'n') .AND.
     1           (IA(I+2:I+2).EQ.'T'.OR.IA(I+2:I+2).EQ.'t') .AND.
     1           (IA(I+3:I+3).EQ.'E'.OR.IA(I+3:I+3).EQ.'e') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+5
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$ int$'
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+5
            NSKIP=5
C
C         SET CIRCULAR INTEGRAL = $\oint$
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'C'.OR.IA(I:I).EQ.'c') .AND.
     1           (IA(I+1:I+1).EQ.'I'.OR.IA(I+1:I+1).EQ.'i') .AND.
     1           (IA(I+2:I+2).EQ.'N'.OR.IA(I+2:I+2).EQ.'n') .AND.
     1           (IA(I+3:I+3).EQ.'T'.OR.IA(I+3:I+3).EQ.'t') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+6
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$ oint$'
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+6
            NSKIP=5
C
C         SET SUMMATION = $\sum$
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'S'.OR.IA(I:I).EQ.'s') .AND.
     1           (IA(I+1:I+1).EQ.'U'.OR.IA(I+1:I+1).EQ.'u') .AND.
     1           (IA(I+2:I+2).EQ.'M'.OR.IA(I+2:I+2).EQ.'m') .AND.
     1           (IA(I+3:I+3).EQ.'M'.OR.IA(I+3:I+3).EQ.'m') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+5
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$ sum$'
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+5
            NSKIP=5
C
C         SET PRODUCT = $\prod$
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'P'.OR.IA(I:I).EQ.'p') .AND.
     1           (IA(I+1:I+1).EQ.'R'.OR.IA(I+1:I+1).EQ.'r') .AND.
     1           (IA(I+2:I+2).EQ.'O'.OR.IA(I+2:I+2).EQ.'o') .AND.
     1           (IA(I+3:I+3).EQ.'D'.OR.IA(I+3:I+3).EQ.'d') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+6
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$ prod$'
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+6
            NSKIP=5
C
C         SET INFINITY = $\infty$
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'I'.OR.IA(I:I).EQ.'i') .AND.
     1           (IA(I+1:I+1).EQ.'N'.OR.IA(I+1:I+1).EQ.'n') .AND.
     1           (IA(I+2:I+2).EQ.'F'.OR.IA(I+2:I+2).EQ.'f') .AND.
     1           (IA(I+3:I+3).EQ.'I'.OR.IA(I+3:I+3).EQ.'i') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+7
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$ infty$'
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+7
            NSKIP=5
C
C         SET TIMES = $\times$
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'T'.OR.IA(I:I).EQ.'t') .AND.
     1           (IA(I+1:I+1).EQ.'I'.OR.IA(I+1:I+1).EQ.'i') .AND.
     1           (IA(I+2:I+2).EQ.'M'.OR.IA(I+2:I+2).EQ.'m') .AND.
     1           (IA(I+3:I+3).EQ.'E'.OR.IA(I+3:I+3).EQ.'e') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+7
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$ times$'
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+7
            NSKIP=5
C
C         SET DOT PRODUCT = $\cdot$
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'D'.OR.IA(I:I).EQ.'d') .AND.
     1           (IA(I+1:I+1).EQ.'O'.OR.IA(I+1:I+1).EQ.'o') .AND.
     1           (IA(I+2:I+2).EQ.'T'.OR.IA(I+2:I+2).EQ.'t') .AND.
     1           (IA(I+3:I+3).EQ.'P'.OR.IA(I+3:I+3).EQ.'p') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+6
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$ cdot$'
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+6
            NSKIP=5
C
C         SET DIVISION = $\div$
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'D'.OR.IA(I:I).EQ.'d') .AND.
     1           (IA(I+1:I+1).EQ.'I'.OR.IA(I+1:I+1).EQ.'i') .AND.
     1           (IA(I+2:I+2).EQ.'V'.OR.IA(I+2:I+2).EQ.'v') .AND.
     1           (IA(I+3:I+3).EQ.'I'.OR.IA(I+3:I+3).EQ.'i') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+5
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$ div$'
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+5
            NSKIP=5
C
C         SET LESS THAN OR EQUAL TO = $\le$
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'L'.OR.IA(I:I).EQ.'l') .AND.
     1           (IA(I+1:I+1).EQ.'T'.OR.IA(I+1:I+1).EQ.'t') .AND.
     1           (IA(I+2:I+2).EQ.'E'.OR.IA(I+2:I+2).EQ.'e') .AND.
     1           (IA(I+3:I+3).EQ.'Q'.OR.IA(I+3:I+3).EQ.'q') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+4
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$ le$'
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+4
            NSKIP=5
C
C         SET GREATER THAN OR EQUAL TO = $\ge$
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'G'.OR.IA(I:I).EQ.'g') .AND.
     1           (IA(I+1:I+1).EQ.'T'.OR.IA(I+1:I+1).EQ.'t') .AND.
     1           (IA(I+2:I+2).EQ.'E'.OR.IA(I+2:I+2).EQ.'e') .AND.
     1           (IA(I+3:I+3).EQ.'Q'.OR.IA(I+3:I+3).EQ.'q') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+4
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$ ge$'
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+4
            NSKIP=5
C
C         SET GREATER THAN OR EQUAL TO = $\ge$
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'G'.OR.IA(I:I).EQ.'g') .AND.
     1           (IA(I+1:I+1).EQ.'T'.OR.IA(I+1:I+1).EQ.'t') .AND.
     1           (IA(I+2:I+2).EQ.'E'.OR.IA(I+2:I+2).EQ.'e') .AND.
     1           (IA(I+3:I+3).EQ.'Q'.OR.IA(I+3:I+3).EQ.'q') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+4
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$ ge$'
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+4
            NSKIP=5
C
C         SET NOT EQUAL TO = $\ne$
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'N'.OR.IA(I:I).EQ.'n') .AND.
     1           (IA(I+1:I+1).EQ.'O'.OR.IA(I+1:I+1).EQ.'o') .AND.
     1           (IA(I+2:I+2).EQ.'T'.OR.IA(I+2:I+2).EQ.'t') .AND.
     1           (IA(I+3:I+3).EQ.'='.OR.IA(I+3:I+3).EQ.'=') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+4
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$ ne$'
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+4
            NSKIP=5
C
C         SET APPROXIMATELY = $\approx$
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'A'.OR.IA(I:I).EQ.'a') .AND.
     1           (IA(I+1:I+1).EQ.'P'.OR.IA(I+1:I+1).EQ.'p') .AND.
     1           (IA(I+2:I+2).EQ.'P'.OR.IA(I+2:I+2).EQ.'p') .AND.
     1           (IA(I+3:I+3).EQ.'R'.OR.IA(I+3:I+3).EQ.'r') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+8
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$ approx$'
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+8
            NSKIP=5
C
C         SET EQUIVALENCE = $\equiv$
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'E'.OR.IA(I:I).EQ.'e') .AND.
     1           (IA(I+1:I+1).EQ.'Q'.OR.IA(I+1:I+1).EQ.'q') .AND.
     1           (IA(I+2:I+2).EQ.'U'.OR.IA(I+2:I+2).EQ.'u') .AND.
     1           (IA(I+3:I+3).EQ.'I'.OR.IA(I+3:I+3).EQ.'i') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+7
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$ equiv$'
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+7
            NSKIP=5
C
C         SET VARIES = I DON'T KNOW HOW TO DO THIS ONE
C
CCCCC     ELSEIF((IA(I:I).EQ.'E'.OR.IA(I:I).EQ.'e') .AND.
CCCCC1           (IA(I+1:I+1).EQ.'Q'.OR.IA(I+1:I+1).EQ.'q') .AND.
CCCCC1           (IA(I+2:I+2).EQ.'U'.OR.IA(I+2:I+2).EQ.'u') .AND.
CCCCC1           (IA(I+3:I+3).EQ.'I'.OR.IA(I+3:I+3).EQ.'i') .AND.
CCCCC1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
CCCCC       IWIDT2=IWIDT2+1
CCCCC       NLAST=IWIDT2+7
CCCCC       IF(NLAST.GT.MAXWID)GOTO8010
CCCCC       IB(IWIDT2:NLAST)='$ equiv$'
CCCCC       IB(IWIDT2+1:IWIDT2+1)=IBASLC
CCCCC       IWIDT2=IWIDT2+7
CCCCC       NSKIP=5
C
C         SET TILDE = ~
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'T'.OR.IA(I:I).EQ.'t') .AND.
     1           (IA(I+1:I+1).EQ.'I'.OR.IA(I+1:I+1).EQ.'i') .AND.
     1           (IA(I+2:I+2).EQ.'L'.OR.IA(I+2:I+2).EQ.'l') .AND.
     1           (IA(I+3:I+3).EQ.'D'.OR.IA(I+3:I+3).EQ.'d') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='~'
            NSKIP=5
C
C         SET CARAT = ^
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'C'.OR.IA(I:I).EQ.'c') .AND.
     1           (IA(I+1:I+1).EQ.'A'.OR.IA(I+1:I+1).EQ.'a') .AND.
     1           (IA(I+2:I+2).EQ.'R'.OR.IA(I+2:I+2).EQ.'r') .AND.
     1           (IA(I+3:I+3).EQ.'A'.OR.IA(I+3:I+3).EQ.'a') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='^'
            NSKIP=5
C
C         SET RADICAL = $\sqrt$
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'R'.OR.IA(I:I).EQ.'r') .AND.
     1           (IA(I+1:I+1).EQ.'A'.OR.IA(I+1:I+1).EQ.'a') .AND.
     1           (IA(I+2:I+2).EQ.'D'.OR.IA(I+2:I+2).EQ.'d') .AND.
     1           (IA(I+3:I+3).EQ.'I'.OR.IA(I+3:I+3).EQ.'i') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+6
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$ sqrt$'
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+6
            NSKIP=5
C
C         SET LARGE RADICAL = $\sqrt$
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'L'.OR.IA(I:I).EQ.'l') .AND.
     1           (IA(I+1:I+1).EQ.'R'.OR.IA(I+1:I+1).EQ.'r') .AND.
     1           (IA(I+2:I+2).EQ.'A'.OR.IA(I+2:I+2).EQ.'a') .AND.
     1           (IA(I+3:I+3).EQ.'D'.OR.IA(I+3:I+3).EQ.'d') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+6
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$ sqrt$'
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+6
            NSKIP=5
C
C         SET SUBSET = $\subset$
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'S'.OR.IA(I:I).EQ.'s') .AND.
     1           (IA(I+1:I+1).EQ.'U'.OR.IA(I+1:I+1).EQ.'u') .AND.
     1           (IA(I+2:I+2).EQ.'B'.OR.IA(I+2:I+2).EQ.'b') .AND.
     1           (IA(I+3:I+3).EQ.'S'.OR.IA(I+3:I+3).EQ.'s') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+8
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$ subset$'
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+8
            NSKIP=5
C
C         SET SUPERSET = $\supset$
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'S'.OR.IA(I:I).EQ.'s') .AND.
     1           (IA(I+1:I+1).EQ.'U'.OR.IA(I+1:I+1).EQ.'u') .AND.
     1           (IA(I+2:I+2).EQ.'P'.OR.IA(I+2:I+2).EQ.'p') .AND.
     1           (IA(I+3:I+3).EQ.'E'.OR.IA(I+3:I+3).EQ.'e') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+8
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$ supset$'
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+8
            NSKIP=5
C
C         SET UNION = $\cup$
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'U'.OR.IA(I:I).EQ.'u') .AND.
     1           (IA(I+1:I+1).EQ.'N'.OR.IA(I+1:I+1).EQ.'n') .AND.
     1           (IA(I+2:I+2).EQ.'I'.OR.IA(I+2:I+2).EQ.'i') .AND.
     1           (IA(I+3:I+3).EQ.'O'.OR.IA(I+3:I+3).EQ.'o') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+5
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$ cup$'
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+5
            NSKIP=5
C
C         SET INTERSECTION = $\cap$
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'I'.OR.IA(I:I).EQ.'i') .AND.
     1           (IA(I+1:I+1).EQ.'N'.OR.IA(I+1:I+1).EQ.'n') .AND.
     1           (IA(I+2:I+2).EQ.'T'.OR.IA(I+2:I+2).EQ.'t') .AND.
     1           (IA(I+3:I+3).EQ.'R'.OR.IA(I+3:I+3).EQ.'r') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+5
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$ cap$'
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+5
            NSKIP=5
C
C         SET IS AN ELEMENT OF = $\in$
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'E'.OR.IA(I:I).EQ.'e') .AND.
     1           (IA(I+1:I+1).EQ.'L'.OR.IA(I+1:I+1).EQ.'l') .AND.
     1           (IA(I+2:I+2).EQ.'E'.OR.IA(I+2:I+2).EQ.'e') .AND.
     1           (IA(I+3:I+3).EQ.'M'.OR.IA(I+3:I+3).EQ.'m') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+4
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$ in$'
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+4
            NSKIP=5
C
C         SET THERE EXISTS = $\exists$
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'T'.OR.IA(I:I).EQ.'t') .AND.
     1           (IA(I+1:I+1).EQ.'H'.OR.IA(I+1:I+1).EQ.'h') .AND.
     1           (IA(I+2:I+2).EQ.'E'.OR.IA(I+2:I+2).EQ.'e') .AND.
     1           (IA(I+3:I+3).EQ.'X'.OR.IA(I+3:I+3).EQ.'x') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+8
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$ exists$'
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+8
            NSKIP=5
C
C         SET THEREFORE = I DON'T KNOW WHAT THIS SHOULD BE
C
CCCCC     ELSEIF((IA(I:I).EQ.'T'.OR.IA(I:I).EQ.'t') .AND.
CCCCC1           (IA(I+1:I+1).EQ.'H'.OR.IA(I+1:I+1).EQ.'h') .AND.
CCCCC1           (IA(I+2:I+2).EQ.'E'.OR.IA(I+2:I+2).EQ.'e') .AND.
CCCCC1           (IA(I+3:I+3).EQ.'X'.OR.IA(I+3:I+3).EQ.'x') .AND.
CCCCC1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
CCCCC       IWIDT2=IWIDT2+1
CCCCC       NLAST=IWIDT2+8
CCCCC       IF(NLAST.GT.MAXWID)GOTO8010
CCCCC       IB(IWIDT2:NLAST)='$ exists$'
CCCCC       IB(IWIDT2+1:IWIDT2+1)=IBASLC
CCCCC       IWIDT2=IWIDT2+8
CCCCC       NSKIP=5
C
C         SET LEFT APOSTROPHE = `
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'L'.OR.IA(I:I).EQ.'l') .AND.
     1           (IA(I+1:I+1).EQ.'A'.OR.IA(I+1:I+1).EQ.'a') .AND.
     1           (IA(I+2:I+2).EQ.'P'.OR.IA(I+2:I+2).EQ.'p') .AND.
     1           (IA(I+3:I+3).EQ.'O'.OR.IA(I+3:I+3).EQ.'o') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='`'
            NSKIP=5
C
C         SET RIGHT APOSTROPHE = '
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'R'.OR.IA(I:I).EQ.'r') .AND.
     1           (IA(I+1:I+1).EQ.'A'.OR.IA(I+1:I+1).EQ.'a') .AND.
     1           (IA(I+2:I+2).EQ.'P'.OR.IA(I+2:I+2).EQ.'p') .AND.
     1           (IA(I+3:I+3).EQ.'O'.OR.IA(I+3:I+3).EQ.'o') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)="`"
            NSKIP=5
C
C         SET LEFT BRACKET = [
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'L'.OR.IA(I:I).EQ.'l') .AND.
     1           (IA(I+1:I+1).EQ.'B'.OR.IA(I+1:I+1).EQ.'b') .AND.
     1           (IA(I+2:I+2).EQ.'R'.OR.IA(I+2:I+2).EQ.'r') .AND.
     1           (IA(I+3:I+3).EQ.'A'.OR.IA(I+3:I+3).EQ.'a') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='['
            NSKIP=5
C
C         SET LEFT CURLY BRACKET = {
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'L'.OR.IA(I:I).EQ.'l') .AND.
     1           (IA(I+1:I+1).EQ.'C'.OR.IA(I+1:I+1).EQ.'c') .AND.
     1           (IA(I+2:I+2).EQ.'B'.OR.IA(I+2:I+2).EQ.'b') .AND.
     1           (IA(I+3:I+3).EQ.'R'.OR.IA(I+3:I+3).EQ.'r') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='{'
            NSKIP=5
C
C         SET RIGHT CURLY BRACKET = }
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'R'.OR.IA(I:I).EQ.'r') .AND.
     1           (IA(I+1:I+1).EQ.'C'.OR.IA(I+1:I+1).EQ.'c') .AND.
     1           (IA(I+2:I+2).EQ.'B'.OR.IA(I+2:I+2).EQ.'b') .AND.
     1           (IA(I+3:I+3).EQ.'R'.OR.IA(I+3:I+3).EQ.'r') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='}'
            NSKIP=5
C
C         SET RIGHT BRACKET = ]
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'R'.OR.IA(I:I).EQ.'r') .AND.
     1           (IA(I+1:I+1).EQ.'B'.OR.IA(I+1:I+1).EQ.'b') .AND.
     1           (IA(I+2:I+2).EQ.'R'.OR.IA(I+2:I+2).EQ.'r') .AND.
     1           (IA(I+3:I+3).EQ.'A'.OR.IA(I+3:I+3).EQ.'a') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)=']'
            NSKIP=5
C
C         SET LEFT ELBOW = I DON'T KNOW HOW TO DO THIS ONE
C
CCCCC     ELSEIF((IA(I:I).EQ.'L'.OR.IA(I:I).EQ.'l') .AND.
CCCCC1           (IA(I+1:I+1).EQ.'E'.OR.IA(I+1:I+1).EQ.'e') .AND.
CCCCC1           (IA(I+2:I+2).EQ.'L'.OR.IA(I+2:I+2).EQ.'l') .AND.
CCCCC1           (IA(I+3:I+3).EQ.'B'.OR.IA(I+3:I+3).EQ.'b') .AND.
CCCCC1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
CCCCC       IWIDT2=IWIDT2+1
CCCCC       NLAST=IWIDT2+8
CCCCC       IF(NLAST.GT.MAXWID)GOTO8010
CCCCC       IB(IWIDT2:NLAST)='$ exists$'
CCCCC       IB(IWIDT2+1:IWIDT2+1)=IBASLC
CCCCC       IWIDT2=IWIDT2+8
CCCCC       NSKIP=5
C
C         SET RIGHT ELBOW = I DON'T KNOW HOW TO DO THIS ONE
C
CCCCC     ELSEIF((IA(I:I).EQ.'R'.OR.IA(I:I).EQ.'r') .AND.
CCCCC1           (IA(I+1:I+1).EQ.'E'.OR.IA(I+1:I+1).EQ.'e') .AND.
CCCCC1           (IA(I+2:I+2).EQ.'L'.OR.IA(I+2:I+2).EQ.'l') .AND.
CCCCC1           (IA(I+3:I+3).EQ.'B'.OR.IA(I+3:I+3).EQ.'b') .AND.
CCCCC1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
CCCCC       IWIDT2=IWIDT2+1
CCCCC       NLAST=IWIDT2+8
CCCCC       IF(NLAST.GT.MAXWID)GOTO8010
CCCCC       IB(IWIDT2:NLAST)='$ exists$'
CCCCC       IB(IWIDT2+1:IWIDT2+1)=IBASLC
CCCCC       IWIDT2=IWIDT2+8
CCCCC       NSKIP=5
C
C         SET LEFT ACCENT = $\`$
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'L'.OR.IA(I:I).EQ.'l') .AND.
     1           (IA(I+1:I+1).EQ.'A'.OR.IA(I+1:I+1).EQ.'a') .AND.
     1           (IA(I+2:I+2).EQ.'C'.OR.IA(I+2:I+2).EQ.'c') .AND.
     1           (IA(I+3:I+3).EQ.'C'.OR.IA(I+3:I+3).EQ.'c') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+4
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$ `$'
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+4
            NSKIP=5
C
C         SET BREVE = $\vee$
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'B'.OR.IA(I:I).EQ.'b') .AND.
     1           (IA(I+1:I+1).EQ.'R'.OR.IA(I+1:I+1).EQ.'r') .AND.
     1           (IA(I+2:I+2).EQ.'E'.OR.IA(I+2:I+2).EQ.'e') .AND.
     1           (IA(I+3:I+3).EQ.'V'.OR.IA(I+3:I+3).EQ.'v') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+5
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$ vee$'
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+5
            NSKIP=5
C
C         SET LEFT QUOTE = "
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'L'.OR.IA(I:I).EQ.'l') .AND.
     1           (IA(I+1:I+1).EQ.'Q'.OR.IA(I+1:I+1).EQ.'q') .AND.
     1           (IA(I+2:I+2).EQ.'U'.OR.IA(I+2:I+2).EQ.'u') .AND.
     1           (IA(I+3:I+3).EQ.'O'.OR.IA(I+3:I+3).EQ.'o') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='"'
            NSKIP=5
C
C         SET RIGHT QUOTE = "
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'R'.OR.IA(I:I).EQ.'r') .AND.
     1           (IA(I+1:I+1).EQ.'Q'.OR.IA(I+1:I+1).EQ.'q') .AND.
     1           (IA(I+2:I+2).EQ.'U'.OR.IA(I+2:I+2).EQ.'u') .AND.
     1           (IA(I+3:I+3).EQ.'O'.OR.IA(I+3:I+3).EQ.'o') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='"'
            NSKIP=5
C
C         SET RIGHT ARROW = $\rightarrow$
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'R'.OR.IA(I:I).EQ.'r') .AND.
     1           (IA(I+1:I+1).EQ.'A'.OR.IA(I+1:I+1).EQ.'a') .AND.
     1           (IA(I+2:I+2).EQ.'R'.OR.IA(I+2:I+2).EQ.'r') .AND.
     1           (IA(I+3:I+3).EQ.'R'.OR.IA(I+3:I+3).EQ.'r') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+12
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$ rightarrow$'
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+12
            NSKIP=5
C
C         SET LEFT ARROW = $\leftarrow$
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'L'.OR.IA(I:I).EQ.'l') .AND.
     1           (IA(I+1:I+1).EQ.'A'.OR.IA(I+1:I+1).EQ.'a') .AND.
     1           (IA(I+2:I+2).EQ.'R'.OR.IA(I+2:I+2).EQ.'r') .AND.
     1           (IA(I+3:I+3).EQ.'R'.OR.IA(I+3:I+3).EQ.'r') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+11
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$ leftarrow$'
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+11
            NSKIP=5
C
C         SET DOWN ARROW = $\downarrow$
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'D'.OR.IA(I:I).EQ.'d') .AND.
     1           (IA(I+1:I+1).EQ.'A'.OR.IA(I+1:I+1).EQ.'a') .AND.
     1           (IA(I+2:I+2).EQ.'R'.OR.IA(I+2:I+2).EQ.'r') .AND.
     1           (IA(I+3:I+3).EQ.'R'.OR.IA(I+3:I+3).EQ.'r') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+11
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$ downarrow$'
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+11
            NSKIP=5
C
C         SET UP ARROW = $\uparrow$
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'U'.OR.IA(I:I).EQ.'u') .AND.
     1           (IA(I+1:I+1).EQ.'A'.OR.IA(I+1:I+1).EQ.'a') .AND.
     1           (IA(I+2:I+2).EQ.'R'.OR.IA(I+2:I+2).EQ.'r') .AND.
     1           (IA(I+3:I+3).EQ.'R'.OR.IA(I+3:I+3).EQ.'r') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+9
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$ uparrow$'
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+9
            NSKIP=5
C
C         SET PARAGRAP = NOT SURE ABOUT THIS ONE
C
CCCCC     ELSEIF((IA(I:I).EQ.'U'.OR.IA(I:I).EQ.'u') .AND.
CCCCC1           (IA(I+1:I+1).EQ.'A'.OR.IA(I+1:I+1).EQ.'a') .AND.
CCCCC1           (IA(I+2:I+2).EQ.'R'.OR.IA(I+2:I+2).EQ.'r') .AND.
CCCCC1           (IA(I+3:I+3).EQ.'R'.OR.IA(I+3:I+3).EQ.'r') .AND.
CCCCC1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
CCCCC       IWIDT2=IWIDT2+1
CCCCC       NLAST=IWIDT2+9
CCCCC       IF(NLAST.GT.MAXWID)GOTO8010
CCCCC       IB(IWIDT2:NLAST)='$ uparrow$'
CCCCC       IB(IWIDT2+1:IWIDT2+1)=IBASLC
CCCCC       IWIDT2=IWIDT2+9
CCCCC       NSKIP=5
C
C         SET DAGGER = $\dagger$
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'D'.OR.IA(I:I).EQ.'d') .AND.
     1           (IA(I+1:I+1).EQ.'A'.OR.IA(I+1:I+1).EQ.'a') .AND.
     1           (IA(I+2:I+2).EQ.'G'.OR.IA(I+2:I+2).EQ.'g') .AND.
     1           (IA(I+3:I+3).EQ.'G'.OR.IA(I+3:I+3).EQ.'g') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+8
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$ dagger$'
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+8
            NSKIP=5
C
C         SET DOUBLE DAGGER = $\ddagger$
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'D'.OR.IA(I:I).EQ.'d') .AND.
     1           (IA(I+1:I+1).EQ.'D'.OR.IA(I+1:I+1).EQ.'d') .AND.
     1           (IA(I+2:I+2).EQ.'A'.OR.IA(I+2:I+2).EQ.'a') .AND.
     1           (IA(I+3:I+3).EQ.'G'.OR.IA(I+3:I+3).EQ.'g') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+9
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$ ddagger$'
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+9
            NSKIP=5
C
C         SET VERTICAL BAR = $\mid$
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'V'.OR.IA(I:I).EQ.'v') .AND.
     1           (IA(I+1:I+1).EQ.'B'.OR.IA(I+1:I+1).EQ.'b') .AND.
     1           (IA(I+2:I+2).EQ.'A'.OR.IA(I+2:I+2).EQ.'a') .AND.
     1           (IA(I+3:I+3).EQ.'R'.OR.IA(I+3:I+3).EQ.'r') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+5
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$ mid$'
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+5
            NSKIP=5
C
C         SET LONG VERTICAL BAR = $\mid$
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'L'.OR.IA(I:I).EQ.'l') .AND.
     1           (IA(I+1:I+1).EQ.'V'.OR.IA(I+1:I+1).EQ.'v') .AND.
     1           (IA(I+2:I+2).EQ.'B'.OR.IA(I+2:I+2).EQ.'b') .AND.
     1           (IA(I+3:I+3).EQ.'A'.OR.IA(I+3:I+3).EQ.'a') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+5
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$ mid$'
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+5
            NSKIP=5
C
C         SET HORIZONTAL BAR = DON'T KNOW HOW TO DO THIS ONE
C
CCCCC     ELSEIF((IA(I:I).EQ.'H'.OR.IA(I:I).EQ.'h') .AND.
CCCCC1           (IA(I+1:I+1).EQ.'B'.OR.IA(I+1:I+1).EQ.'b') .AND.
CCCCC1           (IA(I+2:I+2).EQ.'A'.OR.IA(I+2:I+2).EQ.'a') .AND.
CCCCC1           (IA(I+3:I+3).EQ.'R'.OR.IA(I+3:I+3).EQ.'r') .AND.
CCCCC1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
CCCCC       IWIDT2=IWIDT2+1
CCCCC       NLAST=IWIDT2+5
CCCCC       IF(NLAST.GT.MAXWID)GOTO8010
CCCCC       IB(IWIDT2:NLAST)='$ mid$'
CCCCC       IB(IWIDT2+1:IWIDT2+1)=IBASLC
CCCCC       IWIDT2=IWIDT2+5
CCCCC       NSKIP=5
C
C         SET LONG HORIZONTAL BAR = DON'T KNOW HOW TO DO THIS ONE
C
CCCCC     ELSEIF((IA(I:I).EQ.'L'.OR.IA(I:I).EQ.'l') .AND.
CCCCC1           (IA(I+1:I+1).EQ.'H'.OR.IA(I+1:I+1).EQ.'h') .AND.
CCCCC1           (IA(I+2:I+2).EQ.'B'.OR.IA(I+2:I+2).EQ.'b') .AND.
CCCCC1           (IA(I+3:I+3).EQ.'A'.OR.IA(I+3:I+3).EQ.'a') .AND.
CCCCC1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
CCCCC       IWIDT2=IWIDT2+1
CCCCC       NLAST=IWIDT2+5
CCCCC       IF(NLAST.GT.MAXWID)GOTO8010
CCCCC       IB(IWIDT2:NLAST)='$ mid$'
CCCCC       IB(IWIDT2+1:IWIDT2+1)=IBASLC
CCCCC       IWIDT2=IWIDT2+5
CCCCC       NSKIP=5
C
C         SET DEGREE = $\deg$
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'D'.OR.IA(I:I).EQ.'d') .AND.
     1           (IA(I+1:I+1).EQ.'E'.OR.IA(I+1:I+1).EQ.'e') .AND.
     1           (IA(I+2:I+2).EQ.'G'.OR.IA(I+2:I+2).EQ.'g') .AND.
     1           (IA(I+3:I+3).EQ.'R'.OR.IA(I+3:I+3).EQ.'r') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+5
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$ deg$'
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+5
            NSKIP=5
          ELSE
            IWIDT2=IWIDT2+1
            IB(IWIDT2:IWIDT2)=IA(I:I)
          ENDIF
  100   CONTINUE
      ELSE
        DO190I=1,IWIDTH
          IWIDT2=IWIDT2+1
          IB(IWIDT2:IWIDT2)=IA(I:I)
  190   CONTINUE
        GOTO9000
      ENDIF
C
      ISTRT=IWIDTH-2
      ISTRT=ISTRT+NSKIP
      IF(ISTRT.LE.IWIDTH)THEN
        DO200I=ISTRT,IWIDTH
          IWIDT2=IWIDT2+1
          IB(IWIDT2:IWIDT2)=IA(I:I)
  200   CONTINUE
      ENDIF
C
      IF(ISUBFL.GT.0)THEN
        DO300I=1,ISUBFL
          IWIDT2=IWIDT2+1
          IB(IWIDT2:IWIDT2+1)='}$'
          IWIDT2=IWIDT2+1
  300   CONTINUE
      ENDIF
C
      IF(ISUPFL.GT.0)THEN
        DO400I=1,ISUPFL
          IWIDT2=IWIDT2+1
          IB(IWIDT2:IWIDT2+1)='}$'
          IWIDT2=IWIDT2+1
  400   CONTINUE
      ENDIF
C
      GOTO9000
C
 8010 CONTINUE
      WRITE(ICOUT,8011)
 8011 FORMAT('***** ERROR IN CONVERTING DATAPLOT SPECIAL ',
     1       'CHARACTERS TO EQUIVALENT LATEX--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,8013)
 8013 FORMAT('      MAXIMUM NUMBER OF CHARACTERS, ',I5,',',
     1       'IN LATEX STRING EXCEEDED.')
      CALL DPWRST('XXX','BUG ')
      GOTO9000
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(ISUBRO.EQ.'ON')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END       OF LATCON--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9012)IWIDTH,ISUBRO,IERROR
 9012   FORMAT('IWIDTH,ISUBRO,IERROR = ',I8,2X,A4,2X,A4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9014)(IB(I:I),I=1,MIN(100,IWIDT2))
 9014   FORMAT('(IB(I:I),I=1,IWIDT2) = ',100A1)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      RETURN
      END
      SUBROUTINE LDECDF(X,ALPHA,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE LOG DOUBLE EXPONENTIAL
C              (LAPLACE) DISTRIBUTION.
C              THIS DISTRIBUTION IS DEFINED FOR ALL POSITIVE X AND
C              HAS THE CUMULATIVE DISTRIBUTION FUNCTION
C              F(X) = 0.5*X**ALPHA           0 < X < 1
C                   = 1.0 - 0.5*X**ALPHA     X >= 1
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C                     --ALPHA  = THE SINLE PRECISION SHAPE PARAMETER
C     OUTPUT ARGUMENTS--CDF    = THE SINGLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE CDF.
C     PRINTING--NONE.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--EXP.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN. 
C     REFERENCES--XX
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE:  301-975-2899
C     ORIGINAL VERSION--SEPTEMBER 2001. 
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DALPHA
      DOUBLE PRECISION DCDF
C
C---------------------------------------------------------------------
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     NO INPUT ARGUMENT ERRORS POSSIBLE 
C     FOR THIS DISTRIBUTION.
C
      CDF=0.0
C
      IF(X.LE.0.0)THEN
        WRITE(ICOUT,15)
   15   FORMAT('***** FATAL ERROR--THE FIRST INPUT ARGUMENT TO THE ',
     1         'LDECDF SUBROUTINE IS NON-POSITIVE *****')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
   46   FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
      IF(ALPHA.LE.0.0)THEN
        WRITE(ICOUT,25)
   25   FORMAT('***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE ',
     1         'LDECDF SUBROUTINE IS NON-POSITIVE *****')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ALPHA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
C-----START POINT-----------------------------------------------------
C
      DX=DBLE(X)
      DALPHA=DBLE(ALPHA)
C
      IF(X.LT.1.0)THEN
        DCDF=0.5D0*DX**DALPHA
      ELSE
        DCDF=1.0D0 - 0.5D0*DX**(-DALPHA)
      ENDIF
      CDF=REAL(DCDF)
C
 9000 CONTINUE
      RETURN
      END 
      SUBROUTINE LDEPDF(X,ALPHA,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE LOG DOUBLE EXPONENTIAL
C              (LAPLACE) DISTRIBUTION.
C              THIS DISTRIBUTION IS DEFINED FOR ALL POSITIVE X AND
C              HAS THE PROBABILITY DENSITY FUNCTION
C              F(X) = (ALPHA/2)*X**(ALPHA-1)   0 < X < 1
C                   = (ALPHA/2)*X**(-ALPHA-1)   X>= 1
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                     --ALPHA  = THE SINLE PRECISION SHAPE PARAMETER
C     OUTPUT ARGUMENTS--PDF    = THE SINGLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE PDF.
C     PRINTING--NONE.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--EXP, LOG.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN. 
C     REFERENCES--XX
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899
C                 PHONE:  301-975-2899
C     ORIGINAL VERSION--SEPTEMBER 2001. 
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DALPHA
      DOUBLE PRECISION DTWO
      DOUBLE PRECISION DPDF
      DOUBLE PRECISION DTERM
C
C---------------------------------------------------------------------
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
C
      IF(X.LE.0.0)THEN
        WRITE(ICOUT,15)
   15   FORMAT('***** FATAL ERROR--THE FIRST INPUT ARGUMENT TO THE ',
     1         'LDEPDF SUBROUTINE IS NON-POSITIVE *****')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
   46   FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
      IF(ALPHA.LE.0.0)THEN
        WRITE(ICOUT,25)
   25   FORMAT('***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE ',
     1         'LDEPDF SUBROUTINE IS NON-POSITIVE *****')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ALPHA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
C-----START POINT-----------------------------------------------------
C
      DX=DBLE(X)
      DALPHA=DBLE(ALPHA)
      DTWO=DLOG(2.0D0)
C
      IF(X.LT.1.0)THEN
        DTERM=DLOG(DALPHA) - DTWO + (DALPHA-1.0D0)*DLOG(DX)
        DPDF=DEXP(DTERM)
      ELSE
        DTERM=DLOG(DALPHA) - DTWO + (-DALPHA-1.0D0)*DLOG(DX)
        DPDF=DEXP(DTERM)
      ENDIF
      PDF=REAL(DPDF)
C
 9000 CONTINUE
      RETURN
      END 
      SUBROUTINE LDEPPF(P,ALPHA,PPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE LOG DOUBLE EXPONENTIAL
C              (LAPLACE) DISTRIBUTION.
C              THIS DISTRIBUTION IS DEFINED FOR ALL POSITIVE X AND
C              HAS THE PERCENT POINT FUNCTION
C              G(P) = SQRT(2*P)     
C              NOTE THAT THE PERCENT POINT FUNCTION OF A DISTRIBUTION
C              IS IDENTICALLY THE SAME AS THE INVERSE CUMULATIVE
C              DISTRIBUTION FUNCTION OF THE DISTRIBUTION.
C     INPUT  ARGUMENTS--P      = THE SINGLE PRECISION VALUE
C                                (BETWEEN 0.0 AND 1.0)
C                                AT WHICH THE PERCENT POINT
C                                FUNCTION IS TO BE EVALUATED.
C                     --ALPHA  = THE SINLE PRECISION SHAPE PARAMETER
C     OUTPUT ARGUMENTS--PPF    = THE SINGLE PRECISION PERCENT
C                                POINT FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PERCENT POINT
C             FUNCTION VALUE PPF.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--P SHOULD BE BETWEEN 0.0 AND 1.0, EXCLUSIVELY.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--ALOG.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--XX
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2899
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           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/9
C     ORIGINAL VERSION--SEPTEMBER 2001.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DOUBLE PRECISION DP
      DOUBLE PRECISION DALPHA
      DOUBLE PRECISION DPPF
C
C---------------------------------------------------------------------
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 ')
        GOTO9000
      ENDIF
    1 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ',
     1'LDEPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
      IF(ALPHA.LE.0.0)THEN
        WRITE(ICOUT,25)
   25   FORMAT('***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE ',
     1         'LDEPPF SUBROUTINE IS NON-POSITIVE *****')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ALPHA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
      AONE=1.0
      DP=DBLE(P)
      DALPHA=DBLE(ALPHA)
      CALL LDECDF(AONE,ALPHA,CDF)
C
      IF(P.LT.CDF)THEN
        DPPF=(2.0D0*DP)**(1.0D0/DALPHA)
      ELSE
        DPPF=(2.0D0*(1.0D0-DP))**(-1.0D0/DALPHA)
      ENDIF
      PPF=REAL(DPPF)
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE LDERAN(N,ALPHA,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE LOG DOUBLE EXPONENTIAL DISTRIBUTION
C              WITH TAIL LENGTH PARAMETER VALUE = ALPHA.
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --ALPHA  = THE SINGLE PRECISION VALUE OF THE
C                                TAIL LENGTH PARAMETER.
C                                ALPHA SHOULD BE POSITIVE.
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST N)
C                                INTO WHICH THE GENERATED
C                                RANDOM SAMPLE WILL BE PLACED.
C     OUTPUT--A RANDOM SAMPLE OF SIZE N
C             FROM THE LOG DOUBLE EXPONENTIAL DISTRIBUTION
C             WITH TAIL LENGTH PARAMETER VALUE = ALPHA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C                 --ALPHA SHOULD BE POSITIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--KOZUBOWSKI AND PODGORSKI, "LOG-LAPLACE
C                 DISTRIBUTIONS", PAPER DOWNLOADED FROM THEIR
C                 WEB SITE.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           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         --MARCH     2006. COMPUTE RANDOM NUMBERS
C                                       AS RATIO OF UNIFORMS
C                                       NOTE: THIS SEEMS TO GENERATE
C                                       EXCESIVELY LARGE NUMBERS, SO
C                                       REVERT BACK TO PPF ALGORITHM
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
      DIMENSION Y(2)
C
      DOUBLE PRECISION DALPHA
      DOUBLE PRECISION DY1
      DOUBLE PRECISION DY2
C
C---------------------------------------------------------------------
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(ALPHA.LE.0.0)THEN
        WRITE(ICOUT,15)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ALPHA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
    5 FORMAT('***** ERROR--THE REQUESTED NUMBER OF LOG DOUBLE ',
     1'EXPONENTIAL RANDOM NUMBERS IS NON-POSITIVE.')
   15 FORMAT('***** ERROR--THE SHAPE PARAMETER FOR THE LOG DOUBLE',
     1' EXPONENTIAL RANDOM NUMBERS IS NON-POSITIVE.')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
C
C     GENERATE N LOG DOUBLE EXPONENTIAL DISTRIBUTION RANDOM NUMBERS
C     USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD.
C
C     NOTE 3/2006: LOG DOUBLE EXPONENTIAL CAN BE REPRESENTED AS
C                  U1**(1/ALPHA)/U2**(1/ALPHA)
C
C     RUNNING SOME SIMULATIONS SEEMS TO SHOW THAT THE RATIO OF
C     UNIFORM METHOD RESULTS IN SOME EXCESSIVELY LARGE RANDOM
C     NUMBERS.
C
      IALG=0
      IF(IALG.EQ.0)THEN
        CALL UNIRAN(N,ISEED,X)
        DO100I=1,N
          CALL LDEPPF(X(I),ALPHA,XTEMP)
          X(I)=XTEMP
  100   CONTINUE
      ELSE
        NTEMP=2
        DALPHA=DBLE(ALPHA)
        DO200I=1,N
          CALL UNIRAN(NTEMP,ISEED,Y)
          DY1=DBLE(Y(1))
          DY2=DBLE(Y(2))
          X(I)=REAL(DY1**(1.0D0/DALPHA)/DY2**(1.0D0/DALPHA))
  200   CONTINUE
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE LEGNDR(X,AN,PN)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE LEGENDRE
C              POLYNOMIAL OF ORDER N.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION INPUT ARGUMENT
C                       AN     = THE SINGLE PRECISION VALUE FOR THE
C                                ORDER OF THE FUNCTION (SHOULD BE
C                                NON-NEGATIVE ORDER)
C     OUTPUT ARGUMENTS--PN    = THE SINGLE PRECISION VALUE OF THE
C                                LEGENDRE POLYNOMIAL.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 
C     RESTRICTIONS--
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE
C     MODE OF INTERNAL OPERATIONS--SOME DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN. 
C     REFERENCES--"HANDBOOK OF MATHEMATICAL FUNCTIONS, AMS 55", 
C                 ABRAMOWITZ AND STEGUM.
C                 USE FOLLOWING RECURRENCE FORMULA:
C                    P(N+1) = X*P(N)+(N/N+1)*(X*P(N)-P(N-1))
C                 FIRST FEW TERMS ARE FROM TABLE 22.9 OF ABRAMOWITZ
C                 AND STEGUM.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE:  301-975-2855
C     ORIGINAL VERSION--JULY       1995. 
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
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
      DOUBLE PRECISION DX
      DOUBLE PRECISION DN
      DOUBLE PRECISION DPN, DPN1, DPN2
C
C-----START POINT-----------------------------------------------------
C
CCCCC IF(X.LT.-1.0.OR.X.GT.1.0)THEN
CCCCC   WRITE(ICOUT,4)
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   WRITE(ICOUT,46)X
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   GOTO9999
CCCCC ENDIF
CCCC4 FORMAT('***** NON-FATAL DIAGNOSTIC--THE 1ST INPUT ARGUMENT ',
CCCCC1'TO THE LEGNDR SUBROUTINE IS OUTSIDE THE (-1,1) INTERVAL *****')
CCC46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
      N=INT(AN+0.5)
      IF(N.LT.0)THEN
        WRITE(ICOUT,6)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
    6 FORMAT('***** NON-FATAL DIAGNOSTIC--THE 2ND INPUT ARGUMENT ',
     1'TO THE LEGNDR SUBROUTINE IS NEGATIVE *****')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
C
      DX=DBLE(X)
      DN=DBLE(N)
C
      IF(N.LE.0)THEN
        PN=1.0
      ELSEIF(N.EQ.1)THEN
        PN=X
      ELSEIF(N.EQ.2)THEN
        PN=1.5*X**2-0.5
      ELSEIF(N.EQ.3)THEN
        DPN=2.5D0*DX**3-1.5D0*DX
        PN=REAL(DPN)
      ELSE
        DPN1=2.5D0*DX**3-1.5D0*DX
        DPN2=1.5D0*DX**2-0.5D0
        DO1000I=4,N
          DN=DBLE(I)-1.0D0
          DPN=DX*DPN1+(DN/(DN+1.0D0))*(DX*DPN1-DPN2)
          DPN2=DPN1
          DPN1=DPN
 1000   CONTINUE
        PN=REAL(DPN)
      ENDIF
C
 9999 CONTINUE
      RETURN
      END 
      SUBROUTINE LG1FUN (NPAR, XPAR, FVEC, IFLAG, XDATA, R)
C
C     PURPOSE--THIS ROUTINE COMPUTES THE FUNCTIONS FOR THE
C              LOGNORMAL MAXIMUM LIKELIHOOD EQUATIONS FOR THE
C              SINGLY TIME CENSORED CASE (FROM PP. 161-162 OF BURY).
C
C      SUM[i=1 to r][Z(I)] + M*H(Z(I)) = 0
C
C      SUM[i=1 to r][Z(I)**2] + M*Z*H(Z) - R = 0
C
C      WHERE
C
C
C         R        = NUMBER OF FAILURES
C         M        = NUMBER OF CENSORING TIMES
C         C        = CENSORING TIME (ALL CENSORED DATA WILL HAVE
C                    THE SAME CENSORING TIME)
C         Z(I)     = [LOG(X(I) - UHAT]/SHAT
C         UHAT     = FVEC(1) = CURRENT ESTIMATE OF MU PARAMETER
C         SHAT     = FVEC(2) = CURRENT ESTIMATE OF SIGMA PARAMETER
C         Z        = [LOG(C) - UHAT]/SHAT
C         H(Z)     = NORPDF(Z)/(1 - NOCDF(Z))
C
C              CALLED BY DNSQE ROUTINE FOR SOLVING SIMULTANEOUS
C              NONLINEAR EQUATIONS.  NOTE THAT THE CALLING SEQUENCE
C              DID NOT ACCOMODATE A DATA ARRAY (AND ASSCIATED NUMBER OF
C              OBSERVATIONS), SO THESE WERE ADDED TO THE CALL LIST.
C     EXAMPLE--LOGNORMAL MAXIMUM LIKELIHOOD Y X
C     REFERENCE--KARL BURY, (1999). "STATISTICAL DISTRIBUTIONS IN
C                ENGINEERING", CAMBRIDGE UNIVERSITY PRESS,
C                PP. 161-162.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           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 R
      DOUBLE PRECISION XPAR(*)
      DOUBLE PRECISION FVEC(*)
      REAL XDATA(*)
C
      DOUBLE PRECISION DN
      DOUBLE PRECISION DR
      DOUBLE PRECISION DM
      DOUBLE PRECISION DZ
      DOUBLE PRECISION DH
      DOUBLE PRECISION DX
      DOUBLE PRECISION UHAT
      DOUBLE PRECISION SHAT
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DSUM2
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
C
      DOUBLE PRECISION C
      INTEGER N
      INTEGER M
      COMMON/LG1COM/C,N,M
C
C---------------------------------------------------------------------
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)
      DM=DBLE(M)
      UHAT=XPAR(1)
      SHAT=XPAR(2)
      DZ=(DLOG(C)-UHAT)/SHAT
      CALL NODPDF(DZ,DTERM1)
      CALL NODCDF(DZ,DTERM2)
      DH=DTERM1/(1.0D0 - DTERM2)
C
      DTERM1=DM*DH
      DTERM2=DTERM1*DZ - DR
      DSUM1=0.0D0
      DSUM2=0.0D0
C
      IF(R.GT.0)THEN
        DO100I=1,R
          DX=DBLE(XDATA(I))
          DX=(DLOG(DX) - UHAT)/SHAT
          DSUM1=DSUM1 + DX
          DSUM2=DSUM2 + DX*DX
  100   CONTINUE
      ENDIF
C
      FVEC(1) = DTERM1 + DSUM1
      FVEC(2) = DTERM2 + DSUM2
C
      RETURN
      END
      DOUBLE PRECISION FUNCTION LG2FUN (DU,DX)
C
C     PURPOSE--THIS ROUTINE IS USED IN FINDING THE LIKELIHOOD RATIO
C              BASED CONFIDENCE INTERVAL FOR THE MU (=LOG(SCALE)
C              PARAMETER OF A 2-PARAMETER LOGNORMAL MODEL
C              (SINGLY TIME CENSORED SAMPLE).  THE FOLLOWING
C              EQUATION NEEDS TO BE SOLVED.
C
C                 2*LL(UHAT,SHAT) - 2*LL(U,S(U)) - CHSPPF(alpha,1)
C
C              WITH
C
C                 LL(UHAT,SHAT) = -R*LOG(SHAT) -
C                                 SUM[i=1 tp r][LOG(X(I))] -
C                                 0.5*SUM[i=1 to r]
C                                 [((LOG(X(I)) - UHAT)/SHAT)**2] +
C                                 DM*LOG(1 - NORCDF(
C
C              LL(UHAT,SHAT) IS COMPUTED ONCE BY THE CALLING ROUTINE
C              AND PASSED VIA COMMON BLOCK.
C
C              THEN GIVEN THE CURRENT GUESS FOR U, WE NEED TO
C              SOLVE THE FOLLOWING EQUATION FOR S:
C
C                 SUM[i=1 to r][{(LOG(X(I)-U)/S}**2] +
C                 M*(LOG(C)-U)/S)*H(Z) - R
C
C              WITH
C
C                 Z    = (LOG(X(I))-U)/S
C                 HZ   = NORPDF(Z)/(1-NORCDF(Z))
C
C              WE THEN COMPUTE LL(UHAT,SHAT) WITH THESE U AND S(U)
C              VALUES.
C
C     EXAMPLE--LOGNORMAL MAXIMUM LIKELIHOOD Y X
C     REFERENCE--KARL BURY, "STATISTICAL DISTRIBUTIONS IN ENGINEERING",
C                CAMBRIDGE UNIVERSITY PRESS, 1999, CHAPTER 11 (SEE
C                EXAMPLE 11.5).
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBUG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           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 DU
      DOUBLE PRECISION DX(*)
C
      INTEGER N
      INTEGER IR
      INTEGER IM
      DOUBLE PRECISION DLLUS
      DOUBLE PRECISION DC
      DOUBLE PRECISION DK
      DOUBLE PRECISION DSIGMA
      COMMON/LG2COM/DLLUS,DC,DK,DSIGMA,N,IR,IM
C
      INTEGER N2
      INTEGER IR2
      INTEGER IM2
      DOUBLE PRECISION DU2
      DOUBLE PRECISION DC2
      COMMON/LG3COM/DU2,DC2,N2,IR2,IM2
C
      EXTERNAL LG3FUN
C
      DOUBLE PRECISION AE
      DOUBLE PRECISION RE
      DOUBLE PRECISION XLOW
      DOUBLE PRECISION XUP
      DOUBLE PRECISION XSTRT
      DOUBLE PRECISION DS
      DOUBLE PRECISION DN
      DOUBLE PRECISION DR
      DOUBLE PRECISION DM
      DOUBLE PRECISION DZ
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DSUM2
C
C---------------------------------------------------------------------
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
      IR2=IR
      IM2=IM
      DC2=DC
      DU2=DU
C
      AE=1.D-7
      RE=1.D-7
      XSTRT=DSIGMA
      XLOW=XSTRT/5.0D0
      XUP=XSTRT*5.0D0
      CALL DFZER3(LG3FUN,XLOW,XUP,XSTRT,RE,AE,IFLAG,DX)
      DS=XLOW
C
C  COMPUTE LL(S,G)
C
      DN=DBLE(N)
      DR=DBLE(IR)
      DM=DBLE(IM)
C
      DZ=(DLOG(DC) - DU)/DS
      CALL NODCDF(DZ,DTERM2)
      DTERM1=-DR*DLOG(DS) + DM*DLOG(1.0D0 - DTERM2)
      DSUM1=0.0D0
      DSUM2=0.0D0
      DO100I=1,IR
        DZ=DLOG(DX(I))
        DSUM1=DSUM1 + DZ
        DSUM2=DSUM2 + ((DZ - DU)/DS)**2
  100 CONTINUE
      DTERM2=DTERM1 - DSUM1 - 0.5D0*DSUM2
C
      LG2FUN=2.0*DLLUS - 2.0D0*DTERM2 - DK
C
      RETURN
      END
      DOUBLE PRECISION FUNCTION LG3FUN (DS,DX)
C
C     PURPOSE--THIS ROUTINE IS USED IN FINDING THE LIKELIHOOD RATIO
C              BASED CONFIDENCE INTERVAL FOR THE MU (=LOG(SCALE)
C              PARAMETER OF A 2-PARAMETER LOGNORMAL MODEL
C              (SINGLY TIME CENSORED SAMPLE).  IT IS CALLED BY
C              LG2FUN TO SOLVE THE EQUATION
C
C                 SUM[i=1 to r][{(LOG(X(I)-U)/S}**2] +
C                 M*(LOG(C)-U)/S)*H(Z) - R
C
C              WITH
C
C                 Z    = (LOG(X(I))-U)/S
C                 HZ   = NORPDF(Z)/(1-NORCDF(Z))
C
C              WE ARE GIVEN THE VALUE OF U AND WE NEED TO SOLVE FOR S.
C
C     EXAMPLE--LOGNORMAL MAXIMUM LIKELIHOOD Y X
C     REFERENCE--KARL BURY, "STATISTICAL DISTRIBUTIONS IN ENGINEERING",
C                CAMBRIDGE UNIVERSITY PRESS, 1999, CHAPTER 11 (SEE
C                EXAMPLE 11.5).
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBUG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           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 DS
      DOUBLE PRECISION DX(*)
C
      INTEGER N
      INTEGER IR
      INTEGER IM
      DOUBLE PRECISION DU
      DOUBLE PRECISION DC
      COMMON/LG3COM/DU,DC,N,IR,IM
C
      DOUBLE PRECISION DN
      DOUBLE PRECISION DR
      DOUBLE PRECISION DM
      DOUBLE PRECISION DZ
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
      DOUBLE PRECISION DSUM1
C
C---------------------------------------------------------------------
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(IR)
      DM=DBLE(IM)
C
      DTERM1=(DLOG(DC)-DU)/DS
      CALL NODPDF(DTERM1,DTERM2)
      CALL NODCDF(DTERM1,DTERM3)
C
      DSUM1=0.0D0
      DO100I=1,IR
        DZ=DX(I)
        DZ=(DLOG(DZ) - DU)/DS
        DSUM1=DSUM1 + DZ*DZ
  100 CONTINUE
C
      LG3FUN=DSUM1 + DM*DTERM1*DTERM2/(1.0D0-DTERM3) - DR
C
      RETURN
      END
      DOUBLE PRECISION FUNCTION LG4FUN (DSIGMA,DX)
C
C     PURPOSE--THIS ROUTINE IS USED IN FINDING THE LIKELIHOOD RATIO
C              BASED CONFIDENCE INTERVAL FOR THE SIGMA
C              PARAMETER OF A 2-PARAMETER LOGNORMAL MODEL
C              (SINGLY TIME CENSORED SAMPLE).  THE FOLLOWING
C              EQUATION NEEDS TO BE SOLVED.
C
C                 2*LL(UHAT,SHAT) - 2*LL(G(S),S) - CHSPPF(alpha,1)
C
C              WITH
C
C                 LL(UHAT,SHAT) = -R*LOG(SHAT) -
C                                 SUM[i=1 tp r][LOG(X(I))] -
C                                 0.5*SUM[i=1 to r]
C                                 [((LOG(X(I)) - UHAT)/SHAT)**2] +
C                                 DM*LOG(1 - NORCDF(
C
C              LL(UHAT,SHAT) IS COMPUTED ONCE BY THE CALLING ROUTINE
C              AND PASSED VIA COMMON BLOCK.
C
C              THEN GIVEN THE CURRENT GUESS FOR SIGMA, WE NEED TO
C              SOLVE THE FOLLOWING EQUATION FOR U:
C
C                 SUM[i=1 to r][(LOG(X(I)-U)/S] + M*H(Z)
C
C              WITH
C
C                 Z    = (LOG(X(I))-U)/S
C                 HZ   = NORPDF(Z)/(1-NORCDF(Z))
C
C              WE THEN COMPUTE LL(UHAT,SHAT) WITH THESE G(S) AND S
C              VALUES.
C
C     EXAMPLE--LOGNORMAL MAXIMUM LIKELIHOOD Y X
C     REFERENCE--KARL BURY, "STATISTICAL DISTRIBUTIONS IN ENGINEERING",
C                CAMBRIDGE UNIVERSITY PRESS, 1999, CHAPTER 11 (SEE
C                EXAMPLE 11.5).
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBUG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           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 DSIGMA
      DOUBLE PRECISION DX(*)
C
      INTEGER N
      INTEGER IR
      INTEGER IM
      DOUBLE PRECISION DLLUS
      DOUBLE PRECISION DC
      DOUBLE PRECISION DK
      DOUBLE PRECISION DU
      COMMON/LG4COM/DLLUS,DC,DK,DU,N,IR,IM
C
      INTEGER N2
      INTEGER IR2
      INTEGER IM2
      DOUBLE PRECISION DS2
      DOUBLE PRECISION DC2
      COMMON/LG5COM/DS2,DC2,N2,IR2,IM2
C
      EXTERNAL LG5FUN
C
      DOUBLE PRECISION AE
      DOUBLE PRECISION RE
      DOUBLE PRECISION XLOW
      DOUBLE PRECISION XUP
      DOUBLE PRECISION XSTRT
      DOUBLE PRECISION DS
      DOUBLE PRECISION DN
      DOUBLE PRECISION DR
      DOUBLE PRECISION DM
      DOUBLE PRECISION DZ
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DSUM2
C
C---------------------------------------------------------------------
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 SHAPE PARAMETER (DSIGMA), NEED TO COMPUTE
C          THE SCALE PARAMETER (WHICH IN TURN INVOLVES FINDING A
C          ROOT).

      N2=N
      IR2=IR
      IM2=IM
      DC2=DC
      DS2=DSIGMA
C
      AE=1.D-7
      RE=1.D-7
      XSTRT=DU
      XLOW=XSTRT/5.0D0
      XUP=XSTRT*5.0D0
      CALL DFZER3(LG5FUN,XLOW,XUP,XSTRT,RE,AE,IFLAG,DX)
      DU=XLOW
      DS=DSIGMA
C
C  COMPUTE LL(S,G)
C
      DN=DBLE(N)
      DR=DBLE(IR)
      DM=DBLE(IM)
C
      DZ=(DLOG(DC) - DU)/DS
      CALL NODCDF(DZ,DTERM2)
      DTERM1=-DR*DLOG(DS) + DM*DLOG(1.0D0 - DTERM2)
      DSUM1=0.0D0
      DSUM2=0.0D0
      DO100I=1,IR
        DZ=DLOG(DX(I))
        DSUM1=DSUM1 + DZ
        DSUM2=DSUM2 + ((DZ - DU)/DS)**2
  100 CONTINUE
      DTERM2=DTERM1 - DSUM1 - 0.5D0*DSUM2
C
      LG4FUN=2.0*DLLUS - 2.0D0*DTERM2 - DK
C
      RETURN
      END
      DOUBLE PRECISION FUNCTION LG5FUN (DU,DX)
C
C     PURPOSE--THIS ROUTINE IS USED IN FINDING THE LIKELIHOOD RATIO
C              BASED CONFIDENCE INTERVAL FOR THE SHAPE PARAMETER,
C              SIGMA, OF A 2-PARAMETER LOGNORMAL MODEL
C              (SINGLY TIME CENSORED SAMPLE).  IT IS CALLED BY
C              LG4FUN TO SOLVE THE EQUATION
C
C                 SUM[i=1 to r][{(LOG(X(I)-U)/S}**2] + M*H(Z)
C
C              WITH
C
C                 Z    = (LOG(X(I))-U)/S
C                 HZ   = NORPDF(Z)/(1-NORCDF(Z))
C
C              WE ARE GIVEN THE VALUE OF U AND WE NEED TO SOLVE FOR S.
C
C     EXAMPLE--LOGNORMAL MAXIMUM LIKELIHOOD Y X
C     REFERENCE--KARL BURY, "STATISTICAL DISTRIBUTIONS IN ENGINEERING",
C                CAMBRIDGE UNIVERSITY PRESS, 1999, CHAPTER 11 (SEE
C                EXAMPLE 11.5).
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBUG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           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 DU
      DOUBLE PRECISION DX(*)
C
      INTEGER N
      INTEGER IR
      INTEGER IM
      DOUBLE PRECISION DS
      DOUBLE PRECISION DC
      COMMON/LG5COM/DS,DC,N,IR,IM
C
      DOUBLE PRECISION DN
      DOUBLE PRECISION DR
      DOUBLE PRECISION DM
      DOUBLE PRECISION DZ
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
      DOUBLE PRECISION DSUM1
C
C---------------------------------------------------------------------
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(IR)
      DM=DBLE(IM)
C
      DTERM1=(DLOG(DC)-DU)/DS
      CALL NODPDF(DTERM1,DTERM2)
      CALL NODCDF(DTERM1,DTERM3)
C
      DSUM1=0.0D0
      DO100I=1,IR
        DZ=DX(I)
        DZ=(DLOG(DZ) - DU)/DS
        DSUM1=DSUM1 + DZ
  100 CONTINUE
C
      LG5FUN=DSUM1 + DM*DTERM2/(1.0D0-DTERM3)
C
      RETURN
      END
      DOUBLE PRECISION FUNCTION LG6FUN (DXQ,DX)
C
C     PURPOSE--THIS ROUTINE IS USED IN FINDING THE LIKELIHOOD RATIO
C              BASED CONFIDENCE INTERVAL FOR A GIVEN PERCENTILE
C              OF A 2-PARAMETER LOGNORMAL MODEL
C              (SINGLY TIME CENSORED SAMPLE).  THE FOLLOWING
C              EQUATION NEEDS TO BE SOLVED.
C
C                 2*LL(UHAT,SHAT) - 2*LL(g(xq),s(xq)) - CHSPPF(alpha,1)
C
C              WITH
C
C                 LL(UHAT,SHAT) = -R*LOG(SHAT) -
C                                 SUM[i=1 tp r][LOG(X(I))] -
C                                 0.5*SUM[i=1 to r]
C                                 [((LOG(X(I)) - UHAT)/SHAT)**2] +
C                                 DM*LOG(1 - NORCDF(
C
C              LL(UHAT,SHAT) IS COMPUTED ONCE BY THE CALLING ROUTINE
C              AND PASSED VIA COMMON BLOCK.
C
C              THEN GIVEN THE CURRENT MAXIMUM LIKELIHOOD ESTIMATE OF
C              SIGMA, WE NEED TO SOLVE THE FOLLOWING EQUATION FOR
C              XQ:
C
C
C                 (1/B**2)*SUM[i=1 to r]
C                 [{(LOG(X(I)/X05} + B*Z05]*LOG(X(I)/X05) +
C                 (M/B)*(LOG(C)/X05)*H(Z) - R
C
C              WITH
C
C                 Z05  = NORPPF(1 - ALPHA/2)
C                 X05  = LGNPPF(P) (P IS THE DESIRED PERCENTILE)
C                 Z    = LOG(C/XQ)/B + Z05
C                 HZ   = NORPDF(Z)/(1-NORCDF(Z))
C
C              WE ARE GIVEN THE VALUE OF B (= MAXIMUM LIKELIHOOD
C              ESTIMATE OF SIGMA) AND WE NEED TO SOLVE FOR XQ.
C              WE THEN COMPUTE LL(UHAT,SHAT) WITH THESE U AND S(U)
C              VALUES.
C
C     EXAMPLE--LOGNORMAL MAXIMUM LIKELIHOOD Y X
C     REFERENCE--KARL BURY, "STATISTICAL DISTRIBUTIONS IN ENGINEERING",
C                CAMBRIDGE UNIVERSITY PRESS, 1999, CHAPTER 11 (SEE
C                EXAMPLE 11.5).
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBUG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           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 DXQ
      DOUBLE PRECISION DX(*)
C
      INTEGER N
      INTEGER IR
      INTEGER IM
      DOUBLE PRECISION DLLUS
      DOUBLE PRECISION DC
      DOUBLE PRECISION DK
      DOUBLE PRECISION DSIGMA
      DOUBLE PRECISION DU
      DOUBLE PRECISION DX05
      DOUBLE PRECISION DZ05
      DOUBLE PRECISION SEXQP
      COMMON/LG6COM/DLLUS,DC,DK,DSIGMA,DU,DX05,DZ05,SEXQP,N,IR,IM
C
      INTEGER N2
      INTEGER IR2
      INTEGER IM2
      DOUBLE PRECISION DX052
      DOUBLE PRECISION DZ052
      DOUBLE PRECISION DC2
      DOUBLE PRECISION DS2
      COMMON/LG7COM/DX052,DZ052,DC2,DS2,N2,IR2,IM2
C
      EXTERNAL LG7FUN
C
      DOUBLE PRECISION AE
      DOUBLE PRECISION RE
      DOUBLE PRECISION XLOW
      DOUBLE PRECISION XUP
      DOUBLE PRECISION XSTRT
      DOUBLE PRECISION DS
      DOUBLE PRECISION DU2
      DOUBLE PRECISION DN
      DOUBLE PRECISION DR
      DOUBLE PRECISION DM
      DOUBLE PRECISION DZ
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DSUM2
C
C---------------------------------------------------------------------
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).
C
      DX052=DX05
      DZ052=DZ05
      DC2=DC
      DS2=DSIGMA
      N2=N
      IR2=IR
      IM2=IM
      write(18,*) 'lg6fun: dxq,dx05,dz05=',dxq,dx05,dz05
C
      AE=1.D-7
      RE=1.D-7
      XSTRT=DXQ
      XLOW=XSTRT/5.0D0
      XUP=XSTRT*5.0D0
      write(18,*) 'lg6fun: xlow,xstrt,xup=',xlow,xstrt,xup
      CALL DFZER3(LG7FUN,XLOW,XUP,XSTRT,RE,AE,IFLAG,DX)
      DSXQ=XLOW
C
C  COMPUTE LL(S,G)
C
      DN=DBLE(N)
      DR=DBLE(IR)
      DM=DBLE(IM)
C
      DU2=DLOG(DXQ) - DZ05*DSXQ
      DS=DSXQ
      write(18,*)'iflag,du2,ds=',iflag,du2,ds
      DZ=(DLOG(DC) - DU2)/DS
      CALL NODCDF(DZ,DTERM2)
      DTERM1=-DR*DLOG(DS) + DM*DLOG(1.0D0 - DTERM2)
      DSUM1=0.0D0
      DSUM2=0.0D0
      DO100I=1,IR
        DZ=DLOG(DX(I))
        DSUM1=DSUM1 + DZ
        DSUM2=DSUM2 + ((DZ - DU2)/DS)**2
  100 CONTINUE
      DTERM2=DTERM1 - DSUM1 - 0.5D0*DSUM2
C
      LG6FUN=2.0*DLLUS - 2.0D0*DTERM2 - DK
      write(18,*) 'dllus,dk,dterm1,dterm2,lg6fun=',dllus,dk,dterm1,
     1            dterm2,lg6fun
C
      RETURN
      END
      DOUBLE PRECISION FUNCTION LG7FUN (DXQ,DX)
C
C     PURPOSE--THIS ROUTINE IS USED IN FINDING THE LIKELIHOOD RATIO
C              BASED CONFIDENCE INTERVAL FOR THE PERCENTILE FUNCTION
C              OF A 2-PARAMETER LOGNORMAL MODEL (SINGLY TIME CENSORED
C              SAMPLE).  IT IS CALLED BY LG6FUN TO SOLVE THE EQUATION
C
C                 (1/B**2)*SUM[i=1 to r]
C                 [{(LOG(X(I)/X05} + B*Z05]*LOG(X(I)/X05) +
C                 (M/B)*(LOG(C)/X05)*H(Z) - R
C
C              WITH
C
C                 Z05  = NORPPF(1 - ALPHA/2)
C                 X05  = LGNPPF(P) (P IS THE DESIRED PERCENTILE)
C                 Z    = LOG(C/XQ)/B + Z05
C                 HZ   = NORPDF(Z)/(1-NORCDF(Z))
C
C              WE ARE GIVEN THE VALUE OF B (= MAXIMUM LIKELIHOOD
C              ESTIMATE OF SIGMA) AND WE NEED TO SOLVE FOR XQ.
C
C              THE VALUES OF Z05 AND X05 ARE CALCULATED IN DPMLL2
C              AND STORED IN A COMMON BLOCK.
C
C     EXAMPLE--LOGNORMAL MAXIMUM LIKELIHOOD Y X
C     REFERENCE--KARL BURY, "STATISTICAL DISTRIBUTIONS IN ENGINEERING",
C                CAMBRIDGE UNIVERSITY PRESS, 1999, CHAPTER 11 (SEE
C                EXAMPLE 11.5).
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBUG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           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 DXQ
      DOUBLE PRECISION DX(*)
C
      INTEGER N
      INTEGER IR
      INTEGER IM
      DOUBLE PRECISION DX05
      DOUBLE PRECISION DZ05
      DOUBLE PRECISION DC
      DOUBLE PRECISION DS
      COMMON/LG7COM/DX05,DZ05,DC,DS,N,IR,IM
C
      DOUBLE PRECISION DN
      DOUBLE PRECISION DR
      DOUBLE PRECISION DM
      DOUBLE PRECISION DZ
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
      DOUBLE PRECISION DSUM1
C
C---------------------------------------------------------------------
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(IR)
      DM=DBLE(IM)
C
      DTERM1=(DLOG(DC/DXQ)/DS) + DZ05
      CALL NODPDF(DTERM1,DTERM2)
      CALL NODCDF(DTERM1,DTERM3)
C
      DSUM1=0.0D0
      DO100I=1,IR
        DZ=DLOG(DX(I)/DXQ)
        DSUM1=DSUM1 + (DZ + DS*DZ05)*DZ
  100 CONTINUE
C
      LG7FUN=(1.0D0/DS**2)*DSUM1 +
     1       (DM/DS)*DLOG(DC/DXQ)*DTERM2/(1.0D0-DTERM3) - DR
      write(18,*)'lg7fun=',lg7fun
C
      RETURN
      END
      SUBROUTINE LGACDF(X,GAMMA,ILGADF,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE LOG-GAMMA DISTRIBUTION
C              WITH POSITIVE SHAPE PARAMETER GAMMA
C              THIS DISTRIBUTION IS DEFINED FOR ALL REAL X.
C              THE PDF FOR THE STANDARD FORM OF THE DISTRIBUTION IS
C                  F(X,G) = EXP(G*X-EXP(X))/GAMMA(G)
C              WHERE GAMMA IS THE GAMMA FUNCTION.
C              THE CORRESPONDING CDF IS:
C                  F(X,G) = I(EXP(Y)(GAMMA)
C              WHERE I(X)(GAMMA) IS THE INCOMPLETE GAMMA FUNCTION RATIO
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE NON-NEGATIVE.
C                     --GAMMA  = A POSITIVE SHAPE PARAMETER
C     OUTPUT ARGUMENTS--CDF    = THE SINGLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE CDF FOR THE LOG GAMMA DISTRIBUTION
C             WITH SHAPE PARAMETER GAMMA
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE NON-NEGATIVE.
C                 --GAMMA SHOULD BE A POSITIVE NUMBER.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--2, 1994, PAGE 89-90.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           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/10
C     ORIGINAL VERSION--OCTOBER   1995.
C     UPDATED         --JULY      2005. SUPPORT FOR RE-PARAMETERIZED
C                                       DEFINITION THAT IS USEFUL FOR
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      CHARACTER*4 ILGADF
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DGAMMA
      DOUBLE PRECISION DCDF
      DOUBLE PRECISION DGAMIP
      DOUBLE PRECISION DTERM1
C
      EXTERNAL DGAMIP
C
C---------------------------------------------------------------------
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(GAMMA.LE.0)THEN
        WRITE(ICOUT,15)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)GAMMA
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9999
      ENDIF
   15 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO THE ',
     1'LGACDF SUBROUTINE IS NON-POSITIVE')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
      DX=DBLE(X)
      DGAMMA=DBLE(GAMMA)
C
      IF(ILGADF.EQ.'DEFA')THEN
        DCDF=DGAMIP(DGAMMA,DEXP(DX))
      ELSE
        DTERM1=DGAMMA*DEXP(DX/DSQRT(DGAMMA))
        DCDF=DGAMIP(DGAMMA,DTERM1)
      ENDIF
      CDF=REAL(DCDF)
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE LGAPDF(X,GAMMA,ILGADF,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE LOG-GAMMA DISTRIBUTION
C              WITH POSITIVE SHAPE PARAMETER GAMMA
C              THIS DISTRIBUTION IS DEFINED FOR ALL REAL X.
C              THE PDF FOR THE STANDARD FORM OF THE DISTRIBUTION IS
C                  F(X,G) = EXP(G*X-EXP(X))/GAMMA(G)
C              WHERE GAMMA IS THE GAMMA FUNCTION.
C
C              FOR FITTING PURPOSES, THE FOLLOWING REPARAMETERIZED
C              PDF IS OFTEN PREFERRED:
C                  F(X,G) = (G**(G-0.5)/GAMMA(G)*
C                           EXP(SQRT(G)*X-G*EXP(X/SQRT(G)))
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE NON-NEGATIVE.
C                     --GAMMA  = A POSITIVE SHAPE PARAMETER
C     OUTPUT ARGUMENTS--PDF    = THE SINGLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE PDF FOR THE LOG GAMMA DISTRIBUTION
C             WITH SHAPE PARAMETER GAMMA
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE NON-NEGATIVE.
C                 --GAMMA SHOULD BE A POSITIVE NUMBER.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--2, 1994, PAGE 89-90.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           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/10
C     ORIGINAL VERSION--OCTOBER   1995.
C     UPDATED         --JULY      2005. SUPPORT FOR RE-PARAMETERIZED
C                                       DEFINITION THAT IS USEFUL FOR
C                                       FITTING
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      CHARACTER*4 ILGADF
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DGAMMA
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
      DOUBLE PRECISION DPDF
      DOUBLE PRECISION DLNGAM
C
C---------------------------------------------------------------------
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(GAMMA.LE.0)THEN
        WRITE(ICOUT,15)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)GAMMA
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ENDIF
   15 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO THE ',
     1'LGAPDF SUBROUTINE IS NON-POSITIVE')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
      DX=DBLE(X)
      DGAMMA=DBLE(GAMMA)
C
      IF(ILGADF.EQ.'DEFA')THEN
        DTERM1=DGAMMA*DX - DEXP(DX)
        DTERM2=DTERM1-DLNGAM(DGAMMA)
        DPDF=0.0D0
        IF(DTERM2.GE.-80.0D0)DPDF=DEXP(DTERM2)
        PDF=REAL(DPDF)
      ELSE
        DTERM1=(DGAMMA - 0.5D0)*DLOG(DGAMMA) - DLNGAM(DGAMMA)
        DTERM2=DSQRT(DGAMMA)*DX - DGAMMA*DEXP(DX/DSQRT(DGAMMA))
        DTERM3=DTERM1 + DTERM2
        DPDF=0.0D0
        IF(DTERM3.GE.-80.0D0)DPDF=DEXP(DTERM3)
        PDF=REAL(DPDF)
      ENDIF
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE LGAPPF(P,GAMMA,ILGADF,PPF)
C
C     PURPOSE   --PERCENT POINT FUNCTION FOR THE LOG-GAMMA
C                 DISTRIBUTION.  USES A BISECTION METHOD.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           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         --JULY      2005. SUPPORT FOR RE-PARAMETERIZED
C                                       DEFINITION THAT IS USEFUL FOR
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 ILGADF
C
      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 /2000/
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(P.LE.0.0.OR.P.GE.1.0)THEN
        WRITE(ICOUT,1)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)P
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
        GOTO9999
      ENDIF
      IF(GAMMA.LE.0)THEN
        WRITE(ICOUT,15)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)GAMMA
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
        GOTO9999
      ENDIF
C
    1 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO THE ',
     1' LGAPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL.')
   15 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO THE ',
     1'LGAPPF SUBROUTINE IS NON-POSITIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
C
C  FIND BRACKETING INTERVAL.
C
      XL=-50.0
      XINC=25.0
      ICOUNT=0
      MAXCNT=10000
C
   91 CONTINUE
      XR=XL+XINC
      CALL LGACDF(XL,GAMMA,ILGADF,CDFL)
      CALL LGACDF(XR,GAMMA,ILGADF,CDFR)
      IF(CDFL.LT.P .AND. CDFR.LT.P)THEN
        XL=XR
      ELSEIF(CDFL.GT.P .AND. CDFR.GT.P)THEN
        XL=XL-XINC
      ELSE
        GOTO99
      ENDIF
      ICOUNT=ICOUNT+1
      IF(ICOUNT.GT.MAXCNT)THEN
        WRITE(ICOUT,96)
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
        GOTO9999
      ENDIF
   96 FORMAT('***** ERROR--LGAPPF UNABLE TO FIND A BRACKETING ',
     *      'INTERVAL. *****')
      GOTO91
C
C  BISECTION METHOD
C
   99 CONTINUE
      IC = 0
      FXL = -P
      FXR = 1.0 - P
  105 CONTINUE
      X = (XL+XR)*0.5
      CALL LGACDF(X,GAMMA,ILGADF,CDF)
      P1=CDF
      PPF=X
      FCS = P1 - P
      IF(FCS*FXL.GT.ZERO)GOTO110
      XR = X
      FXR = FCS 
      GOTO115
  110 CONTINUE
      XL = X
      FXL = FCS
  115 CONTINUE
      XRML = XR - XL
      IF(XRML.LE.SIG .AND. ABS(FCS).LE.EPS)GOTO9999
      IC = IC + 1
      IF(IC.LE.MAXIT)GOTO105
      WRITE(ICOUT,130)
      CALL DPWRST('XXX','BUG ')
  130 FORMAT('***** ERROR--THE LGAPPF ROUTINE DID NOT CONVERGE. ***')
      GOTO9999
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE LGARAN(N,GAMMA,ILGADF,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE LOG GAMMA DISTRIBUTION
C              WITH TAIL LENGTH PARAMETER VALUE = GAMMA.
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --GAMMA  = THE SINGLE PRECISION VALUE OF THE
C                                TAIL LENGTH PARAMETER.
C                                GAMMA SHOULD BE POSITIVE.
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST N)
C                                INTO WHICH THE GENERATED
C                                RANDOM SAMPLE WILL BE PLACED.
C     OUTPUT--A RANDOM SAMPLE OF SIZE N
C             FROM THE LOG GAMMA DISTRIBUTION
C             WITH TAIL LENGTH PARAMETER VALUE = GAMMA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C                 --GAMMA SHOULD BE POSITIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--XX
C               --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 2ND. ED., 1994.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           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.10
C     ORIGINAL VERSION--OCTOBER   2001.
C     UPDATED         --JULY      2005. SUPPORT FOR RE-PARAMETERIZED
C                                       DEFINITION THAT IS USEFUL FOR
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
C
      CHARACTER*4 ILGADF
C
C---------------------------------------------------------------------
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('***** ERROR--THE REQUESTED NUMBER OF LOG GAMMA RANDOM',
     1' NUMBERS IS NON-POSITIVE.')
   15 FORMAT('***** ERROR--THE SHAPE PARAMETER FOR LOG GAMMA RANDOM',
     1' NUMBERS IS NON-POSITIVE.')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,'.')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,'.')
C
C     GENERATE N UNIFORM (0,1) RANDOM NUMBERS;
C
      CALL UNIRAN(N,ISEED,X)
C
C     GENERATE N LOG GAMMA DISTRIBUTION RANDOM NUMBERS
C     USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD.
C
      DO100I=1,N
        CALL LGAPPF(X(I),GAMMA,ILGADF,XTEMP)
        X(I)=XTEMP
  100 CONTINUE
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE LGNAFR(X1,X2,SIGMA,ALOC,SCALE,AFR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE AVERAGE FAILURE RATE
C              (AFR) FUNCTION VALUE FOR THE LOGNORMAL DISTRIBUTION.
C              THE AFR IS DEFINED AS:
C
C              AFR(X1,X2,SHAPE,LOC,SCALE) = (H(X2,SHAPE,LOC,SCALE) -
C                                            H(X1,LOC,SCALE))/(X2-X1)
C
C              WHERE
C
C              H(X,SHAPE,LOC,SCALE) = H((X-LOC)/SCALE,SHAPE)
C
C              FOR THE LOGNORMAL, WE USE THE LGNCHA FUNCTION.
C
C     INPUT  ARGUMENTS--X1     = THE SINGLE PRECISION VALUE AT
C                                WHICH THE AFR FUNCTION IS TO BE
C                                EVALUATED.
C                     --X2     = THE SINGLE PRECISION VALUE AT
C                                WHICH THE AFR FUNCTION IS TO BE
C                                EVALUATED.
C                     --SIGMA  = THE (POSITIVE) SHAPE PARAMETER
C                     --ALOC   = THE LOCATION PARAMETER
C                     --SCALE  = THE (POSITIVE) SCALE PARAMETER
C     OUTPUT ARGUMENTS--AFR    = THE SINGLE PRECISION AVERAGE
C                                FAILURE RATE FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION AVERAGE FAILURE RATE FOR THE
C             LOGNORMAL DISTRIBUTION.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--SIGMA AND SCALE SHOULD BE POSITIVE, X2 NOT EQUAL X1.
C     OTHER DATAPAC   SUBROUTINES NEEDED--LGNCHA.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--TOBIAS AND TRINDALE, "APPLIED RELIABILITY", SECOND
C                 EDITION, CHAPMAN AND HALL/CRC, 1995.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2005.3
C     ORIGINAL VERSION--MARCH     2005.
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
      X1MN=MIN(X1,X2)
      X1MX=MAX(X1,X2)
      IF(X1MN.EQ.X1MX)THEN
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)X1MN
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,48)X1MX
        CALL DPWRST('XXX','BUG ')
        AFR=0.0
        GOTO9000
      ELSEIF(X1MN.LT.ALOC)THEN
        WRITE(ICOUT,4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X1MN
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,49)ALOC
        CALL DPWRST('XXX','BUG ')
        AFR=0.0
        GOTO9000
      ELSEIF(SIGMA.LE.0.0)THEN
        WRITE(ICOUT,8)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)SIGMA
        CALL DPWRST('XXX','BUG ')
        AFR=0.0
        GOTO9000
      ELSEIF(SCALE.LE.0.0)THEN
        WRITE(ICOUT,6)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)SCALE
        CALL DPWRST('XXX','BUG ')
        AFR=0.0
        GOTO9000
      ENDIF
   90 CONTINUE
    4 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO LGNAFR ',
     1       'IS LESS THAN THE LOCATION')
    5 FORMAT('***** ERROR--THE FIRST AND SECOND INPUT ARGUMENTS TO ',
     1       'LGNAFR ARE EQUAL')
    6 FORMAT('***** ERROR--THE FIFTH INPUT ARGUMENT TO LGNAFR ',
     1       '(THE SCALE) IS NON-POSITIVE')
    8 FORMAT('***** ERROR--THE THIRD INPUT ARGUMENT TO LGNAFR ',
     1       '(THE SHAPE) IS NON-POSITIVE')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
   47 FORMAT('***** THE VALUE OF THE FIRST ARGUMENT IS ',G15.7)
   48 FORMAT('***** THE VALUE OF THE SECOND ARGUMENT IS ',G15.7)
   49 FORMAT('***** THE VALUE OF THE LOCATION PARAMETER IS ',G15.7)
C
      IF(X1MN.LT.ALOC)THEN
         AFR=0.0
      ELSE IF(X1MN.EQ.ALOC)THEN
         TERM1=(X1MX-ALOC)/SCALE
         CALL LGNCHA(TERM1,SIGMA,CHAZ1)
         AFR=CHAZ1/(X1MX - X1MN)
      ELSE
         TERM1=(X1MX-ALOC)/SCALE
         CALL LGNCHA(TERM1,SIGMA,CHAZ1)
         TERM2=(X1MN-ALOC)/SCALE
         CALL LGNCHA(TERM2,SIGMA,CHAZ2)
         AFR=(CHAZ1 - CHAZ2)/(X1MX - X1MN)
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE LGNCDF(X,SD,CDF)
CCCCC SUBROUTINE LGNCDF(X,CDF)
CCCCC APRIL 1995.  SUPPORT SHAPE PARAMETER
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE LOGNORMAL
C              DISTRIBUTION.
C              THE LOGNORMAL DISTRIBUTION USED
C              HEREIN HAS MEAN = SQRT(E) = 1.64872127
C              AND STANDARD DEVIATION = SQRT(E*(E-1)) = 2.16119742.
C              THIS DISTRIBUTION IS DEFINED FOR ALL POSITIVE X
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C              F(X) = (1/(X*SQRT(2*PI))) * EXP(-ALOG(X)*ALOG(X)/2)
C              THE LOGNORMAL DISTRIBUTION USED HEREIN
C              IS THE DISTRIBUTION OF THE VARIATE X = EXP(Z) WHERE
C              THE VARIATE Z IS NORMALLY DISTRIBUTED
C              WITH MEAN = 0 AND STANDARD DEVIATION = 1.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE 
C                                AT WHICH THE CUMULATIVE DISTRIBUTION 
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE POSITIVE.
C     OUTPUT ARGUMENTS--CDF    = THE SINGLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE CDF FOR THE LOGNORMAL
C             DISTRIBUTION WITH MEAN = SQRT(E) = 1.64872127 
C             AND STANDARD DEVIATION = SQRT(E*(E-1)) = 2.16119742.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 
C     RESTRICTIONS--X SHOULD BE POSITIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NORCDF. 
C     FORTRAN LIBRARY SUBROUTINES NEEDED--ALOG.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN. 
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1970, PAGES 112-136.
C               --CRAMER, MATHEMATICAL METHODS OF STATISTICS,
C                 1946, PAGES 219-220.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE:  301-921-2315
C     ORIGINAL VERSION--APRIL     1994. 
C     UPDATED         --JANUARY   1995. DEFINE X = 0 CASE AS 0
C     UPDATED         --APRIL     1995. SHAPE PARAMETER
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
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(X.LT.0.0)GOTO50
      GOTO90
   50 CONTINUE
      WRITE(ICOUT,4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,5)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)X
      CALL DPWRST('XXX','BUG ')
      CDF=0.0
      RETURN
   90 CONTINUE
    4 FORMAT('***** NON-FATAL DIAGNOSTIC--THE FIRST  INPUT ARGUMENT')
    5 FORMAT('      TO THE LGNCDF SUBROUTINE IS NEGATIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
C-----START POINT-----------------------------------------------------
C
      CDF=0.0
      IF(X.EQ.0.0)RETURN
      IF(SD.NE.1.0)GOTO1000
        ARG=ALOG(X)
        CALL NORCDF(ARG,CDF)
        GOTO9999
C
 10000 CONTINUE
        ARG=ALOG(X)/SD
        CALL NORCDF(ARG,CDF)
        GOTO9999
C
 9999 CONTINUE
      RETURN
      END 
      SUBROUTINE LGNCHA(X,SD,HAZ)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE HAZARD
C              FUNCTION VALUE FOR THE LOGNORMAL
C              DISTRIBUTION.
C              THE LOGNORMAL DISTRIBUTION USED
C              HEREIN HAS MEAN = SQRT(E) = 1.64872127
C              AND STANDARD DEVIATION = SQRT(E*(E-1)) = 2.16119742.
C              THIS DISTRIBUTION IS DEFINED FOR ALL POSITIVE X
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C              F(X) = (1/(X*SQRT(2*PI))) * EXP(-ALOG(X)*ALOG(X)/2)
C              THE LOGNORMAL DISTRIBUTION USED HEREIN
C              IS THE DISTRIBUTION OF THE VARIATE X = EXP(Z) WHERE
C              THE VARIATE Z IS NORMALLY DISTRIBUTED
C              WITH MEAN = 0 AND STANDARD DEVIATION = 1.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE 
C                                AT WHICH THE CUMULATIVE HAZARD
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE POSITIVE.
C     OUTPUT ARGUMENTS--HAZ    = THE SINGLE PRECISION CUMULATIVE HAZARD
C                                FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION CUMULATIVE HAZARD
C             FUNCTION VALUE FOR THE LOGNORMAL
C             DISTRIBUTION WITH MEAN = SQRT(E) = 1.64872127 
C             AND STANDARD DEVIATION = SQRT(E*(E-1)) = 2.16119742.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 
C     RESTRICTIONS--X SHOULD BE POSITIVE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN. 
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1970, PAGES 112-136.
C               --CRAMER, MATHEMATICAL METHODS OF STATISTICS,
C                 1946, PAGES 219-220.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE:  301-975-2855
C     ORIGINAL VERSION--APRIL     1998. 
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DSD
      DOUBLE PRECISION DCDF
      DOUBLE PRECISION DHAZ
C
      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(X.LT.0.0)GOTO50
      GOTO90
   50 CONTINUE
      WRITE(ICOUT,4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,5)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)X
      CALL DPWRST('XXX','BUG ')
      HAZ=0.0
      RETURN
   90 CONTINUE
    4 FORMAT('***** NON-FATAL DIAGNOSTIC--THE FIRST  INPUT ARGUMENT')
    5 FORMAT('      TO THE LGNHAZ SUBROUTINE IS NEGATIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
C-----START POINT-----------------------------------------------------
C
      HAZ=0.0
      IF(X.EQ.0.0)RETURN
      DX=DBLE(X)
      DSD=DBLE(SD)
      CALL NODCDF(DLOG(DX)/DSD,DCDF)
      DCDF=1.0D0-DCDF
CCCCC CALL LGNCDF(X,SD,CDF)
CCCCC CDF=1.0-CDF
      IF(DCDF.GT.0.0D0)THEN
        DHAZ=-DLOG(DCDF)
        HAZ=REAL(DHAZ)
      ELSE
        HAZ=0.0
        WRITE(ICOUT,901)X
        CALL DPWRST('XXX','BUG')
      ENDIF
  901 FORMAT('****ERROR FROM LGNHAZ: FOR X = ',E15.7,' THE CDF ',
     1'VALUE IS ESSENTIALLY 1.')
C
 9999 CONTINUE
      RETURN
      END 
      SUBROUTINE LGNHAZ(X,SD,HAZ)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE LOGNORMAL
C              FUNCTION VALUE FOR THE LOGNORMAL
C              DISTRIBUTION.
C              THE LOGNORMAL DISTRIBUTION USED
C              HEREIN HAS MEAN = SQRT(E) = 1.64872127
C              AND STANDARD DEVIATION = SQRT(E*(E-1)) = 2.16119742.
C              THIS DISTRIBUTION IS DEFINED FOR ALL POSITIVE X
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C              F(X) = (1/(X*SQRT(2*PI))) * EXP(-ALOG(X)*ALOG(X)/2)
C              THE LOGNORMAL DISTRIBUTION USED HEREIN
C              IS THE DISTRIBUTION OF THE VARIATE X = EXP(Z) WHERE
C              THE VARIATE Z IS NORMALLY DISTRIBUTED
C              WITH MEAN = 0 AND STANDARD DEVIATION = 1.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE 
C                                AT WHICH THE HAZARD
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE POSITIVE.
C     OUTPUT ARGUMENTS--HAZ    = THE SINGLE PRECISION HAZARD
C                                FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION HAZARD
C             FUNCTION VALUE PDF FOR THE LOGNORMAL
C             DISTRIBUTION WITH MEAN = SQRT(E) = 1.64872127 
C             AND STANDARD DEVIATION = SQRT(E*(E-1)) = 2.16119742.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 
C     RESTRICTIONS--X SHOULD BE POSITIVE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN. 
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1970, PAGES 112-136.
C               --CRAMER, MATHEMATICAL METHODS OF STATISTICS,
C                 1946, PAGES 219-220.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE:  301-975-2855
C     ORIGINAL VERSION--APRIL     1998. 
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DXLOG
      DOUBLE PRECISION DHAZ
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
      DOUBLE PRECISION DTERM4
C
      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(X.LT.0.0)GOTO50
      GOTO90
   50 CONTINUE
      WRITE(ICOUT,4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,5)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)X
      CALL DPWRST('XXX','BUG ')
      HAZ=0.0
      RETURN
   90 CONTINUE
    4 FORMAT('***** ERROR--THE FIRST  INPUT ARGUMENT')
    5 FORMAT('      TO THE LGNHAZ SUBROUTINE IS NEGATIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
C-----START POINT-----------------------------------------------------
C
      HAZ=0.0
      IF(X.EQ.0.0)RETURN
CCCCC CALL LGNCDF(X,SD,CDF)
CCCCC CDF=1.0-CDF
CCCCC IF(CDF.GT.0.0)THEN
CCCCC   CALL LGNPDF(X,SD,PDF)
CCCCC   HAZ=PDF/CDF
      DX=DBLE(X)
      DXLOG=DLOG(DX)
      DTERM1=-DXLOG/DBLE(SD)
      CALL NODCDF(DTERM1,DTERM2)
      IF(DTERM2.NE.0.0D0)THEN
        DTERM3=DXLOG/DBLE(SD)
        CALL NODPDF(DTERM3,DTERM4)
        DHAZ=1.D0/(DX*DBLE(SD))*DTERM4/DTERM2
        HAZ=REAL(DHAZ)
      ELSE
        HAZ=0.0
        WRITE(ICOUT,901)X
        CALL DPWRST('XXX','BUG')
      ENDIF
  901 FORMAT('****ERROR FROM LGNHAZ: FOR X = ',E15.7,' THE CDF ',
     1'VALUE IS ESSENTIALLY 1.')
C
 9999 CONTINUE
      RETURN
      END 
      SUBROUTINE LGNPDF(X,SD,PDF)
CCCCC SUBROUTINE LGNPDF(X,PDF)
CCCCC APRIL 1995.  ADD SD PARAMETER (THIS IS SHAPE PARAMETER FOR
CCCCC LOGNORMAL).
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE LOGNORMAL
C              DISTRIBUTION.
C              THE LOGNORMAL DISTRIBUTION USED
C              HEREIN HAS MEAN = SQRT(E) = 1.64872127
C              AND STANDARD DEVIATION = SQRT(E*(E-1)) = 2.16119742.
C              THIS DISTRIBUTION IS DEFINED FOR ALL POSITIVE X
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C              F(X) = (1/(X*SQRT(2*PI))) * EXP(-ALOG(X)*ALOG(X)/2)
C              THE LOGNORMAL DISTRIBUTION USED HEREIN
C              IS THE DISTRIBUTION OF THE VARIATE X = EXP(Z) WHERE
C              THE VARIATE Z IS NORMALLY DISTRIBUTED
C              WITH MEAN = 0 AND STANDARD DEVIATION = 1.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE 
C                                AT WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE POSITIVE.
C     OUTPUT ARGUMENTS--CDF    = THE SINGLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE PDF FOR THE LOGNORMAL
C             DISTRIBUTION WITH MEAN = SQRT(E) = 1.64872127 
C             AND STANDARD DEVIATION = SQRT(E*(E-1)) = 2.16119742.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 
C     RESTRICTIONS--X SHOULD BE POSITIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NORPDF. 
C     FORTRAN LIBRARY SUBROUTINES NEEDED--ALOG.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN. 
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1970, PAGES 112-136.
C               --CRAMER, MATHEMATICAL METHODS OF STATISTICS,
C                 1946, PAGES 219-220.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE:  301-975-2855
C     ORIGINAL VERSION--APRIL     1994. 
C     UPDATED         --JANUARY   1995. X=0 CASE EXPLICITLY 0
C     UPDATED         --APRIL     1995. SUPPORT SHAPE PARAMETER
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
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(X.LT.0.0)GOTO50
      GOTO90
   50 CONTINUE
      WRITE(ICOUT,4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,5)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)X
      CALL DPWRST('XXX','BUG ')
      PDF=0.0
      RETURN
   90 CONTINUE
    4 FORMAT('***** NON-FATAL DIAGNOSTIC--THE FIRST  INPUT ARGUMENT')
    5 FORMAT('      TO THE LGNPDF SUBROUTINE IS NEGATIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
C-----START POINT-----------------------------------------------------
C
      PDF=0.0
      IF(X.EQ.0.0)RETURN
      IF(SD.NE.1.0)GOTO1000
        ARG=ALOG(X)
        CALL NORPDF(ARG,PDF)
        PDF=(1.0/X)*PDF
        GOTO9999
C
 1000 CONTINUE
        ARG=ALOG(X)/SD
        CALL NORPDF(ARG,ARG2)
        PDF=(1.0/(SD*X))*ARG2
        GOTO9999
C
 9999 CONTINUE
      RETURN
      END 
      SUBROUTINE LGNPPF(P,SD,PPF)
CCCCC SUBROUTINE LGNPPF(P,PPF)
CCCCC APRIL 1995.  SUPPORT SCALE PARAMETER
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE LOGNORMAL
C              DISTRIBUTION.
C              THE LOGNORMAL DISTRIBUTION USED
C              HEREIN HAS MEAN = SQRT(E) = 1.64872127
C              AND STANDARD DEVIATION = SQRT(E*(E-1)) = 2.16119742.
C              THIS DISTRIBUTION IS DEFINED FOR ALL POSITIVE X
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C              F(X) = (1/(X*SQRT(2*PI))) * EXP(-ALOG(X)*ALOG(X)/2)
C              THE LOGNORMAL DISTRIBUTION USED HEREIN
C              IS THE DISTRIBUTION OF THE VARIATE X = EXP(Z) WHERE
C              THE VARIATE Z IS NORMALLY DISTRIBUTED
C              WITH MEAN = 0 AND STANDARD DEVIATION = 1.
C              NOTE THAT THE PERCENT POINT FUNCTION OF A DISTRIBUTION 
C              IS IDENTICALLY THE SAME AS THE INVERSE CUMULATIVE
C              DISTRIBUTION FUNCTION OF THE DISTRIBUTION.
C     INPUT  ARGUMENTS--P      = THE SINGLE PRECISION VALUE 
C                                (BETWEEN 0.0 (EXCLUSIVELY) 
C                                AND 1.0 (EXCLUSIVELY))
C                                AT WHICH THE PERCENT POINT 
C                                FUNCTION IS TO BE EVALUATED.
C     OUTPUT ARGUMENTS--PPF    = THE SINGLE PRECISION PERCENT
C                                POINT FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PERCENT POINT FUNCTION . 
C             VALUE PPF FOR THE LOGNORMAL DISTRIBUTION
C             WITH MEAN = SQRT(E) = 1.64872127
C             AND STANDARD DEVIATION = SQRT(E*(E-1)) = 2.16119742.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 
C     RESTRICTIONS--P SHOULD BE BETWEEN 0.0 (EXCLUSIVELY)
C                   AND 1.0 (EXCLUSIVELY).
C     OTHER DATAPAC   SUBROUTINES NEEDED--NORPPF. 
C     FORTRAN LIBRARY SUBROUTINES NEEDED--EXP.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN. 
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1970, PAGES 112-136.
C               --CRAMER, MATHEMATICAL METHODS OF STATISTICS,
C                 1946, PAGES 219-220.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE:  301-921-2315
C     ORIGINAL VERSION--APRIL     1994. 
C     UPDATED         --JANUARY   1995. 
C     UPDATED         --APRIL     1995. SUPPORT SCALE PARAMETER
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
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.LT.0.0.OR.P.GE.1.0)GOTO50
      GOTO90
   50 CONTINUE
      WRITE(ICOUT,1)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)P
      CALL DPWRST('XXX','BUG ')
      PPF=0.0
      RETURN
   90 CONTINUE
    1 FORMAT(
     1'***** FATAL ERROR--THE FIRST  INPUT ARGUMENT TO THE LGNPPF')
    2 FORMAT(
     1'      SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
C-----START POINT-----------------------------------------------------
C
      PPF=0.0
      IF(P.EQ.0.0)RETURN
      IF(SD.NE.1.0)GOTO1000
        CALL NORPPF(P,PPF)
        PPF=EXP(PPF)
        GOTO9999
C
 1000 CONTINUE 
        CALL NORPPF(P,PPF)
        PPF=EXP(PPF*SD)
        GOTO9999
C
 9999 CONTINUE
      RETURN
      END 
      SUBROUTINE LGNRAN(N,SIGMA,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE LOGNORMAL DISTRIBUTION.
C              THE PROTOTYPE LOGNORMAL DISTRIBUTION USED
C              HEREIN HAS MEAN = SQRT(E) = 1.64872127
C              AND STANDARD DEVIATION = SQRT(E*(E-1)) = 2.16119742.
C              THIS DISTRIBUTION IS DEFINED FOR ALL POSITIVE X
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C              F(X) = (1/(X*SQRT(2*PI))) * EXP(-ALOG(X)*ALOG(X)/2)
C              THE PROTOTYPE LOGNORMAL DISTRIBUTION USED HEREIN
C              IS THE DISTRIBUTION OF THE VARIATE X = EXP(Z) WHERE
C              THE VARIATE Z IS NORMALLY DISTRIBUTED
C              WITH MEAN = 0 AND STANDARD DEVIATION = 1.
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST N)
C                                INTO WHICH THE GENERATED
C                                RANDOM SAMPLE WILL BE PLACED.
C     OUTPUT--A RANDOM SAMPLE OF SIZE N
C             FROM THE LOGNORMAL DISTRIBUTION
C             WITH MEAN = SQRT(E) = 1.64872127
C             AND STANDARD DEVIATION = SQRT(E*(E-1)) = 2.16119742.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--ALOG, SQRT, SIN, COS, EXP.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--TOCHER, THE ART OF SIMULATION,
C                 1963, PAGES 14-15.
C               --HAMMERSLEY AND HANDSCOMB, MONTE CARLO METHODS,
C                 1964, PAGE 36.
C               --CRAMER, MATHEMATICAL METHODS OF STATISTICS,
C                 1946, PAGES 219-220.
C               --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1970, PAGES 112-136.
C               --HASTINGS AND PEACOCK, STATISTICAL
C                 DISTRIBUTIONS--A HANDBOOK FOR
C                 STUDENTS AND PRACTITIONERS, 1975,
C                 PAGE 88.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           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.6
C     ORIGINAL VERSION--NOVEMBER  1975.
C     UPDATED         --JULY      1976.
C     UPDATED         --DECEMBER  1981.
C     UPDATED         --MAY       1982.
C     UPDATED         --APRIL     2003. ADD SHAPE PARAMETER SIGMA
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
      DIMENSION Y(2)
C
C---------------------------------------------------------------------
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 PI/3.14159265359/
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)GOTO50
      GOTO90
   50 WRITE(ICOUT, 5)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,47)N
      CALL DPWRST('XXX','BUG ')
      RETURN
   90 CONTINUE
    5 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ',
     1'LGNRAN SUBROUTINE IS NON-POSITIVE *****')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
C
C     GENERATE N UNIFORM (0,1) RANDOM NUMBERS;
C     THEN GENERATE 2 ADDITIONAL UNIFORM (0,1) RANDOM NUMBERS
C     (TO BE USED BELOW IN FORMING THE N-TH NORMAL
C     RANDOM NUMBER WHEN THE DESIRED SAMPLE SIZE N
C     HAPPENS TO BE ODD).
C
      CALL UNIRAN(N,ISEED,X)
      CALL UNIRAN(2,ISEED,Y)
C
C     GENERATE N NORMAL RANDOM NUMBERS
C     USING THE BOX-MULLER METHOD.
C
      DO200I=1,N,2
      IP1=I+1
      U1=X(I)
      IF(I.EQ.N)GOTO210
      U2=X(IP1)
      GOTO220
  210 U2=Y(2)
  220 ARG1=-2.0*ALOG(U1)
      ARG2=2.0*PI*U2
      SQRT1=SQRT(ARG1)
      Z1=SQRT1*COS(ARG2)
      Z2=SQRT1*SIN(ARG2)
      X(I)=Z1
      IF(I.EQ.N)GOTO200
      X(IP1)=Z2
  200 CONTINUE
C
C     GENERATE N LOGNORMAL RANDOM NUMBERS
C     USING THE DEFINITION THAT
C     A LOGNORMAL VARIATE
C     EQUALS AN EXPONETIATED NORMAL VARIATE.
C
      DO400I=1,N
      X(I)=EXP(SIGMA*X(I))
  400 CONTINUE
C
      RETURN
      END
      SUBROUTINE LIBFD1(IHLF1,IHLF2,I1,I2,ITYPE,
     1IFUNZ1,IFUNZ2,IDERZ1,IDERZ2)
C
C     PURPOSE--COMPUTE DERIVATIVES FOR
C              SQUARE ROOT, EXPONENTIAL, AND LOGS.
C
C     ORIGINAL VERSION--JANUARY   1979.
C     UPDATED         --FEBRUARY  1979.
C     UPDATED         --JANUARY   1981.
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IHLF1
      CHARACTER*4 IHLF2
      CHARACTER*4 ITYPE
      CHARACTER*4 IFUNZ1
      CHARACTER*4 IFUNZ2
      CHARACTER*4 IDERZ1
      CHARACTER*4 IDERZ2
C
      DIMENSION IFUNZ1(*)
      DIMENSION IFUNZ2(*)
      DIMENSION IDERZ1(*)
      DIMENSION IDERZ2(*)
C
C-----COMMON VARIABLES (GENERAL)-----------------------------------------------
C
      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
      I1P1=I1+1
      I1P2=I1+2
C
      IF(IHLF1.EQ.'SQRT'.AND.IHLF2.EQ.'    ')GOTO510
      IF(IHLF1.EQ.'EXP '.AND.IHLF2.EQ.'    ')GOTO520
      IF(IHLF1.EQ.'ALOG'.AND.IHLF2.EQ.'    ')GOTO530
      IF(IHLF1.EQ.'ALOG'.AND.IHLF2.EQ.'E   ')GOTO530
      IF(IHLF1.EQ.'ALOG'.AND.IHLF2.EQ.'10  ')GOTO540
      IF(IHLF1.EQ.'LOG '.AND.IHLF2.EQ.'    ')GOTO530
      IF(IHLF1.EQ.'LOGE'.AND.IHLF2.EQ.'    ')GOTO530
      IF(IHLF1.EQ.'LOG1'.AND.IHLF2.EQ.'0   ')GOTO540
C
C     TREAT THE SQUARE ROOT CASE
C
  510 CONTINUE
      I2=I2+1
      IDERZ1(I2)='0   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='.   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='5   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='*   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)=IFUNZ1(I1P1)
      IDERZ2(I2)=IFUNZ2(I1P1)
      IF(ITYPE.EQ.'EXP ')I2=I2+1
      IF(ITYPE.EQ.'EXP ')IDERZ1(I2)=IFUNZ1(I1P2)
      IF(ITYPE.EQ.'EXP ')IDERZ2(I2)=IFUNZ2(I1P2)
      I2=I2+1
      IDERZ1(I2)='**  '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='(   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='-   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='0   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='.   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='5   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)=')   '
      IDERZ2(I2)='    '
      IF(ITYPE.EQ.'EXP ')GOTO980
      GOTO985
C
C     TREAT THE EXPONENTIAL CASE
C
  520 CONTINUE
      I2=I2+1
      IDERZ1(I2)='EXP '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='(   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)=IFUNZ1(I1P1)
      IDERZ2(I2)=IFUNZ2(I1P1)
      IF(ITYPE.EQ.'EXP ')I2=I2+1
      IF(ITYPE.EQ.'EXP ')IDERZ1(I2)=IFUNZ1(I1P2)
      IF(ITYPE.EQ.'EXP ')IDERZ2(I2)=IFUNZ2(I1P2)
      I2=I2+1
      IDERZ1(I2)=')   '
      IDERZ2(I2)='    '
      IF(ITYPE.EQ.'EXP ')GOTO980
      GOTO985
C
C     TREAT THE NATURAL LOGARITHM CASE
C
  530 CONTINUE
      I2=I2+1
      IDERZ1(I2)='(   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='1   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='/   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='(   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)=IFUNZ1(I1P1)
      IDERZ2(I2)=IFUNZ2(I1P1)
      IF(ITYPE.EQ.'EXP ')I2=I2+1
      IF(ITYPE.EQ.'EXP ')IDERZ1(I2)=IFUNZ1(I1P2)
      IF(ITYPE.EQ.'EXP ')IDERZ2(I2)=IFUNZ2(I1P2)
      I2=I2+1
      IDERZ1(I2)=')   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)=')   '
      IDERZ2(I2)='    '
      IF(ITYPE.EQ.'EXP ')GOTO980
      GOTO985
C
C     TREAT THE LOGARITHM (TO THE BASE 10) CASE
C
  540 CONTINUE
      I2=I2+1
      IDERZ1(I2)='(   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='1   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='/   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='(   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)=IFUNZ1(I1P1)
      IDERZ2(I2)=IFUNZ2(I1P1)
      IF(ITYPE.EQ.'EXP ')I2=I2+1
      IF(ITYPE.EQ.'EXP ')IDERZ1(I2)=IFUNZ1(I1P2)
      IF(ITYPE.EQ.'EXP ')IDERZ2(I2)=IFUNZ2(I1P2)
      I2=I2+1
      IDERZ1(I2)=')   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)=')   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='*   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='0   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='.   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='4   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='3   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='4   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='2   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='9   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='4   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='4   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='8   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='1   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='9   '
      IDERZ2(I2)='    '
      IF(ITYPE.EQ.'EXP ')GOTO980
      GOTO985
C
  980 CONTINUE
  985 CONTINUE
C
      RETURN
      END
      SUBROUTINE LIMITS( A, B, INFIN, LOWER, UPPER )
      DOUBLE PRECISION A, B, LOWER, UPPER, PHI
      INTEGER INFIN
      LOWER = 0.0D0
      UPPER = 1.0D0
      IF ( INFIN .GE. 0 ) THEN
         IF ( INFIN .NE. 0 ) LOWER = PHI(A)
         IF ( INFIN .NE. 1 ) UPPER = PHI(B)
      ENDIF
C
      RETURN
      END
      SUBROUTINE LINEAR(IT,I1,I2,XS,YS,WH,WV,N,XMAXHF,I3,I4,
     1ALPHA,BETA,PRED,RES,ISUBRO,IBUGA3,IERROR)
C
C     PURPOSE--CARRY OUT A LEAST SQUARES WEIGHTED LINEAR FIT
C              OF THE DATA IN LOCATIONS I1 TO I2
C              OF THE HORIZONTALLY SORTED DATA
C              IN VARIABLES XS(.) AND YS(.).
C              AFTER THE FIT IS DONE, COMPUTE PREDICTED VALUES
C              AND RESIDUALS FOR ELEMENTS I3 TO I4 OF XS(.).
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--88/2
C     ORIGINAL VERSION--FEBRUARY   1988
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 ISUBRO
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DIMENSION XS(*)
      DIMENSION YS(*)
      DIMENSION WH(*)
      DIMENSION WV(*)
      DIMENSION PRED(*)
      DIMENSION RES(*)
C
C---------------------------------------------------------------------
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='LINE'
      ISUBN2='AR  '
C
      IERROR='NO'
C
      IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'NEAR')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF LINEAR--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)ISUBRO,IBUGA3,IERROR
   52 FORMAT('ISUBRO,IBUGA3,IERROR = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)IT,I1,I2,N,I3,I4
   53 FORMAT('IT,I1,I2,N,I3,I4 = ',6I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,54)XMAXHF
   54 FORMAT('XMAXHF = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      IF(N.LE.0)GOTO63
      DO61I=1,N
      WRITE(ICOUT,62)I,XS(I),YS(I),WH(I),WV(I)
   62 FORMAT('I,XS(I),YS(I),WH(I),WV(I) = ',I8,4E15.7)
      CALL DPWRST('XXX','BUG ')
   61 CONTINUE
   63 CONTINUE
   90 CONTINUE
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      IF(N.GE.1)GOTO119
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,111)
  111 FORMAT('***** ERROR IN LINEAR--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,112)
  112 FORMAT('      THE INPUT FULL SAMPLE SIZE,')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,113)
  113 FORMAT('      FOR WHICH LOWESS HORIZONTAL WEIGHTS')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,114)
  114 FORMAT('      ARE TO BE COMPUTED, MUST BE 1 OR LARGER.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,115)
  115 FORMAT('      SUCH WAS NOT THE CASE HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,116)N
  116 FORMAT('      THE FULL SAMPLE SIZE N = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
  119 CONTINUE
C
      IF(IT.GE.1)GOTO129
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,121)
  121 FORMAT('***** ERROR IN LINEAR--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,122)
  122 FORMAT('      THE INPUT TARGET OBSERVATION INDEX')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,123)
  123 FORMAT('      FOR WHICH A LOWESS IS TO BE CARRIED OUT')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,124)N
  124 FORMAT('      MUST BE BETWEEN 1 AND ',I8,' (INCLUSIVE).')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,125)
  125 FORMAT('      SUCH WAS NOT THE CASE HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,126)IT
  126 FORMAT('      THE TARGET OBSERVATION INDEX IT = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
  129 CONTINUE
C
      IF(I1.LE.I2)GOTO139
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,131)
  131 FORMAT('***** ERROR IN LINEAR--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,132)
  132 FORMAT('      THE  NEIGHBORHOOD LOWER INDEX')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,133)
  133 FORMAT('      FOR WHICH A LOWESS IS TO BE CARRIED OUT')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,134)
  134 FORMAT('      MUST NOT EXCEED THE NEIGHBORHOOD UPPER INDEX.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,135)
  135 FORMAT('      SUCH WAS NOT THE CASE HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,136)IT
  136 FORMAT('      THE NEIGHBORHOOD INDICES I1 AND I2 = ',2I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
  139 CONTINUE
C
      IF(I3.LE.I4)GOTO149
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,141)
  141 FORMAT('***** ERROR IN LINEAR--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,142)
  142 FORMAT('      THE  DESIRED LOWER INDEX FOR WHICH')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,143)
  143 FORMAT('      LOWESS PREDICTED VALUES ARE TO BE COMPUTED')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,144)
  144 FORMAT('      MUST NOT EXCEED THE DESIRED UPPER INDEX.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,145)
  145 FORMAT('      SUCH WAS NOT THE CASE HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,146)I3,I4
  146 FORMAT('      THE DESIRED INDICES I3 AND I4 = ',2I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
  149 CONTINUE
C
C               ***********************************************
C               **  STEP 11--                                **
C               **  CARRY OUT A LEAST SQUARES WEIGHTED       **
C               **  LINEAR FIT                               **
C               ***********************************************
C
      IF(XMAXHF.LE.0.0)GOTO1200
      GOTO1300
C
C               ***********************************************
C               **  STEP 12--                                **
C               **  TREAT THE CASE WHEN ALL HORIXONTAL AXIS  **
C               **  VALUES ARE IDENTICAL                     **
C               ***********************************************
C
 1200 CONTINUE
      NN=I2-I1+1
      ANN=NN
C
      SUMY=0.0
      SUMW=0.0
      DO1210I=I1,I2
      W=WH(I)*WV(I)
      SUMY=SUMY+W*YS(I)
      SUMW=SUMW+W
 1210 CONTINUE
      YBAR=SUMY/SUMW
C
      ALPHA=YBAR
      BETA=0.0
C
      DO1220I=I3,I4
      PRED(I)=ALPHA
      RES(I)=YS(I)-PRED(I)
 1220 CONTINUE
C
      GOTO9000
C               *********************************************
C               **  STEP 13--                              **
C               **  TREAT THE CASE WHEN AT LEAST 1         **
C               **  HORIZONTAL AXIS VALUE IS DIFFERENT     **
C               *********************************************
C
 1300 CONTINUE
      NN=I2-I1+1
      ANN=NN
C
      SUMW=0.0
      DO1310I=I1,I2
      W=WH(I)*WV(I)
      SUMW=SUMW+W
 1310 CONTINUE
C
      IF(SUMW.GT.0.0)GOTO1319
      WRITE(ICOUT,1311)
 1311 FORMAT('***** ERROR IN LINEAR--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1312)
 1312 FORMAT('      SUM OF WEIGHTS = 0')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1313)IT,I1,I2,N
 1313 FORMAT('IT,I1,I2,N = ',4I8)
      CALL DPWRST('XXX','BUG ')
      DO1314I=I1,I2
      WPROD=WH(I)*WV(I)
      WRITE(ICOUT,1315)I,WH(I),WV(I),WPROD
 1315 FORMAT('I,WH(I),WV(I),WPROD = ',I8,3E15.7)
      CALL DPWRST('XXX','BUG ')
 1314 CONTINUE
      IERROR='YES'
      GOTO9000
 1319 CONTINUE
C
      SUMX=0.0
      SUMY=0.0
      SUMW=0.0
      DO1320I=I1,I2
      W=WH(I)*WV(I)
      SUMX=SUMX+W*XS(I)
      SUMY=SUMY+W*YS(I)
      SUMW=SUMW+W
 1320 CONTINUE
      XBAR=SUMX/SUMW
      YBAR=SUMY/SUMW
C
      SUM1=0.0
      SUM2=0.0
      DO1330I=I1,I2
      W=WH(I)*WV(I)
      DELX=XS(I)-XBAR
      DELY=YS(I)-YBAR
      SUM1=SUM1+W*DELX*DELY
      SUM2=SUM2+W*DELX**2
 1330 CONTINUE
      BETA=0.0
      IF(SUM2.NE.0.0)BETA=SUM1/SUM2
      ALPHA=YBAR-BETA*XBAR
C
      DO1340I=I3,I4
      PRED(I)=ALPHA+BETA*XS(I)
      RES(I)=YS(I)-PRED(I)
 1340 CONTINUE
C
      GOTO9000
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'NEAR')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF LINEAR--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)ISUBRO,IBUGA3,IERROR
 9012 FORMAT('ISUBRO,IBUGA3,IERROR = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)IT,I1,I2,N,I3,I4
 9013 FORMAT('IT,I1,I2,N,I3,I4 = ',6I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9014)XMAXHF
 9014 FORMAT('XMAXHF = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      IF(N.LE.0)GOTO9033
      DO9031I=I1,I2
      WRITE(ICOUT,9032)I,XS(I),YS(I),WH(I),WV(I)
 9032 FORMAT('I,XS(I),YS(I),WH(I),WV(I) = ',I8,4E15.7)
      CALL DPWRST('XXX','BUG ')
 9031 CONTINUE
 9033 CONTINUE
      WRITE(ICOUT,9040)ALPHA,BETA
 9040 FORMAT('ALPHA,BETA = ',2E15.7)
      CALL DPWRST('XXX','BUG ')
      IF(N.LE.0)GOTO9043
      DO9041I=I3,I4
      WRITE(ICOUT,9042)I,PRED(I),RES(I)
 9042 FORMAT('I,PRED(I),RES(I) = ',I8,2E15.7)
      CALL DPWRST('XXX','BUG ')
 9041 CONTINUE
 9043 CONTINUE
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE LINFIT(Y,X,N,
     1ALPHA,BETA,XRESSD,XRESDF,CCXY,SDALPH,SDBETA,CCALBE,
     1ISUBRO,IBUGA3,IERROR)
CCCCC THE ABOVE ARGUMENT LIST WAS AUGMENTED    DECEMBER 1993
C
C     PURPOSE--CARRY OUT A LEAST SQUARES LINEAR FIT
C              OF THE DATA IN Y(.) AND X(.).
C              AFTER THE FIT IS DONE, COMPUTE PREDICTED VALUES,
C              RESIDUALS, RESIDUAL STANDARD DEVIATION,
C              RESIDUAL DEGREES OF FREEDOM.
C              ALSO COMPUTE THE CORRELATION COEFFICIENT.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--88/3
C     ORIGINAL VERSION--MARCH      1988
C     UPDATED         --DECEMBER   1993  SDA0, SDA1, CORR01
C     UPDATED         --DECEMBER   1993  PROTECT RESSD/DF
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 ISUBRO
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DIMENSION Y(*)
      DIMENSION X(*)
CCCCC DIMENSION PRED(*)  DUE TO COMPLEXITIES WITH DP'S PRED & RES
CCCCC                    AND TEMP STORAGE
CCCCC DIMENSION RES(*)   DUE TO COMPLEXITIES WITH DP'S PRED & RES
CCCCC                    AND TEMP STORAGE
CCCCC DIMENSION SDPRED(*)
CCCCC DIMENSION SDRESV(*)
C
C---------------------------------------------------------------------
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='LINF'
      ISUBN2='IT  '
C
      IERROR='NO'
C
      AN=N
C
      IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'NFIT')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF LINFIT--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)ISUBRO,IBUGA3,IERROR
   52 FORMAT('ISUBRO,IBUGA3,IERROR = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,60)N
   60 FORMAT('N = ',I8)
      CALL DPWRST('XXX','BUG ')
      IF(N.LE.0)GOTO63
      DO61I=1,N
      WRITE(ICOUT,62)I,Y(I),X(I)
   62 FORMAT('I,Y(I),X(I) = ',I8,2E15.7)
      CALL DPWRST('XXX','BUG ')
   61 CONTINUE
   63 CONTINUE
   90 CONTINUE
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      IF(N.GE.1)GOTO119
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,111)
  111 FORMAT('***** ERROR IN LINFIT--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,112)
  112 FORMAT('      THE INPUT SAMPLE SIZE,')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,113)
  113 FORMAT('      FOR WHICH A LINEAR FIT IS TO BE CARRIED OUT,')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,114)
  114 FORMAT('      MUST BE 1 OR LARGER.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,115)
  115 FORMAT('      SUCH WAS NOT THE CASE HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,116)N
  116 FORMAT('      THE SAMPLE SIZE N = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
  119 CONTINUE
C
C               ***********************************************
C               **  STEP 11--                                **
C               **  CARRY OUT A LEAST SQUARES                **
C               **  LINEAR FIT                               **
C               ***********************************************
C
      SUMX=0.0
      SUMY=0.0
      DO1120I=1,N
         SUMX=SUMX+X(I)
         SUMY=SUMY+Y(I)
 1120 CONTINUE
      XBAR=SUMX/AN
      YBAR=SUMY/AN
C
      SUMXX=0.0
      SUMYY=0.0
      SUMXY=0.0
      DO1130I=1,N
         DELX=X(I)-XBAR
         DELY=Y(I)-YBAR
         SUMXX=SUMXX+DELX**2
         SUMYY=SUMYY+DELY**2
         SUMXY=SUMXY+DELX*DELY
 1130 CONTINUE
      BETA=0.0
      IF(SUMXX.NE.0.0)BETA=SUMXY/SUMXX
      ALPHA=YBAR-BETA*XBAR
C
CCCCC DO1140I=1,N
CCCCC    PRED(I)=ALPHA+BETA*X(I)
CCCCC    RES(I)=Y(I)-PRED(I)
C1140 CONTINUE
C
      XRESDF=N-2
      SUM=0.0
      DO1150I=1,N
         SUM=SUM+(Y(I)-(ALPHA+BETA*X(I)))**2
 1150 CONTINUE
      RESVAR=0.0
      IF(XRESDF.GT.0.0)RESVAR=SUM/XRESDF
      XRESSD=0.0
      IF(RESVAR.GT.0.0)XRESSD=SQRT(RESVAR)
C
C               ***********************************************
C               **  STEP 12--                                **
C               **  COMPUTE CORRELATION COEFFICIENT (X,Y)    **
C               ***********************************************
C
      ADENOM=0.0
      IF(SUMXX.GT.0.0.AND.SUMYY.GT.0.0)ADENOM=SQRT(SUMXX)*SQRT(SUMYY)
      CCXY=0.0
      IF(ADENOM.GT.0.0)CCXY=SUMXY/ADENOM
C
C               ************************************
C               **  STEP 13--                     **
C               **  COMPUTE SD OF ESTIMATES       **
C               **  AND CORR(ESTIMATES)           **
C               ************************************
C
      SDALPH=0.0
      SDBETA=0.0
      CCALBE=0.0
      SUM=0.0
      DO1200I=1,N
         SUM=SUM+X(I)*X(I)
 1200 CONTINUE
      IF(SUMXX.GT.0.0)THEN
         SDALPH=XRESSD*SQRT(SUM/(AN*SUMXX))
         SDBETA=XRESSD*SQRT(1/SUMXX)
      ENDIF
      IF(SUM.GT.0.0)THEN
         ANUM=(-XBAR)
         ADENOM=SQRT(SUM/AN)
         CCALBE=ANUM/ADENOM
      ENDIF
C
C               *******************************
C               **  STEP 14--                **
C               **  COMPUTE SD(PRED VALUES)  **
C               *******************************
C
CCCCC DO1300I=1,N
CCCCC    TERM1=1.0/AN
CCCCC    TERM2=0.0
CCCCC    IF(SUMXX.GT.0.0)TERM2=((X(I)-XBAR)**2)/SUMXX
CCCCC    SDPRED(I)=SDRES*SQRT(TERM1+TERM2)
CCCCC    SDRESV(I)=SDRES*SQRT(1.0-TERM1-TERM2)
C1300 CONTINUE
C
      GOTO9000
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'NFIT')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF LINFIT--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)ISUBRO,IBUGA3,IERROR
 9012 FORMAT('ISUBRO,IBUGA3,IERROR = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9020)N
 9020 FORMAT('N = ',I8)
      CALL DPWRST('XXX','BUG ')
      IF(N.LE.0)GOTO9023
      DO9021I=1,N
      WRITE(ICOUT,9022)I,Y(I),X(I)
 9022 FORMAT('I,Y(I),X(I) = ',I8,2E15.7)
      CALL DPWRST('XXX','BUG ')
 9021 CONTINUE
 9023 CONTINUE
CCCCC IF(N.LE.0)GOTO9025
CCCCC DO9026I=1,N
CCCCC WRITE(ICOUT,9027)I,Y(I),X(I),SDPRED(I),SDRESV(I)
C9027 FORMAT('I,Y(I),X(I),SDPRED(I),SDRESV(I) = ',I8,4E15.7)
CCCCC CALL DPWRST('XXX','BUG ')
C9026 CONTINUE
C9025 CONTINUE
      WRITE(ICOUT,9031)YBAR,XBAR
 9031 FORMAT('YBAR,XBAR = ',2E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9032)SUMXX,SUMYY,SUMXY
 9032 FORMAT('SUMXX,SUMYY,SUMXY = ',3E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9036)ALPHA,BETA
 9036 FORMAT('ALPHA,BETA = ',2E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9037)XRESSD,XRESDF
 9037 FORMAT('XRESSD,XRESDF = ',2E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9038)ADENOM,CCXY
 9038 FORMAT('ADENOM,CCXY = ',2E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9039)SDALPH,SDBETA,CCALBE
 9039 FORMAT('SDALPH,SDBETA,CCALBE = ',3E15.7)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE LINFI2(Y,X,N,
     1ALPHA,BETA,
     1ISUBRO,IBUGA3,IERROR)
C
C     PURPOSE--CARRY OUT A LEAST SQUARES LINEAR FIT
C              OF THE DATA IN Y(.) AND X(.).
C              THIS IS A MODIFIED VERSION OF LINFIT.  THE
C              DISTINCTION IS THAT THIS VERSION HAS BEEN PRUNED
C              DOWN TO ONLY GENERATE THE PARAMETER ESTIMATES
C              (USED BY PPCC PLOT FOR ESTIMATES OF LOCATION AND
C              SCALE).
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004/5
C     ORIGINAL VERSION--MAY        2004
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 ISUBRO
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DIMENSION Y(*)
      DIMENSION X(*)
C
C---------------------------------------------------------------------
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='LINF'
      ISUBN2='I2  '
C
      IERROR='NO'
C
      AN=N
C
      IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'NFI2')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF LINFI2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)ISUBRO,IBUGA3,IERROR
   52 FORMAT('ISUBRO,IBUGA3,IERROR = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,60)N
   60 FORMAT('N = ',I8)
      CALL DPWRST('XXX','BUG ')
      IF(N.LE.0)GOTO63
      DO61I=1,N
      WRITE(ICOUT,62)I,Y(I),X(I)
   62 FORMAT('I,Y(I),X(I) = ',I8,2E15.7)
      CALL DPWRST('XXX','BUG ')
   61 CONTINUE
   63 CONTINUE
   90 CONTINUE
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      IF(N.LT.1)THEN
        ALPHA=0.0
        BETA=1.0
        GOTO9000
      ENDIF
C
C               ***********************************************
C               **  STEP 11--                                **
C               **  CARRY OUT A LEAST SQUARES                **
C               **  LINEAR FIT                               **
C               ***********************************************
C
      SUMX=0.0
      SUMY=0.0
      DO1120I=1,N
         SUMX=SUMX+X(I)
         SUMY=SUMY+Y(I)
 1120 CONTINUE
      XBAR=SUMX/AN
      YBAR=SUMY/AN
C
      SUMXX=0.0
      SUMYY=0.0
      SUMXY=0.0
      DO1130I=1,N
         DELX=X(I)-XBAR
         DELY=Y(I)-YBAR
         SUMXX=SUMXX+DELX**2
         SUMYY=SUMYY+DELY**2
         SUMXY=SUMXY+DELX*DELY
 1130 CONTINUE
      BETA=0.0
      IF(SUMXX.NE.0.0)BETA=SUMXY/SUMXX
      ALPHA=YBAR-BETA*XBAR
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'NFI2')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF LINFI2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9031)YBAR,XBAR
 9031 FORMAT('YBAR,XBAR = ',2E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9032)SUMXX,SUMYY,SUMXY
 9032 FORMAT('SUMXX,SUMYY,SUMXY = ',3E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9036)ALPHA,BETA
 9036 FORMAT('ALPHA,BETA = ',2E15.7)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE LININT(Y,X,N,X2,N2,IWRITE,Y2,IBUGG3,ISUBRO,IERROR)
C
C     PURPOSE--COMPUTE LINEAR INTERPOLATION OF A VARIABLE
C              (GENERATE INTERPOLATED POINTS).
C     INPUT  ARGUMENTS--Y      = SINGLE PRECISION VARIABLE
C                                CONTAINING THE ORIGINAL
C                                VERTICAL AXIS DATA POINTS.
C                     --X      = SINGLE PRECISION VARIABLE
C                                CONTAINING THE ORIGINAL
C                                HORIZONTAL AXIS DATA POINTS.
C                     --X2     = SINGLE PRECISION VARIABLE
C                                CONTAINING THE DESIRED
C                                HORIZONTAL AXIS INTERPOLATION
C                                POINTS.
C     OUTPUT ARGUMENTS--Y2     = SINGLE PRECISION VARIABLE
C                                CONTAINING THE COMPUTED
C                                VERTICAL AXIS INTERPOLATION
C                                POINTS.
C     NOTE--IT IS PROBABLY NOT PERMISSIBLE TO HAVE THE OUTPUT VECTOR Y2(.)
C           BEING IDENTICAL TO THE INPUT VECTOR Y(.)
C     NOTE--THIS SUBROUTINE DOES NOT ASSUME THAT THE INPUT
C           DATA IS ALREADY SORTED ACCORDING TO THE
C           HORIZONTAL AXIS VARIABLE.
C           SUCH SORTING IS DOEN HEREIN.
C     CAUTION--THE INPUT VECTORS Y AND X ARE SORTED HEREIN
C              AND SO MAY BE DIFFERENT UPON LEAVING THIS SUBROUTINE
C              THAN UPON ENTERING THIS SUBROUTINE.
C     WRITTEN BY--JAMES J. FILLIBEN
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--94/5
C     ORIGINAL VERSION--MAY       1994.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGG3
      CHARACTER*4 ISUBRO
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 ISTEPN
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOPA.INC'
C
      DIMENSION Y(*)
      DIMENSION X(*)
      DIMENSION X2(*)
      DIMENSION Y2(*)
C
      DIMENSION YTEMP(MAXOBV)
      DIMENSION YDIST(MAXOBV)
      DIMENSION XDIST(MAXOBV)
C
      INCLUDE 'DPCOZZ.INC'
      INCLUDE 'DPCOZ2.INC'
      EQUIVALENCE (G2RBAG(IGAR11),YTEMP(1))
      EQUIVALENCE (G2RBAG(IGAR12),YDIST(1))
      EQUIVALENCE (G2RBAG(IGAR13),XDIST(1))
CCCCC END CHANGE
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='LINI'
      ISUBN2='NT  '
C
      IERROR='NO'
C
      IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'NINT')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF LININT--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)N
   52 FORMAT('N = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO55I=1,N
      WRITE(ICOUT,56)I,Y(I),X(I)
   56 FORMAT('I,Y(I),X(I) = ',I8,2E15.7)
      CALL DPWRST('XXX','BUG ')
   55 CONTINUE
      WRITE(ICOUT,62)N2
   62 FORMAT('N2 = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO65I=1,N2
      WRITE(ICOUT,66)I,X2(I)
   66 FORMAT('I,X2(I) = ',I8,E15.7)
      CALL DPWRST('XXX','BUG ')
   65 CONTINUE
   90 CONTINUE
C
C               ****************************************
C               **  STEP 11--                         **
C               **  SORT THE INPUT DATA ACCORDING     **
C               **  TO THE HORIZONTAL AXIS VARIABLE   **
C               ****************************************
C
      CALL SORTC(X,Y,N,X,Y)
C
C               *******************************************************
C               **  STEP 12--                                        **
C               **  DETERMINE THE NUMBER OF DISTINCT X VALUES        **
C               *******************************************************
C
      ISTEPN='12'
      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'NINT')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      NDIST=0
      DO1210I=1,N
      IF(NDIST.EQ.0)GOTO1220
      DO1215I2=1,NDIST
      IF(X(I).EQ.XDIST(I2))GOTO1210
 1215 CONTINUE
 1220 CONTINUE
      NDIST=NDIST+1
      XDIST(NDIST)=X(I)
 1210 CONTINUE
C
      CALL SORT(XDIST,NDIST,XDIST)
C
C               *****************************************************
C               **  STEP 13--                                      **
C               **  IF ALL DISTINCT (THAT IS, NO REPLICATION),     **
C               **  (THAT IS, HAVE NO REPLICATION),                **
C               **  THEN COPY OVER Y VALUES.                       **
C               **  IF NOT ALL DISTINCT                            **
C               **  (THAT IS, HAVE SOME REPLICATION),              **
C               **  THEN COMPUTE A MEAN VALUE OVER THE REPLICATES  **
C               **  AND TREAT THAT AS THE COMMON VALUE.            **
C               **  THE CORE OF THE INTERPOLATION CODE             **
C               **  IS EXPECTING SORTED, DISTINCT X VALUES.        **
C               *****************************************************
C
      IF(NDIST.EQ.N)GOTO1310
      GOTO1320
C
 1310 CONTINUE
      DO1311K=1,NDIST
      YDIST(K)=Y(K)
 1311 CONTINUE
      GOTO1390
C
 1320 CONTINUE
      DO1321K=1,NDIST
      TAG=XDIST(K)
      J=0
      DO1322I=1,N
      IF(X(I).EQ.TAG)GOTO1323
      GOTO1322
 1323 CONTINUE
      J=J+1
      YTEMP(J)=Y(I)
 1322 CONTINUE
      NI=J
      CALL MEAN(YTEMP,NI,IWRITE,YMEAN,IBUGG3,IERROR)
      YDIST(K)=YMEAN
 1321 CONTINUE
      GOTO1390
C
 1390 CONTINUE
C
C               ********************************************
C               **  STEP 14--                             **
C               **  COMPUTE INTERPOLATED VALUES           **
C               ********************************************
C
      CALL LININ2(YDIST,XDIST,NDIST,X2,N2,Y2,IBUGG3,ISUBRO,IERROR)
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'NINT')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF LININT--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)N,N2
 9012 FORMAT('N,N2 = ',2I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9051)NDIST
 9051 FORMAT('NDIST = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO9052I=1,NDIST
      WRITE(ICOUT,9053)I,XDIST(I),YDIST(I)
 9053 FORMAT('I,XDIST(I),YDIST(I) = ',I8,2E15.7)
      CALL DPWRST('XXX','BUG ')
 9052 CONTINUE
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE LININ2(Y,X,N,X2,N2,Y2,IBUGG3,ISUBRO,IERROR)
C
C     PURPOSE--COMPUTE LINEAR INTERPOLATION OF A VARIABLE
C              (GENERATE INTERPOLATED POINTS).
C     INPUT  ARGUMENTS--Y      = SINGLE PRECISION VARIABLE
C                                CONTAINING THE ORIGINAL
C                                VERTICAL AXIS DATA POINTS.
C                     --X      = SINGLE PRECISION VARIABLE
C                                CONTAINING THE ORIGINAL
C                                HORIZONTAL AXIS DATA POINTS.
C                     --X2     = SINGLE PRECISION VARIABLE
C                                CONTAINING THE DESIRED
C                                HORIZONTAL AXIS INTERPOLATION
C                                POINTS.
C     OUTPUT ARGUMENTS--Y2     = SINGLE PRECISION VARIABLE
C                                CONTAINING THE COMPUTED
C                                VERTICAL AXIS INTERPOLATION
C                                POINTS.
C     NOTE--IT IS PROBABLY NOT PERMISSIBLE TO HAVE THE OUTPUT VECTOR Y2(.)
C           BEING IDENTICAL TO THE INPUT VECTOR Y(.)
C     NOTE--THIS SUBROUTINE DOES NOT ASSUME THAT THE INPUT
C           DATA IS ALREADY SORTED ACCORDING TO THE
C           HORIZONTAL AXIS VARIABLE.
C           SUCH SORTING IS DOEN HEREIN.
C     CAUTION--THE INPUT VECTORS Y AND X ARE SORTED HEREIN
C              AND SO MAY BE DIFFERENT UPON LEAVING THIS SUBROUTINE
C              THAN UPON ENTERING THIS SUBROUTINE.
C     WRITTEN BY--JAMES J. FILLIBEN
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--94/5
C     ORIGINAL VERSION--MAY L     1994.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IBUGG3
      CHARACTER*4 ISUBRO
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
C
      DIMENSION Y(*)
      DIMENSION X(*)
      DIMENSION X2(*)
      DIMENSION Y2(*)
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
      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='LINI'
      ISUBN2='N2  '
C
      IERROR='NO'
C
      IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'NIN2')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF LININ2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)N
   52 FORMAT('N = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO55I=1,N
      WRITE(ICOUT,56)I,Y(I),X(I)
   56 FORMAT('I,Y(I),X(I) = ',I8,2E15.7)
      CALL DPWRST('XXX','BUG ')
   55 CONTINUE
      WRITE(ICOUT,62)N2
   62 FORMAT('N2 = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO65I=1,N2
      WRITE(ICOUT,66)I,X2(I)
   66 FORMAT('I,X2(I) = ',I8,E15.7)
      CALL DPWRST('XXX','BUG ')
   65 CONTINUE
   90 CONTINUE
C
      NM1=N-1
      NM2=N-2
C
C               ****************************************
C               **  STEP 31--
C               **  COMPUTE INTERPOLATION VALUES
C               ****************************************
C
      DO3100J=1,N2
      XT=X2(J)
      IF(X(1).GT.XT.OR.XT.GT.X(N))GOTO3110
      GOTO3119
C
 3110 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3111)
 3111 FORMAT('***** ERROR IN LININ2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3112)
 3112 FORMAT('      AN ATTEMPT WAS MADE TO COMPUTE')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3113)
 3113 FORMAT('      A SMOOTHED VALUE BEYOND THE RANGE')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3114)
 3114 FORMAT('      OF THE DATA--SUCH EXTRAPOLATION')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3115)
 3115 FORMAT('      IS UNRELIABLE AND NOT PERMITTED.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3116)X(1)
 3116 FORMAT('         SMALLEST DATA POINT X(1)      = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3117)X(N)
 3117 FORMAT('         LARGEST DATA POINT  X(N)      = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3118)XT
 3118 FORMAT('         ATTEMPTED EXTRAPOLATION POINT = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
 3119 CONTINUE
C
      DO3200I=1,N
      I2=I
      IF(X(I).EQ.XT)GOTO3210
      IF(X(I).GT.XT)GOTO3220
 3200 CONTINUE
C
 3210 CONTINUE
      Y2(J)=Y(I2)
      GOTO3100
C
 3220 CONTINUE
      K1=I2-1
      DELX=X(I2)-X(K1)
      DELY=Y(I2)-Y(K1)
      SLOPE=DELY/DELX
      Y2(J)=SLOPE*(XT-X(K1))+Y(K1)
C
 3100 CONTINUE
C
C               ****************************************
C               **  STEP 41--
C               **  IF CALLED FOR,
C               **  WRITE OUT INTERPOLATION VALUES
C               ****************************************
C
      IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'NIN2')GOTO4190
      DO4100J=1,N2
      WRITE(ICOUT,4110)X2(J),Y2(J)
      CALL DPWRST('XXX','BUG ')
 4110 FORMAT('X2(J),Y2(J) = ',2E15.7)
 4100 CONTINUE
 4190 CONTINUE
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'NIN2')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF LININ2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)N,N2
 9012 FORMAT('N,N2 = ',2I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9041)N2
 9041 FORMAT('N2 = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO9042I=1,N2
      WRITE(ICOUT,9043)I,X2(I),Y2(I)
 9043 FORMAT('I,X2(I),Y2(I) = ',I8,2E15.7)
      CALL DPWRST('XXX','BUG ')
 9042 CONTINUE
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE LLGCDF(X,DELTA,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE LOG-LOGISTIC DISTRIBUTION.
C              THIS DISTRIBUTION IS DEFINED FOR ALL POSITIVE X
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C                 F(X,DELTA) = DELTA*X**(DELTA-1)/[1+X**DELTA)**2]
C              THE CUMULATIVE DISTRIBUTION FUNCTION IS
C                 F(X,DELTA) = 1/(1+X**(-DELTA))
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE 
C                                AT WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE POSITIVE.
C                     --DELTA  = THE POSITIVE SHAPE PARAMETER
C     OUTPUT ARGUMENTS--CDF    = THE SINGLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE CDF FOR THE LOG-LOGISTIC DISTRIBUTION
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 
C     RESTRICTIONS--X SHOULD BE POSITIVE.
C                 --DELTA SHOULD BE POSITIVE.
C     LANGUAGE--ANSI FORTRAN. 
C     REFERENCES--"MEASURING SKEWNESS WITH RESPECT TO THE MODE",
C                 ARNOLD AND GROENEVELD, AMERICAN STATISTICIAN,
C                 FEBRUARY, 1995.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE:  301-975-2855
C     ORIGINAL VERSION--APRIL     1995. 
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX, DDELTA
      DOUBLE PRECISION DTERM1, DTERM2, DTERM3
C
      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(X.LT.0.0)THEN
        WRITE(ICOUT,4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9999
      ENDIF
      IF(DELTA.LE.0.0)THEN
        WRITE(ICOUT,14)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)DELTA
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9999
      ENDIF
    4 FORMAT('***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT')
   14 FORMAT('***** NON-FATAL DIAGNOSTIC--THE SECOND INPUT ARGUMENT')
    5 FORMAT('      TO THE LLGCDF SUBROUTINE IS NEGATIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
C-----START POINT-----------------------------------------------------
C
      CDF=0.0
      IF(X.EQ.0.0)GOTO9999
      DX=DBLE(X)
      DDELTA=DBLE(DELTA)
C
      DTERM1=DLOG(1.0D0)
      DTERM2=DLOG(1.0D0 + DX**(-DDELTA))
      DTERM3=DTERM1-DTERM2
      DCDF=DEXP(DTERM3)
      CDF=REAL(DCDF)
C
 9999 CONTINUE
      RETURN
      END 
      SUBROUTINE LLGPDF(X,DELTA,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE LOG-LOGISTIC DISTRIBUTION.
C              THIS DISTRIBUTION IS DEFINED FOR ALL POSITIVE X
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C              F(X,DELTA) = DELTA*X**(DELTA-1)/[1+X**DELTA)**2]
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE 
C                                AT WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE POSITIVE.
C                     --DELTA  = THE POSITIVE SHAPE PARAMETER
C     OUTPUT ARGUMENTS--PDF    = THE SINGLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE PDF FOR THE LOG-LOGISTIC DISTRIBUTION
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 
C     RESTRICTIONS--X SHOULD BE POSITIVE.
C                 --DELTA SHOULD BE POSITIVE.
C     LANGUAGE--ANSI FORTRAN. 
C     REFERENCES--"MEASURING SKEWNESS WITH RESPECT TO THE MODE",
C                 ARNOLD AND GROENEVELD, AMERICAN STATISTICIAN,
C                 FEBRUARY, 1995.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE:  301-975-2855
C     ORIGINAL VERSION--APRIL     1995. 
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX, DDELTA
      DOUBLE PRECISION DUL, DZ, DPDF
      DOUBLE PRECISION DTERM1, DTERM2, DTERM3, DTERM4
C
      INCLUDE 'DPCOMC.INC'
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(X.LT.0.0)THEN
        WRITE(ICOUT,4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ENDIF
      IF(DELTA.LE.0.0)THEN
        WRITE(ICOUT,14)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)DELTA
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ENDIF
    4 FORMAT('***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT')
   14 FORMAT('***** NON-FATAL DIAGNOSTIC--THE SECOND INPUT ARGUMENT')
    5 FORMAT('      TO THE LLGPDF SUBROUTINE IS NEGATIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
C-----START POINT-----------------------------------------------------
C
      PDF=0.0
      IF(X.EQ.0.0)GOTO9999
      DX=DBLE(X)
      DDELTA=DBLE(DELTA)
C
C CHECK FOR VALUE OF X**DELTA THAT IS TO LARGE (SET PDF TO 0)
C
      DUL=DLOG(DSQRT(D1MACH(2)))
      DZ=DDELTA*DLOG(DX)
      IF(DZ.GE.DUL)GOTO9999
C
      DTERM1=DLOG(DDELTA)
      DTERM2=(DDELTA-1.0D0)*DLOG(DX)
      DTERM3=2.0D0*DLOG(1.0D0+DX**DDELTA)
      DTERM4=DTERM1+DTERM2-DTERM3
      IF(DTERM4.GE.-80.0D0)THEN
        DPDF=DEXP(DTERM4)
      ELSE
        DPDF=0.0D0
      ENDIF
      PDF=REAL(DPDF)
C
 9999 CONTINUE
      RETURN
      END 
      SUBROUTINE LLGPPF(P,DELTA,PPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE LOG-LOGISTIC
C              DISTRIBUTION.
C     INPUT  ARGUMENTS--P      = THE SINGLE PRECISION VALUE 
C                                (BETWEEN 0.0 (EXCLUSIVELY) 
C                                AND 1.0 (EXCLUSIVELY))
C                                AT WHICH THE PERCENT POINT 
C                                FUNCTION IS TO BE EVALUATED.
C     OUTPUT ARGUMENTS--PPF    = THE SINGLE PRECISION PERCENT
C                                POINT FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PERCENT POINT FUNCTION . 
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 
C     RESTRICTIONS--P SHOULD BE BETWEEN 0.0 (EXCLUSIVELY)
C                   AND 1.0 (EXCLUSIVELY).
C     LANGUAGE--ANSI FORTRAN. 
C     REFERENCES--"MEASURING SKEWNESS WITH RESPECT TO THE MODE",
C                 ARNOLD AND GROENEVELD, AMERICAN STATISTICIAN,
C                 FEBRUARY, 1995.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE:  301-921-2315
C     ORIGINAL VERSION--APRIL     1995. 
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DOUBLE PRECISION DTERM1, DTERM2, DTERM3
      DOUBLE PRECISION DPPF
C
C---------------------------------------------------------------------
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(DELTA.LE.0.0)THEN
        WRITE(ICOUT,14)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)DELTA
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ENDIF
   14 FORMAT('***** NON-FATAL DIAGNOSTIC--THE SECOND INPUT ARGUMENT')
    5 FORMAT('      TO THE LLGPDF SUBROUTINE IS NEGATIVE *****')
      IF(P.LT.0.0.OR.P.GE.1.0)GOTO50
      GOTO90
   50 CONTINUE
      WRITE(ICOUT,1)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)P
      CALL DPWRST('XXX','BUG ')
      PPF=0.0
      RETURN
   90 CONTINUE
    1 FORMAT(
     1'***** FATAL ERROR--THE FIRST  INPUT ARGUMENT TO THE LLGPPF')
    2 FORMAT(
     1'      SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
C-----START POINT-----------------------------------------------------
C
      PPF=0.0
      IF(P.EQ.0.0)GOTO9999
C
      DTERM1=(-1.0D0/DBLE(DELTA))
      DTERM2=DLOG((1.0D0-DBLE(P))/DBLE(P))
      DTERM3=DTERM1*DTERM2
      DPPF=DEXP(DTERM3)
      PPF=DPPF
C
 9999 CONTINUE
      RETURN
      END 
      SUBROUTINE LLGRAN(N,DELTA,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE LOG-LOGISTIC DISTRIBUTION
C              WITH SHAPE PARAMETER VALUE = DELTA.
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --DELTA  = THE SINGLE PRECISION VALUE OF THE
C                                SHAPE PARAMETER.
C                                DELTA SHOULD BE POSITIVE.
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST N)
C                                INTO WHICH THE GENERATED
C                                RANDOM SAMPLE WILL BE PLACED.
C     OUTPUT--A RANDOM SAMPLE OF SIZE N
C             FROM THE LOG-LOGISTIC DISTRIBUTION
C             WITH SHAPE PARAMETER VALUE = DELTA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C                 --DELTA SHOULD BE POSITIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--XX
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           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
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(DELTA.LE.0.0)THEN
        WRITE(ICOUT,15)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)DELTA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
    5 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ',
     1'LLGRAN SUBROUTINE IS NON-POSITIVE *****')
   15 FORMAT('***** FATAL ERROR--THE 2ND INPUT ARGUMENT TO THE ',
     1'LLGRAN SUBROUTINE IS NON-POSITIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
C
C     GENERATE N UNIFORM (0,1) RANDOM NUMBERS;
C
      CALL UNIRAN(N,ISEED,X)
C
C     GENERATE N LOG-LOGISTIC DISTRIBUTION RANDOM NUMBERS
C     USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD.
C
      DO100I=1,N
        CALL LLGPPF(X(I),DELTA,XTEMP)
        X(I)=XTEMP
  100 CONTINUE
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE LLTSLV(NR,N,A,X,B)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C PURPOSE
C -------
C SOLVE AX=B WHERE A HAS THE FORM L(L-TRANSPOSE)
C BUT ONLY THE LOWER TRIANGULAR PART, L, IS STORED.
C
C PARAMETERS
C ----------
C NR           --> ROW DIMENSION OF MATRIX
C N            --> DIMENSION OF PROBLEM
C A(N,N)       --> MATRIX OF FORM L(L-TRANSPOSE).
C                  ON RETURN A IS UNCHANGED.
C X(N)        <--  SOLUTION VECTOR
C B(N)         --> RIGHT-HAND SIDE VECTOR
C
C NOTE
C ----
C IF B IS NOT REQUIRED BY CALLING PROGRAM, THEN
C B AND X MAY SHARE THE SAME STORAGE.
C
      DIMENSION A(NR,1),X(N),B(N)
C
C FORWARD SOLVE, RESULT IN X
C
      CALL FORSLV(NR,N,A,X,B)
C
C BACK SOLVE, RESULT IN X
C
      CALL BAKSLV(NR,N,A,X,X)
      RETURN
      END
      SUBROUTINE LMRGLO(PARA,XMOM,NMOM)
C===================================================== LMRGLO.FOR
C***********************************************************************
C*                                                                     *
C*  FORTRAN CODE WRITTEN FOR INCLUSION IN IBM RESEARCH REPORT RC20525, *
C*  'FORTRAN ROUTINES FOR USE WITH THE METHOD OF L-MOMENTS, VERSION 3' *
C*                                                                     *
C*  J. R. M. HOSKING                                                   *
C*  IBM RESEARCH DIVISION                                              *
C*  T. J. WATSON RESEARCH CENTER                                       *
C*  YORKTOWN HEIGHTS                                                   *
C*  NEW YORK 10598, U.S.A.                                             *
C*                                                                     *
C*  VERSION 3     AUGUST 1996                                          *
C*                                                                     *
C***********************************************************************
C
C  L-MOMENT RATIOS FOR THE GENERALIZED LOGISTIC DISTRIBUTION
C
C  PARAMETERS OF ROUTINE:
C  PARA   * INPUT* ARRAY OF LENGTH 3. CONTAINS THE PARAMETERS OF THE
C                  DISTRIBUTION, IN THE ORDER XI, ALPHA, K (LOCATION,
C                  SCALE, SHAPE).
C  XMOM   *OUTPUT* ARRAY OF LENGTH NMOM. ON EXIT, CONTAINS THE L-MOMENTS
C                  LAMBDA-1, LAMBDA-2, TAU-3, TAU-4, ... .
C  NMOM   * INPUT* NUMBER OF L-MOMENTS TO BE FOUND. AT MOST 20.
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DOUBLE PRECISION PARA(3),XMOM(NMOM),Z(10,20)
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      REAL CPUMIN
      REAL CPUMAX
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DATA ZERO/0D0/,ONE/1D0/
      DATA PI/3.141592653589793238D0/
C
C         SMALL IS USED TO DECIDE WHETHER TO APPROXIMATE THE FIRST 2
C         L-MOMENTS BY A POWER-SERIES EXPANSION WHEN G IS NEAR ZERO.
C         C1,C2 ARE COEFFICIENTS OF THIS POWER-SERIES EXPANSION.
C         C1 IS PI**2/6, C2 IS 7*PI**4/360.
C
      DATA SMALL/1D-4/
      DATA C1,C2/
     *  0.16449 34066 84822 644D 1,  0.18940 65658 99449 184D 1/
C
C         Z-ARRAY CONTAINS COEFFICIENTS OF THE REPRESENTATIONS OF
C         L-MOMENT RATIOS AS POLYNOMIALS IN THE SHAPE PARAMETER K
C
      DATA Z(1,3)/1D0/
      DATA (Z(I, 4),I=1, 2)/
     *  0.16666 66666 66666 667D 0,  0.83333 33333 33333 333D 0/
      DATA (Z(I, 5),I=1, 2)/
     *  0.41666 66666 66666 667D 0,  0.58333 33333 33333 333D 0/
      DATA (Z(I, 6),I=1, 3)/
     *  0.66666 66666 66666 667D-1,  0.58333 33333 33333 333D 0,
     *  0.35000 00000 00000 000D 0/
      DATA (Z(I, 7),I=1, 3)/
     *  0.23333 33333 33333 333D 0,  0.58333 33333 33333 333D 0,
     *  0.18333 33333 33333 333D 0/
      DATA (Z(I, 8),I=1, 4)/
     *  0.35714 28571 42857 143D-1,  0.42083 33333 33333 333D 0,
     *  0.45833 33333 33333 333D 0,  0.85119 04761 90476 190D-1/
      DATA (Z(I, 9),I=1, 4)/
     *  0.15099 20634 92063 492D 0,  0.51562 50000 00000 000D 0,
     *  0.29791 66666 66666 667D 0,  0.35466 26984 12698 413D-1/
      DATA (Z(I,10),I=1, 5)/
     *  0.22222 22222 22222 222D-1,  0.31889 32980 59964 727D 0,
     *  0.47997 68518 51851 852D 0,  0.16550 92592 59259 259D 0,
     *  0.13398 36860 67019 400D-1/
      DATA (Z(I,11),I=1, 5)/
     *  0.10650 79365 07936 508D 0,  0.44766 31393 29805 996D 0,
     *  0.36081 01851 85185 185D 0,  0.80390 21164 02116 402D-1,
     *  0.46285 27336 86067 019D-2/
      DATA (Z(I,12),I=1, 6)/
     *  0.15151 51515 15151 515D-1,  0.25131 61375 66137 566D 0,
     *  0.46969 52160 49382 716D 0,  0.22765 04629 62962 963D 0,
     *  0.34713 95502 64550 265D-1,  0.14727 13243 54657 688D-2/
      DATA (Z(I,13),I=1, 6)/
     *  0.79569 50456 95045 695D-1,  0.38976 59465 02057 613D 0,
     *  0.39291 73096 70781 893D 0,  0.12381 31062 61022 928D 0,
     *  0.13499 87139 91769 547D-1,  0.43426 15974 56041 900D-3/
      DATA (Z(I,14),I=1, 7)/
     *  0.10989 01098 90109 890D-1,  0.20413 29966 32996 633D 0,
     *  0.44773 66255 14403 292D 0,  0.27305 34428 27748 383D 0,
     *  0.59191 74382 71604 938D-1,  0.47768 77572 01646 091D-2,
     *  0.11930 26366 63747 775D-3/
      DATA (Z(I,15),I=1, 7)/
     *  0.61934 52050 59490 774D-1,  0.34203 17593 92870 504D 0,
     *  0.40701 37051 73427 396D 0,  0.16218 91928 06752 331D 0,
     *  0.25249 21002 35155 791D-1,  0.15509 34276 62872 107D-2,
     *  0.30677 82085 63922 850D-4/
      DATA (Z(I,16),I=1, 8)/
     *  0.83333 33333 33333 333D-2,  0.16976 83649 02293 474D 0,
     *  0.42219 12828 68366 202D 0,  0.30542 71728 94620 811D 0,
     *  0.84082 79399 72285 210D-1,  0.97243 57914 46208 113D-2,
     *  0.46528 02829 88616 322D-3,  0.74138 06706 96146 887D-5/
      DATA (Z(I,17),I=1, 8)/
     *  0.49716 60284 16028 416D-1,  0.30276 58385 89871 328D 0,
     *  0.41047 33000 89185 506D 0,  0.19483 90265 03251 764D 0,
     *  0.38659 80637 04648 526D-1,  0.34139 94076 42897 226D-2,
     *  0.12974 16173 71825 705D-3,  0.16899 11822 91033 482D-5/
      DATA (Z(I,18),I=1, 9)/
     *  0.65359 47712 41830 065D-2,  0.14387 48475 95085 690D 0,
     *  0.39643 28537 10259 464D 0,  0.32808 41807 20899 471D 0,
     *  0.10797 13931 65194 318D 0,  0.15965 33699 32077 769D-1,
     *  0.11012 77375 69143 819D-2,  0.33798 23645 82066 963D-4,
     *  0.36449 07853 33601 627D-6/
      DATA (Z(I,19),I=1, 9)/
     *  0.40878 45705 49276 431D-1,  0.27024 42907 25441 519D 0,
     *  0.40759 95245 14551 521D 0,  0.22211 14264 89320 008D 0,
     *  0.52846 38846 29533 398D-1,  0.59829 82392 72872 761D-2,
     *  0.32859 39655 65898 436D-3,  0.82617 91134 22830 354D-5,
     *  0.74603 37711 50646 605D-7/
      DATA (Z(I,20),I=1,10)/
     *  0.52631 57894 73684 211D-2,  0.12381 76557 53054 913D 0,
     *  0.37185 92914 44794 917D 0,  0.34356 87476 70189 607D 0,
     *  0.13019 86628 12524 058D 0,  0.23147 43648 99477 023D-1,
     *  0.20519 25194 79869 981D-2,  0.91205 82581 07571 930D-4,
     *  0.19023 86116 43414 884D-5,  0.14528 02606 97757 497D-7/
C
      U=PARA(1)
      A=PARA(2)
      G=PARA(3)
      IF(A.LE.ZERO.OR.DABS(G).GE.ONE)THEN
        WRITE(ICOUT,7000)
 7000   FORMAT('***** ERROR IN GENERALIZED LOGISTIC L-MOMENTS--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,7005)
 7005   FORMAT('      PARAMETERS INVALID')
        CALL DPWRST('XXX','WRIT')
        GOTO9000
      ELSEIF(NMOM.GT.20)THEN
        WRITE(ICOUT,7000)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,7010)
 7010   FORMAT('      PARAMETER NMOM TOO LARGE')
        CALL DPWRST('XXX','WRIT')
        GOTO9000
      ENDIF
C
C         FIRST 2 MOMENTS
C
      GG=G*G
      ALAM1=-G*(C1+GG*C2)
      ALAM2=ONE+GG*(C1+GG*C2)
      IF(DABS(G).GT.SMALL)ALAM2=G*PI/DSIN(G*PI)
      IF(DABS(G).GT.SMALL)ALAM1=(ONE-ALAM2)/G
      XMOM(1)=U+A*ALAM1
      IF(NMOM.EQ.1)GOTO9000
      XMOM(2)=A*ALAM2
      IF(NMOM.EQ.2)GOTO9000
C
C         HIGHER MOMENTS
C
      DO 20 M=3,NMOM
         KMAX=M/2
         SUM=Z(KMAX,M)
         DO 10 K=KMAX-1,1,-1
            SUM=SUM*GG+Z(K,M)
   10    CONTINUE
         IF(M.NE.M/2*2)SUM=-G*SUM
         XMOM(M)=SUM
   20 CONTINUE
C
 9000 CONTINUE
      RETURN
C
      END
      SUBROUTINE LNHERM(X,AN,HN,ISIGN)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE LOGARITHM OF THE HERMITE
C              POLYNOMIAL OF ORDER N.  THIS IS USEFUL FOR LARGER
C              ORDERS WHERE OVERFLOW MAY OCCUR WITH THE STANDARD
C              HERMITE POLYNOMIAL.
C
C              THE HERMITE POLYNOMIAL CAN BE NEGATIVE OR POSITIVE,
C              SO TAKE LOG OF ABSOLUTE VALUE, SAVE SIGN IN ISIGN.
C              IF HERMITE POLYNOMIAL IS ZERO, THEN SET THIS FUNCTION
C              TO ZERO.
C
C              THIS FUNCTION IS INTENDED FOR INTERMEDIATE PRIMARILY
C              FOR WHEN HIGH ORDER HERMITE POLYNOMIALS ARE USED IN
C              INTERMEDIATE CALCULATIONS AND LOGS CAN BE USED TO
C              HANDLE LARGE VALUES.
C
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION INPUT ARGUMENT
C                       AN     = THE SINGLE PRECISION VALUE FOR THE
C                                ORDER OF THE FUNCTION (SHOULD BE
C                                NON-NEGATIVE ORDER)
C     OUTPUT ARGUMENTS--HN     = THE SINGLE PRECISION VALUE OF THE
C                                LOG HERMITE POLYNOMIAL.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 
C     RESTRICTIONS--
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE
C     MODE OF INTERNAL OPERATIONS--SOME DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN. 
C     REFERENCES--"HANDBOOK OF MATHEMATICAL FUNCTIONS, AMS 55", 
C                 ABRAMOWITZ AND STEGUM.
C                 USE FOLLOWING RECURRENCE FORMULA:
C                    H(N+1) = 2.0*X*H(N)-2.0*N*H(N-1)
C                 FIRST FEW TERMS ARE FROM TABLE 22.12 OF ABRAMOWITZ
C                 AND STEGUM.
C                 COMPUTE THE HERMITE POLYNOMIAL IN THE STANDARD WAY
C                 (IN DOUBLE PRECISION), BUT TAKE LOG BEFORE CONVERTING
C                 TO SINGLE PRECISION.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE:  301-975-2855
C     ORIGINAL VERSION--JULY       1995. 
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
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
      DOUBLE PRECISION DX
      DOUBLE PRECISION DN, DN2
      DOUBLE PRECISION DHN, DHN1, DHN2
C
C-----START POINT-----------------------------------------------------
C
      N=INT(AN+0.5)
      IF(N.LT.0)THEN
        WRITE(ICOUT,6)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
    6 FORMAT('***** NON-FATAL DIAGNOSTIC--THE 2ND INPUT ARGUMENT ',
     1'TO THE LNHERM SUBROUTINE IS NEGATIVE *****')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
C
      DX=DBLE(X)
      DN=DBLE(N)
C
      IF(N.LE.0)THEN
        DHN=1.0D0
      ELSEIF(N.EQ.1)THEN
        DHN=2.0D0*DX
      ELSEIF(N.EQ.2)THEN
        DHN=4.0D0*DX**2 - 2.0D0
      ELSEIF(N.EQ.3)THEN
        DHN=8.0D0*DX**3 - 12.0D0*DX
      ELSEIF(N.EQ.4)THEN
        DHN=16.0D0*DX**4 - 48.0D0*X**2 + 12.0D0
      ELSEIF(N.EQ.5)THEN
        DHN=32.0D0*DX**5 - 160.0D0*DX**3 + 120.0D0*DX
      ELSE
        DHN1=32.0D0*DX**5 - 160.0D0*DX**3 + 120.0D0*DX
        DHN2=16.0D0*DX**4 - 48.0D0*X**2 + 12.0D0
        DO1000I=6,N
          DN2=DBLE(I)-1.0D0
          DHN=2.0D0*DX*DHN1 - 2.0D0*DN2*DHN2
          DHN2=DHN1
          DHN1=DHN
 1000   CONTINUE
      ENDIF
C
      IF(DHN.GT.0.0)THEN
        DHN=DLOG(DHN)
        ISIGN=1
      ELSEIF(DHN.LT.0.D0)THEN
        DHN=DLOG(DABS(DHN))
        ISIGN=-1
      ELSE
        DHN=0.0D0
        ISIGN=0
      ENDIF
C
      HN=REAL(DHN)
C
 9999 CONTINUE
      RETURN
      END 
      SUBROUTINE LNSRCH(N,X,F,G,P,XPLS,FPLS,MXTAKE,
CDPLT SUBROUTINE LNSRCH(N,X,F,G,P,XPLS,FPLS,OPTFCN,MXTAKE,
     +   IRETCD,STEPMX,STEPTL,SX,IPR)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C PURPOSE
C -------
C FIND A NEXT NEWTON ITERATE BY LINE SEARCH.
C
C PARAMETERS
C ----------
C N            --> DIMENSION OF PROBLEM
C X(N)         --> OLD ITERATE:   X[K-1]
C F            --> FUNCTION VALUE AT OLD ITERATE, F(X)
C G(N)         --> GRADIENT AT OLD ITERATE, G(X), OR APPROXIMATE
C P(N)         --> NON-ZERO NEWTON STEP
C XPLS(N)     <--  NEW ITERATE X[K]
C FPLS        <--  FUNCTION VALUE AT NEW ITERATE, F(XPLS)
C OPTFCN       --> NAME OF SUBROUTINE TO EVALUATE FUNCTION
C IRETCD      <--  RETURN CODE
C MXTAKE      <--  BOOLEAN FLAG INDICATING STEP OF MAXIMUM LENGTH USED
C STEPMX       --> MAXIMUM ALLOWABLE STEP SIZE
C STEPTL       --> RELATIVE STEP SIZE AT WHICH SUCCESSIVE ITERATES
C                  CONSIDERED CLOSE ENOUGH TO TERMINATE ALGORITHM
C SX(N)        --> DIAGONAL SCALING MATRIX FOR X
C IPR          --> DEVICE TO WHICH TO SEND OUTPUT
C
C INTERNAL VARIABLES
C ------------------
C SLN              NEWTON LENGTH
C RLN              RELATIVE LENGTH OF NEWTON STEP
C
      INTEGER N,IRETCD
      DIMENSION SX(N)
      DIMENSION X(N),G(N),P(N)
      DIMENSION XPLS(N)
      LOGICAL MXTAKE
C
      IPR=IPR
      MXTAKE=.FALSE.
      IRETCD=2
C$    WRITE(IPR,954)
C$    WRITE(IPR,955) (P(I),I=1,N)
      TMP=0.0
      DO 5 I=1,N
        TMP=TMP+SX(I)*SX(I)*P(I)*P(I)
    5 CONTINUE
      SLN=SQRT(TMP)
      IF(SLN.LE.STEPMX) GO TO 10
C
C NEWTON STEP LONGER THAN MAXIMUM ALLOWED
        SCL=STEPMX/SLN
        CALL SCLMUL(N,SCL,P,P)
        SLN=STEPMX
C$      WRITE(IPR,954)
C$      WRITE(IPR,955) (P(I),I=1,N)
   10 CONTINUE
      SLP=DDOT(N,G,1,P,1)
      RLN=0.
      DO 15 I=1,N
        RLN=MAX(RLN,ABS(P(I))/MAX(ABS(X(I)),1./SX(I)))
   15 CONTINUE
      RMNLMB=STEPTL/RLN
      ALMBDA=1.0
C$    WRITE(IPR,952) SLN,SLP,RMNLMB,STEPMX,STEPTL
C
C LOOP
C CHECK IF NEW ITERATE SATISFACTORY.  GENERATE NEW LAMBDA IF NECESSARY.
C
  100 CONTINUE
      IF(IRETCD.LT.2) RETURN
      DO 105 I=1,N
        XPLS(I)=X(I) + ALMBDA*P(I)
  105 CONTINUE
      CALL OPTFCN(N,XPLS,FPLS)
C$    WRITE(IPR,950) ALMBDA
C$    WRITE(IPR,951)
C$    WRITE(IPR,955) (XPLS(I),I=1,N)
C$    WRITE(IPR,953) FPLS
      IF(FPLS.GT. F+SLP*1.E-4*ALMBDA) GO TO 130
C     IF(FPLS.LE. F+SLP*1.E-4*ALMBDA)
C     THEN
C
C SOLUTION FOUND
C
        IRETCD=0
        IF(ALMBDA.EQ.1.0 .AND. SLN.GT. .99*STEPMX) MXTAKE=.TRUE.
        GO TO 100
C
C SOLUTION NOT (YET) FOUND
C
C     ELSE
  130   IF(ALMBDA .GE. RMNLMB) GO TO 140
C       IF(ALMBDA .LT. RMNLMB)
C       THEN
C
C NO SATISFACTORY XPLS FOUND SUFFICIENTLY DISTINCT FROM X
C
          IRETCD=1
          GO TO 100
C       ELSE
C
C CALCULATE NEW LAMBDA
C
  140     IF(ALMBDA.NE.1.0) GO TO 150
C         IF(ALMBDA.EQ.1.0)
C         THEN
C
C FIRST BACKTRACK: QUADRATIC FIT
C
            TLMBDA=-SLP/(2.*(FPLS-F-SLP))
            GO TO 170
C         ELSE
C
C ALL SUBSEQUENT BACKTRACKS: CUBIC FIT
C
  150       T1=FPLS-F-ALMBDA*SLP
            T2=PFPLS-F-PLMBDA*SLP
            T3=1.0/(ALMBDA-PLMBDA)
            A=T3*(T1/(ALMBDA*ALMBDA) - T2/(PLMBDA*PLMBDA))
            B=T3*(T2*ALMBDA/(PLMBDA*PLMBDA)
     +           - T1*PLMBDA/(ALMBDA*ALMBDA) )
            DISC=B*B-3.0*A*SLP
            IF(DISC.LE. B*B) GO TO 160
C           IF(DISC.GT. B*B)
C           THEN
C
C ONLY ONE POSITIVE CRITICAL POINT, MUST BE MINIMUM
C
              TLMBDA=(-B+SIGN(1.0D0,A)*SQRT(DISC))/(3.0*A)
              GO TO 165
C           ELSE
C
C BOTH CRITICAL POINTS POSITIVE, FIRST IS MINIMUM
C
  160         TLMBDA=(-B-SIGN(1.0D0,A)*SQRT(DISC))/(3.0*A)
C           ENDIF
  165       IF(TLMBDA.GT. .5*ALMBDA) TLMBDA=.5*ALMBDA
C         ENDIF
  170     PLMBDA=ALMBDA
          PFPLS=FPLS
          IF(TLMBDA.GE. ALMBDA*.1) GO TO 180
C         IF(TLMBDA.LT.ALMBDA/10.)
C         THEN
            ALMBDA=ALMBDA*.1
            GO TO 190
C         ELSE
  180       ALMBDA=TLMBDA
C         ENDIF
C       ENDIF
C     ENDIF
  190 GO TO 100
CC950 FORMAT(18H LNSRCH    ALMBDA=,E20.13)
CC951 FORMAT(29H LNSRCH    NEW ITERATE (XPLS))
CC952 FORMAT(18H LNSRCH    SLN   =,E20.13/
CC   +       18H LNSRCH    SLP   =,E20.13/
CC   +       18H LNSRCH    RMNLMB=,E20.13/
CC   +       18H LNSRCH    STEPMX=,E20.13/
CC   +       18H LNSRCH    STEPTL=,E20.13)
CC953 FORMAT(19H LNSRCH    F(XPLS)=,E20.13)
CC954 FORMAT(26H0LNSRCH    NEWTON STEP (P))
CC955 FORMAT(14H LNSRCH       ,5(E20.13,3X))
      END
      DOUBLE PRECISION FUNCTION LOBACH(XVALUE)
C
C   DESCRIPTION:
C
C      This function calculates the Lobachewsky function L(x), defined as
C
C         LOBACH(x) = {integral 0 to x} ( -ln ( | cos t | ) dt
C
C      The code uses Chebyshev expansions whose coefficients are given
C      to 20 decimal places.
C
C
C   ERROR RETURNS:
C
C      If |x| too large, it is impossible to accurately reduce the
C      argument to the range [0,pi]. An error message is printed
C      and the program returns the value 0.0
C
C
C   MACHINE-DEPENDENT CONSTANTS:
C
C      NTERM1 - INTEGER - The no. of terms to be used of the array ARLOB1.
C                          The recommended value is such that
C                          ABS(ARLOB1(NTERM1)) < EPS/100
C
C      NTERM2 - INTEGER - The no. of terms to be used of the array ARLOB2.
C                          The recommended value is such that
C                          ABS(ARLOB2(NTERM2)) < EPS/100
C
C      XLOW1 - DOUBLE PRECISION - The value below which L(x) = 0.0 to machine-precision.
C                     The recommended value is
C                              cube-root ( 6*XMIN )
C
C      XLOW2 - DOUBLE PRECISION - The value below which L(x) = x**3/6 to
C                     machine-precision. The recommended value is
C                              sqrt ( 10*EPS ) 
C
C      XLOW3 - DOUBLE PRECISION - The value below which
C                         L(pi/2) - L(pi/2-x) = x ( 1 - log(x) )
C                     to machine-precision. The recommended value is
C                               sqrt ( 18*EPS )
C
C      XHIGH - DOUBLE PRECISION - The value of |x| above which it is impossible
C                     to accurately reduce the argument. The
C                     recommended value is   1 / EPS.
C
C      For values of EPS, and XMIN, refer to the file MACHCON.TXT
C
C      The machine-dependent constants are computed internally by
C      using the D1MACH subroutine.
C
C
C   INTRINSIC FUNCTIONS USED:
C
C      INT , LOG , SQRT
C
C
C   OTHER MISCFUN SUBROUTINES USED:
C
C          CHEVAL , ERRPRN, D1MACH
C
C
C   AUTHOR:
C
C      Dr. Allan J. MacLeod,
C      Dept. of Mathematics and Statistics,
C      University of Paisley,
C      High St.,
C      Paisley,
C      SCOTLAND
C
C      ( e-mail: macl_ms0@paisley.ac.uk )
C
C
C   LATEST UPDATE:
C                  23 January, 1996
C
      INTEGER INDPI2,INDSGN,NPI,NTERM1,NTERM2
      DOUBLE PRECISION ARLOB1(0:15),ARLOB2(0:10),
     1     CHEVAL,FVAL,FVAL1,HALF,LBPB21,LBPB22,LOBPIA,LOBPIB,
     2     LOBPI1,LOBPI2,ONE,ONEHUN,PI,PIBY2,PIBY21,PIBY22,PIBY4,PI1,
     3     PI11,PI12,PI2,SIX,T,TCON,TEN,TWO,X,XCUB,XHIGH,XLOW1,
     4     XLOW2,XLOW3,XR,XVALUE,ZERO
CCCCC CHARACTER FNNAME*6,ERRMSG*26
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOMC.INC'
      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/'LOBACH'/
CCCCC DATA ERRMSG/'ARGUMENT TOO LARGE IN SIZE'/
      DATA ZERO,HALF/ 0.0 D 0 , 0.5 D 0 /
      DATA ONE,TWO,SIX/ 1.0 D 0 , 2.0 D 0 , 6.0 D 0 /
      DATA TEN,ONEHUN/ 10.0 D 0 , 100.0 D 0 /
      DATA LOBPIA,LOBPIB/ 1115.0 D 0 , 512.0 D 0 /
      DATA LOBPI2/-1.48284 69639 78694 99311 D -4/
      DATA LBPB22/-7.41423 48198 93474 96556 D -5/
      DATA PI11,PI12/ 201.0 D 0 , 64.0 D 0 /
      DATA PI2/9.67653 58979 32384 62643 D -4/
      DATA PIBY22/4.83826 79489 66192 31322 D -4/
      DATA TCON/3.24227 78765 54808 68620 D 0/
      DATA ARLOB1/0.34464 88495 34813 00507  D    0,
     1            0.58419 83571 90277 669    D   -2,
     2            0.19175 02969 46003 30     D   -3,
     3            0.78725 16064 56769        D   -5,
     4            0.36507 47741 5804         D   -6,
     5            0.18302 87272 680          D   -7,
     6            0.96890 33300 5            D   -9,
     7            0.53390 55444              D  -10,
     8            0.30340 8025               D  -11,
     9            0.17667 875                D  -12,
     X            0.10493 93                 D  -13,
     1            0.63359                    D  -15,
     2            0.3878                     D  -16,
     3            0.240                      D  -17,
     4            0.15                       D  -18,
     5            0.1                        D  -19/
      DATA ARLOB2/2.03459 41803 61328 51087  D    0,
     1            0.17351 85882 02740 7681   D   -1,
     2            0.55162 80426 09052 1      D   -4,
     3            0.39781 64627 6598         D   -6,
     4            0.36901 80289 18           D   -8,
     5            0.38804 09214              D  -10,
     6            0.44069 698                D  -12,
     7            0.52767 4                  D  -14,
     8            0.6568                     D  -16,
     9            0.84                       D  -18,
     X            0.1                        D  -19/
C
C   Start computation
C
      X = ABS ( XVALUE )
      INDSGN = 1
      IF ( XVALUE .LT. ZERO ) THEN
         INDSGN = -1
      ENDIF
C
C   Compute the machine-dependent constants.
C
      XR = D1MACH(3)
      XHIGH = ONE / XR
C
C   Error test
C
      IF ( X .GT. XHIGH ) THEN
CCCCC    CALL ERRPRN(FNNAME,ERRMSG)
         WRITE(ICOUT,999)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,101)X
         CALL DPWRST('XXX','BUG ')
         LOBACH = ZERO
         RETURN
      ENDIF
  999 FORMAT(1X)
  101 FORMAT('***** ERROR FROM LOBACH--ARGUMENT TOO LARGE.   ',
     1       'ARGUMENT = ',G15.7)
C
C   continue with constants
C
      T = XR / ONEHUN
      DO 10 NTERM1 = 15 , 0 , -1
         IF ( ABS(ARLOB1(NTERM1)) .GT. T ) GOTO 19
 10   CONTINUE
 19   DO 20 NTERM2 = 10 , 0 , -1
         IF ( ABS(ARLOB2(NTERM2)) .GT. T ) GOTO 29
 20   CONTINUE
 29   XLOW1 = ( SIX * D1MACH(1) ) ** (TWO/SIX)
      XLOW2 = SQRT ( TEN * XR )
      T = TWO * TEN - TWO
      XLOW3 = SQRT ( T * XR )
C
C   Reduce argument to [0,pi]
C
      PI1 = PI11/PI12
      PI = PI1 + PI2
      PIBY2 = PI/TWO
      PIBY21 = PI1/TWO
      PIBY4 = PIBY2/TWO
      NPI = INT ( X / PI )
      XR = ( X - NPI * PI1 ) - NPI * PI2
C
C   Reduce argument to [0,pi/2]
C
      INDPI2 = 0
      IF ( XR .GT. PIBY2 ) THEN
         INDPI2 = 1
         XR = ( PI1 - XR ) + PI2
      ENDIF
C
C   Code for argument in [0,pi/4]
C
      IF ( XR .LE. PIBY4 ) THEN 
         IF ( XR .LT. XLOW1 ) THEN
            FVAL = ZERO
         ELSE
            XCUB = XR * XR * XR
            IF ( XR .LT. XLOW2 ) THEN
               FVAL = XCUB / SIX
            ELSE
               T = ( TCON * XR * XR - HALF ) - HALF
               FVAL = XCUB * CHEVAL(NTERM1,ARLOB1,T)
            ENDIF
         ENDIF
      ELSE
C
C   Code for argument in [pi/4,pi/2]
C
         XR = ( PIBY21 - XR ) + PIBY22
         IF ( XR .EQ. ZERO ) THEN
            FVAL1 = ZERO
         ELSE
            IF ( XR .LT. XLOW3 ) THEN
               FVAL1 = XR * ( ONE - LOG( XR ) )
            ELSE
               T = ( TCON * XR * XR - HALF ) - HALF
               FVAL1 = XR * ( CHEVAL(NTERM2,ARLOB2,T) - LOG( XR ) )
            ENDIF
         ENDIF
         LBPB21 = LOBPIA / ( LOBPIB + LOBPIB )
         FVAL = ( LBPB21 - FVAL1 ) + LBPB22
      ENDIF 
      LOBPI1 = LOBPIA / LOBPIB
C
C   Compute value for argument in [pi/2,pi]
C
      IF ( INDPI2 .EQ. 1 ) THEN
         FVAL = ( LOBPI1 - FVAL ) + LOBPI2
      ENDIF
      LOBACH = FVAL
C
C   Scale up for arguments > pi
C
      IF ( NPI .GT. 0 ) THEN
         LOBACH = ( FVAL + NPI * LOBPI2 ) + NPI * LOBPI1
      ENDIF
      IF ( INDSGN .EQ. -1 ) THEN
         LOBACH = - LOBACH
      ENDIF
      RETURN
      END
      SUBROUTINE LOCAL (XI,YI,FI,NXG,XG,NYG,YG,NP,MP,AL,AB,C,IP,IER)
C
C     THIS SUBROUTINE CONSTRUCTS THE LOCAL APPROXIMANTS FOR THE GRID
C     VERSION OF FRANKE'S METHOD.  THE LOCAL APPROXIMATIONS ARE TAKEN
C     TO BE THE THIN PLATE SPLINES DESCRIBED BY DUCHON AND OTHERS.
C
C     THE ARGUMENTS ARE AS FOLLOWS.
C
C        XI   - \
C        YI   - INPUT.  THE DATA POINTS (XI,YI,FI),I=1,NPI.
C        FI   - /
C        NXG  - INPUT.  THE NUMBER OF VERTICAL GRID LINES.
C        XG   - INPUT.  THE COORDINATES OF THE VERTICAL GRID LINES, IN
C                       INCREASING ORDER.
C        NYG  - INPUT.  THE NUMBER OF HORIZONTAL GRID LINES.
C        YG   - INPUT.  THE COORDINATES OF THE HORIZONTAL GRID LINES, IN
C                       INCREASING ORDER.
C        NP   - INPUT.  AN ARRAY WHICH GIVES THE INITIAL SUBSCRIPT IN
C                       THE ARRAY MP AT WHICH THE SUBSCRIPTS FOR THE
C                       LOCAL INTERPOLATION POINTS ARE STORED.
C        MP   - INPUT.  AN ARRAY WHICH GIVES THE SUBSCRIPTS FOR THE
C                       LOCAL INTERPOLATION POINTS.
C        AL   - OUTPUT.  THE COEFFICIENTS FOR THE LINEAR PART OF THE
C                       LOCAL THIN PLATE SPLINE FIT.
C        AB   - OUTPUT.  THE COEFFICIENTS FOR THE THIN PLATE SPLINES
C        C    - OUTPUT.  NOT MEANINGFUL.  THIS IS A SCRATCH ARRAY USED
C                       DURING CALCULATION OF THE LOCAL APPROXIMATIONS.
C        IP   - OUTPUT.  NOT MEANINGFUL.  THIS IS A SCRATCH ARRAY USED
C                       TO STORE PIVOT ORDER IN EQUATION SOLUTION.
C        IER  - OUTPUT.  RETURN INDICATOR.
C                 = 0,  NORMAL RETURN.
C                 = 1,  SINGULAR MATRIX HAS BEEN DETECTED IN THE
C                       THIN PLATE SPLINE FIT.
C
C     SUBROUTINES USED
C        LINPACK:  SGECO,SGESL
C        SLATEC:  XERROR
C
      DIMENSION XI(*), YI(*), FI(*), NP(*), MP(*), AL(*), AB(*), XG(*),
     1 YG(*),C(*),IP(*)
C
C     ARITHMETIC STATEMENT FUNCTION FOR THE THIN PLATE SPLINE BASIS
C     FUNCTIONS.
C
      PHI(X,Y,XP,YP) = ((X-XP)**2+(Y-YP)**2)*ALOG(((X-XP)**2+(Y-YP)**2)
     1 + 1.E-20)
      IER = 0
      IJ = 0
      DO 160 J=1,NYG
      DO 140 I=1,NXG
      IJ = IJ + 1
  140 CONTINUE
  160 CONTINUE
      IJ = 0
C
      DO 260 J=1,NYG
      DY = YG(J+2)-YG(J)
C
      DO 240 I=1,NXG
      DX = XG(I+2)-XG(I)
      IJ = IJ+1
      LEND = NP(IJ+1)-NP(IJ)
      LEND3 = LEND + 3
      IALS = (IJ-1)*3
C
      DO 200 LI=1,LEND
      MPI = NP(IJ)+LI-1
      KI = MP(MPI)
      XKI = (XI(KI)-XG(I))/DX
      YKI = (YI(KI)-YG(J))/DY
      LIJ = LEND*LEND3 + LI
      C(LIJ) = 1.
      C(LIJ+LEND3) = XKI
      C(LIJ+2*LEND3) = YKI
      LIJ = LEND3*(LI - 1) + LEND + 1
      C(LIJ) = 1.
      C(LIJ+1) = XKI
      C(LIJ+2) = YKI
      LIJL = LI
      LIJU = LEND3*(LI-1)+1
C
      DO 180 LJ=1,LI
      MPJ = NP(IJ)+LJ-1
      KJ = MP(MPJ)
      XKJ = (XI(KJ)-XG(I))/DX
      YKJ = (YI(KJ)-YG(J))/DY
      C(LIJL) = PHI(XKI,YKI,XKJ,YKJ)
      C(LIJU) = C(LIJL)
      LIJL = LIJL + LEND3
  180 LIJU = LIJU + 1
C
      LIJ = LEND3*LEND3 + LI
      C(LIJ) = FI(KI)
  200 CONTINUE
      DO 215 LLI=1,3
      LIJU = (LEND + LLI - 1)*LEND3 + LEND + 1
      LIJL = LEND*LEND3 + LEND + LLI
      DO 210 LLJ = 1,LLI
      C(LIJL) = 0.
      C(LIJU) = 0.
      LIJL = LIJL + LEND3
  210 LIJU = LIJU + 1
      LIJ = LEND3*LEND3 + LEND + LLI
      C(LIJ) = 0.
  215 CONTINUE
C
      LR = LEND3*LEND3 + 1
      LRR = LR + LEND3
  216    CONTINUE
      CALL SGECO(C,LEND3,LEND3,IP,RCOND,C(LRR))
      IF((.1*RCOND+1.).EQ.1.)GO TO 300
      CALL SGESL(C,LEND3,LEND3,IP,C(LR),0)
C
      DO 220 LI=1,LEND
      IAB = NP(IJ)+LI-1
      AB(IAB) = C(LR)
  220 LR = LR + 1
C
      AL(IALS+1) = C(LR)
      AL(IALS+2) = C(LR+1)
      AL(IALS+3) = C(LR+2)
  240 CONTINUE
C
  260 CONTINUE
C
      RETURN
C
C     ERROR RETURN
C
  300 IER = 1
      RETURN
      END
      SUBROUTINE LOEVL (XI,YI,NXG,XG,NYG,YG,NP,MP,AL,AB,NXO,XO,NYO
     1,YO,FO)
C
C     THIS SUBROUTINE EVALUATES THE INTERPOLANT FOR THE GRID VERSION OF
C     FRANKE'S METHOD.  THE FUNCTION IS EVALUATED AT THE GRID OF POINTS
C     INDICATED BY NXO, XO, NYO, YO, AND THESE VALUES ARE RETURNED
C     IN THE ARRAY FO, WHICH IS ASSUMED TO BE DIMENSIONED (NXO,NYO).
C
C     THE ARGUMENTS ARE AS FOLLOWS.
C
C        XI   - \
C        YI   - INPUT.  THE DATA POINTS (XI,YI,FI),I=1,...,NPI.
C        FI   - /
C        NXG  - INPUT.  THE NUMBER OF VERTICAL GRID LINES.
C        XG   - INPUT.  THE COORDINATES OF THE VERTICAL GRID LINES, IN
C                       INCREASING ORDER.
C        NYG  - INPUT.  THE NUMBER OF HORIZONTAL GRID LINES.
C        YG   - INPUT.  THE COORDINATES OF THE HORIZONTAL GRID LINES,
C                       IN INCREASING ORDER.
C        NP   - INPUT.  AN ARRAY WHICH GIVES THE INITIAL SUBSCRIPT IN
C                       THE ARRAY MP AT WHICH THE SUBSCRIPTS FOR THE
C                       LOCAL INTERPOLATION POINTS ARE STORED.
C        MP   - INPUT.  AN ARRAY WHICH GIVES THE SUBSCRIPTS FOR THE
C                       LOCAL INTERPOLATION POINTS.
C        AL   - INPUT.  THE COEFFICIENTS FOR THE LINEAR PART OF THE
C                       THIN PLATE SPLINE APPROXIMATIONS.
C        AB   - INPUT.  THE COEFFICIENTS FOR THE LOCAL THIN PLATE
C                       SPLINE APPROXIMATIONS.
C        NXO  - INPUT.  THE NUMBER OF XO VALUES AT WHICH THE INTERPO-
C                       LATION FUNCTION IS TO BE CALCULATED.
C        XO   - INPUT.  THE VALUES OF X AT WHICH THE INTERPOLATION
C                       FUNCTION IS TO BE CALCULATED.
C        NYO  - INPUT.  THE NUMBER OF YO VALUES AT WHICH THE INTERPO-
C                       LATION FUNCTION IS TO BE CALCULATED.
C        YO   - INPUT.  THE VALUES OF Y AT WHICH THE INTERPOLATION
C                       FUNCTION IS TO BE CALCULATED.
C        FO   - OUTPUT.  VALUES OF THE INTERPOLATION FUNCTION AT THE
C                       GRID POINTS INDICATED BY NXO, XO, NYO, YO.
C                       FO IS ASSUMED TO BE DIMENSIONED (NXO,NYO) IN THE
C                       CALLING PROGRAM.
C
      DIMENSION XG(*), YG(*), XI(*), YI(*), NP(*), MP(*), FC(4), AL(*),
     1AB(*), XO(*), YO(*), FO(NXO,1)
C
C     ARITHMETIC STATEMENT FUNCTION FOR THE HERMITE CUBIC.
C
      H3(S) = 1. - S**2*(3. - 2.*S)
C
C     ARITHMETIC STATEMENT FUNCTION FOR THE THIN PLATE SPLINE BASIS
C     FUNCTIONS.
C
      PHI(X,Y,XP,YP) = ((X-XP)**2+(Y-YP)**2)*ALOG(((X-XP)**2+(Y-YP)**2)
     1 + 1.E-20)
C
      J = 1
C
      DO 640 JO=1,NYO
C
C     DETERMINE THE LOCATION OF THE POINT YO IN TERMS OF THE SMALLEST
C     VALUE OF J SUCH THAT YO(JO) IS IN SOME RECTANGLE (I,J).
C
      YV = YO(JO)
      JJS = J+1
      IF (YV.LT.YG(JJS)) JJS=1
C
      DO 100 JJ=JJS,NYG
      IF (YV.LT.YG(JJ+1)) GO TO 120
  100 CONTINUE
C
      J = NYG
      GO TO 140
  120 J = JJ-1
  140 JD = 3
      IF (J.GE.1) GO TO 160
      JD = 0
      J = 1
      GO TO 180
  160 IF (J.LT.NYG) GO TO 180
      JD = 6
  180 DY = YG(J+2)-YG(J+1)
      I = 1
C
      DO 620 IO=1,NXO
C
C     DETERMINE THE LOCATION OF THE POINT XO IN TERMS OF THE SMALLEST
C     VALUE OF I SUCH THAT XO(IO) IS IN THE RECTANGLE (I,J).
C
      IIS = I+1
      XV = XO(IO)
      IF (XV.LT.XG(IIS)) IIS=1
C
      DO 200 II=IIS,NXG
      IF (XV.LT.XG(II+1)) GO TO 220
  200 CONTINUE
C
      I = NXG
      GO TO 240
  220 I = II-1
  240 ID = 2
      IF (I.GE.1) GO TO 260
      ID = 1
      I = 1
      GO TO 280
  260 IF (I.LT.NXG) GO TO 280
      ID = 3
  280 DX = XG(I+2)-XG(I+1)
      KD = ID+JD
      GO TO (300,360,300,440,520,440,300,360,300), KD
C
C     THIS IS FOR (XO(IO),YO(JO)) POINTS IN A SINGLE RECTANGLE (I,J)
C
  300 FV = 0.
      IJ = (J-1)*NXG+I
      IAL = 3*IJ-2
      LMAX = NP(IJ+1)-NP(IJ)
      DXA = XG(I+2)-XG(I)
      DYA = YG(J+2)-YG(J)
      XVD = (XV-XG(I))/DXA
      YVD = (YV-YG(J))/DYA
C
      DO 320 L=1,LMAX
      MPS = NP(IJ)+L-1
      KI = MP(MPS)
      XKI = (XI(KI)-XG(I))/DXA
      YKI = (YI(KI)-YG(J))/DYA
  320 FV = FV+AB(MPS)*PHI(XKI,YKI,XVD,YVD)
C
  340 FV = FV + AL(IAL) + AL(IAL+1)*XVD + AL(IAL+2)*YVD
      GO TO 620
C
C     THIS IS FOR XO(IO),YO(JO)) POINTS WHICH ARE IN TWO RECTANGLES,
C     (I,J) AND (I+1,J).
C
  360 DYA = YG(J+2)-YG(J)
      YVD = (YV-YG(J))/DYA
C
      DO 420 IP=1,2
      FC(IP) = 0.
      IS = I+IP-1
      IJ = (J-1)*NXG+IS
      IAL = 3*IJ-2
      DXA = XG(IS+2)-XG(IS)
      XVD = (XV-XG(IS))/DXA
      LMAX = NP(IJ+1)-NP(IJ)
C
      DO 380 L=1,LMAX
      MPS = NP(IJ)+L-1
      KI = MP(MPS)
      XKI = (XI(KI)-XG(IS))/DXA
      YKI = (YI(KI)-YG(J))/DYA
  380 FC(IP) = FC(IP)+AB(MPS)*PHI(XKI,YKI,XVD,YVD)
C
  400 FC(IP)=FC(IP)+AL(IAL)+AL(IAL+1)*XVD+AL(IAL+2)*YVD
  420 CONTINUE
C
      WI = H3((XV-XG(I+1))/DX)
      FV = FC(1)*WI+(1.-WI)*FC(2)
      GO TO 620
C
C     THIS IS FOR (XO(IO),YO(JO)) POINTS WHICH ARE IN TWO RECTANGLES,
C     (I,J) AND (I,J+1).
C
  440 DXA = XG(I+2)-XG(I)
      XVD = (XV-XG(I))/DXA
C
      DO 500 JP=1,2
      FC(JP) = 0.
      JS = J+JP-1
      IJ = (JS-1)*NXG+I
      IAL = 3*IJ-2
      DYA = YG(JS+2)-YG(JS)
      YVD = (YV-YG(JS))/DYA
      LMAX = NP(IJ+1)-NP(IJ)
C
      DO 460 L=1,LMAX
      MPS = NP(IJ)+L-1
      KJ = MP(MPS)
      XKJ = (XI(KJ)-XG(I))/DXA
      YKJ = (YI(KJ)-YG(JS))/DYA
  460 FC(JP) = FC(JP)+AB(MPS)*PHI(XKJ,YKJ,XVD,YVD)
C
  480 FC(JP)=FC(JP)+AL(IAL)+AL(IAL+1)*XVD+AL(IAL+2)*YVD
  500 CONTINUE
C
      UJ = H3((YV-YG(J+1))/DY)
      FV = FC(1)*UJ+(1.-UJ)*FC(2)
      GO TO 620
C
C     THIS IS FOR (XO(IO),YO(JO)) POINTS WHICH ARE IN FOUR RECTANGLES,
C     (I,J), (I+1,J), (I,J+1), AND (I+1,J+1).
C
  520 KFC = 0
C
      DO 600 JP=1,2
      JS = J+JP-1
      DYA = YG(JS+2)-YG(JS)
      YVD = (YV-YG(JS))/DYA
C
      DO 580 IP=1,2
      IS = I+IP-1
      IJ = (JS-1)*NXG+IS
      IAL = 3*IJ-2
      KFC = KFC+1
      FC(KFC) = 0.
      DXA = XG(IS+2)-XG(IS)
      XVD = (XV-XG(IS))/DXA
      LMAX = NP(IJ+1)-NP(IJ)
C
      DO 540 L=1,LMAX
      MPS = NP(IJ)+L-1
      KI = MP(MPS)
      XKI = (XI(KI)-XG(IS))/DXA
      YKI = (YI(KI)-YG(JS))/DYA
  540 FC(KFC) = FC(KFC)+AB(MPS)*PHI(XKI,YKI,XVD,YVD)
C
  560 FC(KFC)=FC(KFC)+AL(IAL)+AL(IAL+1)*XVD+AL(IAL+2)*YVD
  580 CONTINUE
C
  600 CONTINUE
C
      WI = H3((XV-XG(I+1))/DX)
      UJ = H3((YV-YG(J+1))/DY)
      FV = WI*(UJ*FC(1)+(1.-UJ)*FC(3))+(1.-WI)*(UJ*FC(2)+(1.-UJ)*FC(4))
  620 FO(IO,JO) = FV
C
  640 CONTINUE
C
      RETURN
      END
      SUBROUTINE LOGARI(Y1,Y2,N1,IACASE,IWRITE,
     1Y3,N3,SCAL3,ITYP3,IBUGA3,ISUBRO,IERROR)
C
C     PURPOSE--CARRY OUT LOGICAL    ARITHMETIC OPERATIONS
C              OF THE REAL DATA IN Y1 AND Y2.
C
C     OPERATIONS--AND (OR CONJUNCTION OR MULTIPLICATION)
C                 OR (OR DISJUNCTION OR ADDITION)
C                 NAND
C                 NOR (OR EXCLUSIVE DISJUNCTION)
C                 IFTHEN (OR IMPLICATION)
C                 IFF (OR EQUIVALENCE)
C                 NOT (OR NEGATION OR NOT OR COMPLEMENT)
C                 XOR (OR EXCLUSIVE OR   OR EXCL. DISJUNCTION)
C
C     INPUT  ARGUMENTS--Y1 (REAL)
C                     --Y2 (REAL)
C     OUTPUT ARGUMENTS--Y3 (REAL)
C                       SCAL3
C                       ITYP3
C
C     NOTE--IT IS NOT PERMISSIBLE TO HAVE THE OUTPUT LOGICALY3(.)
C           BEING IDENTICAL TO THE INPUT LOGICALY1(.) OR Y2(.).
C     REFERENCE--HANDBOOK OF MATHEMATICAL TABLES AND FORMULAS,
C                BURINGTON, EDITION 5, PAGES 130-135.
C              --INTRODUCTION TO COMPUTER SCIENCE,
C                SCHEID, SCHAUM OUTLINE SERIES, PP. 3, 4, 6, 7, 43, 224.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--87/9
C     ORIGINAL VERSION--AUGUST   1987.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IACASE
      CHARACTER*4 IWRITE
      CHARACTER*4 ITYP3
      CHARACTER*4 IBUGA3
      CHARACTER*4 ISUBRO
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOPA.INC'
C
      DIMENSION Y1(*)
      DIMENSION Y2(*)
      DIMENSION Y3(*)
C
C---------------------------------------------------------------------
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='LOGA'
      ISUBN2='RI  '
C
      IERROR='NO'
C
      SCAL3=(-999.0)
      ITYP3='VECT'
C
      TOL=0.00001
      ONE=1.0
      ONEMIN=ONE-TOL
      ONEMAX=ONE+TOL
      ZERO=0.0
      ZERMIN=ZERO-TOL
      ZERMAX=ZERO+TOL
C
      IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'GARI')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF LOGARI--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)IBUGA3,ISUBRO,IACASE,IWRITE
   52 FORMAT('IBUGA3,ISUBRO,IACASE,IWRITE = ',A4,2X,A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)N1
   53 FORMAT('N1 = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO55I=1,N1
      WRITE(ICOUT,56)I,Y1(I),Y2(I)
   56 FORMAT('I,Y1(I),Y2(I) = ',I8,2E13.5)
      CALL DPWRST('XXX','BUG ')
   55 CONTINUE
   90 CONTINUE
C
C               **************************************************
C               **  CARRY OUT LOGICAL    ARITHMETIC OPERATIONS  **
C               **************************************************
C
C               ********************************************
C               **  STEP 11--                             **
C               **  CHECK NUMBER OF INPUT OBSERVATIONS.   **
C               ********************************************
C
      IF(N1.LT.1)GOTO1100
      GOTO1190
C
 1100 CONTINUE
      IERROR='YES'
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1151)
 1151 FORMAT('***** ERROR IN LOGARI--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1152)
 1152 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1153)
 1153 FORMAT('      IN THE VARIABLE FOR WHICH')
      CALL DPWRST('XXX','BUG ')
      IF(IACASE.EQ.'LOAN')WRITE(ICOUT,1161)
 1161 FORMAT('      THE LOGICAL    AND    IS TO BE ',
     1'COMPUTED')
      IF(IACASE.EQ.'LOAN')CALL DPWRST('XXX','BUG ')
      IF(IACASE.EQ.'LOOR')WRITE(ICOUT,1162)
 1162 FORMAT('      THE LOGICAL    OR     IS TO BE ',
     1'COMPUTED')
      IF(IACASE.EQ.'LOOR')CALL DPWRST('XXX','BUG ')
      IF(IACASE.EQ.'LONA')WRITE(ICOUT,1163)
 1163 FORMAT('      THE LOGICAL    NAND   IS TO BE ',
     1'COMPUTED')
      IF(IACASE.EQ.'LONA')CALL DPWRST('XXX','BUG ')
      IF(IACASE.EQ.'LONO')WRITE(ICOUT,1164)
 1164 FORMAT('      THE LOGICAL    NOR    IS TO BE ',
     1'COMPUTED')
      IF(IACASE.EQ.'LONO')CALL DPWRST('XXX','BUG ')
      IF(IACASE.EQ.'LOIM')WRITE(ICOUT,1165)
 1165 FORMAT('      THE LOGICAL    IMPLICATION   IS TO BE ',
     1'COMPUTED')
      IF(IACASE.EQ.'LOIM')CALL DPWRST('XXX','BUG ')
      IF(IACASE.EQ.'LOEQ')WRITE(ICOUT,1166)
 1166 FORMAT('      THE LOGICAL    EQUIVALENCE   IS TO BE ',
     1'COMPUTED')
      IF(IACASE.EQ.'LOEQ')CALL DPWRST('XXX','BUG ')
      IF(IACASE.EQ.'LONT')WRITE(ICOUT,1167)
 1167 FORMAT('      THE LOGICAL    NOT    IS TO BE ',
     1'COMPUTED')
      IF(IACASE.EQ.'LONT')CALL DPWRST('XXX','BUG ')
      IF(IACASE.EQ.'LOXO')WRITE(ICOUT,1168)
 1168 FORMAT('      THE LOGICAL    XOR    IS TO BE ',
     1'COMPUTED')
      IF(IACASE.EQ.'LOXO')CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1181)
 1181 FORMAT('      MUST BE 1 OR LARGER.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1182)
 1182 FORMAT('      SUCH WAS NOT THE CASE HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1183)N1
 1183 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8,
     1'.')
      CALL DPWRST('XXX','BUG ')
      GOTO9000
C
 1190 CONTINUE
C
C               *********************************
C               **  STEP 12--                  **
C               **  BRANCH TO THE PROPER CASE  **
C               *********************************
C
      IF(IACASE.EQ.'LOAN')GOTO2100
      IF(IACASE.EQ.'LOOR')GOTO2200
      IF(IACASE.EQ.'LONA')GOTO2300
      IF(IACASE.EQ.'LONO')GOTO2400
      IF(IACASE.EQ.'LOIM')GOTO2500
      IF(IACASE.EQ.'LOEQ')GOTO2600
      IF(IACASE.EQ.'LONT')GOTO2700
      IF(IACASE.EQ.'LOXO')GOTO2800
C
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1211)
 1211 FORMAT('***** INTERNAL ERROR IN LOGARI--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1212)
 1212 FORMAT('      IACASE NOT EQUAL TO')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1213)
 1213 FORMAT('      LOAN, LOOR, LONA, LONO, ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1214)
 1214 FORMAT('      LOIM, LOEQ, LONT, OR LOXO')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1215)
 1215 FORMAT('      IACASE = ',A4)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
C
C               *********************************************
C               **  STEP 21--                              **
C               **  TREAT THE LOGICAL    AND         CASE  **
C               **  0 0 1 1   &   0 1 0 1  YIELDS  0 0 0 1 **
C               *********************************************
C
 2100 CONTINUE
      DO2110I=1,N1
      Y3(I)=ZERO
      IF(ONEMIN.LE.Y1(I).AND.Y1(I).LE.ONEMAX.AND.
     1   ONEMIN.LE.Y2(I).AND.Y2(I).LE.ONEMAX)Y3(I)=ONE
 2110 CONTINUE
C
      ITYP3='VECT'
      N3=N1
      GOTO9000
C
C               *********************************************
C               **  STEP 22--                              **
C               **  TREAT THE LOGICAL    OR          CASE  **
C               **  0 0 1 1   &   0 1 0 1  YIELDS  0 1 1 1 **
C               *********************************************
C
 2200 CONTINUE
      DO2210I=1,N1
      Y3(I)=ONE
      IF(ZERMIN.LE.Y1(I).AND.Y1(I).LE.ZERMAX.AND.
     1   ZERMIN.LE.Y2(I).AND.Y2(I).LE.ZERMAX)Y3(I)=ZERO
 2210 CONTINUE
C
      ITYP3='VECT'
      N3=N1
      GOTO9000
C
C               ************************************************
C               **  STEP 23--                                 **
C               **  TREAT THE LOGICAL    NAND           CASE  **
C               **  0 0 1 1   &   0 1 0 1  YIELDS  1 1 1 0    **
C               ************************************************
C
 2300 CONTINUE
      DO2310I=1,N1
      Y3(I)=ONE
      IF(ONEMIN.LE.Y1(I).AND.Y1(I).LE.ONEMAX.AND.
     1   ONEMIN.LE.Y2(I).AND.Y2(I).LE.ONEMAX)Y3(I)=ZERO
 2310 CONTINUE
C
      ITYP3='VECT'
      N3=N1
      GOTO9000
C
C               ************************************************
C               **  STEP 24--                                 **
C               **  TREAT THE LOGICAL    NOR            CASE  **
C               **  0 0 1 1   &   0 1 0 1  YIELDS  1 0 0 0    **
C               ************************************************
C
 2400 CONTINUE
      DO2410I=1,N1
      Y3(I)=ZERO
      IF(ZERMIN.LE.Y1(I).AND.Y1(I).LE.ZERMAX.AND.
     1   ZERMIN.LE.Y2(I).AND.Y2(I).LE.ZERMAX)Y3(I)=ONE
 2410 CONTINUE
C
      ITYP3='VECT'
      N3=N1
      GOTO9000
C
C               ***************************************************
C               **  STEP 25--                                    **
C               **  TREAT THE LOGICAL    IMPLICATION       CASE  **
C               **  0 0 1 1   &   0 1 0 1  YIELDS  1 1 0 1       **
C               ***************************************************
C
 2500 CONTINUE
      DO2510I=1,N1
      Y3(I)=ONE
      IF(ONEMIN.LE.Y1(I).AND.Y1(I).LE.ONEMAX.AND.
     1   ZERMIN.LE.Y2(I).AND.Y2(I).LE.ZERMAX)Y3(I)=ZERO
 2510 CONTINUE
C
      ITYP3='VECT'
      N3=N1
      GOTO9000
C
C               ************************************************
C               **  STEP 26--                                 **
C               **  TREAT THE LOGICAL    EQUIVALENCE    CASE  **
C               **  0 0 1 1   &   0 1 0 1  YIELDS  1 0 0 1    **
C               ************************************************
C
 2600 CONTINUE
      DO2610I=1,N1
      Y3(I)=ZERO
      IF(ONEMIN.LE.Y1(I).AND.Y1(I).LE.ONEMAX.AND.
     1   ONEMIN.LE.Y2(I).AND.Y2(I).LE.ONEMAX)Y3(I)=ONE
      IF(ZERMIN.LE.Y1(I).AND.Y1(I).LE.ZERMAX.AND.
     1   ZERMIN.LE.Y2(I).AND.Y2(I).LE.ZERMAX)Y3(I)=ONE
 2610 CONTINUE
C
      ITYP3='VECT'
      N3=N1
      GOTO9000
C
C               *********************************************
C               **  STEP 27--                              **
C               **  TREAT THE LOGICAL    NOT         CASE  **
C               **  0 1      YIELDS  1 0                   **
C               *********************************************
C
 2700 CONTINUE
      DO2710I=1,N1
      Y3(I)=ZERO
      IF(ZERMIN.LE.Y1(I).AND.Y1(I).LE.ZERMAX)Y3(I)=ONE
 2710 CONTINUE
C
      ITYP3='VECT'
      N3=N1
      GOTO9000
C
C               ************************************************
C               **  STEP 28--                                 **
C               **  TREAT THE LOGICAL    XOR            CASE  **
C               **  0 0 1 1   &   0 1 0 1  YIELDS  0 1 1 0    **
C               ************************************************
C
 2800 CONTINUE
      DO2810I=1,N1
      Y3(I)=ONE
      IF(ONEMIN.LE.Y1(I).AND.Y1(I).LE.ONEMAX.AND.
     1   ONEMIN.LE.Y2(I).AND.Y2(I).LE.ONEMAX)Y3(I)=ZERO
      IF(ZERMIN.LE.Y1(I).AND.Y1(I).LE.ZERMAX.AND.
     1   ZERMIN.LE.Y2(I).AND.Y2(I).LE.ZERMAX)Y3(I)=ZERO
 2810 CONTINUE
C
      ITYP3='VECT'
      N3=N1
      GOTO9000
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
C
      IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'GARI')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF LOGARI--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IBUGA3,ISUBRO,IACASE,IWRITE
 9012 FORMAT('IBUGA3,ISUBRO,IACASE,IWRITE = ',A4,2X,A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)IERROR
 9013 FORMAT('IERROR = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9017)N1,N3
 9017 FORMAT('N1,N3 = ',2I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9018)SCAL3,ITYP3
 9018 FORMAT('SCAL3,ITYP3 = ',E15.7,2X,A4)
      CALL DPWRST('XXX','BUG ')
      IF(ITYP3.EQ.'SCAL')GOTO9090
      DO9021I=1,N1
      WRITE(ICOUT,9022)I,Y1(I),Y2(I)
 9022 FORMAT('I,Y1(I),Y2(I) = ',I8,2E13.5)
      CALL DPWRST('XXX','BUG ')
 9021 CONTINUE
      DO9031I=1,N3
      WRITE(ICOUT,9032)I,Y3(I)
 9032 FORMAT('I,Y3(I) = ',I8,E13.5)
      CALL DPWRST('XXX','BUG ')
 9031 CONTINUE
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE LOGGAM(X,ALG)
C
C     THIS PROGRAM CALCULATES THE LOG(TO BASE E) OF THE GAMMA FUNCTION
C     THE INPUT IS SINGLE PRECISION X
C     THE OUTPUT IS SINGLE PRECISION ALG
C     ALL INTERNAL OPERATIONS ARE DONE IN SINGLE PRECISION
C     THE ALGORITHM IS TO USE THE RECURSION FORMULA G(X)=G(X+1)/X
C     UNTIL X IS LARGE ENOUGH TO USE AN ASYMPTOTIC FORMULA FOR G(X)--THE CUT-OFF
C     POINT USED WAS X = 10
C     THE ASYMPTOTIC FORMULA USED IS IN AMS 55, PAGE 257, 6.1.41 (THE FIRST 9
C     TERMS OF THE SERIES WERE USED--I.E., OUT TO X**-17)
C     ALTHOUGH THE DATA STATEMENT DEFINES 10 COEFFICIENTS, THE PROGRAM MAKES USE
C     OF ONLY 9 COEFFICIENTS (THE ERROR BEING BOUNDED BY THE TENTH COEFFICIENT
C     DIVIDED BY X**19
C     SUBROUTINES NEEDED--NONE
C     PRINTING--NONE UNLESS AN ERROR CONDITION EXISTS
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           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.6
C     ORIGINAL VERSION--JUNE      1972.
C     UPDATED         --FEBRUARY  1981.
C     UPDATED         --FEBRUARY  1982.
C     UPDATED         --MAY       1982.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION Y,Y2,Y3,Y4,Y5,DEN,A,B,C,D
C
      DIMENSION D(10)
C
C---------------------------------------------------------------------
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 1ST INPUT ARGUMENT TO THE ',
     1'LOGGAM SUBROUTINE IS NON-POSITIVE *****')
   45 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',D22.15,' *****')
C
      Y=X
      DEN=1.0D0
  100 IF(Y.GE.10.0D0)GOTO200
      DEN=DEN*Y
      Y=Y+1
      GOTO100
  200 Y2=Y*Y
      Y3=Y*Y2
      Y4=Y2*Y2
      Y5=Y2*Y3
      A=(Y-0.5D0)*DLOG(Y)-Y+C
      B=D(1)/Y+D(2)/Y3+D(3)/Y5+D(4)/(Y2*Y5)+D(5)/(Y4*Y5)+
     1D(6)/(Y*Y5*Y5)+D(7)/(Y3*Y5*Y5)+D(8)/(Y5*Y5*Y5)+D(9)/(Y2*Y5*Y5*Y5)
      ALG=(A+B)-DLOG(DEN)
C
      RETURN
      END
      SUBROUTINE LOGIST(N,X,X0,AK,IERROR)
C
C     PURPOSE--THIS SUBROUTINE GENERATES N LOGISTIC NUMBERS
C              (A CLASSIC CHAOS THEORY SEQUENCE)
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF LOGISTIC NUMBERS
C                                TO BE GENERATED.
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST N)
C                                INTO WHICH THE GENERATED
C                                LOGISTIC NUMBERS
C                                WILL BE PLACED.
C                     --X0     = THE STARTING VALUE
C                                (THIS WILL BE THE FIRST VALUE
C                                OF THE OUTPUT SEQUENCE)
C                     --AK    = THE INDEX FOR THE SYSTEM
C     OUTPUT--N LOGISTIC-SEQUENCE NUMBERS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C     LANGUAGE--ANSI FORTRAN (1977)
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--89.6
C     ORIGINAL VERSION--APRIL 1989.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IERROR
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
      CPUMA3=CPUMAX/3.0
C
C               ******************************************
C               **  TREAT THE LOGISTIC SEQUENCE CASE    **
C               ******************************************
C
C               *******************************************
C               **  STEP 1--                             **
C               **  TEST THE INPUT ARGUMENTS FOR ERRORS  **
C               *******************************************
C
      IF(N.GE.1)GOTO190
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,101)
  101 FORMAT('***** ERROR IN LOGIST--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,102)
  102 FORMAT('      THE LENGTH OF THE DESIRED SEQUENCE')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,103)
  103 FORMAT('      OF LOGISTIC NUMBERS MUST BE 1 OR LARGER;')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,104)
  104 FORMAT('      SUCH WAS NOT THE CASE HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,105)N
  105 FORMAT('      N = ',I8)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
  190 CONTINUE
C
C               ******************************
C               **  STEP 2--                **
C               **  GENERATE THE SEQUENCE   **
C               ******************************
C
      X(1)=X0
      IF(N.LT.2)GOTO1190
      DO1100I=2,N
      I2=I
      IM1=I-1
      X(I)=AK*X(IM1)*(1.0-X(IM1))
      IF(X(I).GE.CPUMA3)GOTO1150
 1100 CONTINUE
      GOTO1190
C
 1150 CONTINUE
      I2P1=I2+1
      WRITE(ICOUT,1151)
 1151 FORMAT('***** ERROR IN LOGIST--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1152)
 1152 FORMAT('      A NUMBER IN THE LOGISTIC SEQUENCE')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1153)
 1153 FORMAT('      HAS JUST EXCEEDED THE ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1154)
 1154 FORMAT('      LARGEST FLOATING POINT NUMBER')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1155)
 1155 FORMAT('      ALLOWABLE FOR THIS COMPUTER (',E15.7,').')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1156)
 1156 FORMAT('      THE VALUE CAUSING THE OVERFLOW WAS')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1157)I2P1
 1157 FORMAT('      THE ',I8,'-TH NUMBER IN THE')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1158)
 1158 FORMAT('      LOGISTIC SEQUENCE.')
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
C
 1190 CONTINUE
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE LOGCDF(X,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE LOGISTIC DISTRIBUTION 
C              WITH MEAN = 0 AND STANDARD DEVIATION = PI/SQRT(3).
C              THIS DISTRIBUTION IS DEFINED FOR ALL X AND HAS
C              THE PROBABILITY DENSITY FUNCTION
C              F(X) = EXP(X)/(1+EXP(X)).
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C     OUTPUT ARGUMENTS--CDF    = THE SINGLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE CDF.
C     PRINTING--NONE.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--EXP.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN. 
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--2, 1970, PAGES 1-21.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE:  301-921-2315
C     ORIGINAL VERSION--APRIL     1994. 
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
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     NO INPUT ARGUMENT ERRORS POSSIBLE 
C     FOR THIS DISTRIBUTION.
C
C-----START POINT-----------------------------------------------------
C
      IF(X.GE.0.0)GOTO150
      CDF=EXP(X)/(1.0+EXP(X)) 
      RETURN
  150 CDF=1.0/(1.0+EXP(-X))
      RETURN
C
      END 
      SUBROUTINE LOGCHA(X,CHAZ)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE HAZARD
C              FUNCTION VALUE FOR THE LOGISTIC DISTRIBUTION 
C              WITH MEAN = 0 AND STANDARD DEVIATION = PI/SQRT(3).
C              THIS DISTRIBUTION IS DEFINED FOR ALL X AND HAS
C              THE CUMULATIVE HAZARD FUNCTION
C              F(X) = 1/(1+EXP(-X)).
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE CUMULATIVE HAZARD
C                                FUNCTION IS TO BE EVALUATED.
C     OUTPUT ARGUMENTS--HAZ    = THE SINGLE PRECISION CUMULATIVE
C                                HAZARD FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION CUMULATIVE HAZARD
C             FUNCTION VALUE HAZ.
C     PRINTING--NONE.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--LOG, EXP.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN. 
C     REFERENCES--EVANS, HASTINGS, AND PEACOCK, "STATISITCAL
C                 DISTRIBUTIONS", THIRD EDITION, 2000, PAGES 124-128.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE:  301-975-2899
C     ORIGINAL VERSION--OCTOBER   2003. 
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
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     NO INPUT ARGUMENT ERRORS POSSIBLE 
C     FOR THIS DISTRIBUTION.
C
C-----START POINT-----------------------------------------------------
C
      CHAZ=LOG(1.0+EXP(-X))
C
      RETURN
      END 
      SUBROUTINE LOGHAZ(X,HAZ)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE HAZARD
C              FUNCTION VALUE FOR THE LOGISTIC DISTRIBUTION 
C              WITH MEAN = 0 AND STANDARD DEVIATION = PI/SQRT(3).
C              THIS DISTRIBUTION IS DEFINED FOR ALL X AND HAS
C              THE HAZARD FUNCTION
C              F(X) = 1/(1+EXP(-X)).
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE HAZARD
C                                FUNCTION IS TO BE EVALUATED.
C     OUTPUT ARGUMENTS--HAZ    = THE SINGLE PRECISION HAZARD
C                                FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION HAZARD
C             FUNCTION VALUE HAZ.
C     PRINTING--NONE.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--EXP.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN. 
C     REFERENCES--EVANS, HASTINGS, AND PEACOCK, "STATISITCAL
C                 DISTRIBUTIONS", THIRD EDITION, 2000, PAGES 124-128.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE:  301-975-2899
C     ORIGINAL VERSION--OCTOBER   2003. 
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
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     NO INPUT ARGUMENT ERRORS POSSIBLE 
C     FOR THIS DISTRIBUTION.
C
C-----START POINT-----------------------------------------------------
C
      HAZ=1.0/(1.0+EXP(-X))
C
      RETURN
      END 
      SUBROUTINE LOGPDF(X,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE LOGISTIC DISTRIBUTION 
C              WITH MEAN = 0 AND STANDARD DEVIATION = PI/SQRT(3).
C              THIS DISTRIBUTION IS DEFINED FOR ALL X AND HAS
C              THE PROBABILITY DENSITY FUNCTION
C              F(X) = EXP(X)/(1+EXP(X)).
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C     OUTPUT ARGUMENTS--PDF    = THE SINGLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE PDF.
C     PRINTING--NONE.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--EXP.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN. 
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--2, 1970, PAGES 1-21.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE:  301-921-2315
C     ORIGINAL VERSION--APRIL     1994. 
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
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     NO INPUT ARGUMENT ERRORS POSSIBLE 
C     FOR THIS DISTRIBUTION.
C
C-----START POINT-----------------------------------------------------
C
      PDF=EXP(X)/((1.0+EXP(X))**2)
C
      RETURN
      END 
      SUBROUTINE LOGPPF(P,PPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE LOGISTIC DISTRIBUTION
C              WITH MEAN = 0 AND STANDARD DEVIATION = PI/SQRT(3).
C              THIS DISTRIBUTION IS DEFINED FOR ALL X AND HAS
C              THE PROBABILITY DENSITY FUNCTION
C              F(X) = EXP(X)/(1+EXP(X)).
C              NOTE THAT THE PERCENT POINT FUNCTION OF A DISTRIBUTION
C              IS IDENTICALLY THE SAME AS THE INVERSE CUMULATIVE
C              DISTRIBUTION FUNCTION OF THE DISTRIBUTION.
C     INPUT  ARGUMENTS--P      = THE SINGLE PRECISION VALUE
C                                (BETWEEN 0.0 AND 1.0)
C                                AT WHICH THE PERCENT POINT
C                                FUNCTION IS TO BE EVALUATED.
C     OUTPUT ARGUMENTS--PPF    = THE SINGLE PRECISION PERCENT
C                                POINT FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PERCENT POINT
C             FUNCTION VALUE PPF.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--P SHOULD BE BETWEEN 0.0 AND 1.0, EXCLUSIVELY.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--EXP.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--FILLIBEN, SIMPLE AND ROBUST LINEAR ESTIMATION
C                 OF THE LOCATION PARAMETER OF A SYMMETRIC
C                 DISTRIBUTION (UNPUBLISHED PH.D. DISSERTATION,
C                 PRINCETON UNIVERSITY), 1969, PAGES 21-44, 229-231.
C               --FILLIBEN, 'THE PERCENT POINT FUNCTION',
C                 (UNPUBLISHED MANUSCRIPT), 1970, PAGES 28-31.
C               --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--2, 1970, PAGES 1-21.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           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.6
C     ORIGINAL VERSION--JUNE      1972.
C     UPDATED         --SEPTEMBER 1975.
C     UPDATED         --NOVEMBER  1975.
C     UPDATED         --DECEMBER  1981.
C     UPDATED         --MAY       1982.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      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)GOTO50
      GOTO90
   50 WRITE(ICOUT,1)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)P
      CALL DPWRST('XXX','BUG ')
      RETURN
   90 CONTINUE
    1 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ',
     1'LOGPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
CCCCC CALL QCORR(P,Q)
CCCCC PPF=ALOG(P/Q)
      PPF=ALOG(P/(1.0-P))
C
      RETURN
      END
      SUBROUTINE LOGRAN(N,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE LOGISTIC DISTRIBUTION
C              WITH MEAN = 0 AND STANDARD DEVIATION = PI/SQRT(3).
C              THIS DISTRIBUTION IS DEFINED FOR ALL X AND HAS
C              THE PROBABILITY DENSITY FUNCTION
C              F(X) = EXP(X)/(1+EXP(X)).
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST N)
C                                INTO WHICH THE GENERATED
C                                RANDOM SAMPLE WILL BE PLACED.
C     OUTPUT--A RANDOM SAMPLE OF SIZE N
C             FROM THE LOGISTIC DISTRIBUTION
C             WITH MEAN = 0 AND STANDARD DEVIATION = PI/SQRT(3).
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--ALOG.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--TOCHER, THE ART OF SIMULATION,
C                 1963, PAGES 14-15.
C               --HAMMERSLEY AND HANDSCOMB, MONTE CARLO METHODS,
C                 1964, PAGE 36.
C               --FILLIBEN, SIMPLE AND ROBUST LINEAR ESTIMATION
C                 OF THE LOCATION PARAMETER OF A SYMMETRIC
C                 DISTRIBUTION (UNPUBLISHED PH.D. DISSERTATION,
C                 PRINCETON UNIVERSITY), 1969, PAGE 230.
C               --FILLIBEN, 'THE PERCENT POINT FUNCTION',
C                 (UNPUBLISHED MANUSCRIPT), 1970, PAGES 28-31.
C               --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--2, 1970, PAGES 1-21.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           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.6
C     ORIGINAL VERSION--JUNE      1972.
C     UPDATED         --SEPTEMBER 1975.
C     UPDATED         --NOVEMBER  1975.
C     UPDATED         --DECEMBER  1981.
C     UPDATED         --MAY       1982.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
C
C---------------------------------------------------------------------
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)GOTO50
      GOTO90
   50 WRITE(ICOUT, 5)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,47)N
      CALL DPWRST('XXX','BUG ')
      RETURN
   90 CONTINUE
    5 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ',
     1'LOGRAN SUBROUTINE IS NON-POSITIVE *****')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
C
C     GENERATE N UNIFORM (0,1) RANDOM NUMBERS;
C
      CALL UNIRAN(N,ISEED,X)
C
C     GENERATE N LOGISTIC RANDOM NUMBERS
C     USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD.
C
      DO100I=1,N
      X(I)=ALOG(X(I)/(1.0-X(I)))
  100 CONTINUE
C
      RETURN
      END
      SUBROUTINE LOGRD(X,N,NX,XG,T)
C     THIS SUBROUTINE PLACES A SET OF INTERVALS OVER THE SET OF POINTS
C     (X(I), I=1,...,N).  THIS IS DONE BY PLACING APPROXIMATELY EQUAL
C     NUMBERS OF THEM WITHIN EACH INTERVAL.
C
C     THE ARGUMENTS ARE AS FOLLOWS.
C
C        N   - INPUT.  THE NUMBER OF POINTS IN THE ARRAY X.
C        X   - INPUT.  THE ARRAY OF X POINTS.
C        NX  - INPUT.  THE DESIRED NUMBER OF INTERVALS.
C        XG  - OUTPUT.  THE COORDINATES OF THE INTERVAL ENDPOINTS.
C        T   - WORK ARRAY OF DIMENSION AT LEAST N.
C
C     SUBROUTINES USED
C        SLATEC:  SSORT
C
      DIMENSION X(*),XG(*),T(*)
C
      DO 100 I=1,N
  100 T(I) = X(I)
C
CCCCC CALL SSORT(T,T,N,1)
      CALL SORT(T,N,T)
C
      FINC = REAL(N-1)/REAL(NX+1)
  120 DO 140 J=1,NX
      FK = J*FINC + 1.
      K = FK
      WK1 = FK - K
  140 XG(J+1) = (1. - WK1)*T(K) + WK1*T(K+1)
C
      XG(1) = T(1)
      XG(NX+2) = T(N)
C
      RETURN
      END
      SUBROUTINE LOGSF(P,SF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE SPARSITY
C              FUNCTION VALUE FOR THE LOGISTIC DISTRIBUTION 
C              WITH MEAN = 0 AND STANDARD DEVIATION = PI/SQRT(3).
C              THIS DISTRIBUTION IS DEFINED FOR ALL X AND HAS
C              THE PROBABILITY DENSITY FUNCTION
C              F(X) = EXP(X)/(1+EXP(X)).
C              NOTE THAT THE SPARSITY FUNCTION OF A DISTRIBUTION
C              IS THE DERIVATIVE OF THE PERCENT POINT FUNCTION,
C              AND ALSO IS THE RECIPROCAL OF THE PROBABILITY
C              DENSITY FUNCTION (BUT IN UNITS OF P RATHER THAN X).
C     INPUT  ARGUMENTS--P      = THE SINGLE PRECISION VALUE 
C                                (BETWEEN 0.0 AND 1.0)
C                                AT WHICH THE SPARSITY
C                                FUNCTION IS TO BE EVALUATED.
C     OUTPUT ARGUMENTS--SF     = THE SINGLE PRECISION
C                                SPARSITY FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION SPARSITY
C             FUNCTION VALUE SF.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 
C     RESTRICTIONS--P SHOULD BE BETWEEN 0.0 AND 1.0, EXCLUSIVELY.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN. 
C     REFERENCES--FILLIBEN, SIMPLE AND ROBUST LINEAR ESTIMATION
C                 OF THE LOCATION PARAMETER OF A SYMMETRIC
C                 DISTRIBUTION (UNPUBLISHED PH.D. DISSERTATION,
C                 PRINCETON UNIVERSITY), 1969, PAGES 21-44, 229-231.
C               --FILLIBEN, 'THE PERCENT POINT FUNCTION',
C                 (UNPUBLISHED MANUSCRIPT), 1970, PAGES 28-31.
C               --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--2, 1970, PAGES 1-21.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE:  301-921-2315
C     ORIGINAL VERSION--APRIL     1994. 
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
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
      GOTO90
   50 CONTINUE
      WRITE(ICOUT,1)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)P
      CALL DPWRST('XXX','BUG ')
      RETURN
   90 CONTINUE
    1 FORMAT(
     1'***** FATAL ERROR--THE FIRST  INPUT ARGUMENT TO THE LOGSF')
    2 FORMAT(
     1'SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
C-----START POINT-----------------------------------------------------
C
      SF=1.0/(P-P*P)
C
      RETURN
      END 
      SUBROUTINE LOLIP (NXG,XG,NYG,YG,NPI,XI,YI,NP,MP,MPM,NMAX,D)
C
C     THIS SUBROUTINE DETERMINES THE LOCAL INTERPOLATION POINTS FOR THE
C     GRID VERSION OF FRANKE'S METHOD OF SURFACE INTERPOLATION.
C     MINPTS POINTS ARE REQUIRED FOR EACH REGION.
C     IF FEWER THAN MINPTS POINTS ARE FOUND IN THE REGION, THE NEXT
C     CLOSEST POINTS (IN THE SUP NORM AFTER THE CURRENT RECTANGLE IS
C     TRANSFORMED ONTO (0,1)) ARE USED.  MINPTS IS SET TO 3, WHICH IS
C     THE RECOMMENDED VALUE, ALTHOUGH IT MAY BE ALTERED.
C
C     THE ARGUMENTS ARE AS FOLLOWS.
C
C        NXG  - INPUT.  NUMBER OF VERTICAL GRID LINES.
C        XG   - INPUT.  THE COORDINATES OF THE VERTICAL GRID LINES, IN
C                       INCREASING ORDER
C        NYG  - INPUT.  NUMBER OF HORIZONTAL GRID LINES.
C        YG   - INPUT.  THE COORDINATES OF THE HORIZONTAL GRID LINES,
C                       IN INCREASING ORDER.
C        NPI  - INPUT.  THE NUMBER OF DATA POINTS.
C        XI   - \
C        YI   - INPUT.  THE DATA POINTS (XI,YI), I=1,...,NPI.
C        FI   - /
C        NP   - OUTPUT.  AN ARRAY WHICH GIVES THE INITIAL SUBSCRIPT IN
C                       THE ARRAY MP AT WHICH THE SUBSCRIPTS FOR THE
C                       LOCAL INTERPOLATION POINTS ARE STORED.
C        MP   - OUTPUT.  AN ARRAY WHICH GIVES THE SUBSCRIPTS FOR THE
C                       LOCAL INTERPOLATION POINTS.
C        MPM  - INPUT.  DIMENSION OF THE ARRAY MP IN THE CALLING PROGRAM
C        NMAX - OUTPUT.  THE MAXIMUM NUMBER OF INTERPOLATION POINTS
C                        OVER ALL THE REGIONS.
C        D    - A WORK ARRAY OF DIMENSION AT LEAST NPI.
C
      DIMENSION XG(*), YG(*), XI(*), YI(*), NP(*), MP(*), D(*)
      DATA MINPTS/3/
      IJ = 1
      NP(1) = 1
      NMAX = 0
      L = 0
C
      DO 200 J=1,NYG
      YGA = (YG(J+2)+YG(J))/2.
      DYG = YG(J+2)-YG(J)
C
      DO 180 I=1,NXG
      XGA = (XG(I+2)+XG(I))/2.
      DXG = XG(I+2)-XG(I)
      IJ = IJ+1
C
C     DETERMINE THE POINTS IN THE (I,J)TH RECTANGLE.
C
      DO 120 NK=1,NPI
      D(NK) = AMAX1(ABS(XI(NK) - XGA)/DXG,ABS(YI(NK) - YGA)/DYG)
      IF(D(NK).GT..6125)GO TO 120
      D(NK) = 1.E10
      L = L + 1
      LL = MIN0(L,MPM)
      MP(LL) = NK
  120 CONTINUE
C
      NP(IJ) = L+1
      IF (NP(IJ)-NP(IJ-1).GE.MINPTS) GO TO 180
C
C     ADD THE CLOSEST POINTS IF THERE ARE LESS THAN MINPTS IN THE
C     RECTANGLE.
C
      LM = MINPTS-(NP(IJ)-NP(IJ-1))
C
      DO 160 II=1,LM
      L = L+1
      LL = MIN0(L,MPM)
      MP(LL) = 1
      DM = D(1)
C
      DO 140 NK=2,NPI
      IF (D(NK).GE.DM) GO TO 140
      DM = D(NK)
      MP(LL) = NK
  140 CONTINUE
C
      NK = MP(LL)
  160 D(NK) = 1.E10
C
      NP(IJ) = L+1
  180 NMAX = MAX0(NMAX,NP(IJ)-NP(IJ-1))
C
  200 CONTINUE
C
      RETURN
      END
      SUBROUTINE LOTPS (MODE,NPPR,NPI,XI,YI,FI,NXO,XO,NYO,YO,IWK,NIWK,
     1                  NIWKU,WK,NWK,NWKU,FO,KER)
C***START PROLOGUE LOTPS
C
C     THIS VERSION IS DATED 03/04/82.
C
C                RICHARD FRANKE
C                DEPARTMENT OF MATHEMATICS
C                NAVAL POSTGRADUATE SCHOOL
C                MONTEREY, CALIFORNIA  93940
C                     (408)646-2758 / 2206
C
C
C
C     REFERENCE
C        SMOOTH INTERPOLATION OF SCATTERED DATA BY LOCAL THIN
C        PLATE SPLINES, COMPUTERS AND MATHEMATICS WITH
C        APPLICATIONS 8(1982)???-???+8
C                    OR
C        NAVAL POSTGRADUATE SCHOOL TR#NPS-53-81-002, 1981
C        (AVAILABLE FROM NTIS, AD-A098 232/2)
C
C     ABSTRACT
C        SUBROUTINE LOTPS SERVES AS THE USER INTERFACE FOR A SET OF
C        SUBROUTINES WHICH SOLVE THE SCATTERED DATA INTERPOLATION
C        PROBLEM.  A SMOOTH FUNCTION PASSING THROUGH THE GIVEN POINTS
C        (XI(K),YI(K),FI(K)),K=1,...,NPI IS CONSTRUCTED.
C        THE RESULT RETURNED IS AN ARRAY OF VALUES, FO(I,J), OF THE INT-
C        ERPOLATION FUNCTION AT GRID POINTS, (XO(I),YO(J)),I=1,...,NXO,
C        J=1,...,NYO.
C        THE METHOD USED INVOLVES CONSTRUCTION OF LOCALLY DEFINED 'THIN
C        PLATE SPLINES', WHICH ARE THEN BLENDED TOGETHER SMOOTHLY
C        THROUGH THE USE OF A PARTITION OF UNITY DEFINED ON A
C        RECTANGULAR GRID ON THE PLANE.  THE FUNCTIONS IN THE PARTITION
C        OF UNITY ARE UNIVARIATE PIECEWISE HERMITE CUBIC POLYNOMIALS.
C
C     CAUTIONS
C        THE USER SHOULD BE AWARE THAT FOR SOME DATA THE INTERPOLATION
C        FUNCTION MAY BE ILL-BEHAVED.  SOME INVESTIGATION OF ITS
C        BEHAVIOR FOR THE TYPE OF DATA TO BE INPUT SHOULD BE UNDERTAKEN
C        BEFORE IMBEDDING ANY SCHEME FOR SCATTERED DATA INTERPOLATION
C        INTO ANOTHER PROGRAM.
C
C     DESCRIPTION OF ARGUMENTS
C
C        MODE - INPUT.  INDICATES THE STATUS OF THE CALCULATION.
C                 = 1,  SET UP THE PROBLEM.  COMPUTE THE COEFFICIENTS
C                       FOR THE LOCAL APPROXIMATIONS BY THIN PLATE
C                       SPLINES, AND RETURN THE GRID OF INTERPOLATED
C                       FUNCTION VALUES INDICATED BY NXO, XO, NYO, YO
C                       IN THE ARRAY FO.
C                 = 2,  THIS MODE VALUE IS A CONVENIENCE FOR USERS WHO
C                       WISH TO CALL THE ROUTINE TO EVALUATE THE
C                       SURFACE REPEATEDLY ON DIFFERENT GRIDS OF
C                       POINTS.  A CALL TO LOTPS WITH MODE = 1 HAS
C                       BEEN MADE PREVIOUSLY, NOW CALCULATE
C                       THE GRID OF INTERPOLATED POINTS INDICATED
C                       BY NXO, XO, NYO, YO IN IN THE ARRAY FO.  THE
C                       PROGRAM ASSUMES THAT THE ARRAYS XI, YI, IWK,
C                       AND WK ARE UNCHANGED FROM THE PREVIOUS CALL.
C        NPPR - INPUT.  DESIRED AVERAGE NUMBER OF POINTS PER REGION.
C                       THE SUGGESTED VALUE FOR THE NOVICE USER IS TEN,
C                       WHICH USUALLY GIVES GOOD RESULTS.  THIS PAR-
C                       AMETER HAS TO DO WITH THE LOCAL PROPERTY OF THE
C                       SURFACE.  THE INFLUENCE REGION OF A POINT HAS
C                       AREA WHICH IS ROUGHLY PROPORTIONAL TO NPPR.
C                       UNDER CERTAIN CONDITIONS, SUCH AS TO PRESERVE
C                       ROTATIONAL INVARIANCE, OR TO FORCE CERTAIN
C                       SETS OF POINTS TO BELONG TO THE SAME REGION,
C                       THE USER MAY SPECIFY HIS OWN GRID LINES.
C                       IF THE USER WISHES TO SPECIFY HIS OWN GRID LINES
C                       X TILDA AND Y TILDA, HE MAY DO SO BY SETTING
C                       NPPR = 0 AND SETTING NECESSARY VALUES IN THE
C                       ARRAYS IWK AND WK, AS NOTED BELOW.  DATA WHICH
C                       HAS A POOR DISTRIBUTION OVER THE REGION OF INT-
C                       EREST SHOULD PROBABLY HAVE THE GRID SPECIFIED.
C                       THIS IS ALSO ADVISABLE IF THE X-Y POINTS OCCUR
C                       ALONG LINES.  SEE THE REFERENCE FOR ADDITIONAL
C                       DETAILS.
C        NPI  - INPUT.  NUMBER OF INPUT DATA POINTS.
C        XI   - \
C        YI   - INPUT ARRAYS.  THE DATA POINTS (XI,YI,FI), I=1,...,NPI.
C        FI   - /
C        NXO  - INPUT.  THE NUMBER OF XO VALUES AT WHICH THE INTERP-
C                       OLATION FUNCTION IS TO BE CALCULATED.
C        XO   - INPUT ARRAY.  THE VALUES OF X AT WHICH THE INTERPOLATION
C                       FUNCTION IS TO BE CALCULATED.  THESE SHOULD
C                       BE IN INCREASING ORDER FOR MOST EFFICIENT
C                       EVALUATION, HOWEVER, THEY ONLY NEED TO BE
C                       MONOTONIC.
C        NYO  - INPUT.  THE NUMBER OF YO VALUES AT WHICH THE INTERP-
C                       OLATION FUNCTION IS TO BE CALCULATED.
C        YO   - INPUT ARRAY.  THE VALUES OF Y AT WHICH THE INTERPOLATION
C                       FUNCTION IS TO BE CALCULATED.  THESE SHOULD
C                       BE IN INCREASING ORDER FOR MOST EFFICIENT
C                       EVALUATION, HOWEVER, THEY ONLY NEED TO BE
C                       MONOTONIC.
C        IWK  - INPUT/OUTPUT ARRAY.  THIS ARRAY IS OUTPUT WHEN MODE = 1
C                       AND IS INPUT WHEN MODE = 2.  THIS MUST BE
C                       AN ARRAY DIMENSIONED APPROXIMATELY 7*NPI.  THE
C                       EXACT DIMENSION IS NOT KNOWN A PRIORI, BUT
C                       WILL BE RETURNED AS THE VALUE OF NIWKU.
C                       WHEN NPPR IS INPUT AS ZERO THE USER MUST
C                       SPECIFY THE NUMBER OF VERTICAL GRID LINES (THE
C                       NUMBER OF X TILDA VALUES) IN IWK(1) AND THE
C                       NUMBER OF HORIZONTAL GRID LINES (THE NUMBER OF
C                       Y TILDA VALUES) IN IWK(2).
C        NIWK - INPUT.  ON ENTRY WITH MODE = 1 THIS MUST BE SET TO THE
C                       DIMENSION OF THE ARRAY IWK IN THE CALLING
C                       PROGRAM.
C        NIWKU- OUTPUT.  THE ACTUAL NUMBER OF LOCATIONS NEEDED IN THE
C                       ARRAY IWK.
C        WK   - INPUT/OUTPUT ARRAY.  THIS ARRAY IS OUTPUT WHEN MODE = 1
C                       AND IS INPUT WHEN MODE = 2.  THIS MUST BE AN
C                       ARRAY DIMENSIONED APPROXIMATELY 7*NPI PLUS
C                       THE NUMBER NEEDED TO SET UP AND SOLVE THE SYSTEM
C                       OF EQUATIONS FOR THE LOCAL APPROXIMATIONS.  FOR
C                       NPPR NONZERO THIS WILL BE ABOUT 2.5*NPPR*NPPR
C                       PLUS 11*NPPR.  THE EXACT DIMENSION IS NOT KNOWN
C                       A PRIORI, BUT WILL BE RETURNED AS THE VALUE OF
C                       NWKU.
C                       WHEN NPPR IS INPUT AS ZERO THE USER MUST SPECIFY
C                       THE VALUES OF X TILDA AND Y TILDA AS FOLLOWS.
C                       WK(2), ... , WK(NXG+1) ARE THE NXG (= IWK(1))
C                       X GRID VALUES, X(I) TILDA, IN INCREASING ORDER.
C                       TYPICALLY WK(1) = MIN X(I), ALTHOUGH IT NEED
C                       NOT BE.  WK(1) MUST BE LESS THAN OR EQUAL TO
C                       WK(2), AND SHOULD BE LESS THAN OR EQUAL TO
C                       MIN X(I).  WK(NXG+2) IS USUALLY MAX X(I), AL-
C                       THOUGH IT NEED NOT BE.  WK(NXG+2) MUST BE
C                       GREATER THAN WK(NXG+1), AND SHOULD BE GREATER
C                       THAN OR EQUAL TO MAX X(I).
C                       THE VALUES OF WK(NXG+3), ... , WK(NXG+NYG+4)
C                       ARE THE Y GRID VALUES, Y(I) TILDA, AND MUST
C                       SATISFY DUAL CONDITIONS.
C        NWK  - INPUT.  ON ENTRY WITH MODE = 1 THIS MUST BE SET TO THE
C                       DIMENSION OF THE ARRAY WK IN THE CALLING
C                       PROGRAM.
C        NWKU - OUTPUT.  THE ACTUAL NUMBER OF LOCATIONS NEEDED IN THE
C                       ARRAY WK.
C        FO   - OUTPUT ARRAY.  VALUES OF THE INTERPOLATION FUNCTION AT
C                       THE GRID OF POINTS INDICATED BY NXO, XO, NYO, YO
C                       FO IS ASSUMED TO BE DIMENSIONED (NXO,NYO) IN THE
C                       CALLING PROGRAM.
C        KER  - OUTPUT.  RETURN INDICATOR.
C                 = 0,  NORMAL RETURN.
C                 = NONZERO, ERROR CONDITION ENCOUNTERED.
C
C     ERROR MESSAGES
C        NO. 1   FATAL         SINGULAR MATRIX IN THE CALCULATION OF
C                              LOCAL THIN PLATE SPLINES.  TRY LARGER
C                              VALUE FOR NPPR AND/OR MINPTS.  (MINPTS
C                              IS IN SUBROUTINE LOLIP.)
C        NO. 2   RECOVERABLE   FIRST CALL TO LOTPS MUST BE WITH MODE=1
C        NO. 3   FATAL         PREVIOUS ERROR RETURN FROM SUBROUTINE
C                              LOCAL NOT CORRECTED.
C        NO. 4   FATAL         ARRAY IWK AND/OR WK NOT DIMENSIONED LARGE
C                              ENOUGH.  REDIMENSION AS GIVEN BY NIWKU
C                              AND NWKU.
C        NO. 5   RECOVERABLE   MODE IS OUT OF RANGE.
C
C     SUBROUTINES USED
C
C        THIS PACKAGE:  LOGRD, LOLIP, LOCAL, LOEVL.
C        LINPACK: SGECO, SGESL
C        SLATEC:  SSORT, XERROR
C
C***END PROLOGUE
      DIMENSION XI(NPI), YI(NPI), FI(NPI), IWK(NIWK), WK(NWK),
     1 XO(NXO), YO(NYO), FO(NXO,NYO)
      DATA KERO/-1/
      IF (MODE.LT.1.OR.MODE.GT.2) GO TO 220
      KER = 0
C
C     ON INITIAL ENTRY MODE = 1, THE GRID LINES ARE SET UP,
C     LOCAL INTERPOLATION POINTS ARE DETERMINED AND LOCAL APPROXIMATIONS
C     ARE COMPUTED.
C
      IF (MODE.EQ.2) GO TO 140
      NXGWK = 1
      NPWK = 3
      IF (NPPR.LE.0) GO TO 100
      NXG = SQRT(4.*REAL(NPI)/REAL(NPPR))-.5
      NXG = MAX0(NXG,1)
      NYG = NXG
      IWK(1) = NXG
      IWK(2) = NYG
      GO TO 120
  100 NXG = IWK(1)
      NYG = IWK(2)
  120 IALWK = NXG+NYG+5
      IABWK = IALWK + 3*NXG*NYG
      NYGWK = NXG+3
      MPWK = NXG*NYG+4
C
      IF(NPPR.LE.0)GO TO 130
      CALL LOGRD(XI,NPI,NXG,WK(NXGWK),WK(IALWK))
      CALL LOGRD(YI,NPI,NYG,WK(NYGWK),WK(IALWK))
  130 CONTINUE
C
C     DETERMINE THE LOCAL INTERPOLATION POINTS FOR THE REGIONS.
      MWK = NWK - MPWK + 1
      CALL LOLIP (NXG,WK(NXGWK),NYG,WK(NYGWK),NPI,XI,YI,IWK(NPWK),
     1IWK(MPWK),MWK,NMAX,WK(IALWK))
      NCFM = IABWK +IWK(MPWK - 1)-1
      NWKU = NCFM + (NMAX+3)*(NMAX+5) - 1
      NIPVT = NXG*NYG+3+IWK(MPWK-1)
      NIWKU = NIPVT + NMAX + 2
      IF (NIWKU.GT.NIWK) GO TO 200
      IF (NWKU.GT.NWK) GO TO 200
C
C     COMPUTE THE LOCAL APPROXIMATIONS.
      CALL LOCAL (XI,YI,FI,NXG,WK(NXGWK),NYG,WK(NYGWK),IWK(NPWK),
     1 IWK(MPWK),WK(IALWK),WK(IABWK),WK(NCFM),IWK(NIPVT),IER)
      KERO = IER
      IF (IER.NE.0) GO TO 160
  140 IF (KERO.NE.0) GO TO 180
C
C     COMPUTE THE FUNCTION VALUES ON THE DESIRED GRID OF POINTS.
C
      CALL LOEVL (XI,YI,IWK(1),WK(NXGWK),IWK(2),WK(NYGWK),IWK(NPWK),
     1 IWK(MPWK),WK(IALWK),WK(IABWK),NXO,XO,NYO,YO,FO)
      RETURN
C
C     ERROR RETURNS
C
  160 KER = IER
CCCCC IF(IER.NE.0)CALL XERROR('LOTPS-SINGULAR MATRIX IN LOCAL; INCREAS
CCCCC1E NPPR OR SPECIFY OWN GRID LINES',71,1,2)
      RETURN
  180 KER = 3
      IF (KERO.LT.0) GO TO 190
CCCCC  CALL XERROR('LOTPS-PREVIOUS ERROR FROM SUBROUTINE LOCAL HAS NOT
CCCCC1BEEN CORRECTED.',65,3,2)
      RETURN
  190 KER = 2
CCCCC CALL XERROR('LOTPS-FIRST CALL TO LOTPS MUST BE WITH MODE = 1',
CCCCC1 47,2,1)
      RETURN
  200 KER = 4
CCCCC CALL XERROR('LOTPS-WORK ARRAYS IWK AND/OR WK NOT DIMENSIONED LAR
CCCCC1GE ENOUGH',60,4,2)
      RETURN
  220 KER = 5
CCCCC CALL XERROR('LOTPS-MODE IS OUT OF RANGE.  MUST BE 1 OR 2',43,5,
CCCCC1 1)
      RETURN
      END
      SUBROUTINE LOWESS(Y,X,N,ALOWFR,ALOWDG,
CCCCC MARCH 1994.  ADD ARGUMENT.
CCCCC SUBROUTINE LOWESS(Y,X,N,ALOWFR,
     1XTEMP1,XTEMP2,YS,XS,WH,WV,XTEMP7,MAXNXT,
     1PRED2,RES2,ISUBRO,IBUGA3,IERROR)
C
C     PURPOSE--THIS ROUTINE PERFORMS A LOWESS FIT/SMOOTH
C              OF THE DATA IN Y AND X
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           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--88/2
C     ORIGINAL VERSION--FEBRUARY  1988.
C     UPDATED         --MAY       1989.  ERROR BRANCHES AFTER CALLS
C     UPDATED         --MARCH     1994.  SUPPORT QUADRATIC LOWESS FITS
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 ISUBRO
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 ISTEPN
C
C---------------------------------------------------------------------
C
      DIMENSION Y(*)
      DIMENSION X(*)
      DIMENSION XTEMP1(*)
      DIMENSION XTEMP2(*)
      DIMENSION YS(*)
      DIMENSION XS(*)
      DIMENSION WH(*)
      DIMENSION WV(*)
      DIMENSION XTEMP7(*)
      DIMENSION PRED2(*)
      DIMENSION RES2(*)
C
C---------------------------------------------------------------------
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='LOWE'
      ISUBN2='SS  '
C
      IERROR='NO'
C
      IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'WESS')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('**** AT THE BEGINNING OF LOWESS--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)ISUBRO,IBUGA3,IERROR
   52 FORMAT('ISUBRO,IBUGA3,IERROR = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,61)N,ALOWFR
   61 FORMAT('N,ALOWFR = ',I8,E15.7)
      CALL DPWRST('XXX','BUG ')
      IF(N.LE.0)GOTO64
      DO62I=1,N
      WRITE(ICOUT,63)I,Y(I),X(I)
   63 FORMAT('I,Y(I),X(I) = ',I8,2E15.7)
      CALL DPWRST('XXX','BUG ')
   62 CONTINUE
   64 CONTINUE
   90 CONTINUE
C
C               ***********************************
C               **  STEP 11--                    **
C               **  SORT THE DATA                **
C               **  ACCORDING TO THE HORIZONTAL  **
C               **  AXIS VARIABLE.               **
C               **  RECORD THE ORDER OF THE      **
C               **  INCOMING DATA.               **
C               ***********************************
C
      ISTEPN='11'
      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      CALL SORTC(X,Y,N,XS,YS)
C
      DO1100I=1,N
      XTEMP1(I)=I
 1100 CONTINUE
      CALL SORTC(X,XTEMP1,N,XS,XTEMP7)
C
      AN=N
C
C               ***********************************************
C               **  STEP 12--                                **
C               **  COMPUTE THE TOTAL                        **
C               **  NUMBER OF NEIGHBORS IN  A NEIGHBORHOOD   **
C               ***********************************************
C
      ISTEPN='12'
      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      NN=INT(ALOWFR*AN+0.5)
      ANN=NN
C
C               ***********************************************
C               **  STEP 21--                                **
C               **  SET THE VERTICAL (ROBUSTNESS) WEIGHTS    **
C               **  EQUAL TO UNITY PRIOR TO COMPUTING        **
C               **  INITIAL PREDICTED VALUES                 **
C               ***********************************************
C
      ISTEPN='21'
      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      DO2100I=1,N
      WV(I)=1.0
 2100 CONTINUE
C
C               ************************************************
C               **  STEP 22--                                 **
C               **  LOOP THROUGH EACH OF THE                  **
C               **  N HORIZONTAL DATA POINTS                  **
C               **  FROM SMALLEST TO LARGEST.                 **
C               **  FOR EACH DATA POINT--                     **
C               **     1) COMPUTE NEIGHBORHOOD LIMITS         **
C               **     2) COMPUTE HORIZONTAL WEIGHTS          **
C               **        FOR EACH NEIGHBORHOOD POINT         **
C               **     3) COMPUTE A INITIAL PREDICTED VALUE   **
C               **        FOR THAT POINT VIA A                **
C               **        WEIGHTED LINEAR FIT                 **
C               **        USING HORIZONTAL WEIGHTS ONLY.      **
C               ************************************************
C
      ISTEPN='22'
      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      DO2200IT=1,N
C
      CALL NEIGH(IT,NN,XS,N,I1,I2,ISUBRO,IBUGA3,IERROR)
      IF(IERROR.EQ.'YES')GOTO9000
C
      DEL1=XS(IT)-XS(I1)
      DEL2=XS(I2)-XS(IT)
      XMAXHF=DEL1
      IF(DEL2.GT.DEL1)XMAXHF=DEL2
      CALL WEIGHH(IT,I1,I2,XS,N,XMAXHF,
     1WH,ISUBRO,IBUGA3,IERROR)
      IF(IERROR.EQ.'YES')GOTO9000
C
      I3=IT
      I4=IT
CCCCC MARCH 1994.  ADD CHECK FOR QUADRATIC DEGREE.
      IF(ALOWDG.GT.1.5)THEN
      CALL QUAFIT(IT,I1,I2,XS,YS,WH,WV,N,XMAXHF,I3,I4,
     1ALPHA,BETA1,BETA2,PRED2,RES2,ISUBRO,IBUGA3,IERROR)
      ELSE
      CALL LINEAR(IT,I1,I2,XS,YS,WH,WV,N,XMAXHF,I3,I4,
     1ALPHA,BETA,PRED2,RES2,ISUBRO,IBUGA3,IERROR)
      ENDIF
      IF(IERROR.EQ.'YES')GOTO9000
C
 2200 CONTINUE
C
C               *************************************************
C               **  STEP 31--                                  **
C               **  BASED ON THE INITIAL PREDICTED VALUES      **
C               **  AND THE CONSEQUENTIAL RESIDUALS,           **
C               **  COMPUTE VERTICAL (ROBUSTNESS) WEIGHTS      **
C               **  FOR ALL N DATA POINTS                      **
C               *************************************************
C
      ISTEPN='31'
      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      CALL WEIGHV(RES2,N,XTEMP1,XTEMP2,MAXNXT,
     1WV,ISUBRO,IBUGA3,IERROR)
      IF(IERROR.EQ.'YES')GOTO9000
C
C               ************************************************
C               **  STEP 32--                                 **
C               **  AGAIN LOOP THROUGH EACH OF THE            **
C               **  N HORIZONTAL DATA POINTS                  **
C               **  FROM SMALLEST TO LARGEST.                 **
C               **  FOR EACH DATA POINT--                     **
C               **     1) COMPUTE NEIGHBORHOOD LIMITS         **
C               **     2) COMPUTE HORIZONTAL WEIGHTS          **
C               **        FOR EACH NEIGHBORHOOD POINT         **
C               **     3) COMPUTE A FINAL PREDICTED VALUE     **
C               **        FOR THAT POINT VIA A                **
C               **        WEIGHTED LINEAR FIT                 **
C               **        USING BOTH THE HORIZONTAL WEIGHTS   **
C               **        AND THE VERTICAL WEIGHTS            **
C               ************************************************
C
      ISTEPN='32'
      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      DO3200IT=1,N
C
      CALL NEIGH(IT,NN,XS,N,I1,I2,ISUBRO,IBUGA3,IERROR)
      IF(IERROR.EQ.'YES')GOTO9000
C
      DEL1=XS(IT)-XS(I1)
      DEL2=XS(I2)-XS(IT)
      XMAXHF=DEL1
      IF(DEL2.GT.DEL1)XMAXHF=DEL2
      CALL WEIGHH(IT,I1,I2,XS,N,XMAXHF,
     1WH,ISUBRO,IBUGA3,IERROR)
      IF(IERROR.EQ.'YES')GOTO9000
C
      I3=IT
      I4=IT
CCCCC MARCH 1994.  ADD CHECK FOR QUADRATIC DEGREE.
      IF(ALOWDG.GT.1.5)THEN
      CALL QUAFIT(IT,I1,I2,XS,YS,WH,WV,N,XMAXHF,I3,I4,
     1ALPHA,BETA1,BETA2,PRED2,RES2,ISUBRO,IBUGA3,IERROR)
      ELSE
      CALL LINEAR(IT,I1,I2,XS,YS,WH,WV,N,XMAXHF,I3,I4,
     1ALPHA,BETA,PRED2,RES2,ISUBRO,IBUGA3,IERROR)
      ENDIF
      IF(IERROR.EQ.'YES')GOTO9000
C
 3200 CONTINUE
C
      DO3300I=1,N
      XTEMP1(I)=PRED2(I)
      XTEMP2(I)=RES2(I)
 3300 CONTINUE
C
      DO3400I=1,N
      J=XTEMP7(I)+0.5
      PRED2(J)=XTEMP1(I)
      RES2(J)=XTEMP2(I)
 3400 CONTINUE
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'WESS')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('**** AT THE END       OF LOWESS--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)ISUBRO,IBUGA3,IERROR
 9012 FORMAT('ISUBRO,IBUGA3,IERROR = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9021)N,ALOWFR,NN
 9021 FORMAT('N,ALOWFR,NN = ',I8,E15.7,I8)
      CALL DPWRST('XXX','BUG ')
      IF(N.LE.0)GOTO9024
      DO9022I=1,N
      WRITE(ICOUT,9023)I,Y(I),X(I),PRED2(I),RES2(I)
 9023 FORMAT('I,Y(I),X(I),PRED2(I),RES2(I) = ',I8,4E11.3)
      CALL DPWRST('XXX','BUG ')
 9022 CONTINUE
 9024 CONTINUE
      IF(N.LE.0)GOTO9034
      DO9032I=1,N
      WRITE(ICOUT,9033)I,YS(I),XS(I),WH(I),WV(I),PRED2(I),RES2(I)
 9033 FORMAT('I,YS(I),XS(I),WH(I),WV(I),PRED2(I),RES2(I) = ',
     1I8,6E11.3)
      CALL DPWRST('XXX','BUG ')
 9032 CONTINUE
 9034 CONTINUE
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE LOWHIN(X,N,IWRITE,XTEMP,MAXNXT,XLOWHI,IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE
C              SAMPLE LOWER HINGE
C              OF THE DATA IN THE INPUT VECTOR X.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF
C                                (UNSORTED OR SORTED) OBSERVATIONS.
C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR X.
C     OUTPUT ARGUMENTS--XLOWHI = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED SAMPLE LOWER HINGE.
C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
C             SAMPLE LOWER HINGE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--SORT.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           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.6
C     ORIGINAL VERSION--JUNE      1981.
C     UPDATED         --AUGUST    1981.
C     UPDATED         --MAY       1982.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
      DIMENSION XTEMP(*)
C
C---------------------------------------------------------------------
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='LOWH'
      ISUBN2='IN  '
C
      IERROR='NO'
C
      IARG1=0
      IARG2=0
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 LOWHIN--')
      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 LOWER HINGE  **
C               ***************************
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      AN=N
C
      IF(1.LE.N.AND.N.LE.MAXNXT)GOTO119
      IERROR='YES'
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,111)
  111 FORMAT('***** ERROR IN LOWHIN--')
      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 LOWER HINGE IS TO BE COMPUTED')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,115)MAXNXT
  115 FORMAT('      MUST BE BETWEEN 1 AND ',I8,' (INCLUSIVELY).')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,116)
  116 FORMAT('      SUCH WAS NOT THE CASE HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,117)N
  117 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8,
     1'.')
      CALL DPWRST('XXX','BUG ')
      GOTO9000
  119 CONTINUE
C
      IF(N.EQ.1)GOTO120
      GOTO129
  120 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,121)
  121 FORMAT('***** NON-FATAL DIAGNOSTIC IN LOWHIN--',
     1'THE SECOND INPUT ARGUMENT (N) HAS THE VALUE 1')
      CALL DPWRST('XXX','BUG ')
      XLOWHI=X(1)
      GOTO9000
  129 CONTINUE
C
      HOLD=X(1)
      DO135I=2,N
      IF(X(I).NE.HOLD)GOTO139
  135 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,136)HOLD
  136 FORMAT('***** NON-FATAL DIAGNOSTIC IN LOWHIN--',
     1'THE FIRST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      XLOWHI=HOLD
      GOTO9000
  139 CONTINUE
C
  190 CONTINUE
C
C               ********************************
C               **  STEP 2--                  **
C               **  COMPUTE THE LOWER HINGE.  **
C               ********************************
C
      CALL SORT(X,N,XTEMP)
C
      N2=(N+1)/2
      IARG1=(N2+1)/2
      IARG2=(N2+1)-IARG1
      XLOWHI=(XTEMP(IARG1)+XTEMP(IARG2))/2.0
C
C               j******************************
C               **  STEP 3--                 **
C               **  WRITE OUT A LINE         **
C               **  OF SUMMARY INFORMATION.  **
C               *******************************
C
      IF(IFEEDB.EQ.'OFF')GOTO890
      IF(IWRITE.EQ.'OFF')GOTO890
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,811)N,XLOWHI
  811 FORMAT('THE LOWER HINGE 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 LOWHIN--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IBUGA3,IERROR
 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)N
 9013 FORMAT('N = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9014)IARG1,IARG2
 9014 FORMAT('IARG1,IARG2 = ',2I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9015)XLOWHI
 9015 FORMAT('XLOWHI = ',E15.7)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE LOWQUA(X,N,IWRITE,XTEMP,MAXNXT,XLOWQU,IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE
C              SAMPLE LOWER QUARTILE
C              OF THE DATA IN THE INPUT VECTOR X.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF
C                                (UNSORTED OR SORTED) OBSERVATIONS.
C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR X.
C     OUTPUT ARGUMENTS--XLOWQU = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED SAMPLE LOWER QUARTILE.
C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
C             SAMPLE LOWER QUARTILE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--SORT.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           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.6
C     ORIGINAL VERSION--JUNE      1981.
C     UPDATED         --AUGUST    1981.
C     UPDATED         --MAY       1982.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
      DIMENSION XTEMP(*)
C
C---------------------------------------------------------------------
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='LOWQ'
      ISUBN2='UA  '
C
      IERROR='NO'
C
      NI=0
      NIP1=0
C
      ANI=0.0
      A2NI=0.0
      REM=0.0
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 LOWQUA--')
      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 LOWER QUARTILE  **
C               ******************************
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      AN=N
C
      IF(1.LE.N.AND.N.LE.MAXNXT)GOTO119
      IERROR='YES'
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,111)
  111 FORMAT('***** ERROR IN LOWQUA--')
      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 LOWER QUARTILE IS TO BE COMPUTED')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,115)MAXNXT
  115 FORMAT('      MUST BE BETWEEN 1 AND ',I8,' (INCLUSIVELY).')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,116)
  116 FORMAT('      SUCH WAS NOT THE CASE HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,117)N
  117 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8,
     1'.')
      CALL DPWRST('XXX','BUG ')
      GOTO9000
  119 CONTINUE
C
      IF(N.EQ.1)GOTO120
      GOTO129
  120 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,121)
  121 FORMAT('***** NON-FATAL DIAGNOSTIC IN LOWQUA--',
     1'THE SECOND INPUT ARGUMENT (N) HAS THE VALUE 1')
      CALL DPWRST('XXX','BUG ')
      XLOWQU=X(1)
      GOTO9000
  129 CONTINUE
C
      HOLD=X(1)
      DO135I=2,N
      IF(X(I).NE.HOLD)GOTO139
  135 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,136)HOLD
  136 FORMAT('***** NON-FATAL DIAGNOSTIC IN LOWQUA--',
     1'THE FIRST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      XLOWQU=HOLD
      GOTO9000
  139 CONTINUE
C
  190 CONTINUE
C
C               ***********************************
C               **  STEP 2--                     **
C               **  COMPUTE THE LOWER QUARTILE.  **
C               ***********************************
C
      CALL SORT(X,N,XTEMP)
C
      P=0.25
C
      ANI=P*(AN+1.0)
      NI=ANI
      A2NI=NI
      REM=ANI-A2NI
      NIP1=NI+1
      IF(NI.LE.1)NI=1
      IF(NI.GE.N)NI=N
      IF(NIP1.LE.1)NIP1=1
      IF(NIP1.GE.N)NIP1=N
      XLOWQU=REM*XTEMP(NI)+(1.0-REM)*XTEMP(NIP1)
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,XLOWQU
  811 FORMAT('THE LOWER QUARTILE OF THE ',I8,' OBSERVATIONS = ',
     1E15.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 LOWQUA--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IBUGA3,IERROR
 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)N
 9013 FORMAT('N = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9014)ANI,NI,A2NI,REM,NIP1
 9014 FORMAT('ANI,NI,A2NI,REM,NIP1 = ',E15.7,I8,E15.7,E15.7,I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9015)XLOWQU
 9015 FORMAT('XLOWQU = ',E15.7)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      LOGICAL FUNCTION LSAME( CA, CB )
*
*  -- LAPACK auxiliary routine (version 1.1) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     February 29, 1992
*
*     .. Scalar Arguments ..
      CHARACTER          CA, CB
*     ..
*
*  Purpose
*  =======
*
*  LSAME returns .TRUE. if CA is the same letter as CB regardless of
*  case.
*
*  Arguments
*  =========
*
*  CA      (input) CHARACTER*1
*  CB      (input) CHARACTER*1
*          CA and CB specify the single characters to be compared.
*
*     .. Intrinsic Functions ..
      INTRINSIC          ICHAR
*     ..
*     .. Local Scalars ..
      INTEGER            INTA, INTB, ZCODE
*     ..
*     .. Executable Statements ..
*
*     Test if the characters are equal
*
      LSAME = CA.EQ.CB
      IF( LSAME )
     $   RETURN
*
*     Now test for equivalence if both characters are alphabetic.
*
      ZCODE = ICHAR( 'Z' )
*
*     Use 'Z' rather than 'A' so that ASCII can be detected on Prime
*     machines, on which ICHAR returns a value with bit 8 set.
*     ICHAR('A') on Prime machines returns 193 which is the same as
*     ICHAR('A') on an EBCDIC machine.
*
      INTA = ICHAR( CA )
      INTB = ICHAR( CB )
*
      IF( ZCODE.EQ.90 .OR. ZCODE.EQ.122 ) THEN
*
*        ASCII is assumed - ZCODE is the ASCII code of either lower or
*        upper case 'Z'.
*
         IF( INTA.GE.97 .AND. INTA.LE.122 ) INTA = INTA - 32
         IF( INTB.GE.97 .AND. INTB.LE.122 ) INTB = INTB - 32
*
      ELSE IF( ZCODE.EQ.233 .OR. ZCODE.EQ.169 ) THEN
*
*        EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or
*        upper case 'Z'.
*
         IF( INTA.GE.129 .AND. INTA.LE.137 .OR.
     $       INTA.GE.145 .AND. INTA.LE.153 .OR.
     $       INTA.GE.162 .AND. INTA.LE.169 ) INTA = INTA + 64
         IF( INTB.GE.129 .AND. INTB.LE.137 .OR.
     $       INTB.GE.145 .AND. INTB.LE.153 .OR.
     $       INTB.GE.162 .AND. INTB.LE.169 ) INTB = INTB + 64
*
      ELSE IF( ZCODE.EQ.218 .OR. ZCODE.EQ.250 ) THEN
*
*        ASCII is assumed, on Prime machines - ZCODE is the ASCII code
*        plus 128 of either lower or upper case 'Z'.
*
         IF( INTA.GE.225 .AND. INTA.LE.250 ) INTA = INTA - 32
         IF( INTB.GE.225 .AND. INTB.LE.250 ) INTB = INTB - 32
      END IF
      LSAME = INTA.EQ.INTB
*
*     RETURN
*
*     End of LSAME
*
      END
      SUBROUTINE LSNCDF(X,ALMBDA,SD,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE LOG-SKEW-NORMAL DISTRIBUTION
C              WITH SHAPE PARAMETERS = LAMBDA AND SD (SD IS THE
C              SCALE PARAMETER OF THE CORRESPONDING NORMAL
C              DISTRIBUTION).
C              THIS DISTRIBUTION IS DEFINED FOR POSITIVE X AND HAS
C              THE CUMULATIVE DISTRIBUTION FUNCTION
C                 LSNCDF(X,LAMBDA,SD) = SNCDF(LOG(X)/SD,LAMBDA)
C              WITH SNPDF DENOTING THE SKEW-NORMAL PROBABILITY
C              DENSITY FUNCTION.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE NON-NEGATIVE.
C                     --ALMBDA = THE FIRST SHAPE PARAMETER
C                     --SD     = THE SECOND SHAPE PARAMETER
C     OUTPUT ARGUMENTS--PDF    = THE SINGLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE PDF FOR THE LOG-SKEWED-NORMAL DISTRIBUTION
C             WITH SHAPE PARAMETERS = LAMBDA AND SD.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--SNCDF
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME I", SECOND EDITION,
C                 JOHN WILEY, 1994, PAGE 454.
C               --"Log-Skew-Normal and Log-Skew-t Distributions as
C                 Models for Family Income Data", Azzalini, Cappello,
C                 and Kotz, paper downloaded from Azzalini's web
C                 site.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           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
C---------------------------------------------------------------------
C
      CHARACTER*4 ISKNDF
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               **  CHECK INPUT ARGUMENTS FOR ERRORS **
C               ***************************************
C
      IF(X.LE.0.0)THEN
        CDF=0.0
        GOTO9000
      ENDIF
      IF(SD.LE.0.0)THEN
        WRITE(ICOUT,6)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,45)SD
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9000
      ENDIF
    6 FORMAT('**** ERROR: ARGUMENT FOR THE SECOND SHAPE PARAMETER OF ',
     1       'THE LOG-SKEW-NORMAL CDF IS NON-POSITIVE.')
   45 FORMAT('     VALUE OF THE ARGUMENT IS ',G15.7)
C
C               ************************************
C               **  STEP 2--                      **
C               **  COMPUTE THE DENSITY FUNCTION  **
C               ************************************
C
      ISKNDF='DEFA'
      CALL SNCDF(LOG(X)/SD,ALMBDA,ISKNDF,CDF)
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE LSNPDF(X,ALMBDA,SD,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE LOG-SKEW-NORMAL DISTRIBUTION
C              WITH SHAPE PARAMETERS = LAMBDA AND SD (SD IS THE
C              SCALE PARAMETER OF THE CORRESPONDING NORMAL
C              DISTRIBUTION).
C              THIS DISTRIBUTION IS DEFINED FOR POSITIVE X AND HAS
C              THE PROBABILITY DENSITY FUNCTION
C                 LSNPDF(X,LAMBDA,SD) = (1/(SD*X))*
C                                       SNPDF(LOG(X)/SD,LAMBDA)
C              WITH SNPDF DENOTING THE SKEW-NORMAL PROBABILITY
C              DENSITY FUNCTION.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE NON-NEGATIVE.
C                     --ALMBDA = THE FIRST SHAPE PARAMETER
C                     --SD     = THE SECOND SHAPE PARAMETER
C     OUTPUT ARGUMENTS--PDF    = THE SINGLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE PDF FOR THE LOG-SKEWED-NORMAL DISTRIBUTION
C             WITH SHAPE PARAMETER = LAMBDA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NODPDF, NODCDF..
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME I", SECOND EDITION,
C                 JOHN WILEY, 1994, PAGE 454.
C               --"Log-Skew-Normal and Log-Skew-t Distributions as
C                 Models for Family Income Data", Azzalini, Cappello,
C                 and Kotz, paper downloaded from Azzalini's web
C                 site.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           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
      DOUBLE PRECISION DX
      DOUBLE PRECISION DLMBDA
      DOUBLE PRECISION DSD
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      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-----DATA STATEMENTS-------------------------------------------------
C
C-----START POINT-----------------------------------------------------
C
C               ***************************************
C               **  STEP 1--                         **
C               **  CHECK INPUT ARGUMENTS FOR ERRORS **
C               ***************************************
C
      IF(X.EQ.0.0)THEN
        PDF=0.0
        GOTO9000
      ELSEIF(X.LT.0.0)THEN
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,45)X
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9000
      ENDIF
      IF(SD.LE.0.0)THEN
        WRITE(ICOUT,6)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,45)SD
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9000
      ENDIF
    5 FORMAT('**** ERROR: ARGUMENT FOR LOG-SKEW-NORMAL DISTRIBUTION ',
     1       'IS NON-POSITIVE.')
    6 FORMAT('**** ERROR: ARGUMENT FOR THE SECOND SHAPE PARAMETER OF ',
     1       'THE LOG-SKEW-NORMAL DISTRIBUTION IS NON-POSITIVE.')
   45 FORMAT('     VALUE OF THE ARGUMENT IS ',G15.7)
C
C               ************************************
C               **  STEP 2--                      **
C               **  COMPUTE THE DENSITY FUNCTION  **
C               ************************************
C
      DX=DBLE(X)
      DLMBDA=DBLE(ALMBDA)
      DSD=DBLE(SD)
C
      CALL NODCDF(DLOG(DX)*DLMBDA/DSD,DTERM1)
      CALL NODPDF(DLOG(DX)/DSD,DTERM2)
      DPDF=2.0D0*DTERM1*DTERM2
      DPDF=(1.0D0/(DSD*DX))*DPDF
      PDF=REAL(DPDF)
      GOTO9000
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE LSNPPF(P,ALMBDA,SD,PPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE LOG-SKEW-NORMAL DISTRIBUTION
C              WITH SHAPE PARAMETERS = LAMBDA AND SD.
C              THIS DISTRIBUTION IS DEFINED FOR ALL X AND THE
C              PERCENT POINT FUNCTION IS COMPUTED BY
C              TAKING THE EXPONENT OF THE SKEW-NORMAL PPF FUNCTION.
C     INPUT  ARGUMENTS--P      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE PERCENT POINT
C                                FUNCTION IS TO BE EVALUATED.
C                     --ALMBDA = THE FIRST SHAPE PARAMETER
C                     --SD     = THE SECOND SHAPE PARAMETER
C     OUTPUT ARGUMENTS--PPF    = THE SINGLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PERCENT POINT
C             FUNCTION VALUE PPF.
C     PRINTING--NONE.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--SNPPF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--EXP.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME I", SECOND EDITION,
C                 JOHN WILEY, 1994, PAGE 454.
C               --AZZALINI HAS AUTHORED A NUMBER OF PAPERS ON THIS
C                 DISTRIBUTION.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           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
      CHARACTER*4 ISKNDF
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
      IF(P.LT.0.0.OR.P.GE.1.0)THEN
         WRITE(ICOUT,61)
   61    FORMAT('***** ERROR--THE FIRST  INPUT ARGUMENT ',
     1          'TO THE LSNPPF SUBROUTINE ')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,62)
   62    FORMAT('      IS OUTSIDE THE ALLOWABLE [0,1) INTERVAL ***')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,63)P
   63    FORMAT('      VALUE OF ARGUMENT = ',G15.7)
         CALL DPWRST('XXX','BUG ')
         PPF=0.0
         GOTO9000
      ENDIF
C
      IF(SD.LE.0.0)THEN
        WRITE(ICOUT,6)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,45)SD
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
        GOTO9000
      ENDIF
    6 FORMAT('**** ERROR: ARGUMENT FOR THE SECOND SHAPE PARAMETER OF ',
     1       'THE LOG-SKEW-NORMAL PPF IS NON-POSITIVE.')
   45 FORMAT('     VALUE OF THE ARGUMENT IS ',G15.7)
C
      ISKNDF='DEFA'
      CALL SNPPF(P,ALMBDA,ISKNDF,PPF2)
      PPF=EXP(PPF2*SD)
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE LSNRAN(N,ALMBDA,SD,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE LOG-SKEWED-NORMAL DISTRIBUTION
C              WITH SHAPE PARAMETERS = ALMBDA AND SD.
C              THIS DISTRIBUTION IS DEFINED FOR POSITIVE X.
C              LOG-SKEWED-NORMAL RANDOM NUMBERS ARE FOUND BY
C              EXPONENTIATING SKEW-NORMAL RANDOM NUMBERS.
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --ALMBDA = THE FIRST SHAPE (PARAMETER) FOR THE
C                                LOG-SKEWED-NORMAL DISTRIBUTION.
C                     --SD     = THE SECOND SHAPE (PARAMETER) FOR THE
C                                LOG-SKEWED-NORMAL DISTRIBUTION.
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST N)
C                                INTO WHICH THE GENERATED
C                                RANDOM SAMPLE WILL BE PLACED.
C     OUTPUT--A RANDOM SAMPLE OF SIZE N
C             FROM THE LOG-SKEWED-NORMAL DISTRIBUTION
C             WITH SHAPE PARAMETERS = ALMBDA AND SD.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C                 --ALMBDA CAN BE ANY REAL NUMBER.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NORRAN.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME I", SECOND EDITION,
C                 JOHN WILEY, 1994, PAGE 454.
C               --AZZALINI HAS AUTHORED A NUMBER OF PAPERS ON THIS
C                 DISTRIBUTION.  ALGORITHM FOR RANDOM NUMBERS
C                 ADAPTED FROM AZZALINI'S R FUNCTIONS FOR SKEW
C                 NORMAL.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           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(*)
      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 ')
        GOTO9999
      ENDIF
    5 FORMAT('***** ERROR--FOR THE LOG-SKEWED-NORMAL DISTRIBUTION,')
    6 FORMAT('       THE REQUESTED NUMBER OF RANDOM NUMBERS WAS ',
     1      'NON-POSITIVE.')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
C
C     ALGORITM ADAPTED FROM AZZALINI'S R FUNCTION LIBRARY.
C
      DO100I=1,N
C
        CALL NORRAN(2,ISEED,Y)
        U1=Y(1)
        U2=Y(2)
        ATEMP=ALMBDA*U1
        IF(U2.GT.ATEMP)U1=-U1
        X(I)=EXP(SD*U1)
C
  100 CONTINUE
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE LSTCDF(X,NU,ALMBDA,SD,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE LOG-SKEW-T DISTRIBUTION
C              WITH SHAPE PARAMETERS = NU, LAMBDA AND SD (SD IS THE
C              SCALE PARAMETER OF THE CORRESPONDING T DISTRIBUTION).
C              THIS DISTRIBUTION IS DEFINED FOR POSITIVE X AND HAS
C              THE CUMULATIVE DISTRIBUTION FUNCTION
C                 LSTCDF(X,NU,LAMBDA,SD) = STCDF(LOG(X)/SD,NU,LAMBDA)
C              WITH SNPDF DENOTING THE SKEW-T PROBABILITY
C              DENSITY FUNCTION.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE NON-NEGATIVE.
C                     --NU     = THE FIRST SHAPE PARAMETER
C                     --ALMBDA = THE SECOND SHAPE PARAMETER
C                     --SD     = THE THIRD SHAPE PARAMETER
C     OUTPUT ARGUMENTS--CDF    = THE SINGLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE CDF FOR THE LOG-SKEWED-T DISTRIBUTION
C             WITH SHAPE PARAMETERS = NU, LAMBDA, AND SD.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--STCDF
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME I", SECOND EDITION,
C                 JOHN WILEY, 1994, PAGE 454.
C               --"Log-Skew-Normal and Log-Skew-t Distributions as
C                 Models for Family Income Data", Azzalini, Cappello,
C                 and Kotz, paper downloaded from Azzalini's web
C                 site.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           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
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               **  CHECK INPUT ARGUMENTS FOR ERRORS **
C               ***************************************
C
      IF(X.LE.0.0)THEN
        CDF=0.0
        GOTO9000
      ENDIF
      IF(NU.LE.0)THEN
        WRITE(ICOUT,7)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,8)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)NU
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9000
      ENDIF
      IF(SD.LE.0.0)THEN
        WRITE(ICOUT,6)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,45)SD
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9000
      ENDIF
    6 FORMAT('**** ERROR: ARGUMENT FOR THE THIRD SHAPE PARAMETER OF ',
     1       'THE LOG-SKEW-T CDF IS NON-POSITIVE.')
    7 FORMAT('**** ERROR: ARGUMENT FOR THE FIRST (DEGREES OF ',
     1       'FREEDOM) SHAPE PARAMETER OF')
    8 FORMAT('     THE LOG-SKEW-T CDF IS NON-POSITIVE.')
   45 FORMAT('     VALUE OF THE ARGUMENT IS ',G15.7)
   46 FORMAT('     VALUE OF THE ARGUMENT IS ',I8)
C
C               ************************************
C               **  STEP 2--                      **
C               **  COMPUTE THE DENSITY FUNCTION  **
C               ************************************
C
      CALL STCDF(LOG(X)/SD,NU,ALMBDA,CDF)
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE LSTPDF(X,NU,ALMBDA,SD,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE LOG-SKEW-T DISTRIBUTION
C              WITH SHAPE PARAMETERS = NU, LAMBDA AND SD (SD IS THE
C              SCALE PARAMETER OF THE CORRESPONDING T DISTRIBUTION).
C              THIS DISTRIBUTION IS DEFINED FOR POSITIVE X AND HAS
C              THE PROBABILITY DENSITY FUNCTION
C                 LSTPDF(X,NU,LAMBDA,SD) = (1/(SD*X))*
C                             STPDF(LOG(X)/SD,NU,LAMBDA,SD)
C              WITH SNPDF DENOTING THE SKEW-T PROBABILITY
C              DENSITY FUNCTION.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE NON-NEGATIVE.
C                     --NU     = THE FIRST SHAPE PARAMETER
C                     --ALMBDA = THE SECOND SHAPE PARAMETER
C                     --SD     = THE THIRD SHAPE PARAMETER
C     OUTPUT ARGUMENTS--PDF    = THE SINGLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE PDF FOR THE LOG-SKEWED-T DISTRIBUTION
C             WITH SHAPE PARAMETERS = NU, LAMBDA, AND SD.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--STPDF
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME I", SECOND EDITION,
C                 JOHN WILEY, 1994, PAGE 454.
C               --"Log-Skew-Normal and Log-Skew-t Distributions as
C                 Models for Family Income Data", Azzalini, Cappello,
C                 and Kotz, paper downloaded from Azzalini's web
C                 site.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           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
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               **  CHECK INPUT ARGUMENTS FOR ERRORS **
C               ***************************************
C
      IF(X.LE.0.0)THEN
        PDF=0.0
        GOTO9000
      ENDIF
      IF(NU.LE.0)THEN
        WRITE(ICOUT,7)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,8)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)NU
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9000
      ENDIF
      IF(SD.LE.0.0)THEN
        WRITE(ICOUT,6)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,45)SD
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9000
      ENDIF
    6 FORMAT('**** ERROR: ARGUMENT FOR THE THIRD SHAPE PARAMETER OF ',
     1       'THE LOG-SKEW-T PDF IS NON-POSITIVE.')
    7 FORMAT('**** ERROR: ARGUMENT FOR THE FIRST (DEGREES OF ',
     1       'FREEDOM) SHAPE PARAMETER OF')
    8 FORMAT('     THE LOG-SKEW-T PDF IS NON-POSITIVE.')
   45 FORMAT('     VALUE OF THE ARGUMENT IS ',G15.7)
   46 FORMAT('     VALUE OF THE ARGUMENT IS ',I8)
C
C               ************************************
C               **  STEP 2--                      **
C               **  COMPUTE THE DENSITY FUNCTION  **
C               ************************************
C
      CALL STPDF(LOG(X)/SD,NU,ALMBDA,PDF)
      PDF=(1.0/(SD*X))*PDF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE LSTPPF(P,NU,ALMBDA,SD,PPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE LOG-SKEW-T DISTRIBUTION
C              WITH SHAPE PARAMETERS = NU, LAMBDA AND SD.
C              THIS DISTRIBUTION IS DEFINED FOR ALL X AND THE
C              PERCENT POINT FUNCTION IS COMPUTED BY
C              TAKING THE EXPONENT OF THE SKEW-T PPF FUNCTION.
C     INPUT  ARGUMENTS--P      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE PERCENT POINT
C                                FUNCTION IS TO BE EVALUATED.
C                     --NU     = THE FIRST SHAPE PARAMETER
C                     --ALMBDA = THE SECOND SHAPE PARAMETER
C                     --SD     = THE THIRD SHAPE PARAMETER
C     OUTPUT ARGUMENTS--PPF    = THE SINGLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PERCENT POINT
C             FUNCTION VALUE PPF.
C     PRINTING--NONE.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--STPPF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--EXP.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME I", SECOND EDITION,
C                 JOHN WILEY, 1994, PAGE 454.
C               --"Log-Skew-Normal and Log-Skew-t Distributions as
C                 Models for Family Income Data", Azzalini, Cappello,
C                 and Kotz, paper downloaded from Azzalini's web
C                 site.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           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
      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
      IF(P.LT.0.0.OR.P.GE.1.0)THEN
         WRITE(ICOUT,61)
   61    FORMAT('***** ERROR--THE FIRST  INPUT ARGUMENT ',
     1          'TO THE LSTPPF SUBROUTINE ')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,62)
   62    FORMAT('      IS OUTSIDE THE ALLOWABLE [0,1) INTERVAL ***')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,63)P
   63    FORMAT('      VALUE OF ARGUMENT = ',G15.7)
         CALL DPWRST('XXX','BUG ')
         PPF=0.0
         GOTO9000
      ENDIF
C
      IF(NU.LE.0)THEN
        WRITE(ICOUT,7)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,8)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)NU
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
        GOTO9000
      ENDIF
      IF(SD.LE.0.0)THEN
        WRITE(ICOUT,6)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,45)SD
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
        GOTO9000
      ENDIF
    6 FORMAT('**** ERROR: ARGUMENT FOR THE THIRD SHAPE PARAMETER OF ',
     1       'THE LOG-SKEW-T PPF IS NON-POSITIVE.')
    7 FORMAT('**** ERROR: ARGUMENT FOR THE FIRST (DEGREES OF ',
     1       'FREEDOM) SHAPE PARAMETER OF')
    8 FORMAT('     THE LOG-SKEW-T PPF IS NON-POSITIVE.')
   45 FORMAT('     VALUE OF THE ARGUMENT IS ',G15.7)
   46 FORMAT('     VALUE OF THE ARGUMENT IS ',I8)
C
      CALL STPPF(P,NU,ALMBDA,PPF2)
      PPF=EXP(PPF2*SD)
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE LSTRAN(N,NU,ALMBDA,SD,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE LOG-SKEWED-T DISTRIBUTION
C              WITH SHAPE PARAMETERS = NU, ALMBDA AND SD.
C              THIS DISTRIBUTION IS DEFINED FOR POSITIVE X.
C              LOG-SKEWED-T RANDOM NUMBERS ARE FOUND BY
C              EXPONENTIATING SKEW-NORMAL RANDOM NUMBERS.
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --NU     = THE FIRST SHAPE (PARAMETER) FOR THE
C                                LOG-SKEWED-T DISTRIBUTION.
C                     --ALMBDA = THE SECOND SHAPE (PARAMETER) FOR THE
C                                LOG-SKEWED-T DISTRIBUTION.
C                     --SD     = THE THIRD SHAPE (PARAMETER) FOR THE
C                                LOG-SKEWED-T DISTRIBUTION.
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST N)
C                                INTO WHICH THE GENERATED
C                                RANDOM SAMPLE WILL BE PLACED.
C     OUTPUT--A RANDOM SAMPLE OF SIZE N
C             FROM THE LOG-SKEWED-T DISTRIBUTION
C             WITH SHAPE PARAMETERS = NU, ALMBDA, AND SD.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C                 --ALMBDA CAN BE ANY REAL NUMBER.
C     OTHER DATAPAC   SUBROUTINES NEEDED--STRAN.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME I", SECOND EDITION,
C                 JOHN WILEY, 1994, PAGE 454.
C               --"Log-Skew-Normal and Log-Skew-t Distributions as
C                 Models for Family Income Data", Azzalini, Cappello,
C                 and Kotz, paper downloaded from Azzalini's web
C                 site.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           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-----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
      IF(NU.LE.0)THEN
        WRITE(ICOUT,7)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,8)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)NU
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
      IF(SD.LE.0.0)THEN
        WRITE(ICOUT,9)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,45)SD
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
    5 FORMAT('***** ERROR--FOR THE LOG-SKEWED-T DISTRIBUTION,')
    6 FORMAT('       THE REQUESTED NUMBER OF RANDOM NUMBERS WAS ',
     1      'NON-POSITIVE.')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
    7 FORMAT('**** ERROR: ARGUMENT FOR THE FIRST (DEGREES OF ',
     1       'FREEDOM) SHAPE PARAMETER OF')
    8 FORMAT('     THE LOG-SKEW-T CDF IS NON-POSITIVE.')
    9 FORMAT('**** ERROR: ARGUMENT FOR THE THIRD SHAPE PARAMETER OF ',
     1       'THE LOG-SKEW-T CDF IS NON-POSITIVE.')
   45 FORMAT('     VALUE OF THE ARGUMENT IS ',G15.7)
C
C     TRANSFORM SKEWED T RANDOM NUMBERS
C
      CALL STRAN(N,NU,ALMBDA,ISEED,X)
C
      DO100I=1,N
        X(I)=EXP(SD*X(I))
  100 CONTINUE
C
 9000 CONTINUE
      RETURN
      END
      subroutine ma(x, n, len, ave)
c
c  This routine is part of the Bill Cleveland seasonal loess
c  program.
c
      integer n, len, i, j, k, m, newn
      real x(n), ave(n), flen, v
      newn = n-len+1
      flen = real(len)
      v = 0.0
      do 23083 i = 1,len
      v = v+x(i)
23083 continue
      ave(1) = v/flen
      if(.not.(newn .gt. 1))goto 23085
      k = len
      m = 0
      do 23087 j = 2, newn 
      k = k+1
      m = m+1
      v = v-x(m)+x(k)
      ave(j) = v/flen
23087 continue
23085 continue
      return
      end
      SUBROUTINE MAD(X,N,IWRITE,XTEMP,MAXNXT,XMAD,IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE
C              SAMPLE MEDIAN ABSOLUTE DEVIATION (WITH DENOMINATOR N)
C              OF THE DATA IN THE INPUT VECTOR X.
C              THE SAMPLE MEDIAN ABSOLUTE DEVIATION = (THE MEDIAN OF
C              THE ABSOLUTE DEVIATIONS ABOUT THE SAMPLE MEDIAN) / N).
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF
C                                (UNSORTED OR SORTED) OBSERVATIONS.
C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR X.
C     OUTPUT ARGUMENTS--XMAD    = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED SAMPLE MEDIAN ABSOLUTE DEVIATION.
C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
C             SAMPLE MEDIAN ABSOLUTE DEVIATION (WITH DENOMINATOR N-1).
C     OTHER DATAPAC   SUBROUTINES NEEDED--MEDIAN AND SORT.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--MOSTELLER AND TUKEY, 'DATA ANALYSIS AND REGRESSION'
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2899
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           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/3
C     ORIGINAL VERSION--MARCH     1995.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 IWRIT2
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
C
      DIMENSION X(*)
      DIMENSION XTEMP(*)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='MAD '
      ISUBN2='    '
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 MAD--')
      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 MEDIAN ABSOLUTE 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 MAD--')
      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 MEDIAN ABSOLUTE DEVIATION IS TO BE')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,115)
  115 FORMAT('      COMPUTED, MUST BE 1 OR LARGER.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,116)
  116 FORMAT('      SUCH WAS NOT THE CASE HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,117)N
  117 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8,
     1'.')
      CALL DPWRST('XXX','BUG ')
      GOTO9000
  119 CONTINUE
C
      IF(N.EQ.1)GOTO120
      GOTO129
  120 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,121)
  121 FORMAT('***** NON-FATAL DIAGNOSTIC IN MAD--',
     1'THE SECOND INPUT ARGUMENT (N) HAS THE VALUE 1')
      CALL DPWRST('XXX','BUG ')
      XMAD=0.0
      GOTO9000
  129 CONTINUE
C
      HOLD=X(1)
      DO135I=2,N
      IF(X(I).NE.HOLD)GOTO139
  135 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,136)HOLD
  136 FORMAT('***** NON-FATAL DIAGNOSTIC IN MAD--',
     1'THE FIRST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      XMAD=0.0
      GOTO9000
  139 CONTINUE
C
  190 CONTINUE
C
C               ***********************************************
C               **  STEP 2--                                 **
C               **  COMPUTE THE MEDIAN ABSOLUTE DEVIATION.   **
C               ***********************************************
C
      IWRIT2='OFF'
      CALL MEDIAN(X,N,IWRIT2,XTEMP,MAXNXT,XMED,IBUGA3,IERROR)
C
      DO300I=1,N
      X(I)=ABS(X(I)-XMED)
  300 CONTINUE
      IWRIT2='OFF'
      CALL MEDIAN(X,N,IWRIT2,XTEMP,MAXNXT,XMAD,IBUGA3,IERROR)
C
C               *******************************
C               **  STEP 3--                 **
C               **  WRITE OUT A LINE         **
C               **  OF SUMMARY INFORMATION.  **
C               *******************************
C
      IF(IFEEDB.EQ.'OFF')GOTO890
      IF(IWRITE.EQ.'OFF')GOTO890
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,811)N,XMAD
  811 FORMAT('THE MEDIAN ABSOLUTE DEVIATION OF THE ',I8,
     1' OBSERVATIONS = ',E15.7)
      CALL DPWRST('XXX','BUG ')
  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 MAD--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IBUGA3,IERROR
 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)N
 9013 FORMAT('N = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9014)XMED
 9014 FORMAT('XMED = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9015)XMAD
 9015 FORMAT('XMAD = ',E15.7)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE MAHDIS(AMAT1,AMAT2,AMAT3,MAXROM,MAXCOM,NR1,NC1,
     1Y1,Y2,INDEX,DMEAN,
     1ICASE,IWRITE,IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE
C              MAHALONBIS DISTANCE OF A MATRIX.
C     INPUT  ARGUMENTS--AMAT1  = THE SINGLE PRECISION MATRIX
C                     --MAXROM = THE INTEGER ROW DIMENSION OF AMAT
C                     --MAXCOM = THE INTEGER COUMN DIMENSION OF AMAT
C                     --NR1    = THE INTEGER NUMBER OF ROWS OF AMAT
C                     --NC1    = THE INTEGER NUMBER OF COLUMNS OF AMAT
C     OUTPUT ARGUMENTS--AMAT3    = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED MAHALANOBIS DISTANCE MATRIX.
C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
C             MAHALANOBIS DISTANCE MATRIX.
C     NOTE--THIS ROUTINE ASSUMES THE ERROR CHECKING (FOR EQUAL
C           ROWS AND COLUMNS, MATCHING DIMENSIONS FOR X AND AMAT)
C           IS DONE BT THE CALLING SUBROUTINE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     LANGUAGE--ANSI FORTRAN (1977)
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           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.7
C     ORIGINAL VERSION--JULY      1998.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 ICASE
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DIMENSION AMAT1(MAXROM,MAXCOM)
      DIMENSION AMAT2(MAXROM,MAXCOM)
      DIMENSION AMAT3(MAXROM,MAXCOM)
      DIMENSION Y1(*)
      DIMENSION Y2(*)
      DIMENSION INDEX(*)
      DOUBLE PRECISION DMEAN(*)
C
C---------------------------------------------------------------------
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='MAHD'
      ISUBN2='IS  '
C
      IWRITE='NO'
      IERROR='NO'
C
      IF(IBUGA3.EQ.'OFF')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF MAHDIS--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)IBUGA3,ICASE
   52 FORMAT('IBUGA3,ICASE = ',2A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)NR1,NC1
   53 FORMAT('NR1, NC1 = ',2I8)
      CALL DPWRST('XXX','BUG ')
   90 CONTINUE
C
C               **********************************
C               **  COMPUTE MAHALNOBIS DISTANCE **
C               **********************************
C
      IF(ICASE.EQ.'COLU')THEN
        CALL VARCOV(AMAT1,AMAT2,MAXROM,MAXCOM,NR1,NC1,DMEAN,
     1            ICASE,IBUGA3,IERROR)
         CALL SGECO(AMAT2,MAXROM,NC1,INDEX,RCOND,Y1)
C
         IF(1.0+RCOND.EQ.1.0)THEN
           WRITE(ICOUT,999)
           CALL DPWRST('XXX','BUG ')
           WRITE(ICOUT,5171)
           CALL DPWRST('XXX','ERRO ')
           WRITE(ICOUT,5172)
           CALL DPWRST('XXX','ERRO ')
           WRITE(ICOUT,5173)
           CALL DPWRST('XXX','ERRO ')
           IERROR='YES'
           GOTO9000
         ENDIF
 5171 FORMAT('*** ERROR FROM MAHDIS: UNABLE TO COMPUTE THE INVERSE OF ',
     1       'THE COVARIANCE MATRIX.')
 5172 FORMAT('    PROBLEM: SOME ROWS ARE LINEARLY DEPDENDENT ON OTHER',
     1       ' ROWS.')
 5173 FORMAT('    SUGGESTED SOLUTION: WORK WITH A SUBSET OF THE ',
     1       'ORIGINAL ROWS.')
C
         IJOB=1
         CALL SGEDI(AMAT2,MAXROM,NR1,INDEX,Y1,Y2,IJOB)
         DO5111I=1,NC1
           DO5113J=1,I
             IF(I.EQ.J)THEN
               AMAT3(I,I)=0.0
             ELSE
               DO5117K=1,NR1
                 Y1(K)=AMAT1(K,I)-AMAT1(K,J)
 5117          CONTINUE
               CALL QUAFRM(AMAT2,MAXROM,MAXCOM,NR1,NR1,Y1,IWRITE,
     1                     XQUAD,IBUGA3,IERROR)
               AMAT3(I,J)=XQUAD
               AMAT3(J,I)=XQUAD
             ENDIF
 5113      CONTINUE
 5111    CONTINUE
      ELSE
        CALL VARCOV(AMAT1,AMAT2,MAXROM,MAXCOM,NR1,NC1,DMEAN,
     1            ICASE,IBUGA3,IERROR)
         CALL SGECO(AMAT2,MAXROM,NR1,INDEX,RCOND,Y1)
C
         IF(1.0+RCOND.EQ.1.0)THEN
           WRITE(ICOUT,999)
           CALL DPWRST('XXX','BUG ')
           WRITE(ICOUT,6171)
           CALL DPWRST('XXX','ERRO ')
           WRITE(ICOUT,6172)
           CALL DPWRST('XXX','ERRO ')
           WRITE(ICOUT,6173)
           CALL DPWRST('XXX','ERRO ')
           IERROR='YES'
           GOTO9000
         ENDIF
 6171 FORMAT('*** ERROR FROM MAHDIS: UNABLE TO COMPUTE THE INVERSE OF ',
     1       'THE COVARIANCE MATRIX.')
 6172 FORMAT('    PROBLEM: SOME ROWS ARE LINEARLY DEPDENDENT ON OTHER',
     1       ' ROWS.')
 6173 FORMAT('    SUGGESTED SOLUTION: WORK WITH A SUBSET OF THE ',
     1       'ORIGINAL ROWS.')
C
         IJOB=1
         CALL SGEDI(AMAT2,MAXROM,NR1,INDEX,Y1,Y2,IJOB)
         DO6111I=1,NR1
           DO6113J=1,I
             IF(I.EQ.J)THEN
               AMAT3(I,I)=0.0
             ELSE
               DO6117K=1,NC1
                 Y1(K)=AMAT1(I,K)-AMAT1(J,K)
 6117          CONTINUE
               CALL QUAFRM(AMAT2,MAXROM,MAXCOM,NC1,NC1,Y1,IWRITE,
     1                     XQUAD,IBUGA3,IERROR)
               AMAT3(I,J)=XQUAD
               AMAT3(J,I)=XQUAD
             ENDIF
 6113      CONTINUE
 6111    CONTINUE
      ENDIF
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'OFF')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF MAHDIS--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IBUGA3,IERROR
 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)NR1,NC1
 9013 FORMAT('NR1,NC1 = ',2I8)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE MAINAN(ICASAN,ISEED,ANOPL1,ANOPL2,
     1TEMP,TEMP2,XTEMP1,XTEMP2,MAXNXT,
CCCCC1IFTEXP,
     1IFTEXP,IFTORD,
CCCCC MARCH 1994.  ADD ARGUMENT.
CCCCC1ALOWFR,
     1ALOWFR,ALOWDG,
CCCCC JULY 2002: FOLLOWING LINE FOR BOOTSTRAP FIT
     1IBOOSS,
CCCCC AUGUST 2002: FOLLOWING LINE FOR CROSS TABULATE, TABULATE
     1ICAPSW,
     1IFORSW,
     1IBUGAN,IBUGA2,IBUGA3,
     1IBUGCO,IBUGEV,IBUGQ,ISUBRO,IFOUND,IERROR)
C
C     PURPOSE--THIS IS SUBROUTING MAINAN.
C              (THE   AN    AT THE END OF    MAINAN   STANDS FOR   ANALYSIS)
C              THIS SUBROUTINE SEARCHES FOR AND EXECUTES ANALYSIS COMMANDS.
C              THE ANALYSIS COMMANDS SEARCHED FOR BY MAINAN ARE AS FOLLOWS--
C
C              CODE AT END: H => HTML OUTPUT IMPLEMENTED
C                           L => LATEX OUTPUT IMPLEMENTED
C                           R => RICH TEXT FORMAT OUTOUT IMPLEMENTED
C
C                  ANALYSIS OF VARIANCE                         (HL)
C                  MEDIAN POLISH
C                  ANALYSIS OF PROPORTIONS (WORKING?)
C                  CONSENSUS MEANS (=MANDEL-PAULE,              (HL)
C                                    BOB (BAYESIAN CONCENSUS MEANS),
C                                    SCHILLER-EBERHARDT
C                                    VANGEL-RUKHIN MAXIMUM LIKELIHOD
C                  E691 INTERLAB                               (HLR)
C                  YATES ANALYSIS = DEX FIT = 2**K FIT =        (HL)
C                                    2**K DEX FIT
C                  (YATES) PHD ANALYSIS
C                  KRUSKAL-WALLIS TEST                          (HL)
C                  VAN DER WAERDEN TEST                         (HL)
C                  FRIEDMAN TEST                                (HL)
C                  DURBIN TEST                                  (HL)
C                  COCHRAN TEST                                 (HL)
C
C                  CONFIDENCE LIMITS                            (HL)
C                  BIWEIGHT CONFIDENCE LIMITS                   (HL)
C                  TRIMMED MEAN CONFIDENCE LIMITS               (HL)
C                  MEDIAN CONFIDENCE LIMITS                     (HL)
C                  QUANTILE CONFIDENCE LIMITS                   (HL)
C                  DIFFERENCE OF MEANS CONFIDENCE LIMITS        (HL)
C                  TOLERANCE LIMITS Y
C                  PROPORTION CONFIDENCE LIMITS
C                  DIFFERENCE OF PROPORTION CONFIDENCE LIMITS
C
C                  EXACT ... RATIONAL FIT
C                  ... FIT                                      (HL)
C                  ... PRE-FIT
C                  ... SMOOTH
C                  ... SPLINE FIT
C                  ORTHOGONAL DISTANCE FIT
C                  BOOTSTRAP FIT
C                  BEST CP Y X1 TO XK
C                  LOWESS
C                  SEASONAL LOWESS
C                  LINEAR CALIBRATION                           (HL)
C                  QUADRATIC CALIBRATION                        (HL)
C
C                  LET
C                  LET FUNCTION
C
C                  RUNS
C                  LUJAN-BOX TEST (FOR RANDOMNESS)
C                  FREQUENCY TEST (FOR RANDOMNESS)              (HL)
C                  FREQUENCY WITHIN A BLOCK TEST (FOR RANDOMNESS)  (HL)
C                  CUMULATIVE SUM RANDOMNESS TEST               (HL)
C
C                  T TEST Y1 Y2 or Y MU or MU Y                 (HL)
C                  SIGN TEST Y1 Y2 or Y MU or MU Y OR Y1 Y2 D0  (HL)
C                  WILCOXON SIGNED RANK TEST Y1 Y2 or Y1 Y2 D0  (HL)
C                                            or Y MU
C                  MANN-WHITNEY RANK SUM TEST Y1 Y2
C
C                  CHI-SQUARED TEST Y SIGMA or SIGMA Y          (HL)
C                  F TEST Y1 Y2                                 (HL)
C                  BARTLETT'S TEST Y X1 X2 X3 X4 X5
C                  F LOCATION TEST Y X
C                  LEVENE TEST Y X                              (HL)
C                  ANDERSON DARLING K-SAMPLE TEST Y X
C
C                  ANDERSON DARLING <DIST> TEST Y               (HL)
C                  WILKS-SHAPIRO NORMALITY TEST Y               (HL)
C                  <DIST> CHI-SQUARED GOODNESS OF FIT TEST Y    (HL)
C                  <DIST> KOLMOGOROV-SMIRNOV GOODNESS OF FIT    (HL)
C                                            TEST Y
C                  CHI-SQUARED 2 SAMPLE TEST Y1 Y2
C                  KOMOGOROV-SMIRNOV 2 SAMPLE TEST Y1 Y2
C
C                  GRUBB TEST Y                                 (HL)
C
C                  RELIABILITY TREND TESTS Y
C
C                  SUMMARY                                      (HL)
C                  CAPABILITY ANALYSIS
C
C                  DDS               DDS Y 6 5 DELT   3/94
C                  ARMA              ARMA Y 2 1 2 1 1 1 12
C
C                  RECIPE            RECIPE <FIT/ANOVA> Y <X1 .. XN>
C                  SIMCOV            SIMCOV <FIT/ANOVA> Y <X1 .. XN>
C                  BBASIS <WEIBULL/NORMAL/LOGNORMAL> Y
C                  ABASIS <WEIBULL/NORMAL/LOGNORMAL> Y
C
C                  WEIBULL MAXIMUM LIKELIHOOD Y                 (HL)
C                  INVERTED WEIBULL MAXIMUM LIKELIHOOD Y        (HL)
C                  NORMAL MAXIMUM LIKELIHOOD Y                  (HL)
C                  NORMAL MIXTURE MAXIMUM LIKELIHOOD Y          (HL)
C                  LOGNORMAL MAXIMUM LIKELIHOOD Y               (HL)
C                  EXPONENTIAL MAXIMUM LIKELIHOOD Y             (HL)
C                  EXPONENTIAL GROUPED MAXIMUM LIKELIHOOD Y X   (HL)
C                  PARETO MAXIMUM LIKELIHOOD Y                  (HL)
C                  GAMMA MAXIMUM LIKELIHOOD Y                   (HL)
C                  GUMBEL MAXIMUM LIKELIHOOD Y                  (HL)
C                  FRECHET MAXIMUM LIKELIHOOD Y                 (HL)
C                  GENERALIZED EXTREME VALUE MAXIMUM LIKELIHOOD Y
C                  POWER MAXIMUM LIKELIHOOD Y                   (HL)
C                  DOUBLE EXPONENTIAL MAXIMUM LIKELIHOOD Y      (HL)
C                  BINOMIAL MAXIMUM LIKELIHOOD Y                (HL)
C                  POISSON MAXIMUM LIKELIHOOD Y                 (HL)
C                  BETA BINOMIAL MAXIMUM LIKELIHOOD Y           (HL)
C                  POLYA MAXIMUM LIKELIHOOD Y                   (HL)
C                  GUMBEL (EV1) MAXIMUM LIKELIHOOD Y            (HL)
C                  TWO-SIDED POWER MAXIMUM LIKELIHOOD Y         (HL)
C                  LOGISTIC MAXIMUM LIKELIHOOD Y                (HL)
C                  CAUCHY MAXIMUM LIKELIHOOD Y                  (HL)
C                  BETA MAXIMUM LIKELIHOOD Y                    (HL)
C                  DEHAAN Y (FOR GENERALIZED PARETO)            (HL)
C                  CME Y    (FOR GENERALIZED PARETO)            (HL)
C                  JOHNSON SB MOMENTS Y                         (HL)
C                  JOHNSON SU MOMENTS Y                         (HL)
C                  JOHNSON SB PERCENTILE ESTIMATION Y           (HL)
C                  JOHNSON SU PERCENTILE ESTIMATION Y           (HL)
C                  UNIFORM MOMENTS MLE Y                        (HL)
C                  LOGARITHMIC SERIES MLE Y                     (HL)
C                  GEOMETRIC MLE Y                              (HL)
C                  NEGATIVE BINOMIAL MLE Y                      (HL)
C                  FATIGUE LIFE MLE Y                           (HL)
C                  GEOMETRIC EXTREME EXPONENTIAL MLE Y          (HL)
C                  FOLDED NORMAL MLE Y                          (HL)
C                  HYPERGEOMETRIC MLE Y                         (HL)
C                  HERMITE MLE Y                                (HL)
C                  YULE MLE Y                                   (HL)
C                  WARING MLE Y                                 (HL)
C                  RAYLEIGH MLE Y                               (HL)
C                  MAXWELL MLE Y                                (HL)
C                  GENERALIZED LOGISTIC MLE Y                   (HL)
C
C                  LOW PASS FILTER/SMOOTH Y (NOT WORKING)
C                  HIGH PASS FILTER/SMOOTH Y (NOT WORKING)
C
C                  SINGLE SAMPLE ACCEPTANCE PLAN P1 P2 ALPHA BETA
C                  DOUBLE SAMPLE ACCEPTANCE PLAN P1 P2 ALPHA BETA (NOT WORKING)
C
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           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.6
C     ORIGINAL VERSION--JANUARY   1981.
C     UPDATED         --MARCH     1981.
C     UPDATED         --JULY      1981.
C     UPDATED         --AUGUST    1981.
C     UPDATED         --SEPTEMBER 1981.
C     UPDATED         --OCTOBER   1981.
C     UPDATED         --NOVEMBER  1981.
C     UPDATED         --MARCH     1982.
C     UPDATED         --MAY       1982.
C     UPDATED         --JULY      1987. YATES ANALYSIS
C     UPDATED         --FEBRUARY  1988. LOWESS FIT
C     UPDATED         --DECEMBER  1988. LOWESS FRACTION
C     UPDATED         --MAY       1989. EXPERIMENTAL SIMULATION
C     UPDATED         --JUNE      1989. (2**K) DEX FIT = YATES ANALYSIS
C     UPDATED         --NOVEMBER  1989. YATES ... CUTOFF BRANCH
C     UPDATED         --NOVEMBER  1989. YATES OUTPUT BRANCH
C     UPDATED         --NOVEMBER  1989. CROSS-TABULATION
C     UPDATED         --SEPTEMBER 1990. CAPABILITY ANALYSIS
C     UPDATED         --SEPTEMBER 1993. (YATES) PHD ANALYSIS
C     UPDATED         --FEBRUARY  1994. REWRITE T TEST SECTION
C     UPDATED         --FEBRUARY  1994. CHI-SQUARED TEST
C     UPDATED         --FEBRUARY  1994. F TEST
C     UPDATED         --FEBRUARY  1994. BARTLETT'S TEST
C     UPDATED         --FEBRUARY  1994. ADD ARGUMENT TO DPLET
C     UPDATED         --MARCH     1994. DDS
C     UPDATED         --JUNE      1994. ADD ARGUMENT TO DPLET
C     UPDATED         --FEBRUARY  1995. RENAME PHD TO DEX PHD (A MORE
C                                       GENERAL PHD COMMAND MAY BE 
C                                       ADDED LATER)
C     UPDATED         --JULY      1995. RECIPE ANALYSIS (MARK VANGEL)
C     UPDATED         --JULY      1995. MANDEL (2-WAY) ANALYSIS
C     UPDATED         --OCTOBER   1995. IFTORD
C     UPDATED         --APRIL     1996. FLAG FOR PRESERVING THE CASE
C                                       ON STRINGS
C     UPDATED         --SEPTEMBER 1997. RECIPE AND SIMCOV
C     UPDATED         --SEPTEMBER 1997. GRUBB TEST
C     UPDATED         --SEPTEMBER 1997. LEVENE TEST
C     UPDATED         --SEPTEMBER 1997. F LOCATION TEST
C     UPDATED         --SEPTEMBER 1997. ANDERSON DARLING 1-SAMPLE TEST
C     UPDATED         --JANUARY   1998. NAME CONFLICT WITH RECIPE AND
C                                       RECIPROCAL PROB PLOT AND PPCC PLOT
C     UPDATED         --MARCH     1998. WEIBULL MAXIMUM LIKELIHOOD Y
C     UPDATED         --MARCH     1998. BBASIS WEIBULL/NORMAL/LOGNORMAL Y
C     UPDATED         --MARCH     1998. ABASIS WEIBULL/NORMAL/LOGNORMAL Y
C     UPDATED         --MARCH     1998. K-SAMPLE ANDERSON DARLING
C     UPDATED         --APRIL     1998. OTHER DISTRIBUTIONS FOR MLE
C     UPDATED         --MAY       1998. DEHAAN AND CME
C     UPDATED         --MAY       1998. RELIABILITY TREND TESTS
C     UPDATED         --JUNE      1998. GAMMA, POWER, DOUBLE
C                                       EXPONENTIAL MLE
C     UPDATED         --NOVEMBER  1998. TOLERANCE LIMITS
C     UPDATED         --NOVEMBER  1998. CHI-SQUARE GOODNESS OF FIT
C     UPDATED         --NOVEMBER  1998. KOLMOGOROV-SMIRNOV GOODNESS OF FIT
C     UPDATED         --DECEMBER  1998. CHI-SQUARE 2 SAMPLE TEST
C     UPDATED         --FEBRUARY  1999. UPDATE LOWESS TO SUPPORT 
C                                       SEASONAL LOESS
C     UPDATED         --FEBRUARY  1999. UPDATE SMOOTH TO SUPPORT 
C                                       LOW PASS AND HIGH PASS FILTER
C     UPDATED         --MARCH     1999. WILKS-SHAPIRO NORMALITY TEST
C     UPDATED         --MARCH     1999. SINGLE SAMPLE ACCEPTANCE PLAN
C     UPDATED         --MARCH     1999. DOUBLE SAMPLE ACCEPTANCE PLAN
C     UPDATED         --MARCH     1999. BETA BINOMIAL MAXIMUM LIKELIHOOD Y
C     UPDATED         --MARCH     1999. GENERALIZED EXTREME VALUE MAXIMUM LIKELIHOOD Y
C     UPDATED         --MARCH     1999. WILKS-SHAPIRO NORMALITY TEST
C     UPDATED         --MARCH     1999. PROPORTIONS CONFIDENCE LIMITS
C     UPDATED         --MARCH     1999. DIFFERENCE OF PROPORTIONS
C     UPDATED         --MARCH     1999. DIFFERENCE OF MEANS
C                                       CONFIDENCE LIMITS
C     UPDATED         --MAY       1999. ARMA FIT
C     UPDATED         --JUNE      1999. SIGN TEST
C     UPDATED         --JUNE      1999. KRUSKAL-WALLIS TEST
C     UPDATED         --JUNE      1999. WILCOXON SIGNED RANK TEST
C     UPDATED         --JULY      1999. MANN-WHITNEY TEST
C     UPDATED         --AUGUST    1999. FIX TO LEVENE TEST
C     UPDATED         --AUGUST    1999. FIX TO BARTLETT TEST
C     UPDATED         --OCTOBER   2000. CONSENSUS MEANS
C                                       (MANDEL-PAULE)
C     UPDATED         --OCTOBER   2000. BOB (BAYESIAN IMPLEMENTATION
C                                       OF CONCENSUS MEANS)
C     UPDATED         --APRIL     2001. ORTHOGONAL DISTANCE FIT
C     UPDATED         --JULY      2001. EV1 SYNONYMS FOR ANDERSON
C                                       DARLING TEST
C     UPDATED         --NOVEMBER  2001. BIWEIGHT CONFIDENCE INTEVAL
C     UPDATED         --MAY       2002. TWO-SIDED POWER MAXI LIKE
C     UPDATED         --JUNE      2002. BEST CP
C     UPDATED         --JULY      2002. BOOTSTRAP FIT
C     UPDATED         --AUGUST    2002. CALL LIST TO CROSS TABULAE,
C                                       TABULATE
C     UPDATED         --OCTOBER   2002. CALL LIST TO SUMMARY
C     UPDATED         --OCTOBER   2002. CALL LIST TO CONSENSUS MEAN
C     UPDATED         --FEBRUARY  2003. TRIMMED MEAN CONFIDENCE INTERVAL
C     UPDATED         --FEBRUARY  2003. MEDIAN CONFIDENCE INTERVAL
C     UPDATED         --FEBRUARY  2003. QUANTILE CONFIDENCE INTERVAL
C     UPDATED         --FEBRUARY  2003. LUJAN-BOX TEST FOR RANDOMNESS
C     UPDATED         --JULY      2003. JOHNSON SB MOMEMTS
C     UPDATED         --JULY      2003. JOHNSON SU MOMEMTS
C     UPDATED         --JULY      2003. LINEAR CALIBRATION
C     UPDATED         --JULY      2003. QUADRATIC CALIBRATION
C     UPDATED         --OCTOBER   2003. FRIEDMAN TEST
C     UPDATED         --OCTOBER   2003. LOGISTIC MAXIMUM LIKELIHOOD
C     UPDATED         --OCTOBER   2003. CAUCHY MAXIMUM LIKELIHOOD
C     UPDATED         --OCTOBER   2003. BETA MAXIMUM LIKELIHOOD
C     UPDATED         --OCTOBER   2003. UNIFORM MAXIMUM LIKELIHOOD
C     UPDATED         --OCTOBER   2003. ANDERSON-DARLING LOGISTIC
C     UPDATED         --NOVEMBER  2003. ANDERSON-DARLING UNIFORM
C     UPDATED         --NOVEMBER  2003. ANDERSON-DARLING DOUBLE
C                                       EXPONENTIAL
C     UPDATED         --NOVEMBER  2003. FREQUENCY TEST
C     UPDATED         --NOVEMBER  2003. FREQUENCY WITHIN A BLOCK TEST
C     UPDATED         --DECEMBER  2003. CUSUM BLOCK TEST
C     UPDATED         --MARCH     2004. LOGARITHMIC SERIES MAXIMUM
C                                       LIKELIHOOD
C     UPDATED         --MARCH     2004. NEGATIVE BINOMIAL MAXIMUM
C                                       LIKELIHOOD
C     UPDATED         --MARCH     2004. GEOMETRIC MAXIMUM LIKELIHOOD
C     UPDATED         --MARCH     2004. HYPERGEOMETRIC MAXIMUM
C                                       LIKELIHOOD
C     UPDATED         --MARCH     2004. POLYA MAXIMUM LIKELIHOOD
C     UPDATED         --APRIL     2004. JOHNSON PERCENTILE
C     UPDATED         --OCTOBER   2004. COCHRAN TEST
C     UPDATED         --OCTOBER   2004. VAN DER WAERDEN TEST
C     UPDATED         --DECEMBER  2004. ANDERSON-DARLING GAMMA
C     UPDATED         --FEBRUARY  2005. E691 INTERLAB
C     UPDATED         --MAY       2005. FRECHET MAXIMUM LIKELIHOOD
C     UPDATED         --MAY       2005. ANDERSON DARLING FRECHET
C     UPDATED         --MAY       2005. ANDERSON DARLING CAUCHY
C     UPDATED         --AUGUST    2005. INVERTED WEIBULL MAXI LIKE
C     UPDATED         --DECEMBER  2005. ALLOW "NORMAL" AND
C                                       "NONPARAMETRIC" FOR TOLERANCE
C                                       LIMITS COMMAND
C     UPDATED         --JANUARY   2006. DURBIN TEST
C     UPDATED         --FEBRUARY  2006. ALLOW "GRUBB MINIMUM" AND
C                                       "GRUB MAXIMUM"
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 ICASAN
      CHARACTER*4 IFORSW
      CHARACTER*4 IBUGAN
      CHARACTER*4 IBUGA2
      CHARACTER*4 IBUGA3
      CHARACTER*4 IBUGCO
      CHARACTER*4 IBUGEV
      CHARACTER*4 IBUGQ
      CHARACTER*4 ISUBRO
      CHARACTER*4 IFOUND
      CHARACTER*4 IERROR
C
      CHARACTER*4 ICASML
C
      CHARACTER*4 IFTEXP
CCCCC AUGUST 1995.  ADD FOLLOWING LINE
      CHARACTER*4 IFTORD
CCCCC APRIL 1996.  ADD FOLLOWING LINE
      CHARACTER*10 ISFLAG
CCCCC SEPTEMBER 1997.  ADD FOLLOWING LINE
      CHARACTER*4 ICASDI
      CHARACTER*4 ICAPSW
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
      DIMENSION TEMP(*)
      DIMENSION TEMP2(*)
      DIMENSION XTEMP1(*)
      DIMENSION XTEMP2(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOPA.INC'
      INCLUDE 'DPCOMC.INC'
      INCLUDE 'DPCOHK.INC'
      INCLUDE 'DPCOSU.INC'
      INCLUDE 'DPCOS2.INC'
      INCLUDE 'DPCODA.INC'
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='MAIN'
      ISUBN2='AN  '
C
      IFOUND='NO'
      IERROR='NO'
C
      ICASAN='UNKN'
C
      IF(IBUGAN.EQ.'OFF')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF MAINAN--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)IBUGAN,IBUGA2,IBUGA3
   53 FORMAT('IBUGAN,IBUGA2,IBUGA3 = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,55)IBUGCO,IBUGEV,IBUGQ
   55 FORMAT('IBUGCO,IBUGEV,IBUGQ = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,56)IFTEXP
   56 FORMAT('IFTEXP = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,57)IANGLU
   57 FORMAT('IANGLU = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,58)ICASAN,ISEED,ANOPL1,ANOPL2
   58 FORMAT('ICASAN,ISEED,ANOPL1,ANOPL2 = ',A4,I8,E15.7,E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,60)IFOUND,IERROR
   60 FORMAT('IFOUND,IERROR = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,61)MAXNXT
   61 FORMAT('MAXNXT = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,67)ICOM,ICOM2
   67 FORMAT('ICOM,ICOM2 = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,68)NUMARG
   68 FORMAT('NUMARG = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO70I=1,NUMARG
      WRITE(ICOUT,71)I,IHARG(I),IHARG2(I),IARGT(I),IARG(I),ARG(I)
   71 FORMAT('I,IHARG(I),IHARG2(I),IARGT(I),IARG(I),ARG(I) = ',
     1I8,2X,A4,2X,A4,2X,A4,2X,I8,E15.7)
      CALL DPWRST('XXX','BUG ')
   70 CONTINUE
      WRITE(ICOUT,81)ALOWFR
   81 FORMAT('ALOWFR = ',E15.7)
      CALL DPWRST('XXX','BUG ')
   90 CONTINUE
C
C               *************************
C               **  SEARCH FOR         **
C               **  ANALYSIS COMMANDS  **
C               *************************
C
CCCCC THE FOLLOWING SECTION WAS MOVED HERE TO BE FIRST   MAY 1992 (JJF)
CCCCC TO AVOID MISPROCESSING OF   LET FUNCTION A = FIT   MAY 1992 (JJF)
C               ***********************************
C               **  TREAT THE LET FUNCTION CASE  **
C               ***********************************
C
CCCCC APRIL 1996.  IF ENTERED AS LET STRING, PRESERVE CASE.  IF
CCCCC ENTERED AS LET FUNCTION, CONVERT TO UPPER CASE
      IF(NUMARG.GE.1.AND.ICOM.EQ.'LET'.AND.
     1IHARG(1).EQ.'FUNC'.AND.IHARG2(1).EQ.'TION')ISFLAG='FUNCTION'
      IF(NUMARG.GE.1.AND.ICOM.EQ.'LET'.AND.
     1IHARG(1).EQ.'FUNC'.AND.IHARG2(1).EQ.'TION')GOTO1800
      IF(NUMARG.GE.1.AND.ICOM.EQ.'LET'.AND.
     1IHARG(1).EQ.'STRI'.AND.IHARG2(1).EQ.'NG')ISFLAG='STRING'
      IF(NUMARG.GE.1.AND.ICOM.EQ.'LET'.AND.
     1IHARG(1).EQ.'STRI'.AND.IHARG2(1).EQ.'NG')GOTO1800
      GOTO1899
C
 1800 CONTINUE
      ICASAN='LETF'
      CALL DPLETF(IANGLU,IBUGA2,IBUGA3,IBUGCO,IBUGEV,IBUGQ,ISUBRO,
CCCCC APRIL 1996.  ADD FOLLOWING LINE.
     1ISFLAG,
     1IFOUND,IERROR)
      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
C
 1899 CONTINUE
C
C               **********************************************
C               **  TREAT THE ANALYSIS OF PROPORTIONS CASE  **
C               **********************************************
C
CCCCC IF(ICOM.EQ.'ANOP'.AND.IHARG(1).NE.'LIMI'.AND.
CCCCC1IHARG2(1).NE.'TS  '.AND.IHARG(1).NE.'PLOT'.AND.
CCCCC1IHARG2(1).NE.'    ')GOTO100
CCCCC GOTO199
C
CC100 CONTINUE
CCCCC ICASAN='ANOP'
CCCCC CALL DPANOP(ANOPL1,ANOPL2,IBUGA2,IBUGA3,IBUGQ,
CCCCC1IFOUND,IERROR)
CCCCC IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
C
CC199 CONTINUE
C
C               *******************************************
C               **  TREAT THE ANALYSIS OF VARIANCE CASE  **
C               *******************************************
C
      IF(ICOM.EQ.'ANAL')GOTO200
      IF(ICOM.EQ.'ANOV')GOTO200
      GOTO299
C
  200 CONTINUE
      ICASAN='ANOV'
      CALL DPANOV(ICAPSW,IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR)
      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      GOTO9000
C
  299 CONTINUE
C
C               *********************************************
C               **  TREAT THE EXACT ... RATIONAL FIT CASE  **
C               *********************************************
C
      IF(ICOM.EQ.'EXAC')GOTO300
      GOTO399
C
  300 CONTINUE
      ICASAN='EXAC'
      CALL DPEXAC(IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR)
      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
C
  399 CONTINUE
C
C               *************************************
C               **  TREAT THE LOWESS FIT     CASE  **
C               *************************************
C
      IF(ICOM.EQ.'LOWE')GOTO1100
      IF(ICOM.EQ.'LOES')GOTO1100
      IF(ICOM.EQ.'SEAS')GOTO1100
      GOTO1199
C
 1100 CONTINUE
      ICASAN='LOWF'
CCCCC MARCH 1994.  ADD ARGUMENT.
CCCCC CALL DPLOW(ALOWFR,
      CALL DPLOW(ALOWFR,ALOWDG,
     1TEMP,TEMP2,XTEMP1,XTEMP2,MAXNXT,
     1IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      GOTO9000
C
 1199 CONTINUE
C
C               ************************************************
C               **  TREAT THE ORTHOGONAL DISTANCE FIT   CASE  **
C               ************************************************
C
      IF(ICOM.EQ.'ORTH'.AND.NUMARG.GE.2.AND.IHARG(1).EQ.'DIST'.AND.
     1IHARG(2).EQ.'FIT')GOTO1200
      IF(ICOM.EQ.'ORTH'.AND.NUMARG.GE.2.AND.IHARG(1).EQ.'DIST'.AND.
     1IHARG(2).EQ.'REGR')GOTO1200
      GOTO1299
C
 1200 CONTINUE
      ICASAN='ORTF'
      CALL DPORTH(IBUGA2,IBUGA3,IBUGCO,IBUGEV,IBUGQ,ISUBRO,
     1IFOUND,IERROR)
      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      GOTO9000
C
 1299 CONTINUE
C
C               ******************************
C               **  TREAT THE ... FIT CASE  **
C               ******************************
C
CCCCC THE FOLLOWING 8 LINES WERE ADDED JUNE 1989
      IF(ICOM.EQ.'BOOT')GOTO1799
      IF(ICOM.EQ.'2**K'.AND.NUMARG.GE.1.AND.
     1IHARG(1).EQ.'FIT')GOTO1799
      IF(ICOM.EQ.'2**K'.AND.NUMARG.GE.2.AND.
     1IHARG(2).EQ.'FIT')GOTO1799
      IF(ICOM.EQ.'DEX'.AND.NUMARG.GE.1.AND.
     1IHARG(1).EQ.'FIT')GOTO1799
      IF(ICOM.EQ.'DEX'.AND.NUMARG.GE.2.AND.
     1IHARG(2).EQ.'FIT')GOTO1799
C
      IF(ICOM.EQ.'FIT ')GOTO1700
CCCCC CHECK FOR "RECIPE FIT" AND "SIMCOV FIT" CASES.  SEPTEMBER 1997
      IF(NUMARG.GE.1.AND.ICOM.NE.'SPLI'.AND.ICOM.NE.'PRE '.AND.
CCCCC1ICOM.NE.'LOWE'.AND.
     1ICOM.NE.'LOWE'.AND.ICOM.NE.'RECI'.AND.ICOM.NE.'SIMC'.AND.
     1IHARG(1).EQ.'FIT ')GOTO1700
      DO1710I=2,5
      IM1=I-1
      IF(NUMARG.GE.I.AND.IHARG(IM1).NE.'SPLI'.AND.IHARG(1).NE.'PRE '
     1.AND.IHARG(IM1).NE.'OF'
     1.AND.IHARG(I).EQ.'FIT ')GOTO1700
 1710 CONTINUE
      GOTO1799
C
 1700 CONTINUE
      ICASAN='FIT'
      CALL DPFIT(ICAPSW,IBUGA2,IBUGA3,IBUGCO,IBUGEV,IBUGQ,ISUBRO,
     1IFOUND,IERROR)
      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      GOTO9000
C
 1799 CONTINUE
C
C               ******************************
C               **  TREAT THE BEST CP CASE  **
C               ******************************
C
      IF(ICOM.EQ.'BEST'.AND.NUMARG.GE.1.AND.
     1IHARG(1).EQ.'CP  ')THEN
        ICASAN='CP'
        CALL DPBECP(IBUGA2,IBUGA3,IBUGCO,IBUGEV,IBUGQ,ISUBRO,
     1              IFOUND,IERROR)
        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
C               ******************************
C               **  TREAT THE BOOTSTRAP FIT **
C               ******************************
C
      IF(ICOM.EQ.'BOOT'.AND.NUMARG.GE.1.AND.
     1IHARG(1).EQ.'FIT ')THEN
        ICASAN='BFIT'
        CALL DPBOFI(IBUGA2,IBUGA3,IBUGCO,IBUGEV,IBUGQ,ISUBRO,
     1              ISEED,IBOOSS,
     1              IFOUND,IERROR)
        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
C
CCCCC THE FOLLOWING SECTION WAS COMMENTED OUT HERE    MAY 1992 (JJF)
CCCCC AND MOVED UP TO THE TOP OF THIS SUBROUTINE      MAY 1992 (JJF)
CCCCC TO FIX MISPROCESSING OF    LET STRING A = FIT   MAY 1992 (JJF)
CCCCC           ***********************************
CCCCC           **  TREAT THE LET FUNCTION CASE  **
CCCCC           ***********************************
CCCCC
CCCCC IF(NUMARG.GE.1.AND.ICOM.EQ.'LET'.AND.
CCCCC1IHARG(1).EQ.'FUNC'.AND.IHARG2(1).EQ.'TION')GOTO1800
CCCCC IF(NUMARG.GE.1.AND.ICOM.EQ.'LET'.AND.
CCCCC1IHARG(1).EQ.'STRI'.AND.IHARG2(1).EQ.'NG')GOTO1800
CCCCC GOTO1899
CCCCC
C1800 CONTINUE
CCCCC ICASAN='LETF'
CCCCC CALL DPLETF(IANGLU,IBUGA2,IBUGA3,IBUGCO,IBUGEV,IBUGQ,ISUBRO,
CCCCC1IFOUND,IERROR)
CCCCC IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
CCCCC
C1899 CONTINUE
C
C               **************************
C               **  TREAT THE LET CASE  **
C               **************************
C
      IF(NUMARG.GE.1.AND.ICOM.EQ.'LET')GOTO1900
      GOTO1999
C
 1900 CONTINUE
      ICASAN='LET'
      CALL DPLET(IANGLU,ISEED,IBUGA2,IBUGA3,IBUGCO,IBUGEV,IBUGQ,
     1TEMP,TEMP2,XTEMP1,XTEMP2,MAXNXT,
CCCCC AUGUST 1995.  ADD IFTORD
CCCCC1IFTEXP,
     1IFTEXP,IFTORD,
CCCCC ADD FOLLOWING LINE.  FEBRUARY 1994.
CCCCC ADD OPTACC ARGUMENT JUNE 1994
CCCCC ADD IOTME, IOPTHE ARGUMENTS FEBRUARY 1995
     1ROOTAC,OPTACC,IOPTME,IOPTHE,
     1ISUBRO,IFOUND,IERROR)
      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
C
 1999 CONTINUE
CCCCC THE FOLLOWING SECTION WAS REWRITTEN      JULY 1995
C               ************************************
C               **  TREAT THE MEDIAN POLISH CASE  **
C               ************************************
C
      IF(ICOM.EQ.'MEDI'.AND.
     1   NUMARG.GE.1.AND.IHARG(1).EQ.'POLI'.AND.
     1   IHARG2(1).EQ.'SH  ')THEN
         ICASAN='MEPO'
         CALL DPMEPO(IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED      JULY 1995
C               **********************************************
C               **  TREAT THE MANDEL (2-WAY) ANALYSIS CASE  **
C               **********************************************
C
CCCCC APRIL 1996.  FOLLOWING CODE IS NOT WORKING YET
CCCCC OCTOBER 2000.  UPDATE (CALL IT CONCENSUS MEANS OR
CCCCC MANDEL-PAULE, IT IMPLEMENTS BOTH MANDEL-PAULE AND
CCCCC MARK VANGEL'S MAXIMUM LIKELIHOOD APPROACH).
C
      IF(ICOM.EQ.'MAND'.AND.NUMARG.GE.1.AND.IHARG(1).EQ.'PAUL')THEN
         ICASAN='MAND'
         CALL DPMAND(ICAPSW,IFORSW,ISUBRO,IBUGA2,IBUGA3,IBUGQ,
     1               IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
      IF(ICOM.EQ.'CONS'.AND.NUMARG.GE.1.AND.IHARG(1).EQ.'MEAN')THEN
         ICASAN='MAND'
         CALL DPMAND(ICAPSW,IFORSW,ISUBRO,IBUGA2,IBUGA3,IBUGQ,
     1               IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
 2199 CONTINUE
C
CCCCC THE FOLLOWING SECTION WAS ADDED      FEBRUARY 2005
C               **********************************************
C               **  TREAT THE E691 INTERLAB           CASE  **
C               **********************************************
C
      IF(ICOM.EQ.'E691'.AND.NUMARG.GE.2.AND.IHARG(1).EQ.'INTE'.AND.
     1   IHARG(2).EQ.'ANAL')THEN
         ICASAN='E691'
         CALL DPEINL(ICAPSW,IFORSW,ISUBRO,
     1               IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ELSEIF(ICOM.EQ.'E691'.AND.NUMARG.GE.1.AND.IHARG(1).EQ.'INTE')THEN
         ICASAN='E691'
         CALL DPEINL(ICAPSW,IFORSW,ISUBRO,
     1               IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED      JULY 2003
C               **********************************************
C               **  TREAT THE LINEAR CALIBRATION      CASE  **
C               **********************************************
C
      IF(ICOM.EQ.'LINE'.AND.NUMARG.GE.1.AND.IHARG(1).EQ.'CALI')THEN
         ICASAN='LICA'
         CALL DPLICA(ICAPSW,ISEED,ISUBRO,IBUGA2,IBUGA3,IBUGQ,
     1               IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED      JULY 2003
C               **********************************************
C               **  TREAT THE QUADRATIC CALIBRATION   CASE  **
C               **********************************************
C
      IF(ICOM.EQ.'QUAD'.AND.NUMARG.GE.1.AND.IHARG(1).EQ.'CALI')THEN
         ICASAN='QUCA'
         CALL DPLICA(ICAPSW,ISEED,ISUBRO,IBUGA2,IBUGA3,IBUGQ,
     1               IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
C
C               **********************************
C               **  TREAT THE ... PRE-FIT CASE  **
C               **********************************
C
      IF(NUMARG.GE.1.AND.ICOM.EQ.'PRE '.AND.IHARG(1).EQ.'FIT ')
     1GOTO2200
      DO2210I=2,5
      IM1=I-1
      IF(NUMARG.GE.I.AND.IHARG(IM1).EQ.'PRE '.AND.IHARG(I).EQ.'FIT ')
     1GOTO2200
 2210 CONTINUE
      IF(ICOM.EQ.'PREF')GOTO2200
      DO2220I=1,4
      IF(NUMARG.GE.I.AND.IHARG(I).EQ.'PREF'.AND.
     1IHARG2(I).EQ.'IT  ')GOTO2200
 2220 CONTINUE
      GOTO2299
C
 2200 CONTINUE
      ICASAN='PREF'
      CALL DPPREF(IBUGA2,IBUGA3,IBUGCO,IBUGEV,IBUGQ,ISUBRO,
     1IFOUND,IERROR)
      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
C
 2299 CONTINUE
C
C               *********************************
C               **  TREAT THE ... SMOOTH CASE  **
C               *********************************
C
      IF(ICOM.EQ.'SMOO')GOTO2300
      IF(ICOM.EQ.'LOW'.AND.NUMARG.GE.1.AND.IHARG(1).EQ.'PASS')GOTO2300
      IF(ICOM.EQ.'HIGH'.AND.NUMARG.GE.1.AND.IHARG(1).EQ.'PASS')GOTO2300
      DO2310I=1,3
      IF(NUMARG.GE.I.AND.IHARG(I).EQ.'SMOO'.AND.
     1IHARG2(I).EQ.'TH  ')GOTO2300
      IF(NUMARG.GE.I.AND.IHARG(I).EQ.'SMOO'.AND.
     1IHARG2(I).EQ.'THIN')GOTO2300
 2310 CONTINUE
      GOTO2399
C
 2300 CONTINUE
      ICASAN='SMOO'
      CALL DPSMOO(IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR)
      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
C
 2399 CONTINUE
C
C               *************************************
C               **  TREAT THE ... SPLINE FIT CASE  **
C               *************************************
C
      IF(NUMARG.GE.1.AND.ICOM.EQ.'SPLI'.AND.IHARG(1).EQ.'FIT ')
     1GOTO2400
      DO2410I=2,5
      IM1=I-1
      IF(NUMARG.GE.I.AND.IHARG(IM1).EQ.'SPLI'.AND.IHARG(I).EQ.'FIT ')
     1GOTO2400
 2410 CONTINUE
      GOTO2499
C
 2400 CONTINUE
      ICASAN='SPLI'
      CALL DPSPL(IBUGA2,IBUGA3,IBUGQ,ISUBRO,
     1IFOUND,IERROR)
      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      GOTO9000
C
 2499 CONTINUE
C
C               ******************************
C               **  TREAT THE SUMMARY CASE  **
C               ******************************
C
      IF(ICOM.EQ.'SUMM')GOTO2500
      GOTO2599
C
 2500 CONTINUE
      ICASAN='SUMM'
      CALL DPSUMM(XTEMP1,XTEMP2,MAXNXT,
     1ICAPSW,
     1IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR)
      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
C
 2599 CONTINUE
C
C               ****************************************
C               **  TREAT THE CONFIDENCE LIMITS CASE  **
C               ****************************************
C
      IF(ICOM.EQ.'CONF')GOTO3100
      GOTO3199
C
 3100 CONTINUE
      IF(NUMARG.GE.3.AND.
     1(IHARG(1).EQ.'LIMI'.OR.IHARG(1).EQ.'INTE').AND.
     1IHARG(2).EQ.'FOR '.AND.IHARG(3).EQ.'MEAN')GOTO3130
      IF(NUMARG.GE.2.AND.
     1(IHARG(1).EQ.'LIMI'.OR.IHARG(1).EQ.'INTE').AND.
     1IHARG(2).EQ.'MEAN')GOTO3120
      IF(NUMARG.GE.1.AND.
     1(IHARG(1).EQ.'LIMI'.OR.IHARG(1).EQ.'INTE'))
     1GOTO3110
      GOTO3180
 3110 CONTINUE
      ISHIFT=1
      GOTO3150
 3120 CONTINUE
      ISHIFT=2
      GOTO3150
 3130 CONTINUE
      ISHIFT=3
      GOTO3150
 3150 CONTINUE
      CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1IBUGA2,IERROR)
      GOTO3180
 3180 CONTINUE
      ICASAN='ONEV'
      CALL DPCONF(XTEMP1,XTEMP2,MAXNXT,ICASAN,
     1ICAPSW,
     1IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR)
      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
C
 3199 CONTINUE
C
C               *************************************************
C               **  TREAT THE BIWEIGHT CONFIDENCE LIMITS CASE  **
C               *************************************************
C
      IF(ICOM.EQ.'BIWE')THEN
C
        IF(NUMARG.GE.2.AND.IHARG(1).EQ.'CONF'.AND.
     1     (IHARG(2).EQ.'LIMI'.OR.IHARG(2).EQ.'INTE'))THEN
           ISHIFT=2
           CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1                 IBUGA2,IERROR)
           ICASAN='ONEV'
           CALL DPBWCO(XTEMP1,XTEMP2,MAXNXT,ICASAN,
     1                 ICAPSW,
     1                 IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
           IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
C
        ENDIF
      ENDIF
C
C               *****************************************************
C               **  TREAT THE TRIMMED MEAN CONFIDENCE LIMITS CASE  **
C               *****************************************************
C
      IF(ICOM.EQ.'TRIM'.AND.IHARG(1).EQ.'MEAN')THEN
C
        IF(NUMARG.GE.3.AND.IHARG(2).EQ.'CONF'.AND.
     1     (IHARG(3).EQ.'LIMI'.OR.IHARG(3).EQ.'INTE'))THEN
           ISHIFT=3
           CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1                 IBUGA2,IERROR)
           ICASAN='TMCI'
           CALL DPTMCO(XTEMP1,XTEMP2,MAXNXT,ICASAN,
     1                 ICAPSW,
     1                 IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
           IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
C
        ENDIF
      ENDIF
C
C               *****************************************************
C               **  TREAT THE MEDIAN       CONFIDENCE LIMITS CASE  **
C               **  TREAT THE QUANTILE     CONFIDENCE LIMITS CASE  **
C               *****************************************************
C
      IF(ICOM.EQ.'MEDI')THEN
C
        IF(NUMARG.GE.2.AND.IHARG(1).EQ.'CONF'.AND.
     1     (IHARG(2).EQ.'LIMI'.OR.IHARG(2).EQ.'INTE'))THEN
           ISHIFT=2
           CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1                 IBUGA2,IERROR)
           ICASAN='MECI'
           CALL DPQUCO(XTEMP1,XTEMP2,MAXNXT,ICASAN,
     1                 ICAPSW,
     1                 IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
           IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
C
        ENDIF
      ENDIF
C
      IF(ICOM.EQ.'QUAN')THEN
C
        IF(NUMARG.GE.2.AND.IHARG(1).EQ.'CONF'.AND.
     1     (IHARG(2).EQ.'LIMI'.OR.IHARG(2).EQ.'INTE'))THEN
           ISHIFT=2
           CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1                 IBUGA2,IERROR)
           ICASAN='QUCI'
           CALL DPQUCO(XTEMP1,XTEMP2,MAXNXT,ICASAN,
     1                 ICAPSW,
     1                 IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
           IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
C
        ENDIF
      ENDIF
C
C               ****************************************
C               **  TREAT THE DIFFERENCE OF MEANS     **
C               **  CONFIDENCE LIMITS CASE            **
C               ****************************************
C
      IF(ICOM.EQ.'DIFF')THEN
        IF(NUMARG.GE.4.AND.IHARG(1).EQ.'OF  '.AND.
     1    IHARG(2).EQ.'MEAN'.AND.
     1    IHARG(3).EQ.'CONF'.AND.
     1    (IHARG(4).EQ.'LIMI'.OR.IHARG(4).EQ.'INTE'))THEN
          ISHIFT=4
          CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1                IBUGA2,IERROR)
          ICASAN='TWOV'
          CALL DPCONF(XTEMP1,XTEMP2,MAXNXT,ICASAN,
     1                ICAPSW,
     1                IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR)
          IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
        ENDIF
        IF(NUMARG.GE.3.AND.IHARG(1).EQ.'MEAN'.AND.
     1     IHARG(2).EQ.'CONF'.AND.
     1     (IHARG(3).EQ.'LIMI'.OR.IHARG(3).EQ.'INTE'))THEN
           ISHIFT=3
           CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1                IBUGA2,IERROR)
          ICASAN='TWOV'
          CALL DPCONF(XTEMP1,XTEMP2,MAXNXT,ICASAN,
     1                ICAPSW,
     1                IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR)
          IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
        ENDIF
      ENDIF
C
C               ***************************************************
C               **  TREAT THE PROPORTION CONFIDENCE LIMITS CASE  **
C               **  AND DIFFERENCE OF PROPORTION CONFIDENCE      **
C               **  LIMITS CASE                                  **
C               ***************************************************
C
      IF(ICOM.EQ.'PROP')THEN
        IF(NUMARG.GE.2.AND.IHARG(1).EQ.'CONF'.AND.
     1    (IHARG(2).EQ.'LIMI'.OR.IHARG(2).EQ.'INTE'))THEN
          ISHIFT=2
          CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1                IBUGA2,IERROR)
          ICASAN='PROP'
          CALL DPPRCL(XTEMP1,XTEMP2,MAXNXT,ICASAN,ANOPL1,ANOPL2,
     1                IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR)
          IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
        ENDIF
      ENDIF
C
      IF(ICOM.EQ.'DIFF')THEN
        IF(NUMARG.GE.4.AND.IHARG(1).EQ.'OF  '.AND.
     1    IHARG(2).EQ.'PROP'.AND.IHARG(3).EQ.'CONF'.AND.
     1    (IHARG(4).EQ.'LIMI'.OR.IHARG(4).EQ.'INTE'))THEN
          ISHIFT=4
          CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1                IBUGA2,IERROR)
          ICASAN='DPRO'
          CALL DPPRCL(XTEMP1,XTEMP2,MAXNXT,ICASAN,ANOPL1,ANOPL2,
     1                IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR)
          IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
        ENDIF
        IF(NUMARG.GE.3.AND.IHARG(1).EQ.'PROP'.AND.
     1     IHARG(2).EQ.'CONF'.AND.
     1     (IHARG(3).EQ.'LIMI'.OR.IHARG(3).EQ.'INTE'))THEN
          ISHIFT=3
          CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1                IBUGA2,IERROR)
          ICASAN='DPRO'
          CALL DPPRCL(XTEMP1,XTEMP2,MAXNXT,ICASAN,ANOPL1,ANOPL2,
     1                IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR)
          IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
        ENDIF
      ENDIF
C
C               ****************************************
C               **  TREAT THE TOLERANCE  LIMITS CASE  **
C               ****************************************
C
      IF(ICOM.EQ.'TOLE')THEN
        IF(NUMARG.GE.1.AND.
     1    (IHARG(1).EQ.'LIMI'.OR.IHARG(1).EQ.'INTE'))THEN
          ISHIFT=1
          CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1                IBUGA2,IERROR)
        ENDIF
        ICASAN='TOLE'
        CALL DPTOLI(XTEMP1,XTEMP2,MAXNXT,
     1              ICASAN,
     1              IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR)
        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
C
      ELSE IF(ICOM.EQ.'NORM')THEN
        IF(NUMARG.GE.2.AND.
     1    IHARG(1).EQ.'TOLE'.AND.
     1    (IHARG(2).EQ.'LIMI'.OR.IHARG(2).EQ.'INTE'))THEN
          ISHIFT=2
          CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1                IBUGA2,IERROR)
          ICASAN='NTOL'
          CALL DPTOLI(XTEMP1,XTEMP2,MAXNXT,
     1                ICASAN,
     1                IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR)
          IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
        ENDIF
C
      ELSE IF(ICOM.EQ.'NONP')THEN
        IF(NUMARG.GE.2.AND.
     1    IHARG(1).EQ.'TOLE'.AND.
     1    (IHARG(2).EQ.'LIMI'.OR.IHARG(2).EQ.'INTE'))THEN
          ISHIFT=2
          CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1                IBUGA2,IERROR)
          ICASAN='NPTO'
          CALL DPTOLI(XTEMP1,XTEMP2,MAXNXT,
     1                ICASAN,
     1                IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR)
          IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
        ENDIF
C
      ENDIF
C
C               ******************************
C               **  TREAT THE RUNS    CASE  **
C               ******************************
C
      IF(ICOM.EQ.'RUNS')GOTO3200
      GOTO3299
C
 3200 CONTINUE
      ICASAN='RUNS'
      CALL DPRUN(XTEMP1,XTEMP2,MAXNXT,
     1IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR)
      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
C
 3299 CONTINUE
C
C               *********************************************
C               **  TREAT THE RELIABILTY TREND TESTS CASE  **
C               *********************************************
C
      IF(ICOM.EQ.'RELI')THEN
        IF(NUMARG.GE.2.AND.IHARG(1).EQ.'TREN'.AND.
     1     IHARG(2).EQ.'TEST')THEN
             ICASAN='TREN'
             ISHIFT=2
             CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1                   IBUGA2,IERROR)
             CALL DPTREN(XTEMP1,XTEMP2,MAXNXT,
     1                   IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR)
             IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
        ENDIF
      ENDIF
C
C
CCCCC THE FOLLOWING SECTION WAS REWRITTEN     FEBRUARY 1994
C               ******************************
C               **  TREAT THE T TEST  CASE  **
C               ******************************
C
      IF(ICOM.EQ.'T   ')THEN
         IF(NUMARG.GE.1.AND.IHARG(1).EQ.'TEST')THEN
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
            ICASAN='TTES'
            CALL DPTTES(XTEMP1,XTEMP2,MAXNXT,
     1                  ICAPSW,
     1                  IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR)
            IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
         ENDIF
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     JUNE 1999
C               *********************************
C               **  TREAT THE SIGN TEST  CASE  **
C               *********************************
C
      IF(ICOM.EQ.'SIGN')THEN
         IF(NUMARG.GE.1.AND.IHARG(1).EQ.'TEST')THEN
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         ICASAN='STES'
         IF(NUMARG.GE.1.AND.IHARG(1).EQ.'RANK')THEN
           CONTINUE
         ELSE
           CALL DPSIGN(XTEMP1,XTEMP2,MAXNXT,
     1                ICAPSW,
     1                IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
           IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
         ENDIF
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     JUNE 1999
C               *************************************************
C               **  TREAT THE WILCOXON SIGNED RANK TEST  CASE  **
C               *************************************************
C
      IF(ICOM.EQ.'WILC')THEN
         IF(NUMARG.GE.3.AND.IHARG(1).EQ.'SIGN'.AND.
     1      IHARG(2).EQ.'RANK'.AND.IHARG(3).EQ.'TEST')THEN
            ISHIFT=3
         ELSEIF(NUMARG.GE.2.AND.IHARG(1).EQ.'SIGN'.AND.
     1      IHARG(2).EQ.'RANK')THEN
            ISHIFT=2
         ELSEIF(NUMARG.GE.2.AND.IHARG(1).EQ.'SIGN'.AND.
     1      IHARG(2).EQ.'TEST')THEN
            ISHIFT=2
         ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'TEST')THEN
            ISHIFT=1
         ELSE
           GOTO3039
         ENDIF
         CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1               IBUGA2,IERROR)
         ICASAN='WTES'
         CALL DPWILC(XTEMP1,XTEMP2,MAXNXT,
     1               ICAPSW,
     1               IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
      IF(ICOM.EQ.'SIGN')THEN
         IF(NUMARG.GE.2.AND.IHARG(1).EQ.'RANK'.AND.
     1      IHARG(2).EQ.'TEST')THEN
            ISHIFT=2
         ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'RANK')THEN
            ISHIFT=1
         ELSE
           GOTO3039
         ENDIF
         CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1               IBUGA2,IERROR)
         ICASAN='WTES'
         CALL DPWILC(XTEMP1,XTEMP2,MAXNXT,
     1               ICAPSW,
     1               IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
 3039 CONTINUE
C
CCCCC THE FOLLOWING SECTION WAS ADDED     JULY 1999
C               *************************************************
C               **  TREAT THE MANN-WHITNEY RANK SUM TEST  CASE **
C               *************************************************
C
      IF(ICOM.EQ.'MANN')THEN
         IF(NUMARG.GE.4.AND.IHARG(1).EQ.'WHIT'.AND.
     1      IHARG(2).EQ.'RANK'.AND.IHARG(3).EQ.'SUM '.AND.
     1      IHARG(4).EQ.'TEST')THEN
            ISHIFT=4
         ELSEIF(NUMARG.GE.3.AND.IHARG(1).EQ.'WHIT'.AND.
     1      IHARG(2).EQ.'RANK'.AND.IHARG(3).EQ.'SUM ')THEN
            ISHIFT=3
         ELSEIF(NUMARG.GE.2.AND.IHARG(1).EQ.'WHIT'.AND.
     1      IHARG(2).EQ.'TEST')THEN
            ISHIFT=2
         ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'WHIT')THEN
            ISHIFT=1
         ELSE
           GOTO3049
         ENDIF
         CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1               IBUGA2,IERROR)
         ICASAN='MTES'
         CALL DPMANN(XTEMP1,XTEMP2,MAXNXT,
     1               IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
      IF(ICOM.EQ.'RANK')THEN
         IF(NUMARG.GE.2.AND.IHARG(1).EQ.'SUM '.AND.
     1      IHARG(2).EQ.'TEST')THEN
            ISHIFT=2
         ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'SUM ')THEN
            ISHIFT=1
         ELSE
           GOTO3049
         ENDIF
         CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1               IBUGA2,IERROR)
         ICASAN='MTES'
         CALL DPMANN(XTEMP1,XTEMP2,MAXNXT,
     1               IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
 3049 CONTINUE
C
CCCCC THE FOLLOWING SECTION WAS ADDED     FEBRUARY 1994
C               ****************************************
C               **  TREAT THE CHI-SQUARED TEST  CASE  **
C               ****************************************
C
      IF(ICOM.EQ.'CHI ')THEN
         IF(NUMARG.GE.1.AND.IHARG(1).EQ.'SQUA')THEN
            IF(NUMARG.GE.2.AND.IHARG(2).EQ.'TEST')THEN
               ISHIFT=2
               CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1         IBUGA2,IERROR)
               ICASAN='CSTE'
               CALL DPCSTE(XTEMP1,XTEMP2,MAXNXT,
     1         ICAPSW,
     1         IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR)
               IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
            ENDIF
         ENDIF
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     DECEMBER 1998
C               *************************************************
C               **  TREAT THE CHI-SQUARED 2 SAMPLE TEST  CASE  **
C               *************************************************
C
      IF(ICOM.EQ.'CHI '.OR.ICOM.EQ.'CHIS'.OR.ICOM.EQ.'2'.OR.
     1   ICOM.EQ.'TWO')THEN
         CALL DP2CHS(TEMP,TEMP2,XTEMP1,XTEMP2,MAXNXT,
     1         IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
               IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     DECEMBER 1998
C               *******************************************************
C               **  TREAT THE KOLMOGOROV-SMIRNOV 2 SAMPLE TEST  CASE **
C               *******************************************************
C
      IF(ICOM.EQ.'KOLM'.OR.ICOM.EQ.'2'.OR.
     1   ICOM.EQ.'TWO')THEN
         CALL DP2KST(TEMP,TEMP2,MAXNXT,
     1         IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
               IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     NOVEMBER 1998
C               ***************************************************
C               **  TREAT THE CHI-SQUARED GOODNESS OF FIT  CASE  **
C               ***************************************************
C
      IF(NUMARG.GE.3)THEN
        DO7010I=1,NUMARG-2
          IF(IHARG(I).EQ.'GOOD'.AND.IHARG(I+1).EQ.'OF'.AND.
     1       IHARG(I+2).EQ.'FIT')THEN
               CALL DPCHSQ(XTEMP1,XTEMP2,TEMP,MAXNXT,
     1         ICAPSW,
     1         IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
               IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
          ENDIF
 7010   CONTINUE
      ENDIF
      IF(NUMARG.GE.2)THEN
        DO7020I=1,NUMARG-1
          IF(IHARG(I).EQ.'CHI '.AND.IHARG(I+1).EQ.'SQUA')THEN
               CALL DPCHSQ(XTEMP1,XTEMP2,TEMP,MAXNXT,
     1         ICAPSW,
     1         IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
               IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
          ENDIF
 7020   CONTINUE
      ENDIF
      IF(NUMARG.GE.1)THEN
        DO7030I=1,NUMARG
          IF(IHARG(I).EQ.'CHIS')THEN
               CALL DPCHSQ(XTEMP1,XTEMP2,TEMP,MAXNXT,
     1         ICAPSW,
     1         IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
               IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
          ENDIF
 7030   CONTINUE
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     NOVEMBER 1998
C               ***************************************************
C               **  TREAT THE KOLMOGOROV-SMIRNOV GOODNESS OF FIT  CASE
C               ***************************************************
C
      IF(NUMARG.GE.3)THEN
        DO7060I=1,NUMARG-2
          IF(IHARG(I).EQ.'GOOD'.AND.IHARG(I+1).EQ.'OF'.AND.
     1       IHARG(I+2).EQ.'FIT')THEN
               CALL DP1KST(XTEMP1,XTEMP2,TEMP,MAXNXT,
     1         ICAPSW,
     1         IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
               IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
          ENDIF
 7060   CONTINUE
      ENDIF
      IF(NUMARG.GE.2)THEN
        DO7070I=1,NUMARG-1
          IF(IHARG(I).EQ.'KOLM'.AND.IHARG(I+1).EQ.'SMIR')THEN
               CALL DP1KST(XTEMP1,XTEMP2,TEMP,MAXNXT,
     1         ICAPSW,
     1         IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
               IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
          ENDIF
 7070   CONTINUE
      ENDIF
      IF(NUMARG.GE.2)THEN
        DO7080I=1,NUMARG-1
          IF(IHARG(I).EQ.'KOLM'.AND.IHARG(I+1).EQ.'SMIR')THEN
               CALL DP1KST(XTEMP1,XTEMP2,TEMP,MAXNXT,
     1         ICAPSW,
     1         IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
               IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
          ENDIF
 7080   CONTINUE
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     SEPTEMBER 1997
C               ***************************************
C               **  TREAT THE F LOCATION TEST  CASE  **
C               ***************************************
C
      IF(ICOM.EQ.'F   '.AND.(NUMARG.GE.1.AND.IHARG(1).EQ.'LOCA'))THEN
         IF(NUMARG.GE.1.AND.IHARG(1).EQ.'LOCA')THEN
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
            ICASAN='FLTE'
            IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
         ENDIF
         IF(NUMARG.GE.1.AND.IHARG(1).EQ.'TEST')THEN
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
            IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
         ENDIF
         CALL DPFLTE(XTEMP1,XTEMP2,MAXNXT,
     1   IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR)
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     FEBRUARY 1994
C               ******************************
C               **  TREAT THE F TEST  CASE  **
C               ******************************
C
      IF(ICOM.EQ.'F   ')THEN
         IF(NUMARG.GE.1.AND.IHARG(1).EQ.'TEST')THEN
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
            ICASAN='FTES'
            CALL DPFTES(XTEMP1,XTEMP2,MAXNXT,
     1                  ICAPSW,
     1                  IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR)
            IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
         ENDIF
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     FEBRUARY 1994
C               ***************************************
C               **  TREAT THE BARTLETT'S TEST  CASE  **
C               ***************************************
C
CCCCC ADD: DIXON BARTLETT TEST       AUGUST 1999
CCCCC ADD: DIXON MASSEY BARTLETT TEST       AUGUST 1999
CCCCC ADD: DM BARTLETT TEST       AUGUST 1999
C
      IF(ICOM.EQ.'BART')THEN
         IF(NUMARG.GE.1.AND.IHARG(1).EQ.'TEST')THEN
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
            ICASAN='BTES'
            CALL DPBTES(XTEMP1,XTEMP2,MAXNXT,ICASAN,
     1      IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR)
            IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
         ENDIF
      ENDIF
C
      IF(ICOM.EQ.'DIXO')THEN
         IF(NUMARG.GE.3.AND.IHARG(1).EQ.'MASS'.AND.
     1      IHARG(2).EQ.'BART'.AND.IHARG(3).EQ.'TEST')THEN
            ISHIFT=3
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
            ICASAN='DMBT'
            CALL DPBTES(XTEMP1,XTEMP2,MAXNXT,ICASAN,
     1      IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR)
            IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
         ELSEIF(NUMARG.GE.2.AND.IHARG(1).EQ.'BART'.AND.
     1      IHARG(2).EQ.'TEST')THEN
            ISHIFT=2
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
            ICASAN='DMBT'
            CALL DPBTES(XTEMP1,XTEMP2,MAXNXT,ICASAN,
     1      IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR)
            IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
         ENDIF
      ENDIF
C
      IF(ICOM.EQ.'DM  ')THEN
         IF(NUMARG.GE.2.AND.IHARG(1).EQ.'BART'.AND.
     1      IHARG(2).EQ.'TEST')THEN
            ISHIFT=2
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
            ICASAN='DMBT'
            CALL DPBTES(XTEMP1,XTEMP2,MAXNXT,ICASAN,
     1      IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR)
            IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
         ENDIF
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     SEPTEMBER 1997
C               ********************************************
C               **  TREAT THE KRUSKALL-WALLIS TEST  CASE  **
C               ********************************************
C
      IF(ICOM.EQ.'KRUS')THEN
         IF(NUMARG.GE.2.AND.IHARG(1).EQ.'WALL'.AND.
     1          IHARG(2).EQ.'TEST')THEN
            ISHIFT=2
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'TEST')THEN
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'WALL')THEN
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         ICASAN='KTES'
         CALL DPKRUS(XTEMP1,XTEMP2,MAXNXT,
     1               ICAPSW,
     1               IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
C
CCCCC THE FOLLOWING SECTION WAS ADDED     SEPTEMBER 1997
C               ***************************************************
C               **  TREAT THE VAN DER WAERDEN TEST         CASE  **
C               **            ONE WAY NORMAL SCORES TEST   CASE  **
C               ***************************************************
C
      IF(ICOM.EQ.'VAN ')THEN
         IF(NUMARG.GE.3.AND.IHARG(1).EQ.'DER '.AND.
     1          IHARG(2).EQ.'WAER'.AND.IHARG(3).EQ.'TEST')THEN
            ISHIFT=3
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ELSEIF(NUMARG.GE.2.AND.IHARG(1).EQ.'DER '.AND.
     1          IHARG(2).EQ.'WAER')THEN
            ISHIFT=2
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         ICASAN='VDWA'
         CALL DPVWAE(XTEMP1,XTEMP2,MAXNXT,
     1               ICAPSW,
     1               IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
      IF(ICOM.EQ.'ONE ')THEN
         IF(NUMARG.GE.4.AND.IHARG(1).EQ.'WAY '.AND.
     1          IHARG(2).EQ.'NORM'.AND.IHARG(3).EQ.'SCOR'.AND.
     1          IHARG(4).EQ.'TEST')THEN
            ISHIFT=4
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ELSEIF(NUMARG.GE.3.AND.IHARG(1).EQ.'WAY '.AND.
     1          IHARG(2).EQ.'NORM'.AND.IHARG(3).EQ.'SCOR')THEN
            ISHIFT=4
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         ICASAN='VDWA'
         CALL DPVWAE(XTEMP1,XTEMP2,MAXNXT,
     1               ICAPSW,
     1               IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     OCTOBER 2003
C               ********************************************
C               **  TREAT THE FRIEDMAN              CASE  **
C               ********************************************
C
      IF(ICOM.EQ.'FRIE')THEN
         IF(NUMARG.GE.2.AND.IHARG(1).EQ.'RANK'.AND.
     1      IHARG(2).EQ.'TEST')THEN
            ISHIFT=2
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'TEST')THEN
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         ICASAN='FRIE'
         CALL DPFRIE(XTEMP1,XTEMP2,MAXNXT,
     1               ICAPSW,
     1               IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     JANUARY 2006
C               ********************************************
C               **  TREAT THE DURBIN                CASE  **
C               ********************************************
C
      IF(ICOM.EQ.'DURB')THEN
         IF(NUMARG.GE.2.AND.IHARG(1).EQ.'RANK'.AND.
     1      IHARG(2).EQ.'TEST')THEN
            ISHIFT=2
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'TEST')THEN
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         ICASAN='DURB'
         CALL DPDURB(XTEMP1,XTEMP2,MAXNXT,
     1               ICAPSW,
     1               IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     OCTOBER 2004
C               ********************************************
C               **  TREAT THE COCHRAN               CASE  **
C               ********************************************
C
      IF(ICOM.EQ.'COCH')THEN
         IF(NUMARG.GE.1.AND.IHARG(1).EQ.'TEST')THEN
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         ICASAN='COCH'
         CALL DPCOCH(XTEMP1,XTEMP2,MAXNXT,
     1               ICAPSW,
     1               IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     JUNE 1999
C               ***************************************
C               **  TREAT THE LEVENE'S   TEST  CASE  **
C               ***************************************
C
CCCCC ADD: MEAN LEVENE TEST AND TRIMMED MEAN LEVENE TEST.
CCCCC      APRIL 1999
C
      IF(ICOM.EQ.'LEVE')THEN
         IF(NUMARG.GE.1.AND.IHARG(1).EQ.'TEST')THEN
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1                  IBUGA2,IERROR)
            ICASAN='LMED'
            CALL DPLTES(XTEMP1,XTEMP2,MAXNXT,ICASAN,
     1                  ICAPSW,
     1                  IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR)
            IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
         ENDIF
      ENDIF
C
      IF(ICOM.EQ.'MEAN')THEN
         IF(NUMARG.GE.2.AND.IHARG(1).EQ.'LEVE'.AND.
     1      IHARG(2).EQ.'TEST')THEN
            ISHIFT=2
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1                  IBUGA2,IERROR)
            ICASAN='LMEA'
            CALL DPLTES(XTEMP1,XTEMP2,MAXNXT,ICASAN,
     1                  ICAPSW,
     1                  IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR)
            IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
         ELSE IF(NUMARG.GE.1.AND.IHARG(1).EQ.'LEVE')THEN
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1                  IBUGA2,IERROR)
            ICASAN='LMEA'
            CALL DPLTES(XTEMP1,XTEMP2,MAXNXT,ICASAN,
     1                  ICAPSW,
     1                  IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR)
            IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
         ENDIF
      ENDIF
C
      IF(ICOM.EQ.'MEDI')THEN
         IF(NUMARG.GE.2.AND.IHARG(1).EQ.'LEVE'.AND.
     1      IHARG(2).EQ.'TEST')THEN
            ISHIFT=2
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1                  IBUGA2,IERROR)
            ICASAN='LMED'
            CALL DPLTES(XTEMP1,XTEMP2,MAXNXT,ICASAN,
     1                  ICAPSW,
     1                  IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR)
            IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
         ELSE IF(NUMARG.GE.1.AND.IHARG(1).EQ.'LEVE')THEN
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1                  IBUGA2,IERROR)
            ICASAN='LMED'
            CALL DPLTES(XTEMP1,XTEMP2,MAXNXT,ICASAN,
     1                  ICAPSW,
     1                  IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR)
            IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
         ENDIF
      ENDIF
C
      IF(ICOM.EQ.'TRIM')THEN
         IF(NUMARG.GE.3.AND.IHARG(1).EQ.'MEAN'.AND.
     1      IHARG(2).EQ.'LEVE'.AND.IHARG(3).EQ.'TEST')THEN
            ISHIFT=3
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1                  IBUGA2,IERROR)
            ICASAN='LTRI'
            CALL DPLTES(XTEMP1,XTEMP2,MAXNXT,ICASAN,
     1                  ICAPSW,
     1                  IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR)
            IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
         ELSE IF(NUMARG.GE.2.AND.IHARG(2).EQ.'MEAN'.AND.
     1      IHARG(2).EQ.'LEVE')THEN
            ISHIFT=2
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1                  IBUGA2,IERROR)
            ICASAN='LTRI'
            CALL DPLTES(XTEMP1,XTEMP2,MAXNXT,ICASAN,
     1                  ICAPSW,
     1                  IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR)
            IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
         ENDIF
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     SEPTEMBER 1997
CCCCC ADD THE ANDERSON-DARLING K-SAMPLE TEST APRIL 1998.
CCCCC ADD THE ANDERSON-DARLING LOGISTIC TEST OCTOBER 2003.
CCCCC ADD THE ANDERSON-DARLING UNIFORM TEST NOVEMBER 2003.
CCCCC ADD THE ANDERSON-DARLING DOUBLE EXPONENTIAL TEST NOVEMBER 2003.
C               *********************************************
C               **  TREAT THE ANDERSON DARLING TEST  CASE  **
C               *********************************************
C
      IF(ICOM.EQ.'ANDE')THEN
         IF(NUMARG.GE.1.AND.IHARG(1).EQ.'DARL')THEN
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
C
         ICASDI='NORM'
         IF(NUMARG.GE.1.AND.(IHARG(1).EQ.'NORM'))THEN
            ICASDI='NORM'
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ELSEIF(NUMARG.GE.1.AND.(IHARG(1).EQ.'LOGN'))THEN
            ICASDI='LOGN'
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ELSEIF(NUMARG.GE.1.AND.(IHARG(1).EQ.'LOGI'))THEN
            ICASDI='LOGI'
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ELSEIF(NUMARG.GE.1.AND.(IHARG(1).EQ.'UNIF'))THEN
            ICASDI='UNIF'
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'LAPL')THEN
            ICASDI='DEXP'
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ELSEIF(NUMARG.GE.2.AND.IHARG(1).EQ.'DOUB'.AND.
     1          IHARG(2).EQ.'EXPO')THEN
            ICASDI='DEXP'
            ISHIFT=2
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ELSEIF(NUMARG.GE.2.AND.IHARG(1).EQ.'GENE'.AND.
     1          IHARG(2).EQ.'PARE')THEN
            ICASDI='GPAR'
            ISHIFT=2
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ELSEIF(NUMARG.GE.1.AND.(IHARG(1).EQ.'EXPO'))THEN
            ICASDI='EXPO'
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ELSEIF(NUMARG.GE.1.AND.(IHARG(1).EQ.'WEIB'))THEN
            ICASDI='WEIB'
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ELSEIF(NUMARG.GE.4.AND.(IHARG(1).EQ.'EXTR'.AND.
     1          IHARG(2).EQ.'VALU'.AND.IHARG(3).EQ.'TYPE'.AND.
     1          IHARG(4).EQ.'1   '))THEN
            ICASDI='EXTV'
            ISHIFT=4
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
CCCCC JULY 2001.  ADD "EV1" AND "EXTREME VALUE TYPE I" AS SYNONYMS
         ELSEIF(NUMARG.GE.4.AND.(IHARG(1).EQ.'EXTR'.AND.
     1          IHARG(2).EQ.'VALU'.AND.IHARG(3).EQ.'TYPE'.AND.
     1          IHARG(4).EQ.'1   '))THEN
            ICASDI='EXTV'
            ISHIFT=4
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ELSEIF(NUMARG.GE.4.AND.(IHARG(1).EQ.'EXTR'.AND.
     1          IHARG(2).EQ.'VALU'.AND.IHARG(3).EQ.'TYPE'.AND.
     1          IHARG(4).EQ.'I   '))THEN
            ICASDI='EXTV'
            ISHIFT=4
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ELSEIF(NUMARG.GE.2.AND.(IHARG(1).EQ.'EXTR'.AND.
     1          IHARG(2).EQ.'VALU'))THEN
            ICASDI='EXTV'
            ISHIFT=2
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ELSEIF(NUMARG.GE.2.AND.IHARG(1).EQ.'EV1 ')THEN
            ICASDI='EXTV'
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ELSEIF(NUMARG.GE.1.AND.(IHARG(1).EQ.'K-SA'))THEN
            ICASDI='K-SA'
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ELSEIF(NUMARG.GE.2.AND.(IHARG(1).EQ.'K   '.AND.IHARG(2).EQ.
     1      'SAMP'))THEN
            ICASDI='K-SA'
            ISHIFT=2
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
C
         IF(NUMARG.GE.1.AND.IHARG(1).EQ.'TEST')THEN
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
C
         IF(NUMARG.GE.1.AND.(IHARG(1).EQ.'NORM'))THEN
            ICASDI='NORM'
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ELSEIF(NUMARG.GE.1.AND.(IHARG(1).EQ.'LOGN'))THEN
            ICASDI='LOGN'
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ELSEIF(NUMARG.GE.1.AND.(IHARG(1).EQ.'LOGI'))THEN
            ICASDI='LOGI'
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'UNIF')THEN
            ICASDI='UNIF'
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'LAPL')THEN
            ICASDI='DEXP'
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ELSEIF(NUMARG.GE.2.AND.IHARG(1).EQ.'DOUB'.AND.
     1          IHARG(2).EQ.'EXPO')THEN
            ICASDI='DEXP'
            ISHIFT=2
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ELSEIF(NUMARG.GE.2.AND.IHARG(1).EQ.'GENE'.AND.
     1          IHARG(2).EQ.'PARE')THEN
            ICASDI='GPAR'
            ISHIFT=2
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ELSEIF(NUMARG.GE.1.AND.(IHARG(1).EQ.'EXPO'))THEN
            ICASDI='EXPO'
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ELSEIF(NUMARG.GE.1.AND.(IHARG(1).EQ.'WEIB'))THEN
            ICASDI='WEIB'
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ELSEIF(NUMARG.GE.4.AND.(IHARG(1).EQ.'EXTR'.AND.
     1          IHARG(2).EQ.'VALU'.AND.IHARG(3).EQ.'TYPE'.AND.
     1          IHARG(4).EQ.'1   '))THEN
            ICASDI='EXTV'
            ISHIFT=4
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ELSEIF(NUMARG.GE.4.AND.(IHARG(1).EQ.'EXTR'.AND.
     1          IHARG(2).EQ.'VALU'.AND.IHARG(3).EQ.'TYPE'.AND.
     1          IHARG(4).EQ.'I   '))THEN
            ICASDI='EXTV'
            ISHIFT=4
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ELSEIF(NUMARG.GE.2.AND.(IHARG(1).EQ.'EXTR'.AND.
     1          IHARG(2).EQ.'VALU'))THEN
            ICASDI='EXTV'
            ISHIFT=2
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'GUMB')THEN
            ICASDI='EXTV'
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'EV1 ')THEN
            ICASDI='EXTV'
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ELSEIF(NUMARG.GE.1.AND.(IHARG(1).EQ.'GAMM'))THEN
            ICASDI='GAMM'
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ELSEIF(NUMARG.GE.1.AND.(IHARG(1).EQ.'CAUC'))THEN
            ICASDI='CAUC'
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ELSEIF(NUMARG.GE.1.AND.(IHARG(1).EQ.'FREC'))THEN
            ICASDI='FREC'
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ELSEIF(NUMARG.GE.4.AND.(IHARG(1).EQ.'EXTR'.AND.
     1          IHARG(2).EQ.'VALU'.AND.IHARG(3).EQ.'TYPE'.AND.
     1          IHARG(4).EQ.'2'))THEN
            ICASDI='FREC'
            ISHIFT=4
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ELSEIF(NUMARG.GE.4.AND.(IHARG(1).EQ.'EXTR'.AND.
     1          IHARG(2).EQ.'VALU'.AND.IHARG(3).EQ.'TYPE'.AND.
     1          IHARG(4).EQ.'II'))THEN
            ICASDI='FREC'
            ISHIFT=4
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
C
         IF(ICASDI.EQ.'K-SA')THEN
           ICASAN='ADKS'
           CALL DPADKS(XTEMP1,XTEMP2,MAXNXT,
     1     IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
           IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
         ELSE
           ICASAN='ATES'
           CALL DPADAR(XTEMP1,MAXNXT,ICASDI,
     1     ICAPSW,
     1     IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
           IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
         ENDIF
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     MARCH 1999
C               *********************************************
C               **  TREAT THE WILKS-SHAPIRO    TEST  CASE  **
C               *********************************************
C
      IF(ICOM.EQ.'WILK'.AND.NUMARG.GE.1.AND.IHARG(1).EQ.'SHAP')THEN
         IFOUND='YES'
         IF(NUMARG.GE.3.AND.IHARG(2).EQ.'NORM'.AND.IHARG(3).EQ.'TEST')
     1     THEN
            ISHIFT=3
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ELSEIF(NUMARG.GE.2.AND.IHARG(2).EQ.'TEST')THEN
            ISHIFT=2
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ELSE
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
C
         ICASAN='WSTE'
           CALL DPWSHA(XTEMP1,MAXNXT,ICASDI,
     1     ICAPSW,
     1     IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     SEPTEMBER 1997
C               *********************************************
C               **  TREAT THE GRUBB            TEST  CASE  **
C               *********************************************
C
      IF(ICOM.EQ.'GRUB')THEN
         ICASAN='GTES'
         IF(NUMARG.GE.2.AND.IHARG(1).EQ.'MINI'.AND.
     1      IHARG(2).EQ.'TEST')THEN
            ISHIFT=2
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1                  IBUGA2,IERROR)
            ICASAN='GTMI'
         ELSEIF(NUMARG.GE.2.AND.IHARG(1).EQ.'MAXI'.AND.
     1      IHARG(2).EQ.'TEST')THEN
            ISHIFT=2
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1                  IBUGA2,IERROR)
            ICASAN='GTMA'
         ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'TEST')THEN
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1                  IBUGA2,IERROR)
         ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'MINI')THEN
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1                  IBUGA2,IERROR)
            ICASAN='GTMI'
         ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'MAXI')THEN
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1                  IBUGA2,IERROR)
            ICASAN='GTMA'
         ENDIF
C
         CALL DPGRUB(XTEMP1,MAXNXT,
     1               ICAPSW,ICASAN,
     1               IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     FEBRUARY 2003
C               *********************************************
C               **  TREAT THE LUJAN-BOX        TEST  CASE  **
C               *********************************************
C
      IF(ICOM.EQ.'LJUN')THEN
         IF(NUMARG.GE.1.AND.IHARG(1).EQ.'TEST')THEN
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ELSEIF(NUMARG.GE.2.AND.IHARG(1).EQ.'BOX '.AND.
     1          IHARG(2).EQ.'TEST')THEN
            ISHIFT=2
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'BOX ')THEN
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
C
         ICASAN='LUJA'
         CALL DPLUJA(XTEMP1,MAXNXT,
     1   IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     NOVEMBER 2003
C               ******************************************************
C               **  TREAT THE FREQUENCY        TEST  CASE           **
C               **  TREAT THE FREQUENCY WITHIN A BLOCK  TEST  CASE  **
C               ******************************************************
C
      IF(ICOM.EQ.'FREQ')THEN
         IFOUND='NO'
         IF(NUMARG.GE.4.AND.IHARG(1).EQ.'WITH'.AND.IHARG(2).EQ.'A'.AND.
     1      IHARG(3).EQ.'BLOC'.AND.IHARG(4).EQ.'TEST')THEN
            ISHIFT=4
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
            ICASAN='FBTE'
            IFOUND='YES'
         ELSEIF(NUMARG.GE.3.AND.IHARG(1).EQ.'WITH'.AND.
     1      IHARG(2).EQ.'BLOC'.AND.IHARG(3).EQ.'TEST')THEN
            ISHIFT=3
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
            ICASAN='FBTE'
            IFOUND='YES'
         ELSEIF(NUMARG.GE.2.AND.IHARG(1).EQ.'BLOC'.AND.
     1      IHARG(2).EQ.'TEST')THEN
            ISHIFT=2
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
            ICASAN='FBTE'
            IFOUND='YES'
         ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'TEST')THEN
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
            ICASAN='FRTE'
            IFOUND='YES'
         ENDIF
C
         IF(IFOUND.EQ.'YES')THEN
           IFOUND='NO'
           CALL DPFRTE(XTEMP1,MAXNXT,
     1                 ICASAN,ICAPSW,
     1                 IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
           IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
         ENDIF
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     DECEMBER 2003
C               ******************************************************
C               **  TREAT THE CUMULATIVE SUM   TEST  CASE           **
C               ******************************************************
C
      IF(ICOM.EQ.'CUMU')THEN
         IFOUND='NO'
         IF(NUMARG.GE.3.AND.IHARG(1).EQ.'SUM '.AND.
     1      IHARG(2).EQ.'RAND'.AND.IHARG(3).EQ.'TEST')THEN
            ISHIFT=3
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
            ICASAN='CUSU'
            IFOUND='YES'
         ELSEIF(NUMARG.GE.2.AND.IHARG(1).EQ.'SUM '.AND.
     1      IHARG(2).EQ.'TEST')THEN
            ISHIFT=2
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
            ICASAN='FBTE'
            IFOUND='YES'
         ELSEIF(NUMARG.GE.2.AND.IHARG(1).EQ.'SUM '.AND.
     1      IHARG(2).EQ.'RAND')THEN
            ISHIFT=2
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
            ICASAN='FBTE'
            IFOUND='YES'
         ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'SUM ')THEN
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
            ICASAN='FRTE'
            IFOUND='YES'
         ENDIF
C
         IF(IFOUND.EQ.'YES')THEN
           IFOUND='NO'
           CALL DPCUSU(XTEMP1,MAXNXT,
     1                 ICASAN,ICAPSW,
     1                 IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
           IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
         ENDIF
      ENDIF
C
      IF(ICOM.EQ.'CUSU')THEN
         IFOUND='NO'
         IF(NUMARG.GE.2.AND.IHARG(1).EQ.'RAND'.AND.
     1      IHARG(2).EQ.'TEST')THEN
            ISHIFT=2
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
            ICASAN='FBTE'
            IFOUND='YES'
         ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'RAND')THEN
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
            ICASAN='FRTE'
            IFOUND='YES'
         ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'TEST')THEN
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
            ICASAN='FRTE'
            IFOUND='YES'
         ENDIF
C
         IF(IFOUND.EQ.'YES')THEN
           IFOUND='NO'
           CALL DPCUSU(XTEMP1,MAXNXT,
     1                 ICASAN,ICAPSW,
     1                 IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
           IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
         ENDIF
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     MARCH 1998
C               ************************************************
C               **  TREAT THE WEIBULL MAXIMUM LIKELIHOOD CASE **
C               ************************************************
C
      IF(ICOM.EQ.'WEIB')THEN
         IF(IHARG(1).EQ.'HAZA')GOTO9000
         IF(IHARG(1).EQ.'CHI ')GOTO9000
         IF(IHARG(1).EQ.'CHIS')GOTO9000
         IF(NUMARG.GE.3.AND.IHARG(1).EQ.'MAXI'.AND.
     1      IHARG(2).EQ.'LIKE'.AND.IHARG(3).EQ.'ESTI')THEN
            ISHIFT=3
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         IF(NUMARG.GE.2.AND.IHARG(1).EQ.'MAXI'.AND.
     1      IHARG(2).EQ.'LIKE')THEN
            ISHIFT=2
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         IF(NUMARG.GE.1.AND.IHARG(1).EQ.'MLE ')THEN
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
C
         ICASAN='WEML'
         CALL DPMLWE(XTEMP1,MAXNXT,
     1   ICAPSW,
     1   MINMAX,ISEED,
     1   ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     AUGUST 2005
C               ***************************************************
C               **  TREAT THE INVERTED WEIBULL MAXIMUM LIKE CASE **
C               ***************************************************
C
      IF(ICOM.EQ.'INVE' .AND. IHARG(1).EQ.'WEIB')THEN
         IF(IHARG(2).EQ.'HAZA')GOTO9000
         IF(IHARG(2).EQ.'CHI ')GOTO9000
         IF(IHARG(2).EQ.'CHIS')GOTO9000
         IF(NUMARG.GE.4.AND.IHARG(2).EQ.'MAXI'.AND.
     1      IHARG(3).EQ.'LIKE'.AND.IHARG(4).EQ.'ESTI')THEN
            ISHIFT=4
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         IF(NUMARG.GE.3.AND.IHARG(2).EQ.'MAXI'.AND.
     1      IHARG(3).EQ.'LIKE')THEN
            ISHIFT=3
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         IF(NUMARG.GE.2.AND.IHARG(2).EQ.'MLE ')THEN
            ISHIFT=2
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
C
         ICASAN='IWML'
         CALL DPMLWE(XTEMP1,MAXNXT,
     1   ICAPSW,
     1   MINMAX,ISEED,
     1   ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     MARCH 1999
C               *******************************************************
C               **  TREAT THE NORMAL  MIXTURE MAXIMUM LIKELIHOOD CASE**
C               *******************************************************
C
      IF(ICOM.EQ.'NORM'.AND.NUMARG.GE.1.AND.IHARG(1).EQ.'MIXT')THEN
         IF(IHARG(2).EQ.'HAZA')GOTO9000
         IF(IHARG(2).EQ.'CHI ')GOTO9000
         IF(IHARG(2).EQ.'CHIS')GOTO9000
         IF(NUMARG.GE.4.AND.IHARG(2).EQ.'MAXI'.AND.
     1      IHARG(3).EQ.'LIKE'.AND.IHARG(4).EQ.'ESTI')THEN
            ISHIFT=4
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         IF(NUMARG.GE.3.AND.IHARG(2).EQ.'MAXI'.AND.
     1      IHARG(3).EQ.'LIKE')THEN
            ISHIFT=3
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         IF(NUMARG.GE.2.AND.IHARG(2).EQ.'MLE ')THEN
            ISHIFT=2
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
C
         ICASAN='NMML'
         CALL DPMLWE(XTEMP1,MAXNXT,
     1   ICAPSW,
     1   MINMAX,ISEED,
     1   ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     APRIL 1998
C               ************************************************
C               **  TREAT THE NORMAL  MAXIMUM LIKELIHOOD CASE **
C               ************************************************
C
      IF(ICOM.EQ.'NORM')THEN
         IF(IHARG(1).EQ.'HAZA')GOTO9000
         IF(IHARG(1).EQ.'CHI ')GOTO9000
         IF(IHARG(1).EQ.'CHIS')GOTO9000
         IF(NUMARG.GE.3.AND.IHARG(1).EQ.'MAXI'.AND.
     1      IHARG(2).EQ.'LIKE'.AND.IHARG(3).EQ.'ESTI')THEN
            ISHIFT=3
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         IF(NUMARG.GE.2.AND.IHARG(1).EQ.'MAXI'.AND.
     1      IHARG(2).EQ.'LIKE')THEN
            ISHIFT=2
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         IF(NUMARG.GE.1.AND.IHARG(1).EQ.'MLE ')THEN
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
C
         ICASAN='NOML'
         CALL DPMLWE(XTEMP1,MAXNXT,
     1   ICAPSW,
     1   MINMAX,ISEED,
     1   ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     APRIL 1998
C               ************************************************
C               **  TREAT THE LOGNORMAL  MAXIMUM LIKELIHOOD CASE **
C               ************************************************
C
      IF(ICOM.EQ.'LOGN'.OR.ICOM.EQ.'LOG-')THEN
         IF(IHARG(1).EQ.'HAZA')GOTO9000
         IF(IHARG(1).EQ.'CHI ')GOTO9000
         IF(IHARG(1).EQ.'CHIS')GOTO9000
         IF(NUMARG.GE.3.AND.IHARG(1).EQ.'MAXI'.AND.
     1      IHARG(2).EQ.'LIKE'.AND.IHARG(3).EQ.'ESTI')THEN
            ISHIFT=3
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         IF(NUMARG.GE.2.AND.IHARG(1).EQ.'MAXI'.AND.
     1      IHARG(2).EQ.'LIKE')THEN
            ISHIFT=2
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         IF(NUMARG.GE.1.AND.IHARG(1).EQ.'MLE ')THEN
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
C
         ICASAN='LGML'
         CALL DPMLWE(XTEMP1,MAXNXT,
     1   ICAPSW,
     1   MINMAX,ISEED,
     1   ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     APRIL 1998
C               ************************************************
C               **  TREAT THE EXPONENTIAL MAXIMUM LIKELIHOOD CASE **
C               ************************************************
C
C  OCTOBER 2004: SUPPORT FOR EXPONENTIAL GROUPED MAXIMUM LIKELIHOOD
C
      IF(ICOM.EQ.'EXPO')THEN
         IF(IHARG(1).EQ.'HAZA')GOTO9000
         IF(IHARG(1).EQ.'CHI ')GOTO9000
         IF(IHARG(1).EQ.'CHIS')GOTO9000
         IF(NUMARG.GE.3.AND.IHARG(1).EQ.'MAXI'.AND.
     1      IHARG(2).EQ.'LIKE'.AND.IHARG(3).EQ.'ESTI')THEN
            ISHIFT=3
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         IF(NUMARG.GE.2.AND.IHARG(1).EQ.'MAXI'.AND.
     1      IHARG(2).EQ.'LIKE')THEN
            ISHIFT=2
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
            ICASAN='EXML'
         ENDIF
         IF(NUMARG.GE.1.AND.IHARG(1).EQ.'MLE ')THEN
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
            ICASAN='EXML'
         ENDIF
C
         IF(NUMARG.GE.4.AND.IHARG(1).EQ.'GROU'.AND.
     1      IHARG(2).EQ.'MAXI'.AND.
     1      IHARG(3).EQ.'LIKE'.AND.IHARG(4).EQ.'ESTI')THEN
            ISHIFT=4
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
            ICASAN='EXMG'
         ENDIF
         IF(NUMARG.GE.3.AND.IHARG(1).EQ.'GROU'.AND.
     1      IHARG(2).EQ.'MAXI'.AND.
     1      IHARG(3).EQ.'LIKE')THEN
            ISHIFT=3
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
            ICASAN='EXMG'
         ENDIF
         IF(NUMARG.GE.2.AND.IHARG(1).EQ.'GROU'.AND.
     1      IHARG(2).EQ.'MLE ')THEN
            ISHIFT=2
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
            ICASAN='EXMG'
         ENDIF
C
         CALL DPMLWE(XTEMP1,MAXNXT,
     1   ICAPSW,
     1   MINMAX,ISEED,
     1   ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     JUNE 1998
C               ************************************************
C               **  TREAT THE DOUBLE EXPONENTIAL MAXIMUM      **
C               **  LIKELIHOOD CASE                           **
C               ************************************************
C
      IF(ICOM.EQ.'DOUB')THEN
         IF(IHARG(2).EQ.'CHI ')GOTO9000
         IF(IHARG(2).EQ.'CHIS')GOTO9000
         IF(NUMARG.GE.4.AND.IHARG(1).EQ.'EXPO'.AND.
     1      IHARG(2).EQ.'MAXI'.AND.
     1      IHARG(3).EQ.'LIKE'.AND.IHARG(4).EQ.'ESTI')THEN
            ISHIFT=4
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         IF(NUMARG.GE.3.AND.IHARG(1).EQ.'EXPO'.AND.
     1      IHARG(2).EQ.'MAXI'.AND.
     1      IHARG(3).EQ.'LIKE')THEN
            ISHIFT=3
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         IF(NUMARG.GE.2.AND.IHARG(1).EQ.'EXPO'.AND.
     1      IHARG(2).EQ.'MLE ')THEN
            ISHIFT=2
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
C
         ICASAN='DEML'
         CALL DPMLWE(XTEMP1,MAXNXT,
     1   ICAPSW,
     1   MINMAX,ISEED,
     1   ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     AUGUST 2004
C               ******************************************************
C               **  TREAT THE ASYMMETRIC DOUBLE EXPONENTIAL MAXIMUM **
C               **  LIKELIHOOD CASE                                 **
C               ******************************************************
C
      IF(ICOM.EQ.'ASYM')THEN
         IF(IHARG(2).EQ.'CHI ')GOTO9000
         IF(IHARG(2).EQ.'CHIS')GOTO9000
         IF(NUMARG.GE.5.AND.IHARG(1).EQ.'DOUB'.AND.
     1      IHARG(2).EQ.'EXPO'.AND.IHARG(3).EQ.'MAXI'.AND.
     1      IHARG(4).EQ.'LIKE'.AND.IHARG(5).EQ.'ESTI')THEN
            ISHIFT=5
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ELSEIF(NUMARG.GE.4.AND.IHARG(1).EQ.'DOUB'.AND.
     1      IHARG(2).EQ.'EXPO'.AND.IHARG(3).EQ.'MAXI'.AND.
     1      IHARG(4).EQ.'LIKE')THEN
            ISHIFT=4
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ELSEIF(NUMARG.GE.3.AND.IHARG(1).EQ.'DOUB'.AND.
     1      IHARG(2).EQ.'EXPO'.AND.IHARG(3).EQ.'MLE ')THEN
            ISHIFT=3
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ELSEIF(NUMARG.GE.4.AND.IHARG(1).EQ.'LAPL'.AND.
     1      IHARG(2).EQ.'MAXI'.AND.
     1      IHARG(3).EQ.'LIKE'.AND.IHARG(4).EQ.'ESTI')THEN
            ISHIFT=4
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ELSEIF(NUMARG.GE.3.AND.IHARG(1).EQ.'LAPL'.AND.
     1      IHARG(2).EQ.'MAXI'.AND.
     1      IHARG(3).EQ.'LIKE')THEN
            ISHIFT=3
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ELSEIF(NUMARG.GE.2.AND.IHARG(1).EQ.'LAPL'.AND.
     1      IHARG(2).EQ.'MLE ')THEN
            ISHIFT=2
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
C
         ICASAN='ADML'
         CALL DPMLWE(XTEMP1,MAXNXT,
     1   ICAPSW,
     1   MINMAX,ISEED,
     1   ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
C
CCCCC THE FOLLOWING SECTION WAS ADDED     MAY 1998
C               ************************************************
C               **  TREAT THE INVERSE GAUSSIAN MAXIMUM LIKELIHOOD CASE
C               ************************************************
C
      IF(ICOM.EQ.'INVE'.AND.IHARG(1).EQ.'GAUS')THEN
         IF(IHARG(2).EQ.'CHI ')GOTO9000
         IF(IHARG(2).EQ.'CHIS')GOTO9000
         IF(NUMARG.GE.4.AND.IHARG(2).EQ.'MAXI'.AND.
     1      IHARG(3).EQ.'LIKE'.AND.IHARG(4).EQ.'ESTI')THEN
            ISHIFT=4
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         IF(NUMARG.GE.3.AND.IHARG(2).EQ.'MAXI'.AND.
     1      IHARG(3).EQ.'LIKE')THEN
            ISHIFT=3
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         IF(NUMARG.GE.2.AND.IHARG(2).EQ.'MLE ')THEN
            ISHIFT=2
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
C
         ICASAN='IGML'
         CALL DPMLWE(XTEMP1,MAXNXT,
     1   ICAPSW,
     1   MINMAX,ISEED,
     1   ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     APRIL 1998
C               ************************************************
C               **  TREAT THE PARETO  MAXIMUM LIKELIHOOD CASE **
C               ************************************************
C
      IF(ICOM.EQ.'PARE')THEN
         IF(IHARG(1).EQ.'CHI ')GOTO9000
         IF(IHARG(1).EQ.'CHIS')GOTO9000
         IF(NUMARG.GE.3.AND.IHARG(1).EQ.'MAXI'.AND.
     1      IHARG(2).EQ.'LIKE'.AND.IHARG(3).EQ.'ESTI')THEN
            ISHIFT=3
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         IF(NUMARG.GE.2.AND.IHARG(1).EQ.'MAXI'.AND.
     1      IHARG(2).EQ.'LIKE')THEN
            ISHIFT=2
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         IF(NUMARG.GE.1.AND.IHARG(1).EQ.'MLE ')THEN
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
C
         ICASAN='PAML'
         CALL DPMLWE(XTEMP1,MAXNXT,
     1   ICAPSW,
     1   MINMAX,ISEED,
     1   ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     JUNE 1998
C               ************************************************
C               **  TREAT THE POWER   MAXIMUM LIKELIHOOD CASE **
C               ************************************************
C
      IF(ICOM.EQ.'POWE')THEN
         IF(IHARG(1).EQ.'CHI ')GOTO9000
         IF(IHARG(1).EQ.'CHIS')GOTO9000
         IF(IHARG(1).EQ.'EXPO')GOTO9000
         IF(NUMARG.GE.3.AND.IHARG(1).EQ.'MAXI'.AND.
     1      IHARG(2).EQ.'LIKE'.AND.IHARG(3).EQ.'ESTI')THEN
            ISHIFT=3
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         IF(NUMARG.GE.2.AND.IHARG(1).EQ.'MAXI'.AND.
     1      IHARG(2).EQ.'LIKE')THEN
            ISHIFT=2
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         IF(NUMARG.GE.1.AND.IHARG(1).EQ.'MLE ')THEN
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
C
         ICASAN='PWML'
         CALL DPMLWE(XTEMP1,MAXNXT,
     1   ICAPSW,
     1   MINMAX,ISEED,
     1   ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     MAY 2002
C               ************************************************
C               **  TREAT THE TWO-SIDED POWER   MAXIMUM       **
C               **  LIKELIHOOD CASE                           **
C               ************************************************
C
      IF(ICOM.EQ.'TWO'.AND.IHARG(1).EQ.'SIDE'.AND.
     1   IHARG(2).EQ.'POWE')THEN
         IF(IHARG(3).EQ.'CHI ')GOTO9000
         IF(IHARG(3).EQ.'CHIS')GOTO9000
         IF(NUMARG.GE.5.AND.IHARG(3).EQ.'MAXI'.AND.
     1      IHARG(4).EQ.'LIKE'.AND.IHARG(5).EQ.'ESTI')THEN
            ISHIFT=5
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         IF(NUMARG.GE.4.AND.IHARG(3).EQ.'MAXI'.AND.
     1      IHARG(4).EQ.'LIKE')THEN
            ISHIFT=4
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         IF(NUMARG.GE.3.AND.IHARG(3).EQ.'MLE ')THEN
            ISHIFT=3
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
C
         ICASAN='TSML'
         CALL DPMLWE(XTEMP1,MAXNXT,
     1   ICAPSW,
     1   MINMAX,ISEED,
     1   ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     JUNE 1998
C               ************************************************
C               **  TREAT THE GUMBEL  MAXIMUM LIKELIHOOD CASE **
C               ************************************************
C
      IF(ICOM.EQ.'GUMB'.OR.ICOM.EQ.'EV1 ')THEN
         IF(IHARG(1).EQ.'CHI ')GOTO9000
         IF(IHARG(1).EQ.'CHIS')GOTO9000
         IF(NUMARG.GE.3.AND.IHARG(1).EQ.'MAXI'.AND.
     1      IHARG(2).EQ.'LIKE'.AND.IHARG(3).EQ.'ESTI')THEN
            ISHIFT=3
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         IF(NUMARG.GE.2.AND.IHARG(1).EQ.'MAXI'.AND.
     1      IHARG(2).EQ.'LIKE')THEN
            ISHIFT=2
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         IF(NUMARG.GE.1.AND.IHARG(1).EQ.'MLE ')THEN
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
C
         ICASAN='GUML'
         CALL DPMLWE(XTEMP1,MAXNXT,
     1   ICAPSW,
     1   MINMAX,ISEED,
     1   ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     MAY 2005
C               ************************************************
C               **  TREAT THE FRECHET MAXIMUM LIKELIHOOD CASE **
C               ************************************************
C
      IF(ICOM.EQ.'FREC'.OR.ICOM.EQ.'EV2 ')THEN
         IF(IHARG(1).EQ.'CHI ')GOTO9000
         IF(IHARG(1).EQ.'CHIS')GOTO9000
         IF(NUMARG.GE.3.AND.IHARG(1).EQ.'MAXI'.AND.
     1      IHARG(2).EQ.'LIKE'.AND.IHARG(3).EQ.'ESTI')THEN
            ISHIFT=3
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         IF(NUMARG.GE.2.AND.IHARG(1).EQ.'MAXI'.AND.
     1      IHARG(2).EQ.'LIKE')THEN
            ISHIFT=2
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         IF(NUMARG.GE.1.AND.IHARG(1).EQ.'MLE ')THEN
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
C
         ICASAN='FRML'
         CALL DPMLWE(XTEMP1,MAXNXT,
     1   ICAPSW,
     1   MINMAX,ISEED,
     1   ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     MARCH 2004.
C               ******************************************************
C               **  TREAT THE GEOMETRIC EXTREME EXPONENTIAL MAXIMUM **
C               **  LIEKLIHOOD CASE                                 **
C               ******************************************************
C
      IF(ICOM.EQ.'GEOM'.AND.IHARG(1).EQ.'EXTR'.AND.
     1   IHARG(2).EQ.'EXPO')THEN
         IF(IHARG(3).EQ.'CHI ')GOTO9000
         IF(IHARG(3).EQ.'CHIS')GOTO9000
         IF(NUMARG.GE.5.AND.IHARG(3).EQ.'MAXI'.AND.
     1      IHARG(4).EQ.'LIKE'.AND.IHARG(5).EQ.'ESTI')THEN
            ISHIFT=5
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         IF(NUMARG.GE.4.AND.IHARG(3).EQ.'MAXI'.AND.
     1      IHARG(4).EQ.'LIKE')THEN
            ISHIFT=4
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         IF(NUMARG.GE.3.AND.IHARG(3).EQ.'MLE ')THEN
            ISHIFT=3
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
C
         ICASAN='GXML'
         CALL DPMLWE(XTEMP1,MAXNXT,
     1   ICAPSW,
     1   MINMAX,ISEED,
     1   ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     MARCH 1999
C               ************************************************
C               **  TREAT THE GENERALIZED EXTREME VALUE       **
C               **  MAXIMUM LIKELIHOOD CASE                   **
C               ************************************************
C
      IF(ICOM.EQ.'GENE'.AND.NUMARG.GE.2.AND.IHARG(1).EQ.'EXTR'.AND.
     1   IHARG(2).EQ.'VALU')THEN
         IF(IHARG(3).EQ.'CHI ')GOTO9000
         IF(IHARG(3).EQ.'CHIS')GOTO9000
         IF(NUMARG.GE.5.AND.IHARG(3).EQ.'MAXI'.AND.
     1      IHARG(4).EQ.'LIKE'.AND.IHARG(5).EQ.'ESTI')THEN
            ISHIFT=5
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         IF(NUMARG.GE.4.AND.IHARG(3).EQ.'MAXI'.AND.
     1      IHARG(4).EQ.'LIKE')THEN
            ISHIFT=4
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         IF(NUMARG.GE.3.AND.IHARG(3).EQ.'MLE ')THEN
            ISHIFT=3
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
C
         ICASAN='GEML'
         CALL DPMLWE(XTEMP1,MAXNXT,
     1               ICAPSW,
     1               MINMAX,ISEED,
     1               ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
      IF(ICOM.EQ.'GEV ')THEN
         IF(IHARG(1).EQ.'CHI ')GOTO9000
         IF(IHARG(1).EQ.'CHIS')GOTO9000
         IF(NUMARG.GE.3.AND.IHARG(1).EQ.'MAXI'.AND.
     1      IHARG(2).EQ.'LIKE'.AND.IHARG(3).EQ.'ESTI')THEN
            ISHIFT=3
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         IF(NUMARG.GE.2.AND.IHARG(1).EQ.'MAXI'.AND.
     1      IHARG(2).EQ.'LIKE')THEN
            ISHIFT=2
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         IF(NUMARG.GE.1.AND.IHARG(1).EQ.'MLE ')THEN
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
C
         ICASAN='GEML'
         CALL DPMLWE(XTEMP1,MAXNXT,
     1   ICAPSW,
     1   MINMAX,ISEED,
     1   ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     JUNE 1998
C               ************************************************
C               **  TREAT THE GAMMA   MAXIMUM LIKELIHOOD CASE **
C               ************************************************
C
      IF(ICOM.EQ.'GAMM')THEN
         IF(IHARG(1).EQ.'CHI ')GOTO9000
         IF(IHARG(1).EQ.'CHIS')GOTO9000
         IF(NUMARG.GE.3.AND.IHARG(1).EQ.'MAXI'.AND.
     1      IHARG(2).EQ.'LIKE'.AND.IHARG(3).EQ.'ESTI')THEN
            ISHIFT=3
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         IF(NUMARG.GE.2.AND.IHARG(1).EQ.'MAXI'.AND.
     1      IHARG(2).EQ.'LIKE')THEN
            ISHIFT=2
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         IF(NUMARG.GE.1.AND.IHARG(1).EQ.'MLE ')THEN
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
C
         ICASAN='GAML'
         CALL DPMLWE(XTEMP1,MAXNXT,
     1   ICAPSW,
     1   MINMAX,ISEED,
     1   ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     SEPTEMBER 2001
C               ************************************************
C               **  TREAT THE BETA    MAXIMUM LIKELIHOOD CASE **
C               ************************************************
C
      IF(ICOM.EQ.'BETA' .AND. IHARG(1).NE.'BINO')THEN
         IF(IHARG(1).EQ.'CHI ')GOTO9000
         IF(IHARG(1).EQ.'CHIS')GOTO9000
         IF(NUMARG.GE.3.AND.IHARG(1).EQ.'MAXI'.AND.
     1      IHARG(2).EQ.'LIKE'.AND.IHARG(3).EQ.'ESTI')THEN
            ISHIFT=3
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         IF(NUMARG.GE.2.AND.IHARG(1).EQ.'MAXI'.AND.
     1      IHARG(2).EQ.'LIKE')THEN
            ISHIFT=2
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         IF(NUMARG.GE.1.AND.IHARG(1).EQ.'MLE ')THEN
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
C
         ICASAN='BEML'
         CALL DPMLWE(XTEMP1,MAXNXT,
     1   ICAPSW,
     1   MINMAX,ISEED,
     1   ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     OCTOBER 2003
C               *************************************************
C               **  TREAT THE LOGISTIC MAXIMUM LIKELIHOOD CASE **
C               *************************************************
C
      IF(ICOM.EQ.'LOGI')THEN
         IF(IHARG(1).EQ.'CHI ')GOTO9000
         IF(IHARG(1).EQ.'CHIS')GOTO9000
         IF(NUMARG.GE.3.AND.IHARG(1).EQ.'MAXI'.AND.
     1      IHARG(2).EQ.'LIKE'.AND.IHARG(3).EQ.'ESTI')THEN
            ISHIFT=3
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         IF(NUMARG.GE.2.AND.IHARG(1).EQ.'MAXI'.AND.
     1      IHARG(2).EQ.'LIKE')THEN
            ISHIFT=2
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         IF(NUMARG.GE.1.AND.IHARG(1).EQ.'MLE ')THEN
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
C
         ICASAN='LOML'
         CALL DPMLWE(XTEMP1,MAXNXT,
     1   ICAPSW,
     1   MINMAX,ISEED,
     1   ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     OCTOBER 2003
C               *************************************************
C               **  TREAT THE CAUCHY   MAXIMUM LIKELIHOOD CASE **
C               *************************************************
C
      IF(ICOM.EQ.'CAUC')THEN
         IF(IHARG(1).EQ.'CHI ')GOTO9000
         IF(IHARG(1).EQ.'CHIS')GOTO9000
         IF(NUMARG.GE.3.AND.IHARG(1).EQ.'MAXI'.AND.
     1      IHARG(2).EQ.'LIKE'.AND.IHARG(3).EQ.'ESTI')THEN
            ISHIFT=3
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         IF(NUMARG.GE.2.AND.IHARG(1).EQ.'MAXI'.AND.
     1      IHARG(2).EQ.'LIKE')THEN
            ISHIFT=2
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         IF(NUMARG.GE.1.AND.IHARG(1).EQ.'MLE ')THEN
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
C
         ICASAN='CAML'
         CALL DPMLWE(XTEMP1,MAXNXT,
     1   ICAPSW,
     1   MINMAX,ISEED,
     1   ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     APRIL 1998
C               ************************************************
C               **  TREAT THE BINOMIAL MAXIMUM LIKELIHOOD CASE **
C               ************************************************
C
      IF(ICOM.EQ.'BINO')THEN
         IF(IHARG(1).EQ.'CHI ')GOTO9000
         IF(IHARG(1).EQ.'CHIS')GOTO9000
         IF(NUMARG.GE.3.AND.IHARG(1).EQ.'MAXI'.AND.
     1      IHARG(2).EQ.'LIKE'.AND.IHARG(3).EQ.'ESTI')THEN
            ISHIFT=3
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         IF(NUMARG.GE.2.AND.IHARG(1).EQ.'MAXI'.AND.
     1      IHARG(2).EQ.'LIKE')THEN
            ISHIFT=2
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         IF(NUMARG.GE.1.AND.IHARG(1).EQ.'MLE ')THEN
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
C
         ICASAN='BIML'
         CALL DPMLWE(XTEMP1,MAXNXT,
     1   ICAPSW,
     1   MINMAX,ISEED,
     1   ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     APRIL 1998
C               ************************************************
C               **  TREAT THE POISSON MAXIMUM LIKELIHOOD CASE **
C               ************************************************
C
      IF(ICOM.EQ.'POIS')THEN
         IF(IHARG(1).EQ.'CHI ')GOTO9000
         IF(IHARG(1).EQ.'CHIS')GOTO9000
         IF(NUMARG.GE.3.AND.IHARG(1).EQ.'MAXI'.AND.
     1      IHARG(2).EQ.'LIKE'.AND.IHARG(3).EQ.'ESTI')THEN
            ISHIFT=3
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         IF(NUMARG.GE.2.AND.IHARG(1).EQ.'MAXI'.AND.
     1      IHARG(2).EQ.'LIKE')THEN
            ISHIFT=2
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         IF(NUMARG.GE.1.AND.IHARG(1).EQ.'MLE ')THEN
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
C
         ICASAN='POML'
         CALL DPMLWE(XTEMP1,MAXNXT,
     1   ICAPSW,
     1   MINMAX,ISEED,
     1   ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     MARCH 1999
C               ************************************************
C               **  TREAT THE BETA BINOMIAL MAXIMUM LIKELIHOOD CASE **
C               ************************************************
C
      IF(ICOM.EQ.'BETA'.AND.NUMARG.GE.1.AND.IHARG(1).EQ.'BINO')THEN
         IF(IHARG(2).EQ.'CHI ')GOTO9000
         IF(IHARG(2).EQ.'CHIS')GOTO9000
         IF(NUMARG.GE.4.AND.IHARG(2).EQ.'MAXI'.AND.
     1      IHARG(3).EQ.'LIKE'.AND.IHARG(4).EQ.'ESTI')THEN
            ISHIFT=4
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         IF(NUMARG.GE.3.AND.IHARG(2).EQ.'MAXI'.AND.
     1      IHARG(3).EQ.'LIKE')THEN
            ISHIFT=3
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         IF(NUMARG.GE.2.AND.IHARG(2).EQ.'MLE ')THEN
            ISHIFT=2
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
C
         ICASAN='BBML'
         CALL DPMLWE(XTEMP1,MAXNXT,
     1   ICAPSW,
     1   MINMAX,ISEED,
     1   ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     MARCH 1999
C               ************************************************
C               **  TREAT THE POLYA MAXIMUM LIKELIHOOD CASE   **
C               ************************************************
C
      IF(ICOM.EQ.'POLY')THEN
         IF(IHARG(1).EQ.'CHI ')GOTO9000
         IF(IHARG(1).EQ.'CHIS')GOTO9000
         IF(NUMARG.GE.3.AND.IHARG(1).EQ.'MAXI'.AND.
     1      IHARG(2).EQ.'LIKE'.AND.IHARG(3).EQ.'ESTI')THEN
            ISHIFT=3
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         IF(NUMARG.GE.2.AND.IHARG(1).EQ.'MAXI'.AND.
     1      IHARG(2).EQ.'LIKE')THEN
            ISHIFT=2
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         IF(NUMARG.GE.1.AND.IHARG(1).EQ.'MLE ')THEN
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
C
         ICASAN='PZML'
         CALL DPMLWE(XTEMP1,MAXNXT,
     1   ICAPSW,
     1   MINMAX,ISEED,
     1   ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     MARCH 2004
C               ******************************************************
C               **  TREAT THE HYPERGEOMETRIC MAXIMUM LIKELIHOOD CASE**
C               ******************************************************
C
      IF(ICOM.EQ.'HYPE')THEN
         IF(IHARG(1).EQ.'CHI ')GOTO9000
         IF(IHARG(1).EQ.'CHIS')GOTO9000
         IF(NUMARG.GE.3.AND.IHARG(1).EQ.'MAXI'.AND.
     1      IHARG(2).EQ.'LIKE'.AND.IHARG(3).EQ.'ESTI')THEN
            ISHIFT=3
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         IF(NUMARG.GE.2.AND.IHARG(1).EQ.'MAXI'.AND.
     1      IHARG(2).EQ.'LIKE')THEN
            ISHIFT=2
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         IF(NUMARG.GE.1.AND.IHARG(1).EQ.'MLE ')THEN
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
C
         ICASAN='HYML'
         CALL DPMLWE(XTEMP1,MAXNXT,
     1   ICAPSW,
     1   MINMAX,ISEED,
     1   ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     APRIL 2004
C               ******************************************************
C               **  TREAT THE HERMITE MAXIMUM LIKELIHOOD CASE       **
C               ******************************************************
C
      IF(ICOM.EQ.'HERM')THEN
         IF(IHARG(1).EQ.'CHI ')GOTO9000
         IF(IHARG(1).EQ.'CHIS')GOTO9000
         IF(NUMARG.GE.3.AND.IHARG(1).EQ.'MAXI'.AND.
     1      IHARG(2).EQ.'LIKE'.AND.IHARG(3).EQ.'ESTI')THEN
            ISHIFT=3
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         IF(NUMARG.GE.2.AND.IHARG(1).EQ.'MAXI'.AND.
     1      IHARG(2).EQ.'LIKE')THEN
            ISHIFT=2
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         IF(NUMARG.GE.1.AND.IHARG(1).EQ.'MLE ')THEN
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
C
         ICASAN='HEML'
         CALL DPMLWE(XTEMP1,MAXNXT,
     1   ICAPSW,
     1   MINMAX,ISEED,
     1   ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     APRIL 2004
C               ******************************************************
C               **  TREAT THE YULE    MAXIMUM LIKELIHOOD CASE       **
C               ******************************************************
C
      IF(ICOM.EQ.'YULE')THEN
         IF(IHARG(1).EQ.'CHI ')GOTO9000
         IF(IHARG(1).EQ.'CHIS')GOTO9000
         IF(NUMARG.GE.3.AND.IHARG(1).EQ.'MAXI'.AND.
     1      IHARG(2).EQ.'LIKE'.AND.IHARG(3).EQ.'ESTI')THEN
            ISHIFT=3
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         IF(NUMARG.GE.2.AND.IHARG(1).EQ.'MAXI'.AND.
     1      IHARG(2).EQ.'LIKE')THEN
            ISHIFT=2
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         IF(NUMARG.GE.1.AND.IHARG(1).EQ.'MLE ')THEN
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
C
         ICASAN='YUML'
         CALL DPMLWE(XTEMP1,MAXNXT,
     1   ICAPSW,
     1   MINMAX,ISEED,
     1   ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     APRIL 2004
C               ******************************************************
C               **  TREAT THE WARING  MAXIMUM LIKELIHOOD CASE       **
C               ******************************************************
C
      IF(ICOM.EQ.'WARI')THEN
         IF(IHARG(1).EQ.'CHI ')GOTO9000
         IF(IHARG(1).EQ.'CHIS')GOTO9000
         IF(NUMARG.GE.3.AND.IHARG(1).EQ.'MAXI'.AND.
     1      IHARG(2).EQ.'LIKE'.AND.IHARG(3).EQ.'ESTI')THEN
            ISHIFT=3
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         IF(NUMARG.GE.2.AND.IHARG(1).EQ.'MAXI'.AND.
     1      IHARG(2).EQ.'LIKE')THEN
            ISHIFT=2
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         IF(NUMARG.GE.1.AND.IHARG(1).EQ.'MLE ')THEN
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
C
         ICASAN='WAML'
         CALL DPMLWE(XTEMP1,MAXNXT,
     1   ICAPSW,
     1   MINMAX,ISEED,
     1   ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     JUNE 2004
C               ******************************************************
C               **  TREAT THE RAYLEIG MAXIMUM LIKELIHOOD CASE       **
C               ******************************************************
C
      IF(ICOM.EQ.'RAYL')THEN
         IF(IHARG(1).EQ.'CHI ')GOTO9000
         IF(IHARG(1).EQ.'CHIS')GOTO9000
         IF(NUMARG.GE.3.AND.IHARG(1).EQ.'MAXI'.AND.
     1      IHARG(2).EQ.'LIKE'.AND.IHARG(3).EQ.'ESTI')THEN
            ISHIFT=3
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         IF(NUMARG.GE.2.AND.IHARG(1).EQ.'MAXI'.AND.
     1      IHARG(2).EQ.'LIKE')THEN
            ISHIFT=2
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         IF(NUMARG.GE.1.AND.IHARG(1).EQ.'MLE ')THEN
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
C
         ICASAN='RAYL'
         CALL DPMLWE(XTEMP1,MAXNXT,
     1   ICAPSW,
     1   MINMAX,ISEED,
     1   ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     JUNE 2004
C               ******************************************************
C               **  TREAT THE MAXWELL MAXIMUM LIKELIHOOD CASE       **
C               ******************************************************
C
      IF(ICOM.EQ.'MAXW')THEN
         IF(IHARG(1).EQ.'CHI ')GOTO9000
         IF(IHARG(1).EQ.'CHIS')GOTO9000
         IF(NUMARG.GE.3.AND.IHARG(1).EQ.'MAXI'.AND.
     1      IHARG(2).EQ.'LIKE'.AND.IHARG(3).EQ.'ESTI')THEN
            ISHIFT=3
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         IF(NUMARG.GE.2.AND.IHARG(1).EQ.'MAXI'.AND.
     1      IHARG(2).EQ.'LIKE')THEN
            ISHIFT=2
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         IF(NUMARG.GE.1.AND.IHARG(1).EQ.'MLE ')THEN
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
C
         ICASAN='MAXW'
         CALL DPMLWE(XTEMP1,MAXNXT,
     1   ICAPSW,
     1   MINMAX,ISEED,
     1   ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     NOVEMBER 2003.
C               ******************************************************
C               **  TREAT THE GENERALIZED PARETO MAXIMUM LIKELIHOOD **
C               **  CASE                                            **
C               ******************************************************
C
      IF(ICOM.EQ.'GENE'.AND.IHARG(1).EQ.'PARE')THEN
         IF(IHARG(2).EQ.'CHI ')GOTO9000
         IF(IHARG(2).EQ.'CHIS')GOTO9000
         IF(NUMARG.GE.4.AND.IHARG(2).EQ.'MAXI'.AND.
     1      IHARG(3).EQ.'LIKE'.AND.IHARG(4).EQ.'ESTI')THEN
            ISHIFT=4
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         IF(NUMARG.GE.3.AND.IHARG(2).EQ.'MAXI'.AND.
     1      IHARG(3).EQ.'LIKE')THEN
            ISHIFT=3
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         IF(NUMARG.GE.2.AND.IHARG(2).EQ.'MLE ')THEN
            ISHIFT=2
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
C
         ICASAN='GPML'
         CALL DPMLWE(XTEMP1,MAXNXT,
     1   ICAPSW,
     1   MINMAX,ISEED,
     1   ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     FEBRUARY 2006.
C               ******************************************************
C               **  TREAT THE GENERALIZED LOGISTIC MAXIMUM          **
C               **  LIKELIHOOD CASE                                 **
C               ******************************************************
C
      IF(ICOM.EQ.'GENE'.AND.IHARG(1).EQ.'LOGI')THEN
         IF(IHARG(2).EQ.'CHI ')GOTO9000
         IF(IHARG(2).EQ.'CHIS')GOTO9000
         IF(NUMARG.GE.4.AND.IHARG(2).EQ.'MAXI'.AND.
     1      IHARG(3).EQ.'LIKE'.AND.IHARG(4).EQ.'ESTI')THEN
            ISHIFT=4
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         IF(NUMARG.GE.3.AND.IHARG(2).EQ.'MAXI'.AND.
     1      IHARG(3).EQ.'LIKE')THEN
            ISHIFT=3
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         IF(NUMARG.GE.2.AND.IHARG(2).EQ.'MLE ')THEN
            ISHIFT=2
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
C
         ICASAN='GLML'
         CALL DPMLWE(XTEMP1,MAXNXT,
     1   ICAPSW,
     1   MINMAX,ISEED,
     1   ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     MAY 1998
C               ************************************************
C               **  TREAT THE DEHAAN CASE (GENERALIZED PARETO **
C               ************************************************
C
      IF(ICOM.EQ.'DEHA')THEN
         IF(NUMARG.GE.3.AND.IHARG(1).EQ.'GENE'.AND.
     1      IHARG(2).EQ.'PARE'.AND.IHARG(3).EQ.'ESTI')THEN
            ISHIFT=3
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         IF(NUMARG.GE.2.AND.IHARG(1).EQ.'GENE'.AND.
     1      IHARG(2).EQ.'PARE')THEN
            ISHIFT=2
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         IF(NUMARG.GE.1.AND.IHARG(1).EQ.'ESTI')THEN
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
C
         ICASAN='GPDE'
         CALL DPMLWE(XTEMP1,MAXNXT,
     1   ICAPSW,
     1   MINMAX,ISEED,
     1   ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     MAY 1998
C               ************************************************
C               **  TREAT THE CME    CASE (GENERALIZED PARETO **
C               ************************************************
C
      IF(ICOM.EQ.'CME ')THEN
         IF(NUMARG.GE.3.AND.IHARG(1).EQ.'GENE'.AND.
     1      IHARG(2).EQ.'PARE'.AND.IHARG(3).EQ.'ESTI')THEN
            ISHIFT=3
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         IF(NUMARG.GE.2.AND.IHARG(1).EQ.'GENE'.AND.
     1      IHARG(2).EQ.'PARE')THEN
            ISHIFT=2
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         IF(NUMARG.GE.1.AND.IHARG(1).EQ.'ESTI')THEN
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
C
C  CHECK FOR NAME CONFLICT WITH CME PLOT
C
         IF(NUMARG.GE.1.AND.IHARG(1).EQ.'PLOT')GOTO9000
C
         ICASAN='GPCM'
         CALL DPMLWE(XTEMP1,MAXNXT,
     1   ICAPSW,
     1   MINMAX,ISEED,
     1   ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     JULY 2003
C               ************************************************
C               **  TREAT THE JOHNSON SB MOMENTS       CASE   **
C               **  TREAT THE JOHNSON SU MOMENTS       CASE   **
C               **  TREAT THE JOHNSON SB PERCENTILE    CASE   **
C               **  TREAT THE JOHNSON SU PERCENTILE    CASE   **
C               ************************************************
C
      IF(ICOM.EQ.'JOHN')THEN
         IF(NUMARG.GE.2.AND.IHARG(1).EQ.'SB  '.AND.
     1      IHARG(2).EQ.'MOME')THEN
            ISHIFT=2
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
            ICASAN='JOSB'
            CALL DPMLWE(XTEMP1,MAXNXT,
     1           ICAPSW,
     1           MINMAX,ISEED,
     1           ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
            IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
         ELSEIF(NUMARG.GE.2.AND.IHARG(1).EQ.'SU  '.AND.
     1      IHARG(2).EQ.'MOME')THEN
            ISHIFT=2
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
            ICASAN='JOSU'
            CALL DPMLWE(XTEMP1,MAXNXT,
     1           ICAPSW,
     1           MINMAX,ISEED,
     1           ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
            IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
         ELSEIF(NUMARG.GE.3.AND.IHARG(1).EQ.'SB  '.AND.
     1      IHARG(2).EQ.'PERC'.AND.IHARG(3).EQ.'ESTI')THEN
            ISHIFT=3
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
            ICASAN='JOHN'
            CALL DPMLWE(XTEMP1,MAXNXT,
     1           ICAPSW,
     1           MINMAX,ISEED,
     1           ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
            IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
         ELSEIF(NUMARG.GE.2.AND.IHARG(1).EQ.'SB  '.AND.
     1      IHARG(2).EQ.'PERC')THEN
            ISHIFT=2
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
            ICASAN='JOHN'
            CALL DPMLWE(XTEMP1,MAXNXT,
     1           ICAPSW,
     1           MINMAX,ISEED,
     1           ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
            IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
         ELSEIF(NUMARG.GE.3.AND.IHARG(1).EQ.'SU  '.AND.
     1      IHARG(2).EQ.'PERC'.AND.IHARG(3).EQ.'ESTI')THEN
            ISHIFT=3
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
            ICASAN='JOHN'
            CALL DPMLWE(XTEMP1,MAXNXT,
     1           ICAPSW,
     1           MINMAX,ISEED,
     1           ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
            IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
         ELSEIF(NUMARG.GE.2.AND.IHARG(1).EQ.'SU  '.AND.
     1      IHARG(2).EQ.'PERC')THEN
            ISHIFT=2
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
            ICASAN='JOHN'
            CALL DPMLWE(XTEMP1,MAXNXT,
     1           ICAPSW,
     1           MINMAX,ISEED,
     1           ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
            IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
         ELSEIF(NUMARG.GE.2.AND.IHARG(1).EQ.'PERC'.AND.
     1      IHARG(2).EQ.'ESTI')THEN
            ISHIFT=2
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
            ICASAN='JOHN'
            CALL DPMLWE(XTEMP1,MAXNXT,
     1           ICAPSW,
     1           MINMAX,ISEED,
     1           ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
            IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
         ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'PERC')THEN
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
            ICASAN='JOHN'
            CALL DPMLWE(XTEMP1,MAXNXT,
     1           ICAPSW,
     1           MINMAX,ISEED,
     1           ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
            IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
         ENDIF
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     OCTOBER 2003
C               ************************************************
C               **  TREAT THE UNIFORM MOMENTS          CASE   **
C               ************************************************
C
      IF(ICOM.EQ.'UNIF')THEN
         IF(NUMARG.GE.1.AND.IHARG(1).EQ.'MOME')THEN
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
            ICASAN='UNIF'
            CALL DPMLWE(XTEMP1,MAXNXT,
     1           ICAPSW,
     1           MINMAX,ISEED,
     1           ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
            IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
         ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'MLE ')THEN
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
            ICASAN='UNIF'
            CALL DPMLWE(XTEMP1,MAXNXT,
     1           ICAPSW,
     1           MINMAX,ISEED,
     1           ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
            IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
         ELSEIF(NUMARG.GE.2.AND.IHARG(1).EQ.'MAXI'.AND.
     1          IHARG(2).EQ.'LIKE')THEN
            ISHIFT=2
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
            ICASAN='UNIF'
            CALL DPMLWE(XTEMP1,MAXNXT,
     1           ICAPSW,
     1           MINMAX,ISEED,
     1           ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
            IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
         ENDIF
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     MARCH 2004
C               ******************************************************
C               **  TREAT THE FATIGUE LIFE       MAXIMUM LIKELIHOOD **
C               **  CASE                                            **
C               ******************************************************
C
      IF(ICOM.EQ.'FATI'.AND.IHARG(1).EQ.'LIFE')THEN
         IF(IHARG(2).EQ.'CHI ')GOTO9000
         IF(IHARG(2).EQ.'CHIS')GOTO9000
         IF(NUMARG.GE.4.AND.IHARG(2).EQ.'MAXI'.AND.
     1      IHARG(3).EQ.'LIKE'.AND.IHARG(4).EQ.'ESTI')THEN
            ISHIFT=4
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         IF(NUMARG.GE.3.AND.IHARG(2).EQ.'MAXI'.AND.
     1      IHARG(3).EQ.'LIKE')THEN
            ISHIFT=3
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         IF(NUMARG.GE.2.AND.IHARG(2).EQ.'MLE ')THEN
            ISHIFT=2
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
C
         ICASAN='FLML'
         CALL DPMLWE(XTEMP1,MAXNXT,
     1   ICAPSW,
     1   MINMAX,ISEED,
     1   ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     MARCH 2004
C               ******************************************************
C               **  TREAT THE FOLDED NORMAL      MAXIMUM LIKELIHOOD **
C               **  CASE                                            **
C               ******************************************************
C
      IF(ICOM.EQ.'FOLD'.AND.IHARG(1).EQ.'NORM')THEN
         IF(IHARG(2).EQ.'CHI ')GOTO9000
         IF(IHARG(2).EQ.'CHIS')GOTO9000
         IF(NUMARG.GE.4.AND.IHARG(2).EQ.'MAXI'.AND.
     1      IHARG(3).EQ.'LIKE'.AND.IHARG(4).EQ.'ESTI')THEN
            ISHIFT=4
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         IF(NUMARG.GE.3.AND.IHARG(2).EQ.'MAXI'.AND.
     1      IHARG(3).EQ.'LIKE')THEN
            ISHIFT=3
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         IF(NUMARG.GE.2.AND.IHARG(2).EQ.'MLE ')THEN
            ISHIFT=2
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
C
         ICASAN='FNML'
         CALL DPMLWE(XTEMP1,MAXNXT,
     1   ICAPSW,
     1   MINMAX,ISEED,
     1   ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     MARCH 2004
C               ******************************************************
C               **  TREAT THE LOGARITHMIC SERIES MAXIMUM LIKELIHOOD **
C               **  CASE                                            **
C               ******************************************************
C
      IF(ICOM.EQ.'LOGA'.AND.NUMARG.GE.1.AND.IHARG(1).EQ.'SERI')THEN
         IF(IHARG(1).EQ.'CHI ')GOTO9000
         IF(IHARG(1).EQ.'CHIS')GOTO9000
         IF(NUMARG.GE.4.AND.IHARG(2).EQ.'MAXI'.AND.
     1      IHARG(3).EQ.'LIKE'.AND.IHARG(4).EQ.'ESTI')THEN
            ISHIFT=4
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         IF(NUMARG.GE.3.AND.IHARG(2).EQ.'MAXI'.AND.
     1      IHARG(3).EQ.'LIKE')THEN
            ISHIFT=3
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         IF(NUMARG.GE.2.AND.IHARG(2).EQ.'MLE ')THEN
            ISHIFT=2
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
C
         ICASAN='DLML'
         CALL DPMLWE(XTEMP1,MAXNXT,
     1   ICAPSW,
     1   MINMAX,ISEED,
     1   ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     MARCH 2004
C               ******************************************************
C               **  TREAT THE NEGATIVE BINOMIAL MAXIMUM LIKELIHOOD  **
C               **  CASE                                            **
C               ******************************************************
C
      IF(ICOM.EQ.'NEGA'.AND.NUMARG.GE.1.AND.IHARG(1).EQ.'BINO')THEN
         IF(IHARG(1).EQ.'CHI ')GOTO9000
         IF(IHARG(1).EQ.'CHIS')GOTO9000
         IF(NUMARG.GE.4.AND.IHARG(2).EQ.'MAXI'.AND.
     1      IHARG(3).EQ.'LIKE'.AND.IHARG(4).EQ.'ESTI')THEN
            ISHIFT=4
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         IF(NUMARG.GE.3.AND.IHARG(2).EQ.'MAXI'.AND.
     1      IHARG(3).EQ.'LIKE')THEN
            ISHIFT=3
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         IF(NUMARG.GE.2.AND.IHARG(2).EQ.'MLE ')THEN
            ISHIFT=2
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
C
         ICASAN='NBML'
         CALL DPMLWE(XTEMP1,MAXNXT,
     1   ICAPSW,
     1   MINMAX,ISEED,
     1   ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     MARCH 2004
C               **************************************************
C               **  TREAT THE GEOMETRIC MAXIMUM LIKELIHOOD CASE **
C               **************************************************
C
      IF(ICOM.EQ.'GEOM')THEN
         IF(IHARG(1).EQ.'CHI ')GOTO9000
         IF(IHARG(1).EQ.'CHIS')GOTO9000
         IF(NUMARG.GE.3.AND.IHARG(1).EQ.'MAXI'.AND.
     1      IHARG(2).EQ.'LIKE'.AND.IHARG(3).EQ.'ESTI')THEN
            ISHIFT=3
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         IF(NUMARG.GE.2.AND.IHARG(1).EQ.'MAXI'.AND.
     1      IHARG(2).EQ.'LIKE')THEN
            ISHIFT=2
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         IF(NUMARG.GE.1.AND.IHARG(1).EQ.'MLE ')THEN
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
C
         ICASAN='GMML'
         CALL DPMLWE(XTEMP1,MAXNXT,
     1   ICAPSW,
     1   MINMAX,ISEED,
     1   ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     APRIL 1998
C               ************************************************
C               **  TREAT THE A BASIS TOLERANCE LIMIT    CASE **
C               ************************************************
C
      IF(ICOM.EQ.'A   ')THEN
         ICASDI='NORM'
         IF(NUMARG.GE.1.AND.IHARG(1).EQ.'BASI')THEN
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         IF(NUMARG.GE.1.AND.IHARG(1).EQ.'NORM')THEN
            ICASDI='NORM'
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'WEIB')THEN
            ICASDI='WEIB'
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'LOGN')THEN
            ICASDI='LOGN'
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'NONP')THEN
            ICASDI='NONP'
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         IF(NUMARG.GE.2.AND.IHARG(1).EQ.'TOLE'.AND.
     1      IHARG(2).EQ.'LIMI')THEN
            ISHIFT=2
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'TOLE')THEN
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
C
         ICASAN='ABAS'
         CALL DPABAS(XTEMP1,MAXNXT,
     1   ICASAN,ICASDI,
     1   IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
      IF(ICOM.EQ.'A-BA'.OR.ICOM.EQ.'ABAS')THEN
         ICASDI='NORM'
         IF(NUMARG.GE.1.AND.IHARG(1).EQ.'NORM')THEN
            ICASDI='NORM'
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'WEIB')THEN
            ICASDI='WEIB'
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'LOGN')THEN
            ICASDI='LOGN'
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'NONP')THEN
            ICASDI='NONP'
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         IF(NUMARG.GE.2.AND.IHARG(1).EQ.'TOLE'.AND.
     1      IHARG(2).EQ.'LIMI')THEN
            ISHIFT=2
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'TOLE')THEN
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
C
         ICASAN='ABAS'
         CALL DPABAS(XTEMP1,MAXNXT,
     1   ICASAN,ICASDI,
     1   IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     APRIL 1998
C               ************************************************
C               **  TREAT THE B BASIS TOLERANCE LIMIT    CASE **
C               ************************************************
C
      IF(ICOM.EQ.'B   ')THEN
         ICASDI='NORM'
         IF(NUMARG.GE.1.AND.IHARG(1).EQ.'BASI')THEN
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         IF(NUMARG.GE.1.AND.IHARG(1).EQ.'NORM')THEN
            ICASDI='NORM'
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'WEIB')THEN
            ICASDI='WEIB'
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'LOGN')THEN
            ICASDI='LOGN'
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'NONP')THEN
            ICASDI='NONP'
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         IF(NUMARG.GE.2.AND.IHARG(1).EQ.'TOLE'.AND.
     1      IHARG(2).EQ.'LIMI')THEN
            ISHIFT=2
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'TOLE')THEN
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
C
         ICASAN='BBAS'
         CALL DPABAS(XTEMP1,MAXNXT,
     1   ICASAN,ICASDI,
     1   IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
      IF(ICOM.EQ.'B-BA'.OR.ICOM.EQ.'BBAS')THEN
         ICASDI='NORM'
         IF(NUMARG.GE.1.AND.IHARG(1).EQ.'NORM')THEN
            ICASDI='NORM'
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'WEIB')THEN
            ICASDI='WEIB'
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'LOGN')THEN
            ICASDI='LOGN'
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'NONP')THEN
            ICASDI='NONP'
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         IF(NUMARG.GE.2.AND.IHARG(1).EQ.'TOLE'.AND.
     1      IHARG(2).EQ.'LIMI')THEN
            ISHIFT=2
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'TOLE')THEN
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
C
         ICASAN='BBAS'
         CALL DPABAS(XTEMP1,MAXNXT,
     1   ICASAN,ICASDI,
     1   IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
C               *******************************************
C               **  TREAT THE (2**K) DEX FIT CASE        **
C               **  TREAT THE    YATES ANALYSIS    CASE  **
C               *******************************************
C
      IF(ICOM.EQ.'2**K')GOTO3400
      IF(ICOM.EQ.'DEX'.AND.NUMARG.GE.1.AND.
     1IHARG(1).EQ.'FIT')GOTO3400
      IF(ICOM.EQ.'YATE')GOTO3400
      GOTO3499
C
 3400 CONTINUE
CCCCC THE FOLLOWING 4 LINES WERE INSERTED NOVEMBER 1989
      IF(NUMARG.GE.2.AND.IHARG(2).EQ.'CUTO'.AND.
     1IHARG2(2).EQ.'FF')GOTO3499
      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'OUTP'.AND.
     1IHARG2(1).EQ.'UT')GOTO3499
CCCCC THE FOLLOWING 2 LINES WERE INSERTED FEBRUARY 1995
      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'PHD ')GOTO3499
      ICASAN='DEXF'
      CALL DPYATE(ICASAN,
     1ICAPSW,
     1IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
C
 3499 CONTINUE
C
C               ********************************************************
C               **  TREAT THE ... MAXIMUM LIKELIHOOD ESTIMATION CASE  **
C               ********************************************************
C
      IF(NUMARG.GE.2.AND.ICOM.EQ.'MAXI'.AND.
     1IHARG(1).EQ.'LIKE'.AND.IHARG(2).EQ.'ESTI')GOTO4100
      DO4110I=3,6
      IM1=I-1
      IM2=I-2
      IF(NUMARG.GE.2.AND.IHARG(IM2).EQ.'MAXI'.AND.
     1IHARG(IM1).EQ.'LIKE'.AND.IHARG(I).EQ.'ESTI')GOTO4100
 4110 CONTINUE
      GOTO4199
C
 4100 CONTINUE
      ICASAN='MLE'
      CALL DPMLE(ICASML,ISEED,ILOCES,
     1IBUGA3,IBUGQ,IFOUND,IERROR)
      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      GOTO9000
C
 4199 CONTINUE
C
C               *******************************
C               **  TREAT THE TABULATE CASE  **
C               *******************************
C
      IF(ICOM.EQ.'TABU')GOTO4200
      IF(ICOM.EQ.'TAB')GOTO4200
      GOTO4299
C
 4200 CONTINUE
      ICASAN='TABU'
      CALL DPTABU(XTEMP1,XTEMP2,MAXNXT,
     1ISEED,ICAPSW,
     1IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
C
 4299 CONTINUE
C
CCCCC THE FOLLOWING SECTION WAS ADDED NOVEMBER 1989
C               *************************************
C               **  TREAT THE CROSS-TABULATE CASE  **
C               *************************************
C
      IF(ICOM.EQ.'CROS')GOTO4300
      GOTO4399
C
 4300 CONTINUE
      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'TABU')GOTO4310
      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'TAB')GOTO4310
      GOTO4399
 4310 CONTINUE
      ICASAN='CRTA'
CCCCC ISHIFT=1
CCCCC CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
CCCCC1IBUGA2,IERROR)
      CALL DPCRTA(TEMP,XTEMP1,XTEMP2,MAXNXT,
     1ISEED,
     1ICAPSW,
     1IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
C
 4399 CONTINUE
C
CCCCC THE FOLLOWING SECTION WAS ADDED MAY 1988
C               **********************************************
C               **  TREAT THE EXPERIMENTAL SIMULATION CASE  **
C               **  (SYNONYM = RUN)                         **
C               **********************************************
C
      IF(ICOM.EQ.'EXPE')GOTO4400
      IF(ICOM.EQ.'RUN')GOTO4400
      GOTO4499
C
 4400 CONTINUE
      ICASAN='EXSI'
      CALL DPEXSI(ISEED,XTEMP1,XTEMP2,MAXNXT,ICASAN,
     1IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
C
 4499 CONTINUE
C
CCCCC THE FOLLOWING SECTION WAS ADDED SEPTEMBER 1990
C               ******************************************
C               **  TREAT THE CAPABILITY ANALYSIS CASE  **
C               ******************************************
C
      IF(ICOM.EQ.'CAPA')GOTO4500
      IF(ICOM.EQ.'CAPA'.AND.ICOM2.EQ.'BILI')GOTO4500
      IF(ICOM.EQ.'CP  ')GOTO4500
      IF(ICOM.EQ.'CPK ')GOTO4500
      GOTO4599
C
 4500 CONTINUE
      ICASAN='CAPA'
      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'ANAL')GOTO4510
      GOTO4519
 4510 CONTINUE
      ISHIFT=1
      CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1IBUGA2,IERROR)
 4519 CONTINUE
      CALL DPCAAN(XTEMP1,XTEMP2,MAXNXT,
     1IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR)
      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
C
 4599 CONTINUE
C
C               *******************************************
C               **  TREAT THE (YATES) PHD ANALYSIS CASE  **
C               *******************************************
C
CCCCC FEBRUARY 1995.  RENAME PHD TO DEX PHD IN ORDER TO ALLOW
CCCCC FUTURE ADDITION OF A MORE GENERAL PHD COMMAND.
CCCCC IF(ICOM.EQ.'PHD ')GOTO4600
      IF(ICOM.EQ.'DEX ')THEN
        IF(NUMARG.GE.1.AND.IHARG(1).EQ.'PHD ')GOTO4600
        GOTO4699
      ENDIF
      IF(ICOM.EQ.'PHD ')THEN
        IF(NUMARG.GE.1.AND.IHARG(1).EQ.'DEX ')GOTO4600
        GOTO4699
      ENDIF
      GOTO4699
C
 4600 CONTINUE
      ICASAN='PHD '
      CALL DPPHD(ICASAN,
     1IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
C
 4699 CONTINUE
C
CCCCC THE FOLLOWING SECTION WAS ADDED     MARCH 1994
C               ******************************
C               **  TREAT THE DDS     CASE  **
C               ******************************
C
      IF(ICOM.EQ.'DDS ')THEN
         ICASAN='DDS '
         CALL DPDDS(XTEMP1,XTEMP2,MAXNXT,
     1   IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     MAY 1999
C               ******************************
C               **  TREAT THE ARMA    CASE  **
C               ******************************
C
      IF(ICOM.EQ.'ARMA'.OR.ICOM.EQ.'ARIM')THEN
         ICASAN='ARMA'
         IF(NUMARG.GE.1.AND.IHARG(1).EQ.'FIT ')THEN
           ISHIFT=1
           CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1                 IBUGA2,IERROR)
         ENDIF
         IF(NUMARG.GE.1.AND.IHARG(1).EQ.'MODE')THEN
           ISHIFT=1
           CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1                 IBUGA2,IERROR)
         ENDIF
         IF(NUMARG.GE.1.AND.IHARG(1).EQ.'FORE')THEN
           ISHIFT=1
           CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1                 IBUGA2,IERROR)
           ICASAN='ARFC'
         ENDIF
         CALL DPARMA(XTEMP1,XTEMP2,MAXNXT,
     1   ISUBRO,IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     JULY 1995
CCCCC THE FOLLOWING SECTION WAS ACTIVATED SEPTEMBER 1997
C               ************************************************
C               **  TREAT THE ... RECIPE ANALYSIS CASE        **
C               **  RECIPE = REGRESSION CONFIDENCE INTERVALS  **
C               **           ON PERCENTILES                   **
C               ************************************************
C
CCCCC ACTIVATE COMMAND   AUGUST 1997
      IF(NUMARG.GE.1.AND.ICOM.EQ.'RECI'.AND.IHARG(1).NE.'SIMC')THEN
         IF(NUMARG.GE.2.AND.IHARG(1).EQ.'PROB'.AND.IHARG(2).EQ.'PLOT')
     1     GOTO4799
         IF(NUMARG.GE.2.AND.IHARG(1).EQ.'PPCC'.AND.IHARG(2).EQ.'PLOT')
     1     GOTO4799
         IF(NUMARG.GE.2.AND.IHARG(1).EQ.'KOLM'.AND.IHARG(2).EQ.'SMIR')
     1     GOTO4799
         IF(NUMARG.GE.2.AND.IHARG(1).EQ.'CHI '.AND.IHARG(2).EQ.'SQUA')
     1     GOTO4799
         IF(NUMARG.GE.1.AND.IHARG(1).EQ.'CHI ')
     1     GOTO4799
         ICASAN='RECI'
         CALL DPRECI(ISEED,IBUGA2,IBUGA3,IBUGCO,IBUGEV,IBUGQ,ISUBRO,
     1               IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
 4799 CONTINUE
C
CCCCC THE FOLLOWING SECTION WAS ADDED     SEPTEMBER 1997
C               ************************************************
C               **  TREAT THE ... SIMCOV ANALYSIS CASE        **
C               **  USED PRIOR TO A RECIPE ANALYIS TO         **
C               **  DETERMINE IF SATTERTHWAITE APPROXIMATION  **
C               **  WILL BE ADEQUATE                          **
C               ************************************************
C
      IF(NUMARG.GE.1.AND.ICOM.EQ.'RECI'.AND.IHARG(1).EQ.'SIMC')THEN
        ICOM='SIMC'
        ISHIFT=1
        CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1  IBUGA2,IERROR)
        ICASAN='SIMC'
        CALL SIMCOV(ISEED,IBUGA2,IBUGA3,IBUGCO,IBUGEV,IBUGQ,ISUBRO,
     1              IFOUND,IERROR)
        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ELSEIF(NUMARG.GE.1.AND.ICOM.EQ.'SIMC')THEN
         ICASAN='SIMC'
         CALL SIMCOV(ISEED,IBUGA2,IBUGA3,IBUGCO,IBUGEV,IBUGQ,ISUBRO,
     1               IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     MARCH 1999
C               ***************************************************
C               **  TREAT THE SINGLE SAMPLE ACCEPTANCE PLAN CASE **
C               ***************************************************
C
      IF(ICOM.EQ.'SING')THEN
         IF(NUMARG.GE.3.AND.IHARG(1).EQ.'SAMP'.AND.
     1      IHARG(2).EQ.'ACCE'.AND.IHARG(3).EQ.'PLAN')THEN
            ISHIFT=3
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
            IFOUND='YES' 
         ENDIF
         IF(NUMARG.GE.2.AND.IHARG(1).EQ.'SAMP'.AND.
     1      IHARG(2).EQ.'ACCE')THEN
            ISHIFT=2
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
            IFOUND='YES' 
         ENDIF
         IF(NUMARG.GE.2.AND.IHARG(1).EQ.'SAMP'.AND.
     1      IHARG(2).EQ.'PLAN')THEN
            ISHIFT=2
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
            IFOUND='YES' 
         ENDIF
         IF(NUMARG.GE.1.AND.IHARG(1).EQ.'SAMP')THEN
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
            IFOUND='YES' 
         ENDIF
C
         ICASAN='SSNC'
         IF(IFOUND.EQ.'YES')THEN
           CALL DPACSA(XTEMP1,MAXNXT,
     1     ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
           IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
         ENDIF
      ENDIF
C
C
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      IF(IBUGAN.EQ.'OFF')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF MAINAN--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)IBUGAN,IBUGA2,IBUGA3
 9013 FORMAT('IBUGAN,IBUGA2,IBUGA3 = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9015)IBUGCO,IBUGEV,IBUGQ
 9015 FORMAT('IBUGCO,IBUGEV,IBUGQ = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9016)IFTEXP
 9016 FORMAT('IFTEXP = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9017)IANGLU
 9017 FORMAT('IANGLU = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9018)ICASAN,ISEED,ANOPL1,ANOPL2
 9018 FORMAT('ICASAN,ISEED,ANOPL1,ANOPL2 = ',A4,I8,E15.7,E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9020)IFOUND,IERROR
 9020 FORMAT('IFOUND,IERROR = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9027)ICOM,ICOM2
 9027 FORMAT('ICOM,ICOM2 = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9028)NUMARG
 9028 FORMAT('NUMARG = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO9030I=1,NUMARG
      WRITE(ICOUT,9031)I,IHARG(I),IHARG2(I),IARGT(I),IARG(I),ARG(I)
 9031 FORMAT('I,IHARG(I),IHARG2(I),IARGT(I),IARG(I),ARG(I) = ',
     1I8,2X,A4,2X,A4,2X,A4,2X,I8,E15.7)
      CALL DPWRST('XXX','BUG ')
 9030 CONTINUE
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE MAINDG(IBUGDG,IBUGD2,IBUGU2,ISUBRO,
     1DEFANG,ANGLE,IDEANU,IANGLU,IREPCH,
CCCCC ADD FOLLOWING LINE   SEPTEMBER 1998.
     1IMPSW,
     1ICAPSW,
     1IFOUND,IERROR)
C
C     PURPOSE--THIS IS SUBROUTING MAINDG.
C              (THE   TD    AT THE END OF    MAINDG   STANDS FOR DIAGRAMMATIC
C              THIS SUBROUTINE SEARCHES FOR AND EXECUTES DIAGRAMMATIC GRAPHICS C
C              THE DIAGRAMMATIC GRAPHICS COMMANDS SEARCHED FOR BY MAINDG ARE AS
C
C                      COPY                              A NUMBER
C                      ERASE                             NO ENTRY
C                      RING BELL                         A NUMBER
C
C                      TEXT                              A STRING OF TEXT
C                      FONT                              A FONT NAME
C                      CASE                              UPPER OR LOWER
C                      HEIGHT                            A NUMBER
C                      WIDTH                             A NUMBER
C                      HW                                2 NUMBERS
C                      JUSTIFICATION                     LEFT, CENTER, OR RIGHT
C                      ANGLE                             A NUMBER
C                      ANGLE UNITS                       RADIANS, DEGREES, OR GR
C                      CRLF (CARRIAGE RETURN/LINE FEED)  ON OR OFF
C                      ... MARGIN                        A NUMBER
C                      CROSS-HAIR                        0 OR 2 PARAMTER NAMES
C
C                      MOVE                              2, 4, 6, 8, ... NUMBERS
C                      MOVEDATA                          2, 4, 6, 8, ... NUMBERS
C                      DRAW                              2, 4, 6, 8, ... NUMBERS
C                      DRAWDATA                          2, 4, 6, 8, ... NUMBERS
C
C                      POINT                             0, 2, 4, 6, ... NUMBERS
C                      ARROW                             2, 4, 6, 8, ... NUMBERS
C                      BOX                               2, 4, 6, 8, ... NUMBERS
C                      TRIANGLE                          4, 6, 8, ...    NUMBERS
C                      HEXAGON                           2, 4, 6, 8, ... NUMBERS
C                      CIRCLE                            2, 4, 6, 8, ... NUMBERS
C                      SEMI-CIRCLE                       2, 4, 6, 8, ... NUMBERS
C                      ELLIPSE                           4, 6, 8, ... NUMBERS
C                      AMPLIFIER                           2, 4, 6, 8, ... NUMBE
C                      DIAMOND                           4, 6, 8, ... NUMBERS
C                      OVAL                              4, 6, 8, ... NUMBERS
C                      ARC                               4, 6, 8, ... NUMBERS
C
C                      RESISTOR                       2, 4, ... NUMBERS
C                      CAPACITOR                         2, 4, 6, 8, ... NUMBERS
C                      GROUND                            2, 4, 6, 8, ... NUMBERS
C                      INDUCTOR                          2, 4, 6, 8, ... NUMBERS
C
C                      AND                               2, 4, 6, 8, ... NUMBERS
C                      OR                                2, 4, 6, 8, ... NUMBERS
C                      NAND                              2, 4, 6, 8, ... NUMBERS
C                      NOR                               2, 4, 6, 8, ... NUMBERS
C
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           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.6
C     ORIGINAL VERSION--APRIL     1981.
C     UPDATED         --MAY       1981.
C     UPDATED         --AUGUST    1981.
C     UPDATED         --SEPTEMBER 1981.
C     UPDATED         --MAY       1982.
C     UPDATED         --NOVEMBER  1982.
C     UPDATED         --DECEMBER  1988.  AVOID POINT & POINCARE PLOT CONFLICT
C     UPDATED         --AUGUST    1992.  AVOID SYMBOL & SYMBOL PLOT CONFLICT
C     UPDATED         --AUGUST    1992.  AVOID NAME CONFLICTS WITH BOX
C     UPDATED         --OCTOBER   1992.  BOX BORDER SETTINGS
C     UPDATED         --NOVEMBER  1992.  MOVEDATA COMMAND
C     UPDATED         --MARCH     1993.  ARGUMENTS TO DPBX
C     UPDATED         --SEPTEMBER 1993.  ALLOW LOWER CASE TEXT
C     UPDATED         --FEBRUARY  1994.  FIX CAPABILITY CONFLICT
C     UPDATED         --MAY 1994.  DISCONNECT (TEKT. HARD-) COPY COMMAND
C     UPDATED         --SEPTEMBER 1994.  DRAWDATA COMMAND
C     UPDATED         --OCTOBER   1995.  NAME CONFLICT WITH ANGLIT PROB
C                                        PLOT AND ANGLE COMMANDS
C     UPDATED         --MARCH     1997.  SUPPORT FOR DEVICE FONT (ALAN)
C                                        AUGMENT ARGUMENT LIST FOR 
C                                        MOST COMMANDS
C     UPDATED         --JULY      1997.  ELLIPSE DATA COMMAND (ALAN)
C     UPDATED         --JULY      1997.  <COMM> DATA COMMAND (ALAN)
C                                        FOR DIAGRAMMATIC GRAPHICS
C                                        COMMANDS THAT DRAW FIGURES
C     UPDATED         --JULY      1997.  POLGON COMMAND (ALAN)
C     UPDATED         --JANUARY   1998.  NAME CONFLICT WITH SEMI-
C                                        CIRCLE AND SEMICIRCULAR
C                                        PROB PLOT AND PPCC PLOT
C     UPDATED         --AUGUST    1998.  DRAW<D/S><D/S><D/S><D/S>
C     UPDATED         --AUGUST    1998.  MOVE<D/S><D/S>
C     UPDATED         --SEPTEMBER 1998.  ADD IMPSW TO ARGUMENT LIST
C                                        (USED TO SET IMPSW2)
C     UPDATED         --SEPTEMBER 1999.  ARGUMENT LIST TO DPTEXT
C     UPDATED         --SEPTEMBER 2002.  ICAPSW
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IMPSW
      CHARACTER*4 ICAPSW
      CHARACTER*4 IDEANU
      CHARACTER*4 IANGLU
C
      CHARACTER*1 IREPCH
C
      CHARACTER*4 IBUGDG
      CHARACTER*4 IBUGD2
      CHARACTER*4 IBUGU2
      CHARACTER*4 ISUBRO
      CHARACTER*4 IFOUND
      CHARACTER*4 IERROR
C
      CHARACTER*4 IHOLD
C
      CHARACTER*4 ITEXCV
C
CCCCC THE FOLLOWING LINE WAS ADDED NOVEMBER 1992
CCCCC AND THEN MODIFIED AUGUST 1998.
      CHARACTER*4 UNITSW
      CHARACTER*4 X1UNIT
      CHARACTER*4 X2UNIT
      CHARACTER*4 Y1UNIT
      CHARACTER*4 Y2UNIT
C
      DIMENSION PRV(6)
      DIMENSION PDIARV(4)
      DIMENSION ITEXCV(10)
      DIMENSION PTEXRV(5)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOPA.INC'
      INCLUDE 'DPCOHK.INC'
      INCLUDE 'DPCOPC.INC'
      INCLUDE 'DPCODA.INC'
      INCLUDE 'DPCOBE.INC'
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
      IBUGG4=IBUGU2
      ISUBG4=ISUBRO
C
      PXSTAR=PXEND
      PYSTAR=PYEND
C
CCCCC ADD FOLLOWING LINE SEPTEMBER 1998.
      IMPSW2=IMPSW
C
      IF(IBUGDG.EQ.'OFF')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('AT THE BEGINNING OF MAINDG--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)IBUGDG,IBUGD2,ISUBRO
   53 FORMAT('IBUGDG,IBUGD2,ISUBRO = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,54)IDEFAU,ITEXAU
   54 FORMAT('IDEFAU,ITEXAU = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,59)PXSTAR,PYSTAR,PXEND,PYEND
   59 FORMAT('PXSTAR,PYSTAR,PXEND,PYEND = ',4E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,60)DEFANG,ANGLE,IDEANU,IANGLU
   60 FORMAT('DEFANG,ANGLE,IDEANU,IANGLU = ',2E15.7,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,61)IREPCH
   61 FORMAT('IREPCH = ',A1)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,65)IFOUND,IERROR
   65 FORMAT('IFOUND,IERROR = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,67)ICOM,ICOM2
   67 FORMAT('ICOM,ICOM2 = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,68)NUMARG
   68 FORMAT('NUMARG = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO70I=1,NUMARG
      WRITE(ICOUT,71)I,IHARG(I),IHARG2(I),IARGT(I),IARG(I),ARG(I)
   71 FORMAT('I,IHARG(I),IHARG2(I),IARGT(I),IARG(I),ARG(I) = ',
     1I8,2X,A4,2X,A4,2X,A4,2X,I8,E15.7)
      CALL DPWRST('XXX','BUG ')
   70 CONTINUE
      WRITE(ICOUT,72)IDMANU(1)
   72 FORMAT('IDMANU(1) = ',A4)
      CALL DPWRST('XXX','BUG ')
   90 CONTINUE
C
      IFOUND='NO'
      IERROR='NO'
C
C               ***************************
C               **  TREAT THE COPY CASE  **
C               ***************************
C
CCCCC THE FOLLOWING SECTION WAS COMMENTED OUT      MAY 1994.
CCCCC IN DEFERENCE TO THE COPY FILE COMMAND        MAY 1994
CCCCC IF(ICOM.EQ.'COPY')GOTO100
CCCCC IF(ICOM.EQ.'MAKE')GOTO100
CCCCC GOTO199
C
CC100 CONTINUE
CCCCC CALL DPCOPY(IHARG,IARGT,IARG,NUMARG,
CCCCC1NUMDEV,
CCCCC1IDMANU,IDMODE,IDMOD2,IDMOD3,
CCCCC1IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
CCCCC ADD FOLLOWING LINE MARCH 1997.
CCCCC1IDFONT,
CCCCC1IBUGD2,ISUBRO,IFOUND,IERROR)
CCCCC IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
C
CC199 CONTINUE
C
C               *******************************
C               **  TREAT THE ERASE CASE     **
C               **  TREAT THE PAGE CASE      **
C               **  TREAT THE NEW PAGE CASE  **
C               *******************************
C
      IF(ICOM.EQ.'ERAS')GOTO200
      IF(ICOM.EQ.'PAGE')GOTO200
      IF(ICOM.EQ.'NEW')GOTO200
      GOTO299
C
  200 CONTINUE
      CALL DPERAS(IHARG,IARGT,IARG,NUMARG,
     1IBACCO,
     1IGRASW,IDIASW,
     1PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2,
     1PDIAHE,PDIAWI,PDIAVG,PDIAHG,
     1NUMDEV,
     1IDMANU,IDMODE,IDMOD2,IDMOD3,
     1IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
     1IDNVOF,IDNHOF,
CCCCC ADD FOLLOWING LINE MARCH 1997.
     1IDFONT,
     1ICAPSW,
     1IBUGD2,ISUBRO,IFOUND,IERROR)
      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
C
  299 CONTINUE
C
C               ********************************
C               **  TREAT THE RING BELL CASE  **
C               ********************************
C
      IF(ICOM.EQ.'RING')GOTO300
      GOTO399
C
  300 CONTINUE
      CALL DPRING(IHARG,IARGT,IARG,NUMARG,
     1NUMDEV,
     1IDMANU,IDMODE,IDMOD2,IDMOD3,
     1IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
CCCCC ADD FOLLOWING LINE MARCH 1997.
     1IDFONT,
     1IBUGD2,ISUBRO,IFOUND,IERROR)
      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
C
  399 CONTINUE
C
C               ***************************
C               **  TREAT THE TEXT CASE  **
C               ***************************
C
CCCCC MODIFIED TO SUPPORT "ELLIPSE DATA" OPTION.  JULY 1997.
      IF(ICOM.EQ.'TEXT')GOTO1100
      GOTO1199
C
 1100 CONTINUE
      PRV(1)=PGRAXF
      PRV(2)=PGRAYF
      PRV(3)=PDIAXC
      PRV(4)=PDIAYC
      PRV(5)=PDIAX2
      PRV(6)=PDIAY2
C
      PDIARV(1)=PDIAHE
      PDIARV(2)=PDIAWI
      PDIARV(3)=PDIAVG
      PDIARV(4)=PDIAHG
C
      ITEXCV(1)=ITEXFO
      ITEXCV(2)=ITEXCA
      ITEXCV(3)=ITEXJU
      ITEXCV(4)=ITEXDI
      ITEXCV(5)=ITEXCR
      ITEXCV(6)=ITEXLF
      ITEXCV(7)=ITEXSY
      ITEXCV(8)=ITEXSP
      ITEXCV(9)=ITEXFI
      ITEXCV(10)=ITEXCO
C
      PTEXRV(1)=PTEXHE
      PTEXRV(2)=PTEXWI
      PTEXRV(3)=PTEXVG
      PTEXRV(4)=PTEXHG
      PTEXRV(5)=PTEXTH
C
CCCCC THE FOLLOWING LINE WAS CHANGED      SEPTEBMER 1993
CCCCC TO ALLOW FOR LOWER CASE            SEPTEMBER 1993
CCCCC CALL DPTEXT(IANS,IWIDTH,
      CALL DPTEXT(IANS,IANSLC,IWIDTH,
     1ITEXTE,NCTEX,
     1PXSTAR,PYSTAR,PXEND,PYEND,
     1IGRASW,IDIASW,PRV,PDIARV,
     1ILINPA,ILINCO,PLINTH,
     1ATEXBA,
     1ITEBLI,ITEBCO,PTEBTH,
     1ITEFSW,ITEFCO,
     1ITEPTY,ITEPLI,ITEPCO,PTEPTH,PTEPSP,
     1PTEXMR,ITEXCV,ATEXAN,PTEXRV,
     1IHNAME,IHNAM2,IUSE,IVALUE,VALUE,NUMNAM,
     1IVSTAR,IVSTOP,IFUNC,NUMCHF,IREPCH,
     1NUMDEV,IDMANU,IDMODE,IDMOD2,IDMOD3,
     1IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
     1IDNVOF,IDNHOF,
CCCCC ADD FOLLOWING LINE MARCH 1997.
     1IDFONT,
     1IMPSW2,AMPSCH,AMPSCW,
     1IBUGD2,IFOUND,IERROR)
      IF(ITEXCR.EQ.'ON')PXSTOP=PTEXMR
      IF(ITEXLF.EQ.'ON')PYSTOP=PYSTAR-PTEXHE-PTEXVG
      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
C
 1199 CONTINUE
C
C               ***************************
C               **  TREAT THE FONT CASE  **
C               ***************************
C
      IF(ICOM.EQ.'FONT')GOTO1200
      GOTO1299
C
 1200 CONTINUE
      CALL DPFONT(IHARG,NUMARG,
     1IDEFFO,
     1ITEXFO,
     1IBUGD2,ISUBRO,IFOUND,IERROR)
      IF(IFOUND.EQ.'YES'.AND.IERROR.EQ.'NO')GOTO1250
      GOTO1259
 1250 CONTINUE
      IX1ZFO=ITEXFO
      IX2ZFO=ITEXFO
      IY1ZFO=ITEXFO
      IY2ZFO=ITEXFO
      ITITFO=ITEXFO
      IX1LFO=ITEXFO
      IX2LFO=ITEXFO
      IX3LFO=ITEXFO
      IY1LFO=ITEXFO
      IY2LFO=ITEXFO
      DO1251I=1,MAXLEG
      ILEGFO(I)=ITEXFO
 1251 CONTINUE
      DO1252I=1,MAXCHA
      ICHAFO(I)=ITEXFO
 1252 CONTINUE
 1259 CONTINUE
      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
C
 1299 CONTINUE
C
C               ************************************************
C               **  TREAT THE CASE (UPPER VERSUS LOWER) CASE  **
C               ************************************************
C
      IF(ICOM.EQ.'CASE')GOTO1300
      GOTO1399
C
 1300 CONTINUE
      CALL DPCASE(ICOM,IHARG,NUMARG,
     1IDEFCA,
     1ITEXCA,
     1IBUGD2,ISUBRO,IFOUND,IERROR)
      IF(IFOUND.EQ.'YES'.AND.IERROR.EQ.'NO')GOTO1350
      GOTO1359
 1350 CONTINUE
      DO1351I=1,MAXLEG
      ILEGCA(I)=ITEXCA
 1351 CONTINUE
      DO1352I=1,MAXCHA
      ICHACA(I)=ITEXCA
 1352 CONTINUE
 1359 CONTINUE
      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
C
 1399 CONTINUE
C
C               *****************************
C               **  TREAT THE HEIGHT CASE  **
C               *****************************
C
      IF(ICOM.EQ.'HEIG')GOTO1400
      GOTO1499
C
 1400 CONTINUE
      CALL DPHEIG(IHARG,IARGT,ARG,NUMARG,
     1PDEFHE,
     1PTEXHE,
     1IBUGD2,ISUBRO,IFOUND,IERROR)
      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
C
 1499 CONTINUE
C
C               ****************************
C               **  TREAT THE WIDTH CASE  **
C               ****************************
C
      IF(ICOM.EQ.'WIDT')GOTO1500
      GOTO1599
C
 1500 CONTINUE
      CALL DPWIDT(IHARG,IARGT,ARG,NUMARG,
     1PDEFWI,
     1PTEXWI,
     1IBUGD2,ISUBRO,IFOUND,IERROR)
      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
C
 1599 CONTINUE
C
C               *****************************************************
C               **  TREAT THE HW (THAT IS, HEIGHT AND WIDTH) CASE  **
C               *****************************************************
C
      IF(ICOM.EQ.'HW')GOTO1600
      IF(ICOM.EQ.'WH')GOTO1600
      GOTO1699
C
 1600 CONTINUE
      CALL DPHW(ICOM,IHARG,IARGT,ARG,NUMARG,
     1PDEFHE,PDEFWI,
     1PTEXHE,PTEXWI,
     1IBUGD2,ISUBRO,IFOUND,IERROR)
      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
C
 1699 CONTINUE
C
C               ************************************
C               **  TREAT THE JUSTIFICATION CASE  **
C               ************************************
C
      IF(ICOM.EQ.'JUST')GOTO1700
      GOTO1799
 1700 CONTINUE
      CALL DPJUST(ICOM,IHARG,NUMARG,
     1IDEFJU,
     1ITEXJU,
     1IBUGD2,ISUBRO,IFOUND,IERROR)
      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
C
 1799 CONTINUE
C
C               *****************************
C               **  TREAT THE MARGIN CASE  **
C               *****************************
C
      IF(ICOM.EQ.'MARG'.AND.IHARG(1).EQ.'COLO')GOTO9000
      IF(ICOM.EQ.'MARG'.AND.IHARG(1).EQ.'COOR')GOTO1800
      IF(ICOM.EQ.'MARG')GOTO1800
      GOTO1899
C
 1800 CONTINUE
      CALL DPMARG(IHARG,IARGT,ARG,NUMARG,
     1PDEFMR,
     1PTEXMR,
     1IBUGD2,ISUBRO,IFOUND,IERROR)
      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
C
 1899 CONTINUE
C
C               ************************************************
C               **  TREAT THE CARRIAGE RETURN/LINE FEED CASE  **
C               ************************************************
C
      IF(ICOM.EQ.'CRLF')GOTO 1900
      IF(ICOM.EQ.'LFCR')GOTO 1900
      GOTO1999
C
 1900 CONTINUE
      CALL DPCRLF(IHARG,NUMARG,
     1IDEFCR,IDEFLF,
     1ITEXCR,ITEXLF,
     1IBUGD2,ISUBRO,IFOUND,IERROR)
      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
C
 1999 CONTINUE
C
C               ***************************
C               **  TREAT THE MOVE CASE  **
C               ***************************
C
CCCCC MODIFIED TO SUPPORT "MOVE DATA" OPTION.  JULY 1997.
      IF(ICOM.EQ.'MOVE')GOTO2000
      GOTO2099
C
 2000 CONTINUE
CCCCC THE FOLLOWING 2 LINES WERE ADDED NOVEMBER 1992
CCCCC UNITSW='SCRE'
      X1UNIT='SCRE'
      Y1UNIT='SCRE'
      IF(ICOM2(1:1).EQ.'D')X1UNIT='DATA'
      IF(ICOM2(2:2).EQ.'D')Y1UNIT='DATA'
      IF(ICOM2.EQ.'DATA')THEN
CCCCC   UNITSW='DATA'
        X1UNIT='DATA'
        Y1UNIT='DATA'
      ENDIF
      IF(IHARG(1).EQ.'DATA')THEN
CCCCC   UNITSW='DATA'
        X1UNIT='DATA'
        Y1UNIT='DATA'
        ISHIFT=1
        CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1              IBUGD2,IERROR)
      ENDIF
      CALL DPMOVE(IHARG,IARGT,ARG,NUMARG,
     1PXSTAR,PYSTAR,
     1PXEND,PYEND,
     1ILINPA,ILINCO,PLINTH,
     1AREGBA,
     1IREBLI,IREBCO,PREBTH,
     1IREFSW,IREFCO,
     1IREPTY,IREPLI,IREPCO,PREPTH,PREPSP,
     1PTEXHE,PTEXWI,PTEXVG,PTEXHG,
     1IGRASW,IDIASW,
     1PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2,
     1PDIAHE,PDIAWI,PDIAVG,PDIAHG,
     1NUMDEV,
     1IDMANU,IDMODE,IDMOD2,IDMOD3,
     1IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
     1IDNVOF,IDNHOF,
CCCCC ADD FOLLOWING LINE MARCH 1997.
     1IDFONT,
CCCCC THE FOLLOWING LINE WAS ADDED NOVEMBER 1992
CCCCC AND THEN MODIFIED AUGUST 1998
CCCCC1UNITSW,
     1X1UNIT,Y1UNIT,
     1IBUGD2,IFOUND,IERROR)
      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
C
 2099 CONTINUE
C
C               ***************************
C               **  TREAT THE DRAW CASE  **
C               ***************************
C
CCCCC MODIFIED TO SUPPORT "DRAW  DATA" OPTION.  JULY 1997.
CCCCC MODIFIED TO SUPPORT "DRAWDDDD, DRAWDDDS, ETC. OPTIONS.  JULY 1998
      IF(ICOM.EQ.'DRAW')GOTO2100
      GOTO2199
C
 2100 CONTINUE
CCCCC THE FOLLOWING 2 LINES WERE ADDED SEPTEMBER 1994
CCCCC UNITSW='SCRE'
      X1UNIT='SCRE'
      X2UNIT='SCRE'
      Y1UNIT='SCRE'
      Y2UNIT='SCRE'
      IF(ICOM2(1:1).EQ.'D')X1UNIT='DATA'
      IF(ICOM2(2:2).EQ.'D')Y1UNIT='DATA'
      IF(ICOM2(3:3).EQ.'D')X2UNIT='DATA'
      IF(ICOM2(4:4).EQ.'D')Y2UNIT='DATA'
      IF(ICOM2.EQ.'DATA')THEN
CCCCC   UNITSW='DATA'
        X1UNIT='DATA'
        X2UNIT='DATA'
        Y1UNIT='DATA'
        Y2UNIT='DATA'
      ENDIF
      IF(IHARG(1).EQ.'DATA')THEN
CCCCC   UNITSW='DATA'
        X1UNIT='DATA'
        X2UNIT='DATA'
        Y1UNIT='DATA'
        Y2UNIT='DATA'
        ISHIFT=1
        CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1              IBUGD2,IERROR)
      ENDIF
      CALL DPDRAW(IHARG,IARGT,ARG,NUMARG,
     1PXSTAR,PYSTAR,
     1PXEND,PYEND,
     1ILINPA,ILINCO,PLINTH,
     1AREGBA,
     1IREBLI,IREBCO,PREBTH,
     1IREFSW,IREFCO,
     1IREPTY,IREPLI,IREPCO,PREPTH,PREPSP,
     1PTEXHE,PTEXWI,PTEXVG,PTEXHG,
     1IGRASW,IDIASW,
     1PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2,
     1PDIAHE,PDIAWI,PDIAVG,PDIAHG,
     1NUMDEV,
     1IDMANU,IDMODE,IDMOD2,IDMOD3,
     1IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
     1IDNVOF,IDNHOF,
CCCCC ADD FOLLOWING LINE MARCH 1997.
     1IDFONT,
CCCCC THE FOLLOWING LINE WAS ADDED NOVEMBER 1992
CCCCC AND THEN MODIFIED AUGUST 1998
CCCCC1UNITSW,
     1X1UNIT,Y1UNIT,X2UNIT,Y2UNIT,
     1IBUGD2,IFOUND,IERROR)
      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
C
 2199 CONTINUE
C
C               ****************************
C               **  TREAT THE POINT CASE  **
C               ****************************
C
CCCCC THE FOLLOWING LINE WAS COMMENTED OUT     (DECEMBER 1988)
CCCCC AND REPLACED BY THE SUCCEEDING 2 LINES   (DECEMBER 1988)
CCCCC TO AVOID CONFLICT BETWEEN POINT COMMAND  (DECEMBER 1988)
CCCCC AND POINCARE PLOT COMMAND                (DECEMBER 1988)
CCCCC MODIFIED TO SUPPORT "POINT DATA" OPTION.  JULY 1997.
CCCCC IF(ICOM.EQ.'POIN')GOTO2200         DECEMBER 1988
      IF(ICOM.EQ.'POIN'.AND.NUMARG.GE.1.AND.
     1IHARG(1).NE.'PLOT')GOTO2200
      GOTO2299
C
 2200 CONTINUE
      UNITSW='SCRE'
      IF(IHARG(1).EQ.'DATA')THEN
        UNITSW='DATA'
        ISHIFT=1
        CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1              IBUGD2,IERROR)
      ENDIF
      CALL DPPOIN(IHARG,IARGT,ARG,NUMARG,
     1PXSTAR,PYSTAR,
     1PXEND,PYEND,
     1ILINPA,ILINCO,PLINTH,
     1AREGBA,
     1IREBLI,IREBCO,PREBTH,
     1IREFSW,IREFCO,
     1IREPTY,IREPLI,IREPCO,PREPTH,PREPSP,
     1PTEXHE,PTEXWI,PTEXVG,PTEXHG,
     1IGRASW,IDIASW,
     1PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2,
     1PDIAHE,PDIAWI,PDIAVG,PDIAHG,
     1NUMDEV,
     1IDMANU,IDMODE,IDMOD2,IDMOD3,
     1IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
     1IDNVOF,IDNHOF,
CCCCC ADD FOLLOWING LINE MARCH 1997.
     1IDFONT,
CCCCC ADD FOLLOWING LINE JULY 1997.
     1UNITSW,
     1IBUGD2,IFOUND,IERROR)
      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
C
 2299 CONTINUE
C
C               ****************************
C               **  TREAT THE ARROW CASE  **
C               ****************************
C
CCCCC MODIFIED TO SUPPORT "ARROW DATA" OPTION.  JULY 1997.
      IF(ICOM.EQ.'ARRO')GOTO2300
      GOTO2399
C
 2300 CONTINUE
      UNITSW='SCRE'
      IF(IHARG(1).EQ.'DATA')THEN
        UNITSW='DATA'
        ISHIFT=1
        CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1              IBUGD2,IERROR)
      ENDIF
      CALL DPARRO(IHARG,IARGT,ARG,NUMARG,
     1PXSTAR,PYSTAR,
     1PXEND,PYEND,
C    1ILINPA,ILINCO,PLINTH,
C  AUGUST, 1987: USE VALUES FROM ARROW COMMON BLOCK
     1IARRPA,IARRCO,PARRTH,
C  END CHANGE
     1AREGBA,
     1IREBLI,IREBCO,PREBTH,
     1IREFSW,IREFCO,
     1IREPTY,IREPLI,IREPCO,PREPTH,PREPSP,
     1PTEXHE,PTEXWI,PTEXVG,PTEXHG,
     1IGRASW,IDIASW,
     1PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2,
     1PDIAHE,PDIAWI,PDIAVG,PDIAHG,
     1NUMDEV,
     1IDMANU,IDMODE,IDMOD2,IDMOD3,
     1IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
     1IDNVOF,IDNHOF,
CCCCC ADD FOLLOWING LINE MARCH 1997.
     1IDFONT,
CCCCC ADD FOLLOWING LINE JULY 1997.
     1UNITSW,
     1IBUGD2,IFOUND,IERROR)
      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
C
 2399 CONTINUE
C
C               **************************
C               **  TREAT THE BOX CASE  **
C               **************************
C
CCCCC AUGUST 1992.  CHECK FOR NAME CONFLICTS
CCCCC MODIFIED TO SUPPORT "BOX DATA" OPTION.  JULY 1997.
CCCCC IF(ICOM.EQ.'BOX'.AND.NUMARG.GE.1.AND.
CCCCC1IHARG(1).NE.'PLOT'.AND.IHARG(1).NE.'COX')GOTO2500
      IF(NUMARG.GE.1.AND.
     1IHARG(1).EQ.'PLOT'.OR.IHARG(1).EQ.'COX'.OR.
     1IHARG(1).EQ.'PATT'.OR.IHARG(1).EQ.'THIC'.OR.
     1IHARG(1).EQ.'SHAD'.OR.
     1IHARG(1).EQ.'COLO'.OR.IHARG(1).EQ.'FILL')
     1GOTO2599
      IF(NUMARG.GE.2.AND.
     1IHARG(2).EQ.'PATT'.OR.IHARG(2).EQ.'THIC'.OR.
     1IHARG(2).EQ.'SHAD'.OR.
     1IHARG(2).EQ.'COLO'.OR.IHARG(2).EQ.'FILL')
     1GOTO2599
      IF(ICOM.EQ.'BOX')GOTO2500
      GOTO2599
C
 2500 CONTINUE
      UNITSW='SCRE'
      IF(IHARG(1).EQ.'DATA')THEN
        UNITSW='DATA'
        ISHIFT=1
        CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1              IBUGD2,IERROR)
      ENDIF
      CALL DPBX(IHARG,IARGT,ARG,NUMARG,
     1PXSTAR,PYSTAR,
     1PXEND,PYEND,
C    1ILINPA,ILINCO,PLINTH,
C  USE PARAMETERS FOR BOX FRAME
C  AUGUST, 1987
CCCCC1IBOFPA,IBOFCO,PBOFTH,
CCCCC CHANGE BOX BORDER SETTINGS  OCTOBER 1992
     1IBOBPA,IBOBCO,PBOPTH,
C  END
     1AREGBA,
     1IREBLI,IREBCO,PREBTH,
C  MARCH 1993.  USE PARAMETERS FOR BOX INTERIOR
CCCCC1IREFSW,IREFCO,
CCCCC1IREPTY,IREPLI,IREPCO,PREPTH,PREPSP,
     1IBOFPA,IBOFCO,
     1IBOFPA,IBOPPA,IBOFCO,PBOFTH,PBOPGA,
CCCCC MARCH 1993.  ADD BOX SHADOW PARAMETERS.
     1PBOSHE,PBOSWI,
     1PTEXHE,PTEXWI,PTEXVG,PTEXHG,
     1IGRASW,IDIASW,
     1PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2,
     1PDIAHE,PDIAWI,PDIAVG,PDIAHG,
     1NUMDEV,
     1IDMANU,IDMODE,IDMOD2,IDMOD3,
     1IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
     1IDNVOF,IDNHOF,
CCCCC ADD FOLLOWING LINE MARCH 1997.
     1IDFONT,
CCCCC ADD FOLLOWING LINE JULY 1997.
     1UNITSW,
     1IBUGD2,IFOUND,IERROR)
 2599 CONTINUE
C
C
C               ******************************
C               **  TREAT THE HEXAGON CASE  **
C               ******************************
C
CCCCC MODIFIED TO SUPPORT "HEXAGON DATA" OPTION.  JULY 1997.
      IF(ICOM.EQ.'HEXA')GOTO2600
      GOTO2699
C
 2600 CONTINUE
      UNITSW='SCRE'
      IF(IHARG(1).EQ.'DATA')THEN
        UNITSW='DATA'
        ISHIFT=1
        CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1              IBUGD2,IERROR)
      ENDIF
      CALL DPHEXA(IHARG,IARGT,ARG,NUMARG,
     1PXSTAR,PYSTAR,
     1PXEND,PYEND,
     1ILINPA,ILINCO,PLINTH,
     1AREGBA,
     1IREBLI,IREBCO,PREBTH,
     1IREFSW,IREFCO,
     1IREPTY,IREPLI,IREPCO,PREPTH,PREPSP,
     1PTEXHE,PTEXWI,PTEXVG,PTEXHG,
     1IGRASW,IDIASW,
     1PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2,
     1PDIAHE,PDIAWI,PDIAVG,PDIAHG,
     1NUMDEV,
     1IDMANU,IDMODE,IDMOD2,IDMOD3,
     1IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
     1IDNVOF,IDNHOF,
CCCCC ADD FOLLOWING LINE MARCH 1997.
     1IDFONT,
CCCCC ADD FOLLOWING LINE JULY 1997.
     1UNITSW,
     1IBUGD2,IFOUND,IERROR)
      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
C
 2699 CONTINUE
C
C               *****************************
C               **  TREAT THE CIRCLE CASE  **
C               *****************************
C
CCCCC MODIFIED TO SUPPORT "ELLIPSE DATA" OPTION.  JULY 1997.
      IF(ICOM.EQ.'CIRC')GOTO2700
      GOTO2799
C
 2700 CONTINUE
      UNITSW='SCRE'
      IF(IHARG(1).EQ.'DATA')THEN
        UNITSW='DATA'
        ISHIFT=1
        CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1              IBUGD2,IERROR)
      ENDIF
      CALL DPCIRC(IHARG,IARGT,ARG,NUMARG,
     1PXSTAR,PYSTAR,
     1PXEND,PYEND,
     1ILINPA,ILINCO,PLINTH,
     1AREGBA,
     1IREBLI,IREBCO,PREBTH,
     1IREFSW,IREFCO,
     1IREPTY,IREPLI,IREPCO,PREPTH,PREPSP,
     1PTEXHE,PTEXWI,PTEXVG,PTEXHG,
     1IGRASW,IDIASW,
     1PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2,
     1PDIAHE,PDIAWI,PDIAVG,PDIAHG,
     1NUMDEV,
     1IDMANU,IDMODE,IDMOD2,IDMOD3,
     1IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
     1IDNVOF,IDNHOF,
CCCCC ADD FOLLOWING LINE MARCH 1997.
     1IDFONT,
CCCCC ADD FOLLOWING LINE JULY 1997.
     1UNITSW,
     1IBUGD2,IFOUND,IERROR)
      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
C
 2799 CONTINUE
C
C               **********************************
C               **  TREAT THE SEMI-CIRCLE CASE  **
C               **********************************
C
CCCCC MODIFIED TO SUPPORT "SEMI-CIRCLE DATA" OPTION.  JULY 1997.
      IF(ICOM.EQ.'SEMI')GOTO2800
      GOTO2899
C
 2800 CONTINUE
      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'PROB')GOTO2899
      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'PPCC')GOTO2899
      IF(NUMARG.GE.2.AND.IHARG(2).EQ.'PROB')GOTO2899
      IF(NUMARG.GE.2.AND.IHARG(2).EQ.'PPCC')GOTO2899
      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'KOLM')GOTO2899
      IF(NUMARG.GE.2.AND.IHARG(2).EQ.'KOLM')GOTO2899
      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'CHI ')GOTO2899
      IF(NUMARG.GE.2.AND.IHARG(2).EQ.'CHI ')GOTO2899
      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'CHIS')GOTO2899
      IF(NUMARG.GE.2.AND.IHARG(2).EQ.'CHIS')GOTO2899
      UNITSW='SCRE'
      IF(IHARG(1).EQ.'DATA')THEN
        UNITSW='DATA'
        ISHIFT=1
        CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1              IBUGD2,IERROR)
      ENDIF
      CALL DPSCIR(IHARG,IARGT,ARG,NUMARG,
     1PXSTAR,PYSTAR,
     1PXEND,PYEND,
     1ILINPA,ILINCO,PLINTH,
     1AREGBA,
     1IREBLI,IREBCO,PREBTH,
     1IREFSW,IREFCO,
     1IREPTY,IREPLI,IREPCO,PREPTH,PREPSP,
     1PTEXHE,PTEXWI,PTEXVG,PTEXHG,
     1IGRASW,IDIASW,
     1PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2,
     1PDIAHE,PDIAWI,PDIAVG,PDIAHG,
     1NUMDEV,
     1IDMANU,IDMODE,IDMOD2,IDMOD3,
     1IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
     1IDNVOF,IDNHOF,
CCCCC ADD FOLLOWING LINE MARCH 1997.
     1IDFONT,
CCCCC ADD FOLLOWING LINE JULY 1997.
     1UNITSW,
     1IBUGD2,IFOUND,IERROR)
      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
C
 2899 CONTINUE
C
C               ******************************
C               **  TREAT THE ELLIPSE CASE  **
C               ******************************
C
CCCCC MODIFIED TO SUPPORT "ELLIPSE DATA" OPTION.  JULY 1997.
C
      IF(ICOM.EQ.'ELLI')GOTO2900
      GOTO2999
C
 2900 CONTINUE
      UNITSW='SCRE'
      IF(IHARG(1).EQ.'DATA')THEN
        UNITSW='DATA'
        ISHIFT=1
        CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1              IBUGD2,IERROR)
      ENDIF
      CALL DPELLI(IHARG,IARGT,ARG,NUMARG,
     1PXSTAR,PYSTAR,
     1PXEND,PYEND,
     1ILINPA,ILINCO,PLINTH,
     1AREGBA,
     1IREBLI,IREBCO,PREBTH,
     1IREFSW,IREFCO,
     1IREPTY,IREPLI,IREPCO,PREPTH,PREPSP,
     1PTEXHE,PTEXWI,PTEXVG,PTEXHG,
     1IGRASW,IDIASW,
     1PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2,
     1PDIAHE,PDIAWI,PDIAVG,PDIAHG,
     1NUMDEV,
     1IDMANU,IDMODE,IDMOD2,IDMOD3,
     1IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
     1IDNVOF,IDNHOF,
CCCCC ADD FOLLOWING LINE MARCH 1997.
     1IDFONT,
CCCCC ADD FOLLOWING LINE JULY 1997.
     1UNITSW,
     1IBUGD2,IFOUND,IERROR)
      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
C
 2999 CONTINUE
C
C               *******************************
C               **  TREAT THE RESISTOR CASE  **
C               *******************************
C
CCCCC MODIFIED TO SUPPORT "RESISTOR DATA" OPTION.  JULY 1997.
      IF(ICOM.EQ.'RESI')GOTO3000
      GOTO3099
C
 3000 CONTINUE
      UNITSW='SCRE'
      IF(IHARG(1).EQ.'DATA')THEN
        UNITSW='DATA'
        ISHIFT=1
        CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1              IBUGD2,IERROR)
      ENDIF
      CALL DPRESI(IHARG,IARGT,ARG,NUMARG,
     1PXSTAR,PYSTAR,
     1PXEND,PYEND,
     1ILINPA,ILINCO,PLINTH,
     1AREGBA,
     1IREBLI,IREBCO,PREBTH,
     1IREFSW,IREFCO,
     1IREPTY,IREPLI,IREPCO,PREPTH,PREPSP,
     1PTEXHE,PTEXWI,PTEXVG,PTEXHG,
     1IGRASW,IDIASW,
     1PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2,
     1PDIAHE,PDIAWI,PDIAVG,PDIAHG,
     1NUMDEV,
     1IDMANU,IDMODE,IDMOD2,IDMOD3,
     1IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
     1IDNVOF,IDNHOF,
CCCCC ADD FOLLOWING LINE MARCH 1997.
     1IDFONT,
CCCCC ADD FOLLOWING LINE JULY 1997.
     1UNITSW,
     1IBUGD2,IFOUND,IERROR)
      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
C
 3099 CONTINUE
C
C               *******************************
C               **  TREAT THE INDUCTOR CASE  **
C               *******************************
C
CCCCC MODIFIED TO SUPPORT "INDUCTOR DATA" OPTION.  JULY 1997.
      IF(ICOM.EQ.'INDU')GOTO3100
      GOTO3199
C
 3100 CONTINUE
      UNITSW='SCRE'
      IF(IHARG(1).EQ.'DATA')THEN
        UNITSW='DATA'
        ISHIFT=1
        CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1              IBUGD2,IERROR)
      ENDIF
      CALL DPINDU(IHARG,IARGT,ARG,NUMARG,
     1PXSTAR,PYSTAR,
     1PXEND,PYEND,
     1ILINPA,ILINCO,PLINTH,
     1AREGBA,
     1IREBLI,IREBCO,PREBTH,
     1IREFSW,IREFCO,
     1IREPTY,IREPLI,IREPCO,PREPTH,PREPSP,
     1PTEXHE,PTEXWI,PTEXVG,PTEXHG,
     1IGRASW,IDIASW,
     1PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2,
     1PDIAHE,PDIAWI,PDIAVG,PDIAHG,
     1NUMDEV,
     1IDMANU,IDMODE,IDMOD2,IDMOD3,
     1IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
     1IDNVOF,IDNHOF,
CCCCC ADD FOLLOWING LINE MARCH 1997.
     1IDFONT,
CCCCC ADD FOLLOWING LINE JULY 1997.
     1UNITSW,
     1IBUGD2,IFOUND,IERROR)
      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
C
 3199 CONTINUE
C               ********************************
C               **  TREAT THE CAPACITOR CASE  **
C               ********************************
C
CCCCC THE FOLLOWING LINE WAS FIXED                   FEBRUARY 1994
CCCCC TO AVOID CONFLICT WITH    CAPABILITY   COMMAND FEBRUARY 1994
CCCCC MODIFIED TO SUPPORT "CAPACITOR DATA" OPTION.  JULY 1997.
CCCCC IF(ICOM.EQ.'CAPA')GOTO3200
      IF(ICOM.EQ.'CAPA'.AND.ICOM2.EQ.'CITO')GOTO3200
      GOTO3299
C
 3200 CONTINUE
      UNITSW='SCRE'
      IF(IHARG(1).EQ.'DATA')THEN
        UNITSW='DATA'
        ISHIFT=1
        CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1              IBUGD2,IERROR)
      ENDIF
      IF(ICOM2.EQ.'BILI')GOTO3299
      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'ANAL')GOTO3299
      CALL DPCAPA(IHARG,IARGT,ARG,NUMARG,
     1PXSTAR,PYSTAR,
     1PXEND,PYEND,
     1ILINPA,ILINCO,PLINTH,
     1AREGBA,
     1IREBLI,IREBCO,PREBTH,
     1IREFSW,IREFCO,
     1IREPTY,IREPLI,IREPCO,PREPTH,PREPSP,
     1PTEXHE,PTEXWI,PTEXVG,PTEXHG,
     1IGRASW,IDIASW,
     1PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2,
     1PDIAHE,PDIAWI,PDIAVG,PDIAHG,
     1NUMDEV,
     1IDMANU,IDMODE,IDMOD2,IDMOD3,
     1IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
     1IDNVOF,IDNHOF,
CCCCC ADD FOLLOWING LINE MARCH 1997.
     1IDFONT,
CCCCC ADD FOLLOWING LINE JULY 1997.
     1UNITSW,
     1IBUGD2,IFOUND,IERROR)
      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
C
 3299 CONTINUE
C
C               *****************************
C               **  TREAT THE GROUND CASE  **
C               *****************************
C
CCCCC MODIFIED TO SUPPORT "ELLIPSE DATA" OPTION.  JULY 1997.
      IF(ICOM.EQ.'GROU' .AND. IHARG(1).NE.'PARA'.AND.
     1   IHARG(2).NE.'COOR')GOTO3300
      GOTO3399
C
 3300 CONTINUE
      UNITSW='SCRE'
      IF(IHARG(1).EQ.'DATA')THEN
        UNITSW='DATA'
        ISHIFT=1
        CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1              IBUGD2,IERROR)
      ENDIF
      CALL DPGROU(IHARG,IARGT,ARG,NUMARG,
     1PXSTAR,PYSTAR,
     1PXEND,PYEND,
     1ILINPA,ILINCO,PLINTH,
     1AREGBA,
     1IREBLI,IREBCO,PREBTH,
     1IREFSW,IREFCO,
     1IREPTY,IREPLI,IREPCO,PREPTH,PREPSP,
     1PTEXHE,PTEXWI,PTEXVG,PTEXHG,
     1IGRASW,IDIASW,
     1PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2,
     1PDIAHE,PDIAWI,PDIAVG,PDIAHG,
     1NUMDEV,
     1IDMANU,IDMODE,IDMOD2,IDMOD3,
     1IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
     1IDNVOF,IDNHOF,
CCCCC ADD FOLLOWING LINE MARCH 1997.
     1IDFONT,
CCCCC ADD FOLLOWING LINE JULY 1997.
     1UNITSW,
     1IBUGD2,IFOUND,IERROR)
      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
C
 3399 CONTINUE
C               **************************
C               **  TREAT THE AND CASE  **
C               **************************
C
CCCCC MODIFIED TO SUPPORT "ELLIPSE DATA" OPTION.  JULY 1997.
      IF(ICOM.EQ.'AND')GOTO3400
      GOTO3499
C
 3400 CONTINUE
      UNITSW='SCRE'
      IF(IHARG(1).EQ.'DATA')THEN
        UNITSW='DATA'
        ISHIFT=1
        CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1              IBUGD2,IERROR)
      ENDIF
      CALL DPAND(IHARG,IARGT,ARG,NUMARG,
     1PXSTAR,PYSTAR,
     1PXEND,PYEND,
     1ILINPA,ILINCO,PLINTH,
     1AREGBA,
     1IREBLI,IREBCO,PREBTH,
     1IREFSW,IREFCO,
     1IREPTY,IREPLI,IREPCO,PREPTH,PREPSP,
     1PTEXHE,PTEXWI,PTEXVG,PTEXHG,
     1IGRASW,IDIASW,
     1PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2,
     1PDIAHE,PDIAWI,PDIAVG,PDIAHG,
     1NUMDEV,
     1IDMANU,IDMODE,IDMOD2,IDMOD3,
     1IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
     1IDNVOF,IDNHOF,
CCCCC ADD FOLLOWING LINE MARCH 1997.
     1IDFONT,
CCCCC ADD FOLLOWING LINE JULY 1997.
     1UNITSW,
     1IBUGD2,IFOUND,IERROR)
      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
C
 3499 CONTINUE
C
C               *************************
C               **  TREAT THE OR CASE  **
C               *************************
C
CCCCC MODIFIED TO SUPPORT "ELLIPSE DATA" OPTION.  JULY 1997.
      IF(ICOM.EQ.'OR')GOTO3500
      GOTO3599
C
 3500 CONTINUE
      UNITSW='SCRE'
      IF(IHARG(1).EQ.'DATA')THEN
        UNITSW='DATA'
        ISHIFT=1
        CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1              IBUGD2,IERROR)
      ENDIF
      CALL DPOR(IHARG,IARGT,ARG,NUMARG,
     1PXSTAR,PYSTAR,
     1PXEND,PYEND,
     1ILINPA,ILINCO,PLINTH,
     1AREGBA,
     1IREBLI,IREBCO,PREBTH,
     1IREFSW,IREFCO,
     1IREPTY,IREPLI,IREPCO,PREPTH,PREPSP,
     1PTEXHE,PTEXWI,PTEXVG,PTEXHG,
     1IGRASW,IDIASW,
     1PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2,
     1PDIAHE,PDIAWI,PDIAVG,PDIAHG,
     1NUMDEV,
     1IDMANU,IDMODE,IDMOD2,IDMOD3,
     1IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
     1IDNVOF,IDNHOF,
CCCCC ADD FOLLOWING LINE MARCH 1997.
     1IDFONT,
CCCCC ADD FOLLOWING LINE JULY 1997.
     1UNITSW,
     1IBUGD2,IFOUND,IERROR)
      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
C
 3599 CONTINUE
C
C               ***************************
C               **  TREAT THE NAND CASE  **
C               ***************************
C
CCCCC MODIFIED TO SUPPORT "ELLIPSE DATA" OPTION.  JULY 1997.
      IF(ICOM.EQ.'NAND')GOTO3600
      GOTO3699
C
 3600 CONTINUE
      UNITSW='SCRE'
      IF(IHARG(1).EQ.'DATA')THEN
        UNITSW='DATA'
        ISHIFT=1
        CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1              IBUGD2,IERROR)
      ENDIF
      CALL DPNAND(IHARG,IARGT,ARG,NUMARG,
     1PXSTAR,PYSTAR,
     1PXEND,PYEND,
     1ILINPA,ILINCO,PLINTH,
     1AREGBA,
     1IREBLI,IREBCO,PREBTH,
     1IREFSW,IREFCO,
     1IREPTY,IREPLI,IREPCO,PREPTH,PREPSP,
     1PTEXHE,PTEXWI,PTEXVG,PTEXHG,
     1IGRASW,IDIASW,
     1PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2,
     1PDIAHE,PDIAWI,PDIAVG,PDIAHG,
     1NUMDEV,
     1IDMANU,IDMODE,IDMOD2,IDMOD3,
     1IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
     1IDNVOF,IDNHOF,
CCCCC ADD FOLLOWING LINE MARCH 1997.
     1IDFONT,
CCCCC ADD FOLLOWING LINE JULY 1997.
     1UNITSW,
     1IBUGD2,IFOUND,IERROR)
      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
C
 3699 CONTINUE
C
C               **************************
C               **  TREAT THE NOR CASE  **
C               **************************
C
CCCCC MODIFIED TO SUPPORT "ELLIPSE DATA" OPTION.  JULY 1997.
      IF(ICOM.EQ.'NOR')GOTO3700
      GOTO3799
C
 3700 CONTINUE
      UNITSW='SCRE'
      IF(IHARG(1).EQ.'DATA')THEN
        UNITSW='DATA'
        ISHIFT=1
        CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1              IBUGD2,IERROR)
      ENDIF
      CALL DPNOR(IHARG,IARGT,ARG,NUMARG,
     1PXSTAR,PYSTAR,
     1PXEND,PYEND,
     1ILINPA,ILINCO,PLINTH,
     1AREGBA,
     1IREBLI,IREBCO,PREBTH,
     1IREFSW,IREFCO,
     1IREPTY,IREPLI,IREPCO,PREPTH,PREPSP,
     1PTEXHE,PTEXWI,PTEXVG,PTEXHG,
     1IGRASW,IDIASW,
     1PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2,
     1PDIAHE,PDIAWI,PDIAVG,PDIAHG,
     1NUMDEV,
     1IDMANU,IDMODE,IDMOD2,IDMOD3,
     1IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
     1IDNVOF,IDNHOF,
CCCCC ADD FOLLOWING LINE MARCH 1997.
     1IDFONT,
CCCCC ADD FOLLOWING LINE JULY 1997.
     1UNITSW,
     1IBUGD2,IFOUND,IERROR)
      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
C
 3799 CONTINUE
C
C               **************************************
C               **  TREAT THE CROSS-HAIR CASE       **
C               **  TREAT THE READ CROSS-HAIR CASE  **
C               **************************************
C
      IF(ICOM.EQ.'CROS')GOTO3800
      IF(ICOM.EQ.'CH')GOTO3800
      IF(ICOM.EQ.'READ'.AND.IHARG(1).EQ.'CROS')GOTO3800
      IF(ICOM.EQ.'READ'.AND.IHARG(1).EQ.'CH')GOTO3800
      GOTO3899
C
 3800 CONTINUE
      CALL DPCROS(ICOM,IHARG,IHARG2,IARGT,ARG,NUMARG,
     1IANS,IWIDTH,
     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
     1IGRASW,IDIASW,
     1PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2,
     1PDIAHE,PDIAWI,PDIAVG,PDIAHG,
     1NUMDEV,
     1IDMANU,IDMODE,IDMOD2,IDMOD3,
     1IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
     1IDNVOF,IDNHOF,
CCCCC ADD FOLLOWING LINE MARCH 1997.
     1IDFONT,
     1PXMIN,PXMAX,PYMIN,PYMAX,
     1FX1MIN,FX1MAX,FY1MIN,FY1MAX,
     1IBUGD2,ISUBRO,IFOUND,IERROR)
      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
C
 3899 CONTINUE
C
C               ******************************
C               **  TREAT THE TRIANGLE CASE **
C               ******************************
C
CCCCC MODIFIED TO SUPPORT "TRIANGLE DATA" OPTION.  JULY 1997.
      IF(ICOM.EQ.'TRIA')GOTO3900
      GOTO3999
C
 3900 CONTINUE
CCCCC ADD FOLLOWING CHECK SEPTEMBER 1994.
      IF(IHARG(1).EQ.'PROB')GOTO3999
CCCCC ADD FOLLOWING CHECK SEPTEMBER 2001.
      IF(IHARG(1).EQ.'PPCC')GOTO3999
      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'KOLM')GOTO2899
      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'CHI ')GOTO2899
      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'CHIS')GOTO2899
C
      UNITSW='SCRE'
      IF(IHARG(1).EQ.'DATA')THEN
        UNITSW='DATA'
        ISHIFT=1
        CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1              IBUGD2,IERROR)
      ENDIF
      CALL DPTRIA(IHARG,IARGT,ARG,NUMARG,
     1PXSTAR,PYSTAR,
     1PXEND,PYEND,
     1ILINPA,ILINCO,PLINTH,
     1AREGBA,
     1IREBLI,IREBCO,PREBTH,
     1IREFSW,IREFCO,
     1IREPTY,IREPLI,IREPCO,PREPTH,PREPSP,
     1PTEXHE,PTEXWI,PTEXVG,PTEXHG,
     1IGRASW,IDIASW,
     1PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2,
     1PDIAHE,PDIAWI,PDIAVG,PDIAHG,
     1NUMDEV,
     1IDMANU,IDMODE,IDMOD2,IDMOD3,
     1IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
     1IDNVOF,IDNHOF,
CCCCC ADD FOLLOWING LINE MARCH 1997.
     1IDFONT,
CCCCC ADD FOLLOWING LINE JULY 1997.
     1UNITSW,
     1IBUGD2,IFOUND,IERROR)
      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
C
 3999 CONTINUE
C
C               ******************************
C               **  TREAT THE AMPLIFIER CASE**
C               ******************************
C
CCCCC MODIFIED TO SUPPORT "AMPLIFIER DATA" OPTION.  JULY 1997.
      IF(ICOM.EQ.'AMPL'.AND.ICOM2.EQ.'IFIE')GOTO4000
      IF(ICOM.EQ.'AMP ')GOTO4000
      GOTO4099
C
 4000 CONTINUE
      UNITSW='SCRE'
      IF(IHARG(1).EQ.'DATA')THEN
        UNITSW='DATA'
        ISHIFT=1
        CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1              IBUGD2,IERROR)
      ENDIF
      CALL DPAMPL(IHARG,IARGT,ARG,NUMARG,
     1PXSTAR,PYSTAR,
     1PXEND,PYEND,
     1ILINPA,ILINCO,PLINTH,
     1AREGBA,
     1IREBLI,IREBCO,PREBTH,
     1IREFSW,IREFCO,
     1IREPTY,IREPLI,IREPCO,PREPTH,PREPSP,
     1PTEXHE,PTEXWI,PTEXVG,PTEXHG,
     1IGRASW,IDIASW,
     1PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2,
     1PDIAHE,PDIAWI,PDIAVG,PDIAHG,
     1NUMDEV,
     1IDMANU,IDMODE,IDMOD2,IDMOD3,
     1IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
     1IDNVOF,IDNHOF,
CCCCC ADD FOLLOWING LINE MARCH 1997.
     1IDFONT,
CCCCC ADD FOLLOWING LINE JULY 1997.
     1UNITSW,
     1IBUGD2,IFOUND,IERROR)
      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
C
 4099 CONTINUE
C
C               ******************************
C               **  TREAT THE DIAMOND CASE  **
C               ******************************
C
CCCCC MODIFIED TO SUPPORT "DIAMOND DATA" OPTION.  JULY 1997.
      IF(ICOM.EQ.'DIAM')GOTO4100
      GOTO4199
C
 4100 CONTINUE
      UNITSW='SCRE'
      IF(IHARG(1).EQ.'DATA')THEN
        UNITSW='DATA'
        ISHIFT=1
        CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1              IBUGD2,IERROR)
      ENDIF
      CALL DPDIAM(IHARG,IARGT,ARG,NUMARG,
     1PXSTAR,PYSTAR,
     1PXEND,PYEND,
     1ILINPA,ILINCO,PLINTH,
     1AREGBA,
     1IREBLI,IREBCO,PREBTH,
     1IREFSW,IREFCO,
     1IREPTY,IREPLI,IREPCO,PREPTH,PREPSP,
     1PTEXHE,PTEXWI,PTEXVG,PTEXHG,
     1IGRASW,IDIASW,
     1PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2,
     1PDIAHE,PDIAWI,PDIAVG,PDIAHG,
     1NUMDEV,
     1IDMANU,IDMODE,IDMOD2,IDMOD3,
     1IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
     1IDNVOF,IDNHOF,
CCCCC ADD FOLLOWING LINE MARCH 1997.
     1IDFONT,
CCCCC ADD FOLLOWING LINE JULY 1997.
     1UNITSW,
     1IBUGD2,IFOUND,IERROR)
      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
C
 4199 CONTINUE
C
C               ******************************
C               **  TREAT THE OVAL     CASE **
C               ******************************
C
CCCCC MODIFIED TO SUPPORT "OVAL DATA" OPTION.  JULY 1997.
      IF(ICOM.EQ.'OVAL')GOTO4200
      GOTO4299
C
 4200 CONTINUE
      UNITSW='SCRE'
      IF(IHARG(1).EQ.'DATA')THEN
        UNITSW='DATA'
        ISHIFT=1
        CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1              IBUGD2,IERROR)
      ENDIF
      CALL DPOVAL(IHARG,IARGT,ARG,NUMARG,
     1PXSTAR,PYSTAR,
     1PXEND,PYEND,
     1ILINPA,ILINCO,PLINTH,
     1AREGBA,
     1IREBLI,IREBCO,PREBTH,
     1IREFSW,IREFCO,
     1IREPTY,IREPLI,IREPCO,PREPTH,PREPSP,
     1PTEXHE,PTEXWI,PTEXVG,PTEXHG,
     1IGRASW,IDIASW,
     1PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2,
     1PDIAHE,PDIAWI,PDIAVG,PDIAHG,
     1NUMDEV,
     1IDMANU,IDMODE,IDMOD2,IDMOD3,
     1IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
     1IDNVOF,IDNHOF,
CCCCC ADD FOLLOWING LINE MARCH 1997.
     1IDFONT,
CCCCC ADD FOLLOWING LINE JULY 1997.
     1UNITSW,
     1IBUGD2,IFOUND,IERROR)
      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
C
 4299 CONTINUE
C
C               ******************************
C               **  TREAT THE ARC      CASE **
C               ******************************
C
CCCCC MODIFIED TO SUPPORT "ARC DATA" OPTION.  JULY 1997.
      IF(ICOM.EQ.'ARC ')GOTO4300
      GOTO4399
C
 4300 CONTINUE
      UNITSW='SCRE'
      IF(IHARG(1).EQ.'DATA')THEN
        UNITSW='DATA'
        ISHIFT=1
        CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1              IBUGD2,IERROR)
      ENDIF
      CALL DPARC(IHARG,IARGT,ARG,NUMARG,
     1PXSTAR,PYSTAR,
     1PXEND,PYEND,
     1ILINPA,ILINCO,PLINTH,
     1AREGBA,
     1IREBLI,IREBCO,PREBTH,
     1IREFSW,IREFCO,
     1IREPTY,IREPLI,IREPCO,PREPTH,PREPSP,
     1PTEXHE,PTEXWI,PTEXVG,PTEXHG,
     1IGRASW,IDIASW,
     1PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2,
     1PDIAHE,PDIAWI,PDIAVG,PDIAHG,
     1NUMDEV,
     1IDMANU,IDMODE,IDMOD2,IDMOD3,
     1IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
     1IDNVOF,IDNHOF,
CCCCC ADD FOLLOWING LINE MARCH 1997.
     1IDFONT,
CCCCC ADD FOLLOWING LINE JULY 1997.
     1UNITSW,
     1IBUGD2,IFOUND,IERROR)
      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
C
 4399 CONTINUE
C
C               ************************************
C               **  TREAT THE FILL CASE  **
C               ************************************
C
      IF(ICOM.EQ.'FILL')GOTO7100
      GOTO7199
 7100 CONTINUE
      CALL DPFILL(IHARG,NUMARG,
     1IDEFFI,
     1ITEXFI,
     1IBUGD2,ISUBRO,IFOUND,IERROR)
      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
C
 7199 CONTINUE
C
C               ************************************
C               **  TREAT THE ANGLE CASE  **
C               ************************************
C
CCCCC OCTOBER 1995.  NAME CONFLICT WITH ANGLIT PROBABILITY PLOT
C
      IF(ICOM.EQ.'ANGL')GOTO7200
      GOTO7299
 7200 CONTINUE
CCCCC OCTOBER 1995.  ADD FOLLOWING 2 LINES.
      IF(ICOM2.EQ.'IT  '.OR.(NUMARG.GE.2.AND.IHARG(1).EQ.'PROB'.AND.
     1IHARG(2).EQ.'PLOT'))GOTO7299
      CALL DPANGL(IHARG,IARGT,ARG,NUMARG,
     1ITEXAU,
     1ADEFAN,IDEFDI,
     1ATEXAN,ITEXDI,
     1IBUGD2,ISUBRO,IFOUND,IERROR)
      ANGLE=ATEXAN
      DEFANG=ADEFAN
      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
C
 7299 CONTINUE
C
C               ************************************
C               **  TREAT THE ANGLE UNITS CASE  **
C               **  TREAT THE RADIANS     CASE  **
C               **  TREAT THE DEGREES     CASE  **
C               **  TREAT THE GRADS       CASE  **
C               ************************************
C
      IF(ICOM.EQ.'ANGL')GOTO7300
      IF(ICOM.EQ.'RADI')GOTO7300
      IF(ICOM.EQ.'DEGR')GOTO7300
      IF(ICOM.EQ.'GRAD')GOTO7300
      GOTO7399
 7300 CONTINUE
      IF(ICOM.EQ.'ANGL')GOTO7310
      ISHIFT=2
      CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1IBUGD2,IERROR)
      IHARG(1)='UNIT'
      IHOLD=ICOM
      IF(NUMARG.GE.3.AND.IHARG(3).EQ.'OFF')IHOLD=IDEFAU
      IF(NUMARG.GE.3.AND.IHARG(3).EQ.'OFF'.AND.ICOM.EQ.IDEFAU)
     1IHOLD='DEGR'
      IHARG(2)=IHOLD
      NUMARG=2
 7310 CONTINUE
      CALL DPANGU(IHARG,NUMARG,
     1IDEFAU,
     1ITEXAU,
     1IBUGD2,ISUBRO,IFOUND,IERROR)
      IANGLU=ITEXAU
      IDEANU=IDEFAU
      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
C
 7399 CONTINUE
C
C               ************************************
C               **  TREAT THE PATTERN CASE  **
C               ************************************
C
      IF(ICOM.EQ.'PATT')GOTO7400
      GOTO7499
 7400 CONTINUE
      CALL DPPATT(IHARG,NUMARG,
     1IDEFPA,
     1ITEXPA,
     1IBUGD2,ISUBRO,IFOUND,IERROR)
      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
C
 7499 CONTINUE
C
C               ************************************
C               **  TREAT THE COLOR CASE  **
C               ************************************
C
      IF(ICOM.EQ.'COLO')GOTO7500
      IF(ICOM.EQ.'PEN')GOTO7500
      GOTO7599
 7500 CONTINUE
      CALL DPCOLO(IHARG,NUMARG,
     1IDEFCO,
     1ITEXCO,
     1IBUGD2,ISUBRO,IFOUND,IERROR)
      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
C
 7599 CONTINUE
C
C               ***************************************
C               **  TREAT THE VERTICAL SPACING CASE  **
C               ***************************************
C
      IF(ICOM.EQ.'VERT')GOTO7600
      GOTO7699
C
 7600 CONTINUE
      CALL DPVERT(IHARG,IARGT,ARG,NUMARG,
     1PDEFVG,
     1PTEXVG,
     1IBUGD2,ISUBRO,IFOUND,IERROR)
      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
C
 7699 CONTINUE
C
C               *****************************************
C               **  TREAT THE HORIZONTAL SPACING CASE  **
C               *****************************************
C
      IF(ICOM.EQ.'HORI'.AND.IHARG(1).NE.'SWIT')GOTO7700
      GOTO7799
C
 7700 CONTINUE
      CALL DPHORI(IHARG,IARGT,ARG,NUMARG,
     1PDEFHG,
     1PTEXHG,
     1IBUGD2,ISUBRO,IFOUND,IERROR)
      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
C
 7799 CONTINUE
C
C               ***************************************
C               **  TREAT THE CARRAIAGE RETURN CASE  **
C               ***************************************
C
      IF(ICOM.EQ.'CARR')GOTO7800
      IF(ICOM.EQ.'CR')GOTO7800
      GOTO7899
C
 7800 CONTINUE
      CALL DPCR(IHARG,NUMARG,
     1IDEFCR,
     1ITEXCR,
     1IBUGD2,ISUBRO,IFOUND,IERROR)
      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
C
 7899 CONTINUE
C
C               ********************************
C               **  TREAT THE LINE FEED CASE  **
C               ********************************
C
      IF(ICOM.EQ.'LINE'.AND.NUMARG.GE.1.AND.IHARG(1).EQ.'FEED')GOTO7900
      IF(ICOM.EQ.'LF')GOTO7900
      GOTO7999
C
 7900 CONTINUE
      CALL DPLF(IHARG,NUMARG,
     1IDEFLF,
     1ITEXLF,
     1IBUGD2,ISUBRO,IFOUND,IERROR)
      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
C
 7999 CONTINUE
C
C               ***************************************
C               **  TREAT THE SYMBOL CHARACTER CASE  **
C               ***************************************
C
CCCCC AUGUST 1992.  CHECK FOR CONFLICT WITH "SYMBOL PLOT" COMMAND.
CCCCC IF(ICOM.EQ.'SYMB')GOTO8000
      IF(ICOM.EQ.'SYMB'.AND.IHARG(1).NE.'PLOT')GOTO8000
      GOTO8099
C
 8000 CONTINUE
      CALL DPSYMB(IHARG,NUMARG,
     1IDEFSY,
     1ITEXSY,
     1IBUGD2,ISUBRO,IFOUND,IERROR)
      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
C
 8099 CONTINUE
C
C               *******************************************************
C               **  TREAT THE SPACING (EQUAL VS. PROPORTIONAL) CASE  **
C               *******************************************************
C
      IF(ICOM.EQ.'SPAC')GOTO8100
      GOTO8199
C
 8100 CONTINUE
      CALL DPSPAC(IHARG,NUMARG,
     1IDEFSP,
     1ITEXSP,
     1IBUGD2,ISUBRO,IFOUND,IERROR)
      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
C
 8199 CONTINUE
C
C               *****************************
C               **  TREAT THE THICKNESS CASE  **
C               *****************************
C
      IF(ICOM.EQ.'THIC')GOTO8200
      GOTO8299
C
 8200 CONTINUE
      CALL DPTHIC(IHARG,IARGT,ARG,NUMARG,
     1PDEFTH,
     1PTEXTH,
C  DECEMBER 1987: SET ALL THICKNESS (CAN THEN
C  OVERRIDE ANY INDIVIDUALLY)
     1PFRATH,PTICTH,PTIZTH,PVGRTH,PHGRTH,PTITTH,PX1LTH,PX2LTH,PY1LTH,
     1PY2LTH,PLEGTH,MAXLG,PBOPTH,PBOFTH,MAXBX,PARRTH,MAXAR,
     1PSEGTH,MAXSG,PLINTH,MAXLN,PCHATH,MAXCH2,PFILTH,MAXFL,
     1PPATTH,MAXPT,PSPITH,MAXSP,PBABTH,PBAPTH,MAXBA,PREPTH,MAXRG,
     1PMABTH,PMAPTH,MAXMR,PTEBTH,PTEPTH,MAXTX,
C  END CHANGE
     1IBUGD2,ISUBRO,IFOUND,IERROR)
      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
C
 8299 CONTINUE
C
C               *******************************
C               **  TREAT THE DIALOGUE CASE  **
C               *******************************
C
CCCCC IF(ICOM.EQ.'DIAL')GOTO8300
CCCCC IF(ICOM.EQ.'D')GOTO8300
CCCCC GOTO8399
CCCCC
C8300 CONTINUE
CCCCC CALL DPDIAL(IHARG,IARGT,IARG,NUMARG,
CCCCC1IGRASW,PDIAXC,PDIAYC,
CCCCC1NUMDEV,
CCCCC1IDMANU,IDMODE,IDMOD2,IDMOD3,
CCCCC1IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
CCCCC1IDNVOF,IDNHOF,
CCCCC ADD FOLLOWING LINE MARCH 1997.
CCCCC1IDFONT,
CCCCC1IBUGD2,ISUBRO,IFOUND,IERROR)
CCCCC IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
CCCCC
C8399 CONTINUE
C
C               **************************
C               **  TREAT THE CUBE CASE **
C               **************************
C
CCCCC MODIFIED TO SUPPORT "CUBE DATA" OPTION.  JULY 1997.
      IF(ICOM.EQ.'CUBE')GOTO8400
      GOTO8499
C
 8400 CONTINUE
      UNITSW='SCRE'
      IF(IHARG(1).EQ.'DATA')THEN
        UNITSW='DATA'
        ISHIFT=1
        CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1              IBUGD2,IERROR)
      ENDIF
      CALL DPCUBE(IHARG,IARGT,ARG,NUMARG,
     1PXSTAR,PYSTAR,
     1PXEND,PYEND,
     1ILINPA,ILINCO,PLINTH,
     1AREGBA,
     1IREBLI,IREBCO,PREBTH,
     1IREFSW,IREFCO,
     1IREPTY,IREPLI,IREPCO,PREPTH,PREPSP,
     1PTEXHE,PTEXWI,PTEXVG,PTEXHG,
     1IGRASW,IDIASW,
     1PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2,
     1PDIAHE,PDIAWI,PDIAVG,PDIAHG,
     1NUMDEV,
     1IDMANU,IDMODE,IDMOD2,IDMOD3,
     1IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
     1IDNVOF,IDNHOF,
     1IDFONT,
CCCCC ADD FOLLOWING LINE JULY 1997.
     1UNITSW,
     1IBUGD2,IFOUND,IERROR)
 8499 CONTINUE
C
C               ******************************
C               **  TREAT THE PYRAMID CASE  **
C               ******************************
C
CCCCC MODIFIED TO SUPPORT "PYRAMID DATA" OPTION.  JULY 1997.
      IF(ICOM.EQ.'PYRA')GOTO8500
      GOTO8599
C
 8500 CONTINUE
      UNITSW='SCRE'
      IF(IHARG(1).EQ.'DATA')THEN
        UNITSW='DATA'
        ISHIFT=1
        CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1              IBUGD2,IERROR)
      ENDIF
      CALL DPPYRA(IHARG,IARGT,ARG,NUMARG,
     1PXSTAR,PYSTAR,
     1PXEND,PYEND,
     1ILINPA,ILINCO,PLINTH,
     1AREGBA,
     1IREBLI,IREBCO,PREBTH,
     1IREFSW,IREFCO,
     1IREPTY,IREPLI,IREPCO,PREPTH,PREPSP,
     1PTEXHE,PTEXWI,PTEXVG,PTEXHG,
     1IGRASW,IDIASW,
     1PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2,
     1PDIAHE,PDIAWI,PDIAVG,PDIAHG,
     1NUMDEV,
     1IDMANU,IDMODE,IDMOD2,IDMOD3,
     1IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
     1IDNVOF,IDNHOF,
     1IDFONT,
CCCCC ADD FOLLOWING LINE JULY 1997.
     1UNITSW,
     1IBUGD2,IFOUND,IERROR)
 8599 CONTINUE
C
C               ******************************
C               **  TREAT THE LATTICE  CASE **
C               ******************************
C
CCCCC MODIFIED TO SUPPORT "LATTICE DATA" OPTION.  JULY 1997.
      IF(ICOM.EQ.'LATT')GOTO8600
      GOTO8699
C
 8600 CONTINUE
      UNITSW='SCRE'
      IF(IHARG(1).EQ.'DATA')THEN
        UNITSW='DATA'
        ISHIFT=1
        CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1              IBUGD2,IERROR)
      ENDIF
      CALL DPLATT(IHARG,IARGT,ARG,NUMARG,
     1PXSTAR,PYSTAR,
     1PXEND,PYEND,
     1ILINPA,ILINCO,PLINTH,
     1AREGBA,
     1IREBLI,IREBCO,PREBTH,
     1IREFSW,IREFCO,
     1IREPTY,IREPLI,IREPCO,PREPTH,PREPSP,
     1PTEXHE,PTEXWI,PTEXVG,PTEXHG,
     1IGRASW,IDIASW,
     1PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2,
     1PDIAHE,PDIAWI,PDIAVG,PDIAHG,
     1NUMDEV,
     1IDMANU,IDMODE,IDMOD2,IDMOD3,
     1IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
     1IDNVOF,IDNHOF,
     1IDFONT,
CCCCC ADD FOLLOWING LINE JULY 1997.
     1UNITSW,
     1IBUGD2,IFOUND,IERROR)
      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
C
 8699 CONTINUE
C
C               ******************************
C               **  TREAT THE POLYGON CASE  **
C               ******************************
C
      IF(ICOM.EQ.'POLY'.AND.ICOM2.EQ.'GON ')GOTO8700
      GOTO8799
C
 8700 CONTINUE
      UNITSW='SCRE'
      IF(IHARG(1).EQ.'DATA')THEN
        UNITSW='DATA'
        ISHIFT=1
        CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1              IBUGD2,IERROR)
      ENDIF
      CALL DPPOLY(
     1PXSTAR,PYSTAR,
     1PXEND,PYEND,
     1ILINPA,ILINCO,PLINTH,
     1AREGBA,
     1IREBLI,IREBCO,PREBTH,
     1IREFSW,IREFCO,
     1IREPTY,IREPLI,IREPCO,PREPTH,PREPSP,
     1PTEXHE,PTEXWI,PTEXVG,PTEXHG,
     1IGRASW,IDIASW,
     1PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2,
     1PDIAHE,PDIAWI,PDIAVG,PDIAHG,
     1NUMDEV,
     1IDMANU,IDMODE,IDMOD2,IDMOD3,
     1IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
     1IDNVOF,IDNHOF,
     1IDFONT,
     1UNITSW,
     1IBUGD2,IFOUND,IERROR)
      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
C
 8799 CONTINUE
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      IF(IBUGDG.EQ.'OFF')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('AT THE END       OF MAINDG--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)IBUGDG,IBUGD2,ISUBRO
 9013 FORMAT('IBUGDG,IBUGD2,ISUBRO = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9014)IFOUND,IERROR
 9014 FORMAT('IFOUND,IERROR = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9019)PXSTAR,PYSTAR,PXEND,PYEND
 9019 FORMAT('PXSTAR,PYSTAR,PXEND,PYEND = ',4E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9020)DEFANG,ANGLE,IDEANU,IANGLU
 9020 FORMAT('DEFANG,ANGLE,IDEANU,IANGLU = ',2E15.7,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9029)IFOUND,IERROR
 9029 FORMAT('IFOUND,IERROR = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9027)ICOM,ICOM2
 9027 FORMAT('ICOM,ICOM2 = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9028)NUMARG
 9028 FORMAT('NUMARG = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO9030I=1,NUMARG
      WRITE(ICOUT,9031)I,IHARG(I),IHARG2(I),IARGT(I),IARG(I),ARG(I)
 9031 FORMAT('I,IHARG(I),IHARG2(I),IARGT(I),IARG(I),ARG(I) = ',
     1I8,2X,A4,2X,A4,2X,A4,2X,I8,E15.7)
      CALL DPWRST('XXX','BUG ')
 9030 CONTINUE
      WRITE(ICOUT,9041)IREPCH
 9041 FORMAT('IREPCH = ',A1)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
