      DOUBLE PRECISION FUNCTION UNI()
*
*     Uniform (0, 1) random number generator
*
*     Reference:
*     L'Ecuyer, Pierre (1996), 
*     "Combined Multiple Recursive Random Number Generators"
*     Operations Research 44, pp. 816-822.
*
*
      INTEGER A12, A13, A21, A23, P12, P13, P21, P23
      INTEGER Q12, Q13, Q21, Q23, R12, R13, R21, R23
      INTEGER X10, X11, X12, X20, X21, X22, Z, M1, M2, H 
      DOUBLE PRECISION INVMP1
      PARAMETER (  M1 = 2147483647,  M2 = 2145483479 )
      PARAMETER ( A12 =   63308,    Q12 = 33921, R12 = 12979 )
      PARAMETER ( A13 = -183326,    Q13 = 11714, R13 =  2883 )
      PARAMETER ( A21 =   86098,    Q21 = 24919, R21 =  7417 )
      PARAMETER ( A23 = -539608,    Q23 =  3976, R23 =  2071 )
      PARAMETER ( INVMP1 = 4.656612873077392578125D-10 ) 
*                 INVMP1 = 1.0D0/DBLE(M1+1)
      SAVE X10, X11, X12, X20, X21, X22
      DATA       X10,      X11,      X12,      X20,      X21,      X22  
     &    / 11111111, 22222223, 33333335, 44444447, 55555559, 66666661 /
*
*     Component 1
*
      H = X10/Q13
      P13 = -A13*( X10 - H*Q13 ) - H*R13
      H = X11/Q12
      P12 =  A12*( X11 - H*Q12 ) - H*R12
      IF ( P13 .LT. 0 ) P13 = P13 + M1
      IF ( P12 .LT. 0 ) P12 = P12 + M1
      X10 = X11 
      X11 = X12
      X12 = P12 - P13
      IF ( X12 .LT. 0 ) X12 = X12 + M1
*
*     Component 2
*
      H = X20/Q23
      P23 = -A23*( X20 - H*Q23 ) - H*R23
      H = X22/Q21
      P21 =  A21*( X22 - H*Q21 ) - H*R21
      IF ( P23 .LT. 0 ) P23 = P23 + M2
      IF ( P21 .LT. 0 ) P21 = P21 + M2
      X20 = X21 
      X21 = X22
      X22 = P21 - P23
      IF ( X22 .LT. 0 ) X22 = X22 + M2
*
*     Combination
*
      Z = X12 - X22
      IF ( Z .LE. 0 ) Z = Z + M1
      UNI = Z*INVMP1
*
      RETURN
      END
      SUBROUTINE UNICDF(X,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE UNIFORM (RECTANGULAR) 
C              DISTRIBUTION ON THE UNIT INTERVAL (0,1).
C              THIS DISTRIBUTION HAS MEAN = 0.5
C              AND STANDARD DEVIATION = SQRT(1/12) = 0.28867513.
C              THIS DISTRIBUTION HAS THE PROBABILITY
C              DENSITY FUNCTION F(X) = 1.
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 UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 
C     RESTRICTIONS--X SHOULD BE BETWEEN 0 AND 1, 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--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--2, 1970, PAGES 57-74.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 WASHINGTON, D. C. 20234
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.OR.X.GT.1.0)GOTO50
      GOTO90
   50 CONTINUE
      WRITE(ICOUT,2)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)X
      CALL DPWRST('XXX','BUG ')
      IF(X.LT.0.0)CDF=0.0
      IF(X.GT.1.0)CDF=1.0
      RETURN
   90 CONTINUE
    2 FORMAT(
     1'***** NON-FATAL DIAGNOSTIC--THE FIRST  INPUT ARGUMENT TO THE')
    3 FORMAT(
     1'      UNICDF SUBROUTINE IS OUTSIDE THE USUAL (0,1) INTERVAL ***')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
C-----START POINT-----------------------------------------------------
C
      CDF=X
C
      RETURN
      END 
      SUBROUTINE UNICHA(X,HAZ)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE HAZARD
C              FUNCTION VALUE FOR THE UNIFORM (RECTANGULAR) 
C              DISTRIBUTION ON THE UNIT INTERVAL (0,1).
C              THIS DISTRIBUTION HAS MEAN = 0.5
C              AND STANDARD DEVIATION = SQRT(1/12) = 0.28867513.
C              THIS DISTRIBUTION HAS THE PROBABILITY
C              DENSITY FUNCTION F(X) = 1 AND CUMULATIVE HAZARD FUNCTION
C                               H(X) = -LOG(1-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 HAZARD
C                                FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION CUMULATIVE HAZARD
C             FUNCTION VALUE HAZ.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 
C     RESTRICTIONS--X SHOULD BE BETWEEN 0 AND 1, 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--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--2, 1970, PAGES 57-74.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 WASHINGTON, D. C. 20234
C                 PHONE:  301-975-2855
C     ORIGINAL VERSION--APRIL     1998. 
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.OR.X.GE.1.0)GOTO50
      GOTO90
   50 CONTINUE
      WRITE(ICOUT,2)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)X
      CALL DPWRST('XXX','BUG ')
      HAZ=0.0
      RETURN
   90 CONTINUE
    2 FORMAT(
     1'***** NON-FATAL DIAGNOSTIC--THE FIRST  INPUT ARGUMENT TO THE')
    3 FORMAT(
     1'UNICHA SUBROUTINE IS OUTSIDE THE USUAL (0,1) INTERVAL *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
C-----START POINT-----------------------------------------------------
C
      HAZ=-LOG(1.0-X)
C
      RETURN
      END 
      SUBROUTINE UNIHAZ(X,HAZ)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE HAZARD
C              FUNCTION VALUE FOR THE UNIFORM (RECTANGULAR) 
C              DISTRIBUTION ON THE UNIT INTERVAL (0,1).
C              THIS DISTRIBUTION HAS MEAN = 0.5
C              AND STANDARD DEVIATION = SQRT(1/12) = 0.28867513.
C              THIS DISTRIBUTION HAS THE PROBABILITY
C              DENSITY FUNCTION F(X) = 1 AND HAZARD FUNCTION
C                               H(X) = 1/(1-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 UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 
C     RESTRICTIONS--X SHOULD BE BETWEEN 0 AND 1, 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--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--2, 1970, PAGES 57-74.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 WASHINGTON, D. C. 20234
C                 PHONE:  301-975-2855
C     ORIGINAL VERSION--APRIL     1998. 
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.OR.X.GE.1.0)GOTO50
      GOTO90
   50 CONTINUE
      WRITE(ICOUT,2)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)X
      CALL DPWRST('XXX','BUG ')
      HAZ=0.0
      RETURN
   90 CONTINUE
    2 FORMAT(
     1'***** NON-FATAL DIAGNOSTIC--THE FIRST  INPUT ARGUMENT TO THE')
    3 FORMAT(
     1'UNIHAZ SUBROUTINE IS OUTSIDE THE USUAL (0,1) INTERVAL *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
C-----START POINT-----------------------------------------------------
C
      HAZ=1.0/(1.0 - X)
C
      RETURN
      END 
      REAL FUNCTION UNIKMN()
C***BEGIN PROLOGUE  UNIKMN
C***DATE WRITTEN   810915 (YYMMDD)
C***REVISION DATE  871210 (YYMMDD)
C***CATEGORY NO.  L6A21
C***KEYWORDS  RANDOM NUMBERS, UNIFORM RANDOM NUMBERS
C***AUTHOR    KAHANER, DAVID, SCIENTIFIC COMPUTING DIVISION, NBS
C             MARSAGLIA, GEORGE, SUPERCOMPUTER RES. INST., FLORIDA ST. U.
C
C***PURPOSE  THIS ROUTINE GENERATES REAL (SINGLE PRECISION) UNIFORM 
C             RANDOM NUMBERS ON [0,1)
C***DESCRIPTION
C        Computes real (single precision) uniform numbers on [0,1).
C           From the book, "Numerical Methods and Software" by
C                D. Kahaner, C. Moler, S. Nash
C                Prentice Hall, 1988
C 
C       USAGE: 
C              To initialize the generator 
C                   USEED = USTART(ISEED) 
C               where: ISEED is any NONZERO integer 
C                  will return floating point value of ISEED. 
C 
C               Subsequently 
C                       U = UNI() 
C                  will return a real uniform on [0,1) 
C 
C                One initialization is necessary, but any number of evaluations 
C                  of  UNI in any order, are allowed.
C 
C           Note: Depending upon the value of K (see below), the output
C                       of UNI may differ from one machine to another.
C 
C           Typical usage:
C
C               REAL U,UNI,USTART,USEED
C               INTEGER ISEED
CC                 Set seed
C               ISEED = 305 
C               USEED = USTART(ISEED)
C               DO 1 I = 1,1000 
C                   U = UNI()
C             1 CONTINUE 
CC                 NOTE: If K=24 (the default, see below) the output value of 
CC                           U will be 0.1570390462475...
C               WRITE(*,*) U 
C               END 
C
C          NOTE ON PORTABILITY: Users can choose to run UNI in its default
C               mode (requiring NO user action) which will generate the same 
C               sequence of numbers on any computer supporting floating point
C               numbers with at least 24 bit mantissas, or in a mode that 
C               will generate numbers with a longer period on computers with 
C               larger mantissas.
C          TO EXERCISE THIS OPTION:  B E F O R E  invoking USTART insert
C               the instruction        UBITS = UNIB(K)      K >= 24
C               where K is the number of bits in the mantissa of your floating
C               point word (K=48 for Cray, Cyber 205). UNIB returns the
C               floating point value of K that it actually used.
C                    K input as .LE. 24, then UBITS=24.
C                    K input as .GT. 24, then UBITS=FLOAT(K)
C               If K>24 the sequence of numbers generated by UNI may differ
C               from one computer to another.
C               
C             
C
C***REFERENCES  MARSAGLIA G., "COMMENTS ON THE PERFECT UNIFORM RANDOM 
C                 NUMBER GENERATOR", UNPUBLISHED NOTES, WASH S. U.
C***ROUTINES CALLED  (NONE)
C***END PROLOGUE UNI
      PARAMETER(
     *    CSAVE=362436./16777216.  ,
     *    CD=7654321./16777216.,
     *    CM=16777213./16777216.  )
C                            2**24=16777216
      REAL U(17),S,T,USTART,C,UNIB
      INTEGER I,J,II,JJ,K,KK,I1,J1,K1,L1,M1,ISEED
C      
      SAVE U,I,J,K,C
C      Load data array in case user forgets to initialize.
C      This array is the result of calling UNI 100000 times
C         with ISEED=305 and K=64.
      DATA U/
     *0.8668672834288,  0.3697986366357,  0.8008968294805,
     *0.4173889774680,  0.8254561579836,  0.9640965269077,
     *0.4508667414265,  0.6451309529668,  0.1645456024730,
     *0.2787901807898,  0.06761531340295, 0.9663226330820,
     *0.01963343943798, 0.02947398211399, 0.1636231515294,
     *0.3976343250467,  0.2631008574685/
      DATA I,J,K,C/17,5,24,CSAVE/
C 
C   Basic generator is Fibonacci
C 
      UNIKMN = U(I)-U(J)
      IF(UNIKMN.LT.0.0)UNIKMN = UNIKMN+1.0
      U(I) = UNIKMN
      I = I-1
      IF(I.EQ.0)I = 17
      J = J-1
      IF(J.EQ.0)J = 17
C
C   Second generator is congruential
C
      C = C-CD
      IF(C.LT.0.0) C=C+CM
C
C   Combination generator
C
      UNIKMN = UNIKMN-C
      IF(UNIKMN.LT.0.0)UNIKMN = UNIKMN+1.0
      RETURN
C
      ENTRY USTART(ISEED)
C 
C          Set up ...
C          Convert ISEED to four smallish positive integers.
C
        I1 = MOD(ABS(ISEED),177)+1
        J1 = MOD(ABS(ISEED),167)+1
        K1 = MOD(ABS(ISEED),157)+1
        L1 = MOD(ABS(ISEED),147)+1
C
C              Generate random bit pattern in array based on given seed.
C 
        DO 2 II = 1,17
          S = 0.0
          T = 0.5
C             Do for each of the bits of mantissa of word 
C             Loop  over K bits, where K is defaulted to 24 but can
C               be changed by user call to UNIB(K)
          DO 3 JJ = 1,K
                  M1 = MOD(MOD(I1*J1,179)*K1,179)
                  I1 = J1
                  J1 = K1
                  K1 = M1
                  L1 = MOD(53*L1+1,169)
                  IF(MOD(L1*M1,64).GE.32)S=S+T
    3             T = .5*T
    2   U(II) = S
        USTART = FLOAT(ISEED)
        RETURN
C
      ENTRY UNIB(KK)
        IF(KK.LE.24)THEN
             K=24
        ELSE
             K=KK
        ENDIF
        UNIB=FLOAT(K)
      RETURN
      END
      SUBROUTINE UNIPDF(X,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE UNIFORM (RECTANGULAR) 
C              DISTRIBUTION ON THE UNIT INTERVAL (0,1).
C              THIS DISTRIBUTION HAS MEAN = 0.5
C              AND STANDARD DEVIATION = SQRT(1/12) = 0.28867513.
C              THIS DISTRIBUTION HAS THE PROBABILITY
C              DENSITY FUNCTION F(X) = 1.
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 UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 
C     RESTRICTIONS--X SHOULD BE BETWEEN 0 AND 1, 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--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--2, 1970, PAGES 57-74.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 WASHINGTON, D. C. 20234
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.OR.X.GT.1.0)GOTO50
      GOTO90
   50 CONTINUE
      WRITE(ICOUT,2)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)X
      CALL DPWRST('XXX','BUG ')
      PDF=0.0
      RETURN
   90 CONTINUE
    2 FORMAT(
     1'***** NON-FATAL DIAGNOSTIC--THE FIRST  INPUT ARGUMENT TO THE')
    3 FORMAT(
     1'UNIPDF SUBROUTINE IS OUTSIDE THE USUAL (0,1) INTERVAL *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
C-----START POINT-----------------------------------------------------
C
      PDF=1.0
C
      RETURN
      END 
      SUBROUTINE UNIME2(N,I,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES THE I-TH ORDER STATISTIC MEDIAN
C              FROM A SAMPLE OF SIZE N
C              FROM THE UNIFORM (RECTANGULAR)
C              DISTRIBUTION ON THE UNIT INTERVAL (0,1).
C              THIS DISTRIBUTION HAS MEAN = 0.5
C              AND STANDARD DEVIATION = SQRT(1/12) = 0.28867513.
C              THIS DISTRIBUTION HAS THE PROBABILITY
C              DENSITY FUNCTION F(X) = 1.
C              THIS SUBROUTINE IS A SUPPORT SUBROUTINE FOR
C              ALL OF THE PROBABILITY PLOT SUBROUTINES
C              IN DATAPAC; IT IS RARELY USED BY THE
C              DATA ANALYST DIRECTLY.
C              A PROBABILITY PLOT FOR A GENERAL DISTRIBUTION
C              IS A PLOT OF THE ORDERED OBSERVATIONS VERSUS
C              THE ORDER STATISTIC MEDIANS FOR THAT DISTRIBUTION.
C              THE I-TH ORDER STATISTIC MEDIAN FOR A GENERAL
C              DISTRIBUTION IS OBTAINED BY TRANSFORMING
C              THE I-TH UNIFORM ORDER STATISTIC MEDIAN
C              BY THE PERCENT POINT FUNCTION OF THE DESIRED
C              DISTRIBUTION--HENCE THE IMPORTANCE OF BEING ABLE TO
C              GENERATE UNIFORM ORDER STATISTIC MEDIANS.
C              IT IS OF THEROETICAL INTEREST TO NOTE THAT
C              THE I-TH UNIFORM ORDER STATISTIC MEDIAN
C              IN A SAMPLE OF SIZE N IS IDENTICALLY THE
C              MEDIAN OF THE BETA DISTRIBUTION
C              WITH PARAMETERS I AND N-I+1.
C     INPUT  ARGUMENTS--N      = THE INTEGER NUMBER
C                                OF OBSERVATIONS
C                                IN A SAMPLE.
C                     --I      = THE INTEGER NUMBER
C                                OF THE ORDER STATISTIC
C                                FOR WHICH A UNIFORM ORDER
C                                STATISTIC MEDIAN IS TO BE GENERATED.
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VARIABLE
C                                INTO WHICH THE GENERATED
C                                UNIFORM ORDER STATISTIC MEDIAN
C                                WILL BE PLACED.
C     OUTPUT--A SINGLE ORDER STATISTIC MEDIAN
C             FROM THE RECTANGULAR DISTRIBUTION ON (0,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--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--FILLIBEN, 'THE PROBABILITY PLOT CORRELATION COEFFICIENT
C                 TEST FOR NORMALITY', TECHNOMETRICS, 1975, PAGES 111-117.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--82.6
C     ORIGINAL VERSION--JANUARY   1981.
C     UPDATED         --DECEMBER  1981.
C     UPDATED         --MAY       1982.
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(N.LT.1)GOTO50
      IF(N.EQ.1)GOTO55
      GOTO90
   50 WRITE(ICOUT, 5)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,47)N
      CALL DPWRST('XXX','BUG ')
      RETURN
   55 CONTINUE
CCCCC WRITE(ICOUT, 8)
CCCCC CALL DPWRST('XXX','BUG ')
   90 CONTINUE
    5 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ',
     1'UNIME2 SUBROUTINE IS NON-POSITIVE *****')
    8 FORMAT('***** NON-FATAL DIAGNOSTIC--THE 1ST INPUT ARGUMENT ',
     1'TO THE UNIME2 SUBROUTINE HAS THE VALUE 1')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
C
      AN=N
C
C     COMPUTE THE MEDIANS FOR THE FIRST AND LAST ORDER STATISTICS
C
      IF(I.EQ.1)GOTO110
      IF(I.EQ.N)GOTO120
      GOTO130
C
  110 CONTINUE
      IF(I.EQ.1)X=1.0-(0.5**(1.0/AN))
      GOTO9000
C
  120 CONTINUE
      IF(I.EQ.N)X=0.5**(1.0/AN)
      GOTO9000
C
  130 CONTINUE
      GAM=0.3175
      AI=I
      X=(AI-GAM)/(AN-2.0*GAM+1.0)
      GOTO9000
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE UNIMED(N,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES THE N ORDER STATISTIC MEDIANS
C              FROM THE UNIFORM (RECTANGULAR)
C              DISTRIBUTION ON THE UNIT INTERVAL (0,1).
C              THIS DISTRIBUTION HAS MEAN = 0.5
C              AND STANDARD DEVIATION = SQRT(1/12) = 0.28867513.
C              THIS DISTRIBUTION HAS THE PROBABILITY
C              DENSITY FUNCTION F(X) = 1.
C              THIS SUBROUTINE IS A SUPPORT SUBROUTINE FOR
C              ALL OF THE PROBABILITY PLOT SUBROUTINES
C              IN DATAPAC; IT IS RARELY USED BY THE
C              DATA ANALYST DIRECTLY.
C              A PROBABILITY PLOT FOR A GENERAL DISTRIBUTION
C              IS A PLOT OF THE ORDERED OBSERVATIONS VERSUS
C              THE ORDER STATISTIC MEDIANS FOR THAT DISTRIBUTION.
C              THE I-TH ORDER STATISTIC MEDIAN FOR A GENERAL
C              DISTRIBUTION IS OBTAINED BY TRANSFORMING
C              THE I-TH UNIFORM ORDER STATISTIC MEDIAN
C              BY THE PERCENT POINT FUNCTION OF THE DESIRED
C              DISTRIBUTION--HENCE THE IMPORTANCE OF BEING ABLE TO
C              GENERATE UNIFORM ORDER STATISTIC MEDIANS.
C              IT IS OF THEROETICAL INTEREST TO NOTE THAT
C              THE I-TH UNIFORM ORDER STATISTIC MEDIAN
C              IN A SAMPLE OF SIZE N IS IDENTICALLY THE
C              MEDIAN OF THE BETA DISTRIBUTION
C              WITH PARAMETERS I AND N-I+1.
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF UNIFORM ORDER STATISTIC MEDIANS
C                                TO BE GENERATED.
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST N)
C                                INTO WHICH THE GENERATED
C                                UNIFORM ORDER STATISTIC MEDIANS
C                                WILL BE PLACED.
C     OUTPUT--THE N ORDER STATISTIC MEDIANS
C             FROM THE RECTANGULAR DISTRIBUTION ON (0,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--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--FILLIBEN, 'THE PROBABILITY PLOT CORRELATION COEFFICIENT
C                 TEST FOR NORMALITY', TECHNOMETRICS, 1975, PAGES 111-117.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--82.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
      IF(N.EQ.1)GOTO55
      GOTO90
   50 WRITE(ICOUT, 5)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,47)N
      CALL DPWRST('XXX','BUG ')
      RETURN
   55 WRITE(ICOUT, 8)
      CALL DPWRST('XXX','BUG ')
   90 CONTINUE
    5 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ',
     1'UNIMED SUBROUTINE IS NON-POSITIVE *****')
    8 FORMAT('***** NON-FATAL DIAGNOSTIC--THE 1ST INPUT ARGUMENT ',
     1' TO THE UNIMED SUBROUTINE HAS THE VALUE 1')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
C
      AN=N
C
C     COMPUTE THE MEDIANS FOR THE FIRST AND LAST ORDER STATISTICS
C
      X(N)=0.5**(1.0/AN)
      X(1)=1.0-X(N)
C
C     DETERMINE IF AN ODD OR EVEN SAMPLE SIZE
C
      NHALF=(N/2)+1
      NEVODD=2*(N/2)
      IF(N.NE.NEVODD)X(NHALF)=0.5
      IF(N.LE.3)RETURN
C
C     COMPUTE THE MEDIANS FOR THE OTHER ORDER STATISTICS
C
      GAM=0.3175
      IMAX=N/2
      DO100I=2,IMAX
      AI=I
      IREV=N-I+1
      X(I)=(AI-GAM)/(AN-2.0*GAM+1.0)
      X(IREV)=1.0-X(I)
  100 CONTINUE
C
      RETURN
      END
      SUBROUTINE UNIME3(N,X,TAG,IMETH)
C
C     PURPOSE--THE UNIMED SUBROUTINE COMPUTES UNIFORM ORDER
C              STATISTIC MEDIANS FROM THE UNIFORM (RECTANGULAR)
C              DISTRIBUTION ON THE UNIT INTERVAL (0,1).
C              FOR FULL SAMPLES, THIS IS USED TO GENERATE
C              PLOTTING POSITIONS FOR THE PROBABILITY PLOT.
C              THE UNIME2 SUBROUTINE IS A MODIFIED VERSION THAT
C              IS USED FOR THE CASE OF TIME CENSORED DATA.  IN
C              THIS CASE, THE TAG VARIABLE IDENTIFIES WHETHER
C              THE I-TH POINT REPRESENTS A FAILURE TIME OR A
C              TRUNCATION TIME.  THE BASIC IDEA IS THAT ORDER
C              STATISTIC MEDIANS ARE GENERATED BASED ON THE FULL
C              SAMPLE, BUT ONLY FAILURE TIMES ARE ACTUALLY PLOTTED
C              ON THE PROBABILITY PLOT.  ALTERNATIVELY, PLOTTING
C              POSITIONS CAN BE BASED ON THE MODIFIED KAPLAN-MIER
C              METHOD.
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF UNIFORM ORDER STATISTIC MEDIANS
C                                TO BE GENERATED.
C                     --TAG    = A SINGLE PRECISION VECTOR WHERE
C                                1 INDICATES A FAILURE TIME AND
C                                0 INDICATES A TRUNCATION TIME
C                     --IMETH  = CHARACTER VARIABLE (EITHER
C                                "UNIM" OR "KAPM") TO SPECIFY
C                                WHICH PLOTTING POSITIONS TO USE
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST N)
C                                INTO WHICH THE GENERATED
C                                UNIFORM ORDER STATISTIC MEDIANS
C                                WILL BE PLACED.
C     OUTPUT--THE N ORDER STATISTIC MEDIANS
C             FROM THE RECTANGULAR DISTRIBUTION ON (0,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--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--FILLIBEN, 'THE PROBABILITY PLOT CORRELATION COEFFICIENT
C                 TEST FOR NORMALITY', TECHNOMETRICS, 1975, PAGES 111-117.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG< MD 20899-8980
C                 PHONE--301-75-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.10
C     ORIGINAL VERSION--OCTOBER   2004.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES----------------
C
C------------------------------------------------------------------
C
      DIMENSION X(*)
      DIMENSION TAG(*)
      CHARACTER*4 IMETH
C
      DOUBLE PRECISION DPROD
      DOUBLE PRECISION DCONST
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DN
      DOUBLE PRECISION DQ
C
C------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT--------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)THEN
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(N.EQ.1)THEN
        WRITE(ICOUT,8)
        CALL DPWRST('XXX','BUG ')
      ENDIF
    5 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO THE ',
     1'UNIME2 SUBROUTINE IS NON-POSITIVE *****')
    8 FORMAT('***** WARNING--THE FIRST INPUT ARGUMENT ',
     1' TO THE UNIME2 SUBROUTINE HAS THE VALUE 1')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
C
      AN=N
C
CCCCC UNIFORM ORDER STATISTIC METHOD
C
      IF(IMETH.EQ.'UNIM')THEN
C
C     COMPUTE THE MEDIANS FOR THE FIRST AND LAST ORDER STATISTICS
C
        X(N)=0.5**(1.0/AN)
        X(1)=1.0-X(N)
C
C     DETERMINE IF AN ODD OR EVEN SAMPLE SIZE
C
        NHALF=(N/2)+1
        NEVODD=2*(N/2)
        IF(N.NE.NEVODD)X(NHALF)=0.5
        IF(N.LE.3)GOTO9000
C
C     COMPUTE THE MEDIANS FOR THE OTHER ORDER STATISTICS
C
        GAM=0.3175
        IMAX=N/2
        DO100I=2,IMAX
          AI=I
          IREV=N-I+1
          X(I)=(AI-GAM)/(AN-2.0*GAM+1.0)
          X(IREV)=1.0-X(I)
  100   CONTINUE
C
CCCCC KAPLAM-MIER METHOD
C
      ELSE
        DPROD=1.0D0
        DN=DBLE(N)
        DCONST=(DN+0.7D0)/(DN+0.4D0)
        DO200I=1,N
          IF(TAG(I).EQ.1.0)THEN
            DQ=DBLE(I)
            DTERM1=(DN - DQ + 0.7D0)/(DN - DQ + 1.7D0)
            DPROD=DPROD*DTERM1
            X(I)=REAL(1.0D0 - DCONST*DPROD)
          ELSE
            X(I)=REAL(DPROD)
          ENDIF
          IF(X(I).GT.1.0)X(I)=1.0
          IF(X(I).LT.0.0)X(I)=0.0
  200   CONTINUE
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE UNIPPC(X,N,IWRITE,Y,W,MAXNYW,PPCC,IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE UNIFORM
C              PROBABILITY PLOT CORRELATION COEFFICIENT.
C              THE PROTOTYPE UNIFORM DISTRIBUTION USED HEREIN
C              IS DEFINED ON THE UNIT INTERVAL (0,1).
C              THIS DISTRIBUTION HAS MEAN = 0.5
C              AND STANDARD DEVIATION = SQRT(1/12) = 0.28867513.
C              THIS DISTRIBUTION HAS
C              THE PROBABILITY DENSITY FUNCTION
C              F(X) = 1.
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 UNIFORM 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 UNIFORM DISTRIBUTION.
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     OUTPUT ARGUMENTS--PPCC   = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED UNIFORM PPCC.
C     OUTPUT--NONE.
C     PRINTING--YES.
C     OTHER DATAPAC   SUBROUTINES NEEDED--SORT, UNIMED.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--SQRT.
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--2, 1970, PAGES 57-74.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--82.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='UNIP'
      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 UNIPPC--')
      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 UNIFORM                           **
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 UNIPPC--')
      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 UNIFORM 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 UNIPPC--',
     1'THE 2ND 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 UNIPPC--',
     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 UNIFORM                        **
C               **  PROBABILITY PLOT CORRELATION COEFFICIENT.  **
C               *************************************************
C
      CALL SORT(X,N,Y)
C
      CALL UNIMED(N,W)
C
      SUM1=0.0
      DO300I=1,N
      SUM1=SUM1+Y(I)
  300 CONTINUE
      YBAR=SUM1/AN
      WBAR=0.5
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)
  811 FORMAT('THE UNIFORM PROBABILITY PLOT 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 UNIPPC--')
      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)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 UNIPPF(P,PPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE UNIFORM (RECTANGUALAR)
C       DISTRIBUTION FROM 0 TO 1
C              THIS DISTRIBUTION IS DEFINED FOR ALL X AND HAS
C              THE PROBABILITY DENSITY FUNCTION
C       F(X)=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 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, INCLUSIVELY.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--82.6
C     ORIGINAL VERSION--JUNE      1972.
C     UPDATED         --SEPTEMBER 1975.
C     UPDATED         --NOVEMBER  1975.
C     UPDATED         --OCTOBER   1976.
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     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(P.LT.0.0.OR.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'UNIPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
C-----START POINT-----------------------------------------------------
C
      PPF=P
      RETURN
      END
      SUBROUTINE UNISF(P,SF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE SPARSITY
C              FUNCTION VALUE FOR THE UNIFORM (RECTANGULAR) 
C              DISTRIBUTION ON THE UNIT INTERVAL (0,1).
C              THIS DISTRIBUTION HAS MEAN = 0.5
C              AND STANDARD DEVIATION = SQRT(1/12) = 0.28867513.
C              THIS DISTRIBUTION HAS THE PROBABILITY
C              DENSITY FUNCTION F(X) = 1.
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 SPARSITY
C                                FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION
C             SPARSITY FUNCTION VALUE SF.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 
C     RESTRICTIONS--P SHOULD BE BETWEEN 0.0 AND 1.0, 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--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 57-74.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 WASHINGTON, D. C. 20234
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.LT.0.0.OR.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 UNISF')
    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
C
      RETURN
      END 
      SUBROUTINE UPDAPR(ICOLPR,ICOLRE,PRED2,RES2,PRED,RES,ISUB,NLEFT,
     1IREPU,REPSD,REPDF,IRESU,RESSD,RESDF,ALFCDF,
     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
     1IANS,IWIDTH,ILOCN,IBUGA3,IERROR)
C
C     PURPOSE--UPDATE PREDICTED VALUES AND RESIDUALS
C              AND ASSOCIATED INTERNAL TABLES.
C              ALSO ADJUST (IF CALLED FOR) THE
C                   REPLICATION STANDARD DEVIATION
C                   REPLICATION DEGREES OF FREEDOM
C                   RESIDUAL STANDARD DEVIATION
C                   RESIDUAL DEGREES OF FREEDOM
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--82.6
C     ORIGINAL VERSION--MARCH     1981.
C     UPDATED         --JULY      1981.
C     UPDATED         --SEPTEMBER 1981.
C     UPDATED         --OCTOBER   1981.
C     UPDATED         --MAY       1982.
C     UPDATED         --MARCH     1988.  ADD LOFCDF
C     UPDATED         --NOVEMBER  1989.  ADD DIMENSION IANS(*) (NELSON)
C     UPDATED         --APRIL     1992.  LOFCDF TO ALFCDF
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IREPU
      CHARACTER*4 IRESU
      CHARACTER*4 IHNAME
      CHARACTER*4 IHNAM2
      CHARACTER*4 IUSE
      CHARACTER*4 IANS
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 IH1
      CHARACTER*4 IH2
      CHARACTER*4 IOP
      CHARACTER*4 MESSAG
      CHARACTER*4 IFOUNN
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 ISTEPN
C
C---------------------------------------------------------------------
C
      DIMENSION PRED2(*)
      DIMENSION RES2(*)
      DIMENSION PRED(*)
      DIMENSION RES(*)
      DIMENSION ISUB(*)
C
      DIMENSION IHNAME(*)
      DIMENSION IHNAM2(*)
      DIMENSION IUSE(*)
      DIMENSION IN(*)
      DIMENSION IVALUE(*)
      DIMENSION VALUE(*)
C
CCCCC THE FOLLOWING LINE WAS INSERTED NOVERMBER 1989
CCCCC (BUG UNCOVERED BY NELSON HSU)
      DIMENSION IANS(*)
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='UPDA'
      ISUBN2='PR  '
C
      IERROR='NO'
C
C               ***************************************
C               **  STEP 1--                         **
C               **  UPDATE INTERNAL DATAPLOT TABLES  **
C               ***************************************
C
      IF(IBUGA3.EQ.'OFF')GOTO90
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF UPDAPR--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)IBUGA3
   52 FORMAT('IBUGA3 = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)ICOLPR,ICOLRE
   53 FORMAT('ICOLPR,ICOLRE = ',I8,I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,54)NLEFT
   54 FORMAT('NLEFT = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,55)IREPU,REPSD,REPDF,IRESU,RESSD,RESDF
   55 FORMAT('IREPU,REPSD,REPDF,IRESU,RESSD,RESDF = ',
     1A4,2E15.7,2X,A4,2E15.7)
      CALL DPWRST('XXX','BUG ')
CCCCC THE FOLLOWING 2 LINES WERE FIXED   APRIL 1992
CCCCC WRITE(ICOUT,56)LOFCDF
CCC56 FORMAT('LOFCDF = ',E15.7)
CCCCC CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,56)ALFCDF
   56 FORMAT('ALFCDF = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      DO60I=1,NLEFT
      WRITE(ICOUT,61)I,ISUB(I),PRED2(I),PRED(I),RES2(I),RES(I)
   61 FORMAT('I,ISUB(I),PRED2(I),PRED(I),RES2(I),RES(I) = ',
     1I8,I8,4E15.7)
      CALL DPWRST('XXX','BUG ')
   60 CONTINUE
   90 CONTINUE
C
      ISTEPN='15'
      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      DO7210J4=1,NUMNAM
      IF(IUSE(J4).EQ.'V'.AND.IVALUE(J4).EQ.ICOLPR)GOTO7215
      GOTO7210
 7215 CONTINUE
      IUSE(J4)='V'
      IVALUE(J4)=ICOLPR
      VALUE(J4)=ICOLPR
      IN(J4)=NLEFT
 7210 CONTINUE
C
      DO7220J4=1,NUMNAM
      IF(IUSE(J4).EQ.'V'.AND.IVALUE(J4).EQ.ICOLRE)GOTO7225
      GOTO7220
 7225 CONTINUE
      IUSE(J4)='V'
      IVALUE(J4)=ICOLRE
      VALUE(J4)=ICOLRE
      IN(J4)=NLEFT
 7220 CONTINUE
C
      J=0
      DO7300I=1,NLEFT
      IF(ISUB(I).EQ.0)GOTO7310
      J=J+1
      PRED(I)=PRED2(J)
      RES(I)=RES2(J)
      GOTO7300
 7310 CONTINUE
 7300 CONTINUE
C
      IF(IREPU.EQ.'OFF')GOTO7490
      IH1='REPS'
      IH2='D   '
      IOP='CHAD'
      MESSAG='NO'
      CALL UPDATP(IH1,IH2,REPSD,IOP,MESSAG,
     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
     1IANS,IWIDTH,IBUGA3,ILOCN,IFOUNN,IERROR)
      IF(IERROR.EQ.'YES')GOTO9000
C
      IH1='REPD'
      IH2='F   '
      IOP='CHAD'
      MESSAG='NO'
      CALL UPDATP(IH1,IH2,REPDF,IOP,MESSAG,
     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
     1IANS,IWIDTH,IBUGA3,ILOCN,IFOUNN,IERROR)
      IF(IERROR.EQ.'YES')GOTO9000
 7490 CONTINUE
C
      IF(IRESU.EQ.'OFF')GOTO7590
      IH1='RESS'
      IH2='D   '
      IOP='CHAD'
      MESSAG='NO'
      CALL UPDATP(IH1,IH2,RESSD,IOP,MESSAG,
     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
     1IANS,IWIDTH,IBUGA3,ILOCN,IFOUNN,IERROR)
      IF(IERROR.EQ.'YES')GOTO9000
C
      IH1='RESD'
      IH2='F   '
      IOP='CHAD'
      MESSAG='NO'
      CALL UPDATP(IH1,IH2,RESDF,IOP,MESSAG,
     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
     1IANS,IWIDTH,IBUGA3,ILOCN,IFOUNN,IERROR)
      IF(IERROR.EQ.'YES')GOTO9000
C
CCCCC THE FOLLOWING SECTION OF CODE WAS ADDED MARCH 1988.
      IH1='LOFC'
      IH2='DF  '
      IOP='CHAD'
      MESSAG='NO'
      CALL UPDATP(IH1,IH2,ALFCDF,IOP,MESSAG,
     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
     1IANS,IWIDTH,IBUGA3,ILOCN,IFOUNN,IERROR)
      IF(IERROR.EQ.'YES')GOTO9000
 7590 CONTINUE
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'OFF')GOTO9090
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF UPDAPR--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IERROR
 9012 FORMAT('IERROR = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)IBUGA3
 9013 FORMAT('IBUGA3 = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9014)NLEFT
 9014 FORMAT('NLEFT = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO9015I=1,NLEFT
      WRITE(ICOUT,9016)I,ISUB(I),PRED2(I),PRED(I),RES2(I),RES(I)
 9016 FORMAT('I,ISUB(I),PRED2(I),PRED(I),RES2(I),RES(I) = ',
     1I8,I8,4E15.7)
      CALL DPWRST('XXX','BUG ')
 9015 CONTINUE
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE UPDATF(IHWORD,IHWOR2,IFUNC3,N3,IOP,MESSAG,
     1IHNAME,IHNAM2,IUSE,IVSTAR,IVSTOP,
     1NUMNAM,MAXNAM,IANS,IWIDTH,ILISTL,NEWNAM,MAXN3,
     1IFUNC,NUMCHF,MAXCHF,IBUGS2,ILOCN,IFOUNN,IERRON)
C
C     PURPOSE--CHECK TO SEE IF THE FUNCTION NAME
C              IN   (IHWORD,IHWOR2)
C              EXISTS IN THE CURRENT TABLE OF AVAILABLE PARAMETER,
C              VARIABLE, AND FUNCTION NAMES AS GIVEN IN IHNAME(.) AND IHNAM2(I).
C              IF FOUND,
C              PLACE THE N3-LENGTH STRING    IFUNC3      INTO THE
C              CORRESPONDING ELEMENT OF THE VECTORS IFUNC(.)
C              IF NOT FOUND AND IF SPECIFIED (VIA IOP),
C              ADD THE NAME TO THE TABLE
C              PLACING THE N3-LENGTH STRING    IFUNC3      INTO THE
C              CORRESPONDING ELEMENT OF THE VECTORS IFUNC(.)
C     OUTPUT ARGUMENTS--ILOCN  = THE LOCATION (THAT IS, THE LINE OR ROW)
C                                IN THE TABLE WHERE THE NAME WAS FOUND
C                                (IF FOUND).
C                     --IFOUNN = A HOLLERITH VARIABLE
C                                WITH THE VALUE 'YES' OR 'NO'
C                                DEPENDING ON WHETHER OR NOT
C                                THE NAME WAS FOUND IN THE EXISTING TABLE.
C                     --IERRON = A HOLLERITH VARIABLE
C                                WITH THE VALUE 'YES' OR 'NO'.
C                                IERRON WILL TAKE ON THE VALUE 'NO'
C                                UNDER ANY OF THE FOLLOWING CONDITIONS--
C                                1) IF THE NAME WAS FOUND IN THE EXISTING TABLE,
C                                2) IF THE NAME WAS NOT FOUND BUT
C                                   ONLY A CHECK WAS CALLED FOR AS
C                                   OPPOSED TO A CHECK & ADD,
C                                3) IF THE NAME WAS NOT FOUND BUT THE
C                                   TABLE WAS NOT FULL AND SO THERE
C                                   WAS ROOM TO ADD THE NAME TO THE TA
C                                IERRON WILL TAKE ON THE VALUE 'YES'
C                                ONLY WHEN THE FOLLOWING 3 CONDITIONS
C                                ALL HOLD SIMULTANEOUSLY--
C                                1) THE NAME WAS NOT FOUND IN THE TABLE;
C                                2) A CHECK & ADD WAS CALLED FOR;
C                                3) THE TABLE WAS ALREADY FULL.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--82.6
C     ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--FEBRUARY   1993.
C     UPDATED       --NOVEMBER    1994. IERROR TO IERRON (BOMB ON VAX)
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IHWORD
      CHARACTER*4 IHWOR2
      CHARACTER*4 IFUNC3
      CHARACTER*4 IFUNC
      CHARACTER*4 IOP
      CHARACTER*4 MESSAG
      CHARACTER*4 IHNAME
      CHARACTER*4 IHNAM2
      CHARACTER*4 IUSE
      CHARACTER*4 IANS
      CHARACTER*4 IBUGS2
      CHARACTER*4 IFOUNN
      CHARACTER*4 IERRON
CCCCC OCTOBER 1993.  ADD FOLLOWING LINE
      CHARACTER*4 NEWNAM
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 ISTEPN
C
C---------------------------------------------------------------------
C
      DIMENSION IFUNC3(*)
      DIMENSION IFUNC(*)
C
      DIMENSION IHNAME(*)
      DIMENSION IHNAM2(*)
      DIMENSION IUSE(*)
      DIMENSION IVSTAR(*)
      DIMENSION IVSTOP(*)
C
      DIMENSION IANS(*)
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='UPDA'
      ISUBN2='TF  '
C
      IFOUNN='NO'
      IERRON='NO'
      ILOCN=0
C
      IF(IBUGS2.EQ.'OFF')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF UPDATF--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)IHWORD,IHWOR2,IOP,MESSAG,IBUGS2
   52 FORMAT('IHWORD,IHWOR2,IOP,MESSAG,IBUGS2 = ',
     1A4,2X,A4,2X,A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)NUMNAM,MAXNAM
   53 FORMAT('NUMNAM,MAXNAM = ',I8,I8)
      CALL DPWRST('XXX','BUG ')
      DO55I=1,NUMNAM
      WRITE(ICOUT,56)I,IHNAME(I),IHNAM2(I),IUSE(I)
   56 FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I) = ',
     1I8,2X,A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
   55 CONTINUE
   90 CONTINUE
C
C               ****************************************
C               **  STEP 1--                          **
C               **  CHECK FOR THE FUNCTION NAME       **
C               **  IN THE CURRENT LIST.              **
C               **  IF FOUND, THEN COPY IN THE STRING  **
C               **  AND EXIT.                         **
C               **  IF NOT FOUND, THEN CONTINUE.      **
C               ****************************************
C
      ISTEPN='1'
      IF(IBUGS2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      DO1110I=1,NUMNAM
      I2=I
      IF(IHWORD.EQ.IHNAME(I).AND.IHWOR2.EQ.IHNAM2(I).AND.
     1IUSE(I).EQ.'F')GOTO1120
 1110 CONTINUE
      GOTO1190
 1120 CONTINUE
      ILOCN=I2
      IFOUNN='YES'
      IERRON='NO'
      NEWNAM='NO'
      ILISTL=ILOCN
      CALL DPINFU(IFUNC3,N3,
     1IHNAME,IHNAM2,IUSE,IVSTAR,IVSTOP,
     1NUMNAM,IANS,IWIDTH,IHWORD,IHWOR2,ILISTL,NEWNAM,MAXN3,
CCCCC1IFUNC,NUMCHF,MAXCHF,IBUGS2,IERROR)
     1IFUNC,NUMCHF,MAXCHF,IBUGS2,IERRON)
      GOTO9000
 1190 CONTINUE
C
C               ******************************************
C               **  STEP 2--                            **
C               **  THE FUNCTION  NAME WAS NOT FOUND.   **
C               **  IF SPECIFIED(VIA    MESSAG),        **
C               **  GENERATE A MESSAGE TO THAT EFFECT.  **
C               ******************************************
C
      ISTEPN='2'
      IF(IBUGS2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(MESSAG.EQ.'NO')GOTO1290
      WRITE(ICOUT,1202)ISUBN1,ISUBN2
 1202 FORMAT('***** ERROR IN ',2A4,'--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1204)
 1204 FORMAT('      A FUNCTION/STRING NAME USED (OR NEEDED)')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1206)
 1206 FORMAT('      IN A COMMAND OR AN EXPRESSION')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1208)
 1208 FORMAT('      WAS NOT FOUND IN THE CURRENT LIST')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1210)
 1210 FORMAT('      OF AVAILABLE FUNCTION/STRING NAMES.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1212)IHWORD,IHWOR2
 1212 FORMAT('      THE FUNCTION/STRING IN QUESTION WAS ',2A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
 1290 CONTINUE
C
C               *************************************
C               **  STEP 3--                       **
C               **  IF ONLY A CHECK                **
C               **  (AS OPPOSED TO A CHECK & ADD)  **
C               **  WAS SPECIFIED (VIA     IOP),   **
C               **  THEN EXIT.                     **
C               *************************************
C
      ISTEPN='3'
      IF(IBUGS2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(IOP.EQ.'CHEC')GOTO1310
      GOTO1390
 1310 CONTINUE
      IFOUNN='NO'
      IERRON='NO'
      GOTO9000
 1390 CONTINUE
C
C               *******************************************************
C               **  STEP 4--                                         **
C               **  IF A CHECK & ADD                                 **
C               **  WAS SPECIFIED (VIA    IOP),                      **
C               **  THEN ATTEMPT TO ADD                              **
C               **  THE PARAMETER NAME TO THE LIST.                  **
C               **  IF THE LIST IS NOT FULL,                         **
C               **  THEN ADD THE NAME, COPY IN THE FUNCTION, AND EXIT.  **
C               **  IF THE LIST IS FULL,                             **
C               **  THEN CONTINUE.                                   **
C               *******************************************************
C
      ISTEPN='4'
      IF(IBUGS2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(NUMNAM.LT.MAXNAM)GOTO1410
      GOTO1490
 1410 CONTINUE
      NUMNAM=NUMNAM+1
      ILOCN=NUMNAM
      IHNAME(ILOCN)=IHWORD
      IHNAM2(ILOCN)=IHWOR2
      IUSE(ILOCN)='F'
      NEWNAM='YES'
      ILISTL=ILOCN
      CALL DPINFU(IFUNC3,N3,
     1IHNAME,IHNAM2,IUSE,IVSTAR,IVSTOP,
     1NUMNAM,IANS,IWIDTH,IHWORD,IHWOR2,ILISTL,NEWNAM,MAXN3,
CCCCC1IFUNC,NUMCHF,MAXCHF,IBUGS2,IERROR)
     1IFUNC,NUMCHF,MAXCHF,IBUGS2,IERRON)
      IFOUNN='NO'
      IERRON='NO'
      GOTO9000
 1490 CONTINUE
C
C               **********************************************************
C               **  STEP 5--                                            **
C               **  THE LIST IS FULL                                    **
C               **  AND THEREFORE THE NAME COULD NOT BE ADDED.          **
C               **  GENERATE AN ERROR MESSAGE TO THAT EFFECT AND EXIT.  **
C               **********************************************************
C
      ISTEPN='5'
      IF(IBUGS2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      WRITE(ICOUT,1502)ISUBN1,ISUBN2
 1502 FORMAT('***** ERROR IN ',2A4,'--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1504)
 1504 FORMAT('      A FUNCTION/STRING NAME USED (OR NEEDED)')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1506)
 1506 FORMAT('      IN A COMMAND OR AN EXPRESSION')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1508)
 1508 FORMAT('      WAS NOT FOUND IN THE CURRENT LIST')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1510)
 1510 FORMAT('      OF AVAILABLE FUNCTION/STRING NAMES.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1511)
 1511 FORMAT('      AND COULD NOT BE ADDED TO THE LIST')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1512)
 1512 FORMAT('      BECAUSE THE LIST IS FULL.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1516)IHWORD,IHWOR2
 1516 FORMAT('      THE FUNCTION/STRING IN QUESTION WAS ',2A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1517)NUMNAM
 1517 FORMAT('      THE CURRENT   NUMBER OF NAMES IN THE LIST = ',
     1I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1518)NUMNAM
 1518 FORMAT('      THE ALLOWABLE NUMBER OF NAMES IN THE LIST = ',
     1I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      IFOUNN='NO'
      IERRON='YES'
      GOTO9000
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      IF(IBUGS2.EQ.'OFF')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF UPDATF--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IFOUNN,IERRON,ILOCN
 9012 FORMAT('IFOUNN,IERRON,ILOCN = ',A4,2X,A4,I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)IHWORD,IHWOR2,IOP,MESSAG
 9013 FORMAT('IHWORD,IHWOR2,IOP,MESSAG = ',
     1A4,2X,A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9014)NUMNAM,MAXNAM
 9014 FORMAT('NUMNAM,MAXNAM = ',I8,I8)
      CALL DPWRST('XXX','BUG ')
      DO9015I=1,NUMNAM
      WRITE(ICOUT,9016)I,IHNAME(I),IHNAM2(I),IUSE(I)
 9016 FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I) = ',
     1I8,2X,A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
 9015 CONTINUE
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE UPDATP(IHWORD,IHWOR2,SCALAR,IOP,MESSAG,
     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
     1IANS,IWIDTH,IBUGA3,ILOCN,IFOUNN,IERRON)
C
C     PURPOSE--CHECK TO SEE IF THE HOLLERITH PARAMETER NAME
C              IN (IHWORD,IHWOR2)
C              EXISTS IN THE CURRENT TABLE OF AVAILABLE PARAMETER,
C              VARIABLE, AND FUNCTION NAMES AS GIVEN IN IHNAME(.) AND IHNAM2(I).
C              IF FOUND, PLACE THE VALUE   SCALAR    INTO THE
C              CORRESPONDING ELEMENT OF THE VECTORS VALUE(.) AND IVALUE(.).
C              IF NOT FOUND AND
C              IF SPECIFIED (VIA IOP), ADD THE NAME TO THE TABLE
C              BEFORE PLACING THE VALUE    SCALAR   INTO THE
C              CORRESPONDING ELEMENTS OF VALUE(.) AND IVALUE(.).
C     OUTPUT ARGUMENTS--ILOCN  = THE LOCATION (THAT IS, THE LINE OR ROW)
C                                IN THE TABLE WHERE THE NAME WAS FOUND
C                                (IF FOUND).
C                     --IFOUNN = A HOLLERITH VARIABLE
C                                WITH THE VALUE 'YES' OR 'NO'
C                                DEPENDING ON WHETHER OR NOT
C                                THE NAME WAS FOUND IN THE EXISTING TABLE.
C                     --IERRON = A HOLLERITH VARIABLE
C                                WITH THE VALUE 'YES' OR 'NO'.
C                                IERRON WILL TAKE ON THE VALUE 'NO'
C                                UNDER ANY OF THE FOLLOWING CONDITIONS--
C                                1) IF THE NAME WAS FOUND IN THE EXISTING TABLE,
C                                2) IF THE NAME WAS NOT FOUND BUT
C                                   ONLY A CHECK WAS CALLED FOR AS
C                                   OPPOSED TO A CHECK & ADD,
C                                3) IF THE NAME WAS NOT FOUND BUT THE
C                                   TABLE WAS NOT FULL AND SO THERE
C                                   WAS ROOM TO ADD THE NAME TO THE TA
C                                IERRON WILL TAKE ON THE VALUE 'YES'
C                                ONLY WHEN THE FOLLOWING 3 CONDITIONS
C                                ALL HOLD SIMULTANEOUSLY--
C                                1) THE NAME WAS NOT FOUND IN THE TABLE;
C                                2) A CHECK & ADD WAS CALLED FOR;
C                                3) THE TABLE WAS ALREADY FULL.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--82.6
C     ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--FEBRUARY   1981.
C     UPDATED         --JULY      1981.
C     UPDATED         --OCTOBER   1981.
C     UPDATED         --MAY       1982.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IHWORD
      CHARACTER*4 IHWOR2
      CHARACTER*4 IOP
      CHARACTER*4 MESSAG
      CHARACTER*4 IHNAME
      CHARACTER*4 IHNAM2
      CHARACTER*4 IUSE
      CHARACTER*4 IANS
      CHARACTER*4 IBUGA3
      CHARACTER*4 IFOUNN
      CHARACTER*4 IERRON
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 ISTEPN
C
C---------------------------------------------------------------------
C
      DIMENSION IHNAME(*)
      DIMENSION IHNAM2(*)
      DIMENSION IUSE(*)
      DIMENSION IN(*)
      DIMENSION IVALUE(*)
      DIMENSION VALUE(*)
C
      DIMENSION IANS(*)
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='UPDA'
      ISUBN2='TP  '
C
      IFOUNN='NO'
      IERRON='NO'
      ILOCN=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 UPDATP--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)IHWORD,IHWOR2,SCALAR,IOP,MESSAG,IBUGA3
   52 FORMAT('IHWORD,IHWOR2,SCALAR,IOP,MESSAG,IBUGA3 = ',
     1A4,2X,A4,E15.7,2X,A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)NUMNAM,MAXNAM
   53 FORMAT('NUMNAM,MAXNAM = ',I8,I8)
      CALL DPWRST('XXX','BUG ')
      DO55I=1,NUMNAM
      WRITE(ICOUT,56)I,IHNAME(I),IHNAM2(I),IUSE(I),IN(I),IVALUE(I),
     1VALUE(I)
   56 FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IN(I),IVALUE(I),',
     1'VALUE(I) = ',I8,2X,A4,2X,A4,2X,A4,I8,I8,E15.7)
      CALL DPWRST('XXX','BUG ')
   55 CONTINUE
   90 CONTINUE
C
C
C               ****************************************
C               **  STEP 1--                          **
C               **  CHECK FOR THE PARAMETER NAME      **
C               **  IN THE CURRENT LIST.              **
C               **  IF FOUND, THEN EQUATE THE SCALAR  **
C               **  AND EXIT.                         **
C               **  IF NOT FOUND, THEN CONTINUE.      **
C               ****************************************
C
      ISTEPN='1'
      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      DO1110I=1,NUMNAM
      I2=I
      IF(IHWORD.EQ.IHNAME(I).AND.IHWOR2.EQ.IHNAM2(I).AND.
     1IUSE(I).EQ.'P')GOTO1120
 1110 CONTINUE
      GOTO1190
 1120 CONTINUE
      ILOCN=I2
      VALUE(I2)=SCALAR
      IVALUE(I2)=SCALAR+0.5
      IFOUNN='YES'
      IERRON='NO'
      GOTO9000
 1190 CONTINUE
C
C               ******************************************
C               **  STEP 2--                            **
C               **  THE PARAMETER NAME WAS NOT FOUND.   **
C               **  IF SPECIFIED(VIA    MESSAG),        **
C               **  GENERATE A MESSAGE TO THAT EFFECT.  **
C               ******************************************
C
      ISTEPN='2'
      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(MESSAG.EQ.'NO')GOTO1290
      WRITE(ICOUT,1202)ISUBN1,ISUBN2
 1202 FORMAT('***** ERROR IN ',2A4,'--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1204)
 1204 FORMAT('      A PARAMETER NAME USED (OR NEEDED)')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1206)
 1206 FORMAT('      IN A COMMAND OR AN EXPRESSION')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1208)
 1208 FORMAT('      WAS NOT FOUND IN THE CURRENT LIST')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1210)
 1210 FORMAT('      OF AVAILABLE PARAMETER NAMES.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1212)IHWORD,IHWOR2
 1212 FORMAT('      THE PARAMETER IN QUESTION WAS ',2A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
 1290 CONTINUE
C
C               *************************************
C               **  STEP 3--                       **
C               **  IF ONLY A CHECK                **
C               **  (AS OPPOSED TO A CHECK & ADD)  **
C               **  WAS SPECIFIED (VIA     IOP),   **
C               **  THEN EXIT.                     **
C               *************************************
C
      ISTEPN='3'
      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(IOP.EQ.'CHEC')GOTO1310
      GOTO1390
 1310 CONTINUE
      IFOUNN='NO'
      IERRON='NO'
      GOTO9000
 1390 CONTINUE
C
C               *******************************************************
C               **  STEP 4--                                         **
C               **  IF A CHECK & ADD                                 **
C               **  WAS SPECIFIED (VIA    IOP),                      **
C               **  THEN ATTEMPT TO ADD                              **
C               **  THE PARAMETER NAME TO THE LIST.                  **
C               **  IF THE LIST IS NOT FULL,                         **
C               **  THEN ADD THE NAME, EQUATE THE SCALAR, AND EXIT.  **
C               **  IF THE LIST IS FULL,                             **
C               **  THEN CONTINUE.                                   **
C               *******************************************************
C
      ISTEPN='4'
      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(NUMNAM.LT.MAXNAM)GOTO1410
      GOTO1490
 1410 CONTINUE
      NUMNAM=NUMNAM+1
      ILOCN=NUMNAM
      IHNAME(ILOCN)=IHWORD
      IHNAM2(ILOCN)=IHWOR2
      IUSE(ILOCN)='P'
      VALUE(ILOCN)=SCALAR
      IVALUE(ILOCN)=SCALAR+0.5
      IFOUNN='NO'
      IERRON='NO'
      GOTO9000
 1490 CONTINUE
C
C               **********************************************************
C               **  STEP 5--                                            **
C               **  THE LIST IS FULL                                    **
C               **  AND THEREFORE THE NAME COULD NOT BE ADDED.          **
C               **  GENERATE AN ERROR MESSAGE TO THAT EFFECT AND EXIT.  **
C               **********************************************************
C
      ISTEPN='5'
      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      WRITE(ICOUT,1502)ISUBN1,ISUBN2
 1502 FORMAT('***** ERROR IN ',2A4,'--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1504)
 1504 FORMAT('      A PARAMETER NAME USED (OR NEEDED)')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1506)
 1506 FORMAT('      IN A COMMAND OR AN EXPRESSION')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1508)
 1508 FORMAT('      WAS NOT FOUND IN THE CURRENT LIST')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1510)
 1510 FORMAT('      OF AVAILABLE PARAMETER NAMES.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1511)
 1511 FORMAT('      AND COULD NOT BE ADDED TO THE LIST')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1512)
 1512 FORMAT('      BECAUSE THE LIST IS FULL.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1516)IHWORD,IHWOR2
 1516 FORMAT('      THE PARAMETER IN QUESTION WAS ',2A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1517)NUMNAM
 1517 FORMAT('      THE CURRENT   NUMBER OF NAMES IN THE LIST = ',
     1I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1518)NUMNAM
 1518 FORMAT('      THE ALLOWABLE NUMBER OF NAMES IN THE LIST = ',
     1I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      IFOUNN='NO'
      IERRON='YES'
      GOTO9000
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 UPDATP--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IFOUNN,IERRON,ILOCN
 9012 FORMAT('IFOUNN,IERRON,ILOCN = ',A4,2X,A4,I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)IHWORD,IHWOR2,SCALAR,IOP,MESSAG
 9013 FORMAT('IHWORD,IHWOR2,SCALAR,IOP,MESSAG = ',
     1A4,2X,A4,E15.7,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9014)NUMNAM,MAXNAM
 9014 FORMAT('NUMNAM,MAXNAM = ',I8,I8)
      CALL DPWRST('XXX','BUG ')
      DO9015I=1,NUMNAM
      WRITE(ICOUT,9016)I,IHNAME(I),IHNAM2(I),IUSE(I),IN(I),IVALUE(I),
     1VALUE(I)
 9016 FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IN(I),IVALUE(I),',
     1'VALUE(I) = ',I8,2X,A4,2X,A4,2X,A4,I8,I8,E15.7)
      CALL DPWRST('XXX','BUG ')
 9015 CONTINUE
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE UPPHIN(X,N,IWRITE,XTEMP,MAXNXT,XUPPHI,IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE
C              SAMPLE UPPER 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--XUPPHI = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED SAMPLE UPPER HINGE.
C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
C             SAMPLE UPPER 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                 WASHINGTON, D. C. 20234
C                 PHONE--301-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--82.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='UPPH'
      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 UPPHIN--')
      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 UPPER 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 UPPHIN--')
      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 UPPER 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 UPPHIN--',
     1'THE 2ND INPUT ARGUMENT (N) HAS THE VALUE 1')
      CALL DPWRST('XXX','BUG ')
      XUPPHI=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 UPPHIN--',
     1'THE FIRST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      XUPPHI=HOLD
      GOTO9000
  139 CONTINUE
C
  190 CONTINUE
C
C               ********************************
C               **  STEP 2--                  **
C               **  COMPUTE THE UPPER HINGE.  **
C               ********************************
C
C
      CALL SORT(X,N,XTEMP)
C
      N2=(N+1)/2
      IARG1=(N2+1)/2
      IARG2=(N2+1)-IARG1
      IARG1R=N-IARG1+1
      IARG2R=N-IARG2+1
      XUPPHI=(XTEMP(IARG1R)+XTEMP(IARG2R))/2.0
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,XUPPHI
  811 FORMAT('THE UPPER 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 UPPHIN--')
      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)XUPPHI
 9015 FORMAT('XUPPHI = ',E15.7)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE UPPQUA(X,N,IWRITE,XTEMP,MAXNXT,XUPPQU,IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE
C              SAMPLE UPPER 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--XUPPQU = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED SAMPLE UPPER QUARTILE.
C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
C             SAMPLE UPPER 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                 WASHINGTON, D. C. 20234
C                 PHONE--301-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--82.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='UPPQ'
      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 UPPQUA--')
      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 UPPER 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 UPPQUA--')
      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 UPPER 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 UPPQUA--',
     1'THE 2ND INPUT ARGUMENT (N) HAS THE VALUE 1')
      CALL DPWRST('XXX','BUG ')
      XUPPQU=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 UPPQUA--',
     1'THE FIRST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      XUPPQU=HOLD
      GOTO9000
  139 CONTINUE
C
  190 CONTINUE
C
C               ***********************************
C               **  STEP 2--                     **
C               **  COMPUTE THE UPPER QUARTILE.  **
C               ***********************************
C
      CALL SORT(X,N,XTEMP)
C
      P=0.75
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
      XUPPQU=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,XUPPQU
  811 FORMAT('THE UPPER 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 UPPQUA--')
      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)XUPPQU
 9015 FORMAT('XUPPQU = ',E15.7)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE VAR(X,N,IWRITE,XVAR,IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE
C              SAMPLE VARIANCE (WITH DENOMINATOR N-1)
C              OF THE DATA IN THE INPUT VECTOR X.
C              THE SAMPLE VARIANCE = (THE SUM OF THE
C              SQUARED DEVIATIONS ABOUT THE SAMPLE MEAN)/(N-1).
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--XVAR   = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED SAMPLE VARIANCE.
C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
C             SAMPLE VARIANCE (WITH DENOMINATOR N-1).
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     REFERENCES--SNEDECOR AND COCHRAN, STATISTICAL METHODS,
C                 EDITION 6, 1967, PAGE 44.
C               --DIXON AND MASSEY, INTRODUCTION TO STATISTICAL
C                 ANALYSIS, EDITION 2, 1957, PAGE 38.
C               --MOOD AND GRABLE, 'INTRODUCTION TO THE THEORY
C                 OF STATISTICS, EDITION 2, 1963, PAGE 171.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--82.6
C     ORIGINAL VERSION--JUNE      1972.
C     UPDATED         --SEPTEMBER 1975.
C     UPDATED         --NOVEMBER  1975.
C     UPDATED         --JUNE      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 DN
      DOUBLE PRECISION DX
      DOUBLE PRECISION DSUM
      DOUBLE PRECISION DMEAN
      DOUBLE PRECISION DVAR
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='VAR '
      ISUBN2='    '
C
      IERROR='NO'
      DMEAN=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 VAR--')
      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 VARIANCE  **
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 VAR--')
      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 VARIANCE 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
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,121)
  121 FORMAT('***** NON-FATAL DIAGNOSTIC IN VAR--',
     1'THE 2ND INPUT ARGUMENT (N) HAS THE VALUE 1')
      CALL DPWRST('XXX','BUG ')
      XVAR=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 VAR--',
     1'THE FIRST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      XVAR=0.0
      GOTO9000
  139 CONTINUE
C
  190 CONTINUE
C
C               *****************************
C               **  STEP 2--               **
C               **  COMPUTE THE VARIANCE.  **
C               *****************************
C
      DN=N
      DSUM=0.0D0
      DO200I=1,N
      DX=X(I)
      DSUM=DSUM+DX
  200 CONTINUE
      DMEAN=DSUM/DN
C
      DSUM=0.0D0
      DO300I=1,N
      DX=X(I)
      DSUM=DSUM+(DX-DMEAN)**2
  300 CONTINUE
      DVAR=DSUM/(DN-1.0D0)
      XVAR=DVAR
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,XVAR
  811 FORMAT('THE VARIANCE 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 VAR--')
      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)DMEAN
 9014 FORMAT('DMEAN = ',D15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9015)XVAR
 9015 FORMAT('XVAR = ',E15.7)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE VARCOV(AMAT1,AMAT2,MAXROM,MAXCOM,NR1,NC1,DMEAN,
     1ICASE,IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE
C              VARIANCE-COVARIANCE MATRIX OF A MATRIX.  NOTE
C              THAT IT CAN BE COMPUTED FOR COVARIANCE BETWEEN
C              COLUMNS (I.E., VARIABLES, NORMAL CASE) OR BETWEEN
C              ROWS (I.E., DATA POINTS=COVARIANCE MATRIX OF THE
C              TRANSPOSE).
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 VARIANCE-COVARIANCE MATRIX.
C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
C             VARIANCE-COVARIANCE 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                 WASHINGTON, D. C. 20234
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 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DYM1
      DOUBLE PRECISION DYM2
      DOUBLE PRECISION DDEL1
      DOUBLE PRECISION DDEL2
      DOUBLE PRECISION DDENOM
      DOUBLE PRECISION DCOV
      DOUBLE PRECISION D999
C
      DIMENSION AMAT1(MAXROM,MAXCOM)
      DIMENSION AMAT2(MAXROM,MAXCOM)
      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='VARC'
      ISUBN2='OV  '
C
      IERROR='NO'
      D999=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 VARCOV--')
      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 ')
   90 CONTINUE
C
C               ******************************
C               **  COMPUTE QUADRATIC FORM  **
C               ******************************
C
      DNR1=DBLE(NR1)
      DNC1=DBLE(NC1)
C
      IF(ICASE.EQ.'COLU')THEN
      DO5111J=1,NC1
      DSUM1=0.0D0
      DO5112I=1,NR1
      DYM1=AMAT1(I,J)
      DSUM1=DSUM1+DYM1
 5112 CONTINUE
      DMEAN(J)=D999
      DDENOM=DNR1
      IF(DDENOM.NE.0.0D0)DMEAN(J)=DSUM1/DDENOM
 5111 CONTINUE
C
      DO5121J=1,NC1
      DO5122K=J,NC1
      DSUM1=0.0D0
      DO5123I=1,NR1
      DYM1=AMAT1(I,J)
      DYM2=AMAT1(I,K)
      DDEL1=DYM1-DMEAN(J)
      DDEL2=DYM2-DMEAN(K)
      DSUM1=DSUM1+DDEL1*DDEL2
 5123 CONTINUE
      DCOV=D999
      DDENOM=DNR1-1.0D0
      IF(DDENOM.NE.0.0D0)DCOV=DSUM1/DDENOM
      AMAT2(J,K)=DCOV
      AMAT2(K,J)=DCOV
 5122 CONTINUE
 5121 CONTINUE
C
      ELSE
      DO6111J=1,NR1
      DSUM1=0.0D0
      DO6112I=1,NC1
      DYM1=AMAT1(J,I)
      DSUM1=DSUM1+DYM1
 6112 CONTINUE
      DMEAN(J)=D999
      DDENOM=DNC1
      IF(DDENOM.NE.0.0D0)DMEAN(J)=DSUM1/DDENOM
 6111 CONTINUE
C
      DO6121J=1,NR1
      DO6122K=J,NR1
      DSUM1=0.0D0
      DO6123I=1,NC1
      DYM1=AMAT1(J,I)
      DYM2=AMAT1(K,I)
      DDEL1=DYM1-DMEAN(J)
      DDEL2=DYM2-DMEAN(K)
      DSUM1=DSUM1+DDEL1*DDEL2
 6123 CONTINUE
      DCOV=D999
      DDENOM=DNR1-1.0D0
      IF(DDENOM.NE.0.0D0)DCOV=DSUM1/DDENOM
      AMAT2(J,K)=DCOV
      AMAT2(K,J)=DCOV
 6122 CONTINUE
 6121 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 VARCOV--')
      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 VARPOO(AMAT1,AMAT2,AMAT3,MAXROM,MAXCOM,NR1,NC1,NR2,
     1DMEAN,IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE
C              POOLED VARIANCE-COVARIANCE MATRIX OF TWO MATRICES.
C                     Cpooled = [(n1-1)*C1 + (n2-1)*C2]/(n1+n2-2)
C              WHERE C1 AND C2 ARE THE VARIANCE-COVARIANCE MATRICES
C              FOR SAMPLE 1 AND 2 RESPECTIVELY.
C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
C             POOLED VARIANCE-COVARIANCE 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                 WASHINGTON, D. C. 20234
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 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DYM1
      DOUBLE PRECISION DYM2
      DOUBLE PRECISION DDEL1
      DOUBLE PRECISION DDEL2
      DOUBLE PRECISION DDENOM
      DOUBLE PRECISION DCOV
      DOUBLE PRECISION D999
C
      DIMENSION AMAT1(MAXROM,MAXCOM)
      DIMENSION AMAT2(MAXROM,MAXCOM)
      DIMENSION AMAT3(MAXROM,MAXCOM)
      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='VARP'
      ISUBN2='OO  '
C
      IERROR='NO'
      D999=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 VARPOO--')
      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 POOLED VARIANCE-COVARIANCE MATRIX  **
C               *************************************************
C
      DNR1=DBLE(NR1)
      DNR2=DBLE(NR2)
      DNC1=DBLE(NC1)
C
      DO5111J=1,NC1
      DSUM1=0.0D0
      DO5112I=1,NR1
      DYM1=AMAT1(I,J)
      DSUM1=DSUM1+DYM1
 5112 CONTINUE
      DMEAN(J)=D999
      DDENOM=DNR1
      IF(DDENOM.NE.0.0D0)DMEAN(J)=DSUM1/DDENOM
 5111 CONTINUE
C
      DO5121J=1,NC1
      DO5122K=J,NC1
      DSUM1=0.0D0
      DO5123I=1,NR1
      DYM1=AMAT1(I,J)
      DYM2=AMAT1(I,K)
      DDEL1=DYM1-DMEAN(J)
      DDEL2=DYM2-DMEAN(K)
      DSUM1=DSUM1+DDEL1*DDEL2
 5123 CONTINUE
      DCOV=D999
      DDENOM=DNR1-1.0D0
      IF(DDENOM.NE.0.0D0)DCOV=DSUM1/DDENOM
      AMAT3(J,K)=(DNR1-1.0D0)*DCOV
      AMAT3(K,J)=(DNR1-1.0D0)*DCOV
 5122 CONTINUE
 5121 CONTINUE
C
      DO6111J=1,NC1
      DSUM1=0.0D0
      DO6112I=1,NR2
      DYM1=AMAT2(I,J)
      DSUM1=DSUM1+DYM1
 6112 CONTINUE
      DMEAN(J)=D999
      DDENOM=DNR2
      IF(DDENOM.NE.0.0D0)DMEAN(J)=DSUM1/DDENOM
 6111 CONTINUE
C
      DO6121J=1,NC1
      DO6122K=J,NC1
      DSUM1=0.0D0
      DO6123I=1,NR2
      DYM1=AMAT2(I,J)
      DYM2=AMAT2(I,K)
      DDEL1=DYM1-DMEAN(J)
      DDEL2=DYM2-DMEAN(K)
      DSUM1=DSUM1+DDEL1*DDEL2
 6123 CONTINUE
      DCOV=D999
      DDENOM=DNR2-1.0D0
      IF(DDENOM.NE.0.0D0)DCOV=DSUM1/DDENOM
      AMAT3(J,K)=(AMAT3(J,K) + (DNR2-1.0D0)*DCOV)/REAL(NR1+NR2-2)
      AMAT3(K,J)=(AMAT3(K,J) + (DNR2-1.0D0)*DCOV)/REAL(NR1+NR2-2)
 6122 CONTINUE
 6121 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 VARPOO--')
      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 VARPO2(AMAT1,AMAT2,AMAT3,MAXROM,MAXCOM,NR1,NC1,NR3,
     1TAG,TAGDIS,NIJUNK,NK,DMEAN,IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE
C              POOLED VARIANCE-COVARIANCE MATRIX OF MORE THAN 2
C              MATRICES.
C                     Cpooled = [(n1-1)*C1 + (n2-1)*C2 + ... +(nk-1)*CK]/(n1+n2+ ... +nk-k)
C              WHERE C1, C2, ..., CK ARE THE VARIANCE-COVARIANCE MATRICES
C              FOR SAMPLE 1, 2, ... , K RESPECTIVELY.
C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
C             POOLED VARIANCE-COVARIANCE 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     NOTE--THE TAG VARIABLE IS A GROUP IDENTIFIER THAT DEFINES
C           WHAT MATRIX A GIVEN ROW BELONGS TO.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     LANGUAGE--ANSI FORTRAN (1977)
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 WASHINGTON, D. C. 20234
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 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 IWRITE
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DYM1
      DOUBLE PRECISION DYM2
      DOUBLE PRECISION DDEL1
      DOUBLE PRECISION DDEL2
      DOUBLE PRECISION DDENOM
      DOUBLE PRECISION DCOV
C
      DIMENSION AMAT1(MAXROM,MAXCOM)
      DIMENSION AMAT2(MAXROM,MAXCOM)
      DIMENSION AMAT3(NR3,MAXCOM)
      DIMENSION TAG(*)
      DIMENSION TAGDIS(*)
      DIMENSION NIJUNK(*)
      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='VARP'
      ISUBN2='O2  '
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 VARPO2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)IBUGA3
   52 FORMAT('IBUGA3 = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)NR1,NC1
   53 FORMAT('NR1, NC1 = ',3I8)
      CALL DPWRST('XXX','BUG ')
      DO55I=1,MIN(20,NR1)
      WRITE(ICOUT,56)I,TAG(I),AMAT1(I,1),AMAT1(I,2)
   56 FORMAT('I,TAG(I),Z(I,1),Z(I,2)=',I8,3E15.7)
   55 CONTINUE
   90 CONTINUE
C
C               *************************************************
C               **  COMPUTE NUMBER OF DISTINCT ELEMENTS OF TAG **
C               *************************************************
C
      IWRITE='OFF'
      CALL DISTIN(TAG,NR1,IWRITE,TAGDIS,NK,IBUGA3,IERROR)
C
C               *************************************************
C               **  COMPUTE POOLED VARIANCE-COVARIANCE MATRIX  **
C               *************************************************
C
      DO95J=1,NC1
        DO98I=1,NC1
          AMAT3(I,J)=0.0
   98   CONTINUE
   95 CONTINUE
      NSUM=0
C
      DO100IGROUP=1,NK
C
        ATEMP=TAGDIS(IGROUP)
        ICOUNT=0
        DO200J=1,NR1
          IF(TAG(J).EQ.ATEMP)THEN
            ICOUNT=ICOUNT+1
            DO210L=1,NC1
              AMAT2(ICOUNT,L)=AMAT1(J,L)
  210       CONTINUE
          ENDIF
  200   CONTINUE
        IF(ICOUNT.LT.1)GOTO100
        NI=ICOUNT
        NIJUNK(IGROUP)=NI
        NSUM=NSUM + (NI - 1)
C
        DNR1=DBLE(NI)
        DNC1=DBLE(NC1)
C
        DO5111J=1,NC1
          DSUM1=0.0D0
          DO5112I=1,NI
            DYM1=AMAT2(I,J)
            DSUM1=DSUM1+DYM1
 5112     CONTINUE
          DMEAN(J)=0.0D0
          DDENOM=DNR1
          IF(DDENOM.NE.0.0D0)DMEAN(J)=DSUM1/DDENOM
 5111   CONTINUE
C
        DO5121J=1,NC1
        DO5122K=J,NC1
        DSUM1=0.0D0
        DO5123I=1,NI
        DYM1=AMAT2(I,J)
        DYM2=AMAT2(I,K)
        DDEL1=DYM1-DMEAN(J)
        DDEL2=DYM2-DMEAN(K)
        DSUM1=DSUM1+DDEL1*DDEL2
 5123   CONTINUE
        DCOV=0.0D0
        DDENOM=DNR1-1.0D0
        IF(DDENOM.NE.0.0D0)DCOV=DSUM1/DDENOM
        AMAT3(J,K)=AMAT3(J,K) + REAL((DNR1-1.0D0)*DCOV)
        AMAT3(K,J)=AMAT3(J,K)
 5122   CONTINUE
 5121   CONTINUE
C
  100 CONTINUE
C
      ACONST=1.0/REAL(NSUM)
      DO6100J=1,NC1
        DO6200I=1,NC1
          AMAT3(I,J)=ACONST*AMAT3(I,J)
 6200   CONTINUE
 6100 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 VARPO2--')
      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 VECARI(Y1,Y2,N1,IACASE,IWRITE,
     1Y3,N3,SCAL3,ITYP3,IBUGA3,ISUBRO,IERROR)
C
C     PURPOSE--CARRY OUT VECTOR     ARITHMETIC OPERATIONS
C              OF THE REAL DATA IN Y1 AND Y2.
C
C     OPERATIONS--ADDITION
C                 SUBTRACTION
C                 DOT PRODUCT
C                 CROSS PRODUCT
C                 LENGTH
C                 DISTANCE
C                 ANGLE
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 VECTOR Y3(.)
C           BEING IDENTICAL TO THE INPUT VECTOR Y1(.) OR Y2(.).
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--87/9
C     ORIGINAL VERSION--AUGUST   1987.
C     UPDATED         --SEPTEMBER  1993.  ACTIVATE CROSS PRODUCT (ALAN)
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IACASE
      CHARACTER*4 IWRITE
      CHARACTER*4 ITYP3
      CHARACTER*4 IBUGA3
      CHARACTER*4 ISUBRO
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C-----DOUBLE PRECISION STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DOUBLE PRECISION DY1
      DOUBLE PRECISION DY2
      DOUBLE PRECISION DY3
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DSUM2
      DOUBLE PRECISION DSUM12
      DOUBLE PRECISION DDEL
      DOUBLE PRECISION DARG1
      DOUBLE PRECISION DARG2
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='VECA'
      ISUBN2='RI  '
C
      IERROR='NO'
C
      SCAL3=(-999.0)
      ITYP3='VECT'
C
      IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'CARI')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF VECARI--')
      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 VECTOR     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 VECARI--')
      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.'VEAD')WRITE(ICOUT,1161)
 1161 FORMAT('      THE VECTOR     ADDITION IS TO BE ',
     1'COMPUTED')
      IF(IACASE.EQ.'VEAD')CALL DPWRST('XXX','BUG ')
      IF(IACASE.EQ.'VESU')WRITE(ICOUT,1162)
 1162 FORMAT('      THE VECTOR     SUBTRACTION IS TO BE ',
     1'COMPUTED')
      IF(IACASE.EQ.'VESU')CALL DPWRST('XXX','BUG ')
      IF(IACASE.EQ.'VEDP')WRITE(ICOUT,1163)
 1163 FORMAT('      THE VECTOR     DOT PRODUCT IS TO BE ',
     1'COMPUTED')
      IF(IACASE.EQ.'VEDP')CALL DPWRST('XXX','BUG ')
      IF(IACASE.EQ.'VECP')WRITE(ICOUT,1164)
 1164 FORMAT('      THE VECTOR     CROSS PRODUCT IS TO BE ',
     1'COMPUTED')
      IF(IACASE.EQ.'VECP')CALL DPWRST('XXX','BUG ')
      IF(IACASE.EQ.'VELE')WRITE(ICOUT,1165)
 1165 FORMAT('      THE VECTOR     LENGTH IS TO BE ',
     1'COMPUTED')
      IF(IACASE.EQ.'VELE')CALL DPWRST('XXX','BUG ')
      IF(IACASE.EQ.'VEDI')WRITE(ICOUT,1166)
 1166 FORMAT('      THE VECTOR     DISTANCE IS TO BE ',
     1'COMPUTED')
      IF(IACASE.EQ.'VEDI')CALL DPWRST('XXX','BUG ')
      IF(IACASE.EQ.'VEAN')WRITE(ICOUT,1167)
 1167 FORMAT('      THE VECTOR     ANGLE IS TO BE ',
     1'COMPUTED')
      IF(IACASE.EQ.'VEAN')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.'VEAD')GOTO2100
      IF(IACASE.EQ.'VESU')GOTO2200
      IF(IACASE.EQ.'VEDP')GOTO2300
      IF(IACASE.EQ.'VECP')GOTO2400
      IF(IACASE.EQ.'VELE')GOTO2500
      IF(IACASE.EQ.'VEDI')GOTO2600
      IF(IACASE.EQ.'VEAN')GOTO2700
C
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1211)
 1211 FORMAT('***** INTERNAL ERROR IN VECARI--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1212)
 1212 FORMAT('      IACASE NOT EQUAL TO')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1213)
 1213 FORMAT('      VEAD, VESU, VEDP, VECP, ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1214)
 1214 FORMAT('      VELE, VEDI, OR VEAN')
      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 VECTOR     ADDITION    CASE  **
C               *********************************************
C
 2100 CONTINUE
      DO2110I=1,N1
      DY1=Y1(I)
      DY2=Y2(I)
      DY3=DY1+DY2
      Y3(I)=DY3
 2110 CONTINUE
C
      ITYP3='VECT'
      N3=N1
      GOTO9000
C
C               *********************************************
C               **  STEP 22--                              **
C               **  TREAT THE VECTOR     SUBTRACTION CASE  **
C               *********************************************
C
 2200 CONTINUE
      DO2210I=1,N1
      DY1=Y1(I)
      DY2=Y2(I)
      DY3=DY1-DY2
      Y3(I)=DY3
 2210 CONTINUE
C
      ITYP3='VECT'
      N3=N1
      GOTO9000
C
C               ************************************************
C               **  STEP 23--                                 **
C               **  TREAT THE VECTOR     DOT PRODUCT    CASE  **
C               ************************************************
C
 2300 CONTINUE
      DSUM12=0.0D0
      DO2310I=1,N1
      DY1=Y1(I)
      DY2=Y2(I)
      DSUM12=DSUM12+DY1*DY2
 2310 CONTINUE
      SCAL3=DSUM12
C
      ITYP3='SCAL'
      GOTO9000
C
C               ************************************************
C               **  STEP 24--                                 **
C               **  TREAT THE VECTOR     CROSS PRODUCT  CASE  **
C               ************************************************
C
CCCCC SEPTEMBER 1993.  IMPLEMENT THIS SECTION.  NOTE THAT THE
CCCCC CROSS PRODUCT IS ONLY DEFINED FOR VECTORS OF LENGTH 3.
 2400 CONTINUE
C
C     NOT YET DONE
C
C
      IF(N1.NE.3)THEN
        IERROR='YES'
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,2411)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,2412)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,2413)N1
        CALL DPWRST('XXX','BUG ')
 2411 FORMAT('******* ERROR IN VECARI. *******')
 2412 FORMAT('        THE NUMBER OF ELEMENTS FOR THE CROSS PRODUCT')
 2413 FORMAT('        MUST BE EXACTLY 3 (IT WAS ',I8,').')
      ELSE
        DARG1=Y1(2)
        DARG2=Y2(3)
        DY1=Y1(3)
        DY2=Y2(2)
        DY3=DARG1*DARG2-DY1*DY2
        Y3(1)=DY3
        DARG1=Y1(3)
        DARG2=Y2(1)
        DY1=Y1(1)
        DY2=Y2(3)
        DY3=DARG1*DARG2-DY1*DY2
        Y3(2)=DY3
        DARG1=Y1(1)
        DARG2=Y2(2)
        DY1=Y1(2)
        DY2=Y2(1)
        DY3=DARG1*DARG2-DY1*DY2
        Y3(3)=DY3
      ENDIF
C
      ITYP3='VECT'
      N3=N1
      GOTO9000
C
C               ***************************************************
C               **  STEP 25--                                    **
C               **  TREAT THE VECTOR     LENGTH            CASE  **
C               ***************************************************
C
 2500 CONTINUE
      DSUM1=0.0D0
      DO2510I=1,N1
      DY1=Y1(I)
      DSUM1=DSUM1+DY1*DY1
 2510 CONTINUE
      SCAL3=0.0
      IF(DSUM1.GT.0.0D0)SCAL3=DSQRT(DSUM1)
C
      ITYP3='SCAL'
      GOTO9000
C
C               ************************************************
C               **  STEP 26--                                 **
C               **  TREAT THE VECTOR     DISTANCE       CASE  **
C               ************************************************
C
 2600 CONTINUE
      DSUM12=0.0D0
      DO2610I=1,N1
      DY1=Y1(I)
      DY2=Y2(I)
      DDEL=DY1-DY2
      DSUM12=DSUM12+DDEL*DDEL
 2610 CONTINUE
      SCAL3=0.0
      IF(DSUM12.GT.0.0D0)SCAL3=DSQRT(DSUM12)
C
      ITYP3='SCAL'
      GOTO9000
C
C               ********************************************************
C               **  STEP 27--                                         **
C               **  TREAT THE VECTOR     ANGLE         CASE           **
C               **  THIS ANGLE MUST BE BETWEEN 0 AND 180              **
C               **  AND THIS ANGLE HAS THE PROPERTY THAT              **
C               **  ITS COSINE = INNER PRODUCT / (LENGTH1 * LENGTH2)  **
C               ********************************************************
C
 2700 CONTINUE
      DSUM1=0.0D0
      DSUM2=0.0D0
      DSUM12=0.0D0
      DO2710I=1,N1
      DY1=Y1(I)
      DY2=Y2(I)
      DSUM1=DSUM1+DY1*DY1
      DSUM2=DSUM2+DY2*DY2
      DSUM12=DSUM12+DY1*DY2
 2710 CONTINUE
      DARG1=DSUM1*DSUM2-DSUM12*DSUM12
      IF(DARG1.LE.0.0)DARG1=0.0D0
      IF(DARG1.GT.0.0)DARG1=DSQRT(DARG1)
      DARG2=DSUM12
      SCAL3=DATAN2(DARG1,DARG2)
C
      ITYP3='SCAL'
      GOTO9000
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
C
      IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'CARI')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF VECARI--')
      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 VONCDF(X,B,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE VON MISES DISTRIBUTION
C              WITH SCALE PARAMETER B AND LOCATION PARAMETER A.
C              THIS DISTRIBUTION IS DEFINED FOR ALL  X BETWEEN 0 AND
C              2*PI.  A MUST ALSO BE IN THE RANGE 0 TO 2*PI AND B
C              MUST BE POSITIVE.  WE CALCULATE FOR THE CASE A = 0
C              (VONCDF(X,B)+A FOR A <> 0 CASE).
C              IT HAS THE PROBABILITY DENSITY FUNCTION
C              F(X) = EXP[B*COS(X-1)]/[2*PI*I0(B)]
C              WHERE I0 IS THE MODIFIED BESSEL FUNCTION OR ORDER 0.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                       B      = POSITIVE SCALE PARAMETER
C                       A      = LOCATION PARAMETER
C     OUTPUT ARGUMENTS--CDF    = THE SINGLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE PDF.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 
C     RESTRICTIONS--  -PI <= X <= PI
C                     B >= 0
C     OTHER DATAPAC   SUBROUTINES NEEDED--DBESI0.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--DEXP.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN. 
C     REFERENCES--"STATISTICAL DISTRIBUTIONS", EVANS, HASTINGS, PEACOCK
C                 "ALGORITHM 518 INCOMPLETE BESSEL FUNCTION I0: THE
C                 VON MISES DISTRIBUTION", GEOFFREY HILL, TRANSACTIONS
C                 OF THE ACM, MATHEMATICAL SOFTWARE.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 WASHINGTON, D. C. 20234
C                 PHONE:  301-975-2855
C     ORIGINAL VERSION--OCTOBER   1994. 
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
      DATA PI / 3.1415926535898 /
      DATA TPI / 6.2831853071760 /
      DATA A1 /28.0 /
      DATA A2 /0.5  /
      DATA A3 /100.0/
      DATA A4 /5.0  /
      DATA CK /50.0 /
      DATA C1 /50.1 /
C
C---------------------------------------------------------------------
C
C     STEP 1--CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(B.LT.0.0)THEN
        WRITE(ICOUT,24)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)B
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        RETURN
      ENDIF
   24 FORMAT('***** FATAL DIAGNOSTIC--THE SECOND INPUT ARGUMENT TO ',
     *'THE VONCDF ROUTINE IS NEGATIVE. ****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.7)
C
C-----START POINT-----------------------------------------------------
C
      Z=B
C
C     STEP 2--CONVERT ANGLE X MODULO 2*PI TO (-PI,+PI) INTERVAL
C
      U=AMOD(X+PI,TPI)
      IF(U.LT.0.0)U=U+TPI
      Y=U-PI
      IF(Z.GT.CK)GOTO300
      V=0.0
      IF(Z.LE.0.0)GOTO200
C
C  STEP 3--FOR SMALL B, SUM IP TERMS BY BACKWARDS RECURSION
C
      IP=Z*A2-A3/(Z+A4)+A1
      P=REAL(IP)
      S=SIN(Y)
      C=COS(Y)
      Y=P*Y
      SN=SIN(Y)
      CN=COS(Y)
      R=0.0
      Z=2.0/Z
      DO100N=2,IP
        P=P-1.0
        Y=SN
        SN=SN*C - CN*S
        CN=CN*C + Y*S
        R=1.0/(P*Z+R)
        V=(SN/P+V)*R
 100  CONTINUE
 200  CONTINUE
      CDF=(U*0.5+V)/PI
      GOTO400
C
C  STEP 4--FOR LARGE B, USE A NORMAL APPROXIMATION
C
  300 CONTINUE
      C=24.0*Z
      V=C-C1
      R=SQRT((54.0/(347.0/V+26.0-C)-6.0+C)/6.0)
      Z=SIN(Y*0.5)*R
      S=Z*Z
      V=V-S+3.0
      Y=(C-S-S-16.0)/3.0
      Y=((S+1.75)*S+83.5)/V - Y
      ARG1=Z-S/(Y*Y)*Z
      CALL NORCDF(ARG1,CDFN)
      CDF=CDFN
      GOTO400
C
C STEP 5--
C
  400 CONTINUE
      IF(CDF.LT.0.0)CDF=0.0
      IF(CDF.GT.1.0)CDF=1.0
C
      RETURN
      END 
      SUBROUTINE VONPDF(X,B,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE VON MISES DISTRIBUTION
C              WITH SCALE PARAMETER B AND LOCATION PARAMETER A.
C              THIS DISTRIBUTION IS DEFINED FOR ALL  X BETWEEN 0 AND
C              2*PI.  A MUST ALSO BE IN THE RANGE 0 TO 2*PI AND B
C              MUST BE POSITIVE.  WE CALCULATE FOR THE CASE A = 0
C              (VONPDF(X,B)+A FOR A <> 0 CASE).
C              IT HAS THE PROBABILITY DENSITY FUNCTION
C              F(X) = EXP[B*COS(X-1)]/[2*PI*I0(B)]
C              WHERE I0 IS THE MODIFIED BESSEL FUNCTION OR ORDER 0.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                       B      = POSITIVE SCALE PARAMETER
C                       A      = LOCATION PARAMETER
C     OUTPUT ARGUMENTS--PDF    = THE SINGLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE PDF.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 
C     RESTRICTIONS--  -PI <= X <= PI
C                     B >= 0
C     OTHER DATAPAC   SUBROUTINES NEEDED--DBESI0.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--DEXP.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN. 
C     REFERENCES--"STATISTICAL DISTRIBUTIONS", EVANS, HASTINGS, PEACOCK
C                 "ALGORITHM 518 INCOMPLETE BESSEL FUNCTION I0: THE
C                 VON MISES DISTRIBUTION", GEOFFREY HILL, TRANSACTIONS
C                 OF THE ACM, MATHEMATICAL SOFTWARE.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 WASHINGTON, D. C. 20234
C                 PHONE:  301-975-2855
C     ORIGINAL VERSION--OCTOBER   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
      DOUBLE PRECISION DTERM1, DTERM2, DTERM3, DTERM4
      DOUBLE PRECISION DX, DB
      DOUBLE PRECISION DBESI0
      DATA PI / 3.1415926535898 /
      DATA TPI / 6.2831853071760 /
CCCCC DATA A1 /28.0 /
CCCCC DATA A2 /0.5  /
CCCCC DATA A3 /100.0/
CCCCC DATA A4 /5.0  /
      DATA CK /500.0 /
      DATA C1 /50.1 /
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(B.LT.0.0)THEN
        WRITE(ICOUT,24)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)B
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        RETURN
      ENDIF
      IF(B.EQ.0.0)THEN
        PDF=1./(2*PI)
        RETURN
      ENDIF
   24 FORMAT('***** FATAL DIAGNOSTIC--THE SECOND INPUT ARGUMENT TO ',
     *'THE VONPDF ROUTINE IS NEGATIVE. ****')
CCCCC IF(X.LT.-PI.OR.X.GT.PI)THEN
CCCCC   WRITE(ICOUT,4)
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   WRITE(ICOUT,5)
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   WRITE(ICOUT,46)X
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   PDF=0.0
CCCCC   RETURN
CCCCC ENDIF
CCCC4 FORMAT('***** FATAL DIAGNOSTIC--THE FIRST  INPUT ARGUMENT TO ')
CCCC5 FORMAT('      THE VONPDF SUBROUTINE IS OUTSIDE THE INTERVAL ',
CCCCC*       '(-PI,PI). *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.7)
C
C-----START POINT-----------------------------------------------------
C
C     STEP 1--CONVERT ANGLE X MODULO 2*PI TO (-PI,+PI) INTERVAL
C
      U=AMOD(X+PI,TPI)
      IF(U.LT.0.0)U=U+TPI
      Y=U-PI
      DTERM1=DLOG(D1MACH(2))
      IF(B.GE.SNGL(DTERM1))GOTO300
C
C     STEP 2--COMPUTE BY EXACT FORMULA
C
      DX=DBLE(Y)
      DB=DBLE(B)
      DTERM1=DBESI0(DB)
      DTERM2=DB*DCOS(DX)
      DTERM3=DEXP(DTERM2)
      DTERM4=DTERM3/DTERM1
      PDF=SNGL(DTERM4)/(2.0*PI)
      GOTO9999
C
C     STEP 3--COMPUTE VIA NORMAL APPROXIMATION
C             NORMAL APPROXIMATION IN ACM ALGORITHM 518 IS PROBABLY
C             MORE ACCURATE.  HOWEVER, STANDARD DEVIATION NOT GIVEN
C             IN ORDER TO APPLY PROPER SCALING.  USE THE NORMALIZATION
C             FROM AS 86 (SD=SQRT(B-0.5)).  CAN REVERT TO ACM 518
C             ALGORITHM IF LOCATE STANDARD DEVIATION.
C
  300 CONTINUE
CCCCC Z=B
CCCCC C=24.0*Z
CCCCC V=C-C1
CCCCC R=SQRT((54.0/(347.0/V+26.0-C)-6.0+C)/6.0)
C
C  Z IN LINE BELOW IS B(K)*SIN(THETA/2) IN TERMS OF
C  THE HILL PAPER.
C
CCCCC Z=SIN(Y*0.5)*R
CCCCC S=Z*Z
CCCCC V=V-S+3.0
CCCCC Y=(C-S-S-16.0)/3.0
CCCCC Y=((S+1.75)*S+83.5)/V - Y
C
CCCCC ARG1=Z-S/(Y*Y)*Z
CCCCC CALL NORPDF(ARG1,PDFN)
CCCCC PDF=PDFN
      SD=SQRT(B-0.5)
      ARG1=SD*X
      CALL NORPDF(ARG1,PDFN)
      PDF=SD*PDFN
      GOTO9999
C
 9999 CONTINUE
      RETURN
      END 
      SUBROUTINE VONPPF(P,B,PPF)
C
C     PURPOSE   --PERCENT POINT FUNCTION FOR THE VON MISES
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                 WASHINGTON, D. C. 20234
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/9
C     ORIGINAL VERSION--SEPTEMBER 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
      DATA EPS /0.00001/
      DATA SIG /1.0E-6/
      DATA ZERO /0./
      DATA MAXIT /500/
      DATA PI / 3.1415926535898 /
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(P.LT.0.0.OR.P.GT.1.0)GOTO50
      IF(B.LT.0.0)GOTO70
      GOTO90
   50 WRITE(ICOUT,1)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)P
      CALL DPWRST('XXX','BUG ')
      PPF=0.0
      RETURN
   70 WRITE(ICOUT,35)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)B
      CALL DPWRST('XXX','BUG ')
      PPF=0.0
      GOTO9999
C
    1 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ',
     1' VONPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL.')
   35 FORMAT('***** FATAL ERROR--THE 2ND INPUT ARGUMENT TO THE ',
     1' VONPPF SUBROUTINE IS NEGATIVE.')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
   90 CONTINUE
C
C  VON MISES DISTRIBUTION BRACKETED BY (-PI,PI).
C  SET TO -PI IF P=0, SET TO +PI IF P=1.
C
      IF(P.LE.0.0)THEN
        PPF=-PI
        GOTO9999
      ELSEIF(P.GE.1.0)THEN
        PPF=PI
        GOTO9999
      ENDIF
      XL=-PI
      XR=PI
C
C  BISECTION METHOD
C
   99 CONTINUE
      IC = 0
      FXL = -P
      FXR = 1.0 - P
  105 CONTINUE
      X = (XL+XR)*0.5
      CALL VONCDF(X,B,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('***** FATAL ERROR--VONPPF ROUTINE DID NOT CONVERGE. ***')
      GOTO9999
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE VONRAN(N,B,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE VON MISES DISTRIBUTION
C              WITH SHAPE PARAMETER VALUE = P.
C              THIS DISTRIBUTION IS DEFINED FOR ALL  X BETWEEN 0 AND
C              2*PI.  A MUST ALSO BE IN THE RANGE 0 TO 2*PI AND B
C              MUST BE POSITIVE.  WE CALCULATE FOR THE CASE A = 0
C              (VONPDF(X,B)+A FOR A <> 0 CASE).
C              IT HAS THE PROBABILITY DENSITY FUNCTION
C              F(X) = EXP[B*COS(X-1)]/[2*PI*I0(B)]
C              WHERE I0 IS THE MODIFIED BESSEL FUNCTION OR ORDER 0.
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --B      = THE SINGLE PRECISION VALUE OF THE
C                                SHAPE PARAMETER.  B > 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 VON MISES DISTRIBUTION
C             WITH SHAPE PARAMETER VALUE = B.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C                 --B > 0
C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN, VONPPF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--LUC DEVROYE, "NON-UNIFORM RANDOM VARIATE
C                 GENERATION", SPRINGER-VERLANG, 1986, PP. 473-476.
C               --HAMMERSLEY AND HANDSCOMB, MONTE CARLO METHODS,
C                 1964, PAGE 36.
C               --JOHNSON, KOTZ, AND BALAKRISHNAN, CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--1, 1994.  CAUCHY CHAPTER.
C               --EVANS, HASTINGS AND PEACOCK, STATISTICAL
C                 DISTRIBUTIONS--THIRD EDITION, 2000.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 WASHINGTON, D. C. 20234
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.6
C     ORIGINAL VERSION--JUNE      2003.
C     MODIFIED        --APRIL     2004. USE BEST-FISHER ALGORITHM,
C                                       BASED ON REJECTION FROM
C                                       WRAPPED CAUCHY.
C                                       ALGORITHM AS GIVEN BY
C                                       DEVROYE DOESN'T SEEM TO
C                                       BE GIVING REASONABLE RESULTS
C                                       (IN PARTICULAR, THE WRAPPED
C                                       CAUCHY ALGORITH), SO LEAVE
C                                       PERCENT POINT ALGORITHM FOR
C                                       NOW.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
      DIMENSION U(2)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DATA PI / 3.1415926535/
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(B.LE.0.0)THEN
        WRITE(ICOUT,15)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)B
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
    5 FORMAT('***** FATAL ERROR--THE NUMBER OF VON MISES RANDOM ',
     1'NUMBERS IS NON-POSITIVE.')
   15 FORMAT('***** FATAL ERROR--THE SHAPE PARAMETER FOR THE VON ',
     1'MISES 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 VON MISES DISTRIBUTION RANDOM NUMBERS
C     USING THE BEST-FISHER ALGORITHM.
C
C     SETUP:
C        P = SHAPE PARAMETER FOR WRAPPED CAUCHY
C          = (R - SQRT(2*PI))/2*B
C     WITH
C        R = 1 + SQRT(1 + 4*B**2)
C     THEN
C        S = (1 + P**2)/(2*P)
C
CCCCC R=1.0 + SQRT(1.0 + 4*B*B)
CCCCC P=(R-SQRT(2.0*R))/(2.0*B)
CCCCC S=(1.0 + P*P)/(2.0*P)
CCCCC NTEMP=2
CCCCC print *,'r,p,s=',r,p,s
      CALL UNIRAN(N,ISEED,X)
C
      DO100I=1,N
C
C       GENERATE 2 UNIFORM (-1,1) RANDOM NUMBERS;
C
CC110   CONTINUE
CBEST   CALL UNIRAN(NTEMP,ISEED,U)
CBEST   U1=U(1)
CBEST   U2=U(2)
CBEST   U1=(U1-0.5)*2.0
CBEST   U1SIGN=1.0
CBEST   IF(U1.LT.0.0)U1SIGN=-1.0
CBEST   U2=(U2-0.5)*2.0
CBEST   print *,'u1,u2=',u1,u2
CBEST   Z=COS(PI*U1)
CBEST   W=(1.0+S*Z)/(S+Z)
CBEST   Y=B*(S-W)
CBEST   print *,'z,w,y=',z,w,y
CBEST   ATEMP=W*(2.0-W)-U2
CBEST   print *,'atemp=',atemp
CBEST   IF(ATEMP.GE.0.0)THEN
CBEST     X(I)=U1SIGN/COS(W)
CBEST   ELSE
CBEST     ATEMP=LOG(W/U2) + 1.0 - W
CBEST     IF(ATEMP.GE.0.0)THEN
CBEST       X(I)=U1SIGN/COS(W)
CBEST     ELSE
CBEST       GOTO110
CBEST     ENDIF
CBEST   ENDIF
        CALL VONPPF(X(I),B,XOUT)
        X(I)=XOUT
  100 CONTINUE
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE VVLA(VA,X,PV)
C
C       ===================================================
C       Purpose: Compute parabolic cylinder function Vv(x)
C                for large argument
C       Input:   x  --- Argument
C                va --- Order
C       Output:  PV --- Vv(x)
C       Routines called:
C             (1) DVLA for computing Dv(x) for large |x|
C             (2) GAMMA for computing â(x)
C                 SUBSTITUTE CMLIB "DGAMMA" FUNCTION
C       ===================================================
C
        IMPLICIT DOUBLE PRECISION (A-H,O-Z)
        PI=3.141592653589793D0
        EPS=1.0D-12
        QE=DEXP(0.25*X*X)
        A0=DABS(X)**(-VA-1.0D0)*DSQRT(2.0D0/PI)*QE
        R=1.0D0
        PV=1.0D0
        DO 10 K=1,18
           R=0.5D0*R*(2.0*K+VA-1.0)*(2.0*K+VA)/(K*X*X)
           PV=PV+R
           IF (DABS(R/PV).LT.EPS) GO TO 15
10      CONTINUE
15      PV=A0*PV
        IF (X.LT.0.0D0) THEN
           X1=-X
           CALL DVLA(VA,X1,PDL)
CCCCC      CALL GAMMA(-VA,GL)
           GL=DGAMM2(-VA)
           DSL=DSIN(PI*VA)*DSIN(PI*VA)
           PV=DSL*GL/PI*PDL-DCOS(PI*VA)*PV
        ENDIF
        RETURN
        END
        SUBROUTINE VVSA(VA,X,PV)
C
C       ===================================================
C       Purpose: Compute parabolic cylinder function Vv(x)
C                for small argument
C       Input:   x  --- Argument
C                va --- Order
C       Output:  PV --- Vv(x)
C       Routine called : GAMMA for computing â(x)
C                SUBSTITUTE CMLIB DGAMMA FUNCTION
C       ===================================================
C
        IMPLICIT DOUBLE PRECISION (A-H,O-Z)
        EPS=1.0D-15
        PI=3.141592653589793D0
        EP=DEXP(-.25D0*X*X)
        VA0=1.0D0+0.5D0*VA
        IF (X.EQ.0.0) THEN
           IF (VA0.LE.0.0.AND.VA0.EQ.INT(VA0).OR.VA.EQ.0.0) THEN
              PV=0.0D0
           ELSE
              VB0=-0.5D0*VA
              SV0=DSIN(VA0*PI)
CCCCC         CALL GAMMA(VA0,GA0)
              GA0=DGAMM2(VA0)
              PV=2.0D0**VB0*SV0/GA0
           ENDIF
        ELSE
           SQ2=DSQRT(2.0D0)
           A0=2.0D0**(-.5D0*VA)*EP/(2.0D0*PI)
           SV=DSIN(-(VA+.5D0)*PI)
           V1=-.5D0*VA
CCCCC      CALL GAMMA(V1,G1)
           G1=DGAMM2(V1)
           PV=(SV+1.0D0)*G1
           R=1.0D0
           FAC=1.0D0
           DO 10 M=1,250
              VM=.5D0*(M-VA)
CCCCC         CALL GAMMA(VM,GM)
              GM=DGAMM2(VM)
              R=R*SQ2*X/M
              FAC=-FAC
              GW=FAC*SV+1.0D0
              R1=GW*R*GM
              PV=PV+R1
              IF (DABS(R1/PV).LT.EPS.AND.GW.NE.0.0) GO TO 15
10         CONTINUE
15         PV=A0*PV
        ENDIF
        RETURN
        END
      SUBROUTINE WAKRAN(N,BETA,GAMMA,DELTA,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE WAKEBY DISTRIBUTION
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --BETA   = THE FIRST SHAPE PARAMETER
C                     --GAMMA  = THE SECOND SHAPE PARAMETER
C                     --DELTA  = THE THIRD SHAPE PARAMETER
C                     --SEED   = THE SEED FOR THE RANDOM NUMBER
C                                GENERATOR
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST N)
C                                INTO WHICH THE GENERATED
C                                RANDOM SAMPLE WILL BE PLACED.
C     OUTPUT--A RANDOM SAMPLE OF SIZE N
C             FROM THE WAKEBY 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, QUAWAK.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2006/2
C     ORIGINAL VERSION--FEBRUARY  2006.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
C
      DOUBLE PRECISION XPAR(5)
      DOUBLE PRECISION QUAGLO
      DOUBLE PRECISION DX
      DOUBLE PRECISION DPPF
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)THEN
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
        CALL DPWRST('XXX','BUG ')
        RETURN
      ENDIF
    5 FORMAT('***** ERROR--THE REQUESTED NUMBER OF WAKEBY ',
     1       'RANDOM NUMBERS IS NON-POSITIVE.')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8)
C
C     GENERATE N UNIFORM (0,1) RANDOM NUMBERS;
C
      CALL UNIRAN(N,ISEED,X)
C
C     GENERATE N WAKEBY RANDOM NUMBERS
C     USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD
C
      XPAR(1)=0.0D0
      XPAR(2)=1.0D0
      XPAR(3)=DBLE(BETA)
      XPAR(4)=DBLE(GAMMA)
      XPAR(5)=DBLE(DELTA)
C
      DO100I=1,N
        DX=DBLE(X(I))
        DPPF=QUAWAK(DX,XPAR)
        X(I)=REAL(DPPF)
  100 CONTINUE
C
      RETURN
      END
      SUBROUTINE WALCDF(X,GAMMA,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE WALD DISTRIBUTION
C              (BUT HERE TREATED AS IDENTICAL TO THE
C              INVERSE GAUSSIAN DISTRIBUTION).
C              WITH SHAPE PARAMETER = GAMMA
C              AND (BY DEFINITION) LOCATION PARAMETER = 1.
C     REFERENCES--KOTZ & JOHNSON, ENCYCLOPEDIA OF STAT SCIENCES
C                 VOLUME 4, PAGE 247, COLUMNS 1 (FOR CDF) AND 2.
C     VERSION NUMBER--90.6
C     ORIGINAL VERSION--MAY       1990.
C     UPDATED         --JANUARY   1995. NEW DEF. OF WALD & REWRITTEN
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
      AMU=1.0
      CALL IGCDF(X,GAMMA,AMU,CDF)
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE WALPDF(X,GAMMA,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE WALD DISTRIBUTION
C              (BUT HERE TREATED AS IDENTICAL TO THE
C              INVERSE GAUSSIAN DISTRIBUTION).
C              WITH SHAPE PARAMETER = GAMMA
C              AND (BY DEFINITION) LOCATION PARAMETER = 1.
C     REFERENCES--KOTZ & JOHNSON, ENCYCLOPEDIA OF STAT SCIENCES
C                 VOLUME 4, PAGE 247, COLUMNS 1 (FOR CDF) AND 2.
C     VERSION NUMBER--90.6
C     ORIGINAL VERSION--MAY       1990.
C     UPDATED         --JANUARY   1995. NEW DEF. OF WALD & REWRITTEN
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
      AMU=1.0
      CALL IGPDF(X,GAMMA,AMU,PDF)
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE WALPPF(P,GAMMA,PPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE WALD DISTRIBUTION
C              (BUT HERE TREATED AS IDENTICAL TO THE
C              INVERSE GAUSSIAN DISTRIBUTION).
C              WITH SHAPE PARAMETER = GAMMA
C              AND (BY DEFINITION) LOCATION PARAMETER = 1.
C     REFERENCES--KOTZ & JOHNSON, ENCYCLOPEDIA OF STAT SCIENCES
C                 VOLUME 4, PAGE 247, COLUMNS 1 (FOR CDF) AND 2.
C     VERSION NUMBER--90.6
C     ORIGINAL VERSION--MAY       1990.
C     UPDATED         --JANUARY   1995. NEW DEF. OF WALD & REWRITTEN
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
      AMU=1.0
      CALL IGPPF(P,GAMMA,AMU,PPF)
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE WALRAN(N,GAMMA,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE WALD DISTRIBUTION
C              (BUT HERE TREATED AS IDENTICAL TO THE
C              INVERSE GAUSSIAN DISTRIBUTION).
C              WITH SHAPE PARAMETER VALUE = GAMMA
C              AND LOCATION PARAMETER MU = 1.
C     REFERENCES--KOTZ & JOHNSON, ENCYCLOPEDIA OF STAT SCIENCES
C                 VOLUME 4, PAGE 247, COLUMNS 1 (FOR CDF) AND 2.
C     VERSION NUMBER--90.6
C     ORIGINAL VERSION--MAY       1990.
C     UPDATED         --JANUARY   1995. NEW DEF. OF WALD & REWRITTEN
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
      AMU=1.0
      CALL IGRAN(N,GAMMA,AMU,ISEED,X)
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE WARCDF(X,C,A,CDF,IFLAG2)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE DISCRETE WARING
C              DISTRIBUTION WITH SHAPE PARAMETERS = C AND A.
C              THIS DISTRIBUTION IS DEFINED FOR ALL INTEGER X>=0.
C              THE PROBABILITY DENSITY FUNCTION IS:
C              F(X,C,A)=(C-A)(A+X-1)!C!/[C(A-1)!(C+X)!]
C              CASE WHERE A = 1 IS THE YULE DISTRIBUTION
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                     --C    = THE SHAPE PARAMETER
C                     --A    = THE SHAPE PARAMETER
C     OUTPUT ARGUMENTS--CDF    = THE SINGLE PRECISION DENSITY
C                                FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE A NON-NEGATIVE INTEGER
C                 --C > A
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON AND KOTZ, DISCRETE UNIVARIATE
C                 DISTRIBUTIONS--1, 1994, PP. 276-279.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--95/4
C     ORIGINAL VERSION--APRIL     1995.
C     MODIFIED        --JUNE      1995. FOR BETTER PERFORMANCE, INCLUDE
C                                       A FLAG FOR TRUNCATING IF
C                                       INDIVIDUAL TERMS BELOW SOME
C                                       EPS VALUE.  THIS IS SET FOR
C                                       PPF FUNCTION, PROB PLOT, BUT NOT
C                                       FOR CDF FUNCTION
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DTERM1, DTERM2, DTERM3, DTERM4, DTERM5
      DOUBLE PRECISION DTERM6, DTERM7
      DOUBLE PRECISION DX, DC, DA
      DOUBLE PRECISION DPDF, DSUM
      DOUBLE PRECISION DLNGAM
      DOUBLE PRECISION DEPS
C
      CHARACTER*4 IFLAG2
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 DEPS /1.0D-12/
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(C.LE.0.0)THEN
        WRITE(ICOUT,15)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)C
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9999
      ENDIF
      IF(A.LE.0.0)THEN
        WRITE(ICOUT,25)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)A
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9999
      ENDIF
      IF(C.LE.A.AND.A.NE.1.0)THEN
        WRITE(ICOUT,35)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)C
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,48)A
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9999
      ENDIF
C
      IX=X+0.5
      IF(IX.LT.0)THEN
        WRITE(ICOUT,4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9999
      ENDIF
C
    4 FORMAT('***** NON-FATAL DIAGNOSTIC--THE 1ST INPUT ARGUMENT ',
     1'TO THE WARCDF SUBROUTINE IS LESS THAN 0 *****')
   15 FORMAT('***** FATAL ERROR--THE 2ND INPUT ARGUMENT TO THE ',
     1'WARCDF SUBROUTINE IS NOT POSITIVE *****')
   25 FORMAT('***** FATAL ERROR--THE THIRD INPUT ARGUMENT TO THE ',
     1'WARCDF SUBROUTINE IS NOT POSITIVE *****')
   35 FORMAT('***** FATAL ERROR--THE THIRD INPUT ARGUMENT TO THE ',
     1'WARCDF SUBROUTINE IS LARGER THAN THE SECOND *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
   47 FORMAT('***** THE VALUE OF THE FIRST ARGUMENT IS ',E15.8,' *****')
   48 FORMAT('***** THE VALUE OF THE SECOND ARGUMENT IS ',E15.8,
     1' *****')
C
   90 CONTINUE
C
      DC=DBLE(C)
      DA=DBLE(A)
      DSUM=0.0D0
C
      IF(A.EQ.1.0)THEN
        DTERM1=DLOG(DC)
        DTERM3=DLNGAM(DC+1.0D0)
        DO1000I=1,IX
          DX=DBLE(I)
          DTERM2=DLNGAM(DX)
          DTERM6=DLNGAM(DC+DX+1.0D0)
          DTERM7=DTERM1+DTERM2+DTERM3-DTERM6
          DPDF=DEXP(DTERM7)
          DSUM=DSUM+DPDF
CCCCC     IF(IFLAG2.EQ.'TRUN'.AND.DPDF.LT.DEPS)GOTO1099
 1000   CONTINUE
C
      ELSE
        DTERM1=DLOG(DC-DA)
        DTERM3=DLNGAM(DC+1.0D0)
        DTERM4=DLOG(DC)
        DTERM5=DLNGAM(DA)
        DO2000I=0,IX
          DX=DBLE(I)
          DTERM2=DLNGAM(DA+DX)
          DTERM6=DLNGAM(DC+DX+1.0D0)
          DTERM7=DTERM1+DTERM2+DTERM3-DTERM4-DTERM5-DTERM6
          DPDF=DEXP(DTERM7)
          DSUM=DSUM+DPDF
CCCCC     IF(IFLAG2.EQ.'TRUN'.AND.DPDF.LT.DEPS)GOTO1099
 2000   CONTINUE
      ENDIF
C
      CDF=REAL(DSUM)
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE WARFU2(NPAR,XPAR,FVEC,IFLAG,XTEMP,NCLASS)
C
C     PURPOSE--DPMLWA CALLS DNSQE TO SOLVE THE MAXIMUM LIKELIHOOD
C              EQUATIONS.  WARFU2 IS CALLED TO EVALUATE THE EQUATIONS
C              AT A GIVEN SET OF PARAMETERS.  THE LIKELIHOOD EQUATIONS
C              ARE
C                 N/(X*(X-A)) - SUM[K=2 to LAMBDA][V(K)/(X+K-1)]
C                 N/(X-A)) - SUM[K=2 to LAMBDA][V(K)/(A+K-2)]
C              WITH V(K) DENOTING THE CUMULATIVE FREQUENCY FROM
C              K UPWARDS AND X AND A DENOTING THE SHAPE PARAMETERS
C              OF THE WARING DISTRIBUTION.
C     INPUT  ARGUMENTS--XPAR   = THE SINGLE PRECISION VECTOR
C                                CONTAINING THE VALUES OF THE SHAPE
C                                PARAMETERS.
C                       NPAR   = THE NUMBER OF PARAMETERS.
C                       IFLAG  = NOT USED
C                       XTEMP  = ROWS 1 TO NCLASS CONTAIN THE VALUES
C                                OF THE FREQUENCIES AND ROWS
C                                (NCLASS+1) TO 2*NCLASS CONTAIN THE
C                                PRECOMPUTED VALUES OF VK.
C                       NCLASS = THE NUMBER OF FREQUENCY CLASSES.
C     OUTPUT ARGUMENTS--THE VECTOR FVEC CONTAINS THE COMPUTED VALUES
C                       OF THE LIKELIHOOD EQUATIONS.
C     PRINTING--NONE.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--IRWIN, "MATHEMATICS IN MEDICAL AND BIOLOGICAL
C                 STATISTICS", JOURNAL OF THE ROYAL STATISTICAL
C                 SOCIETY, SERIES A, VOL. 126, PP. 1-44.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE 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.4
C     ORIGINAL VERSION--APRIL     2004.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      REAL XTEMP(*)
      DOUBLE PRECISION XPAR(*)
      DOUBLE PRECISION FVEC(*)
C
      COMMON/WARCOM/NTOT
C
      DOUBLE PRECISION TERM1
      DOUBLE PRECISION TERM2
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DSUM2
      DOUBLE PRECISION XFREQ
      DOUBLE PRECISION VK
      DOUBLE PRECISION X
      DOUBLE PRECISION A
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      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
      A=XPAR(1)
      X=XPAR(2)
      TERM1=DBLE(NTOT)/(X*(X-A))
      TERM2=DBLE(NTOT)/(X-A)
      DSUM1=0.0D0
      DSUM2=0.0D0
      DO100K=1,NCLASS
        XFREQ=DBLE(XTEMP(K))
        VK=DBLE(XTEMP(NCLASS+K))
        IF(XFREQ.GE.0.99999D0)THEN
          DSUM1=DSUM1 + VK/(X+DBLE(K)-1.0D0)
        ENDIF
        IF(XFREQ.GE.0.99999D0)THEN
          DSUM2=DSUM2 + VK/(A+DBLE(K)-2.0D0)
        ENDIF
  100 CONTINUE
      FVEC(1)=TERM1 - DSUM1
      FVEC(2)=TERM2 - DSUM2
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE WARPDF(X,C,A,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE DISCRETE WARING
C              DISTRIBUTION WITH SHAPE PARAMETERS = C AND A.
C              THIS DISTRIBUTION IS DEFINED FOR ALL INTEGER X>=0.
C              THE PROBABILITY DENSITY FUNCTION IS:
C              F(X,C,A)=(C-A)(A+X-1)!C!/[C(A-1)!(C+X)!]
C              CASE WHERE A = 1 IS THE YULE DISTRIBUTION
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                     --C    = THE SHAPE PARAMETER
C                     --A    = THE SHAPE PARAMETER
C     OUTPUT ARGUMENTS--PDF    = THE SINGLE PRECISION DENSITY
C                                FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE A NON-NEGATIVE INTEGER
C                 --C > A
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON AND KOTZ, DISCRETE UNIVARIATE
C                 DISTRIBUTIONS--1, 1994, PP. 276-279.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--95/4
C     ORIGINAL VERSION--APRIL     1995.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DTERM1, DTERM2, DTERM3, DTERM4, DTERM5
      DOUBLE PRECISION DTERM6, DTERM7
      DOUBLE PRECISION DX, DC, DA
      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-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(C.LE.0.0)THEN
        WRITE(ICOUT,15)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)C
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ENDIF
      IF(A.LE.0.0)THEN
        WRITE(ICOUT,25)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)A
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ENDIF
      IF(C.LE.A.AND.A.NE.1.0)THEN
        WRITE(ICOUT,35)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)C
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,48)A
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ENDIF
C
      IX=X+0.5
      IF(IX.LT.0)THEN
        WRITE(ICOUT,4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ENDIF
      IF(A.EQ.1.0.AND.IX.LT.0)THEN
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ENDIF
C
    4 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT ',
     1'TO THE WARPDF SUBROUTINE IS LESS THAN 0 *****')
    5 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT ',
     1'TO THE WARPDF SUBROUTINE IS 0 WHEN THIRD')
    6 FORMAT('      ARGUMENT IS 1.0 ')
   15 FORMAT('***** FATAL ERROR--THE 2ND INPUT ARGUMENT TO THE ',
     1'WARPDF SUBROUTINE IS NOT POSITIVE *****')
   25 FORMAT('***** FATAL ERROR--THE THIRD INPUT ARGUMENT TO THE ',
     1'WARPDF SUBROUTINE IS NOT POSITIVE *****')
   35 FORMAT('***** FATAL ERROR--THE THIRD INPUT ARGUMENT TO THE ',
     1'WARPDF SUBROUTINE IS LARGER THAN THE SECOND *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
   47 FORMAT('***** THE VALUE OF THE FIRST ARGUMENT IS ',E15.8,' *****')
   48 FORMAT('***** THE VALUE OF THE SECOND ARGUMENT IS ',E15.8,
     1' *****')
C
   90 CONTINUE
C
      DX=DBLE(IX)
      DC=DBLE(C)
      DA=DBLE(A)
C
      IF(A.EQ.1.0)THEN
        DTERM1=DLOG(DC)
        DTERM2=DLNGAM(DX)
        DTERM3=DLNGAM(DC+1.0D0)
        DTERM6=DLNGAM(DC+DX+1.0D0)
        DTERM7=DTERM1+DTERM2+DTERM3-DTERM6
        DPDF=DEXP(DTERM7)
      ELSE
        DTERM1=DLOG(DC-DA)
        DTERM2=DLNGAM(DA+DX)
        DTERM3=DLNGAM(DC+1.0D0)
        DTERM4=DLOG(DC)
        DTERM5=DLNGAM(DA)
        DTERM6=DLNGAM(DC+DX+1.0D0)
        DTERM7=DTERM1+DTERM2+DTERM3-DTERM4-DTERM5-DTERM6
        DPDF=DEXP(DTERM7)
      ENDIF
C
      PDF=REAL(DPDF)
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE WARPPF(P,C,A,PPF,IFLAG2)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE AT THE SINGLE PRECISION VALUE P
C              FOR THE WARING DISTRIBUTION (IF A = 1, THIS REDUCES
C              TO THE YULE DISTRIBUTION)
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                     --C  = THE FIRST SHAPE PARAMETER
C                     --A  = THE SECOND SHAPE PARAMETER
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 (EXCLUSIVELY FOR 1).
C                 --C SHOULD BE IN THE INTERVAL (0,1) (EXCLUSIVELY)
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     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     OTHER DATAPAC   SUBROUTINES NEEDED--WARCDF.
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, 1994.  PP. 276-279.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--95/4
C     ORIGINAL VERSION--APRIL     1995.
C     MODIFIED        --JUNE      1995. FOR BETTER PERFORMANCE, INCLUDE
C                                       A FLAG FOR TRUNCATING IF
C                                       INDIVIDUAL TERMS BELOW SOME
C                                       EPS VALUE.
C     MODIFIED        --FEBRUARY  1996. ROUTINE REWRITTEN FOR BETTER
C                                       PERFORMANCE
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IFLAG
      CHARACTER*4 IFLAG2
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DTERM1, DTERM2, DTERM3, DTERM4, DTERM5
      DOUBLE PRECISION DTERM6, DTERM7
      DOUBLE PRECISION DX, DC, DA
      DOUBLE PRECISION DPDF, DSUM
      DOUBLE PRECISION DLNGAM
CCCCC DOUBLE PRECISION DEPS
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      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
      ENDIF
      IF(C.LE.0.0)THEN
        WRITE(ICOUT,15)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)C
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ENDIF
      IF(A.LE.0.0)THEN
        WRITE(ICOUT,25)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)A
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ENDIF
      IF(C.LE.A.AND.A.NE.1.0)THEN
        WRITE(ICOUT,35)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)C
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,48)A
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ENDIF
    1 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ',
     1' WARPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL')
    4 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT ',
     1'TO THE WARPPF SUBROUTINE IS LESS THAN 0 *****')
    5 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT ',
     1'TO THE WARPPF SUBROUTINE IS 0 WHEN THIRD')
    6 FORMAT('      ARGUMENT IS 1.0 ')
   15 FORMAT('***** FATAL ERROR--THE 2ND INPUT ARGUMENT TO THE ',
     1'WARPPF SUBROUTINE IS NOT POSITIVE *****')
   25 FORMAT('***** FATAL ERROR--THE THIRD INPUT ARGUMENT TO THE ',
     1'WARPPF SUBROUTINE IS NOT POSITIVE *****')
   35 FORMAT('***** FATAL ERROR--THE THIRD INPUT ARGUMENT TO THE ',
     1'WARPPF SUBROUTINE IS LARGER THAN THE SECOND *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
   47 FORMAT('***** THE VALUE OF THE SECOND ARGUMENT IS ',E15.8,' ***')
   48 FORMAT('***** THE VALUE OF THE THIRD ARGUMENT IS ',E15.8,
     1' *****')
C
      PPF=1.0
CCCCC IFLAG2='TRUN'
      IFLAG2='OFF'
      IFLAG='WARI'
      IF(A.EQ.1.0)IFLAG='YULE'
C
C     TREAT CERTAIN SPECIAL CASES IMMEDIATELY--
C     1) P = 0.0
C
      IF(P.EQ.0.0)THEN
        PPF=0.0
        IF(IFLAG.EQ.'YULE')PPF=1.0
        GOTO9999
      ENDIF
C
C     USE BRUTE FORCE METHOD WHERE CALCULATE CDF UNTIL CUMULATIVE
C     PROBABILITY IS GREATER THAN INPUT PROBABILITY.  DO THIS SINCE
C     WARING CDF DOES NOT CURRENTLY UTILIZE MORE EFFICIENT
C     APPROXIMATIONS.
C
      IUPPER=2000000
C
      DC=DBLE(C)
      DA=DBLE(A)
      DSUM=0.0D0
C
      IF(A.EQ.1.0)THEN
        DTERM1=DLOG(DC)
        DTERM3=DLNGAM(DC+1.0D0)
        DO1000I=0,IUPPER
          DX=DBLE(I)
          IF(I.EQ.0)GOTO1000
          DTERM2=DLNGAM(DX)
          DTERM6=DLNGAM(DC+DX+1.0D0)
          DTERM7=DTERM1+DTERM2+DTERM3-DTERM6
          DPDF=DEXP(DTERM7)
          DSUM=DSUM+DPDF
          IF(DSUM.GE.DBLE(P))THEN
            PPF=REAL(I)
            GOTO9999
          ENDIF
 1000   CONTINUE
      ELSE
        DTERM1=DLOG(DC-DA)
        DTERM3=DLNGAM(DC+1.0D0)
        DTERM4=DLOG(DC)
        DTERM5=DLNGAM(DA)
        DO2000I=0,IUPPER
          DX=DBLE(I)
          DTERM2=DLNGAM(DA+DX)
          DTERM6=DLNGAM(DC+DX+1.0D0)
          DTERM7=DTERM1+DTERM2+DTERM3-DTERM4-DTERM5-DTERM6
          DPDF=DEXP(DTERM7)
          DSUM=DSUM+DPDF
          IF(DSUM.GE.DBLE(P))THEN
            PPF=REAL(I)
            GOTO9999
          ENDIF
 2000   CONTINUE
      ENDIF
C
      PPF=REAL(IUPPER)
      WRITE(ICOUT,3000)IUPPER,IUPPER
 3000 FORMAT('****** PPF VALUE EXCEEDS ',I8,' .  TRUNCATED AT ',
     1'THIS VALUE.')
      CALL DPWRST('XXX','BUG ')
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE WBLEST(X,NOBS,ALPHA,BETA,IERROR)
C
C   Written by Fred Todt, Battelle Columbus, Sept. 1985
C
C  COMPUTE MLES FOR SHAPE PARAMETER (BETA) AND SCALE
C  PARAMETER (ALPHA) BY SOLVING THE EQUATION  G(BETA)=0, WHERE G IS
C  A MONOTONICALLY INCREASING FUNCTION OF BETA.
C  THE INITIAL ESTIMATE IS:  RI=(1.28)/(STD. DEV. OF LOG(X)'S)
C  AND THE TOLERANCE IS   :   2*RI/(10**6).
C
      DIMENSION X(*)
      DOUBLE PRECISION SUMY
      DOUBLE PRECISION SUMYSQ
      CHARACTER*4 IERROR
C
      IERROR='NO'
      RN=REAL(NOBS)
      SUMY=0.0
      SUMYSQ=0.0
      DO  2 I=1,NOBS
           Y=ALOG(X(I))
           SUMY=SUMY+DBLE(Y)
         SUMYSQ=SUMYSQ+(DBLE(Y)**2)
    2 CONTINUE
      YSTD=SQRT((SNGL(SUMYSQ)-(SNGL(SUMY)**2)/RN)/(RN-1.0))
      XGM=EXP(SNGL(SUMY)/RN)
      RI=1.28/YSTD
      TOL=2.0*.000001*RI
      BETAM=RI
      GFM=GFUNCT(X,NOBS,BETAM,XGM)
CCCCC WRITE (*,*) ' XGM, RI, GFM ',XGM, RI, GFM
C
C  IF G(BETAM) .GE. 0, DIVIDE THE INITIAL ESTIMATE BY 2 UNTIL
C  THE ROOT IS BRACKETED BY BETAL AND BETAH.
      IF(GFM.GE.0.0)THEN
           DO 3 J=1,20
                BETAH=BETAM
                BETAM=BETAM/2.0
                GFM=GFUNCT(X,NOBS,BETAM,XGM)
                IF(GFM.LE.0.0)GO TO 4
    3      CONTINUE
CCCCC      STOP 'GFM NEVER LE 0'
           IERROR='YES'
           GOTO9999
    4      CONTINUE
           BETAL=BETAM
      ENDIF
C
C  IF G(BETAM) .LT. 0, MULTIPLY THE INITIAL ESTIMATE BY 2 UNTIL
C  THE ROOT IS BRACKETED BY BETAL AND BETAH.
      IF(GFM.LT.0.0)THEN
           DO 7 J=1,20
                BETAL=BETAM
                BETAM=BETAM*2.0
                GFM=GFUNCT(X,NOBS,BETAM,XGM)
                IF(GFM.GE.0.0)GO TO 8
    7      CONTINUE
CCCCC      STOP 'GFM NEVER GE 0'
           IERROR='YES'
           GOTO9999
    8      CONTINUE
           BETAH=BETAM
      ENDIF
C
C SOLVE THE EQUATION G(BETA)=0 FOR BETA BY BISECTING THE
C   INTERVAL (BETAL,BETAH) UNTIL THE TOLERANCE IS MET
   10 CONTINUE
      BETAM=(BETAL+BETAH)/2.0
      GFM=GFUNCT(X,NOBS,BETAM,XGM)
      IF(GFM.GE.0.0)THEN
           BETAH=BETAM
      ENDIF
      IF(GFM.LT.0.0)THEN
           BETAL=BETAM
      ENDIF
      IF(BETAH-BETAL.GT.TOL)GO TO 10
C
      BETA=(BETAL+BETAH)/2.0
      ALPHA=FNALPH(X,NOBS,BETA,XGM)
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE WBLES2(X,N,IR,ALPHA,GAMMA,IERROR)
C
C  COMPUTE MLES FOR SHAPE PARAMETER (GAMMA) AND SCALE
C  PARAMETER (ALPHA) BY SOLVING THE EQUATION  G(GAMMA)=0, WHERE G IS
C  A MONOTONICALLY INCREASING FUNCTION OF GAMMA.
C  THE INITIAL ESTIMATE IS:  RI=(1.28)/(STD. DEV. OF LOG(X)'S)
C  AND THE TOLERANCE IS   :   2*RI/(10**6).
C
      DIMENSION X(*)
      CHARACTER*4 IERROR
      PARAMETER (MAXIT=20000)
C
      IERROR='NO'
      RN=REAL(IR)
      CALL WBLEST(X,IR,ALPHA,GAMMA,IERROR)
      RI=GAMMA
      TOL=2.0*.000001*RI
      GAMMAM=RI
      CALL GFUNC2(X,N,IR,ALPHA,GAMMAM,GFM)
C
C  IF G(GAMMAM) .GE. 0, DIVIDE THE INITIAL ESTIMATE BY 2 UNTIL
C  THE ROOT IS BRACKETED BY GAMMAL AND GAMMAH.
      IF(GFM.GE.0.0)THEN
           DO 3 J=1,20
                GAMMAH=GAMMAM
                GAMMAM=GAMMAM/2.0
                CALL GFUNC2(X,N,IR,ALPHA,GAMMAM,GFM)
                IF(GFM.LE.0.0)GO TO 4
    3      CONTINUE
CCCCC      STOP 'GFM NEVER LE 0'
           IERROR='YES'
           GOTO9999
    4      CONTINUE
           GAMMAL=GAMMAM
      ENDIF
C
C  IF G(GAMMAM) .LT. 0, MULTIPLY THE INITIAL ESTIMATE BY 2 UNTIL
C  THE ROOT IS BRACKETED BY GAMMAL AND GAMMAH.
      IF(GFM.LT.0.0)THEN
           DO 7 J=1,20
                GAMMAL=GAMMAM
                GAMMAM=GAMMAM*2.0
                CALL GFUNC2(X,N,IR,ALPHA,GAMMAM,GFM)
                IF(GFM.GE.0.0)GO TO 8
    7      CONTINUE
CCCCC      STOP 'GFM NEVER GE 0'
           IERROR='YES'
           GOTO9999
    8      CONTINUE
           GAMMAH=GAMMAM
      ENDIF
C
C SOLVE THE EQUATION G(GAMMA)=0 FOR GAMMA BY BISECTING THE
C   INTERVAL (GAMMAL,GAMMAH) UNTIL THE TOLERANCE IS MET
      NUMIT=0
   10 CONTINUE
      NUMIT=NUMIT+1
      IF(NUMIT.GT.MAXIT)THEN
        IERROR='YES'
        GOTO9999
      ENDIF
      GAMMAM=(GAMMAL+GAMMAH)/2.0
      CALL GFUNC2(X,N,IR,ALPHA,GAMMAM,GFM)
      IF(GFM.GE.0.0)THEN
           GAMMAH=GAMMAM
      ENDIF
      IF(GFM.LT.0.0)THEN
           GAMMAL=GAMMAM
      ENDIF
      IF(GAMMAH-GAMMAL.GT.TOL)GO TO 10
C
      GAMMA=(GAMMAL+GAMMAH)/2.0
      ALPHA=FNALP2(X,N,IR,GAMMA)
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE WCACDF(X,P,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE WRAPPED CAUCHY DISTRIBUTION
C              THIS DISTRIBUTION IS DEFINED FOR 0<=X<=2*PI AND HAS
C              THE PROBABILITY DENSITY FUNCTION
C              F(X) = (1/(2*PI)*(1-P**2)/(1+P**2-2*P*COS(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--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN. 
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1994, CAUCHY DISTRIBUTION CHAPTER
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 WASHINGTON, D. C. 20234
C                 PHONE:  301-975-2855
C     ORIGINAL VERSION--OCTOBER   1995. 
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      REAL P
      DOUBLE PRECISION DX
      DOUBLE PRECISION DCDF
      DOUBLE PRECISION DP
      DOUBLE PRECISION DPI
      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
      DATA DPI/3.14159265358979D0/
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS.
C
      IF(X.LT.0.0.OR.X.GT.SNGL(2.0D0*DPI))THEN
        WRITE(ICOUT,1)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
      IF(P.LT.0.0.OR.P.GE.1.0)THEN
        WRITE(ICOUT,2)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)P
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
    1 FORMAT('***** FATAL DIAGNOSTIC--THE FIRST ARGUMENT TO THE ',
     &'WCACDF ROUTINE IS OUTSIDE THE (0,2*PI) INTERVAL.')
    2 FORMAT('***** FATAL DIAGNOSTIC--THE SECOND ARGUMENT TO THE ',
     &'WCACDF ROUTINE IS OUTSIDE THE (0,1) INTERVAL.')
   46 FORMAT('      THE ARGUMENT HAS THE VALUE ',E15.7)
C
      DX=DBLE(X)
      DP=DBLE(P)
      IF(DX.LE.DPI)THEN
        DTERM3=-DCOS(DX/2.0D0)+DP*DCOS(DX/2.0D0)
        DTERM1=(-DSIN(DX/2.0D0)-DP*DSIN(DX/2.0D0))/DTERM3
        DTERM2=(DSIN(DX/2.0D0)+DP*DSIN(DX/2.0D0))/DTERM3
        DCDF=(DATAN(DTERM1) - DATAN(DTERM2))/(2.0D0*DPI)
        CDF=REAL(DCDF)
      ELSE
        DX=2.0D0*DPI - DX
        DTERM3=-DCOS(DX/2.0D0)+DP*DCOS(DX/2.0D0)
        DTERM1=(-DSIN(DX/2.0D0)-DP*DSIN(DX/2.0D0))/DTERM3
        DTERM2=(DSIN(DX/2.0D0)+DP*DSIN(DX/2.0D0))/DTERM3
        DCDF=(DATAN(DTERM1) - DATAN(DTERM2))/(2.0D0*DPI)
        DCDF=1.0D0 - DCDF
        CDF=REAL(DCDF)
      ENDIF
C
 9999 CONTINUE
      RETURN
      END 
      SUBROUTINE WCACD2(X,DP,DCDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE WRAPPED CAUCHY DISTRIBUTION
C              THIS DISTRIBUTION IS DEFINED FOR 0<=X<=2*PI AND HAS
C              THE PROBABILITY DENSITY FUNCTION
C              F(X) = (1/(2*PI)*(1-P**2)/(1+P**2-2*P*COS(X))
C     INPUT  ARGUMENTS--X      = THE DOUBLE PRECISION VALUE AT
C                                WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C     OUTPUT ARGUMENTS--CDF    = THE DOULE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION CUMUALATIVE DISTRIBUTION
C             FUNCTION VALUE CDF.
C     NOTE--THIS IS A DOUBLE PRECSION VERSION OF WCACDF THAT IS
C           USED BY THE WCAPPF ROUTINE FOR GREATER ACCURACY.
C     PRINTING--NONE.
C     RESTRICTIONS--NONE.
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--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1994, CAUCHY DISTRIBUTION CHAPTER
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 WASHINGTON, D. C. 20234
C                 PHONE:  301-975-2855
C     ORIGINAL VERSION--JANUARY   2005. 
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION X
      DOUBLE PRECISION DX
      DOUBLE PRECISION DCDF
      DOUBLE PRECISION DP
      DOUBLE PRECISION DPI
      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
      DATA DPI/3.14159265358979D0/
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS.
C
      DX=X
C
      IF(DX.LE.0.0D0)THEN
        DCDF=0.0D0
      ELSEIF(DX.GE.2.0D0*DPI)THEN
        DCDF=1.0D0
      ENDIF
      IF(DX.LT.0.0D0.OR.DX.GT.2.0D0*DPI)THEN
        WRITE(ICOUT,1)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)DX
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
      IF(DP.LT.0.0D0.OR.DP.GE.1.0D0)THEN
        WRITE(ICOUT,2)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)DP
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
    1 FORMAT('***** FATAL DIAGNOSTIC--THE FIRST ARGUMENT TO THE ',
     &'WCACD2 ROUTINE IS OUTSIDE THE (0,2*PI) INTERVAL.')
    2 FORMAT('***** FATAL DIAGNOSTIC--THE SECOND ARGUMENT TO THE ',
     &'WCACD2 ROUTINE IS OUTSIDE THE (0,1) INTERVAL.')
   46 FORMAT('      THE ARGUMENT HAS THE VALUE ',E15.7)
C
      IF(DX.LE.DPI)THEN
        DTERM3=-DCOS(DX/2.0D0)+DP*DCOS(DX/2.0D0)
        DTERM1=(-DSIN(DX/2.0D0)-DP*DSIN(DX/2.0D0))/DTERM3
        DTERM2=(DSIN(DX/2.0D0)+DP*DSIN(DX/2.0D0))/DTERM3
        DCDF=(DATAN(DTERM1) - DATAN(DTERM2))/(2.0D0*DPI)
      ELSE
        DX=2.0D0*DPI-DX
        DTERM3=-DCOS(DX/2.0D0)+DP*DCOS(DX/2.0D0)
        DTERM1=(-DSIN(DX/2.0D0)-DP*DSIN(DX/2.0D0))/DTERM3
        DTERM2=(DSIN(DX/2.0D0)+DP*DSIN(DX/2.0D0))/DTERM3
        DCDF=1.0D0-(DATAN(DTERM1) - DATAN(DTERM2))/(2.0D0*DPI)
      ENDIF
C
 9999 CONTINUE
      RETURN
      END 
      SUBROUTINE WCAPDF(X,P,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE WRAPPED CAUCHY DISTRIBUTION
C              THIS DISTRIBUTION IS DEFINED FOR 0<=X<=2*PI AND HAS
C              THE PROBABILITY DENSITY FUNCTION
C              F(X) = (1/(2*PI)*(1-P**2)/(1+P**2-2*P*COS(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--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN. 
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1994, CAUCHY DISTRIBUTION CHAPTER
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 WASHINGTON, D. C. 20234
C                 PHONE:  301-975-2855
C     ORIGINAL VERSION--OCTOBER   1995. 
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      REAL P
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C---------------------------------------------------------------------
C
      DATA C/0.1591549/
      DATA TWOPI/6.283185/
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS.
C
      IF(X.LT.0.0.OR.X.GT.TWOPI)THEN
        WRITE(ICOUT,1)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
      IF(P.LT.0.0.OR.P.GE.1.0)THEN
        WRITE(ICOUT,2)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)P
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
    1 FORMAT('***** FATAL DIAGNOSTIC--THE FIRST ARGUMENT TO THE ',
     &'WCAPDF ROUTINE IS OUTSIDE THE (0,2*PI) INTERVAL.')
    2 FORMAT('***** FATAL DIAGNOSTIC--THE SECOND ARGUMENT TO THE ',
     &'WCAPDF ROUTINE IS OUTSIDE THE (0,1) INTERVAL.')
   46 FORMAT('      THE ARGUMENT HAS THE VALUE ',E15.7)
C
      IF(P.EQ.0.0)THEN
        PDF=1.0/TWOPI
      ELSE
        PDF=C*(1.0-P*P)/(1+P*P-2.0*P*COS(X))
      ENDIF
C
 9999 CONTINUE
      RETURN
      END 
      SUBROUTINE WCAPPF(P,AP,PPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE WRAPPED CAUCHY DISTRIBUTION
C              THIS DISTRIBUTION IS DEFINED FOR 0<=X<=2*PI AND HAS
C              THE PROBABILITY DENSITY FUNCTION
C              F(X) = (1/(2*PI)*(1-P**2)/(1+P**2-2*P*COS(X))
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 WASHINGTON, D. C. 20234
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     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1994, CAUCHY DISTRIBUTION CHAPTER
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--95/10
C     ORIGINAL VERSION--OCTOBER   1995.
C     UPDATED         --JANUARY   2005. CONVERT TO DOUBLE PRECISION
C                                       FOR GREATER ACCURACY
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DOUBLE PRECISION DP
      DOUBLE PRECISION DAP
      DOUBLE PRECISION DPPF
      DOUBLE PRECISION DPI
      DOUBLE PRECISION TWOPI
      DOUBLE PRECISION EPS
      DOUBLE PRECISION SIG
      DOUBLE PRECISION ZERO
      DOUBLE PRECISION XL
      DOUBLE PRECISION XR
      DOUBLE PRECISION FXL
      DOUBLE PRECISION FXR
      DOUBLE PRECISION X
      DOUBLE PRECISION CDF
      DOUBLE PRECISION P1
      DOUBLE PRECISION FCS
      DOUBLE PRECISION XRML
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 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 TWOPI/6.283185/
      DATA DPI/ 3.14159265358979D+00/
      DATA EPS /1.0D-6/
      DATA SIG /1.0D-6/
      DATA ZERO /0.0D0/
      DATA MAXIT /2000/
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
        GOTO9999
      ENDIF
      IF(AP.LT.0.0.OR.AP.GE.1.0)THEN
        WRITE(ICOUT,2)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)AP
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
    2 FORMAT('***** ERROR--THE SECOND ARGUMENT TO THE ',
     &'WCAPPF ROUTINE IS OUTSIDE THE (0,1] INTERVAL.')
    1 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO THE ',
     1' WCAPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE [0,1) INTERVAL')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
      IF(P.EQ.0.0)THEN
        DPPF=0.0
        GOTO9999
      ELSEIF(P.EQ.0.5)THEN
        DPPF=REAL(DPI)
        GOTO9999
      ELSEIF(P.EQ.1.0)THEN
        DPPF=TWOPI
        GOTO9999
      ENDIF
C
CCCCC EPS=1.0D-6
CCCCC SIG=1.0D-6
CCCCC IF(AP.GE.0.9 .AND. P.GE.0.9)THEN
CCCCC   EPS=1.0D-5
CCCCC   SIG=1.0D-5
CCCCC ENDIF
      TWOPI=2.0D0*DPI
      DP=DBLE(P)
      DAP=DBLE(AP)
C
      IERR=0
      IC = 0
      IF(P.LE.0.5)THEN
        XL = 0.0D0
        XR = DPI
      ELSE
        XL = DPI
        XR = TWOPI
      ENDIF
      FXL=-DP
      FXR=1.0D0 - DP
C
C  BISECTION METHOD
C
  105 CONTINUE
      X = (XL+XR)*0.5D0
      CALL WCACD2(X,DAP,CDF)
      P1=CDF
      DPPF=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. DABS(FCS).LE.EPS)GOTO9999
      IC = IC + 1
      IF(IC.LE.MAXIT)GOTO105
      WRITE(ICOUT,130)
      CALL DPWRST('XXX','BUG ')
  130 FORMAT('***** ERROR--WCAPPF ROUTINE DID NOT CONVERGE. ***')
      GOTO9999
C
 9999 CONTINUE
      PPF=REAL(DPPF)
      RETURN
      END
      SUBROUTINE WCARAN(N,P,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE WRAPPED CAUCHY DISTRIBUTION
C              WITH SHAPE PARAMETER VALUE = P.
C              THIS DISTRIBUTION IS DEFINED FOR 0<=X<=2*PI AND HAS
C              THE PROBABILITY DENSITY FUNCTION
C              F(X) = (1/(2*PI)*(1-P**2)/(1+P**2-2*P*COS(X))
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --P      = THE SINGLE PRECISION VALUE OF THE
C                                SHAPE PARAMETER.  0 <= P <= 1
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 WRAPPED CAUCHY DISTRIBUTION
C             WITH SHAPE PARAMETER VALUE = P.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C                 --0 <= P <= 1
C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--TOCHER, THE ART OF SIMULATION,
C                 1963, PAGES 14-15.
C               --HAMMERSLEY AND HANDSCOMB, MONTE CARLO METHODS,
C                 1964, PAGE 36.
C               --JOHNSON, KOTZ, AND BALAKRISHNAN, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1994.  CAUCJY CHAPTER.
C               --EVANS, HASTINGS AND PEACOCK, STATISTICAL
C                 DISTRIBUTIONS--THIRD EDITION, 2000.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 WASHINGTON, D. C. 20234
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.6
C     ORIGINAL VERSION--JUNE      2003.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      REAL P
      DIMENSION X(*)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)THEN
        WRITE(ICOUT, 5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
      IF(P.LT.0.0.OR.P.GE.1.0)THEN
        WRITE(ICOUT,15)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)P
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
    5 FORMAT('***** FATAL ERROR--THE NUMBER OF WRAPPED CAUCHY RANDOM ',
     1'NUMBERS IS NON-POSITIVE.')
   15 FORMAT('***** FATAL ERROR--THE SHAPE PARAMETER FOR THE WRAPPED ',
     1'CAUCHY RANDOM NUMBERS IS OUTSIDE THE (0,1] INTERVAL.')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
C
C     GENERATE N UNIFORM (0,1) RANDOM NUMBERS;
C
      CALL UNIRAN(N,ISEED,X)
C
C     GENERATE N WRAPPED CAUCHY DISTRIBUTION RANDOM NUMBERS
C     USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD.
C
      DO100I=1,N
        CALL WCAPPF(X(I),P,XOUT)
        X(I)=XOUT
  100 CONTINUE
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE WEIBAR(X,N,IWRITE,Y,IBUGA3,IERROR)
C
C
C     PURPOSE--THIS SUBROUTINE GENERATES THE N ADJUSTED RANKS
C              FOR A WEIBULL PLOT
C     INPUT  ARGUMENTS--X        = A FLOATING POINT TAG VARIABLE
C                                  CONSISTING OF 1'S AND 0'S
C                                  IN WHICH 1 IMPLIES
C                                  DATA POINT IS TO BE INLCUDED IN ANALYSIS
C                                  AND 0 IMPLIES THE DATA POINT IS A
C                                  SUSPENDED (= CENSORED) ITEM.
C                     --N      = THE INTEGER NUMBER (VALID + SUSPENDED)
C                                OF DATA POINTS (AND VALUES IN    TAG).
C     OUTPUT ARGUMENTS--Y      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST N)
C                                INTO WHICH THE GENERATED
C                                ADJUSTED RANKS
C                                WILL BE PLACED.
C     OUTPUT--THE N ADJUSTED RANKS FOR A WEIBULL PLOT
C     NOTE--THE ADJUSTED RANKS AT X=0 ELEMENTS
C           ARE NEVER USED IN FURTHER ANALYSES.
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 SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCE--ABERNATHY ET AL, WEIBULL ANALYSIS HANDBOOK
C                PAGES 20-21.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     VERSION NUMBER--85.6
C     ORIGINAL VERSION--APRIL     1985.
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='WEIB'
      ISUBN2='AR  '
C
      NVALID=(-999)
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 WEIBAR--')
      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 WEIBULL ADJUSTED RANKS.  **
C               *****************************
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      IF(N.GE.1)GOTO119
      IERROR='YES'
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,111)
  111 FORMAT('***** ERROR IN WEIBAR--',
     1'THE 2ND INPUT ARGUMENT (N) IS SMALLER THAN 1')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,118)N
  118 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8)
      CALL DPWRST('XXX','BUG ')
      GOTO9000
  119 CONTINUE
C
  190 CONTINUE
C
C               *******************************
C               **  STEP 2--                 **
C               **  FORM THE ADJUSTED RANKS  **
C               *******************************
C
      AN=N
C
 1000 CONTINUE
C
C     SET INITIAL VALUE FOR SAVED ADJUSTED RANK.
C     SET INITIAL VALUE FOR RANK INCREMENT.
C
      SAVEAR=0.0
C
      I=0
      ANUM=(AN+1.0)-SAVEAR
      ADENOM=1+(N-I)
      RANINC=ANUM/ADENOM
C
      NVALID=0
      DO1100I=1,N
      ITAGI=X(I)+0.5
      IF(ITAGI.EQ.1)GOTO1200
      GOTO1300
C
C     TREAT THE VALID (TO BE INCLUDED) ITEM CASE.
C     COMPUTE THE ADJUSTED RANK.
C     SAVE THE ADJUSTED RANK.
C     DO NOT RECOMPUTE THE RANK INCREMENT.
C
 1200 CONTINUE
      NVALID=NVALID+1
      Y(I)=SAVEAR+RANINC
      SAVEAR=Y(I)
      GOTO1190
C
C     TREAT THE SUSPENDED (= CENSORED) ITEM CASE
C     RECOMPUTE THE RANK INCREMENT.
C     DO NOT RECOMPUTE THE SAVED ADJUSTED RANK.
C
 1300 CONTINUE
      ANUM=(AN+1.0)-SAVEAR
      ADENOM=1+(N-I)
      RANINC=ANUM/ADENOM
      GOTO1190
C
 1190 CONTINUE
CCCCC WRITE(ICOUT,1191)I,ITAGI,SAVEAR,ANUM,ADENOM,RANINC,Y(I)
C1191 FORMAT('I,ITAGI,SAVEAR,ANUM,ADENOM,RANINC,Y(I) = ',
CCCCC12I8,5E12.5)
CCCCC CALL DPWRST('XXX','BUG ')
 1100 CONTINUE
C
C               ******************************
C               **  STEP 3--                **
C               **  WRITE OUT A FEW LINES   **
C               **  OF SUMMARY INFORMATION  **
C               **  ABOUT THE ADJUSTED RANKS.       **
C               ******************************
C
      IF(IFEEDB.EQ.'OFF')GOTO1890
      IF(IWRITE.EQ.'OFF')GOTO1890
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1811)N
 1811 FORMAT('TOTAL NUMBER OF VALUES (VALID + SUSPENDED) = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1812)NVALID
 1812 FORMAT('TOTAL NUMBER OF VALUES (VALID ONLY       ) = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1813)Y(1)
 1813 FORMAT('THE FIRST ELEMENT IN OUTPUT VARIABLE = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1814)Y(N)
 1814 FORMAT('THE LAST  ELEMENT IN OUTPUT VARIABLE = ',E15.7)
      CALL DPWRST('XXX','BUG ')
 1890 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 WEIBAR--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IBUGA3,IERROR
 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)N,NVALID
 9013 FORMAT('N,NVALID = ',2I8)
      CALL DPWRST('XXX','BUG ')
      DO9015I=1,N
      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 WEIAFR(X1,X2,GAMMA,ALOC,SCALE,MINMAX,AFR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE AVERAGE FAILURE RATE
C              (AFR) FUNCTION VALUE FOR THE WEIBULL 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 WEIBULL (MINIMUM ORDER STATISTIC),
C
C              AFR(X1,X2) = [((X2-LOC)/SCALE)**GAMMA -
C                            ((X1-LOC)/SCALE)**GAMMA]/(X2-X1)
C
C              FOR THE WEIBULL (MAXIMUM ORDER STATISTIC),
C
C              AFR(X1,X2) = [((-X2-LOC)/SCALE)**GAMMA -
C                            ((-X1-LOC)/SCALE)**GAMMA]/(X2-X1)
C
C     INPUT  ARGUMENTS--X1     = THE SINGLE PRECISION VALUE AT
C                                WHICH THE AFR FUNCTION IS TO BE
C                                EVALUATED.
C     INPUT  ARGUMENTS--X2     = THE SINGLE PRECISION VALUE AT
C                                WHICH THE AFR FUNCTION IS TO BE
C                                EVALUATED.
C                     --GAMMA  = THE (POSITIVE) SHAPE PARAMETER
C                     --ALOC   = THE LOCATION PARAMETER
C                     --SCALE  = THE (POSITIVE) SCALE PARAMETER
C                     --MINMAX = THE INTEGER VALUE
C                                IDENTIFYING THE
C                                CHOSEN WEIBULL DISTRIBUTION.
C                                1 = MIN, 2 = MAX.
C     OUTPUT ARGUMENTS--AFR    = THE SINGLE PRECISION AVERAGE
C                                FAILURE RATE FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION AVERAGE FAILURE RATE FOR THE
C             WEIBULL DISTRIBUTION.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--GAMMA AND SCALE SHOULD BE POSITIVE, X2 NOT EQUAL X1.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--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
      DOUBLE PRECISION DX1
      DOUBLE PRECISION DX2
      DOUBLE PRECISION DLOC
      DOUBLE PRECISION DSCALE
      DOUBLE PRECISION DG
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DAFR
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      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
CCCCC ELSEIF(X1MN.LT.ALOC)THEN
CCCCC   WRITE(ICOUT,4)
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   WRITE(ICOUT,46)X1MN
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   WRITE(ICOUT,49)ALOC
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   AFR=0.0
CCCCC   GOTO9000
      ELSEIF(GAMMA.LE.0.0)THEN
        WRITE(ICOUT,8)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)GAMMA
        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
CCCC4 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO WEIAFR ',
CCCC 1       'IS LESS THAN THE LOCATION')
    5 FORMAT('***** ERROR--THE FIRST AND SECOND INPUT ARGUMENTS TO ',
     1       'WEIAFR ARE EQUAL')
    6 FORMAT('***** ERROR--THE FIFTH INPUT ARGUMENT TO WEIAFR ',
     1       '(THE SCALE) IS NON-POSITIVE')
    8 FORMAT('***** ERROR--THE THIRD INPUT ARGUMENT TO WEIAFR ',
     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(MINMAX.EQ.2)THEN
         IF(X1MX.GT.ALOC)THEN
            AFR=0.0
         ELSEIF(X1MX.EQ.ALOC)THEN
            DX2=DBLE(-X1MN)
            DX1=DBLE(-X1MX)
            DG=DBLE(GAMMA)
            DLOC=DBLE(ALOC)
            DSCALE=DBLE(SCALE)
            DTERM1=((DX2-DLOC)/DSCALE)**DG
            DAFR=DTERM1/(DX2-DX1)
            AFR=REAL(DAFR)
         ELSE
            DX2=DBLE(-X1MN)
            DX1=DBLE(-X1MX)
            DG=DBLE(GAMMA)
            DLOC=DBLE(ALOC)
            DSCALE=DBLE(SCALE)
            DTERM1=((DX2-DLOC)/DSCALE)**DG - ((DX1-DLOC)/DSCALE)**DG
            DAFR=DTERM1/(DX2-DX1)
            AFR=REAL(DAFR)
         ENDIF
C
      ELSE IF(MINMAX.EQ.1 .OR. MINMAX.EQ.0)THEN
         IF(X1MN.LT.ALOC)THEN
            AFR=0.0
         ELSE IF(X1MN.EQ.ALOC)THEN
            DX1=DBLE(X1MN)
            DX2=DBLE(X1MX)
            DG=DBLE(GAMMA)
            DLOC=DBLE(ALOC)
            DSCALE=DBLE(SCALE)
            DTERM1=((DX2-DLOC)/DSCALE)**DG
            DAFR=DTERM1/(DX2-DX1)
            AFR=REAL(DAFR)
         ELSE
            DX1=DBLE(X1MN)
            DX2=DBLE(X1MX)
            DG=DBLE(GAMMA)
            DLOC=DBLE(ALOC)
            DSCALE=DBLE(SCALE)
            DTERM1=((DX2-DLOC)/DSCALE)**DG - ((DX1-DLOC)/DSCALE)**DG
            DAFR=DTERM1/(DX2-DX1)
            AFR=REAL(DAFR)
         ENDIF
      ELSE
         WRITE(ICOUT,1800)
 1800    FORMAT('*****ERROR IN WEIAFR--MINMAX NOT 1 OR 2')
         CALL DPWRST('XXX','BUG ')
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE WEICDF(X,GAMMA,MINMAX,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE WEIBULL
C              DISTRIBUTION WITH SINGLE PRECISION
C              TAIL LENGTH PARAMETER = GAMMA.
C              THERE ARE 2 SUCH WEIBULL FAMILIES--
C                 ONE FOR THE MIN ORDER STAT (THE USUAL) AND
C                 ONE FOR THE MAX ORDER STAT.
C              (SEE SARHAN & GREENBERG, PAGE 69)
C              THE WEIBULL TYPE IS SPECIFIED VIA   MINMAX
C              FOR MINMAX = 1  (FOR THE DEFAULT MINIMUM)
C                 THE 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              FOR MINMAX = 2 (FOR THE MAXIMUM),
C                 THE WEIBULL DISTRIBUTION USED
C                 HEREIN IS DEFINED FOR ALL NEGATIVE X,
C                 AND HAS THE PROBABILITY DENSITY FUNCTION
C                 F(X) = ...
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                     --MINMAX = THE INTEGER VALUE
C                                IDENTIFYING THE
C                                CHOSEN WEIBULL DISTRIBUTION.
C                                1 = MIN, 2 = MAX.
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 LENGHT 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--SARHAN & GREENBERG,
C                 CONTRIBUTIONS TO ORDER STATISTICS,
C                 1962, WILEY, PAGE 69.
C               --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1970, PAGES 250-271.
C               --HASTINGS AND PEACOCK, STATISTICAL
C                 DISTRIBUTIONS--A HANDBOOK FOR
C                 STUDENTS AND PRACTITIONERS, 1975,
C                 PAGE 124.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--87.7
C     ORIGINAL VERSION--NOVEMBER  1987.
C     UPDATED         --MAY       1992. REWRITTEN--ADD WEIB. FOR MAX
C     UPDATED         --JANUARY   1994. ADD MINMAX ERROR MESSAGE
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)GOTO50
      GOTO90
   50 WRITE(ICOUT,15)
   15 FORMAT('***** FATAL ERROR--THE 2ND INPUT ARGUMENT TO THE ',
     1'WEICDF SUBROUTINE IS NON-POSITIVE *****')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)GAMMA
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
      CALL DPWRST('XXX','BUG ')
      CDF=0.0
      RETURN
   90 CONTINUE
C
CCCCC THE FOLLOWING SECTION WAS REWRITTEN      JANUARY 1994
      IF(MINMAX.EQ.2)THEN
         IF(X.GE.0.0)CDF=1.0
         IF(X.LT.0.0)CDF=EXP(-((-X)**GAMMA))
      ELSE IF(MINMAX.EQ.1 .OR. MINMAX.EQ.0)THEN
         IF(X.LE.0.0)CDF=0.0
         IF(X.GT.0.0)CDF=1.0-EXP(-(X**GAMMA))
      ELSE
         WRITE(ICOUT,1800)
 1800    FORMAT('*****ERROR IN WEICDF--MINMAX NOT 1 OR 2')
         CALL DPWRST('XXX','BUG ')
      ENDIF
C
      RETURN
      END
      SUBROUTINE WEICEN(CYCLE,CENSOR,Y,X,CASE,N,SHAPE,SCALE,
     1                  ICAPSW,ICAPTY,
     1                  IERROR)
C
C****************************************************
C* FORTRAN PROGRAM USES MAXIMUM LIKELIHOOD TO       *
C* ESTIMATE THE PARAMETERS OF TWO-PARAMETER WEIBULL *
C* DISTRIBUTION. THE PROGRAM CAN BE USED FOR ALL    *
C* CENSORING CASES:                                 *
C*     CASE 1: MULTIPLY CENSORED DATA               *
C*     CASE 2: SINGLY CENSORED DATA                 *
C*     CASE 3: COMPLETE DATA                        *
C*                                                  *
C* PROGRAM INPUT CAN BE INTERACTIVE OR FROM A USER  *
C* SPECIFIED FILE                                   *
C*                                                  *
C* THE INPUT FILE FORMAT IS AS FOLLOWS:             *
C* COL.1: CYCLE TIME                                *
C* COL.2: CENSORED TYPE (1: FAILURE; 0: NON-FAILURE)*
C****************************************************
C
CCCCC CODE FROM: 
CCCCC NOVEMBER 2003. ADD SUPPORT FOR HTML/LATEX OUTPUT.
      PARAMETER(NLEV=6)
      INTEGER I,R,S,J,L,CC,CASE
      INTEGER N,CENSOR(*),K,K1
      DOUBLE PRECISION BETA,THETA,CYCLE(*)
      DOUBLE PRECISION X(*),Y(*),PI,LEVEL(NLEV)
      DOUBLE PRECISION T2,T3,T4,ST1,ST2,NUM,NUM1
      DOUBLE PRECISION VARB,VART,COVBT,DEM1,DEM2,DEM3
      DOUBLE PRECISION S1R,S2R,S3R,S4R,S2S,S3S,S4S
      DOUBLE PRECISION DENOM,DENOM1,DENOM2,DENOM3,DENOM4
      DOUBLE PRECISION CON,IB,IT,COV
      DOUBLE PRECISION LOW1(NLEV),LOW2(NLEV),UP1(NLEV),UP2(NLEV)
      DOUBLE PRECISION ALPHA,NORM,DELTA,L1,L2
C
      CHARACTER*4 ICAPSW
      CHARACTER*4 ICAPTY
      CHARACTER*1 IBASLC
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
      CHARACTER*4 IERROR
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DATA PI / 3.1415926535 8979323846 2643383279 503 D0 /
C
C-----START POINT-----------------------------------------------------
C
      LEVEL(1)=0.50
      LEVEL(2)=0.75
      LEVEL(3)=0.90
      LEVEL(4)=0.95
      LEVEL(5)=0.99
      LEVEL(6)=0.999
C
      R = 0
      S = 0
      J = 1
      L = 1
      DO 30 I = 1,N
        IF (CENSOR(I) .EQ. 1) THEN
          X(J) = CYCLE(I)
          J = J + 1
          R = R + 1
        ELSE
          Y(L) = CYCLE(I)
          L = L + 1
          S = S + 1
        END IF
30      CONTINUE
C
C MENON'S ESTIMATE OF BETA AS INITIAL
C APPROXIMATION OF BETA
C
      ST1 = 0.0D0
      ST2 = 0.0D0
      DO 40 I = 1, R
        ST1 = ST1 +  DLOG(X(I))
        ST2 = ST2 + ( DLOG(X(I)))**2
40    CONTINUE
      S1R = ST1
      ST1 = (ST1**2)/(DBLE(R))
      BETA = (6.0D0 * (ST2 - ST1))/
     *((PI**2)*(DBLE(R - 1.0D0)))
      IF (BETA .EQ. 0.0D0) BETA = .0001D0
      BETA = 1.0D0 / SQRT(BETA)
      CC = 0
      DELTA = 0.0D0
C
C NEWTON-RAPHSON ITERATIVE ESTIMATE OF BETA
C
      MAXIT=500
      DO 100 K = 1,MAXIT
        S2R = 0.0D0
        S3R = 0.0D0
        S4R = 0.0D0
        S2S = 0.0D0
        S3S = 0.0D0
        S4S = 0.0D0
        DO 80 I = 1,R
          S2R = S2R + X(I)**BETA
          S3R = S3R + (X(I)**BETA) *  DLOG(X(I))
          S4R = S4R + (X(I)**BETA) * ( DLOG(X(I))**2)
80      CONTINUE
        DO 85 I = 1,S
           S2S = S2S + Y(I)**BETA
           S3S = S3S + (Y(I)**BETA) *  DLOG(Y(I))
           S4S = S4S + (Y(I)**BETA) * ( DLOG(Y(I))**2)
85      CONTINUE
        NUM1 = (S3R + S3S) / (S2R + S2S)
        NUM = (1.0D0 / BETA) + (S1R / DBLE(R)) - NUM1
        DENOM1 = (S3R + S3S)**2
        DENOM2 = (S2R + S2S) * (S4R + S4S)
        DENOM3 = (S2R + S2S)**2
        DENOM4 = 1.0D0 / BETA**2
        DENOM = DENOM4 - ((DENOM1 - DENOM2) / DENOM3)
        DELTA = NUM / DENOM
        BETA = BETA + DELTA
        K1 = K
C
C TEST FOR CONVERGENCE
C
        IF (ABS(DELTA) .LT. 0.000001D0) THEN
          CC = 1
          GOTO 105
        END IF
100     CONTINUE
C
C INDICATE NON-CONVERGENCE
C
105   CONTINUE
      IF (CC .EQ. 0) THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG')
        WRITE(ICOUT,108)
        CALL DPWRST('XXX','BUG')
        IERROR='YES'
  999 FORMAT(1X)
  108 FORMAT('****** ERROR: WEIBULL MAXIMUM LIKELIHOOD ESTIMATE IS ',
     1       'NOT CONVERGING.')
      ELSE
C
C IF CONVERGENCE HAS OCCURRED CALCULATE THETA & BETA
C
        S2R = 0.0D0
        S3R = 0.0D0
        S4R = 0.0D0
        S2S = 0.0D0
        S3S = 0.0D0
        S4S = 0.0D0
        DO 90 I = 1,R
          S2R = S2R + X(I)**BETA
          S3R = S3R + (X(I)**BETA) *  DLOG(X(I))
          S4R = S4R + (X(I)**BETA) * ( DLOG(X(I))**2)
90      CONTINUE
        DO 95 I = 1,S
          S2S = S2S + Y(I)**BETA
          S3S = S3S + (Y(I)**BETA) *  DLOG(Y(I))
          S4S = S4S + (Y(I)**BETA) * ( DLOG(Y(I))**2)
95      CONTINUE
        T2 = S2R + S2S
        T3 = S3R + S3S
        T4 = S4R + S4S
        THETA = (T2 / DBLE(R))**(1.0D0 / BETA)
      END IF
C
C COMPUTE THE CONFIDENCE INTERVAL OF THE PARAMETERS
C THETA & BETA
C
      DEM1 = THETA**BETA
      DEM2 = THETA**(1.0D0 + BETA)
      DEM3 = THETA**(2.0D0 + BETA)
      L1 =  DLOG(THETA)
      L2 = ( DLOG(THETA))**2
      IB = DBLE(R) / BETA**2 + (L2 * T2 - 2.0D0 * L1 * T3 + T4)
     */ DEM1
      IT = (BETA * (BETA + 1.0D0) / DEM3 * T2) -
     *(DBLE(R) * BETA / THETA**2)
      COV = DBLE(R) / THETA - (T2 - BETA * L1 * T2 + BETA * T3) / DEM2
      CON = (IB *IT) - COV**2
      VARB = IT / CON
      VART = IB / CON
      COVBT = COV / CON
      DO500I=1,NLEV
        ALPHA = 1.0D0-((1.0D0 - LEVEL(I)) / 2.0D0)
        CALL NORPPF(REAL(ALPHA),ANORM)
        NORM=DBLE(ANORM)
        LOW1(I) = BETA - NORM * SQRT(VARB)
        UP1(I) = BETA + NORM * SQRT(VARB)
        LOW2(I) = THETA - NORM * SQRT(VART)
        UP2(I) = THETA + NORM * SQRT(VART)
  500 CONTINUE
c
      IF(IPRINT.EQ.'ON')THEN
CCCCC WRITE OUTPUT IN HTML FORMAT
      IF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'HTML')THEN
C
C  STEP 1: END ASIS MODE AND WRITE A HEADER
C
 5001   FORMAT('</PRE>')
 5002   FORMAT('<CENTER>')
 5003   FORMAT('<B>2-PARAMETER WEIBULL MAXIMUM LIKELIHOOD</B>')
 5004   FORMAT('</CENTER>')
C5005   FORMAT('<BR><BR>')
        WRITE(ICOUT,5001)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5002)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5003)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5004)
        CALL DPWRST('XXX','WRIT')
CCCCC   WRITE(ICOUT,5005)
CCCCC   CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
C
C  STEP 2: START TABLE AND DEFINE A CAPTION
C
 5011   FORMAT('<UL>')
 5013   FORMAT('<TABLE NOBORDER>')
        WRITE(ICOUT,5011)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5013)
        CALL DPWRST('XXX','WRIT')
C
C  STEP 4: DEFINE DATA ROW
C
 5041   FORMAT('   <TR>')
 5043   FORMAT('      <TD ALIGN=LEFT VALIGN=BOTTOM WIDTH=300>')
 5047   FORMAT('      </TD>')
 5049   FORMAT('      <TD ALIGN=RIGHT VALIGN=BOTTOM WIDTH=200>')
 5051   FORMAT('         ',G15.7)
 5053   FORMAT('         ',I8)
 5055   FORMAT('          &nbsp;')
 5059   FORMAT('   </TR>')
 5061   FORMAT('         Full Sample Case')
 5062   FORMAT('         Singly Censored Case')
 5063   FORMAT('         Multiply Censored Case')
 5064   FORMAT('         Sample Size:')
 5065   FORMAT('         Estimate for Shape Parameter Gamma:')
 5066   FORMAT('         Standard Error for Shape Parameter Gamma:')
 5067   FORMAT('         Estimate for Scale Parameter Beta:')
 5068   FORMAT('         Standard Error for Scale Parameter Beta:')
 5069   FORMAT('         Number of Failures:')
 5070   FORMAT('         Number of Non-Failures:')
C
        WRITE(ICOUT,5041)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5043)
        CALL DPWRST('XXX','WRIT')
        IF(CASE.EQ.1)THEN
          WRITE(ICOUT,5063)
        ELSEIF(CASE.EQ.2)THEN
          WRITE(ICOUT,5062)
        ELSE
          WRITE(ICOUT,5061)
        ENDIF
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5047)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5049)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5055)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5047)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5059)
        CALL DPWRST('XXX','WRIT')
C
        IF(CASE.LT.3)THEN
          WRITE(ICOUT,5041)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5043)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5069)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5047)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5049)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5053)R
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5047)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5059)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5041)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5043)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5070)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5047)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5049)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5053)S
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5047)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5059)
          CALL DPWRST('XXX','WRIT')
        ENDIF
C
        WRITE(ICOUT,5041)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5043)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5064)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5047)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5049)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5053)N
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5047)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5059)
        CALL DPWRST('XXX','WRIT')
C
        WRITE(ICOUT,5041)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5043)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5065)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5047)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5049)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5051)BETA
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5047)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5059)
        CALL DPWRST('XXX','WRIT')
C
        WRITE(ICOUT,5041)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5043)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5066)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5047)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5049)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5051)SQRT(VARB)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5047)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5059)
        CALL DPWRST('XXX','WRIT')
C
        WRITE(ICOUT,5041)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5043)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5067)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5047)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5049)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5051)THETA
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5047)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5059)
        CALL DPWRST('XXX','WRIT')
C
        WRITE(ICOUT,5041)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5043)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5068)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5047)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5049)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5051)SQRT(VART)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5047)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5059)
        CALL DPWRST('XXX','WRIT')
C
C  STEP 4: END THE TABLE AND RESET ASIS MODE
C
 5091   FORMAT('</TABLE>')
 5093   FORMAT('</UL>')
        WRITE(ICOUT,5091)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5093)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
C
C  STEP 2: START TABLE AND DEFINE A CAPTION
C
 5111   FORMAT('<UL>')
 5113   FORMAT('<TABLE WIDTH=500 NOBORDER>')
 5115   FORMAT('   <CAPTION ALIGN=CENTER>')
 5117   FORMAT('      <B>Confidence Limits for the Shape ',
     1         'Parameter Gamma</B>')
 5119   FORMAT('   </CAPTION>')
        WRITE(ICOUT,5111)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5113)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5115)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5117)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5119)
        CALL DPWRST('XXX','WRIT')
C
C  STEP 3: DEFINE HEADER ROW
C
 5121   FORMAT('   <TR>')
 5123   FORMAT('      <TH ALIGN=RIGHT VALIGN=BOTTOM WIDTH=33%>')
 5125   FORMAT('         Confidence<br>Value (%)')
 5126   FORMAT('         Lower<br>Limit')
 5128   FORMAT('         Upper<br>Limit')
 5127   FORMAT('      </TH>')
 5131   FORMAT('         ',G15.7)
 5133   FORMAT('         ',I8)
 5135   FORMAT('         ',A8)
 5137   FORMAT('   </TR>')
 5138   FORMAT('      <TD COLSPAN=3>')
 5139   FORMAT('          <HR>')
C
        WRITE(ICOUT,5121)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5123)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5125)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5127)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5123)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5126)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5127)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5123)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5128)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5127)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5137)
        CALL DPWRST('XXX','WRIT')
C
C  FOLLOWING ADDS A RULE LINE BETWEEN HEADER AND DATA LINES
C
        WRITE(ICOUT,5121)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5138)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5139)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5147)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5137)
        CALL DPWRST('XXX','WRIT')
C
C  STEP 4: DEFINE DATA ROW
C
 5141   FORMAT('   <TR>')
 5143   FORMAT('      <TD ALIGN=RIGHT VALIGN=BOTTOM WIDTH=33%>')
 5147   FORMAT('      </TD>')
 5151   FORMAT('         ',G15.7)
 5159   FORMAT('   </TR>')
C
        DO5160I=1,6
          WRITE(ICOUT,5141)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5143)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5151)100*REAL(LEVEL(I))
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5147)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5143)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5151)REAL(LOW1(I))
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5147)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5143)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5151)REAL(UP1(I))
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5147)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5159)
          CALL DPWRST('XXX','WRIT')
 5160   CONTINUE
C
C  STEP 4: END THE TABLE AND RESET ASIS MODE
C
 5191   FORMAT('</TABLE>')
 5193   FORMAT('</UL>')
        WRITE(ICOUT,5191)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5193)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
C
C
C  STEP 2: START TABLE AND DEFINE A CAPTION
C
 5211   FORMAT('<UL>')
 5213   FORMAT('<TABLE WIDTH=500 NOBORDER>')
 5215   FORMAT('   <CAPTION ALIGN=CENTER>')
 5217   FORMAT('      <B>Confidence Limits for the Scale ',
     1         'Parameter Beta</B>')
 5219   FORMAT('   </CAPTION>')
        WRITE(ICOUT,5211)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5213)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5215)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5217)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5219)
        CALL DPWRST('XXX','WRIT')
C
C  STEP 3: DEFINE HEADER ROW
C
 5221   FORMAT('   <TR>')
 5223   FORMAT('      <TH ALIGN=RIGHT VALIGN=BOTTOM WIDTH=33%>')
 5225   FORMAT('         Confidence<br>Value (%)')
 5226   FORMAT('         Lower<br>Limit')
 5228   FORMAT('         Upper<br>Limit')
 5227   FORMAT('      </TH>')
 5231   FORMAT('         ',G15.7)
 5233   FORMAT('         ',I8)
 5235   FORMAT('         ',A8)
 5237   FORMAT('   </TR>')
 5238   FORMAT('      <TD COLSPAN=3>')
 5239   FORMAT('          <HR>')
C
        WRITE(ICOUT,5221)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5223)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5225)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5227)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5223)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5226)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5227)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5223)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5228)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5227)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5237)
        CALL DPWRST('XXX','WRIT')
C
C  FOLLOWING ADDS A RULE LINE BETWEEN HEADER AND DATA LINES
C
        WRITE(ICOUT,5221)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5238)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5239)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5247)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5237)
        CALL DPWRST('XXX','WRIT')
C
C  STEP 4: DEFINE DATA ROW
C
 5241   FORMAT('   <TR>')
 5243   FORMAT('      <TD ALIGN=RIGHT VALIGN=BOTTOM WIDTH=33%>')
 5247   FORMAT('      </TD>')
 5251   FORMAT('         ',G15.7)
 5259   FORMAT('   </TR>')
C
        DO5260I=1,6
          WRITE(ICOUT,5241)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5243)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5251)100*REAL(LEVEL(I))
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5247)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5243)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5251)REAL(LOW2(I))
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5247)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5243)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5251)REAL(UP2(I))
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5247)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5259)
          CALL DPWRST('XXX','WRIT')
 5260   CONTINUE
C
C  STEP 4: END THE TABLE AND RESET ASIS MODE
C
 5291   FORMAT('</TABLE>')
 5293   FORMAT('</UL>')
 5299   FORMAT('<PRE>')
        WRITE(ICOUT,5291)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5293)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5299)
        CALL DPWRST('XXX','WRIT')
C
CCCCC WRITE OUTPUT IN LATEX FORMAT
      ELSEIF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'LATE')THEN
C
C  STEP 1: END ASIS FORMAT, START TABLE ENVIRONMENT, WRITE A HEADER, AND
C          WRITE A TABLE CAPTION
C
 8001 FORMAT(A1,'end{verbatim}')
 8003 FORMAT(A1,'begin{table}')
 8007 FORMAT(5X,'$ ',A1,1X,A1,' $ ',A1,A1,' ')
 8009 FORMAT(A1,'begin{center}')
 8011 FORMAT(5X,'{',A1,'bf 2-Parameter Weibull Maximum Likelihood ',
     1       'Estimation}')
 8013 FORMAT(A1,'end{center}')
 8015 FORMAT(5X,'} ',A1,A1)
C
        CALL DPCONA(92,IBASLC)
C
        WRITE(ICOUT,8001)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8003)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8009)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8011)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8007)IBASLC,IBASLC,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8007)IBASLC,IBASLC,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8013)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
C
C STEP 2: START TABULAR ENVIRONMENT, WRITE SUBSESQUENT ROWS, END
C         TABULAR ENVIRONMENT
C
 8020 FORMAT(5X,A1,'begin{tabular} {lr}')
 8021 FORMAT(5X,'Full Sample Case & ',2X,A1,A1)
 8022 FORMAT(5X,'Singly Censored Case & ',2X,A1,A1)
 8023 FORMAT(5X,'Multiply Censored Case & ',2X,A1,A1)
 8024 FORMAT(5X,'Number of Observations: & ',I8,2X,A1,A1)
 8025 FORMAT(5X,'Estimate for the Shape Parameter $',A1,'gamma$: & ',
     1       G15.7,2X,A1,A1)
 8026 FORMAT(5X,'Standard Error for the Shape Parameter $',A1,
     1       'gamma$: & ',G15.7,2X,A1,A1)
 8027 FORMAT(5X,'Estimate for the Scale Parameter $',A1,'beta$: & ',
     1       G15.7,2X,A1,A1)
 8028 FORMAT(5X,'Standard Error for the Scale Parameter $',A1,
     1       'beta$: & ',G15.7,2X,A1,A1)
 8029 FORMAT(5X,'Number of Failures: & ',I8,2X,A1,A1)
 8030 FORMAT(5X,'Number of Non-Failures: & ',I8,2X,A1,A1)
 8040 FORMAT(5X,A1,'hline')
 8049 FORMAT(A1,'end{tabular}')
        WRITE(ICOUT,8009)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8020)IBASLC
        CALL DPWRST('XXX','WRIT')
        IF(CASE.EQ.1)THEN
          WRITE(ICOUT,8023)IBASLC,IBASLC
        ELSEIF(CASE.EQ.2)THEN
          WRITE(ICOUT,8022)IBASLC,IBASLC
        ELSE
          WRITE(ICOUT,8021)IBASLC,IBASLC
        ENDIF
        CALL DPWRST('XXX','WRIT')
        IF(CASE.LT.3)THEN
          WRITE(ICOUT,8029)R,IBASLC,IBASLC
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,8030)S,IBASLC,IBASLC
          CALL DPWRST('XXX','WRIT')
        ENDIF
        WRITE(ICOUT,8024)N,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8025)IBASLC,BETA,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8026)IBASLC,SQRT(VARB),IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8027)IBASLC,THETA,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8028)IBASLC,SQRT(VART),IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8049)IBASLC
        CALL DPWRST('XXX','WRIT')
C
C STEP 3: END TABLE ENVIRONMENT, RESET ASIS MODE
C
 8091 FORMAT(A1,'end{center}')
 8093 FORMAT(A1,'end{table}')
        WRITE(ICOUT,8091)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8093)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
C
 8103 FORMAT(A1,'begin{table}')
 8107 FORMAT(5X,'$ ',A1,1X,A1,' $ ',A1,A1,' ')
 8109 FORMAT(A1,'begin{center}')
 8111 FORMAT(5X,'{',A1,'bf Confidence Limits for the Shape ',
     1       'Parameter $',A1,'gamma$}')
 8113 FORMAT(A1,'end{center}')
 8115 FORMAT(5X,'} ',A1,A1)
C
        WRITE(ICOUT,8103)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8109)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8111)IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8107)IBASLC,IBASLC,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8107)IBASLC,IBASLC,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8113)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
C
C STEP 2: START TABULAR ENVIRONMENT, WRITE SUBSESQUENT ROWS, END
C         TABULAR ENVIRONMENT
C
 8120 FORMAT(5X,A1,'begin{tabular} {rrr}')
 8121 FORMAT(5X,'Confidence & Lower & Upper ',2X,A1,A1)
 8122 FORMAT(5X,'Limits (',A1,'%) & Limit & Limits ',2X,A1,A1)
 8123 FORMAT(5X,G15.7,' & ',G15.7, ' & ',G15.7,2X,A1,A1)
 8140 FORMAT(5X,A1,'hline')
 8149 FORMAT(A1,'end{tabular}')
C
        WRITE(ICOUT,8109)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8120)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8121)IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8122)IBASLC,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8140)IBASLC
        CALL DPWRST('XXX','WRIT')
        DO8130I=1,6
          WRITE(ICOUT,8123)100.*REAL(LEVEL(I)),REAL(LOW1(I)),
     1                     REAL(UP1(I)),IBASLC,IBASLC
          CALL DPWRST('XXX','WRIT')
 8130   CONTINUE
        WRITE(ICOUT,8149)IBASLC
        CALL DPWRST('XXX','WRIT')
C
C STEP 3: END TABLE ENVIRONMENT, RESET ASIS MODE
C
 8191 FORMAT(A1,'end{center}')
 8193 FORMAT(A1,'end{table}')
        WRITE(ICOUT,8191)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8193)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
C
 8203 FORMAT(A1,'begin{table}')
 8207 FORMAT(5X,'$ ',A1,1X,A1,' $ ',A1,A1,' ')
 8209 FORMAT(A1,'begin{center}')
 8211 FORMAT(5X,'{',A1,'bf Confidence Limits for the Scale ',
     1       'Parameter $',A1,'beta$}')
 8213 FORMAT(A1,'end{center}')
 8215 FORMAT(5X,'} ',A1,A1)
C
        WRITE(ICOUT,8203)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8209)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8211)IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8207)IBASLC,IBASLC,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8207)IBASLC,IBASLC,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8213)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
C
C STEP 2: START TABULAR ENVIRONMENT, WRITE SUBSESQUENT ROWS, END
C         TABULAR ENVIRONMENT
C
 8220 FORMAT(5X,A1,'begin{tabular} {rrr}')
 8221 FORMAT(5X,'Confidence & Lower & Upper ',2X,A1,A1)
 8222 FORMAT(5X,'Limits (',A1,'%) & Limit & Limits ',2X,A1,A1)
 8223 FORMAT(5X,G15.7,' & ',G15.7, ' & ',G15.7,2X,A1,A1)
 8240 FORMAT(5X,A1,'hline')
 8249 FORMAT(A1,'end{tabular}')
C
        WRITE(ICOUT,8209)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8220)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8221)IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8222)IBASLC,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8240)IBASLC
        CALL DPWRST('XXX','WRIT')
        DO8230I=1,6
          WRITE(ICOUT,8223)100.*REAL(LEVEL(I)),REAL(LOW2(I)),
     1                     REAL(UP2(I)),IBASLC,IBASLC
          CALL DPWRST('XXX','WRIT')
 8230   CONTINUE
        WRITE(ICOUT,8249)IBASLC
        CALL DPWRST('XXX','WRIT')
C
C STEP 3: END TABLE ENVIRONMENT, RESET ASIS MODE
C
 8291 FORMAT(A1,'end{center}')
 8293 FORMAT(A1,'end{table}')
 8299 FORMAT(A1,'begin{verbatim}')
        WRITE(ICOUT,8291)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8293)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8299)IBASLC
        CALL DPWRST('XXX','WRIT')
C
      ELSEIF(ICAPTY.EQ.'RTF')THEN
C
C
      ELSE
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,300)
        CALL DPWRST('XXX','WRIT')
  300   FORMAT('2-PARAMETER WEIBULL MAXIMUM LIKELIHOOD ESTIMATION')
        IF (CASE .EQ. 1) THEN
          WRITE(ICOUT,301)
          CALL DPWRST('XXX','WRIT')
        ELSE IF (CASE .EQ. 2) THEN
          WRITE(ICOUT,302)
          CALL DPWRST('XXX','WRIT')
        ELSE IF (CASE .EQ. 3) THEN
          WRITE(ICOUT,303)
          CALL DPWRST('XXX','WRIT')
        ENDIF
  301   FORMAT('MULTIPLY CENSORED CASE')
  302   FORMAT('SINGLY CENSORED CASE')
  303   FORMAT('FULL SAMPLE CASE')
        WRITE(ICOUT,310)N
        CALL DPWRST('XXX','WRIT')
  310   FORMAT('SAMPLE SIZE             = ',I8)
        IF(CASE.LT.3)THEN
          WRITE(ICOUT,320)R
          CALL DPWRST('XXX','WRIT')
  320     FORMAT('NUMBER OF FAILURES      = ',I8)
          WRITE(ICOUT,330)S
          CALL DPWRST('XXX','WRIT')
  330     FORMAT('NUMBER OF NON-FAILURES  = ',I8)
        ENDIF
C
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,605)BETA
  605   FORMAT(
     1  'ESTIMATE FOR SHAPE PARAMETER GAMMA           = ',G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,608)SQRT(VARB)
  608   FORMAT(
     1  'STANDARD ERROR FOR SHAPE PARAMETER GAMMA     = ',G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,610)
        CALL DPWRST('XXX','WRIT')
  610   FORMAT(
     1  '   CONFIDENCE           LOWER         UPPER')
        WRITE(ICOUT,620)
  620   FORMAT(
     1  '   VALUE (%)            LIMIT         LIMIT')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,630)
  630   FORMAT(
     1  '---------------------------------------------------')
        CALL DPWRST('XXX','WRIT')
        DO640I=1,6
          WRITE(ICOUT,641)100*REAL(LEVEL(I)),REAL(LOW1(I)),
     1                    REAL(UP1(I))
  641     FORMAT('   ',F8.3,10X,3(G12.6,2X))
          CALL DPWRST('XXX','WRIT')
  640   CONTINUE
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
C
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,655)THETA
  655   FORMAT(
     1  'ESTIMATE FOR SCALE PARAMETER BETA      = ',G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,658)SQRT(VART)
  658   FORMAT(
     1  'STANDARD ERROR FOR SCALE PARAMETER BETA      = ',G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,660)
        CALL DPWRST('XXX','WRIT')
  660   FORMAT(
     1  '   CONFIDENCE           LOWER         UPPER')
        WRITE(ICOUT,670)
  670   FORMAT(
     1  '   VALUE (%)            LIMIT         LIMIT')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,630)
        CALL DPWRST('XXX','WRIT')
        DO680I=1,6
          WRITE(ICOUT,681)100*REAL(LEVEL(I)),REAL(LOW2(I)),
     1                    REAL(UP2(I))
  681   FORMAT('   ',F8.3,10X,2(G12.6,2X))
        CALL DPWRST('XXX','WRIT')
  680   CONTINUE
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
      ENDIF
      ENDIF
C
 9000 CONTINUE
      SCALE=REAL(THETA)
      SHAPE=REAL(BETA)
      RETURN
      END
      DOUBLE PRECISION FUNCTION WEIFUN (GHAT,X)
C
C     PURPOSE--THIS ROUTINE IS USED IN FINDING THE MAXIMUM LIKELIHOOD
C              ESTIMATE OF GAMMA FOR THE 2-PARAMETER WEIBULL
C              MODEL FOR FULL SAMPLE DATA (NO CENSORING).  THIS
C              FUNCTION FINDS THE ROOT OF THE EQUATION:
C
C                 (1/GHAT) -
C                 SUM[i=1 to n][Y(I)**GHAT*LN(Y(I))]/
C                 SUM[i=1 to n][[Y(I)**GHAT] +
C                 (1/N)*SUM[i=1 to n][LN(Y(I))] = 0
C
C              WITH
C
C                 GHAT     = POINT ESTIMATE OF GAMMA (THIS IS THE
C                            PARAMETER WE ARE ITERATING OVER)
C
C              NOTE THAT THE THIRD TERM DDOES NOT DEPENDE ON GHAT,
C              SO THIS IS A CONSTANT.  FOR EFFICIENCY, SAVE THIS AS
C              A CONSTANT IN A COMMON BLOCK.
C
C              CALLED BY DFZER2 ROUTINE FOR FINDING THE ROOT OF A
C              FUNCTION.
C     EXAMPLE--WEIBULL MAXIMUM LIKELIHOOD Y
C     REFERENCE--KARL BURY, "STATISTICAL DISTRIBUTIONS IN
C                ENGINEERING", CAMBRIDGE UNIVERSITY PRESS,
C                1999, CHAPTER 17.
C              --JOHNSON, KOTZ, AND BALAKRISNAN, "CONTINUOUS
C                UNIVARIATE DISTRIBUTIONS--VOLUME 1", SECOND EDITION,
C                WILEY, 1994, CHAPTER xx.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBUG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004/11
C     ORIGINAL VERSION--NOVEMBER   2004.
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION GHAT
      DOUBLE PRECISION X(*)
C
      INTEGER IN 
      DOUBLE PRECISION DWEISM
      COMMON/WEICOM/DWEISM,IN
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DSUM2
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DX1
      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  COMPUTE SOME SUMS
C
      DSUM1=0.0D0
      DSUM2=0.0D0
      DG=GHAT
C
      DTERM1=1.0D0/DG
      DO100I=1,IN
        DX1=X(I)
        DSUM1=DSUM1 + (DX1**DG)*DLOG(DX1)
        DSUM2=DSUM2 + DX1**DG
  100 CONTINUE
      DTERM2=DSUM1/DSUM2
C
      WEIFUN=DTERM1 - DTERM2 + DWEISM
C
      RETURN
      END
      DOUBLE PRECISION FUNCTION WEIFU2 (DA,DX)
C
C     PURPOSE--THIS ROUTINE IS USED IN FINDING THE LIKELIHOOD RATIO
C              BASED CONFIDECE INTERVAL FOR THE 2-PARAMETER WEIBULL
C              MODEL (FULL SAMPLE).  THIS FUNCTION FINDS THE ROOT
C              OF THE EQUATION:
C
C                 2*LL(ALPHA,GAMMA) - 2*LL(S(a),,a) - CHSPPF(alpha,1)
C
C              WITH
C
C                 LL(ALPHA,GAMMA) = N*LN(GAMMA) - N*GAMMA*LN(ALPHA) +
C                          (GAMMA-1)*SUM[i=1 to n][LN(X(i))] -
C                          ALPHA**(-GAMMA)*SUM[i=1 to n][(X(i)**GAMA]
C                 ALPHA    = POINT ESTIMATE OF SCALE PARAMETER
C                 GAMMA    = POINT ESTIMATE OF SHAPE PARAMETER
C                 A        = PARAMETER WE ARE FINDING ROOT FOR
C                 K        = CHSPPF(ALPHA,1) (HERE, ALPHA IS THE
C                            SIGNIFICANCE LEVEL, NOT THE SCALE PARAMETER)
C
C              NOTE THAT QUANTITIES THAT DO NOT DEPEND ON A ARE
C              COMPUTED ONCE IN DPMLW1 AND PASSED VIA COMMON BLOCK.
C
C              CALLED BY DFZER2 ROUTINE FOR FINDING THE ROOT OF A
C              FUNCTION.  DFZER2 IS MODIFIED VERSION OF DFZERO THAT
C              PASSES ALONG THE DATA ARRAY.
C
C     EXAMPLE--WEIBULL MAXIMUM LIKELIHOOD Y
C     REFERENCE--KARL BURY, "STATISTICAL DISTRIBUTIONS IN ENGINEERING",
C                CAMBRIDGE UNIVERSITY PRESS, 1999, CHAPTER 17 (SEE
C                EXAMPLE 12.4).
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBUG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004/11
C     ORIGINAL VERSION--NOVEMBER   2004.
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DA
      DOUBLE PRECISION DX(*)
C
      DOUBLE PRECISION DK
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      COMMON/WEICO2/DK,DTERM1,DTERM2,N
C
      DOUBLE PRECISION DN
      DOUBLE PRECISION DG
      DOUBLE PRECISION DSCALE
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DTERM3
      DOUBLE PRECISION DTERM4
      DOUBLE PRECISION DTERM5
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C  COMPUTE SOME SUMS
C
      DN=DBLE(N)
      DG=DA
C
      DSUM1=0.0D0
      DO100I=1,N
        DSUM1=DSUM1 + DX(I)**DG
  100 CONTINUE
      DSCALE=(DSUM1/DN)**(1.0D0/DG)
C
      DTERM3=DN*DLOG(DG) - DN*DG*DLOG(DSCALE)
      DTERM4=(DG-1.0D0)*DTERM2
      DTERM5=DSCALE**(-DG)*DSUM1
C
      WEIFU2=DTERM1 - 2.0D0*(DTERM3 + DTERM4 - DTERM5) - DK
C
      RETURN
      END
      DOUBLE PRECISION FUNCTION WEIFU3 (DB,DX)
C
C     PURPOSE--THIS ROUTINE IS USED IN FINDING THE LIKELIHOOD RATIO
C              BASED CONFIDENCE INTERVAL FOR THE SCALE PARAMETER OF A
C              2-PARAMETER WEIBULL MODEL (FULL SAMPLE).  THIS FUNCTION
C              FINDS THE ROOT OF THE EQUATION:
C
C                 2*LL(ALPHA,GAMMA) - 2*LL(b,I(b)) - CHSPPF(alpha,1)
C
C              WITH
C
C                 LL(ALPHA,GAMMA) = N*LN(GAMMA) - N*GAMMA*LN(ALPHA) +
C                          (GAMMA-1)*SUM[i=1 to n][LN(X(i))] -
C                          ALPHA**(-GAMMA)*SUM[i=1 to n][(X(i)**GAMA]
C                 ALPHA    = POINT ESTIMATE OF SCALE PARAMETER
C                 GAMMA    = POINT ESTIMATE OF SHAPE PARAMETER
C                 B        = PARAMETER (SCALE) WE ARE FINDING ROOT FOR
C                 K        = CHSPPF(ALPHA,1) (HERE, ALPHA IS THE
C                            SIGNIFICANCE LEVEL, NOT THE SCALE
C                            PARAMETER)
C
C              NOTE THAT QUANTITIES THAT DO NOT DEPEND ON B ARE
C              COMPUTED ONCE IN DPMLW1 AND PASSED VIA COMMON BLOCK.
C
C              GIVEN A VALUE FOR THE SCALE PARAMETER (DB), WE NEED
C              TO CALL A ROOT FINDING ROUTINE TO DETERMINE THE VALUE
C              OF THE SHAPE PARAMETER (A).
C
C              CALLED BY DFZER2 ROUTINE FOR FINDING THE ROOT OF A
C              FUNCTION.  DFZER2 IS MODIFIED VERSION OF DFZERO THAT
C              PASSES ALONG THE DATA ARRAY.
C
C     EXAMPLE--WEIBULL MAXIMUM LIKELIHOOD Y
C     REFERENCE--KARL BURY, "STATISTICAL DISTRIBUTIONS IN ENGINEERING",
C                CAMBRIDGE UNIVERSITY PRESS, 1999, CHAPTER 17 (SEE
C                EXAMPLE 17.7).
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBUG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004/11
C     ORIGINAL VERSION--NOVEMBER   2004.
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DB
      DOUBLE PRECISION DX(*)
C
      DOUBLE PRECISION DK
      DOUBLE PRECISION DTERM6
      DOUBLE PRECISION DTERM7
      DOUBLE PRECISION DGAMMA
      COMMON/WEICO3/DK,DTERM6,DTERM7,DGAMMA,N
C
      DOUBLE PRECISION DBTEMP
      COMMON/WEICO4/DBTEMP,N2
C
      DOUBLE PRECISION AE
      DOUBLE PRECISION RE
      DOUBLE PRECISION XLOW
      DOUBLE PRECISION XUP
      DOUBLE PRECISION XSTRT
      DOUBLE PRECISION DA
      DOUBLE PRECISION DG
      DOUBLE PRECISION DN
      DOUBLE PRECISION DSCALE
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DTERM3
      DOUBLE PRECISION DTERM4
      DOUBLE PRECISION DTERM5
C
      DOUBLE PRECISION WEIFU4
      EXTERNAL WEIFU4
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C  STEP 1: GIVEN VALUE OF SCALE PARAMETER (DB), NEED TO COMPUTE
C          THE SHAPE PARAMETER (WHICH IN TURN INVOLVES FINDING A
C          ROOT).

      N2=N
      DBTEMP=DB
      AE=1.D-7
      RE=1.D-7
      XSTRT=DGAMMA
      XLOW=XSTRT/5.0D0
      XUP=XSTRT*5.0D0
      CALL DFZER3(WEIFU4,XLOW,XUP,XSTRT,RE,AE,IFLAG,DX)
      DA=XLOW
C
C  COMPUTE SOME SUMS
C
      DN=DBLE(N)
      DG=DA
      DSCALE=DB
C
      DSUM1=0.0D0
      DO100I=1,N
        DSUM1=DSUM1 + DX(I)**DG
  100 CONTINUE
C
      DTERM3=DN*DLOG(DG) - DN*DG*DLOG(DSCALE)
      DTERM4=(DG-1.0D0)*DTERM7
      DTERM5=DSCALE**(-DG)*DSUM1
C
      WEIFU3=DTERM6 - 2.0D0*(DTERM3 + DTERM4 - DTERM5) - DK
C
      RETURN
      END
      DOUBLE PRECISION FUNCTION WEIFU4 (DA,DX)
C
C     PURPOSE--THIS ROUTINE IS USED IN FINDING THE LIKELIHOOD RATIO
C              BASED CONFIDENCE INTERVAL FOR THE SCALE PARAMETER OF
C              THE 2-PARAMETER WEIBULL MODEL (FULL SAMPLE).
C              SPECIFICALLY, IT IS USED TO DETERMINE AN ESTIMATE
C              OF THE SHAPE PARAMETER GIVEN A VALUE OF THE SCALE
C              PARAMETER.  IT FINDS THE ROOT OF THE FOLLOWING
C              EQUATION:
C
C                 (N/A) - N*LOG(B) + SUM[LOG(X)] -
C                       SUM[(X/B)**A*LOG)X/B)]
C
C              WITH A DENOTING THE SHAPE PARAMETER, B THE SCALE
C              PARAMETER, AND THE ROOT IS WITH RESPECT TO A.
C
C              CALLED BY DFZER3 ROUTINE FOR FINDING THE ROOT OF A
C              FUNCTION.  DFZER3 IS MODIFIED VERSION OF DFZERO THAT
C              PASSES ALONG THE DATA ARRAY.
C
C     EXAMPLE--WEIBULL MAXIMUM LIKELIHOOD Y
C     REFERENCE--KARL BURY, "STATISTICAL DISTRIBUTIONS IN ENGINEERING",
C                CAMBRIDGE UNIVERSITY PRESS, 1999, CHAPTER 17 (SEE
C                EXAMPLE 17.7).
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBUG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004/11
C     ORIGINAL VERSION--NOVEMBER   2004.
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DA
      DOUBLE PRECISION DX(*)
C
      DOUBLE PRECISION DB
      COMMON/WEICO4/DB,N
C
      DOUBLE PRECISION DN
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DSUM2
      DOUBLE PRECISION DTERM1
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C  COMPUTE SOME SUMS
C
      DN=DBLE(N)
      DTERM1=(DN/DA) - DN*DLOG(DB)
C
      DSUM1=0.0D0
      DSUM2=0.0D0
      DO100I=1,N
        DSUM1=DSUM1 + DLOG(DX(I))
        DSUM2=DSUM2 + ((DX(I)/DB)**DA)*DLOG(DX(I)/DB)
  100 CONTINUE
C
      WEIFU4=DTERM1 + DSUM1 - DSUM2
C
      RETURN
      END
      DOUBLE PRECISION FUNCTION WEIFU5 (DA,DX)
C
C     PURPOSE--THIS ROUTINE IS USED IN FINDING THE LIKELIHOOD RATIO
C              BASED CONFIDECE INTERVAL FOR THE 2-PARAMETER WEIBULL
C              MODEL (FULL SAMPLE).  THIS FUNCTION FINDS THE ROOT
C              OF THE EQUATION:
C
C                 2*LL(ALPHA,GAMMA) - 2*LL(S(a),,a) - CHSPPF(alpha,1)
C
C              WITH
C
C                 LL(ALPHA,GAMMA) = N*LN(GAMMA) - N*GAMMA*LN(ALPHA) +
C                          (GAMMA-1)*SUM[i=1 to n][LN(X(i))] -
C                          ALPHA**(-GAMMA)*SUM[i=1 to n][(X(i)**GAMA]
C                 ALPHA    = POINT ESTIMATE OF SCALE PARAMETER
C                 GAMMA    = POINT ESTIMATE OF SHAPE PARAMETER
C                 A        = PARAMETER WE ARE FINDING ROOT FOR
C                 K        = CHSPPF(ALPHA,1) (HERE, ALPHA IS THE
C                            SIGNIFICANCE LEVEL, NOT THE SCALE PARAMETER)
C
C              NOTE THAT QUANTITIES THAT DO NOT DEPEND ON A ARE
C              COMPUTED ONCE IN DPMLW1 AND PASSED VIA COMMON BLOCK.
C
C              CALLED BY DFZER2 ROUTINE FOR FINDING THE ROOT OF A
C              FUNCTION.  DFZER2 IS MODIFIED VERSION OF DFZERO THAT
C              PASSES ALONG THE DATA ARRAY.
C
C     EXAMPLE--WEIBULL MAXIMUM LIKELIHOOD Y X
C     REFERENCE--KARL BURY, "STATISTICAL DISTRIBUTIONS IN ENGINEERING",
C                CAMBRIDGE UNIVERSITY PRESS, 1999, CHAPTER 17 (SEE
C                EXAMPLE 12.4).
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBUG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004/11
C     ORIGINAL VERSION--NOVEMBER   2004.
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DA
      DOUBLE PRECISION DX(*)
C
      DOUBLE PRECISION DK
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      COMMON/WEICO5/DK,DTERM1,DTERM2,N,IR
C
      DOUBLE PRECISION DN
      DOUBLE PRECISION DR
      DOUBLE PRECISION DG
      DOUBLE PRECISION DSCALE
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DTERM3
      DOUBLE PRECISION DTERM4
      DOUBLE PRECISION DTERM5
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C  COMPUTE SOME SUMS
C
      DN=DBLE(N)
      DR=DBLE(IR)
      DG=DA
C
      DSUM1=0.0D0
      DO100I=1,N
        DSUM1=DSUM1 + DX(I)**DG
  100 CONTINUE
      DSCALE=(DSUM1/DR)**(1.0D0/DG)
C
      DTERM3=DR*DLOG(DG) - DR*DG*DLOG(DSCALE)
      DTERM4=(DG-1.0D0)*DTERM2
      DTERM5=DSCALE**(-DG)*DSUM1
C
      WEIFU5=DTERM1 - 2.0D0*(DTERM3 + DTERM4 - DTERM5) - DK
C
      RETURN
      END
      DOUBLE PRECISION FUNCTION WEIFU6 (DB,DX)
C
C     PURPOSE--THIS ROUTINE IS USED IN FINDING THE LIKELIHOOD RATIO
C              BASED CONFIDENCE INTERVAL FOR THE SCALE PARAMETER OF A
C              2-PARAMETER WEIBULL MODEL (TIME CENSORED).  THIS
C              FUNCTION FINDS THE ROOT OF THE EQUATION:
C
C                 2*LL(ALPHA,GAMMA) - 2*LL(b,I(b)) - CHSPPF(alpha,1)
C
C              WITH
C
C                 LL(ALPHA,GAMMA) = N*LN(GAMMA) - N*GAMMA*LN(ALPHA) +
C                          (GAMMA-1)*SUM[i=1 to n][LN(X(i))] -
C                          ALPHA**(-GAMMA)*SUM[i=1 to n][(X(i)**GAMA]
C                 ALPHA    = POINT ESTIMATE OF SCALE PARAMETER
C                 GAMMA    = POINT ESTIMATE OF SHAPE PARAMETER
C                 B        = PARAMETER (SCALE) WE ARE FINDING ROOT FOR
C                 K        = CHSPPF(ALPHA,1) (HERE, ALPHA IS THE
C                            SIGNIFICANCE LEVEL, NOT THE SCALE
C                            PARAMETER)
C
C              NOTE THAT QUANTITIES THAT DO NOT DEPEND ON B ARE
C              COMPUTED ONCE IN DPMLW2 AND PASSED VIA COMMON BLOCK.
C
C              GIVEN A VALUE FOR THE SCALE PARAMETER (DB), WE NEED
C              TO CALL A ROOT FINDING ROUTINE TO DETERMINE THE VALUE
C              OF THE SHAPE PARAMETER (A).
C
C              CALLED BY DFZER2 ROUTINE FOR FINDING THE ROOT OF A
C              FUNCTION.  DFZER2 IS MODIFIED VERSION OF DFZERO THAT
C              PASSES ALONG THE DATA ARRAY.
C
C     EXAMPLE--WEIBULL MAXIMUM LIKELIHOOD Y X
C     REFERENCE--KARL BURY, "STATISTICAL DISTRIBUTIONS IN ENGINEERING",
C                CAMBRIDGE UNIVERSITY PRESS, 1999, CHAPTER 17 (SEE
C                EXAMPLE 17.7).
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBUG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004/11
C     ORIGINAL VERSION--NOVEMBER   2004.
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DB
      DOUBLE PRECISION DX(*)
C
      DOUBLE PRECISION DK
      DOUBLE PRECISION DTERM6
      DOUBLE PRECISION DTERM7
      DOUBLE PRECISION DGAMMA
      COMMON/WEICO6/DK,DTERM6,DTERM7,DGAMMA,N,IR
C
      DOUBLE PRECISION DBTEMP
      COMMON/WEICO7/DBTEMP,N2,IR2
C
      DOUBLE PRECISION AE
      DOUBLE PRECISION RE
      DOUBLE PRECISION XLOW
      DOUBLE PRECISION XUP
      DOUBLE PRECISION XSTRT
      DOUBLE PRECISION DA
      DOUBLE PRECISION DG
      DOUBLE PRECISION DN
      DOUBLE PRECISION DR
      DOUBLE PRECISION DSCALE
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DTERM3
      DOUBLE PRECISION DTERM4
      DOUBLE PRECISION DTERM5
C
      EXTERNAL WEIFU7
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
      DBTEMP=DB
      AE=1.D-7
      RE=1.D-7
      XSTRT=DGAMMA
      XLOW=XSTRT/5.0D0
      XUP=XSTRT*5.0D0
      CALL DFZER3(WEIFU7,XLOW,XUP,XSTRT,RE,AE,IFLAG,DX)
      DA=XLOW
C
C  COMPUTE SOME SUMS
C
      DN=DBLE(N)
      DR=DBLE(IR)
      DG=DA
      DSCALE=DB
C
      DSUM1=0.0D0
      DO100I=1,N
        DSUM1=DSUM1 + DX(I)**DG
  100 CONTINUE
C
      DTERM3=DR*DLOG(DG) - DR*DG*DLOG(DSCALE)
      DTERM4=(DG-1.0D0)*DTERM7
      DTERM5=DSCALE**(-DG)*DSUM1
C
      WEIFU6=DTERM6 - 2.0D0*(DTERM3 + DTERM4 - DTERM5) - DK
C
      RETURN
      END
      DOUBLE PRECISION FUNCTION WEIFU7 (DA,DX)
C
C     PURPOSE--THIS ROUTINE IS USED IN FINDING THE LIKELIHOOD RATIO
C              BASED CONFIDENCE INTERVAL FOR THE SCALE PARAMETER OF
C              THE 2-PARAMETER WEIBULL MODEL (FULL SAMPLE).
C              SPECIFICALLY, IT IS USED TO DETERMINE AN ESTIMATE
C              OF THE SHAPE PARAMETER GIVEN A VALUE OF THE SCALE
C              PARAMETER.  IT FINDS THE ROOT OF THE FOLLOWING
C              EQUATION:
C
C                 (N/A) - N*LOG(B) + SUM[LOG(X)] -
C                       SUM[(X/B)**A*LOG)X/B)]
C
C              WITH A DENOTING THE SHAPE PARAMETER, B THE SCALE
C              PARAMETER, AND THE ROOT IS WITH RESPECT TO A.
C
C              FOR CENSORED SAMPLES, RELACE N WITH R (= NUMBER OF
C              FAILURE TIMES).
C
C              CALLED BY DFZER3 ROUTINE FOR FINDING THE ROOT OF A
C              FUNCTION.  DFZER3 IS MODIFIED VERSION OF DFZERO THAT
C              PASSES ALONG THE DATA ARRAY.
C
C     EXAMPLE--WEIBULL MAXIMUM LIKELIHOOD Y X
C     REFERENCE--KARL BURY, "STATISTICAL DISTRIBUTIONS IN ENGINEERING",
C                CAMBRIDGE UNIVERSITY PRESS, 1999, CHAPTER 17 (SEE
C                EXAMPLE 17.7).
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBUG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004/11
C     ORIGINAL VERSION--NOVEMBER   2004.
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DA
      DOUBLE PRECISION DX(*)
C
      DOUBLE PRECISION DB
      COMMON/WEICO7/DB,N,IR
C
      DOUBLE PRECISION DR
      DOUBLE PRECISION DN
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DSUM2
      DOUBLE PRECISION DTERM1
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C  COMPUTE SOME SUMS
C
      DN=DBLE(N)
      DR=DBLE(IR)
      DTERM1=(DR/DA) - DR*DLOG(DB)
C
      DSUM1=0.0D0
      DSUM2=0.0D0
      DO100I=1,N
        DSUM1=DSUM1 + DLOG(DX(I))
        DSUM2=DSUM2 + ((DX(I)/DB)**DA)*DLOG(DX(I)/DB)
  100 CONTINUE
C
      WEIFU7=DTERM1 + DSUM1 - DSUM2
C
      RETURN
      END
      SUBROUTINE WEIGHH(IT,I1,I2,XS,N,XMAXHF,
     1WH,ISUBRO,IBUGA3,IERROR)
C     PURPOSE--DETERMINE THE HORIZONTAL WEIGHTS
C              WH(I1) THROUGH WH(I2).
C              THESE WILL BE THE WEIGHTS FOR THE NN = I2-I1+1 POINTS
C              OF THE NEIGHBORHOOD SURROUNDING POINT XS(IT).
C     NOTE--XS(IT) IS CONSIDERED A NEIGHBOR OF ITSELF.
C     NOTE--WEIGHT FUNCTION IS TRICUBE.
C     REFERENCE--CHAMBERS, ET AL.  GRAPHICAL METHODS FOR DATA ANALYSIS.
C                WADSWORTH, 1983, PAGES 94-98, 121-122.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--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 WH(*)
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='WEIG'
      ISUBN2='HH  '
C
      IERROR='NO'
C
      IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'IGHH')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF WEIGHH--')
      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
   53 FORMAT('IT,I1,I2,N = ',4I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,54)XMAXHF
   54 FORMAT('XMAXHF = ',E15.7)
      CALL DPWRST('XXX','BUG ')
   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 WEIGHH--')
      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 WEIGHH--')
      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 WEIGHH--')
      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
C               ***********************************************
C               **  STEP 11--                                **
C               **  COMPUTE THE  HORIZONTAL WEIGHTS FOR THE  **
C               **  NEIGHBORHOOD SUURROUNDING XS(IT)         **
C               ***********************************************
C
      IF(XMAXHF.LE.0.0)GOTO1190
C
      DO1100I=I1,I2
      U=(XS(I)-XS(IT))/XMAXHF
      U2=ABS(U)
      WH(I)=(1.0-U2**3)**3
 1100 CONTINUE
C
 1190 CONTINUE
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'IGHH')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF WEIGHH--')
      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
 9013 FORMAT('IT,I1,I2,N = ',4I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9014)XMAXHF
 9014 FORMAT('XMAXHF = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      DO9021I=I1,I2
      WRITE(ICOUT,9022)I,XS(I),WH(I)
 9022 FORMAT('I,XS(I),WH(I) = ',I8,2E15.7)
      CALL DPWRST('XXX','BUG ')
 9021 CONTINUE
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE WEIGHV(RES,N,XTEMP1,XTEMP2,MAXNXT,
     1WV,ISUBRO,IBUGA3,IERROR)
C     PURPOSE--DETERMINE THE N VERTICAL (ROBUST) WEIGHTS
C              WV(1) THROUGH WV(N)
C              BASED ON THE NATURE OF THE RESIDUALS IN RES(.).
C     NOTE--WEIGHT FUNCTION IS BIWEIGHT.
C     NOTE--IF ALL INPUT RESIDUALS ARE ZERO, THIS SUBROUTINE
C           WILL OUTPUT ALL WEIGHTS AS UNITY.
C     REFERENCE--CHAMBERS, ET AL.  GRAPHICAL METHODS FOR DATA ANALYSIS.
C                WADSWORTH, 11013, PAGES 98-101, 122-123.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--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 IWRITE
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DIMENSION RES(*)
      DIMENSION XTEMP1(*)
      DIMENSION XTEMP2(*)
      DIMENSION WV(*)
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='WEIG'
      ISUBN2='HV  '
C
      IERROR='NO'
C
      IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'IGHV')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF WEIGHV--')
      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)N
   53 FORMAT('N = ',I8)
      CALL DPWRST('XXX','BUG ')
      IF(N.LE.0)GOTO63
      DO61I=1,N
      WRITE(ICOUT,62)I,RES(I)
   62 FORMAT('I,RES(I) = ',I8,E15.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 WEIGHV--')
      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 VERTICAL (ROBUST) 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
C               ***********************************************
C               **  STEP 11--                                **
C               **  COMPUTE THE  VERTICAL (ROBUST) WEIGHTS   **
C               **  FOR THE FULL DATA SET--ALL N POINTS      **
C               ***********************************************
C
      DO1100I=1,N
      XTEMP1(I)=ABS(RES(I))
 1100 CONTINUE
C
      IWRITE='OFF'
      CALL MEDIAN(XTEMP1,N,IWRITE,XTEMP2,MAXNXT,AMEDAR,IBUGA3,IERROR)
C
      IF(AMEDAR.EQ.0.0)GOTO1110
      GOTO1120
C
 1110 CONTINUE
      CONST=(-999.0)
      DO1111I=1,N
      WV(I)=1.0
 1111 CONTINUE
      GOTO1190
C
 1120 CONTINUE
      CONST=6.0*AMEDAR
      DO1121I=1,N
      U=RES(I)/CONST
      WV(I)=0.0
      IF(-1.0.LE.U.AND.U.LE.1.0)WV(I)=(1.0-U**2)**2
 1121 CONTINUE
      GOTO1190
C
 1190 CONTINUE
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'IGHV')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF WEIGHV--')
      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)N
 9013 FORMAT('N = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9014)AMEDAR
 9014 FORMAT('AMEDAR = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      IF(N.LE.0)GOTO9023
      DO9021I=1,N
      WRITE(ICOUT,9022)I,RES(I),WV(I)
 9022 FORMAT('I,RES(I),WV(I) = ',I8,2E15.7)
      CALL DPWRST('XXX','BUG ')
 9021 CONTINUE
 9023 CONTINUE
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE WEICHA(X,GAMMA,MINMAX,HAZ)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE HAZARD
C              FUNCTION VALUE FOR THE WEIBULL
C              DISTRIBUTION WITH SINGLE PRECISION
C              TAIL LENGTH PARAMETER = GAMMA.
C              THERE ARE 2 SUCH WEIBULL FAMILIES--
C                 ONE FOR THE MIN ORDER STAT (THE USUAL) AND
C                 ONE FOR THE MAX ORDER STAT.
C              (SEE SARHAN & GREENBERG, PAGE 69)
C              THE WEIBULL TYPE IS SPECIFIED VIA   MINMAX
C              FOR MINMAX = 1  (FOR THE DEFAULT MINIMUM)
C                 THE 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              FOR MINMAX = 2 (FOR THE MAXIMUM),
C                 THE WEIBULL DISTRIBUTION USED
C                 HEREIN IS DEFINED FOR ALL NEGATIVE X,
C                 AND HAS THE PROBABILITY DENSITY FUNCTION
C                 F(X) = ...
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE CUMULATIVE HAZARD
C                                FUNCTION IS TO BE EVALUATED.
C                     --GAMMA  = THE SHAPE PARAMETER
C                                GAMMA SHOULD BE POSITIVE.
C                     --MINMAX = THE INTEGER VALUE
C                                IDENTIFYING THE
C                                CHOSEN WEIBULL DISTRIBUTION.
C                                1 = MIN, 2 = MAX.
C     OUTPUT ARGUMENTS--HAZ    = THE SINGLE PRECISION
C                                CUMULATIVE HAZARD FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION CUMULATIVE HAZARD
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--SARHAN & GREENBERG,
C                 CONTRIBUTIONS TO ORDER STATISTICS,
C                 1962, WILEY, PAGE 69.
C               --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1970, PAGES 250-271.
C               --HASTINGS AND PEACOCK, STATISTICAL
C                 DISTRIBUTIONS--A HANDBOOK FOR
C                 STUDENTS AND PRACTITIONERS, 1975,
C                 PAGE 124.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--98.4
C     ORIGINAL VERSION--APRIL     1998.
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      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)GOTO50
      GOTO90
   50 WRITE(ICOUT,15)
   15 FORMAT('***** FATAL ERROR--THE 2ND INPUT ARGUMENT TO THE ',
     1'WEICHA SUBROUTINE IS NON-POSITIVE *****')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)GAMMA
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
      CALL DPWRST('XXX','BUG ')
      HAZ=0.0
      RETURN
   90 CONTINUE
C
      IF(MINMAX.EQ.2)THEN
         IF(X.GT.0.0)THEN
            HAZ=0.0
         ELSE IF(X.EQ.0.0)THEN
            HAZ=0.0
         ELSE
            HAZ=(-X)**GAMMA
         ENDIF
C
      ELSE IF(MINMAX.EQ.1 .OR. MINMAX.EQ.0)THEN
         IF(X.LT.0.0)THEN
            HAZ=0.0
         ELSE IF(X.EQ.0.0)THEN
            HAZ=0.0
         ELSE
            HAZ=X**GAMMA
         ENDIF
      ELSE
         WRITE(ICOUT,1800)
 1800    FORMAT('*****ERROR IN WEICHA--MINMAX NOT 1 OR 2')
         CALL DPWRST('XXX','BUG ')
      ENDIF
C
      RETURN
      END
      SUBROUTINE WEIHAZ(X,GAMMA,MINMAX,HAZ)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE HAZARD
C              FUNCTION VALUE FOR THE WEIBULL
C              DISTRIBUTION WITH SINGLE PRECISION
C              TAIL LENGTH PARAMETER = GAMMA.
C              THERE ARE 2 SUCH WEIBULL FAMILIES--
C                 ONE FOR THE MIN ORDER STAT (THE USUAL) AND
C                 ONE FOR THE MAX ORDER STAT.
C              (SEE SARHAN & GREENBERG, PAGE 69)
C              THE WEIBULL TYPE IS SPECIFIED VIA   MINMAX
C              FOR MINMAX = 1  (FOR THE DEFAULT MINIMUM)
C                 THE 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              FOR MINMAX = 2 (FOR THE MAXIMUM),
C                 THE WEIBULL DISTRIBUTION USED
C                 HEREIN IS DEFINED FOR ALL NEGATIVE X,
C                 AND HAS THE PROBABILITY DENSITY FUNCTION
C                 F(X) = ...
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE HAZARD
C                                FUNCTION IS TO BE EVALUATED.
C                     --GAMMA  = THE SHAPE PARAMETER
C                                GAMMA SHOULD BE POSITIVE.
C                     --MINMAX = THE INTEGER VALUE
C                                IDENTIFYING THE
C                                CHOSEN WEIBULL DISTRIBUTION.
C                                1 = MIN, 2 = MAX.
C     OUTPUT ARGUMENTS--HAZ    = THE SINGLE PRECISION
C                                HAZARD FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION HAZARD
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--SARHAN & GREENBERG,
C                 CONTRIBUTIONS TO ORDER STATISTICS,
C                 1962, WILEY, PAGE 69.
C               --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1970, PAGES 250-271.
C               --HASTINGS AND PEACOCK, STATISTICAL
C                 DISTRIBUTIONS--A HANDBOOK FOR
C                 STUDENTS AND PRACTITIONERS, 1975,
C                 PAGE 124.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--98.4
C     ORIGINAL VERSION--APRIL     1998.
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      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)GOTO50
      GOTO90
   50 WRITE(ICOUT,15)
   15 FORMAT('***** FATAL ERROR--THE 2ND INPUT ARGUMENT TO THE ',
     1'WEIHAZ SUBROUTINE IS NON-POSITIVE *****')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)GAMMA
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
      CALL DPWRST('XXX','BUG ')
      HAZ=0.0
      RETURN
   90 CONTINUE
C
      IF(MINMAX.EQ.2)THEN
         IF(X.GT.0.0)THEN
            HAZ=0.0
         ELSE IF(X.EQ.0.0)THEN
            IF(GAMMA.EQ.1.0)THEN
              HAZ=1.0
            ELSEIF(GAMMA.LT.1.0)THEN
              HAZ=0.0
              WRITE(ICOUT,1700)
              CALL DPWRST('XXX','BUG ')
            ELSEIF(GAMMA.GT.1.0)THEN
              HAZ=0.0
            ENDIF
         ELSE
            HAZ=GAMMA*((-X)**(GAMMA-1.0))
         ENDIF
C
      ELSE IF(MINMAX.EQ.1 .OR. MINMAX.EQ.0)THEN
         IF(X.LT.0.0)THEN
            HAZ=0.0
         ELSE IF(X.EQ.0.0)THEN
            IF(GAMMA.EQ.1.0)THEN
              HAZ=1.0
            ELSEIF(GAMMA.LT.1.0)THEN
              HAZ=0.0
              WRITE(ICOUT,1700)
 1700    FORMAT('*****WARNING IN WEIHAZ--FOR GAMMA < 1 AND X = 0 ',
     1          'HAZARD VALUE IS UNDEFINED (SET TO 0).')
         CALL DPWRST('XXX','BUG ')
            ELSEIF(GAMMA.GT.1.0)THEN
              HAZ=0.0
            ENDIF
         ELSE
            HAZ=GAMMA*(X**(GAMMA-1.0))
         ENDIF
      ELSE
         WRITE(ICOUT,1800)
 1800    FORMAT('*****ERROR IN WEIHAZ--MINMAX NOT 1 OR 2')
         CALL DPWRST('XXX','BUG ')
      ENDIF
C
      RETURN
      END
      SUBROUTINE WEIPDF(X,GAMMA,MINMAX,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE WEIBULL
C              DISTRIBUTION WITH SINGLE PRECISION
C              TAIL LENGTH PARAMETER = GAMMA.
C              THERE ARE 2 SUCH WEIBULL FAMILIES--
C                 ONE FOR THE MIN ORDER STAT (THE USUAL) AND
C                 ONE FOR THE MAX ORDER STAT.
C              (SEE SARHAN & GREENBERG, PAGE 69)
C              THE WEIBULL TYPE IS SPECIFIED VIA   MINMAX
C              FOR MINMAX = 1  (FOR THE DEFAULT MINIMUM)
C                 THE 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              FOR MINMAX = 2 (FOR THE MAXIMUM),
C                 THE WEIBULL DISTRIBUTION USED
C                 HEREIN IS DEFINED FOR ALL NEGATIVE X,
C                 AND HAS THE PROBABILITY DENSITY FUNCTION
C                 F(X) = ...
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                     --MINMAX = THE INTEGER VALUE
C                                IDENTIFYING THE
C                                CHOSEN WEIBULL DISTRIBUTION.
C                                1 = MIN, 2 = MAX.
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--SARHAN & GREENBERG,
C                 CONTRIBUTIONS TO ORDER STATISTICS,
C                 1962, WILEY, PAGE 69.
C               --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1970, PAGES 250-271.
C               --HASTINGS AND PEACOCK, STATISTICAL
C                 DISTRIBUTIONS--A HANDBOOK FOR
C                 STUDENTS AND PRACTITIONERS, 1975,
C                 PAGE 124.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--87.7
C     ORIGINAL VERSION--NOVEMBER  1987.
C     UPDATED         --MAY       1992. REWRITTEN--ADD WEIB/MAX DIST.
C     UPDATED         --JANUARY   1994. ADD MINMAX ERROR MESSAGE
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)GOTO50
      GOTO90
   50 WRITE(ICOUT,15)
   15 FORMAT('***** FATAL ERROR--THE 2ND INPUT ARGUMENT TO THE ',
     1'WEIPDF 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
      RETURN
   90 CONTINUE
C
CCCCC THE FOLLOWING SECTION WAS REWRITTEN      JANUARY 1994
      IF(MINMAX.EQ.2)THEN
         IF(X.GT.0.0)THEN
            PDF=0.0
         ELSE IF(X.EQ.0.0)THEN
            IF(GAMMA.LE.1.0)PDF=1.0
            IF(GAMMA.GT.1.0)PDF=0.0
         ELSE
            PDF=GAMMA*((-X)**(GAMMA-1.0))*EXP(-((-X)**GAMMA))
         ENDIF
C
      ELSE IF(MINMAX.EQ.1 .OR. MINMAX.EQ.0)THEN
         IF(X.LT.0.0)THEN
            PDF=0.0
         ELSE IF(X.EQ.0.0)THEN
            IF(GAMMA.LE.1.0)PDF=1.0
            IF(GAMMA.GT.1.0)PDF=0.0
         ELSE
            PDF=GAMMA*(X**(GAMMA-1.0))*EXP(-(X**GAMMA))
         ENDIF
      ELSE
         WRITE(ICOUT,1800)
 1800    FORMAT('*****ERROR IN WEICDF--MINMAX NOT 1 OR 2')
         CALL DPWRST('XXX','BUG ')
      ENDIF
C
      RETURN
      END
      SUBROUTINE WEIPPF(P,GAMMA,MINMAX,PPF)
CCCCC MINMAX ADDED TO ABOVE ARGUMENT LIST   MAY 1993
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE WEIBULL
C              DISTRIBUTION WITH SINGLE PRECISION
C              TAIL LENGTH PARAMETER = GAMMA.
C              THERE ARE 2 SUCH WEIBULL FAMILIES--
C                 ONE FOR THE MIN ORDER STAT (THE USUAL) AND
C                 ONE FOR THE MAX ORDER STAT.
C              (SEE SARHAN & GREENBERG, PAGE 69)
C              THE WEIBULL TYPE IS SPECIFIED VIA   MINMAX
C              FOR MINMAX = 1  (FOR THE DEFAULT MINIMUM)
C                 THE 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              FOR MINMAX = 2 (FOR THE MAXIMUM),
C                 THE WEIBULL DISTRIBUTION USED
C                 HEREIN IS DEFINED FOR ALL NEGATIVE X,
C                 AND HAS THE PROBABILITY DENSITY FUNCTION
C                 F(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 (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                     --MINMAX = THE INTEGER VALUE
C                                IDENTIFYING THE
C                                CHOSEN WEIBULL DISTRIBUTION.
C                                1 = MIN, 2 = MAX.
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--SARHAN & GREENBERG,
C                 CONTRIBUTIONS TO ORDER STATISTICS,
C                 1962, WILEY, PAGE 69.
C               --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1970, PAGES 250-271.
C               --HASTINGS AND PEACOCK, STATISTICAL
C                 DISTRIBUTIONS--A HANDBOOK FOR
C                 STUDENTS AND PRACTITIONERS, 1975,
C                 PAGE 124.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--82.6
C     ORIGINAL VERSION--NOVEMBER  1975.
C     UPDATED         --DECEMBER  1981.
C     UPDATED         --MAY       1982.
C     UPDATED         --MAY       1993. REWRITTEN--ADD WEIB/MAX DIST.
C     UPDATED         --JANUARY   1994. ADD MINMAX ERROR MESSAGE
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(P.LT.0.0.OR.P.GE.1.0)GOTO50
      IF(GAMMA.LE.0.0)GOTO55
      GOTO90
   50 WRITE(ICOUT,1)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)P
      CALL DPWRST('XXX','BUG ')
      PPF=0.0
      RETURN
   55 WRITE(ICOUT,15)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)GAMMA
      CALL DPWRST('XXX','BUG ')
      PPF=0.0
      RETURN
   90 CONTINUE
    1 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ',
     1'WEIPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL')
   15 FORMAT('***** FATAL ERROR--THE 2ND INPUT ARGUMENT TO THE ',
     1'WEIPPF SUBROUTINE IS NON-POSITIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
CCCCC THE FOLLOWING LINE WAS REWRITTEN   MAY 1993
CCCCC PPF=(-ALOG(1.0-P))**(1.0/GAMMA)
C
CCCCC THE FOLLOWING SECTION WAS REWRITTEN      JANUARY 1994
      IF(MINMAX.EQ.2)THEN
         PPF=(-((ALOG(1.0/P))**(1.0/GAMMA)))
      ELSE IF(MINMAX.EQ.1 .OR. MINMAX.EQ.0)THEN
         PPF=(ALOG(1.0/(1.0-P)))**(1.0/GAMMA)
      ELSE
         WRITE(ICOUT,1800)
 1800    FORMAT('*****ERROR IN WEICDF--MINMAX NOT 1 OR 2')
         CALL DPWRST('XXX','BUG ')
      ENDIF
C
      RETURN
      END
      SUBROUTINE WEIRAN(N,GAMMA,MINMAX,ISEED,X)
CCCCC MINMAX WAS ADDED TO THE ABOVE ARGUMENT LIST   MAY 1993
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE 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                     --MINMAX = THE INTEGER VALUE
C                                IDENTIFYING THE
C                                CHOSEN WEIBULL DISTRIBUTION.
C                                1 = MIN, 2 = MAX.
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 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--SARHAN & GREENBERG,
C                 CONTRIBUTIONS TO ORDER STATISTICS,
C                 1962, WILEY, PAGE 69.
C               --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 250-271.
C               --HASTINGS AND PEACOCK, STATISTICAL
C                 DISTRIBUTIONS--A HANDBOOK FOR
C                 STUDENTS AND PRACTITIONERS, 1975,
C                 PAGE 128.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--82.6
C     ORIGINAL VERSION--NOVEMBER  1975.
C     UPDATED         --DECEMBER  1981.
C     UPDATED         --MAY       1982.
C     UPDATED         --MAY       1993. REWRITTEN--ADD WEIB/MAX DIST.
C     UPDATED         --JANUARY   1994. ADD MINMAX ERROR MESSAGE
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
      IF(GAMMA.LE.0.0)GOTO60
      GOTO90
   50 WRITE(ICOUT, 5)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,47)N
      CALL DPWRST('XXX','BUG ')
      RETURN
   60 WRITE(ICOUT,15)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)GAMMA
      CALL DPWRST('XXX','BUG ')
      RETURN
   90 CONTINUE
    5 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ',
     1'WEIRAN SUBROUTINE IS NON-POSITIVE *****')
   15 FORMAT('***** FATAL ERROR--THE 2ND INPUT ARGUMENT TO THE ',
     1'WEIRAN 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 WEIBULL DISTRIBUTION RANDOM NUMBERS
C     USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD.
C
CCCCC THE FOLLOWING WAS REWRITTEN    MAY 1993
CCCCC DO100I=1,N
CCCCC X(I)=(-ALOG(1.0-X(I)))**(1.0/GAMMA)
CC100 CONTINUE
C
CCCCC THE FOLLOWING SECTION WAS REWRITTEN      JANUARY 1994
      IF(MINMAX.EQ.2)THEN
         DO100I=1,N
         X(I)=(-((-ALOG(X(I)))**(1.0/GAMMA)))
  100    CONTINUE
      ELSE IF(MINMAX.EQ.1 .OR. MINMAX.EQ.0)THEN
         DO200I=1,N
         X(I)=(-ALOG(1.0-X(I)))**(1.0/GAMMA)
  200    CONTINUE
      ELSE
         WRITE(ICOUT,1800)
 1800    FORMAT('*****ERROR IN WEICDF--MINMAX NOT 1 OR 2')
         CALL DPWRST('XXX','BUG ')
      ENDIF
C
      RETURN
      END
      SUBROUTINE WEMEAN(X,W,N,IWRITE,WMEAN,IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE
C              SAMPLE WEIGHTED MEAN
C              OF THE DATA IN X WITH THE WEIGHTS IN W.
C              THE SAMPLE COVARIANCE COEFFICIENT WILL BE A SINGLE
C              PRECISION VALUE CALCULATED AS THE
C              SUM OF CROSS PRODUCTS DIVIDED BY (N-1).
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF
C                                (UNSORTED) OBSERVATIONS
C                                WHICH CONSTITUTE THE FIRST SET
C                                OF DATA.
C                     --W      = THE SINGLE PRECISION VECTOR OF
C                                WEIGHTS
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--WMEAN  = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED SAMPLE WEIGHTED MEAN.
C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
C             SAMPLE COVARIANCE COEFFICIENT BETWEEN THE 2 SETS
C             OF DATA IN THE INPUT VECTORS X AND Y.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--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                 WASHINGTON, D. C. 20234
C                 PHONE--301-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--88/9
C     ORIGINAL VERSION--AUGUST    1988.
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 DW
      DOUBLE PRECISION DSUMX
      DOUBLE PRECISION DSUMW
C
      DIMENSION X(*)
      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
      ISUBN1='WEME'
      ISUBN2='AN  '
C
      IERROR='NO'
C
      DN=0.0D0
      DSUMX=0.0D0
      DSUMW=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 WEMEAN--')
      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),W(I)
   56 FORMAT('I,X(I),W(I) = ',I8,2E15.7)
      CALL DPWRST('XXX','BUG ')
   55 CONTINUE
   90 CONTINUE
C
C               *******************************************
C               **  COMPUTE      WEIGHTED MEANS          **
C               *******************************************
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
C
      IF(N.GE.1)GOTO119
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,111)
  111 FORMAT('***** ERROR IN WEMEAN--')
      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 WEIGHTED MEAN 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 ')
      IERROR='YES'
      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 WEMEAN--',
     1'THE THIRD INPUT ARGUMENT (N) HAS THE VALUE 1')
      CALL DPWRST('XXX','BUG ')
      WMEAN=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 WEMEAN--',
     1'THE 1ST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      WMEAN=X(1)
      GOTO9000
  139 CONTINUE
C
      SUM=0.0
      DO145I=1,N
      SUM=SUM+W(I)
  145 CONTINUE
      IF(SUM.NE.0.0)GOTO149
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,146)HOLD
  146 FORMAT('***** FATAL ERROR IN WEMEAN--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,147)
  147 FORMAT('      IN ATTEMPTING TO COMPUTE A WEIGHTED MEAN,')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,148)
  148 FORMAT('      THE INPUT WEIGHTS SUMMED TO 0.')
      CALL DPWRST('XXX','BUG ')
      WMEAN=0.0
      IERROR='YES'
      GOTO9000
  149 CONTINUE
C
  190 CONTINUE
C
C               ************************************************
C               **  STEP 11--                                 **
C               **  COMPUTE THE      WEIGHTED MEAN.           **
C               ************************************************
C
      DN=N
      DSUMX=0.0D0
      DO1100I=1,N
      DX=X(I)
      DW=W(I)
      DSUMX=DSUMX+DX*DW
 1100 CONTINUE
C
      DSUMW=0.0D0
      DO1200I=1,N
      DW=W(I)
      DSUMW=DSUMW+DW
 1200 CONTINUE
C
      WMEAN=DSUMX/DSUMW
C
C               *******************************
C               **  STEP 12--                **
C               **  WRITE OUT A LINE         **
C               **  OF SUMMARY INFORMATION.  **
C               *******************************
C
      IF(IFEEDB.EQ.'OFF')GOTO1290
      IF(IWRITE.EQ.'OFF')GOTO1290
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1211)N,WMEAN
 1211 FORMAT('THE WEIGHTED MEAN OF THE ',I8,
     1' OBSERVATIONS = ',E15.7)
      CALL DPWRST('XXX','BUG ')
 1290 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 WEMEAN--')
      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)DN,DSUMX,DSUMW
 9014 FORMAT('DN,DSUMX,DSUMW = ',3D15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9015)WMEAN
 9015 FORMAT('WMEAN = ',E15.7)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE WEMEDI(X,W,N,IWRITE,WMED,IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE
C              SAMPLE WEIGHTED MEDIAN
C              OF THE DATA IN X WITH THE WEIGHTS IN W.
C              THE SAMPLE COVARIANCE COEFFICIENT WILL BE A SINGLE
C              PRECISION VALUE CALCULATED AS THE
C              SUM OF CROSS PRODUCTS DIVIDED BY (N-1).
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF
C                                (UNSORTED) OBSERVATIONS
C                                WHICH CONSTITUTE THE FIRST SET
C                                OF DATA.
C                     --W      = THE SINGLE PRECISION VECTOR OF
C                                WEIGHTS
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--WMED  = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED SAMPLE WEIGHTED MEDIAN.
C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
C             SAMPLE COVARIANCE COEFFICIENT BETWEEN THE 2 SETS
C             OF DATA IN THE INPUT VECTORS X AND Y.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--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                 WASHINGTON, D. C. 20234
C                 PHONE--301-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--88/9
C     ORIGINAL VERSION--AUGUST    1988.
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
CCCCC DOUBLE PRECISION DX
CCCCC DOUBLE PRECISION DW
      DOUBLE PRECISION DSUMX
      DOUBLE PRECISION DSUMW
C
      DIMENSION X(*)
      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
      ISUBN1='WEME'
      ISUBN2='DI  '
C
      IERROR='NO'
C
      DN=0.0D0
      DSUMX=0.0D0
      DSUMW=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 WEMEDI--')
      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),W(I)
   56 FORMAT('I,X(I),W(I) = ',I8,2E15.7)
      CALL DPWRST('XXX','BUG ')
   55 CONTINUE
   90 CONTINUE
C
C               *******************************************
C               **  COMPUTE      WEIGHTED MEDIANS        **
C               *******************************************
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
C
      IF(N.GE.1)GOTO119
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,111)
  111 FORMAT('***** ERROR IN WEMEDI--')
      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 WEIGHTED MEDIAN 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 ')
      IERROR='YES'
      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 WEMEDI--',
     1'THE THIRD INPUT ARGUMENT (N) HAS THE VALUE 1')
      CALL DPWRST('XXX','BUG ')
      WMED=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 WEMEDI--',
     1'THE 1ST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      WMED=X(1)
      GOTO9000
  139 CONTINUE
C
      SUM=0.0
      DO145I=1,N
      SUM=SUM+W(I)
  145 CONTINUE
      IF(SUM.NE.0.0)GOTO149
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,146)HOLD
  146 FORMAT('***** FATAL ERROR IN WEMEDI--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,147)
  147 FORMAT('      IN ATTEMPTING TO COMPUTE A WEIGHTED MEDIAN,')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,148)
  148 FORMAT('      THE INPUT WEIGHTS SUMMED TO 0.')
      CALL DPWRST('XXX','BUG ')
      WMED=0.0
      IERROR='YES'
      GOTO9000
  149 CONTINUE
C
  190 CONTINUE
C
C               ************************************************
C               **  STEP 11--                                 **
C               **  COMPUTE THE      WEIGHTED MEDIAN.           **
C               ************************************************
C
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1111)
 1111 FORMAT('***** ERROR IN WEMEDI--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1112)
 1112 FORMAT('       WEIGHED MEDIAN NOT YET IMPLEMENTED')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1113)
 1113 FORMAT('     (AMBIGUITY IN DEFINITION)')
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
C
C               *******************************
C               **  STEP 12--                **
C               **  WRITE OUT A LINE         **
C               **  OF SUMMARY INFORMATION.  **
C               *******************************
C
CCCCC IF(IFEEDB.EQ.'OFF')GOTO1290
CCCCC IF(IWRITE.EQ.'OFF')GOTO1290
CCCCC WRITE(ICOUT,999)
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC WRITE(ICOUT,1211)N,WMED
C1211 FORMAT('THE WEIGHTED MEDIAN OF THE ',I8,
CCCCC1' OBSERVATIONS = ',E15.7)
CCCCC CALL DPWRST('XXX','BUG ')
C1290 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 WEMEDI--')
      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)DN,DSUMX,DSUMW
 9014 FORMAT('DN,DSUMX,DSUMW = ',3D15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9015)WMED
 9015 FORMAT('WMED = ',E15.7)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE WESD(X,W,N,IWRITE,WSD,IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE
C              SAMPLE WEIGHTED STANDARD DEVIATION
C              OF THE DATA IN X WITH THE WEIGHTS IN W.
C              THE SAMPLE COVARIANCE COEFFICIENT WILL BE A SINGLE
C              PRECISION VALUE CALCULATED AS THE
C              SUM OF CROSS PRODUCTS DIVIDED BY (N-1).
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF
C                                (UNSORTED) OBSERVATIONS
C                                WHICH CONSTITUTE THE FIRST SET
C                                OF DATA.
C                     --W      = THE SINGLE PRECISION VECTOR OF
C                                WEIGHTS
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--WSD  = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED SAMPLE WEIGHTED STANDARD DEVIATION.
C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
C             SAMPLE COVARIANCE COEFFICIENT BETWEEN THE 2 SETS
C             OF DATA IN THE INPUT VECTORS X AND Y.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--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                 WASHINGTON, D. C. 20234
C                 PHONE--301-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--88/9
C     ORIGINAL VERSION--AUGUST    1988.
C     UPDATED         --APRIL     1992. DEFINE DMEAN
C     UPDATED         --DECEMBER  1992. FIX DMEAN AND ** BUGS
C     UPDATED         --DECEMBER  1994. FIX FORMULA
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 DW
      DOUBLE PRECISION DSUMX
      DOUBLE PRECISION DSUMW
CCCCC THE FOLLOWING LINE WAS ADDED DECEMBER 1992
      DOUBLE PRECISION DMEAN
      DOUBLE PRECISION DDEL
      DOUBLE PRECISION DDENOM
      DOUBLE PRECISION DVAR
C
      DIMENSION X(*)
      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
      ISUBN1='WESD'
      ISUBN2='    '
C
      IERROR='NO'
C
      DN=0.0D0
      DSUMX=0.0D0
      DSUMW=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 WESD--')
      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),W(I)
   56 FORMAT('I,X(I),W(I) = ',I8,2E15.7)
      CALL DPWRST('XXX','BUG ')
   55 CONTINUE
   90 CONTINUE
C
C               *******************************************
C               **  COMPUTE WEIGHTED STANDARD DEVIATIONS **
C               *******************************************
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
C
      IF(N.GE.1)GOTO119
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,111)
  111 FORMAT('***** ERROR IN WESD--')
      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 WEIGHTED STANDARD 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 ')
      IERROR='YES'
      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 WESD--',
     1'THE THIRD INPUT ARGUMENT (N) HAS THE VALUE 1')
      CALL DPWRST('XXX','BUG ')
      WSD=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 WESD--',
     1'THE 1ST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      WSD=X(1)
      GOTO9000
  139 CONTINUE
C
CCCCC DECEMBER 1994.  UPDATE FOLLOWING LOOP TO:
CCCCC 1) CHECK FOR NEGATIVE WEIGHTS (THIS IS AN ERROR CONDITION)
CCCCC 2) COUNT THE NUMBER OF ZERO WEIGHTS
C
      NUMZER=0
      SUM=0.0
      DO145I=1,N
      IF(W(I).LT.0.0)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,141)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,142)I,W(I)
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        WSD=0.0
        GOTO9000
      ENDIF
      IF(W(I).EQ.0.0)NUMZER=NUMZER+1
      SUM=SUM+W(I)
  145 CONTINUE
  141 FORMAT('***** FATAL ERROR IN WESD--NEGATIVE WEIGHT ENCOUNTERED.')
  142 FORMAT('      WEIGHT ',I7,' =  ',E15.7)
      IF(SUM.NE.0.0)GOTO149
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,146)HOLD
  146 FORMAT('***** FATAL ERROR IN WESD--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,147)
  147 FORMAT('      IN ATTEMPTING TO COMPUTE A WEIGHTED ST. DEV.,')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,148)
  148 FORMAT('      THE INPUT WEIGHTS SUMMED TO 0.')
      CALL DPWRST('XXX','BUG ')
      WSD=0.0
      IERROR='YES'
      GOTO9000
  149 CONTINUE
C
  190 CONTINUE
C
C               ************************************************
C               **  STEP 11--                                 **
C               **  COMPUTE THE WEIGHTED STANDARD DEVIATION.  **
C               ************************************************
C
      DN=N
      DSUMX=0.0D0
      DO1100I=1,N
      DX=X(I)
      DW=W(I)
      DSUMX=DSUMX+DX*DW
 1100 CONTINUE
C
      DSUMW=0.0D0
      DO1200I=1,N
      DW=W(I)
      DSUMW=DSUMW+DW
 1200 CONTINUE
C
CCCCC THE FOLLOWING LINE WAS FIXED    APRIL 1992
CCCCC WMEAN=DSUMX/DSUMW
      DMEAN=DSUMX/DSUMW
CCCCC THE FOLLOWING LINE WAS ADDED    APRIL 1992
      WMEAN=DMEAN
CCCCC THE FOLLOWING LINE WAS ADDED    DECEMBER 1994
      WADJ=DSUMW/REAL(N-NUMZER)
C
      DSUMX=0.0D0
      DO1300I=1,N
      DX=X(I)
      DDEL=DX-DMEAN
      DW=W(I)
CCCCC THE FOLLOWING LINE WAS CHANGED DECEMBER 1992
CCCCC DSUMX=DSUMX+DW*DDEL
      DSUMX=DSUMX+DW*DDEL**2
 1300 CONTINUE
C
CCCCC THE FOLLOWING LINE WAS CHANGED DECEMBER 1992
CCCCC DDENOM=N-1
CCCCC THE FOLLOWING LINE WAS CHANGED DECEMBER 1994
CCCCC DDENOM=DSUMW-1.0D0
      DDENOM=WADJ*REAL(N-NUMZER-1)
      IF(DDENOM.EQ.0.0D0)DVAR=0.0
CCCCC THE FOLLOWING LINE WAS CHANGED DECEMBER 1992
CCCCC IF(DDENOM.NE.0.0)DVAR=DSUMX/DDENOM
      IF(DDENOM.NE.0.0D0)DVAR=DSUMX/DDENOM
      WSD=0.0
      IF(DVAR.GT.0.0D0)WSD=DSQRT(DVAR)
C
C               *******************************
C               **  STEP 12--                **
C               **  WRITE OUT A LINE         **
C               **  OF SUMMARY INFORMATION.  **
C               *******************************
C
      IF(IFEEDB.EQ.'OFF')GOTO1290
      IF(IWRITE.EQ.'OFF')GOTO1290
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1211)N,WSD
 1211 FORMAT('THE WEIGHTED STANDARD DEVIATION OF THE ',I8,
     1' OBSERVATIONS = ',E15.7)
      CALL DPWRST('XXX','BUG ')
 1290 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 WESD--')
      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 ')
CCCCC THE FOLLOWING 2 LINES WERE AUGMENTED DECEMBER 1992
CCCCC WRITE(ICOUT,9014)DN,DSUMX,DSUMW,DDEL,DVAR
C9014 FORMAT('DN,DSUMX,DSUMW,DDEL,DVAR = ',5D15.7)
CCCCC CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9014)DN,DSUMX,DSUMW
 9014 FORMAT('DN,DSUMX,DSUMW = ',3D15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9015)DDEL,DDENOM,DMEAN,DVAR
 9015 FORMAT('DDEL,DDENOM,DMEAN,DVAR = ',4D15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9016)WSD
 9016 FORMAT('WSD = ',E15.7)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE WETRME(X,W,N,PROP1,PROP2,IWRITE,XTEMP,STEP,
     1IUPPER,XTRIM,
     1IBUGA3,ISUBRO,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE
C              SAMPLE WEIGHTED TRIMMED MEAN.
C              OF THE DATA IN THE INPUT VECTOR X.
C      NOTE--PROP1 % OF THE DATA IS WTTRMED FROM THE LEFT SIDE;
C            PROP2 % OF THE DATA IS WTTRMED FROM THE RIGHT SIDE.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF
C                                (UNSORTED OR SORTED) OBSERVATIONS.
C                     --W      = THE SINGLE PRECISION VECTOR OF
C                                WEIGHTS.
C                     --STEP   = A COMPUTED CUMULATIVE WEIGHTS
C                                VECTOR.
C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR X.
C                     --PROP1  = THE SINGLE PRECISION PROPORTION (0 TO 100)
C                                OF OBSERVATIONS TO BE WTTRMED FROM LEFT SIDE.
C                     --PROP2  = THE SINGLE PRECISION PORTION (0 TO 100)
C                                OF OBSERVATIONS TO BE WTTRMED FROM RIGHT SIDE.
C     OUTPUT ARGUMENTS--XTRIM  = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED SAMPLE WTTRMED MEAN.
C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
C             SAMPLE WEIGHTED TRIMMED MEAN.
C     OTHER DATAPAC   SUBROUTINES NEEDED--SORTC.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--DAVID, ORDER STATISTICS, 1970, PAGES 129, 136.
C               --CROW AND SIDDIQUI, 'ROBUST ESTIMATION OF LOCATION',
C                 JOURNAL OF THE AMERICAN STATISTICAL ASSOCIATION,
C                 1967, PAGES 357, 387.
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).
C               --ADAPTED FROM CODE PROVIDED BY JAMES YEN OF THE
C                 NIST STATISITICAL ENGINEERING DIVISION.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 WASHINGTON, D. C. 20234
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--2003.5
C     ORIGINAL VERSION--MAY       2003.
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
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DSUM
C
      DIMENSION X(*)
      DIMENSION XTEMP(*)
      DIMENSION W(*)
      DIMENSION STEP(*)
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='TRIM'
      ISUBN2='ME  '
C
      IERROR='NO'
C
      DSUM=0.0D0
C
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'TRME')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,51)
   51   FORMAT('***** AT THE BEGINNING OF WTTRME--')
        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 ')
        WRITE(ICOUT,54)PROP1,PROP2
   54   FORMAT('PROP1,PROP2 = ',2E15.7)
        CALL DPWRST('XXX','BUG ')
        DO55I=1,N
          WRITE(ICOUT,56)I,X(I),W(I)
   56     FORMAT('I,X(I),W(I) = ',I8,2E15.7)
          CALL DPWRST('XXX','BUG ')
   55   CONTINUE
      ENDIF
C
C               *****************************************
C               **  COMPUTE THE WEIGHTED TRIMMED MEAN  **
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.IUPPER)THEN
        IERROR='YES'
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,111)
  111   FORMAT('***** ERROR IN WEIGHTED TRIMMED MEAN--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,112)
  112   FORMAT('      THE INPUT NUMBER OF OBSERVATIONS IN THE ',
     1         'VARIABLE FOR')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,114)
  114   FORMAT('      WHICH THE WEIGHTED TRIMMED MEAN IS TO BE ',
     1         'COMPUTED')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,115)IUPPER
  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,'.')
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
      IF(N.EQ.1)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,121)
  121   FORMAT('***** NON-FATAL DIAGNOSTIC IN WEIGHTED TRIMMED MEAN--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,123)
  123   FORMAT('      THE NUMBER OF OBSERVATIONS IS EQUAL TO 1.')
        CALL DPWRST('XXX','BUG ')
        XTRIM=X(1)
        GOTO9000
      ENDIF
C
      HOLD=X(1)
      DO135I=2,N
        IF(X(I).NE.HOLD)GOTO139
  135 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,136)
  136 FORMAT('***** NON-FATAL DIAGNOSTIC IN WEIGHTED TRIMMED MEAN--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,137)HOLD
  137 FORMAT('THE FIRST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',
     1E15.7)
      CALL DPWRST('XXX','BUG ')
      XTRIM=HOLD
      GOTO9000
  139 CONTINUE
C
      IF(PROP1.LT.0.0 .OR. PROP1.GT.100.0)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,141)
  141   FORMAT('***** ERROR IN WEIGHTED TRIMMED MEAN--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,142)
  142   FORMAT('      P1 SHOULD BE BETWEEN 0 AND 100, BUT IS NOT.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,143)PROP1
  143   FORMAT('THE VALUE OF P1 IS ',E15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      IF(PROP2.LT.0.0 .OR. PROP2.GT.100.0)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,151)
  151   FORMAT('***** ERROR IN WEIGHTED TRIMMED MEAN--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,152)
  152   FORMAT('      P2 SHOULD BE BETWEEN 0 AND 100, BUT IS NOT.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,153)PROP2
  153   FORMAT('THE VALUE OF P2 IS ',E15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
C               ******************************************
C               **  STEP 2--                            **
C               **  COMPUTE THE WEIGHTED TRIMMED MEAN.  **
C               ******************************************
C
      A1=PROP1/100.0
      A2=PROP2/100.0
      IF(A1.LT.0.0001 .AND. A2.LT.0.0001)THEN
        CALL WEMEAN(X,W,N,IWRITE,XTRIM,IBUGA3,IERROR)
        GOTO800
      END IF
C
      CALL SORTC(X,W,N,XTEMP,W)
C
      DSUM=0.0D0
      DO200I=1,N
        DSUM=DSUM+DBLE(W(I))
  200 CONTINUE
C
      W(1)=REAL(DBLE(W(1))/DSUM)
      STEP(1)=W(1)
      DO210I=1,N
        W(I)=REAL(DBLE(W(I))/DSUM)
        STEP(I)=STEP(I-1)+W(I)
  210 CONTINUE
C
      IF(STEP(1).LE.A1)THEN
        W(1)=0.0
      ELSEIF(STEP(1).GE.(1.0-A2))THEN
        W(1)=1.0-(A1+A2)
      ELSE
        W(1)=STEP(1) - A1
      ENDIF
C
      DO310I=2,N
        IF(STEP(I-1).GE.A1 .AND. STEP(I).LE.(1.0-A2))THEN
          W(I)=W(I)
        ELSEIF(STEP(I).LE.A1 .OR. STEP(I-1).GE.(1.0-A2))THEN
          W(I)=0.0
        ELSEIF((STEP(I-1).LE.A1 .AND. STEP(I).GE.A1) .AND.
     1         STEP(I).LE.(1.0-A2))THEN  
          W(I)=STEP(I)-A1
        ELSEIF((STEP(I-1).LE.(1.0-A2).AND.STEP(I).GE.(1.0-A2)).AND.
     1         STEP(I-1).GE.A1)THEN
          W(I)=(1.0-A2) - STEP(I-1)
        ELSEIF(STEP(I-1).LE.A1 .AND. STEP(I).GE.(1.0-A2))THEN
          W(I)=1.0 - (A1 + A2)
        ENDIF
  310 CONTINUE
C
      IF(STEP(N-1).GE.(1.0-A2))THEN
        W(N)=0.0
      ELSEIF(STEP(N-1).LE.A1)THEN
        W(N)=1.0-(A1 + A2)
      ELSE
        W(N)=(1.0-A2) - STEP(N-1)
      ENDIF
C
      NPROP1=(PROP1/100.0)*AN+0.0001
      ISTART=NPROP1+1
C
      DSUM=0.0D0
      DO410I=1,N
        DSUM=DSUM + (W(I)*X(I))
  410 CONTINUE
      XTRIM=DSUM/(1.0 - (A1 + A2))
C
C               *******************************
C               **  STEP 3--                 **
C               **  WRITE OUT A LINE         **
C               **  OF SUMMARY INFORMATION.  **
C               *******************************
C
  800 CONTINUE
      IF(IFEEDB.EQ.'OFF')GOTO890
      IF(IWRITE.EQ.'OFF')GOTO890
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,821)N,XTRIM
  821 FORMAT('THE WEIGHTED TRIMMED MEAN 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' .OR. ISUBRO.EQ.'TRME')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END       OF WTTRME--')
        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)PROP1,PROP2
 9014   FORMAT('PROP1,PROP2 = ',23E15.7)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9018)XTRIM
 9018   FORMAT('XTRIM = ',E15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      RETURN
      END
      SUBROUTINE WEVARI(X,W,N,IWRITE,WVAR,IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE
C              SAMPLE WEIGHTED VARIANCE
C              OF THE DATA IN X WITH THE WEIGHTS IN W.
C              THE SAMPLE COVARIANCE COEFFICIENT WILL BE A SINGLE
C              PRECISION VALUE CALCULATED AS THE
C              SUM OF CROSS PRODUCTS DIVIDED BY (N-1).
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF
C                                (UNSORTED) OBSERVATIONS
C                                WHICH CONSTITUTE THE FIRST SET
C                                OF DATA.
C                     --W      = THE SINGLE PRECISION VECTOR OF
C                                WEIGHTS
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--WVAR = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED SAMPLE WEIGHTED VARIANCE.
C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
C             SAMPLE COVARIANCE COEFFICIENT BETWEEN THE 2 SETS
C             OF DATA IN THE INPUT VECTORS X AND Y.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--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                 WASHINGTON, D. C. 20234
C                 PHONE--301-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--88/9
C     ORIGINAL VERSION--AUGUST    1988.
C     UPDATED         --APRIL     1992. DEFINE DMEAN
C     UPDATED         --DECEMBER  1992. FIX DMEAN AND ** BUGS
C     UPDATED         --DECEMBER  1994. FIX DEFINITION
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 DW
      DOUBLE PRECISION DSUMX
      DOUBLE PRECISION DSUMW
CCCCC THE FOLLOWING LINE WAS ADDED DECEMBER 1992
      DOUBLE PRECISION DMEAN
      DOUBLE PRECISION DDEL
      DOUBLE PRECISION DDENOM
CCCCC DOUBLE PRECISION DVAR
C
      DIMENSION X(*)
      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
      ISUBN1='WEVA'
      ISUBN2='RI  '
C
      IERROR='NO'
C
      DN=0.0D0
      DSUMX=0.0D0
      DSUMW=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 WEVARI--')
      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),W(I)
   56 FORMAT('I,X(I),W(I) = ',I8,2E15.7)
      CALL DPWRST('XXX','BUG ')
   55 CONTINUE
   90 CONTINUE
C
C               *******************************************
C               **  COMPUTE WEIGHTED VARIANCES           **
C               *******************************************
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
C
      IF(N.GE.1)GOTO119
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,111)
  111 FORMAT('***** ERROR IN WEVARI--')
      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 WEIGHTED VARIANCE 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 ')
      IERROR='YES'
      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 WEVARI--',
     1'THE THIRD INPUT ARGUMENT (N) HAS THE VALUE 1')
      CALL DPWRST('XXX','BUG ')
      WVAR=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 WEVARI--',
     1'THE 1ST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      WVAR=X(1)
      GOTO9000
  139 CONTINUE
C
      SUM=0.0
CCCCC DECEMBER 1994.  UPDATE FOLLOWING LOOP TO:
CCCCC 1) CHECK FOR NEGATIVE WEIGHTS (THIS IS AN ERROR CONDITION)
CCCCC 2) COUNT THE NUMBER OF ZERO WEIGHTS
C
      NUMZER=0
      SUM=0.0
      DO145I=1,N
      IF(W(I).LT.0.0)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,141)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,142)I,W(I)
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        WVAR=0.0
        GOTO9000
      ENDIF
      IF(W(I).EQ.0.0)NUMZER=NUMZER+1
      SUM=SUM+W(I)
  145 CONTINUE
  141 FORMAT('***** FATAL ERROR IN WEVAR--NEGATIVE WEIGHT ',
     1'ENCOUNTERED.')
  142 FORMAT('      WEIGHT ',I7,' =  ',E15.7)
      IF(SUM.NE.0.0)GOTO149
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,146)HOLD
  146 FORMAT('***** FATAL ERROR IN WEVARI--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,147)
  147 FORMAT('      IN ATTEMPTING TO COMPUTE A WEIGHTED ST. DEV.,')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,148)
  148 FORMAT('      THE INPUT WEIGHTS SUMMED TO 0.')
      CALL DPWRST('XXX','BUG ')
      WVAR=0.0
      IERROR='YES'
      GOTO9000
  149 CONTINUE
C
  190 CONTINUE
C
C               ************************************************
C               **  STEP 11--                                 **
C               **  COMPUTE THE WEIGHTED VARIANCE.            **
C               ************************************************
C
      DN=N
      DSUMX=0.0D0
      DO1100I=1,N
      DX=X(I)
      DW=W(I)
      DSUMX=DSUMX+DX*DW
 1100 CONTINUE
C
      DSUMW=0.0D0
      DO1200I=1,N
      DW=W(I)
      DSUMW=DSUMW+DW
 1200 CONTINUE
C
CCCCC THE FOLLOWING LINE WAS FIXED    APRIL 1992
CCCCC WMEAN=DSUMX/DSUMW
      DMEAN=DSUMX/DSUMW
CCCCC THE FOLLOWING LINE WAS ADDED    APRIL 1992
      WMEAN=DMEAN
CCCCC THE FOLLOWING LINE WAS ADDED    DECEMBER 1994
      WADJ=DSUMW/REAL(N-NUMZER)
C
      DSUMX=0.0D0
      DO1300I=1,N
      DX=X(I)
      DDEL=DX-DMEAN
      DW=W(I)
CCCCC THE FOLLOWING LINE WAS CHANGED DECEMBER 1992
CCCCC DSUMX=DSUMX+DW*DDEL
      DSUMX=DSUMX+DW*DDEL**2
 1300 CONTINUE
C
CCCCC THE FOLLOWING LINE WAS CHANGED DECEMBER 1992
CCCCC DDENOM=N-1
CCCCC THE FOLLOWING LINE WAS CHANGED DECEMBER 1994
CCCCC DDENOM=DSUMW-1.0D0
      DDENOM=WADJ*REAL(N-NUMZER-1)
      IF(DDENOM.EQ.0.0D0)WVAR=0.0
CCCCC THE FOLLOWING LINE WAS CHANGED DECEMBER 1992
CCCCC IF(DDENOM.NE.0.0)WVAR=DSUMX/DDENOM
      IF(DDENOM.NE.0.0D0)WVAR=DSUMX/DDENOM
C
C               *******************************
C               **  STEP 12--                **
C               **  WRITE OUT A LINE         **
C               **  OF SUMMARY INFORMATION.  **
C               *******************************
C
      IF(IFEEDB.EQ.'OFF')GOTO1290
      IF(IWRITE.EQ.'OFF')GOTO1290
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1211)N,WVAR
 1211 FORMAT('THE WEIGHTED VARIANCE OF THE ',I8,
     1' OBSERVATIONS = ',E15.7)
      CALL DPWRST('XXX','BUG ')
 1290 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 WEVARI--')
      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 ')
CCCCC THE FOLLOWING 2 LINES WERE AUGMENTED DECEMBER 1992
CCCCC WRITE(ICOUT,9014)DN,DSUMX,DSUMW,DDEL
C9014 FORMAT('DN,DSUMX,DSUMW,DDEL = ',4D15.7)
CCCCC CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9014)DN,DSUMX,DSUMW
 9014 FORMAT('DN,DSUMX,DSUMW = ',3D15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9015)DDEL,DDENOM,DMEAN
 9015 FORMAT('DDEL,DDENOM,DMEAN = ',3D15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9016)WVAR
 9016 FORMAT('WVAR = ',E15.7)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      function whimed(a,iw,n,acand,iwcand)
cc
cc  Algorithm to compute the weighted high median in O(n) time.
cc
cc  The whimed is defined as the smallest a(j) such that the sum
cc  of the weights of all a(i) <= a(j) is strictly greater than
cc  half of the total weight.
cc
cc  Parameters of this function:
cc        a: real array containing the observations
cc        n: number of observations
cc       iw: array of integer weights of the observations.
cc
cc  This function uses the function pull.
cc
cc  The size of acand, iwcand must be at least n.
cc
      dimension a(*),iw(*)
ccccc dimension acand(500),iwcand(500)
      dimension acand(*),iwcand(*)
      integer wtotal,wrest,wleft,wmid,wright
c
      nn=n
      wtotal=0
      do 20 i=1,nn
          wtotal=wtotal+iw(i)
20    continue
      wrest=0
100   continue
      trial=pull(a,nn,nn/2+1,acand)
      do22i=1,n
        acand(i)=0.0
22    continue
      wleft=0
      wmid=0
      wright=0
      do 30 i=1,nn
          if (a(i).lt.trial) then
              wleft=wleft+iw(i)
          else
              if (a(i).gt.trial) then
                  wright=wright+iw(i)
              else
                  wmid=wmid+iw(i)
              endif
          endif
30    continue
      if ((2*wrest+2*wleft).gt.wtotal) then
          kcand=0
          do 40 i=1,nn
              if (a(i).lt.trial) then
                  kcand=kcand+1
                  acand(kcand)=a(i)
                  iwcand(kcand)=iw(i)
              endif
40        continue
          nn=kcand
      else
          if ((2*wrest+2*wleft+2*wmid).gt.wtotal) then
              whimed=trial
              return
          else
              kcand=0
              do 50 i=1,nn
                  if(a(i).gt.trial) then
                      kcand=kcand+1
                      acand(kcand)=a(i)
                      iwcand(kcand)=iw(i)
                  endif
50            continue
              nn=kcand
              wrest=wrest+wleft+wmid
          endif
      endif
      do 60 i=1,nn
          a(i)=acand(i)
          iw(i)=iwcand(i)
60    continue
      go to 100
      end
      SUBROUTINE WINDME(X,N,PROP1,PROP2,IWRITE,XTEMP,IUPPER,XWIND,
     1IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE
C              SAMPLE WINDME = THE
C              SAMPLE (ON EACH SIDE) WINDSORIZED MEAN
C              OF THE DATA IN THE INPUT VECTOR X.
C      NOTE--PROP1 % OF THE DATA IS WINDSORIZED FROM THE LEFT SIDE;
C            PROP2 % OF THE DATA IS WINDSORIZED FROM THE RIGHT SIDE.
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                     --PROP1  = THE SINGLE PRECISION PROPORTION (0 TO 100)
C                                OF OBSERVATIONS TO BE WINDSORIZED FROM LEFT
C                     --PROP2  = THE SINGLE PRECISION PORTION (0 TO 100)
C                                OF OBSERVATIONS TO BE WINDSORIZED FROM RIGHT
C     OUTPUT ARGUMENTS--XWIND  = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED SAMPLE WINDSORIZED MEAN.
C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
C             SAMPLE WINDSORIZED MEAN.
C     RESTRICTIONS--THE MAXIMUM ALLOWABLE VALUE OF N
C                   FOR THIS SUBROUTINE IS 15000.
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--DAVID, ORDER STATISTICS, 1970, PAGES 129, 136.
C               --CROW AND SIDDIQUI, 'ROBUST ESTIMATION OF LOCATION',
C                 JOURNAL OF THE AMERICAN STATISTICAL ASSOCIATION,
C                 1967, PAGES 357, 387.
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).
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--83.6
C     ORIGINAL VERSION--JULY      1973.
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---------------------------------------------------------------------
C
      DOUBLE PRECISION DK
      DOUBLE PRECISION DX
      DOUBLE PRECISION DSUM
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='WIND'
      ISUBN2='ME  '
C
      IERROR='NO'
CCCCC IUPPER=1000
C
      NPROP1=0
      NPROP2=0
      NPROP3=0
      ISTART=0
      ISTOP=0
      DSUM=0.0D0
      DK=0.0D0
      PROP3=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 WINDME--')
      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 ')
      WRITE(ICOUT,54)PROP1,PROP2
   54 FORMAT('PROP1,PROP2 = ',2E15.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 THE WINDSORIZED MEAN  **
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 WINDME--')
      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 WINDME IS TO BE COMPUTED')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,115)IUPPER
  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 WINDME--',
     1'THE 2ND INPUT ARGUMENT (N) HAS THE VALUE 1')
      CALL DPWRST('XXX','BUG ')
      XWIND=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 WINDME--',
     1'THE FIRST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      XWIND=HOLD
      GOTO9000
  139 CONTINUE
C
      IF(0.0.LE.PROP1.AND.PROP1.LE.100.0)GOTO149
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,141)
  141 FORMAT('***** ERROR IN WINDME--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,142)
  142 FORMAT('PROP1 SHOULD BE BETWEEN 0 AND 100, BUT IS NOT.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,143)PROP1
  143 FORMAT('THE VALUE OF PROP1 IS ',E15.7)
      CALL DPWRST('XXX','BUG ')
  149 CONTINUE
C
      IF(0.0.LE.PROP2.AND.PROP2.LE.100.0)GOTO159
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,151)
  151 FORMAT('***** ERROR IN WINDME--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,152)
  152 FORMAT('PROP2 SHOULD BE BETWEEN 0 AND 100, BUT IS NOT.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,153)PROP2
  153 FORMAT('THE VALUE OF PROP2 IS ',E15.7)
      CALL DPWRST('XXX','BUG ')
  159 CONTINUE
C
  190 CONTINUE
C
C               *************************************
C               **  STEP 2--                       **
C               **  COMPUTE THE WINDSORIZED MEAN.  **
C               *************************************
C
      CALL SORT(X,N,XTEMP)
C
      NPROP1=(PROP1/100.0)*AN+0.0001
      ISTART=NPROP1+1
C
      NPROP2=(PROP2/100.0)*AN+0.0001
      ISTOP=N-NPROP2
C
      DSUM=0.0
      IF(ISTART.GT.ISTOP)GOTO250
      DO200I=1,N
      IF(I.LT.ISTART)GOTO210
      IF(I.GT.ISTOP)GOTO220
      GOTO230
  210 CONTINUE
      DX=XTEMP(ISTART)
      DSUM=DSUM+DX
      GOTO200
  220 CONTINUE
      DX=XTEMP(ISTOP)
      DSUM=DSUM+DX
      GOTO200
  230 CONTINUE
      DX=XTEMP(I)
      DSUM=DSUM+DX
      GOTO200
  200 CONTINUE
      DK=AN
      XWIND=DSUM/DK
      GOTO290
C
  250 CONTINUE
      IERROR='YES'
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,251)
  251 FORMAT('***** INTERNAL ERROR IN WINDME--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,252)
  252 FORMAT('      START INDEX IS HIGHER THAN STOP INDEX.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,253)ISTART,ISTOP
  253 FORMAT('      ISTART,ISTOP = ',2I8)
      CALL DPWRST('XXX','BUG ')
      GOTO9000
  290 CONTINUE
C
C               *******************************
C               *******************************
C               **  STEP 3--                 **
C               **  WRITE OUT A LINE         **
C               **  OF SUMMARY INFORMATION.  **
C               *******************************
C
      IF(IFEEDB.EQ.'OFF')GOTO890
      IF(IWRITE.EQ.'OFF')GOTO890
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      PROP3=100.00-PROP1-PROP2
      NPROP3=N-NPROP1-NPROP2
      WRITE(ICOUT,811)PROP1,NPROP1
  811 FORMAT(8X,F10.4,' PERCENT (= ',I8,' OBSERVATIONS) ',
     1'OF THE DATA WERE WINDSORIZED         FROM BELOW')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,812)PROP2,NPROP2
  812 FORMAT(8X,F10.4,' PERCENT (= ',I8,' OBSERVATIONS) ',
     1'OF THE DATA WERE WINDSORIZED         FROM ABOVE')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,813)PROP3,NPROP3
  813 FORMAT(8X,F10.4,' PERCENT (= ',I8,' OBSERVATIONS) ',
     1'OF THE DATA REMAINING IN MIDDLE BEFORE WINDSORIZING')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,821)N,XWIND
  821 FORMAT('THE WINDSORIZED MEAN 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 WINDME--')
      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)PROP1,PROP2,PROP3
 9014 FORMAT('PROP1,PROP2,PROP3 = ',3E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9015)NPROP1,NPROP2,NPROP3
 9015 FORMAT('NPROP1,NPROP2,NPROP3 = ',3I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9016)ISTART,ISTOP
 9016 FORMAT('ISTART,ISTOP = ',2I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9017)DSUM,DK
 9017 FORMAT('DSUM,DK = ',2D15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9018)XWIND
 9018 FORMAT('XWIND = ',E15.7)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE WINSOR(X,N,PROP1,PROP2,IWRITE,XTEMP,IUPPER,Y,
     1IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE WINSORIZES THE DATA
C      NOTE--PROP1 % OF THE DATA IS WINSORIZED FROM THE LEFT SIDE;
C            PROP2 % OF THE DATA IS WINSORIZED FROM THE RIGHT SIDE.
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                     --PROP1  = THE SINGLE PRECISION PROPORTION (0 TO 100)
C                                OF OBSERVATIONS TO BE WINSORIZED FROM LEFT
C                     --PROP2  = THE SINGLE PRECISION PORTION (0 TO 100)
C                                OF OBSERVATIONS TO BE WINSORIZED FROM RIGHT
C     OUTPUT ARGUMENTS--Y      = THE SINGLE PRECISION VECTOR OF THE
C                                COMPUTED SAMPLE WINSORIZED DATA.
C     OUTPUT--THE COMPUTED SINGLE PRECISION VECTOR OF
C             SAMPLE WINSORIZED DATA.
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--DAVID, ORDER STATISTICS, 1970, PAGES 129, 136.
C               --CROW AND SIDDIQUI, 'ROBUST ESTIMATION OF LOCATION',
C                 JOURNAL OF THE AMERICAN STATISTICAL ASSOCIATION,
C                 1967, PAGES 357, 387.
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).
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 WASHINGTON, D. C. 20234
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--2002.7
C     ORIGINAL VERSION--JULY      2002.
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---------------------------------------------------------------------
C
      DIMENSION X(*)
      DIMENSION Y(*)
      DIMENSION XTEMP(*)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='WIND'
      ISUBN2='ME  '
C
      IERROR='NO'
C
      NPROP1=0
      NPROP2=0
      NPROP3=0
      ISTART=0
      ISTOP=0
      PROP3=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 WINSOR--')
      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 ')
      WRITE(ICOUT,54)PROP1,PROP2
   54 FORMAT('PROP1,PROP2 = ',2E15.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 THE WINSORIZED VARIANCE  **
C               ************************************
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      AN=N
C
      IF(N.LE.0.OR.N.GT.IUPPER)THEN
        IERROR='YES'
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,111)
  111   FORMAT('***** ERROR IN WINSOR--')
        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('      VARIABLE FOR WHICH THE WINSOR IS TO BE COMPUTED')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,115)IUPPER
  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('***** NON-FATAL DIAGNOSTIC IN WINSOR--',
     1        'ONLY ONE ELEMENT IN THE VECTOR TO BE WINSORIZED.')
        CALL DPWRST('XXX','BUG ')
        Y(1)=X(1)
        GOTO9000
      ENDIF
C
      HOLD=X(1)
      DO135I=2,N
        IF(X(I).NE.HOLD)GOTO139
  135 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,136)HOLD
  136 FORMAT('***** NON-FATAL DIAGNOSTIC IN WINSOR--',
     1'THE FIRST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      DO138I=1,N
        Y(I)=HOLD
        GOTO9000
  138 CONTINUE
  139 CONTINUE
C
      IF(0.0.LE.PROP1.AND.PROP1.LE.100.0)GOTO149
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,141)
  141 FORMAT('***** ERROR IN WINSOR--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,142)
  142 FORMAT('PROP1 SHOULD BE BETWEEN 0 AND 100, BUT IS NOT.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,143)PROP1
  143 FORMAT('THE VALUE OF PROP1 IS ',E15.7)
      CALL DPWRST('XXX','BUG ')
  149 CONTINUE
C
      IF(0.0.LE.PROP2.AND.PROP2.LE.100.0)GOTO159
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,151)
  151 FORMAT('***** ERROR IN WINSOR--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,152)
  152 FORMAT('PROP2 SHOULD BE BETWEEN 0 AND 100, BUT IS NOT.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,153)PROP2
  153 FORMAT('THE VALUE OF PROP2 IS ',E15.7)
      CALL DPWRST('XXX','BUG ')
  159 CONTINUE
C
  190 CONTINUE
C
C               ****************************************
C               **  STEP 2--                          **
C               **  COMPUTE THE WINSORIZED VARIABLE.  **
C               ****************************************
C
      CALL SORT(X,N,XTEMP)
C
      NPROP1=(PROP1/100.0)*AN+0.0001
      ISTART=NPROP1+1
C
      NPROP2=(PROP2/100.0)*AN+0.0001
      ISTOP=N-NPROP2
C
      IF(ISTART.GT.ISTOP)GOTO250
      ALOW=XTEMP(ISTART)
      AHIGH=XTEMP(ISTOP)
C
      DO200I=1,N
        IF(X(I).LT.ALOW)THEN
          Y(I)=ALOW
        ELSEIF(X(I).GT.AHIGH)THEN
          Y(I)=AHIGH
        ELSE
          Y(I)=X(I)
        ENDIF
  200 CONTINUE
      GOTO290
C
  250 CONTINUE
      IERROR='YES'
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,251)
  251 FORMAT('***** INTERNAL ERROR IN WINSOR--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,252)
  252 FORMAT('      START INDEX IS HIGHER THAN STOP INDEX.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,253)ISTART,ISTOP
  253 FORMAT('      ISTART,ISTOP = ',2I8)
      CALL DPWRST('XXX','BUG ')
      GOTO9000
  290 CONTINUE
C
C               *******************************
C               *******************************
C               **  STEP 3--                 **
C               **  WRITE OUT A LINE         **
C               **  OF SUMMARY INFORMATION.  **
C               *******************************
C
      IF(IFEEDB.EQ.'OFF')GOTO890
      IF(IWRITE.EQ.'OFF')GOTO890
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      PROP3=100.00-PROP1-PROP2
      NPROP3=N-NPROP1-NPROP2
      WRITE(ICOUT,811)PROP1,NPROP1
  811 FORMAT(8X,F10.4,' PERCENT (= ',I8,' OBSERVATIONS) ',
     1'OF THE DATA WERE WINSORIZED         FROM BELOW')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,812)PROP2,NPROP2
  812 FORMAT(8X,F10.4,' PERCENT (= ',I8,' OBSERVATIONS) ',
     1'OF THE DATA WERE WINSORIZED         FROM ABOVE')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,813)PROP3,NPROP3
  813 FORMAT(8X,F10.4,' PERCENT (= ',I8,' OBSERVATIONS) ',
     1'OF THE DATA REMAINING IN MIDDLE BEFORE WINSORIZING')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      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 WINSOR--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IBUGA3,IERROR
 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9014)N,PROP1,PROP2,PROP3
 9014 FORMAT('N,PROP1,PROP2,PROP3 = ',I8,3E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9015)NPROP1,NPROP2,NPROP3
 9015 FORMAT('NPROP1,NPROP2,NPROP3 = ',3I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9016)ISTART,ISTOP
 9016 FORMAT('ISTART,ISTOP = ',2I8)
      CALL DPWRST('XXX','BUG ')
      DO9017I=1,N
      WRITE(ICOUT,9018)XTEMP(I),Y(I)
 9018 FORMAT('XTEMP(I),Y = ',2E15.7)
      CALL DPWRST('XXX','BUG ')
 9017 CONTINUE
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE WNOPEN(I1,I2,I3,I4)
C     THIS IS A DUMMY SUBROUTINE TO BE "USED"
C     IN PLACE OF THE WNOPEN SUBROUTINE
C     IN THE OTG INTERACTOR WINDOW MANAGER LIBRARY.
C     IF YOU DO HAVE THAT LIBRARY, THEN DELETE THIS DUMMY SUBROUTINE.
C     IF YOU DO NOT HAVE THAT LIBRARY, THEN LEAVE THIS DUMMY
C     SUBROUTINE IN SO AS TO AVOID A MISSING EXTERNAL REFERENCE
C     AT LINK TIME.
      RETURN
      END
      SUBROUTINE WNCLOS(IJUNK)
C     THIS IS A DUMMY SUBROUTINE TO BE "USED"
C     IN PLACE OF THE WNCLOS SUBROUTINE
C     IN THE OTG INTERACTOR WINDOW MANAGER LIBRARY.
C     IF YOU DO HAVE THAT LIBRARY, THEN DELETE THIS DUMMY SUBROUTINE.
C     IF YOU DO NOT HAVE THAT LIBRARY, THEN LEAVE THIS DUMMY
C     SUBROUTINE IN SO AS TO AVOID A MISSING EXTERNAL REFERENCE
C     AT LINK TIME.
      RETURN
      END
      SUBROUTINE WSHRT(D, N, NP, NNP, SB, SA, ISEED)
C
C     ALGORITHM AS 53  APPL. STATIST. (1972) VOL.21, NO.3
C
C     Wishart variate generator.  On output, SA is an upper-triangular
C     matrix of size NP * NP (written in linear form, column ordered)
C     whose elements have a Wishart(N, SIGMA) distribution.
C
C     D is an upper-triangular array such that SIGMA = D'D (see AS 6)
C
C     Auxiliary function required: a random no. generator called RAND.
C     The Wichmann & Hill generator is included here.   It should be
C     initialized in the calling program.
C
      INTEGER N, NP, NNP
      REAL D(NNP), SB(NNP), SA(NNP)
C
C     Local variables
C
      INTEGER K, NS, I, J, NR, IP, NQ, II
      REAL DF, U1, U2, RN, C
      REAL ZERO, ONE, TWO, NINE
      DATA ZERO /0.0/, ONE /1.0/, TWO /2.0/, NINE /9.0/
C
      K = 1
    1 CONTINUE
      CALL RNORM(U1, U2, ISEED)
C
C     Load SB with independent normal (0, 1) variates
C
      SB(K) = U1
      K = K + 1
      IF (K .GT. NNP) GO TO 2
      SB(K) = U2
      K = K + 1
      IF (K .LE. NNP) GO TO 1
    2 NS = 0
C
C     Load diagonal elements with square root of chi-square variates
C
      DO 3 I = 1, NP
        DF = N - I + 1
        NS = NS + I
        U1 = TWO / (NINE * DF)
        U2 = ONE - U1
        U1 = SQRT(U1)
C
C     Wilson-Hilferty formula for approximating chi-square variates
C
        SB(NS) = SQRT(DF * (U2 + SB(NS) * U1)**3)
    3 CONTINUE
C
      RN = N
      NR = 1
      DO 5 I = 1, NP
        NR = NR + I - 1
        DO 5 J = I, NP
          IP = NR
          NQ = (J*J - J) / 2 + I - 1
          C = ZERO
          DO 4 K = I, J
            IP = IP + K - 1
            NQ = NQ + 1
            C = C + SB(IP) * D(NQ)
    4     CONTINUE
        SA(IP) = C
    5 CONTINUE
C
      DO 7 I = 1, NP
      II = NP - I + 1
      NQ = NNP - NP
      DO 7 J = 1, I
        IP = (II*II - II) / 2
        C = ZERO
        DO 6 K = I, NP
          IP = IP + 1
          NQ = NQ + 1
          C = C + SA(IP) * SA(NQ)
    6     CONTINUE
          SA(NQ) = C / RN
          NQ = NQ - 2 * NP + I + J - 1
    7 CONTINUE
C
      RETURN
      END
      DOUBLE PRECISION FUNCTION Y0INT(XVALUE)
C
C   DESCRIPTION:
C
C      This function calculates the integral of the Bessel
C      function Y0, defined as
C
C        Y0INT(x) = {integral 0 to x} Y0(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 x < 0.0, the function is undefined. An error message
C      is printed and the function returns the value 0.0.
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
C
C      NTERM2 - The no. of terms to be used from the array
C                ARY01. The recommended value is such that
C                   ABS(ARY01(NTERM2)) < EPS/100
C
C      NTERM3 - The no. of terms to be used from the array
C                ARY0A1. The recommended value is such that
C                   ABS(ARY0A1(NTERM3)) < EPS/100
C
C      NTERM4 - The no. of terms to be used from the array
C                ARY0A2. The recommended value is such that
C                   ABS(ARY0A2(NTERM4)) < EPS/100
C
C      XLOW - The value of x below which
C                  Y0INT(x) = x*(ln(x) - 0.11593)*2/pi
C             to machine-precision. The recommended value is
C                 sqrt(9*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, 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 , LOG , 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 NTERM1,NTERM2,NTERM3,NTERM4
      DOUBLE PRECISION ARJ01(0:23),ARY01(0:24),ARY0A1(0:21),
     1     ARY0A2(0:18),CHEVAL,FIVE12,GAL2M1,GAMLN2,
     2     NINE,ONE,ONEHUN,ONE28,PIB41,PIB411,PIB412,
     3     PIB42,RT2BPI,SIXTEN,T,TEMP,TWOBPI,X,XHIGH,
     4     XLOW,XMPI4,XVALUE,ZERO
CCCCC CHARACTER FNNAME*6,ERMSG1*14,ERMSG2*18
CCCCC DATA FNNAME/'Y0INT '/
CCCCC DATA ERMSG1/'ARGUMENT < 0.0'/
CCCCC DATA ERMSG2/'ARGUMENT TOO LARGE'/
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 NINE,SIXTEN/ 9.0 D 0 , 16.0 D 0 /
      DATA ONEHUN,ONE28,FIVE12/ 100.0 D 0 , 128.0 D 0 , 512.0 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 TWOBPI/0.63661 97723 67581 34308 D 0/
      DATA GAL2M1/-1.11593 15156 58412 44881 D 0/      
      DATA GAMLN2/-0.11593 15156 58412 44881 D 0/      
      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 ARY01(0)/  0.54492 69630 27243 65490  D    0/
      DATA ARY01(1)/ -0.14957 32358 86847 82157  D    0/
      DATA ARY01(2)/  0.11085 63448 62548 42337  D    0/
      DATA ARY01(3)/ -0.94953 30018 68377 7109   D   -1/
      DATA ARY01(4)/  0.68208 17786 99145 6963   D   -1/
      DATA ARY01(5)/ -0.10324 65338 33682 00408  D    0/
      DATA ARY01(6)/  0.10625 70328 75344 25491  D    0/
      DATA ARY01(7)/ -0.62583 67679 96168 1990   D   -1/
      DATA ARY01(8)/  0.23856 45760 33829 3285   D   -1/
      DATA ARY01(9)/ -0.64486 49130 15404 481    D   -2/
      DATA ARY01(10)/ 0.13128 70828 91002 331    D   -2/
      DATA ARY01(11)/-0.20988 08817 49896 40     D   -3/
      DATA ARY01(12)/ 0.27160 42484 13834 7      D   -4/
      DATA ARY01(13)/-0.29119 91140 14694        D   -5/
      DATA ARY01(14)/ 0.26344 33309 3795         D   -6/
      DATA ARY01(15)/-0.20411 72069 780          D   -7/
      DATA ARY01(16)/ 0.13712 47813 17           D   -8/
      DATA ARY01(17)/-0.80706 80792              D  -10/
      DATA ARY01(18)/ 0.41988 3057               D  -11/
      DATA ARY01(19)/-0.19459 104                D  -12/
      DATA ARY01(20)/ 0.80878 2                  D  -14/
      DATA ARY01(21)/-0.30329                    D  -15/
      DATA ARY01(22)/ 0.1032                     D  -16/
      DATA ARY01(23)/-0.32                       D  -18/
      DATA ARY01(24)/ 0.1                        D  -19/
      DATA ARY0A1(0)/  1.24030 13303 75189 70827  D    0/
      DATA ARY0A1(1)/ -0.47812 53536 32280 693    D   -2/
      DATA ARY0A1(2)/  0.66131 48891 70667 8      D   -4/
      DATA ARY0A1(3)/ -0.18604 27404 86349        D   -5/
      DATA ARY0A1(4)/  0.83627 35565 080          D   -7/
      DATA ARY0A1(5)/ -0.52585 70367 31           D   -8/
      DATA ARY0A1(6)/  0.42606 36325 1            D   -9/
      DATA ARY0A1(7)/ -0.42117 61024              D  -10/
      DATA ARY0A1(8)/  0.48894 6426               D  -11/
      DATA ARY0A1(9)/ -0.64834 929                D  -12/
      DATA ARY0A1(10)/ 0.96172 34                 D  -13/
      DATA ARY0A1(11)/-0.15703 67                 D  -13/
      DATA ARY0A1(12)/ 0.27871 2                  D  -14/
      DATA ARY0A1(13)/-0.53222                    D  -15/
      DATA ARY0A1(14)/ 0.10844                    D  -15/
      DATA ARY0A1(15)/-0.2342                     D  -16/
      DATA ARY0A1(16)/ 0.533                      D  -17/
      DATA ARY0A1(17)/-0.127                      D  -17/
      DATA ARY0A1(18)/ 0.32                       D  -18/
      DATA ARY0A1(19)/-0.8                        D  -19/
      DATA ARY0A1(20)/ 0.2                        D  -19/
      DATA ARY0A1(21)/-0.1                        D  -19/
      DATA ARY0A2(0)/  1.99616 09630 13416 75339  D    0/
      DATA ARY0A2(1)/ -0.19037 98192 46668 161    D   -2/
      DATA ARY0A2(2)/  0.15397 10927 04422 6      D   -4/
      DATA ARY0A2(3)/ -0.31145 08832 8103         D   -6/
      DATA ARY0A2(4)/  0.11108 50971 321          D   -7/
      DATA ARY0A2(5)/ -0.58666 78712 3            D   -9/
      DATA ARY0A2(6)/  0.41399 26949              D  -10/
      DATA ARY0A2(7)/ -0.36539 8763               D  -11/
      DATA ARY0A2(8)/  0.38557 568                D  -12/
      DATA ARY0A2(9)/ -0.47098 00                 D  -13/
      DATA ARY0A2(10)/ 0.65022 0                  D  -14/
      DATA ARY0A2(11)/-0.99624                    D  -15/
      DATA ARY0A2(12)/ 0.16700                    D  -15/
      DATA ARY0A2(13)/-0.3028                     D  -16/
      DATA ARY0A2(14)/ 0.589                      D  -17/
      DATA ARY0A2(15)/-0.122                      D  -17/
      DATA ARY0A2(16)/ 0.27                       D  -18/
      DATA ARY0A2(17)/-0.6                        D  -19/
      DATA ARY0A2(18)/ 0.1                        D  -19/
C
C   Start computation
C
      X = XVALUE
C
C   First error test
C
      IF ( X .LT. ZERO ) THEN
CCCCC    CALL ERRPRN(FNNAME,ERMSG1)
         WRITE(ICOUT,999)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,101)X
         CALL DPWRST('XXX','BUG ')
         Y0INT = 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)
      XHIGH = ONE / TEMP
C
C   Second error test 
C
      IF ( X .GT. XHIGH ) THEN
CCCCC    CALL ERRPRN(FNNAME,ERMSG2)
         WRITE(ICOUT,999)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,201)X
         CALL DPWRST('XXX','BUG ')
         Y0INT = ZERO
         RETURN
      ENDIF
  201 FORMAT('***** ERROR FROM Y0INT--SIZE OF THE INPUT ARGUMENT ',
     1        'IS TOO LARGE, ARGUMENT = ',G15.7)
C
C   continue with machine 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      DO 20 NTERM2 = 24 , 0 , -1
            IF ( ABS(ARY01(NTERM2)) .GT. T ) GOTO 29
 20      CONTINUE
 29      XLOW = SQRT ( NINE * TEMP )
      ELSE
         DO 40 NTERM3 = 21 , 0 , -1
            IF ( ABS(ARY0A1(NTERM3)) .GT. T ) GOTO 49
 40      CONTINUE
 49      DO 50 NTERM4 = 18 , 0 , -1
            IF ( ABS(ARY0A2(NTERM4)) .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
            IF ( X .EQ. ZERO ) THEN
               Y0INT = ZERO
            ELSE 
               Y0INT = ( LOG(X) + GAL2M1 ) * TWOBPI * X
            ENDIF
         ELSE
            T = X * X / ONE28 - ONE
            TEMP = ( LOG(X) + GAMLN2 ) * CHEVAL(NTERM1,ARJ01,T)
            TEMP = TEMP - CHEVAL(NTERM2,ARY01,T)
            Y0INT = TWOBPI * X * TEMP
         ENDIF
      ELSE
C
C   Code for x > 16
C
         T = FIVE12 / ( X * X ) - ONE
         PIB41 = PIB411 / PIB412
         XMPI4 = ( X - PIB41 ) - PIB42
         TEMP = SIN(XMPI4) * CHEVAL(NTERM3,ARY0A1,T) / X
         TEMP = TEMP + COS(XMPI4) * CHEVAL(NTERM4,ARY0A2,T)
         Y0INT = - RT2BPI * TEMP / SQRT(X)
      ENDIF
      RETURN
      END
      SUBROUTINE YULCDF(X,P,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE DISCRETE YULE
C              DISTRIBUTION WITH SHAPE PARAMETERS = P.
C              THIS DISTRIBUTION IS DEFINED FOR ALL INTEGER X >= 0.
C              THE PROBABILITY DENSITY FUNCTION IS:
C                 P(X,P)=P*P!*X!/(X+P+1)!         X = 0, 1, 2, ...
C                       =P*GAMMA(P+1)*GAMMA(X+1)/GAMMA(X+P+2)
C              NOTE THAT THE YULE IS ALSO SOMETIME DEFINED AS
C                 P(X,P)=P*P!*(X-1)!/(X+P)!       X = 1, 2, ...
C              THE YULE IS ALSO A SPECIAL CASE OF THE WARING
C              DISTRIBUTION:
C                 YULCDF(X,P) = WARCDF(X,P-1,1)
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                     --P    = THE SHAPE PARAMETER
C     OUTPUT ARGUMENTS--CDF    = THE SINGLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE A NON-NEGATIVE INTEGER
C                 --P SHOULD BE POSITIVIE
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND KEMP, DISCRETE UNIVARIATE
C                 DISTRIBUTIONS--SECOND EDITION, 1992, PP. 276-279.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF 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/4
C     ORIGINAL VERSION--APRIL     2004.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DTERM1, DTERM2, DTERM3, DTERM4, DTERM5
      DOUBLE PRECISION DX, DP
      DOUBLE PRECISION DCDF
      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-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(P.LT.0.1)THEN
        WRITE(ICOUT,15)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)P
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9999
      ENDIF
C
      IX=X+0.5
      IF(IX.LT.0)THEN
        WRITE(ICOUT,4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9999
      ENDIF
C
    4 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO THE ',
     1'YULCDF SUBROUTINE IS LESS THAN 0')
   15 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO THE ',
     1'YULCDF SUBROUTINE IS < 0.1')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
      DP=DBLE(P)
C
      DCDF=0.0D0
      DTERM1=DLOG(DP)
      DTERM3=DLNGAM(DP+1.0D0)
      DO100I=IX,0,-1
        DX=DBLE(I)
        DTERM2=DLNGAM(DX+1.0)
        DTERM4=DLNGAM(DP+DX+2.0D0)
        DTERM5=DTERM1+DTERM2+DTERM3-DTERM4
        DCDF=DCDF + DEXP(DTERM5)
  100 CONTINUE
C
      CDF=REAL(DCDF)
C
 9999 CONTINUE
      RETURN
      END
      REAL FUNCTION YULFU2(X,XFREQ,VK)
C
C     PURPOSE--DPMLYU CALLS FZERO TO FIND A ROOT FOR THE LIKELIHOOD
C              FUNCTION.  YULFU2 IS THE FUNCTION FOR WHICH
C              THE ZERO IS FOUND.  IT IS:
C                 N/(X*(X-1)) -SUM[K=2 to LAMBDA][V(K)/(X+K-1)]
C              WITH V(K) DENOTING THE CUMULATIVE FREQUENCY FROM
C              K UPWARDS.
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 YULFU2.
C     PRINTING--NONE.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, BALKRISHNAN, "CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS, VOLUME 1", WILEY, 1994 (PAGE 63).
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 XFREQ(*)
      REAL VK(*)
      COMMON/YULCOM/NTOT,NCLASS
C
      REAL TERM1
      DOUBLE PRECISION DSUM1
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      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
      TERM1=REAL(NTOT)/(X*(X-1.0))
      DSUM1=0.0D0
      DO100K=1,NCLASS
        IF(XFREQ(K).GE.1)THEN
          DSUM1=DSUM1 + VK(K)/(X+REAL(K)-1.0)
        ENDIF
  100 CONTINUE
      YULFU2=TERM1 - REAL(DSUM1)
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE YULPDF(X,P,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE DISCRETE YULE
C              DISTRIBUTION WITH SHAPE PARAMETER = P.
C              THIS DISTRIBUTION IS DEFINED FOR ALL INTEGER X >= 0.
C              THE PROBABILITY DENSITY FUNCTION IS:
C                 P(X,P)=P*P!*X!/(X+P+1)!         X = 0, 1, 2, ...
C                       =P*GAMMA(P+1)*GAMMA(X+1)/GAMMA(X+P+2)
C              NOTE THAT THE YULE IS ALSO SOMETIME DEFINED AS
C                 P(X,P)=P*P!*(X-1)!/(X+P)!       X = 1, 2, ...
C              THE YULE IS ALSO A SPECIAL CASE OF THE WARING
C              DISTRIBUTION:
C                 YULPDF(X,P) = WARPDF(X,P-1,1)
C              CURRENTLY, WE ONLY SUPPORT THE CASE WHERE P > 0.1
C              (TAIL GETS INFINITELY LONG AS P GOES TO 0).
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                     --P    = THE SHAPE PARAMETER
C     OUTPUT ARGUMENTS--PDF    = THE SINGLE PRECISION DENSITY
C                                FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE A NON-NEGATIVE INTEGER
C                 --P SHOULD BE POSITIVIE
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND KEMP, DISCRETE UNIVARIATE
C                 DISTRIBUTIONS--SECOND EDITION, 1992, PP. 276-279.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF 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/4
C     ORIGINAL VERSION--APRIL     2004.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DTERM1, DTERM2, DTERM3, DTERM4, DTERM5
      DOUBLE PRECISION DX, DP
      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-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
C  FOR NOW, DO NOT ACCEPT VALUES OF P < 0.1
C
      IF(P.LT.0.1)THEN
        WRITE(ICOUT,15)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)P
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ENDIF
C
      IX=X+0.5
      IF(IX.LT.0)THEN
        WRITE(ICOUT,4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ENDIF
C
    4 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO THE ',
     1'YULPDF SUBROUTINE IS LESS THAN 0')
   15 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO THE ',
     1'YULPDF SUBROUTINE IS < 0.1')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
      DX=DBLE(IX)
      DP=DBLE(P)
C
      DTERM1=DLOG(DP)
      DTERM2=DLNGAM(DX+1.0)
      DTERM3=DLNGAM(DP+1.0D0)
      DTERM4=DLNGAM(DP+DX+2.0D0)
      DTERM5=DTERM1+DTERM2+DTERM3-DTERM4
      DPDF=EXP(DTERM5)
C
      PDF=REAL(DPDF)
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE YULPPF(P,PPAR,PPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE AT THE SINGLE PRECISION VALUE P
C              FOR THE YULE DISTRIBUTION.
C              THIS DISTRIBUTION IS DEFINED FOR ALL INTEGER X >= 0.
C              THE PROBABILITY DENSITY FUNCTION IS:
C                 P(X,P)=P*P!*X!/(X+P+1)!         X = 0, 1, 2, ...
C                       =P*GAMMA(P+1)*GAMMA(X+1)/GAMMA(X+P+2)
C              NOTE THAT THE YULE IS ALSO SOMETIME DEFINED AS
C                 P(X,P)=P*P!*(X-1)!/(X+P)!       X = 1, 2, ...
C              THE YULE IS ALSO A SPECIAL CASE OF THE WARING
C              DISTRIBUTION:
C                 YULPDF(X,P) = WARPDF(X,P-1,1)
C              CURRENTLY, WE ONLY SUPPORT THE CASE WHERE P > 0.1
C              (TAIL GETS INFINITELY LONG AS P GOES TO 0).
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                     --PPAR   = THE SHAPE PARAMETER
C     OUTPUT ARGUMENTS--PPF    = THE SINGLE PRECISION PERCENT POINT
C                                FUNCTION VALUE.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--P SHOULD BE BETWEEN 0 AND 1 (EXCLUSIVELY FOR 1).
C                 --PPAR SHOULD BE GREATER THAN 0.1
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     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND KEMP, DISCRETE UNIVARIATE
C                 DISTRIBUTIONS--SECOND EDITION, 1992, PP. 276-279.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF 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/4
C     ORIGINAL VERSION--APRIL     2004.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DTERM1, DTERM2, DTERM3, DTERM4, DTERM5
      DOUBLE PRECISION DX, DP
      DOUBLE PRECISION DCDF
      DOUBLE PRECISION DLNGAM
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
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
      ENDIF
      IF(PPAR.LT.0.1)THEN
        WRITE(ICOUT,15)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)PPAR
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
        GOTO9999
      ENDIF
    1 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO THE ',
     1' YULPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1] INTERVAL')
   15 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO THE ',
     1'YULPPF SUBROUTINE IS < 0.1')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8)
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     USE BRUTE FORCE METHOD WHERE CALCULATE CDF UNTIL CUMULATIVE
C     PROBABILITY IS GREATER THAN INPUT PROBABILITY.  DO THIS SINCE
C     YULE CDF DOES NOT CURRENTLY UTILIZE MORE EFFICIENT
C     APPROXIMATIONS.
C
      IUPPER=2000000
C
      DP=DBLE(PPAR)
      DCDF=0.0D0
C
      DTERM1=DLOG(DP)
      DTERM3=DLNGAM(DP+1.0D0)
      DO1000I=0,IUPPER
        DX=DBLE(I)
        DTERM2=DLNGAM(DX+1.0D0)
        DTERM4=DLNGAM(DP+DX+2.0D0)
        DTERM5=DTERM1+DTERM2+DTERM3-DTERM4
        DCDF=DCDF + DEXP(DTERM5)
        IF(DCDF.GE.DBLE(P))THEN
          PPF=REAL(I)
          GOTO9999
        ENDIF
 1000 CONTINUE
C
      PPF=REAL(IUPPER)
      WRITE(ICOUT,3000)IUPPER,IUPPER
 3000 FORMAT('****** PPF VALUE EXCEEDS ',I8,' .  TRUNCATED AT ',
     1'THIS VALUE.')
      CALL DPWRST('XXX','BUG ')
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE YULRAN(N,P,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE YULE DISTRIBUTION
C              WITH SINGLE PRECISION SHAPE PARAMETER P.
C              THIS DISTRIBUTION IS DEFINED FOR ALL INTEGER X >= 0.
C              THE PROBABILITY DENSITY FUNCTION IS:
C                 P(X,P)=P*P!*X!/(X+P+1)!         X = 0, 1, 2, ...
C                       =P*GAMMA(P+1)*GAMMA(X+1)/GAMMA(X+P+2)
C              NOTE THAT THE YULE IS ALSO SOMETIME DEFINED AS
C                 P(X,P)=P*P!*(X-1)!/(X+P)!       X = 1, 2, ...
C              THE YULE IS ALSO A SPECIAL CASE OF THE WARING
C              DISTRIBUTION:
C                 YULPDF(X,P) = WARPDF(X,P-1,1)
C              CURRENTLY, WE ONLY SUPPORT THE CASE WHERE P > 0.1
C              (TAIL GETS INFINITELY LONG AS P GOES TO 0).
C     ALGORITHM--FROM PAGE 553 OF
C                "NON-UNIFORM RANDOM VARIATE GENERATION",
C                LUC DEVROYE, SPRINGER-VERLAG, 1986.
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --P      = THE SINGLE PRECISION VALUE
C                                OF THE SHAPE PARAMETER FOR THE
C                                YULE DISTRIBUTION.
C                                P SHOULD BE >= 0.1.
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 LOGARITHMIC SERIES 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                 --P SHOULD BE >= 0.1
C     OTHER DATAPAC   SUBROUTINES NEEDED--EXPRAN.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--ALOG.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--LUC DEVROYE, "NON-UNIFORM RANDOM VARIATE
C                 GENERATION", SPRINGER-VERLAG, 1986, P. 553.
C     WRITTEN BY--JAMES J. FILLIBEN
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--2004/4
C     ORIGINAL VERSION--APRIL     2004.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
      DIMENSION U(2)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)THEN
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
      IF(P.LT.0.1)THEN
        WRITE(ICOUT,15)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)P
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ENDIF
C
    5 FORMAT('***** ERROR--NUMBER OF YULE RANDOM ',
     1'NUMBERS REQUESTED IS LESS THAN 1')
   15 FORMAT('***** ERROR--THE SHAPE PARAMETER FOR THE YULE ',
     1'DISTRIBUTION IS < 0.1')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8)
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8)
C
C     GENERATE N YULE  RANDOM NUMBERS
C
C     ALGORITHM:
C     X = -E/[LOG(1 - EXP(-E*/P))]
C
C     WITH E AND E* DENOTING INDEPENDENT EXPONENTIAL RANDOM
C     VARIABLES.
C
      NTEMP=2
      DO100I=1,N
  110   CONTINUE
        CALL EXPRAN(NTEMP,ISEED,U)
        E1=U(1)
        E2=U(2)
        DENOM=LOG(1.0 - EXP(-E2/P))
        ATEMP=-E1/DENOM
        ITEMP=INT(ATEMP)
        X(I)=REAL(ITEMP)
        IF(X(I).LT.0.0)GOTO110
  100 CONTINUE
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE XTXINV(AMAT1,AMAT2,Y1,Y2,INDX,
     1MAXROM,MAXCOM,NR1,NC1,
     1IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE
C              (X'X)**(-1) MATRIX:
C              THIS MATRIX IS USEFUL FOR SOME REGRESSION DIAGNOSTIC
C              CAPABILITIES (E.G., THE CONDITION INDICES).
C     INPUT  ARGUMENTS--AMAT1  = THE DESIGN MATRIX (X)
C                     --Y1     = A SCRATCH VECTOR
C                     --Y2     = A SCRATCH VECTOR
C                     --INDX   = A SCRATCH INTEGER) VECTOR
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     OUTPUT ARGUMENTS--AMAT2  = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED CATCHER MATRTIX
C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUES OF THE
C             CATCHER MATRIX.
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                 WASHINGTON, D. C. 20234
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--2002.6
C     ORIGINAL VERSION--JUNE      2002.
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 AMAT1(MAXROM,MAXCOM)
      DIMENSION AMAT2(MAXROM,MAXCOM)
      DIMENSION Y1(*)
      DIMENSION Y2(*)
      INTEGER   INDX(*)
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 ZERO /0.0/
      DATA ONE  /1.0/
      DATA EPS  /1.0E-20/
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='XTXI'
      ISUBN2='NV  '
C
      IWRITE='OFF'
      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 XTXINV--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)IBUGA3
   52 FORMAT('IBUGA3 = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)MAXROM,MAXCOM,NR1,NC1
   53 FORMAT('MAXROM, MAXCOM, NR1, NC1 = ',4I8)
      CALL DPWRST('XXX','BUG ')
      ENDIF
C
C               **********************************
C               **  COMPUTE CATCHER MATRIX      **
C               **  1) COMPUTE X'X              **
C               **  2) COMPUTE INVERSE OF X'X   **
C               **  3) COMPUTE X TIMES INVERSE  **
C               **********************************
C
      DO110J=1,MAXCOM
        DO120I=1,MAXROM
          AMAT2(I,J)=ZERO
  120   CONTINUE
  110 CONTINUE
C
      CALL SGEMM ('T', 'N', NC1, NC1, NR1, ONE, AMAT1, MAXROM,
     $             AMAT1, MAXROM, ZERO, AMAT2, MAXROM, IERROR)
      IF(IERROR.EQ.'YES')RETURN
C
      IF(IBUGA3.EQ.'ON')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,151)
  151   FORMAT('***** IN XTXINV, AFTER CALL SGEMM--')
        CALL DPWRST('XXX','BUG ')
        DO 152 I=1,NC1
          WRITE(ICOUT,153)I,(AMAT2(I,J),J=1,MIN(5,NC1))
  153     FORMAT('***** I,AMAT2(I,1..MIN(NC1,5)',I8,5E15.7)
          CALL DPWRST('XXX','BUG ')
  152   CONTINUE
      ENDIF
C
      RCOND=0.0
      CALL SGECO(AMAT2,MAXROM,NC1,INDX,RCOND,Y1)
C
      IF(IBUGA3.EQ.'ON')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,171)RCOND
  171   FORMAT('***** IN XTXINV, AFTER CALL SGECO, RCOND=',E15.7)
        CALL DPWRST('XXX','BUG ')
        DO 172 I=1,NC1
          WRITE(ICOUT,173)I,(AMAT2(I,J),J=1,MIN(5,NC1))
  173     FORMAT('***** I,AMAT2(I,1..MIN(NC1,5)',I8,5E15.7)
          CALL DPWRST('XXX','BUG ')
  172   CONTINUE
      ENDIF
C
      IF(RCOND.LE.EPS)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 XTXINV: UNABLE TO COMPUTE THE INVERSE OF ',
     1       'THE X-TRANSPOSE*X 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,INDX,Y1,Y2,IJOB)
C
      IF(IBUGA3.EQ.'ON')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,181)
  181   FORMAT('***** IN XTXINV, AFTER CALL SGEDI')
        CALL DPWRST('XXX','BUG ')
        DO 182 I=1,NC1
          WRITE(ICOUT,183)I,(AMAT2(I,J),J=1,MIN(5,NC1))
  183     FORMAT('***** I,AMAT2(I,1..MIN(NC1,5)',I8,5E15.7)
          CALL DPWRST('XXX','BUG ')
  182   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 XTXINV--')
      CALL DPWRST('XXX','BUG ')
      DO9022I=1,NR1
        WRITE(ICOUT,9023)I,(AMAT2(I,J),J=1,MIN(5,NC1))
 9023   FORMAT('***** I,AMAT2(I,1..MIN(NC1,5)',I8,5E15.7)
        CALL DPWRST('XXX','BUG ')
 9022 CONTINUE
      WRITE(ICOUT,9012)IBUGA3,IERROR
 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE YATES(IR,IC,OUT)
C
C     PURPOSE--DETERMINE IF THE ELEMENT IN ROW IR AND COLUMN IC
C              OF A MATRIX IN STANDARD YATES ORDER IS -1 OR +1.
C     OUTPUT--THE FLOATING POINT SCALAR OUT CONSISTING OF -1 OR +1.
C     DATE--SEPTEMBER 1993
C     ORIGINAL VERSION--SEPTEMBER 1993.
C
C---------------------------------------------------------------------
C
C-----START POINT-----------------------------------------------------
C
      N=2**IC
      NHALF=N/2
C
      OUT=+1.0
      I=MOD(IR,N)
      IF(1.LE.I.AND.I.LE.NHALF)OUT=-1.0
C
      RETURN
      END
      SUBROUTINE YAIRY (X, RX, C, BI, DBI)
C***BEGIN PROLOGUE  YAIRY
C***SUBSIDIARY
C***PURPOSE  Subsidiary to BESJ and BESY
C***LIBRARY   SLATEC
C***TYPE      SINGLE PRECISION (YAIRY-S, DYAIRY-D)
C***AUTHOR  Amos, D. E., (SNLA)
C           Daniel, S. L., (SNLA)
C***DESCRIPTION
C
C                  YAIRY computes the Airy function BI(X)
C                   and its derivative DBI(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        BI  - Value of function BI(X)
C       DBI  - Value of the derivative DBI(X)
C
C***SEE ALSO  BESJ, BESY
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   750101  DATE WRITTEN
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  YAIRY
C
      INTEGER I, J, M1, M1D, M2, M2D, M3, M3D, M4D, N1, N1D, N2, N2D,
     1 N3, N3D, N4D
      REAL AA, AX, BB, BI, BJN, BJP, BK1, BK2, BK3, BK4, C, CON1, CON2,
     1 CON3, CV, DAA, DBB, DBI, DBJN, DBJP, DBK1, DBK2, DBK3, DBK4, D1,
     2 D2, EX, E1, E2, FPI12, F1, F2, RTRX, RX, SPI12, S1, S2, T, TC,
     3 TEMP1, TEMP2, TT, X
      DIMENSION BK1(20), BK2(20), BK3(20), BK4(14)
      DIMENSION BJP(19), BJN(19), AA(14), BB(14)
      DIMENSION DBK1(21), DBK2(20), DBK3(20), DBK4(14)
      DIMENSION DBJP(19), DBJN(19), DAA(14), DBB(14)
      SAVE N1, N2, N3, M1, M2, M3, N1D, N2D, N3D, N4D,
     1 M1D, M2D, M3D, M4D, FPI12, SPI12, CON1, CON2, CON3,
     2 BK1, BK2, BK3, BK4, BJP, BJN, AA, BB, DBK1, DBK2, DBK3, DBK4,
     3 DBJP, DBJN, DAA, DBB
      DATA N1,N2,N3/20,19,14/
      DATA M1,M2,M3/18,17,12/
      DATA N1D,N2D,N3D,N4D/21,20,19,14/
      DATA M1D,M2D,M3D,M4D/19,18,17,12/
      DATA FPI12,SPI12,CON1,CON2,CON3/
     1 1.30899693899575E+00, 1.83259571459405E+00, 6.66666666666667E-01,
     2 7.74148278841779E+00, 3.64766105490356E-01/
      DATA BK1(1),  BK1(2),  BK1(3),  BK1(4),  BK1(5),  BK1(6),
     1     BK1(7),  BK1(8),  BK1(9),  BK1(10), BK1(11), BK1(12),
     2     BK1(13), BK1(14), BK1(15), BK1(16), BK1(17), BK1(18),
     3     BK1(19), BK1(20)/ 2.43202846447449E+00, 2.57132009754685E+00,
     4 1.02802341258616E+00, 3.41958178205872E-01, 8.41978629889284E-02,
     5 1.93877282587962E-02, 3.92687837130335E-03, 6.83302689948043E-04,
     6 1.14611403991141E-04, 1.74195138337086E-05, 2.41223620956355E-06,
     7 3.24525591983273E-07, 4.03509798540183E-08, 4.70875059642296E-09,
     8 5.35367432585889E-10, 5.70606721846334E-11, 5.80526363709933E-12,
     9 5.76338988616388E-13, 5.42103834518071E-14, 4.91857330301677E-15/
      DATA BK2(1),  BK2(2),  BK2(3),  BK2(4),  BK2(5),  BK2(6),
     1     BK2(7),  BK2(8),  BK2(9),  BK2(10), BK2(11), BK2(12),
     2     BK2(13), BK2(14), BK2(15), BK2(16), BK2(17), BK2(18),
     3     BK2(19), BK2(20)/ 5.74830555784088E-01,-6.91648648376891E-03,
     4 1.97460263052093E-03,-5.24043043868823E-04, 1.22965147239661E-04,
     5-2.27059514462173E-05, 2.23575555008526E-06, 4.15174955023899E-07,
     6-2.84985752198231E-07, 8.50187174775435E-08,-1.70400826891326E-08,
     7 2.25479746746889E-09,-1.09524166577443E-10,-3.41063845099711E-11,
     8 1.11262893886662E-11,-1.75542944241734E-12, 1.36298600401767E-13,
     9 8.76342105755664E-15,-4.64063099157041E-15, 7.78772758732960E-16/
      DATA BK3(1),  BK3(2),  BK3(3),  BK3(4),  BK3(5),  BK3(6),
     1     BK3(7),  BK3(8),  BK3(9),  BK3(10), BK3(11), BK3(12),
     2     BK3(13), BK3(14), BK3(15), BK3(16), BK3(17), BK3(18),
     3     BK3(19), BK3(20)/ 5.66777053506912E-01, 2.63672828349579E-03,
     4 5.12303351473130E-05, 2.10229231564492E-06, 1.42217095113890E-07,
     5 1.28534295891264E-08, 7.28556219407507E-10,-3.45236157301011E-10,
     6-2.11919115912724E-10,-6.56803892922376E-11,-8.14873160315074E-12,
     7 3.03177845632183E-12, 1.73447220554115E-12, 1.67935548701554E-13,
     8-1.49622868806719E-13,-5.15470458953407E-14, 8.75741841857830E-15,
     9 7.96735553525720E-15,-1.29566137861742E-16,-1.11878794417520E-15/
      DATA BK4(1),  BK4(2),  BK4(3),  BK4(4),  BK4(5),  BK4(6),
     1     BK4(7),  BK4(8),  BK4(9),  BK4(10), BK4(11), BK4(12),
     2     BK4(13), BK4(14)/ 4.85444386705114E-01,-3.08525088408463E-03,
     3 6.98748404837928E-05,-2.82757234179768E-06, 1.59553313064138E-07,
     4-1.12980692144601E-08, 9.47671515498754E-10,-9.08301736026423E-11,
     5 9.70776206450724E-12,-1.13687527254574E-12, 1.43982917533415E-13,
     6-1.95211019558815E-14, 2.81056379909357E-15,-4.26916444775176E-16/
      DATA BJP(1),  BJP(2),  BJP(3),  BJP(4),  BJP(5),  BJP(6),
     1     BJP(7),  BJP(8),  BJP(9),  BJP(10), BJP(11), BJP(12),
     2     BJP(13), BJP(14), BJP(15), BJP(16), BJP(17), BJP(18),
     3     BJP(19)         / 1.34918611457638E-01,-3.19314588205813E-01,
     4 5.22061946276114E-02, 5.28869112170312E-02,-8.58100756077350E-03,
     5-2.99211002025555E-03, 4.21126741969759E-04, 8.73931830369273E-05,
     6-1.06749163477533E-05,-1.56575097259349E-06, 1.68051151983999E-07,
     7 1.89901103638691E-08,-1.81374004961922E-09,-1.66339134593739E-10,
     8 1.42956335780810E-11, 1.10179811626595E-12,-8.60187724192263E-14,
     9-5.71248177285064E-15, 4.08414552853803E-16/
      DATA BJN(1),  BJN(2),  BJN(3),  BJN(4),  BJN(5),  BJN(6),
     1     BJN(7),  BJN(8),  BJN(9),  BJN(10), BJN(11), BJN(12),
     2     BJN(13), BJN(14), BJN(15), BJN(16), BJN(17), BJN(18),
     3     BJN(19)         / 6.59041673525697E-02,-4.24905910566004E-01,
     4 2.87209745195830E-01, 1.29787771099606E-01,-4.56354317590358E-02,
     5-1.02630175982540E-02, 2.50704671521101E-03, 3.78127183743483E-04,
     6-7.11287583284084E-05,-8.08651210688923E-06, 1.23879531273285E-06,
     7 1.13096815867279E-07,-1.46234283176310E-08,-1.11576315688077E-09,
     8 1.24846618243897E-10, 8.18334132555274E-12,-8.07174877048484E-13,
     9-4.63778618766425E-14, 4.09043399081631E-15/
      DATA AA(1),   AA(2),   AA(3),   AA(4),   AA(5),   AA(6),
     1     AA(7),   AA(8),   AA(9),   AA(10),  AA(11),  AA(12),
     2     AA(13),  AA(14) /-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/
      DATA BB(1),   BB(2),   BB(3),   BB(4),   BB(5),   BB(6),
     1     BB(7),   BB(8),   BB(9),   BB(10),  BB(11),  BB(12),
     2     BB(13),  BB(14) /-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/
      DATA DBK1(1), DBK1(2), DBK1(3), DBK1(4), DBK1(5), DBK1(6),
     1     DBK1(7), DBK1(8), DBK1(9), DBK1(10),DBK1(11),DBK1(12),
     2     DBK1(13),DBK1(14),DBK1(15),DBK1(16),DBK1(17),DBK1(18),
     3     DBK1(19),DBK1(20),
     4     DBK1(21)        / 2.95926143981893E+00, 3.86774568440103E+00,
     5 1.80441072356289E+00, 5.78070764125328E-01, 1.63011468174708E-01,
     6 3.92044409961855E-02, 7.90964210433812E-03, 1.50640863167338E-03,
     7 2.56651976920042E-04, 3.93826605867715E-05, 5.81097771463818E-06,
     8 7.86881233754659E-07, 9.93272957325739E-08, 1.21424205575107E-08,
     9 1.38528332697707E-09, 1.50190067586758E-10, 1.58271945457594E-11,
     1 1.57531847699042E-12, 1.50774055398181E-13, 1.40594335806564E-14,
     2 1.24942698777218E-15/
      DATA DBK2(1), DBK2(2), DBK2(3), DBK2(4), DBK2(5), DBK2(6),
     1     DBK2(7), DBK2(8), DBK2(9), DBK2(10),DBK2(11),DBK2(12),
     2     DBK2(13),DBK2(14),DBK2(15),DBK2(16),DBK2(17),DBK2(18),
     3    DBK2(19),DBK2(20)/ 5.49756809432471E-01, 9.13556983276901E-03,
     4-2.53635048605507E-03, 6.60423795342054E-04,-1.55217243135416E-04,
     5 3.00090325448633E-05,-3.76454339467348E-06,-1.33291331611616E-07,
     6 2.42587371049013E-07,-8.07861075240228E-08, 1.71092818861193E-08,
     7-2.41087357570599E-09, 1.53910848162371E-10, 2.56465373190630E-11,
     8-9.88581911653212E-12, 1.60877986412631E-12,-1.20952524741739E-13,
     9-1.06978278410820E-14, 5.02478557067561E-15,-8.68986130935886E-16/
      DATA DBK3(1), DBK3(2), DBK3(3), DBK3(4), DBK3(5), DBK3(6),
     1     DBK3(7), DBK3(8), DBK3(9), DBK3(10),DBK3(11),DBK3(12),
     2     DBK3(13),DBK3(14),DBK3(15),DBK3(16),DBK3(17),DBK3(18),
     3    DBK3(19),DBK3(20)/ 5.60598509354302E-01,-3.64870013248135E-03,
     4-5.98147152307417E-05,-2.33611595253625E-06,-1.64571516521436E-07,
     5-2.06333012920569E-08,-4.27745431573110E-09,-1.08494137799276E-09,
     6-2.37207188872763E-10,-2.22132920864966E-11, 1.07238008032138E-11,
     7 5.71954845245808E-12, 7.51102737777835E-13,-3.81912369483793E-13,
     8-1.75870057119257E-13, 6.69641694419084E-15, 2.26866724792055E-14,
     9 2.69898141356743E-15,-2.67133612397359E-15,-6.54121403165269E-16/
      DATA DBK4(1), DBK4(2), DBK4(3), DBK4(4), DBK4(5), DBK4(6),
     1     DBK4(7), DBK4(8), DBK4(9), DBK4(10),DBK4(11),DBK4(12),
     2    DBK4(13),DBK4(14)/ 4.93072999188036E-01, 4.38335419803815E-03,
     3-8.37413882246205E-05, 3.20268810484632E-06,-1.75661979548270E-07,
     4 1.22269906524508E-08,-1.01381314366052E-09, 9.63639784237475E-11,
     5-1.02344993379648E-11, 1.19264576554355E-12,-1.50443899103287E-13,
     6 2.03299052379349E-14,-2.91890652008292E-15, 4.42322081975475E-16/
      DATA DBJP(1), DBJP(2), DBJP(3), DBJP(4), DBJP(5), DBJP(6),
     1     DBJP(7), DBJP(8), DBJP(9), DBJP(10),DBJP(11),DBJP(12),
     2     DBJP(13),DBJP(14),DBJP(15),DBJP(16),DBJP(17),DBJP(18),
     3     DBJP(19)        / 1.13140872390745E-01,-2.08301511416328E-01,
     4 1.69396341953138E-02, 2.90895212478621E-02,-3.41467131311549E-03,
     5-1.46455339197417E-03, 1.63313272898517E-04, 3.91145328922162E-05,
     6-3.96757190808119E-06,-6.51846913772395E-07, 5.98707495269280E-08,
     7 7.44108654536549E-09,-6.21241056522632E-10,-6.18768017313526E-11,
     8 4.72323484752324E-12, 3.91652459802532E-13,-2.74985937845226E-14,
     9-1.95036497762750E-15, 1.26669643809444E-16/
      DATA DBJN(1), DBJN(2), DBJN(3), DBJN(4), DBJN(5), DBJN(6),
     1     DBJN(7), DBJN(8), DBJN(9), DBJN(10),DBJN(11),DBJN(12),
     2     DBJN(13),DBJN(14),DBJN(15),DBJN(16),DBJN(17),DBJN(18),
     3     DBJN(19)        /-1.88091260068850E-02,-1.47798180826140E-01,
     4 5.46075900433171E-01, 1.52146932663116E-01,-9.58260412266886E-02,
     5-1.63102731696130E-02, 5.75364806680105E-03, 7.12145408252655E-04,
     6-1.75452116846724E-04,-1.71063171685128E-05, 3.24435580631680E-06,
     7 2.61190663932884E-07,-4.03026865912779E-08,-2.76435165853895E-09,
     8 3.59687929062312E-10, 2.14953308456051E-11,-2.41849311903901E-12,
     9-1.28068004920751E-13, 1.26939834401773E-14/
      DATA DAA(1),  DAA(2),  DAA(3),  DAA(4),  DAA(5),  DAA(6),
     1     DAA(7),  DAA(8),  DAA(9),  DAA(10), DAA(11), DAA(12),
     2     DAA(13), DAA(14)/ 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/
      DATA DBB(1),  DBB(2),  DBB(3),  DBB(4),  DBB(5),  DBB(6),
     1     DBB(7),  DBB(8),  DBB(9),  DBB(10), DBB(11), DBB(12),
     2     DBB(13), DBB(14)/ 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/
C***FIRST EXECUTABLE STATEMENT  YAIRY
      AX = ABS(X)
      RX = SQRT(AX)
      C = CON1*AX*RX
      IF (X.LT.0.0E0) GO TO 120
      IF (C.GT.8.0E0) GO TO 60
      IF (X.GT.2.5E0) GO TO 30
      T = (X+X-2.5E0)*0.4E0
      TT = T + T
      J = N1
      F1 = BK1(J)
      F2 = 0.0E0
      DO 10 I=1,M1
        J = J - 1
        TEMP1 = F1
        F1 = TT*F1 - F2 + BK1(J)
        F2 = TEMP1
   10 CONTINUE
      BI = T*F1 - F2 + BK1(1)
      J = N1D
      F1 = DBK1(J)
      F2 = 0.0E0
      DO 20 I=1,M1D
        J = J - 1
        TEMP1 = F1
        F1 = TT*F1 - F2 + DBK1(J)
        F2 = TEMP1
   20 CONTINUE
      DBI = T*F1 - F2 + DBK1(1)
      RETURN
   30 CONTINUE
      RTRX = SQRT(RX)
      T = (X+X-CON2)*CON3
      TT = T + T
      J = N1
      F1 = BK2(J)
      F2 = 0.0E0
      DO 40 I=1,M1
        J = J - 1
        TEMP1 = F1
        F1 = TT*F1 - F2 + BK2(J)
        F2 = TEMP1
   40 CONTINUE
      BI = (T*F1-F2+BK2(1))/RTRX
      EX = EXP(C)
      BI = BI*EX
      J = N2D
      F1 = DBK2(J)
      F2 = 0.0E0
      DO 50 I=1,M2D
        J = J - 1
        TEMP1 = F1
        F1 = TT*F1 - F2 + DBK2(J)
        F2 = TEMP1
   50 CONTINUE
      DBI = (T*F1-F2+DBK2(1))*RTRX
      DBI = DBI*EX
      RETURN
C
   60 CONTINUE
      RTRX = SQRT(RX)
      T = 16.0E0/C - 1.0E0
      TT = T + T
      J = N1
      F1 = BK3(J)
      F2 = 0.0E0
      DO 70 I=1,M1
        J = J - 1
        TEMP1 = F1
        F1 = TT*F1 - F2 + BK3(J)
        F2 = TEMP1
   70 CONTINUE
      S1 = T*F1 - F2 + BK3(1)
      J = N2D
      F1 = DBK3(J)
      F2 = 0.0E0
      DO 80 I=1,M2D
        J = J - 1
        TEMP1 = F1
        F1 = TT*F1 - F2 + DBK3(J)
        F2 = TEMP1
   80 CONTINUE
      D1 = T*F1 - F2 + DBK3(1)
      TC = C + C
      EX = EXP(C)
      IF (TC.GT.35.0E0) GO TO 110
      T = 10.0E0/C - 1.0E0
      TT = T + T
      J = N3
      F1 = BK4(J)
      F2 = 0.0E0
      DO 90 I=1,M3
        J = J - 1
        TEMP1 = F1
        F1 = TT*F1 - F2 + BK4(J)
        F2 = TEMP1
   90 CONTINUE
      S2 = T*F1 - F2 + BK4(1)
      BI = (S1+EXP(-TC)*S2)/RTRX
      BI = BI*EX
      J = N4D
      F1 = DBK4(J)
      F2 = 0.0E0
      DO 100 I=1,M4D
        J = J - 1
        TEMP1 = F1
        F1 = TT*F1 - F2 + DBK4(J)
        F2 = TEMP1
  100 CONTINUE
      D2 = T*F1 - F2 + DBK4(1)
      DBI = RTRX*(D1+EXP(-TC)*D2)
      DBI = DBI*EX
      RETURN
  110 BI = EX*S1/RTRX
      DBI = EX*RTRX*D1
      RETURN
C
  120 CONTINUE
      IF (C.GT.5.0E0) GO TO 150
      T = 0.4E0*C - 1.0E0
      TT = T + T
      J = N2
      F1 = BJP(J)
      E1 = BJN(J)
      F2 = 0.0E0
      E2 = 0.0E0
      DO 130 I=1,M2
        J = J - 1
        TEMP1 = F1
        TEMP2 = E1
        F1 = TT*F1 - F2 + BJP(J)
        E1 = TT*E1 - E2 + BJN(J)
        F2 = TEMP1
        E2 = TEMP2
  130 CONTINUE
      BI = (T*E1-E2+BJN(1)) - AX*(T*F1-F2+BJP(1))
      J = N3D
      F1 = DBJP(J)
      E1 = DBJN(J)
      F2 = 0.0E0
      E2 = 0.0E0
      DO 140 I=1,M3D
        J = J - 1
        TEMP1 = F1
        TEMP2 = E1
        F1 = TT*F1 - F2 + DBJP(J)
        E1 = TT*E1 - E2 + DBJN(J)
        F2 = TEMP1
        E2 = TEMP2
  140 CONTINUE
      DBI = X*X*(T*F1-F2+DBJP(1)) + (T*E1-E2+DBJN(1))
      RETURN
C
  150 CONTINUE
      RTRX = SQRT(RX)
      T = 10.0E0/C - 1.0E0
      TT = T + T
      J = N3
      F1 = AA(J)
      E1 = BB(J)
      F2 = 0.0E0
      E2 = 0.0E0
      DO 160 I=1,M3
        J = J - 1
        TEMP1 = F1
        TEMP2 = E1
        F1 = TT*F1 - F2 + AA(J)
        E1 = TT*E1 - E2 + BB(J)
        F2 = TEMP1
        E2 = TEMP2
  160 CONTINUE
      TEMP1 = T*F1 - F2 + AA(1)
      TEMP2 = T*E1 - E2 + BB(1)
      CV = C - FPI12
      BI = (TEMP1*COS(CV)+TEMP2*SIN(CV))/RTRX
      J = N4D
      F1 = DAA(J)
      E1 = DBB(J)
      F2 = 0.0E0
      E2 = 0.0E0
      DO 170 I=1,M4D
        J = J - 1
        TEMP1 = F1
        TEMP2 = E1
        F1 = TT*F1 - F2 + DAA(J)
        E1 = TT*E1 - E2 + DBB(J)
        F2 = TEMP1
        E2 = TEMP2
  170 CONTINUE
      TEMP1 = T*F1 - F2 + DAA(1)
      TEMP2 = T*E1 - E2 + DBB(1)
      CV = C - SPI12
      DBI = (TEMP1*COS(CV)-TEMP2*SIN(CV))*RTRX
      RETURN
      END
      double precision function zeroin(ax,bx,f,tol,ierror)
      double precision ax,bx,f,tol
c
c      NOTE: This subroutine used in computing the consensus mean
c            using the Iyer and Wang generalized tolerance interval
c            approach.
c
c            Modified for Dataplot 3/2006.
c
c      a zero of the function  f(x)  is computed in the
c      interval ax,bx .
c
c  input..
c
c  ax     left endpoint of initial interval
c  bx     right endpoint of initial interval
c  f      function subprogram which evaluates f(x) for any x in
c         the interval  ax,bx
c  tol    desired length of the interval of uncertainty of the
c         final result ( .ge. 0.0d0)
c
c
c  output..
c
c  zeroin abcissa approximating a zero of  f  in the interval ax,bx
c
c
c      it is assumed  that   f(ax)   and   f(bx)   have  opposite  signs
c  without  a  check.  zeroin  returns a zero  x  in the given interval
c  ax,bx  to within a tolerance  4*macheps*abs(x) + tol, where macheps
c  is the relative machine precision.
c
c  this function subprogram is a slightly  modified  translation  of
c  the algol 60 procedure  zero  given in  richard brent, algorithms
c  for c  minimization without derivatives, prentice - hall,
c  inc. (1973).
c
      integer           nstep, maxfn
      double precision  a,b,c,d,e,eps,fa,fb,fc,tol1,xm,p,q,r,s
      double precision  dabs,dsign
c
      CHARACTER*4 IERROR
C
      REAL CPUMIN
      REAL CPUMAX
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      data maxfn /100/
      data eps   /1.1102230246252D-16/
c
c initialization
c
      nstep = 0
      a = ax
      b = bx
      fa = f(a)
      fb = f(b)
c
      if (fa*fb .gt. 0.0d0) then
ccccc    write (*, '(A)') 'f(a) and f(b) not opposite signs'
ccccc    write (*, *) fa, fb
         WRITE(ICOUT,10)
   10    FORMAT('*****ERROR FROM CONSENSUS MEANS--')
         CALL DPWRST('XXX','WRIT')
         WRITE(ICOUT,12)
   12    FORMAT('     IN ZEROIN (ROOT FINDER), THE END POINTS')
         CALL DPWRST('XXX','WRIT')
         WRITE(ICOUT,14)
   14    FORMAT('     (FA AND FB) DO NOT HAVE OPPOSITE SIGNS.')
         CALL DPWRST('XXX','WRIT')
         WRITE(ICOUT,16)
   16    FORMAT('     FA = ',G15.7)
         CALL DPWRST('XXX','WRIT')
         WRITE(ICOUT,18)
   18    FORMAT('     FB = ',G15.7)
         CALL DPWRST('XXX','WRIT')
         ZEROIN=0.0
         IERROR='YES'
         GOTO9000
      end if
c
c begin step
c
   20 c = a
      fc = fa
      d = b - a
      e = d
   30 if (dabs(fc) .ge. dabs(fb)) go to 40
      a = b
      b = c
      c = a
      fa = fb
      fb = fc
      fc = fa
c
c convergence test
c
   40 tol1 = 2.0d0*eps*dabs(b) + 0.5d0*tol
      xm = .5*(c - b)
      if (dabs(xm) .le. tol1) go to 90
      if (fb .eq. 0.0d0) go to 90
c
c is bisection necessary
c
      if (dabs(e) .lt. tol1) go to 70
      if (dabs(fa) .le. dabs(fb)) go to 70
c
c is quadratic interpolation possible
c
      if (a .ne. c) go to 50
c
c linear interpolation
c
      s = fb/fa
      p = 2.0d0*xm*s
      q = 1.0d0 - s
      go to 60
c
c inverse quadratic interpolation
c
   50 q = fa/fc
      r = fb/fc
      s = fb/fa
      p = s*(2.0d0*xm*q*(q - r) - (b - a)*(r - 1.0d0))
      q = (q - 1.0d0)*(r - 1.0d0)*(s - 1.0d0)
c
c adjust signs
c
   60 if (p .gt. 0.0d0) q = -q
      p = dabs(p)
c
c is interpolation acceptable
c
      if ((2.0d0*p) .ge. (3.0d0*xm*q - dabs(tol1*q))) go to 70
      if (p .ge. dabs(0.5d0*e*q)) go to 70
      e = d
      d = p/q
      go to 80
c
c bisection
c
   70 d = xm
      e = d
c
c complete step
c
   80 nstep = nstep + 1
      a = b
      fa = fb
      if (dabs(d) .gt. tol1) b = b + d
      if (dabs(d) .le. tol1) b = b + dsign(tol1, xm)
      fb = f(b)
      if (nstep .gt. maxfn) go to 90
      if ((fb*(fc/dabs(fc))) .gt. 0.0d0) go to 20
      go to 30
c
c done
c
   90 zeroin = b
c
 9000 CONTINUE
      return
      end
      SUBROUTINE ZETA(DX,DZETA)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE ZETA FUNCTION
C              FOR REAL ARGUMENTS GREATER THAN 1 USING
C              EULER-MACMACLAURIN SUMMATION.
C              ZETA(X)=SUM(1/K**X)  WHERE THE SUM IS FROM 
C                      1 TO INFINITY
C              FOR BETTER COMPUTATIONAL ACCURACY, ACTUALLY
C              COMPUTE ZETA(X) - 1.
C     INPUT  ARGUMENTS--DX     = THE DOUBLE PRECISION VALUE AT
C                                WHICH THE ZETA
C                                FUNCTION IS TO BE EVALUATED.
C     OUTPUT ARGUMENTS--DZETA  = THE DOUBLE PRECISION ZETA
C                                FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION ZETA
C             FUNCTION VALUE DZETA.
C     PRINTING--NONE.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY APPLIED MATHEMATICS
C                 SERIES 55, 1964.
C               --THOMPSON, "ATLAS FOR COMPUTING MATHEMATICAL
C                 FUNCTIONS", WILEY, 1997.  THIS ROUTINE IS A
C                 FORTRAN TRANSLATION OF THE C FUNCTION ON PAGE 146
C                 OF THIS BOOK.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1966)
C     VERSION NUMBER--97.9
C     ORIGINAL VERSION--SEPTEMBER 1997.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      REAL CPUMAX, CPUMIN
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      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 DEPS/1.0D-20/
C
C-----START POINT-----------------------------------------------------
C
      DSTERM=DX*(DX+1.0D0)*(DX+2.0D0)*
     1       (DX+3.0D0)*(DX+4.0D0)/30240.0D0
      DTERM1=DSTERM*(2.0D0**DX)/DEPS
      DTERM2=DTERM1**(1.0D0/(DX+5.0D0))
      IF(DTERM2.LE.10.01)THEN
        N=10
      ELSEIF(DTERM2.GE.9999.99D0)THEN
        N=10000
      ELSE
        N=INT(DTERM2)
      ENDIF
C
      FN=DBLE(N)
      DNEGX=-DX
      DSUM=0.D0
      DO100K=2,N-1
        DSUM=DSUM + DBLE(K)**DNEGX
 100  CONTINUE
C
      DSUM = DSUM +
     1       (FN**DNEGX)*(0.5D0 + FN/(DX-1.0D0)
     1       + DX*(1.0D0 -
     1       (DX+1.0D0)*(DX+2.0D0)/(60.0D0*FN*FN))/(12.0D0*FN))
     1       + DSTERM/(FN**(DX+0.5D0))
C
CCCCC COMPUTE ZETA(X) - 1 FOR BETTER ACCURACY.
CCCCC DZETA=DSUM+1.0D0
      DZETA=DSUM
      RETURN
      END
      SUBROUTINE ZETRCH(IC,IC1,IC2)
C
C     PURPOSE--TRANSLATE ANY OF THE 128 ASCII CHARACTERS
C              INTO A 2-CHARACTER REPRESENTATION
C              THAT WILL BE UNDERSTOOD BY A ZETA
C              (MODEL 3600SX AND MODEL 3653SX)
C              GRAPHICS DEVICE,
C              FOR USE WITH A CHARACTER VECTOR (= OP CODE 3) COMMAND
C
C     THE INPUT  CONSISTS OF 1 CHARACTER*1 VARIABLE--
C           IC.
C     THE OUTPUT CONSISTS OF 2 CHARACTER*1 VARIABLES--
C           IC1 AND IC2.
C
C     NOTE--THE ZETA CONVERSION SCHEME IS AS FOLLOWS--
C           TAKE THE INPUT CHARACTER.
C           NOTE THE EBCDIC (UGH!) NUMERIC EQUIVALENT.
C           SPLIT IT INTO 2 5-BIT BYTES.
C           CONVERT EACH BYTE INTO ITS INTEGER EQUIVALENT.
C           APPLY FINAL CONVERSION SCHEME OF
C                0 TO  7 MAPS INTO THE CHARACTERS 0 TO 7
C                8 TO 31 MAPS INTO THE CHARACTERS A TO X
C
C     NOTE--IN GENERAL, THE ZETA ONLY ACCEPTS AS INPUT
C           THE 32 CHARACTERS--0 TO 7 AND A TO X.
C
C     REFERENCE--ZETA REFERENCE MANUAL
C                FUNDAMENTAL PLOTTING ROUTINES (FORTRAN)
C                PAGE A-2.
C     REFERENCE--ZETA USER MANUAL
C                DIGITAL PLOTTER, MODELS 3600SC, 3653SX
C                PAGE B-1.
C
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--83.6
C     ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MAY       1983.
C     UPDATED--NOVEMBER           1996. LINUX COMPILE PROBLEM
C
C-----NON-COMMON VARIABLES (GRAPHICS)-------------------------------------------
C
      CHARACTER*1 IC
      CHARACTER*1 IC1
      CHARACTER*1 IC2
C
      CHARACTER*4 ICTAB
      CHARACTER*1 IC1TAB
      CHARACTER*1 IC2TAB
C
      DIMENSION ICTAB(128)
      DIMENSION IC1TAB(128)
      DIMENSION IC2TAB(128)
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 ICTAB(128),IC1TAB(128),IC2TAB(128)/'NU  ','?','?'/
      DATA ICTAB(  1),IC1TAB(  1),IC2TAB(  1)/'SH  ','?','?'/
      DATA ICTAB(  2),IC1TAB(  2),IC2TAB(  2)/'SX  ','?','?'/
      DATA ICTAB(  3),IC1TAB(  3),IC2TAB(  3)/'EX  ','?','?'/
      DATA ICTAB(  4),IC1TAB(  4),IC2TAB(  4)/'ET  ','?','?'/
      DATA ICTAB(  5),IC1TAB(  5),IC2TAB(  5)/'EQ  ','?','?'/
      DATA ICTAB(  6),IC1TAB(  6),IC2TAB(  6)/'AK  ','?','?'/
      DATA ICTAB(  7),IC1TAB(  7),IC2TAB(  7)/'BL  ','?','?'/
      DATA ICTAB(  8),IC1TAB(  8),IC2TAB(  8)/'BS  ','?','?'/
      DATA ICTAB(  9),IC1TAB(  9),IC2TAB(  9)/'HT  ','?','?'/
      DATA ICTAB( 10),IC1TAB( 10),IC2TAB( 10)/'LF  ','?','?'/
      DATA ICTAB( 11),IC1TAB( 11),IC2TAB( 11)/'VT  ','?','?'/
      DATA ICTAB( 12),IC1TAB( 12),IC2TAB( 12)/'FF  ','?','?'/
      DATA ICTAB( 13),IC1TAB( 13),IC2TAB( 13)/'CR  ','?','?'/
      DATA ICTAB( 14),IC1TAB( 14),IC2TAB( 14)/'SO  ','?','?'/
      DATA ICTAB( 15),IC1TAB( 15),IC2TAB( 15)/'SI  ','?','?'/
C
      DATA ICTAB( 16),IC1TAB( 16),IC2TAB( 16)/'DL  ','?','?'/
      DATA ICTAB( 17),IC1TAB( 17),IC2TAB( 17)/'D1  ','?','?'/
      DATA ICTAB( 18),IC1TAB( 18),IC2TAB( 18)/'D2  ','?','?'/
      DATA ICTAB( 19),IC1TAB( 19),IC2TAB( 19)/'D3  ','?','?'/
      DATA ICTAB( 20),IC1TAB( 20),IC2TAB( 20)/'D4  ','?','?'/
      DATA ICTAB( 21),IC1TAB( 21),IC2TAB( 21)/'NK  ','?','?'/
      DATA ICTAB( 22),IC1TAB( 22),IC2TAB( 22)/'SY  ','?','?'/
      DATA ICTAB( 23),IC1TAB( 23),IC2TAB( 23)/'EB  ','?','?'/
      DATA ICTAB( 24),IC1TAB( 24),IC2TAB( 24)/'CN  ','?','?'/
      DATA ICTAB( 25),IC1TAB( 25),IC2TAB( 25)/'EM  ','?','?'/
      DATA ICTAB( 26),IC1TAB( 26),IC2TAB( 26)/'SB  ','?','?'/
      DATA ICTAB( 27),IC1TAB( 27),IC2TAB( 27)/'EC  ','?','?'/
      DATA ICTAB( 28),IC1TAB( 28),IC2TAB( 28)/'FS  ','?','?'/
      DATA ICTAB( 29),IC1TAB( 29),IC2TAB( 29)/'GS  ','?','?'/
      DATA ICTAB( 30),IC1TAB( 30),IC2TAB( 30)/'RS  ','?','?'/
      DATA ICTAB( 31),IC1TAB( 31),IC2TAB( 31)/'US  ','?','?'/
C
      DATA ICTAB( 32),IC1TAB( 32),IC2TAB( 32)/'    ','4','0'/
      DATA ICTAB( 33),IC1TAB( 33),IC2TAB( 33)/'!   ','2','S'/
      DATA ICTAB( 34),IC1TAB( 34),IC2TAB( 34)/'"   ','3','X'/
      DATA ICTAB( 35),IC1TAB( 35),IC2TAB( 35)/'#   ','3','T'/
      DATA ICTAB( 36),IC1TAB( 36),IC2TAB( 36)/'$   ','2','T'/
      DATA ICTAB( 37),IC1TAB( 37),IC2TAB( 37)/'%   ','3','E'/
      DATA ICTAB( 38),IC1TAB( 38),IC2TAB( 38)/'&   ','2','I'/
      DATA ICTAB( 39),IC1TAB( 39),IC2TAB( 39)/'SQUO','?','?'/
      DATA ICTAB( 40),IC1TAB( 40),IC2TAB( 40)/'(   ','2','F'/
      DATA ICTAB( 41),IC1TAB( 41),IC2TAB( 41)/')   ','2','V'/
      DATA ICTAB( 42),IC1TAB( 42),IC2TAB( 42)/'*   ','2','U'/
      DATA ICTAB( 43),IC1TAB( 43),IC2TAB( 43)/'+   ','2','G'/
      DATA ICTAB( 44),IC1TAB( 44),IC2TAB( 44)/',   ','3','D'/
      DATA ICTAB( 45),IC1TAB( 45),IC2TAB( 45)/'-   ','3','0'/
      DATA ICTAB( 46),IC1TAB( 46),IC2TAB( 46)/'.   ','2','D'/
      DATA ICTAB( 47),IC1TAB( 47),IC2TAB( 47)/'/   ','3','1'/
C
      DATA ICTAB( 48),IC1TAB( 48),IC2TAB( 48)/'0   ','3','I'/
      DATA ICTAB( 49),IC1TAB( 49),IC2TAB( 49)/'1   ','3','J'/
      DATA ICTAB( 50),IC1TAB( 50),IC2TAB( 50)/'2   ','3','K'/
      DATA ICTAB( 51),IC1TAB( 51),IC2TAB( 51)/'3   ','3','L'/
      DATA ICTAB( 52),IC1TAB( 52),IC2TAB( 52)/'4   ','3','M'/
      DATA ICTAB( 53),IC1TAB( 53),IC2TAB( 53)/'5   ','3','N'/
      DATA ICTAB( 54),IC1TAB( 54),IC2TAB( 54)/'6   ','3','O'/
      DATA ICTAB( 55),IC1TAB( 55),IC2TAB( 55)/'7   ','3','P'/
      DATA ICTAB( 56),IC1TAB( 56),IC2TAB( 56)/'8   ','3','Q'/
      DATA ICTAB( 57),IC1TAB( 57),IC2TAB( 57)/'9   ','3','R'/
      DATA ICTAB( 58),IC1TAB( 58),IC2TAB( 58)/':   ','2','H'/
      DATA ICTAB( 59),IC1TAB( 59),IC2TAB( 59)/';   ','2','W'/
      DATA ICTAB( 60),IC1TAB( 60),IC2TAB( 60)/'<   ','2','E'/
      DATA ICTAB( 61),IC1TAB( 61),IC2TAB( 61)/'=   ','3','W'/
      DATA ICTAB( 62),IC1TAB( 62),IC2TAB( 62)/'>   ','3','G'/
      DATA ICTAB( 63),IC1TAB( 63),IC2TAB( 63)/'?   ','3','H'/
C
      DATA ICTAB( 64),IC1TAB( 64),IC2TAB( 64)/'@   ','3','U'/
      DATA ICTAB( 65),IC1TAB( 65),IC2TAB( 65)/'A   ','2','1'/
      DATA ICTAB( 66),IC1TAB( 66),IC2TAB( 66)/'B   ','2','2'/
      DATA ICTAB( 67),IC1TAB( 67),IC2TAB( 67)/'C   ','2','3'/
      DATA ICTAB( 68),IC1TAB( 68),IC2TAB( 68)/'D   ','2','4'/
      DATA ICTAB( 69),IC1TAB( 69),IC2TAB( 69)/'E   ','2','5'/
      DATA ICTAB( 70),IC1TAB( 70),IC2TAB( 70)/'F   ','2','6'/
      DATA ICTAB( 71),IC1TAB( 71),IC2TAB( 71)/'G   ','2','7'/
      DATA ICTAB( 72),IC1TAB( 72),IC2TAB( 72)/'H   ','2','A'/
      DATA ICTAB( 73),IC1TAB( 73),IC2TAB( 73)/'I   ','2','B'/
      DATA ICTAB( 74),IC1TAB( 74),IC2TAB( 74)/'J   ','2','J'/
      DATA ICTAB( 75),IC1TAB( 75),IC2TAB( 75)/'K   ','2','K'/
      DATA ICTAB( 76),IC1TAB( 76),IC2TAB( 76)/'L   ','2','L'/
      DATA ICTAB( 77),IC1TAB( 77),IC2TAB( 77)/'M   ','2','M'/
      DATA ICTAB( 78),IC1TAB( 78),IC2TAB( 78)/'N   ','2','N'/
      DATA ICTAB( 79),IC1TAB( 79),IC2TAB( 79)/'O   ','2','O'/
C
      DATA ICTAB( 80),IC1TAB( 80),IC2TAB( 80)/'P   ','2','P'/
      DATA ICTAB( 81),IC1TAB( 81),IC2TAB( 81)/'Q   ','2','Q'/
      DATA ICTAB( 82),IC1TAB( 82),IC2TAB( 82)/'R   ','2','R'/
      DATA ICTAB( 83),IC1TAB( 83),IC2TAB( 83)/'S   ','3','2'/
      DATA ICTAB( 84),IC1TAB( 84),IC2TAB( 84)/'T   ','3','3'/
      DATA ICTAB( 85),IC1TAB( 85),IC2TAB( 85)/'U   ','3','4'/
      DATA ICTAB( 86),IC1TAB( 86),IC2TAB( 86)/'V   ','3','5'/
      DATA ICTAB( 87),IC1TAB( 87),IC2TAB( 87)/'W   ','3','6'/
      DATA ICTAB( 88),IC1TAB( 88),IC2TAB( 88)/'X   ','3','7'/
      DATA ICTAB( 89),IC1TAB( 89),IC2TAB( 89)/'Y   ','3','A'/
      DATA ICTAB( 90),IC1TAB( 90),IC2TAB( 90)/'Z   ','3','B'/
      DATA ICTAB( 91),IC1TAB( 91),IC2TAB( 91)/'[   ','1','N'/
CLINX FOLLOWING LINE MODIFIED FOR LINIX G77 COMPILER NOVEMBER 1996
CLINX DATA ICTAB( 92),IC1TAB( 92),IC2TAB( 92)/'\   ','1','P'/
      DATA IC1TAB( 92),IC2TAB( 92)/'1','P'/
      DATA ICTAB( 93),IC1TAB( 93),IC2TAB( 93)/']   ','1','O'/
      DATA ICTAB( 94),IC1TAB( 94),IC2TAB( 94)/'CARA','0','K'/
      DATA ICTAB( 95),IC1TAB( 95),IC2TAB( 95)/'_   ','?','?'/
C
      DATA ICTAB( 96),IC1TAB( 96),IC2TAB( 96)/'`   ','3','V'/
      DATA ICTAB( 97),IC1TAB( 97),IC2TAB( 97)/'a   ','4','1'/
      DATA ICTAB( 98),IC1TAB( 98),IC2TAB( 98)/'b   ','4','2'/
      DATA ICTAB( 99),IC1TAB( 99),IC2TAB( 99)/'c   ','4','3'/
      DATA ICTAB(100),IC1TAB(100),IC2TAB(100)/'d   ','4','4'/
      DATA ICTAB(101),IC1TAB(101),IC2TAB(101)/'e   ','4','5'/
      DATA ICTAB(102),IC1TAB(102),IC2TAB(102)/'f   ','4','6'/
      DATA ICTAB(103),IC1TAB(103),IC2TAB(103)/'g   ','4','7'/
      DATA ICTAB(104),IC1TAB(104),IC2TAB(104)/'h   ','4','A'/
      DATA ICTAB(105),IC1TAB(105),IC2TAB(105)/'i   ','4','B'/
      DATA ICTAB(106),IC1TAB(106),IC2TAB(106)/'j   ','4','J'/
      DATA ICTAB(107),IC1TAB(107),IC2TAB(107)/'k   ','4','K'/
      DATA ICTAB(108),IC1TAB(108),IC2TAB(108)/'l   ','4','L'/
      DATA ICTAB(109),IC1TAB(109),IC2TAB(109)/'m   ','4','M'/
      DATA ICTAB(110),IC1TAB(110),IC2TAB(110)/'n   ','4','N'/
      DATA ICTAB(111),IC1TAB(111),IC2TAB(111)/'o   ','4','O'/
C
      DATA ICTAB(112),IC1TAB(112),IC2TAB(112)/'p   ','4','P'/
      DATA ICTAB(113),IC1TAB(113),IC2TAB(113)/'q   ','4','Q'/
      DATA ICTAB(114),IC1TAB(114),IC2TAB(114)/'r   ','4','R'/
      DATA ICTAB(115),IC1TAB(115),IC2TAB(115)/'s   ','5','2'/
      DATA ICTAB(116),IC1TAB(116),IC2TAB(116)/'t   ','5','3'/
      DATA ICTAB(117),IC1TAB(117),IC2TAB(117)/'u   ','5','4'/
      DATA ICTAB(118),IC1TAB(118),IC2TAB(118)/'v   ','5','5'/
      DATA ICTAB(119),IC1TAB(119),IC2TAB(119)/'w   ','5','6'/
      DATA ICTAB(120),IC1TAB(120),IC2TAB(120)/'x   ','5','7'/
      DATA ICTAB(121),IC1TAB(121),IC2TAB(121)/'y   ','5','A'/
      DATA ICTAB(122),IC1TAB(122),IC2TAB(122)/'z   ','5','B'/
      DATA ICTAB(123),IC1TAB(123),IC2TAB(123)/'{   ','1','1'/
      DATA ICTAB(124),IC1TAB(124),IC2TAB(124)/'|   ','2','H'/
      DATA ICTAB(125),IC1TAB(125),IC2TAB(125)/'}   ','1','0'/
      DATA ICTAB(126),IC1TAB(126),IC2TAB(126)/'~   ','0','W'/
      DATA ICTAB(127),IC1TAB(127),IC2TAB(127)/'DT  ','?','?'/
C
C-----START POINT-----------------------------------------------------
C
      IERRG4='NO'
C
      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'TRCH')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF ZETRCH--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)IC
   52 FORMAT('IC = ',A1)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,69)IBUGG4,ISUBG4,IERRG4
   69 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
   90 CONTINUE
CLINX FOLLOWING LINE TO ACCOMODATE LINUX G77 COMPILER  NOVEMBER 1996
      CALL DPCONA(92,ICTAB(92))
C
C               ******************************************************
C               **  STEP 1--                                        **
C               **  DETERMINE THE ASCII NUMERIC EQUIVALENT OF THE   **
C               **  INPUT CHARACTER.                                **
C               **  THEN DO A TABLE LOOK-UP TO EXTRACT              **
C               **  THE 2 CODED CHARACTERS THAT THE ZETA EXPECTS.   **
C               ******************************************************
C
CCCCC INDEX=ICHAR(IC)
      CALL DPCOAN(IC,INDEX)
      IF(INDEX.LE.0)INDEX=0
      IF(INDEX.GE.128)INDEX=0
      IC1=IC1TAB(INDEX)
      IC2=IC2TAB(INDEX)
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'TRCH')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF ZETRCH--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IC
 9012 FORMAT('IC = ',A1)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)INDEX
 9013 FORMAT('INDEX = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9014)ICTAB(INDEX),IC1TAB(INDEX),IC2TAB(INDEX)
 9014 FORMAT('ICTAB(INDEX),IC1TAB(INDEX),IC2TAB(INDEX) = ',
     1A4,2X,A1,2X,A1)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9015)IC,IC1,IC2
 9015 FORMAT('IC,IC1,IC2 = ',A1,2X,A1,2X,A1)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9029)IBUGG4,ISUBG4,IERRG4
 9029 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE ZETRPT(IXC,IYC,ICSTR,NCSTR,ISUBN0)
C
C     PURPOSE--TRANSLATE AN INTEGER PAIR OF COORDINATES
C              INTO A PACKED CHARACTER REPRESENTATION
C              THAT WILL BE UNDERSTOOD BY A ZETA
C              (MODEL 3600SX AND MODEL 3653SX)
C              GRAPHICS DEVICE.
C
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 RESULTRING CHARACTER STING WILL GO INTO
C           THE NEXT AVAILABLE ELEMENTS OF ICSTR(.:.)
C           AND THE VALUE OF    NCSTR    WILL BE
C           UPDATED ACCORDINGLY.
C     NOTE--THE 32 VALID INPUT VALUES THAT THE ZETA EXPECTS ARE--
C           0 TO 7 AND A TO X
C     REFERENCE--ZETA MANUAL, PAGE B-1.
C
C     NOTE--THE ZETA HAS AN ACCURACY OF 1/400 OF AN INCH
C           THE RAW UNITS ARE IN INCHES, BUT THE INPUT TO THIS
C           SUBROUTINE IS INCHES X 400 AND THEN ROUNDED TO CLOSEST INTEGER.
C
C     DANGER--NCSTR IS BOTH AN INPUT ARGUMENT
C             AND AN OUTPUT ARGUMENT OF THIS SUBROUTINE.
C     NOTE--ISUBN0 = NAME OF SUBROUTINE WHICH CALLED ZETRPT
C                    (AND THEREBY HAVE WALKBACK INFORMATION).
C     REFERENCE--4105 PROGRAMMER'S REFERENCE MANUAL
C                PAGE 5-4
C     REFERENCE--MAHLON KELLY, BYTE, OCTOBER 1983,
C                PAGES 439 TO 442.
C
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--83.6
C     ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MAY       1983.
C
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 K5/32/
      DATA K10/1024/
      DATA K15/32768/
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 ZETRPT--')
      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)K5,K10,K15
   55 FORMAT('K5,K10,K15 = ',3I8)
      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 CODED X VALUE.                         **
C               **  PRODUCE 4 5-BIT BYTES.                          **
C               **  SPLIT THE 20 RIGHT-MOST BITS OF THE BINARY      **
C               **  REPRESENTATION FOR THE INTEGER                  **
C               **  INTO 40 5-BIT BYTES.                            **
C               **  THEN CONVERT EACH BYTE INTO THE ASCII           **
C               **  NUMERIC EQUIVALENT OF THE 32 SPECIAL            **
C               **  CHARACTERS THAT THE ZETA EXPECTS, NAMELY,       **
C               **  0, 1, 2, ..., 7, A, B, C, ..., W, X.            **
C               **  FORM THE LEFT-MOST 5-BIT BYTE--                 **
C               **       SHIFT THE X VALUE TO THE RIGHT 15 PLACES;  **
C               **       THEN KEEP ONLY THE RIGHT 5 PLACES;         **
C               **  FORM THE LEFT-MIDDLE 5-BIT BYTE--               **
C               **       SHIFT THE X VALUE TO THE RIGHT 10 PLACES;  **
C               **       THEN KEEP ONLY THE RIGHT 5 PLACES;         **
C               **  FORM THE RIGHT-MIDDLE 5-BIT BYTE--              **
C               **       SHIFT THE X VALUE TO THE RIGHT 5 PLACES;   **
C               **       THEN KEEP ONLY THE RIGHT 5 PLACES;         **
C               **  FORM THE LEFT-MOST 5-BIT BYTE--                 **
C               **       SHIFT THE X VALUE TO THE RIGHT 0 PLACES;   **
C               **       THEN KEEP ONLY THE RIGHT 5 PLACES;         **
C               ******************************************************
C
C
      IHOLD=MOD(IVX/K15,K5)
      IARG=IHOLD+48
      IF(IHOLD.GE.8)IARG=IHOLD+57
      NCSTR=NCSTR+1
CCCCC ICSTR(NCSTR:NCSTR)=CHAR(IARG)
      CALL DPCONA(IARG,ICSTR(NCSTR:NCSTR))
C
      IHOLD=MOD(IVX/K10,K5)
      IARG=IHOLD+48
      IF(IHOLD.GE.8)IARG=IHOLD+57
      NCSTR=NCSTR+1
CCCCC ICSTR(NCSTR:NCSTR)=CHAR(IARG)
      CALL DPCONA(IARG,ICSTR(NCSTR:NCSTR))
C
      IHOLD=MOD(IVX/K5,K5)
      IARG=IHOLD+48
      IF(IHOLD.GE.8)IARG=IHOLD+57
      NCSTR=NCSTR+1
CCCCC ICSTR(NCSTR:NCSTR)=CHAR(IARG)
      CALL DPCONA(IARG,ICSTR(NCSTR:NCSTR))
C
      IHOLD=MOD(IVX,K5)
      IARG=IHOLD+48
      IF(IHOLD.GE.8)IARG=IHOLD+57
      NCSTR=NCSTR+1
CCCCC ICSTR(NCSTR:NCSTR)=CHAR(IARG)
      CALL DPCONA(IARG,ICSTR(NCSTR:NCSTR))
C
C               *******************************************
C               **  STEP 2--                             **
C               **  FORM THE CODED Y VALUE.              **
C               **  PRODUCE 4 5-BIT BYTES.               **
C               **  USE THE SAME PROCEDURE AS IN STEP 1  **
C               *******************************************
C
      IHOLD=MOD(IVY/K15,K5)
      IARG=IHOLD+48
      IF(IHOLD.GE.8)IARG=IHOLD+57
      NCSTR=NCSTR+1
CCCCC ICSTR(NCSTR:NCSTR)=CHAR(IARG)
      CALL DPCONA(IARG,ICSTR(NCSTR:NCSTR))
C
      IHOLD=MOD(IVY/K10,K5)
      IARG=IHOLD+48
      IF(IHOLD.GE.8)IARG=IHOLD+57
      NCSTR=NCSTR+1
CCCCC ICSTR(NCSTR:NCSTR)=CHAR(IARG)
      CALL DPCONA(IARG,ICSTR(NCSTR:NCSTR))
C
      IHOLD=MOD(IVY/K5,K5)
      IARG=IHOLD+48
      IF(IHOLD.GE.8)IARG=IHOLD+57
      NCSTR=NCSTR+1
CCCCC ICSTR(NCSTR:NCSTR)=CHAR(IARG)
      CALL DPCONA(IARG,ICSTR(NCSTR:NCSTR))
C
      IHOLD=MOD(IVY,K5)
      IARG=IHOLD+48
      IF(IHOLD.GE.8)IARG=IHOLD+57
      NCSTR=NCSTR+1
CCCCC ICSTR(NCSTR:NCSTR)=CHAR(IARG)
      CALL DPCONA(IARG,ICSTR(NCSTR:NCSTR))
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'TRPT')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF ZETRPT--')
      CALL DPWRST('XXX','BUG ')
      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)K5,K10,K15
 9015 FORMAT('K5,K10,K15 = ',3I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9016)IGUNIT
 9016 FORMAT('IGUNIT = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9017)IARG
 9017 FORMAT('IARG = ',I8)
      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 ZIPPDF(X,ALPHA,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE DISCRETE ZIPF
C              DISTRIBUTION WITH SHAPE PARAMETER = ALPHA.
C              THIS DISTRIBUTION IS DEFINED FOR ALL INTEGER X >= 1.
C              THE PROBABILITY DENSITY FUNCTION IS:
C              F(X,ALPHA)=1/[ZETA(ALPHA)*X**ALPHA]    X=1,2,3,...
C                                                     ALPHA > 1
C              WITH ZETA DENOTING THE RIEMANN ZETA 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                     --ALPHA  = THE SHAPE PARAMETER
C     OUTPUT ARGUMENTS--PDF    = THE SINGLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE PDF FOR THE ZIPF
C             DISTRIBUTION WITH SHAPE PARAMETER = ALPHA
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE A POSITIVE INTEGER
C                 --ALPHA > 1
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JAMES E. GENTLE (2003). 'RANDOM NUMBER GENERATION
C                 AND MONTE CARLO METHODS', SPRINGER-VERLANG, P. 192.
C                 USE HIS DESCRIPTION OF AN ALGORITHM DUE TO DEVROYE.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2003/11
C     ORIGINAL VERSION--NOVEMBER  2003.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DALPHA
      DOUBLE PRECISION DZETA
      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(ALPHA.LE.1.0)THEN
        WRITE(ICOUT,15)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ALPHA
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ENDIF
      IX=X+0.5
      IF(IX.LT.1)THEN
        WRITE(ICOUT,4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ENDIF
   15 FORMAT('***** FATAL ERROR--THE ALPHA SHAPE PARAMETER FOR THE ',
     1'ZIPF PDF IS <= 1')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
    4 FORMAT('***** FATAL ERROR--THE FIRST INPUT ARGUMENT ',
     1'TO THE ZIPPDF SUBROUTINE IS LESS THAN 1 *****')
C
      DX=DBLE(IX)
      DALPHA=DBLE(ALPHA)
C
      CALL ZETA(DALPHA,DZETA)
      DZETA=DZETA+1.0D0
      DPDF=DLOG(1.0D0) - DLOG(DZETA) - DALPHA*DLOG(DX)
      DPDF=DEXP(DPDF)
      PDF=REAL(DPDF)
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE ZIPRAN(N,ALPHA,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE ZIPF DISTRIBUTION
C              WITH SHAPE PARAMETER ALPHA
C              THIS DISTRIBUTION IS DEFINED FOR ALL POSITIVE INTEGERS
C              X, AND HAS THE PROBABILITY MASS FUNCTION
C              F(X) = 1/[ZETA(ALPHA)*X**ALPHA]   X = 1, 2, 3, ...
C                                                ALPHA > 1
C              WITH ZETA DENOTING THE RIEMANN ZETA FUNCTION.
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                                SHAPE PARAMETER, ALPHA > 1
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 ZIPF DISTRIBUTION
C             WITH SHAPE 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 > 1.
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--JAMES E. GENTLE (2003). 'RANDOM NUMBER GENERATION
C                 AND MONTE CARLO METHODS', SPRINGER-VERLANG, P. 192.
C                 USE HIS DESCRIPTION OF AN ALGORITHM DUE TO DEVROYE.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2899
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2003/11
C     ORIGINAL VERSION--NOVEMBER  2003.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
C
      DIMENSION U(2)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----DATA STATEMENTS-------------------------------------------------
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)THEN
        WRITE(ICOUT, 5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
      IF(ALPHA.LE.1.0)THEN
        WRITE(ICOUT,15)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ALPHA
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
    5 FORMAT('***** FATAL ERROR--THE REQUESTED NUMBER OF ZIPF',
     1' RANDOM NUMBERS IS NON-POSITIVE')
   15 FORMAT('***** FATAL ERROR--THE ALPHA SHAPE PARAMETER FOR THE ',
     1'ZIPF RANDOM NUMBERS IS <= 1')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
C
C     GENERATE N ZIPF DISTRIBUTION RANDOM NUMBERS
C
      NTEMP=2
      DO100I=1,N
  199   CONTINUE
        CALL UNIRAN(NTEMP,ISEED,U)
        XTEMP=U(1)**(-1.0/(ALPHA-1.0))
C
        IF(XTEMP.LE.0.0)THEN
          IARG2=INT(XTEMP)
          ARG3=REAL(IARG2)
          ARG4=XTEMP-ARG3
          TERM=ARG3
          IF(ARG4.NE.0.0)TERM=TERM-1.0
        ELSE
          IARG2=INT(XTEMP)
          TERM=REAL(IARG2)
        ENDIF
        XTEMP=TERM
C
        TTEMP=(1.0 + 1.0/XTEMP)**(ALPHA-1.0)
        TERM1=TTEMP/(TTEMP-1.0)
        TERM2=(2.0**(ALPHA-1.0) - 1.0)/(2.0**(ALPHA-1.0)*U(2))
        IF(XTEMP.LE.TERM1*TERM2)THEN
          X(I)=XTEMP
        ELSE
          GOTO199
        ENDIF
  100 CONTINUE
C
 9999 CONTINUE
C
      RETURN
      END
      SUBROUTINE ZROOTS(A,M,ROOTS,POLISH)
C
C     SOURCE--NUMERICAL RECIPES,
C             PRESS, FLANNERY, TEUKOLSKY, AND VETTERLING,
C             CAMBRIDGE UNIVERSITY PRESS, 1986.
C
      PARAMETER (EPS=1.E-6,MAXM=101)
      COMPLEX A(*),ROOTS(M),AD(MAXM),X,B,C
      LOGICAL POLISH
C
      DO 11 J=1,M+1
        AD(J)=A(J)
11    CONTINUE
C
      DO 13 J=M,1,-1
        X=CMPLX(0.,0.)
        CALL LAGUER(AD,J,X,EPS,.FALSE.)
        IF(ABS(AIMAG(X)).LE.2.*EPS**2*ABS(REAL(X))) X=CMPLX(REAL(X),0.)
        ROOTS(J)=X
        B=AD(J+1)
        DO 12 JJ=J,1,-1
          C=AD(JJ)
          AD(JJ)=B
          B=X*B+C
12      CONTINUE
13    CONTINUE
C
      IF (POLISH) THEN
        DO 14 J=1,M
          CALL LAGUER(A,M,ROOTS(J),EPS,.TRUE.)
14      CONTINUE
      ENDIF
C
      DO 16 J=2,M
        X=ROOTS(J)
        DO 15 I=J-1,1,-1
          IF(REAL(ROOTS(I)).LE.REAL(X))GO TO 10
          ROOTS(I+1)=ROOTS(I)
15      CONTINUE
        I=0
10      ROOTS(I+1)=X
16    CONTINUE
C
      RETURN
      END
      double precision function ztran (var)
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 TRANSFORMATION OF OBSERVATIONS TO AVOID NUMERICAL PROBLEMS DURING
c OPTIMIZATION
c
      implicit double precision (a-h,o-z)
      logical trans
      common /pnrlst/trans
c
      data one,xkp,xkm,txkp,txkm / 1.0d0,4.0d0,-4.0d0,7.9d0,-7.9d0/
c
      if (.not.trans)then
         ztran=var
         if (var.gt.txkp)ztran=txkp
         if (var.lt.txkm)ztran=txkm
      elseif (var.gt.xkp)then
         zmxkp=var-xkp
         ztran=xkp+zmxkp/(one+zmxkp/xkp)
      elseif (var.gt.xkm)then
         ztran=var
         if (var.gt.txkp)ztran=txkp
         if (var.lt.txkm)ztran=txkm
      else
         zmxkm=var-xkm
         ztran=xkm+zmxkm/(one+zmxkm/xkm)
      endif
C
      return
      end
