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

      real function ran183(ix,iy,iz)
c
c     Algorithm AS 183 Appl. Statist. (1982) vol.31, no.2
c
c     Returns a pseudo-random number rectangularly distributed
c     between 0 and 1.   The cycle length is 6.95E+12 (See page 123
c     of Applied Statistics (1984) vol.33), not as claimed in the
c     original article.
c
c     IX, IY and IZ should be set to integer values between 1 and
c     30000 before the first entry.
c
c     Integer arithmetic up to 30323 is required.
c
      integer ix, iy, iz
c
      ix = 171 * mod(ix, 177) - 2 * (ix / 177)
      iy = 172 * mod(iy, 176) - 35 * (iy / 176)
      iz = 170 * mod(iz, 178) - 63 * (iz / 178)
c
      if (ix .lt. 0) ix = ix + 30269
      if (iy .lt. 0) iy = iy + 30307
      if (iz .lt. 0) iz = iz + 30323
c
c     If integer arithmetic up to 5212632 is available, the preceding
c     6 statements may be replaced by:
c
c     ix = mod(171 * ix, 30269)
c     iy = mod(172 * iy, 30307)
c     iz = mod(170 * iz, 30323)
c
      ran183 = mod(float(ix) / 30269. + float(iy) / 30307. +
     +                        float(iz) / 30323., 1.0)
      return
      end
      FUNCTION RANDDP(R)
CCCCC RENAME TO AVOID CONFLICT WITH INTRINSIC RAND FUNCTION
CCCCC FUNCTION RAND(R)
C***BEGIN PROLOGUE  RAND
C***DATE WRITTEN   770401   (YYMMDD)
C***REVISION DATE  820801   (YYMMDD)
C***CATEGORY NO.  L6A21
C***KEYWORDS  RANDOM NUMBER,SPECIAL FUNCTION,UNIFORM
C***AUTHOR  FULLERTON, W., (LANL)
C***PURPOSE  Generates a uniformly distributed random number.
C***DESCRIPTION
C
C      This pseudo-random number generator is portable among a wide
C variety of computers.  RAND(R) undoubtedly is not as good as many
C readily available installation dependent versions, and so this
C routine is not recommended for widespread usage.  Its redeeming
C feature is that the exact same random numbers (to within final round-
C off error) can be generated from machine to machine.  Thus, programs
C that make use of random numbers can be easily transported to and
C checked in a new environment.
C      The random numbers are generated by the linear congruential
C method described, e.g., by Knuth in Seminumerical Methods (p.9),
C Addison-Wesley, 1969.  Given the I-th number of a pseudo-random
C sequence, the I+1 -st number is generated from
C             X(I+1) = (A*X(I) + C) MOD M,
C where here M = 2**22 = 4194304, C = 1731 and several suitable values
C of the multiplier A are discussed below.  Both the multiplier A and
C random number X are represented in double precision as two 11-bit
C words.  The constants are chosen so that the period is the maximum
C possible, 4194304.
C      In order that the same numbers be generated from machine to
C machine, it is necessary that 23-bit integers be reducible modulo
C 2**11 exactly, that 23-bit integers be added exactly, and that 11-bit
C integers be multiplied exactly.  Furthermore, if the restart option
C is used (where R is between 0 and 1), then the product R*2**22 =
C R*4194304 must be correct to the nearest integer.
C      The first four random numbers should be .0004127026,
C .6750836372, .1614754200, and .9086198807.  The tenth random number
C is .5527787209, and the hundredth is .3600893021 .  The thousandth
C number should be .2176990509 .
C      In order to generate several effectively independent sequences
C with the same generator, it is necessary to know the random number
C for several widely spaced calls.  The I-th random number times 2**22,
C where I=K*P/8 and P is the period of the sequence (P = 2**22), is
C still of the form L*P/8.  In particular we find the I-th random
C number multiplied by 2**22 is given by
C I   =  0  1*P/8  2*P/8  3*P/8  4*P/8  5*P/8  6*P/8  7*P/8  8*P/8
C RAND=  0  5*P/8  2*P/8  7*P/8  4*P/8  1*P/8  6*P/8  3*P/8  0
C Thus the 4*P/8 = 2097152 random number is 2097152/2**22.
C      Several multipliers have been subjected to the spectral test
C (see Knuth, p. 82).  Four suitable multipliers roughly in order of
C goodness according to the spectral test are
C    3146757 = 1536*2048 + 1029 = 2**21 + 2**20 + 2**10 + 5
C    2098181 = 1024*2048 + 1029 = 2**21 + 2**10 + 5
C    3146245 = 1536*2048 +  517 = 2**21 + 2**20 + 2**9 + 5
C    2776669 = 1355*2048 + 1629 = 5**9 + 7**7 + 1
C
C      In the table below LOG10(NU(I)) gives roughly the number of
C random decimal digits in the random numbers considered I at a time.
C C is the primary measure of goodness.  In both cases bigger is better.
C
C                   LOG10 NU(I)              C(I)
C       A       I=2  I=3  I=4  I=5    I=2  I=3  I=4  I=5
C
C    3146757    3.3  2.0  1.6  1.3    3.1  1.3  4.6  2.6
C    2098181    3.3  2.0  1.6  1.2    3.2  1.3  4.6  1.7
C    3146245    3.3  2.2  1.5  1.1    3.2  4.2  1.1  0.4
C    2776669    3.3  2.1  1.6  1.3    2.5  2.0  1.9  2.6
C   Best
C    Possible   3.3  2.3  1.7  1.4    3.6  5.9  9.7  14.9
C
C             Input Argument --
C R      If R=0., the next random number of the sequence is generated.
C        If R .LT. 0., the last generated number will be returned for
C          possible use in a restart procedure.
C        If R .GT. 0., the sequence of random numbers will start with
C          the seed R mod 1.  This seed is also returned as the value of
C          RAND provided the arithmetic is done exactly.
C
C             Output Value --
C RAND   a pseudo-random number between 0. and 1.
C***REFERENCES  (NONE)
C***ROUTINES CALLED  (NONE)
C***END PROLOGUE  RAND
      DATA IA1, IA0, IA1MA0 /1536, 1029, 507/
      DATA IC /1731/
      DATA IX1, IX0 /0, 0/
C***FIRST EXECUTABLE STATEMENT  RAND
      IF (R.LT.0.) GO TO 10
      IF (R.GT.0.) GO TO 20
C
C           A*X = 2**22*IA1*IX1 + 2**11*(IA1*IX1 + (IA1-IA0)*(IX0-IX1)
C                   + IA0*IX0) + IA0*IX0
C
      IY0 = IA0*IX0
      IY1 = IA1*IX1 + IA1MA0*(IX0-IX1) + IY0
      IY0 = IY0 + IC
      IX0 = MOD (IY0, 2048)
      IY1 = IY1 + (IY0-IX0)/2048
      IX1 = MOD (IY1, 2048)
C
 10   RANDDP = IX1*2048 + IX0
      RANDDP = RANDDP / 4194304.
      RETURN
C
 20   IX1 = INT(AMOD(R,1.)*4194304. + 0.5)
      IX0 = MOD (IX1, 2048)
      IX1 = (IX1-IX0)/2048
      GO TO 10
C
      END
      SUBROUTINE RANERR(X,Y,N,IWRITE,TEMP1,MAXNXT,YOUT,
     1                  IBUGA3,ISUBRO,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE SAMPLE RANDOM ERROR
C              QUANTITY BETWEEN TWO SETS OF DATA.  THE RANDOM ERROR
C              QUANTITY IS DEFINED AS:
C
C                 [(X(i) - Y(i) - (Xmed - Ymed)]
C
C              BETWEEN THE 2 SETS OF DATA IN THE INPUT VECTORS X AND Y.
C              THE SAMPLE RANDOM ERROR QUANTITY WILL BE A SINGLE
C              PRECISION VALUE.
C
C              NOTE THAT THE X AND Y VALUES ARE PAIRED.  THE
C              RANDOM ERROR QUANTITY IS USED IN TWO SAMPLE
C              PROFICENCY STUDIES.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF
C                                (UNSORTED) OBSERVATIONS
C                                WHICH CONSTITUTE THE FIRST SET
C                                OF DATA.
C                     --Y      = THE SINGLE PRECISION VECTOR OF
C                                (UNSORTED) OBSERVATIONS
C                                WHICH CONSTITUTE THE SECOND SET
C                                OF DATA.
C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR X, OR EQUIVALENTLY,
C                                THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR Y.
C     OUTPUT ARGUMENTS--YOUT   = THE SINGLE PRECISION VECTOR OF THE
C                                COMPUTED SAMPLE RANDOM ERROR QUANTITIES
C                                BETWEEN THE 2 SETS OF DATA
C                                IN THE INPUT VECTORS X AND Y.
C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
C             SAMPLE RANDOM ERROR QUANTITIESY 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--MEDIAN.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--"Standard Practice for Statistical Analysis of
C                 One-Sample and Two-Sample Interlaboratory Proficiency
C                 Testing Programs", 2006, ASTM International, 100 Barr
C                 Harbor Drive, PO BOX C700, West Conshohoceken, PA
C                 19428-2959, USA.
C     WRITTEN BY--ALAN HECKERT
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS
C                 GAITHERSBURG, MD 20899
C                 PHONE--301-975-2899
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2014/12
C     ORIGINAL VERSION--DECEMBER  2014.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGA3
      CHARACTER*4 ISUBRO
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
      DIMENSION Y(*)
      DIMENSION TEMP1(*)
      DIMENSION YOUT(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='RANE'
      ISUBN2='RR  '
      IERROR='NO'
C
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'NERR')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,51)
   51   FORMAT('***** AT THE BEGINNING OF RANERR--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,52)IBUGA3,N
   52   FORMAT('IBUGA3,N = ',A4,2X,I8)
        CALL DPWRST('XXX','BUG ')
        DO55I=1,N
         WRITE(ICOUT,56)I,X(I),Y(I)
   56    FORMAT('I,X(I),Y(I) = ',I8,2G15.7)
         CALL DPWRST('XXX','BUG ')
   55   CONTINUE
      ENDIF
C
C               *******************************************
C               **  COMPUTE THE RANDOM ERROR QUANTITY    **
C               *******************************************
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      AN=N
C
      IF(N.LT.1)THEN
        IERROR='YES'
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,111)
  111   FORMAT('***** ERROR IN RANDOM ERROR QUANTITY--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,112)
  112   FORMAT('      THE NUMBER OF OBSERVATIONS FOR THE RESPONSE')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,113)
  113   FORMAT('      IS LESS THAN 1.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,117)N
  117   FORMAT('      THE NUMBER OF OBSERVATIONS HERE = ',I8,'.')
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
C               ************************************************
C               **  STEP 2--                                  **
C               **  COMPUTE THE RANDOM ERROR QUANTITIES.      **
C               ************************************************
C
      CALL MEDIAN(X,N,IWRITE,TEMP1,MAXNXT,XMED,IBUGA3,IERROR)
      CALL MEDIAN(Y,N,IWRITE,TEMP1,MAXNXT,YMED,IBUGA3,IERROR)
      XYMED=XMED - YMED
      DO200I=1,N
        YOUT(I)=(X(I) - Y(I)) - XYMED
  200 CONTINUE
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'ON')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END       OF RANERR--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9012)IERROR,XMED,YMED
 9012   FORMAT('IERROR,XMED,YMED = ',A4,2X,2G15.7)
        CALL DPWRST('XXX','BUG ')
        DO9013I=1,N
          WRITE(ICOUT,9015)I,YOUT(I)
 9015     FORMAT('I,YOUT(I) = ',I8,2X,G15.7)
          CALL DPWRST('XXX','BUG ')
 9013   CONTINUE
      ENDIF
C
      RETURN
      END
      SUBROUTINE RANGDP(X,N,IWRITE,XRANGE,IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE
C              SAMPLE RANGE
C              OF THE DATA IN THE INPUT VECTOR X.
C              THE SAMPLE RANGE = SAMPLE MAX - SAMPLE MIN.
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--XRANGE = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED SAMPLE RANGE.
C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
C             SAMPLE RANGE.
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--KENDALL AND STUART, THE ADVANCED THEORY OF
C                 STATISTICS, VOLUME 1, EDITION 2, 1963, PAGE 338.
C               --DAVID, ORDER STATISTICS, 1970, PAGE 10-11.
C               --SNEDECOR AND COCHRAN, STATISTICAL METHODS,
C                 EDITION 6, 1967, PAGE 39.
C               --DIXON AND MASSEY, INTRODUCTION TO STATISTICAL
C                 ANALYSIS, EDITION 2, 1957, PAGE 21.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (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         --JUNE      1974.
C     UPDATED         --APRIL     1975.
C     UPDATED         --SEPTEMBER 1975.
C     UPDATED         --NOVEMBER  1975.
C     UPDATED         --JUNE      1979.
C     UPDATED         --AUGUST    1981.
C     UPDATED         --MAY       1982.
C     UPDATED         --NOVEMBER  2009. RENAME "RANGE" TO "RANGDP".  THIS
C                                       IS SIMPLY TO AVOID COMPILATION
C                                       ISSUES WITH VERSION 11 OF THE
C                                       INTEL COMPILER ON WINDOWS
C                                       (CONFLICTS WITH INTRINSIC
C                                       RANGE FUNCTION EVEN IF AN
C                                       EXTERNAL STATEMENT IS USED)
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(*)
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='RANG'
      ISUBN2='E   '
      IERROR='NO'
C
      XMIN=0.0
      XMAX=0.0
C
      IF(IBUGA3.EQ.'ON')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,51)
   51   FORMAT('***** AT THE BEGINNING OF RANGE--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,52)IBUGA3,N
   52   FORMAT('IBUGA3,N = ',A4,2X,I10)
        CALL DPWRST('XXX','BUG ')
        DO55I=1,N
         WRITE(ICOUT,56)I,X(I)
   56    FORMAT('I,X(I) = ',I8,G15.7)
         CALL DPWRST('XXX','BUG ')
   55   CONTINUE
      ENDIF
C
C               *********************
C               **  COMPUTE RANGE  **
C               *********************
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      AN=N
C
      IF(N.LT.1)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,111)
  111   FORMAT('***** ERROR IN RANGE--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,112)
  112   FORMAT('      THE NUMBER OF OBSERVATIONS IN THE RESPONSE ',
     1         'VARIABLE')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,115)
  115   FORMAT('      MUST BE 1 OR LARGER.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,117)N
  117   FORMAT('      THE NUMBER OF OBSERVATIONS = ',I8,'.')
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        GOTO9000
      ENDIF
C
      IF(N.EQ.1)THEN
        XRANGE=0.0
        GOTO800
      ENDIF
C
      HOLD=X(1)
      DO135I=2,N
      IF(X(I).NE.HOLD)GOTO139
  135 CONTINUE
      XRANGE=0.0
      GOTO9000
  139 CONTINUE
C
C               **************************
C               **  STEP 2--            **
C               **  COMPUTE THE RANGE.  **
C               **************************
C
      XMIN=X(1)
      XMAX=X(1)
      DO200I=2,N
        IF(X(I).LT.XMIN)XMIN=X(I)
        IF(X(I).GT.XMAX)XMAX=X(I)
  200 CONTINUE
      XRANGE=XMAX-XMIN
C
C               *******************************
C               **  STEP 3--                 **
C               **  WRITE OUT A LINE         **
C               **  OF SUMMARY INFORMATION.  **
C               *******************************
C
  800 CONTINUE
      IF(IFEEDB.EQ.'ON' .AND. IWRITE.EQ.'ON')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,811)N,XRANGE
  811   FORMAT('THE RANGE OF THE ',I8,' OBSERVATIONS = ',G15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'ON')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END       OF RANGE--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9014)XMIN,XMAX,XRANGE,IERROR
 9014   FORMAT('XMIN,XMAX,XRANGE,IERROR = ',3G15.7,2X,A4)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      RETURN
      END
      SUBROUTINE RANK(X,N,IWRITE,XR,XS,MAXOBV,IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE RANKS (IN ASCENDING ORDER)
C              THE N ELEMENTS OF THE SINGLE PRECISION VECTOR X,
C              AND PUTS THE RESULTING N RANKS INTO THE
C              SINGLE PRECISION VECTOR XR.
C     NOTE--THIS ROUTINE IN JJF8 HAS BEEN MODIFIED
C           FOR DATAPLOT
C           FROM THE SAME-NAME SUBROUTINE IN JJF6 IN 3 IMPORTANT WAYS--
C           1)  THE UPPER LIMIT (IUPPER) HAS BEEN
C               REDUCED FROM 7500 TO 1000
C           2)  THE VECTOR XS HAS HAD ITS DIMENSION
C               CHANGED FROM 7500 TO 1000.
C           3)  THE VECTOR XS HAS BEEN TAKEN OUT OF COMMON.
C              THIS SUBROUTINE GIVES THE DATA ANALYST
C              THE ABILITY TO (FOR EXAMPLE) RANK THE DATA
C              PRELIMINARY TO CERTAIN DISTRIBUTION-FREE
C              ANALYSES.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF
C                                OBSERVATIONS TO BE RANKED.
C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR X.
C     OUTPUT ARGUMENTS--XR     = THE SINGLE PRECISION VECTOR
C                                INTO WHICH THE RANKS
C                                FROM X WILL BE PLACED.
C     OUTPUT--THE SINGLE PRECISION VECTOR XR
C             CONTAINING THE RANKS
C             (IN ASCENDING ORDER)
C             OF THE VALUES
C             IN THE SINGLE PRECISION VECTOR X.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THE MAXIMUM ALLOWABLE VALUE OF N
C                   FOR THIS SUBROUTINE IS 7500.
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     COMMENT--THE RANK OF THE FIRST ELEMENT
C              OF THE VECTOR X
C              WILL BE PLACED IN THE FIRST POSITION
C              OF THE VECTOR XR,
C              THE RANK OF THE SECOND ELEMENT
C              OF THE VECTOR X
C              WILL BE PLACED IN THE SECOND POSITION
C              OF THE VECTOR XR,
C              ETC.
C     COMMENT--THE SMALLEST ELEMENT IN THE VECTOR X
C              WILL HAVE A RANK OF 1 (UNLESS TIES EXIST).
C              THE LARGEST ELEMENT IN THE VECTOR X
C              WILL HAVE A RANK OF N (UNLESS TIES EXIST).
C     COMMENT--ALTHOUGH RANKS ARE USUALLY (UNLESS TIES EXIST)
C              INTEGRAL VALUES FROM 1 TO N, IT IS TO BE
C              NOTED THAT THEY ARE OUTPUTED AS SINGLE
C              PRECISION INTEGERS IN THE SINGLE PRECISION
C              VECTOR XR.
C              XR IS SINGLE PRECISION SO AS TO BE
C              CONSISTENT WITH THE FACT THAT ALL
C              VECTOR ARGUMENTS IN ALL OTHER
C              DATAPAC SUBROUTINES ARE SINGLE PRECISION;
C              BUT MORE IMPORTANTLY, BECAUSE TIES FREQUENTLY
C              DO EXIST IN DATA SETS AND SO SOME OF THE
C              RESULTING RANKS WILL BE NON-INTEGRAL
C              AND SO THE OUTPUT VECTOR OF RANKS MUST NECESSARILY
C              BE SINGLE PRECISION AND NOT INTEGER.
C     COMMENT--THE INPUT VECTOR X REMAINS UNALTERED.
C     COMMENT--THE FIRST AND THIRD ARGUMENTS IN THE
C              CALLING SEQUENCE MAY
C              BE IDENTICAL; THAT IS, AN 'IN PLACE'
C              RANKING IS PERMITTED.
C              THE CALLING SEQUENCE
C              CALL RANK(X,N,X) IS VALID, IF DESIRED.
C     COMMENT--THE SORTING ALGORTHM USED HEREIN
C              IS THE QUICKSORT.
C              THIS ALGORTHIM IS EXTREMELY FAST AS THE
C              FOLLOWING TIME TRIALS INDICATE.
C              THESE TIME TRIALS WERE CARRIED OUT ON THE
C              UNIVAC 1108 EXEC 8 SYSTEM AT NBS
C              IN AUGUST OF 1974.
C              BY WAY OF COMPARISON, THE TIME TRIAL VALUES
C              FOR THE EASY-TO-PROGRAM BUT EXTREMELY
C              INEFFICIENT BUBBLE SORT ALGORITHM HAVE
C              ALSO BEEN INCLUDED--
C              NUMBER OF RANDOM         QUICKSORT       BUBBLE SORT
C               NUMBERS SORTED
C                N = 10                 .002 SEC          .002 SEC
C                N = 100                .011 SEC          .045 SEC
C                N = 1000               .141 SEC         4.332 SEC
C                N = 3000               .476 SEC        37.683 SEC
C                N = 10000             1.887 SEC      NOT COMPUTED
C     REFERENCES--CACM MARCH 1969, PAGE 186 (QUICKSORT ALGORITHM
C                 BY RICHARD C. SINGLETON).
C               --CACM JANUARY 1970, PAGE 54.
C               --CACM OCTOBER 1970, PAGE 624.
C               --JACM JANUARY 1961, PAGE 41.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (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         --JANUARY   1975.
C     UPDATED         --NOVEMBER  1975.
C     UPDATED         --JANUARY   1977.
C     UPDATED         --MARCH     1979.
C     UPDATED         --AUGUST    1981.
C     UPDATED         --MARCH     1982.
C     UPDATED         --MAY       1982.
C     UPDATED         --JUNE      1990. TEMPORARY ARRAYS TO GARBAGE COMMON
C     UPDATED         --JANUARY   2007. PASS XS AS ARGUMENT
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 XR(*)
      DIMENSION XS(MAXOBV)
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='RANK'
      ISUBN2='    '
      IERROR='NO'
      IUPPER=MAXOBV
C
      K=0
      RPREV=0.0
C
      IF(IBUGA3.EQ.'ON')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,51)
   51   FORMAT('***** AT THE BEGINNING OF RANK--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,53)N,IUPPER,IBUGA3
   53   FORMAT('N,IUPPER,IBUGA3 = ',2I8,2X,A4)
        CALL DPWRST('XXX','BUG ')
        DO55I=1,N
          WRITE(ICOUT,56)I,X(I)
   56     FORMAT('I,X(I) = ',I8,G15.7)
          CALL DPWRST('XXX','BUG ')
   55   CONTINUE
      ENDIF
C
C               **********************************
C               **  COMPUTE THE RANKED VALUES.  **
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 RANK--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,113)IUPPER
  113   FORMAT('      THE NUMBER OF OBSERVATIONS IS LESS THAN 1 OR ',
     1         'OR LARGER THAN ',I8)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,118)N
  118   FORMAT('      THE NUMBER OF OBSERVATIONS IS ',I8)
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
      IF(N.EQ.1)THEN
        XR(1)=1.0
        GOTO9000
      ENDIF
C
      HOLD=X(1)
      DO133I=2,N
        IF(X(I).NE.HOLD)GOTO139
  133 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,135)HOLD
  135 FORMAT('***** WARNING IN RANK--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,136)HOLD
  136 FORMAT('      THE RESPONSE VARIABLE HAS ALL ELEMENTS = ',G15.7)
      CALL DPWRST('XXX','BUG ')
      AVRANK=(AN+1.0)/2.0
      DO137I=1,N
        XR(I)=AVRANK
  137 CONTINUE
      GOTO9000
  139 CONTINUE
C
C               ***************************************************
C               **  STEP 2--                                     **
C               **  FIRST SORT THE DATA FROM THE INPUT VECTOR X  **
C               **  INTO THE INTERMEDIATE STORAGE VECTOR XS.     **
C               ***************************************************
C
      CALL SORT(X,N,XS)
C
C               ****************************************************************
C               **  STEP 3--
C               **  NOW DETERMINE THE RANKS.
C               **  THE BASIC ALGORITHM IS TO TAKE A GIVEN ELEMENT
C               **  IN THE ORIGINAL INPUT VECTOR X,
C               **  AND SCAN THE SORTED VALUES IN THE XS VECTOR
C               **  UNTIL A MATCH IS FOUND;
C               **  WHEN A MATCH IS FOUND, THEN THE RANK FOR THAT
C               **  VALUE IN THE XS VECTOR IS DETERMINED.
C               **  THAT RANK IS THEN WRITTEN INTO THAT POSITION
C               **  IN THE OUTPUT Y VECTOR WHICH CORRESPONDS TO THE POSITION OF
C               **  GIVEN ELEMENT OF INTEREST IN THE ORIGINAL X VECTOR.
C               **  THE CODE IS LENGTHENED FROM THIS BASIC ALGORITHM
C               **  BY A SECTION WHICH CUTS DOWN THE SEARCH IN THE XS VECTOR,
C               **  AND BY A SECTION WHICH OBVIATES (UNDER CERTAIN CIRCUMSTANCES
C               **  THE NEED FOR RECALCULATING THE RANK OF AN ELEMENT IN XS.
C               ****************************************************************
C
      NM1=N-1
      XPREV=X(1)
      DO700I=1,N
        JMIN=1
        IF(X(I).GT.XPREV)THEN
          JMIN=K
          IF(JMIN.LT.N)GOTO790
          IF(JMIN.EQ.N)GOTO820
C
          IERROR='YES'
          IBRAN=1
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,111)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,781)IBRAN
  781     FORMAT('      IMPOSSIBLE BRANCH CONDITION AT BRANCH POINT = ',
     1           I8)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,782)JMIN
  782     FORMAT('JMIN = ',I8)
          CALL DPWRST('XXX','BUG ')
          GOTO9000
        ENDIF
        IF(I.EQ.1)GOTO790
        IF(X(I).EQ.XPREV)THEN
          XPREV=X(I)
          XR(I)=RPREV
          GOTO880
        ENDIF
C
  790   CONTINUE
        DO800J=JMIN,NM1
          IF(X(I).NE.XS(J))GOTO800
          JP1=J+1
          DO900K=JP1,N
            IF(XS(K).NE.XS(J))GOTO950
  900     CONTINUE
          K=N+1
  950     CONTINUE
          AVRANK=J+K-1
          AVRANK=AVRANK/2.0
          XPREV=X(I)
          XR(I)=AVRANK
          GOTO880
  800   CONTINUE
  820   CONTINUE
        J=N
        K=N+1
        IF(X(I).EQ.XS(J))GOTO850
C
        IERROR='YES'
        IBRAN=2
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,111)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,881)IBRAN
  881   FORMAT('      IMPOSSIBLE BRANCH CONDITION AT BRANCH POINT = ',
     1         I8)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,882)X(I),XS(I)
  882   FORMAT('X(I) = ',E15.7,'   XS(J) = ',E15.7)
        CALL DPWRST('XXX','BUG ')
        GOTO9000
C
  850   CONTINUE
        XPREV=X(I)
        XR(I)=N
  880   CONTINUE
        RPREV=XR(I)
  700 CONTINUE
C
      XMIN=XS(1)
      XMAX=XS(N)
C
C               ******************************
C               **  STEP 4--                **
C               **  WRITE OUT A FEW LINES   **
C               **  OF SUMMARY INFORMATION  **
C               **  ABOUT THE CODING.       **
C               ******************************
C
      IF(IFEEDB.EQ.'ON' .AND. IWRITE.EQ.'ON')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        AI=1
        WRITE(ICOUT,912)XS(1),AI
  912   FORMAT('THE MINIMUM (= ',E15.7,' ) HAS RANK ',F10.0)
        CALL DPWRST('XXX','BUG ')
        AI=N
        WRITE(ICOUT,913)XS(N),AI
  913   FORMAT('THE MAXIMUM (= ',E15.7,' ) HAS RANK ',F10.0)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
C
      IF(IBUGA3.EQ.'ON')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END       OF RANK--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9012)IBUGA3,IERROR
 9012   FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
        CALL DPWRST('XXX','BUG ')
        DO9015I=1,N
          WRITE(ICOUT,9016)I,X(I),XR(I),XS(I)
 9016     FORMAT('I,X(I),XR(I),XS(I) = ',I8,3G15.7)
          CALL DPWRST('XXX','BUG ')
 9015   CONTINUE
      ENDIF
C
      RETURN
      END
      SUBROUTINE RANKI(X,N,IWRITE,XR,XS,ITAG,MAXOBV,IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE RANKS (IN ASCENDING ORDER)
C              THE N ELEMENTS OF THE SINGLE PRECISION VECTOR X,
C              AND PUTS THE RESULTING N RANKS INTO THE
C              SINGLE PRECISION VECTOR XR.
C
C              THIS IS A VARIANT OF RANK THAT HANDLES TIES
C              DIFFERENTLY.  FOR EXAMPLE, IT THERE IS A TIE BETWEEN
C              RANK 7 AND RANK 8, THE RANK SUBROUTINE WILL ASSIGN
C              A RANK OF 7.5 TO BOTH.  THIS ROUTINE WILL ASSIGN
C              A RANK OF 7 AND A RANK OF 8 (IT WILL MAINTAIN THE
C              ORIGINAL ORDER).  THE "RANK INDEX" IS TYPICALLY USED
C              AS AN INDEX TO ANOTHER VECTOR, SO WE WANT ALL RANKS
C              TO BE UNIQUE INTEGERS.
C
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF
C                                OBSERVATIONS TO BE RANKED.
C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR X.
C     OUTPUT ARGUMENTS--XR     = THE SINGLE PRECISION VECTOR
C                                INTO WHICH THE RANKS
C                                FROM X WILL BE PLACED.
C     OUTPUT--THE SINGLE PRECISION VECTOR XR CONTAINING THE RANKS
C             (IN ASCENDING ORDER) OF THE VALUES
C             IN THE SINGLE PRECISION VECTOR X.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THE MAXIMUM ALLOWABLE VALUE OF N
C                   FOR THIS SUBROUTINE IS 7500.
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     COMMENT--THE RANK OF THE FIRST ELEMENT OF THE VECTOR X
C              WILL BE PLACED IN THE FIRST POSITION OF THE VECTOR XR,
C              THE RANK OF THE SECOND ELEMENT OF THE VECTOR X WILL BE
C              PLACED IN THE SECOND POSITION OF THE VECTOR XR, ETC.
C     COMMENT--THE SMALLEST ELEMENT IN THE VECTOR X
C              WILL HAVE A RANK OF 1 AND
C              THE LARGEST ELEMENT IN THE VECTOR X
C              WILL HAVE A RANK OF N.
C     COMMENT--ALTHOUGH RANKS ARE USUALLY (UNLESS TIES EXIST)
C              INTEGRAL VALUES FROM 1 TO N, IT IS TO BE
C              NOTED THAT THEY ARE OUTPUTED AS SINGLE
C              PRECISION INTEGERS IN THE SINGLE PRECISION
C              VECTOR XR.
C              XR IS SINGLE PRECISION SO AS TO BE
C              CONSISTENT WITH THE FACT THAT ALL
C              VECTOR ARGUMENTS IN ALL OTHER
C              DATAPAC SUBROUTINES ARE SINGLE PRECISION;
C              BUT MORE IMPORTANTLY, BECAUSE TIES FREQUENTLY
C              DO EXIST IN DATA SETS AND SO SOME OF THE
C              RESULTING RANKS WILL BE NON-INTEGRAL
C              AND SO THE OUTPUT VECTOR OF RANKS MUST NECESSARILY
C              BE SINGLE PRECISION AND NOT INTEGER.
C     COMMENT--THE INPUT VECTOR X REMAINS UNALTERED.
C     COMMENT--THE FIRST AND THIRD ARGUMENTS IN THE
C              CALLING SEQUENCE MAY
C              BE IDENTICAL; THAT IS, AN 'IN PLACE'
C              RANKING IS PERMITTED.
C              THE CALLING SEQUENCE
C              CALL RANK(X,N,X) IS VALID, IF DESIRED.
C     COMMENT--THE SORTING ALGORTHM USED HEREIN
C              IS THE QUICKSORT.
C              THIS ALGORTHIM IS EXTREMELY FAST AS THE
C              FOLLOWING TIME TRIALS INDICATE.
C              THESE TIME TRIALS WERE CARRIED OUT ON THE
C              UNIVAC 1108 EXEC 8 SYSTEM AT NBS
C              IN AUGUST OF 1974.
C              BY WAY OF COMPARISON, THE TIME TRIAL VALUES
C              FOR THE EASY-TO-PROGRAM BUT EXTREMELY
C              INEFFICIENT BUBBLE SORT ALGORITHM HAVE
C              ALSO BEEN INCLUDED--
C              NUMBER OF RANDOM         QUICKSORT       BUBBLE SORT
C               NUMBERS SORTED
C                N = 10                 .002 SEC          .002 SEC
C                N = 100                .011 SEC          .045 SEC
C                N = 1000               .141 SEC         4.332 SEC
C                N = 3000               .476 SEC        37.683 SEC
C                N = 10000             1.887 SEC      NOT COMPUTED
C     REFERENCES--CACM MARCH 1969, PAGE 186 (QUICKSORT ALGORITHM
C                 BY RICHARD C. SINGLETON).
C               --CACM JANUARY 1970, PAGE 54.
C               --CACM OCTOBER 1970, PAGE 624.
C               --JACM JANUARY 1961, PAGE 41.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2010.6
C     ORIGINAL VERSION--JUNE      2010.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
C
      DIMENSION X(*)
      DIMENSION XR(*)
      DIMENSION XS(*)
      INTEGER   ITAG(*)
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='RANK'
      ISUBN2='I   '
      IERROR='NO'
C
      IUPPER=MAXOBV
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 RANK--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,53)IBUGA3,N,IUPPER
   53   FORMAT('IBUGA3,N,IUPPER = ',A4,2X,2I8)
        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
      ENDIF
C
C               **********************************
C               **  COMPUTE THE RANKED VALUES.  **
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 RANK INDEX--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,113)IUPPER
  113   FORMAT('      THE NUMBER OF OBSERVATIONS IS LESS THAN ONE ',
     1         'OR LARGER THAN ',I8)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,118)N
  118   FORMAT('***** THE NUMBER OF OBSERVATIONS IS ',I8)
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
      IF(N.EQ.1)THEN
        XR(1)=1.0
        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('***** WARNING IN RANK INDEX--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,138)HOLD
  138 FORMAT('      THE RESPONSE VARIABLE HAS ALL ELEMENTS = ',G15.7)
      CALL DPWRST('XXX','BUG ')
      DO137I=1,N
        XR(I)=REAL(I)
  137 CONTINUE
      GOTO9000
  139 CONTINUE
C
C               ***************************************************
C               **  STEP 2--                                     **
C               **  FIRST SORT THE DATA FROM THE INPUT VECTOR X  **
C               **  INTO THE INTERMEDIATE STORAGE VECTOR XS.     **
C               ***************************************************
C
      CALL SORT(X,N,XS)
      DO210I=1,N
        ITAG(I)=0
  210 CONTINUE
C
C               ********************************************************
C               **  STEP 3--                                          **
C               **  NOW DETERMINE THE RANKS.                          **
C               **  THE BASIC ALGORITHM IS TO TAKE A GIVEN ELEMENT    **
C               **  IN THE ORIGINAL INPUT VECTOR X,                   **
C               **  AND SCAN THE SORTED VALUES IN THE XS VECTOR       **
C               **  UNTIL A MATCH IS FOUND;                           **
C               **  WHEN A MATCH IS FOUND, THEN THE RANK FOR THAT     **
C               **  VALUE IN THE XS VECTOR IS DETERMINED.             **
C               **  THAT RANK IS THEN WRITTEN INTO THAT POSITION      **
C               **  IN THE OUTPUT Y VECTOR WHICH CORRESPONDS TO THE   **
C               **  POSITION OF GIVEN ELEMENT OF INTEREST IN THE      **
C               **  ORIGINAL X VECTOR.  TIES ARE HANDLED BY           **
C               **  KEEPING A TAG VECTOR WHICH IDENTIFIES WHETHER A   **
C               **  MATCHED ELEMENT HAS BEEN PREVIOUSLY IDENTIFIED.   **
C               ********************************************************
C
      DO700I=1,N
        DO800J=1,N
          IF(X(I).EQ.XS(J) .AND. ITAG(J).EQ.0)THEN
            XR(I)=REAL(J)
            ITAG(J)=1
            GOTO700
          ENDIF
  800   CONTINUE
  700 CONTINUE
C
      XMIN=XS(1)
      XMAX=XS(N)
C
C               ******************************
C               **  STEP 4--                **
C               **  WRITE OUT A FEW LINES   **
C               **  OF SUMMARY INFORMATION  **
C               **  ABOUT THE CODING.       **
C               ******************************
C
      IF(IFEEDB.EQ.'OFF')GOTO990
      IF(IWRITE.EQ.'OFF')GOTO990
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      AI=1
      WRITE(ICOUT,912)XS(1),AI
  912 FORMAT('THE MINIMUM (= ',E15.7,' ) HAS RANK ',F10.0)
      CALL DPWRST('XXX','BUG ')
      AI=N
      WRITE(ICOUT,913)XS(N),AI
  913 FORMAT('THE MAXIMUM (= ',E15.7,' ) HAS RANK ',F10.0)
      CALL DPWRST('XXX','BUG ')
  990 CONTINUE
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
C
      IF(IBUGA3.EQ.'ON')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END       OF RANK--')
        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 ')
        DO9015I=1,N
         WRITE(ICOUT,9016)I,X(I),XR(I),XS(I)
 9016    FORMAT('I,X(I),XR(I),XS(I) = ',I8,3E15.7)
         CALL DPWRST('XXX','BUG ')
 9015  CONTINUE
      ENDIF
C
      RETURN
      END
      SUBROUTINE RANK2(Y1,GROUP,N,IWRITE,Y2,TEMP1,TEMPR,XIDTEM,ITEMP1,
     1                 MAXOBV,
     1                 ISUBRO,IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE RANKS BASED ON TWO VARIABLES
C     INPUT  ARGUMENTS--Y1     = THE SINGLE PRECISION VECTOR CONTAINING
C                                THE RESPONSE VARIABLE TO BE RANKED.
C                     --GROUP  = THE SINGLE PRECISION VECTOR CONTAINING
C                                THE GROUP-ID VARIABLE TO BE RANKED.
C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR X.
C     OUTPUT ARGUMENTS--Y2     = THE SINGLE PRECISION VECTOR
C                                CONTAINING THE RANKED VALUES OF
C                                THE RESPONSE VARIABLE.
C     OUTPUT--THE SINGLE PRECISION VECTORS Y2 CONTAINING
C             THE RANKED VECTORS.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     OTHER DATAPAC   SUBROUTINES NEEDED--RANK, SORT.
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                 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2008.12
C     ORIGINAL VERSION--NOVEMBER  2008.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 ISUBRO
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DIMENSION Y1(*)
      DIMENSION Y2(*)
      DIMENSION GROUP(*)
      DIMENSION TEMP1(*)
      DIMENSION TEMPR(*)
      DIMENSION XIDTEM(*)
C
      INTEGER ITEMP1(*)
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='RANK'
      ISUBN2='2   '
      IERROR='NO'
      IWRITE='OFF'
C
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'ANK2')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,51)
   51   FORMAT('***** AT THE BEGINNING OF RANK2--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,52)IBUGA3
   52   FORMAT('IBUGA3 = ',A4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,53)N
   53   FORMAT('N = ',2I8)
        CALL DPWRST('XXX','BUG ')
        DO55I=1,N
          WRITE(ICOUT,56)I,GROUP(I),Y1(I)
   56     FORMAT('I,GROUP(I),Y1(I) = ',I8,2G15.7)
          CALL DPWRST('XXX','BUG ')
   55   CONTINUE
      ENDIF
C
C    ********************************************
C    **  STEP 1--                              **
C    **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C    ********************************************
C
      AN=N
C
      IF(N.LT.1)THEN
        IERROR='YES'
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,111)
  111   FORMAT('***** ERROR IN RANK2--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,113)
  113   FORMAT('      THE NUMBER OF RESPONSE VALUES IS ',
     1         'NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,115)N
  115   FORMAT('      THE NUMBER OF RESPONSE VALUES IS ',I8)
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
      IF(N.EQ.1)THEN
        Y2(1)=1.0
        GOTO9000
      ENDIF
C
C     ***************************************************
C     **  STEP 2--                                     **
C     **  DETERMINE DISTINCT VALUES OF FIRST VARIABLE  **
C     **  (THE GROUP-ID VARIABLE)                      **
C     ***************************************************
C
      CALL DISTIN(GROUP,N,IWRITE,XIDTEM,NDIST,IBUGA3,IERROR)
      IF(N.EQ.NDIST)THEN
        DO1010I=1,N
          Y2(I)=1.0
 1010   CONTINUE
        GOTO9000
      ELSEIF(NDIST.EQ.1)THEN
        CALL RANK(Y1,N,IWRITE,Y2,TEMP1,MAXOBV,IBUGA3,IERROR)
        GOTO9000
      ENDIF
C
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'ANK2')THEN
        WRITE(ICOUT,1091)
 1091   FORMAT('AFTER DETERMINE DISTINCT VALUES OF VARIABLE ONE')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,1092)NDIST
 1092   FORMAT('NDIST = ',I8)
        CALL DPWRST('XXX','BUG ')
        DO1099I=1,NDIST
        WRITE(ICOUT,1093)I,XIDTEM(I)
 1093   FORMAT('I,XIDTEM(I) = ',I8,G15.7)
        CALL DPWRST('XXX','BUG ')
 1099   CONTINUE
      ENDIF
C
C     ****************************************************
C     **  STEP 3--                                      **
C     **  NOW RANK THE SECOND VARIABLE FOR COMMON       **
C     **  VALUES OF FIRST VARIABLE.                     **
C     ****************************************************
C
C
      CALL SORT(XIDTEM,NDIST,XIDTEM)
C
      DO2110ISET=1,NDIST
        HOLD=XIDTEM(ISET)
C
        IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'ANK2')THEN
          WRITE(ICOUT,2111)ISET,ISTRT,HOLD
 2111     FORMAT('AT 2110: ISET,ISTRT,HOLD = ',2I8,G15.7)
          CALL DPWRST('XXX','BUG ')
        ENDIF
C
        ICNT=0
        DO2120I=1,N
          IF(GROUP(I).EQ.HOLD)THEN
            ICNT=ICNT+1
            TEMP1(ICNT)=Y1(I)
            ITEMP1(ICNT)=I
          ENDIF
 2120   CONTINUE
        CALL RANK(TEMP1,ICNT,IWRITE,TEMP1,TEMPR,MAXOBV,IBUGA3,IERROR)
        DO2160J=1,ICNT
          IINDX=ITEMP1(J)
          Y2(IINDX)=TEMP1(J)
 2160   CONTINUE
 2110 CONTINUE
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
C
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'ANK2')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END       OF RANK2--')
        CALL DPWRST('XXX','BUG ')
        DO9015I=1,N
          WRITE(ICOUT,9016)I,GROUP(I),Y1(I),Y2(I)
 9016     FORMAT('I,GROUP(I),Y1(I),Y2(I) = ',I8,3G15.7)
          CALL DPWRST('XXX','BUG ')
 9015   CONTINUE
      ENDIF
C
      RETURN
      END
      SUBROUTINE RANK3(Y1,GROUP1,GROUP2,N,IWRITE,Y2,
     1                 TEMP1,TEMPR,XIDTEM,XIDTE2,ITEMP1,
     1                 MAXOBV,
     1                 ISUBRO,IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE RANKS BASED ON TWO VARIABLES
C     INPUT  ARGUMENTS--Y1     = THE SINGLE PRECISION VECTOR CONTAINING
C                                THE RESPONSE VARIABLE TO BE RANKED.
C                     --GROUP1 = THE SINGLE PRECISION VECTOR CONTAINING
C                                THE FIRST GROUP-ID VARIABLE TO BE
C                                RANKED.
C                     --GROUP2 = THE SINGLE PRECISION VECTOR CONTAINING
C                                THE SECOND GROUP-ID VARIABLE TO BE
C                                RANKED.
C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR X.
C     OUTPUT ARGUMENTS--Y2     = THE SINGLE PRECISION VECTOR
C                                CONTAINING THE RANKED VALUES OF
C                                THE RESPONSE VARIABLE.
C     OUTPUT--THE SINGLE PRECISION VECTORS Y2 CONTAINING
C             THE RANKED VECTOR.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     OTHER DATAPAC   SUBROUTINES NEEDED--RANK, SORT.
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                 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2008.12
C     ORIGINAL VERSION--DECEMBER  2008.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 ISUBRO
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DIMENSION Y1(*)
      DIMENSION Y2(*)
      DIMENSION GROUP1(*)
      DIMENSION GROUP2(*)
      DIMENSION TEMP1(*)
      DIMENSION TEMPR(*)
      DIMENSION XIDTEM(*)
      DIMENSION XIDTE2(*)
C
      INTEGER ITEMP1(*)
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='RANK'
      ISUBN2='3   '
      IERROR='NO'
      IWRITE='OFF'
C
      N1=0
      N2=0
      NDIST=0
C
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'ANK3')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,51)
   51   FORMAT('***** AT THE BEGINNING OF RANK2--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,52)IBUGA3
   52   FORMAT('IBUGA3 = ',A4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,53)N
   53   FORMAT('N = ',2I8)
        CALL DPWRST('XXX','BUG ')
        DO55I=1,N
          WRITE(ICOUT,56)I,GROUP1(I),GROUP2(I),Y1(I)
   56     FORMAT('I,GROUP1(I),GROUP2(I),Y1(I) = ',I8,3G15.7)
          CALL DPWRST('XXX','BUG ')
   55   CONTINUE
      ENDIF
C
C    ********************************************
C    **  STEP 1--                              **
C    **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C    ********************************************
C
      AN=N
C
      IF(N.LT.1)THEN
        IERROR='YES'
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,111)
  111   FORMAT('***** ERROR IN RANK2--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,113)
  113   FORMAT('      THE NUMBER OF RESPONSE VALUES IS ',
     1         'NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,115)N
  115   FORMAT('      THE NUMBER OF RESPONSE VALUES IS ',I8)
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
      IF(N.EQ.1)THEN
        Y2(1)=1.0
        GOTO9000
      ENDIF
C
C     ***************************************************
C     **  STEP 2--                                     **
C     **  DETERMINE DISTINCT VALUES OF FIRST VARIABLE  **
C     **  (THE GROUP-ID VARIABLE)                      **
C     ***************************************************
C
      CALL DISTIN(GROUP1,N,IWRITE,XIDTEM,NDIST1,IBUGA3,IERROR)
      CALL DISTIN(GROUP2,N,IWRITE,XIDTE2,NDIST2,IBUGA3,IERROR)
      IF(N1.EQ.NDIST1 .AND. N2.EQ.NDIST2)THEN
        DO1010I=1,N
          Y2(I)=1.0
 1010   CONTINUE
        GOTO9000
      ELSEIF(NDIST1.EQ.1 .AND. NDIST2.EQ.1)THEN
        CALL RANK(Y1,N,IWRITE,Y2,TEMP1,MAXOBV,IBUGA3,IERROR)
        GOTO9000
      ENDIF
C
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'ANK3')THEN
        WRITE(ICOUT,1091)
 1091   FORMAT('AFTER DETERMINE DISTINCT VALUES OF VARIABLE ONE')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,1092)NDIST
 1092   FORMAT('NDIST = ',I8)
        CALL DPWRST('XXX','BUG ')
        DO1099I=1,NDIST
        WRITE(ICOUT,1093)I,XIDTEM(I),XIDTE2(I)
 1093   FORMAT('I,XIDTEM(I),XIDTE2(I) = ',I8,2G15.7)
        CALL DPWRST('XXX','BUG ')
 1099   CONTINUE
      ENDIF
C
C     ****************************************************
C     **  STEP 3--                                      **
C     **  NOW RANK THE SECOND VARIABLE FOR COMMON       **
C     **  VALUES OF FIRST VARIABLE.                     **
C     ****************************************************
C
C
      CALL SORT(XIDTEM,NDIST1,XIDTEM)
      CALL SORT(XIDTE2,NDIST2,XIDTE2)
C
      DO2110ISET1=1,NDIST1
        HOLD1=XIDTEM(ISET1)
C
        DO2120ISET2=1,NDIST2
          HOLD2=XIDTEM(ISET2)
C
          IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'ANK3')THEN
            WRITE(ICOUT,2121)ISET1,ISET2,HOLD1,HOLD2
 2121       FORMAT('AT 2120: ISET1,ISET2,HOLD1,HOLD2 = ',2I8,2G15.7)
            CALL DPWRST('XXX','BUG ')
          ENDIF
C
          ICNT=0
          DO2130I=1,N
            IF(GROUP1(I).EQ.HOLD1 .AND. GROUP2(I).EQ.HOLD2)THEN
              ICNT=ICNT+1
              TEMP1(ICNT)=Y1(I)
              ITEMP1(ICNT)=I
            ENDIF
 2130     CONTINUE
          CALL RANK(TEMP1,ICNT,IWRITE,TEMP1,TEMPR,MAXOBV,
     1              IBUGA3,IERROR)
          DO2160J=1,ICNT
            IINDX=ITEMP1(J)
            Y2(IINDX)=TEMP1(J)
 2160     CONTINUE
 2120   CONTINUE
 2110 CONTINUE
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
C
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'ANK3')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END       OF RANK3--')
        CALL DPWRST('XXX','BUG ')
        DO9015I=1,N
          WRITE(ICOUT,9016)I,GROUP1(I),GROUP2(I),Y1(I),Y2(I)
 9016     FORMAT('I,GROUP1(I),GROUP2(I),Y1(I),Y2(I) = ',
     1           I8,4G15.7)
          CALL DPWRST('XXX','BUG ')
 9015   CONTINUE
      ENDIF
C
      RETURN
      END
      SUBROUTINE RANKCM(X,Y,N,IWRITE,XTEMP,YTEMP,XTEMP2,
     1MAXNXT,XYRACM,
     1IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE
C              RANK COMOVEMENT COEFFICIENT
C              BETWEEN THE 2 SETS OF DATA IN THE INPUT VECTORS X AND Y.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF
C                                (UNSORTED OR SORTED) OBSERVATIONS
C                                WHICH CONSTITUTE THE FIRST SET
C                                OF DATA.
C                     --Y      = THE SINGLE PRECISION VECTOR OF
C                                (UNSORTED OR SORTED) OBSERVATIONS
C                                WHICH CONSTITUTE THE SECOND SET
C                                OF DATA.
C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR X, OR EQUIVALENTLY,
C                                THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR Y.
C     OUTPUT ARGUMENTS--XYRACM = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED RANK COMOVEMENT
C                                COEFFICIENT BETWEEN THE 2 SETS OF DATA
C                                IN THE INPUT VECTORS X AND Y.
C                                THIS SINGLE PRECISION VALUE
C                                WILL BE BETWEEN -1.0 AND 1.0
C                                (INCLUSIVELY).
C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
C             RANK COMOVEMENT COEFFICIENT BETWEEN THE 2 SETS
C             OF DATA IN THE INPUT VECTORS X AND Y.
C     OTHER DATAPAC   SUBROUTINES NEEDED--RANK AND SORT.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--AN INDEX FOR COMOVEMENT OF TIME SEQUENCES
C                 WITH GEOPHYSICAL APPLICATIONS:  A WORKING PAPER
C                 (PENN STATE INTERFACE CONFERANCE ON ASTRONOMY
C                 AUGUST 11-14, 1991)
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--91.8
C     ORIGINAL VERSION--AUGUST    1991.
C     UPDATED         --JANUARY   2007.  CALL LIST TO RANK
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 IWRIT2
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DN
      DOUBLE PRECISION DXI
      DOUBLE PRECISION DXIM1
      DOUBLE PRECISION DYI
      DOUBLE PRECISION DYIM1
      DOUBLE PRECISION DDELX
      DOUBLE PRECISION DDELY
      DOUBLE PRECISION DSUMX
      DOUBLE PRECISION DSUMY
      DOUBLE PRECISION DSUMXY
      DOUBLE PRECISION DSQRTX
      DOUBLE PRECISION DSQRTY
C
      DIMENSION X(*)
      DIMENSION Y(*)
C
      DIMENSION XTEMP(*)
      DIMENSION YTEMP(*)
      DIMENSION XTEMP2(*)
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='RANK'
      ISUBN2='CM  '
      IERROR='NO'
C
      DN=0.0D0
      DSUMX=0.0D0
      DSUMY=0.0D0
      DSUMXY=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 RANKCM--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)IBUGA3
   52 FORMAT('IBUGA3 = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)N
   53 FORMAT('N = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO55I=1,N
      WRITE(ICOUT,56)I,X(I),Y(I)
   56 FORMAT('I,X(I),Y(I) = ',I8,2E15.7)
      CALL DPWRST('XXX','BUG ')
   55 CONTINUE
   90 CONTINUE
C
C               ********************************************
C               **  COMPUTE RANK COMOVEMENT  COEFFICIENT  **
C               ********************************************
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      AN=N
C
      IF(2.LE.N.AND.N.LE.MAXNXT)GOTO119
      IERROR='YES'
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,111)
  111 FORMAT('***** ERROR IN RANKCM--')
      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 RANK COMOVEMENT COEFFICIENT IS TO BE')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,115)MAXNXT
  115 FORMAT('      MUST BE BETWEEN 2 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.2)GOTO120
      GOTO129
  120 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,121)
  121 FORMAT('***** NON-FATAL DIAGNOSTIC IN RANKCM--',
     1'THE THIRD INPUT ARGUMENT (N) HAS THE VALUE 2')
      CALL DPWRST('XXX','BUG ')
      XYRACM=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 RANKCM--',
     1'THE 1ST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      XYRACM=0.0
      GOTO9000
  139 CONTINUE
C
      HOLD=Y(1)
      DO145I=2,N
      IF(Y(I).NE.HOLD)GOTO149
  145 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,146)HOLD
  146 FORMAT('***** NON-FATAL DIAGNOSTIC IN RANKCM--',
     1'THE 2ND INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      XYRACM=0.0
      GOTO9000
  149 CONTINUE
C
C               *************************************************
C               **  STEP 2--                                   **
C               **  COMPUTE THE RANK COMOVEMENT  COEFFICIENT.  **
C               *************************************************
C
      IWRIT2=IBUGA3
      CALL RANK(X,N,IWRIT2,XTEMP,XTEMP2,MAXNXT,IBUGA3,IERROR)
      CALL RANK(Y,N,IWRIT2,YTEMP,XTEMP2,MAXNXT,IBUGA3,IERROR)
C
      DN=N
      DSUMX=0.0D0
      DSUMY=0.0D0
      DSUMXY=0.0D0
      DO300I=2,N
      IM1=I-1
      DXI=XTEMP(I)
      DXIM1=XTEMP(IM1)
      DDELX=DXI-DXIM1
      DYI=YTEMP(I)
      DYIM1=YTEMP(IM1)
      DDELY=DYI-DYIM1
      DSUMX=DSUMX+DDELX**2
      DSUMY=DSUMY+DDELY**2
      DSUMXY=DSUMXY+DDELX*DDELY
  300 CONTINUE
      DSQRTX=0.0
      IF(DSUMX.GT.0.0D0)DSQRTX=DSQRT(DSUMX)
      DSQRTY=0.0
      IF(DSUMY.GT.0.0D0)DSQRTY=DSQRT(DSUMY)
      XYRACM=DSUMXY/(DSQRTX*DSQRTY)
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,XYRACM
  811 FORMAT('THE RANK COMOVEMENT COEFFICIENT OF THE ',I8,
     1' OBSERVATIONS = ',E15.7)
      CALL DPWRST('XXX','BUG ')
  890 CONTINUE
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'OFF')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF RANKCM--')
      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,DSUMY,DSUMXY
 9014 FORMAT('DN,DSUMX,DSUMY,DSUMXY = ',4D15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9015)XYRACM
 9015 FORMAT('XYRACM = ',E15.7)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE RANCOM(K,N,ISEED,X,ITEMP1)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM COMPOSITION
C              OF THE INTEGER N INTO K NON-NEGATIVE INTEGERS.
C     INPUT  ARGUMENTS--K      = THE INTEGER NUMBER DENOTING THE
C                                NUMBER OF ELEMENTS IN THE
C                                COMPOSITION
C                     --N      = THE INTEGER NUMBER BEING COMPOSED.
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST K)
C                                INTO WHICH THE GENERATED
C                                RANDOM COMPOSITION IS PLACED.
C     OUTPUT--A RANDOM COMPOSITION OF THE INTEGER N INTO K ELEMENTS.
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.   HOWEVER, K <= N.
C     OTHER DATAPAC   SUBROUTINES NEEDED--RANKSB.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCE: NIJENHUIS, ALBERT AND WILF, HERBERT S., 'COMBINATORIAL
C                ALGORITHMS', ACADEMIC PRESS, 1975, CH. 6, P. 48.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2008/5
C     ORIGINAL VERSION--MAY       2008.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DIMENSION X(*)
      INTEGER   ITEMP1(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(K.LT.1)THEN
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,6)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)K
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(N.LT.1)THEN
        WRITE(ICOUT,15)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,48)N
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(K.GT.N)THEN
        WRITE(ICOUT,25)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,26)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)K
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,48)N
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
    5 FORMAT('***** ERROR--FOR THE RANDOM COMPOSITION OF N, THE')
    6 FORMAT('      REQUESTED NUMBER OF ELEMENTS IS NON-POSITIVE.')
   15 FORMAT('***** ERROR--FOR THE RANDOM COMPOSITION OF N, THE ',
     1       'VALUE OF N IS NON-POSITIVE.')
   25 FORMAT('***** ERROR--FOR THE RANDOM COMPOSITION OF N INTO ',
     1       'K ELEMENTS,')
   26 FORMAT('      K IS GREATER THAN N.')
   47 FORMAT('***** THE VALUE OF K IS ',I8)
   48 FORMAT('***** THE VALUE OF N IS ',I8)
C
C     GENERATE A RANDOM COMPOSITION OF N INTO K ELEMENTS
C
      NTEMP1=N+K-1
      NTEMP2=K-1
      CALL RANKSB(NTEMP2,NTEMP1,ISEED,X,ITEMP1)
      CALL SORT(X,NTEMP2,X)
      DO100I=1,NTEMP2
        ITEMP1(I)=INT(X(I)+0.5)
  100 CONTINUE
C
      ITEMP1(K)=N+K
      L=0
      DO200I=1,K
        M=ITEMP1(I)
        ITEMP1(I)=M-L-1
        L=M
  200 CONTINUE
C
      DO300I=1,K
        X(I)=REAL(ITEMP1(I))
  300 CONTINUE
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE RANKCR(X,Y,N,IRCRTA,IWRITE,XTEMP,YTEMP,XTEMP2,MAXNXT,
     1                  XYRACR,STATCD,PVAL,PVALLT,PVALUT,
     1                  CUTU90,CUTU95,CTU975,CUTU99,CTU995,CTU999,
     1                  CUTL90,CUTL95,CTL975,CUTL99,CTL995,CTL999,
     1                  IBUGA3,ISUBRO,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE SPEARMAN RANK CORRELATION
C              COEFFICIENT BETWEEN THE 2 SETS OF DATA IN THE INPUT
C              VECTORS X AND Y.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF
C                                (UNSORTED OR SORTED) OBSERVATIONS
C                                WHICH CONSTITUTE THE FIRST SET
C                                OF DATA.
C                     --Y      = THE SINGLE PRECISION VECTOR OF
C                                (UNSORTED OR SORTED) OBSERVATIONS
C                                WHICH CONSTITUTE THE SECOND SET
C                                OF DATA.
C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR X, OR EQUIVALENTLY,
C                                THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR Y.
C     OUTPUT ARGUMENTS--XYRACR = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED SPEARMAN RANK CORRELATION
C                                COEFFICIENT BETWEEN THE 2 SETS OF DATA
C                                IN THE INPUT VECTORS X AND Y.
C                                THIS SINGLE PRECISION VALUE
C                                WILL BE BETWEEN -1.0 AND 1.0
C                                (INCLUSIVELY).
C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
C             SPEARMAN RANK CORRELATION COEFFICIENT BETWEEN THE 2 SETS
C             OF DATA IN THE INPUT VECTORS X AND Y.
C     OTHER DATAPAC   SUBROUTINES NEEDED--RANK AND SORT.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--DSQRT.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--KENDALL AND STUART, THE ADVANCED THEORY OF
C                 STATISTICS, VOLUME 2, EDITION 1, 1961, PAGES 476-477.
C               --SNEDECOR AND COCHRAN, STATISTICAL METHODS,
C                 EDITION 6, 1967, PAGES 193-195.
C               --DIXON AND MASSEY, INTRODUCTION TO STATISTICAL
C                 ANALYSIS, EDITION 2, 1957, PAGES 294-295.
C               --MOOD AND GRABLE, 'INTRODUCTION TO THE THEORY
C                 OF STATISTICS, EDITION 2, 1963, PAGE 424.
C               --W. J. CONOVER, "PRACTICAL NON-PARAMETRIC
C                 STATISTICS", THIRD EDITION, WILEY, 1999,
C                 PP. 318-322.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--82.6
C     ORIGINAL VERSION--JUNE      1972.
C     UPDATED         --OCTOBER   1974.
C     UPDATED         --JANUARY   1975.
C     UPDATED         --SEPTEMBER 1975.
C     UPDATED         --NOVEMBER  1975.
C     UPDATED         --FEBRUARY  1976.
C     UPDATED         --JUNE      1979.
C     UPDATED         --JULY      1979.
C     UPDATED         --JULY      1981.
C     UPDATED         --AUGUST    1981.
C     UPDATED         --MAY       1982.
C     UPDATED         --JANUARY   2007. CALL LIST TO RANK
C     UPDATED         --FEBRUARY  2013. RETURN CRITICAL VALUES FOR
C                                       SMALL SAMPLES, CDF/PVALUES
C                                       FOR LARGE SAMPLES
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IRCRTA
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGA3
      CHARACTER*4 ISUBRO
      CHARACTER*4 IERROR
C
      CHARACTER*4 IWRIT2
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DN
      DOUBLE PRECISION DX1
      DOUBLE PRECISION DX2
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DSUM2
      DOUBLE PRECISION DSUM12
      DOUBLE PRECISION DMEAN1
      DOUBLE PRECISION DMEAN2
C
      DIMENSION X(*)
      DIMENSION Y(*)
C
      DIMENSION XTEMP(*)
      DIMENSION YTEMP(*)
      DIMENSION XTEMP2(*)
C
      DIMENSION WP900(30)
      DIMENSION WP950(30)
      DIMENSION WP975(30)
      DIMENSION WP990(30)
      DIMENSION WP995(30)
      DIMENSION WP999(30)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      DATA WP900/
     1  -9.9999,-9.9999,-9.9999, 0.8000, 0.7000, 0.6000, 0.5357, 0.5000,
     1   0.4667, 0.4424, 0.4182, 0.3986, 0.3791, 0.3626, 0.3500, 0.3382,
     1   0.3260, 0.3148, 0.3070, 0.2977, 0.2909, 0.2829, 0.2767, 0.2704,
     1   0.2646, 0.2588, 0.2540, 0.2490, 0.2443, 0.2400/
C
      DATA WP950/
     1  -9.9999,-9.9999,-9.9999, 0.8000, 0.8000, 0.7714, 0.6786, 0.6190,
     1   0.5833, 0.5515, 0.5273, 0.4965, 0.4780, 0.4593, 0.4429, 0.4265,
     1   0.4118, 0.3994, 0.3895, 0.3789, 0.3688, 0.3597, 0.3518, 0.3435,
     1   0.3362, 0.3299, 0.3236, 0.3175, 0.3113, 0.3059/
C
      DATA WP975/
     1  -9.9999,-9.9999,-9.9999,-9.9999, 0.9000, 0.8286, 0.7500, 0.7143,
     1   0.6833, 0.6364, 0.6091, 0.5804, 0.5549, 0.5341, 0.5179, 0.5000,
     1   0.4853, 0.4696, 0.4579, 0.4451, 0.4351, 0.4241, 0.4150, 0.4061,
     1   0.3977, 0.3894, 0.3822, 0.3749, 0.3685, 0.3620/
C
      DATA WP990/
     1  -9.9999,-9.9999,-9.9999,-9.9999, 0.9000, 0.8857, 0.8571, 0.8095,
     1   0.7667, 0.7333, 0.7000, 0.6713, 0.6429, 0.6220, 0.6000, 0.5794,
     1   0.5637, 0.5480, 0.5333, 0.5203, 0.5078, 0.4963, 0.4852, 0.4748,
     1   0.4654, 0.4564, 0.4481, 0.4401, 0.4320, 0.4251/
C
      DATA WP995/
     1  -9.9999,-9.9999,-9.9999,-9.9999,-9.9999, 0.9429, 0.8929, 0.8571,
     1   0.8167, 0.7818, 0.7455, 0.7203, 0.6978, 0.6747, 0.6500, 0.6324,
     1   0.6152, 0.5975, 0.5825, 0.5684, 0.5545, 0.5426, 0.5306, 0.5200,
     1   0.5100, 0.5002, 0.4915, 0.4828, 0.4744, 0.4665/
C
      DATA WP999/
     1  -9.9999,-9.9999,-9.9999,-9.9999,-9.9999,-9.9999, 0.9643, 0.9286,
     1   0.9000, 0.8667, 0.8364, 0.8112, 0.7857, 0.7670, 0.7464, 0.7265,
     1   0.7083, 0.6904, 0.6737, 0.6586, 0.6455, 0.6318, 0.6186, 0.6070,
     1   0.5962, 0.5856, 0.5757, 0.5660, 0.5567, 0.5479/
C
      ISUBN1='RANK'
      ISUBN2='CR  '
C
      IERROR='NO'
C
      DN=0.0D0
      DMEAN1=0.0D0
      DMEAN2=0.0D0
      DSUM12=0.0D0
C
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'NKCR')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,51)
   51   FORMAT('***** AT THE BEGINNING OF RANKCR--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,52)IBUGA3,ISUBRO,N
   52   FORMAT('IBUGA3,ISUBRO,N = ',2(A4,2X),I8)
        CALL DPWRST('XXX','BUG ')
        DO55I=1,N
          WRITE(ICOUT,56)I,X(I),Y(I)
   56     FORMAT('I,X(I),Y(I) = ',I8,2G15.7)
          CALL DPWRST('XXX','BUG ')
   55   CONTINUE
      ENDIF
C
C               ********************************************
C               **  COMPUTE RANK CORRELATION COEFFICIENT  **
C               ********************************************
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      AN=N
C
      IF(N.LT.1 .OR. N.GT.MAXNXT)THEN
        IERROR='YES'
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,111)
  111   FORMAT('***** ERROR IN RANK CORRELATION--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,112)
  112   FORMAT('      THE NUMBER OF OBSERVATIONS IN THE RESPONSE ',
     1         'VARIABLES')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,115)MAXNXT
  115   FORMAT('      MUST BE BETWEEN 1 AND ',I8,' (INCLUSIVELY).')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,117)N
  117   FORMAT('      THE NUMBER OF OBSERVATIONS  = ',I8)
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(N.EQ.1)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,121)
  121   FORMAT('***** WARNING IN RANK CORRELATION--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,123)
  123   FORMAT('      THE NUMBER OF OBSERVATIONS IS ONE.')
        CALL DPWRST('XXX','BUG ')
        XYRACR=1.0
        GOTO9000
      ENDIF
C
      HOLD=X(1)
      DO135I=2,N
       IF(X(I).NE.HOLD)GOTO139
  135 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,121)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,136)HOLD
  136 FORMAT('      THE FIRST RESPONSE VARIABLE HAS ALL ELEMENTS = ',
     1       G15.7)
      CALL DPWRST('XXX','BUG ')
      XYRACR=1.0
      GOTO9000
  139 CONTINUE
C
      HOLD=Y(1)
      DO145I=2,N
        IF(Y(I).NE.HOLD)GOTO149
  145 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,121)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,146)HOLD
  146 FORMAT('      THE SECOND RESPONSE VARIABLE HAS ALL ELEMENTS = ',
     1       G15.7)
      CALL DPWRST('XXX','BUG ')
      XYRACR=1.0
      GOTO9000
  149 CONTINUE
C
C               *************************************************
C               **  STEP 2--                                   **
C               **  COMPUTE THE RANK CORRELATION COEFFICIENT.  **
C               *************************************************
C
      IWRIT2='OFF'
      CALL RANK(X,N,IWRIT2,XTEMP,XTEMP2,MAXNXT,IBUGA3,IERROR)
      CALL RANK(Y,N,IWRIT2,YTEMP,XTEMP2,MAXNXT,IBUGA3,IERROR)
C
      DN=N
      DSUM1=0.0D0
      DSUM2=0.0D0
      DO200I=1,N
        DX1=XTEMP(I)
        DX2=YTEMP(I)
        DSUM1=DSUM1+DX1
        DSUM2=DSUM2+DX2
  200 CONTINUE
      DMEAN1=DSUM1/DN
      DMEAN2=DSUM2/DN
C
      DSUM1=0.0D0
      DSUM2=0.0D0
      DSUM12=0.0D0
      DO300I=1,N
        DX1=XTEMP(I)
        DX2=YTEMP(I)
        DSUM1=DSUM1+(DX1-DMEAN1)*(DX1-DMEAN1)
        DSUM2=DSUM2+(DX2-DMEAN2)*(DX2-DMEAN2)
        DSUM12=DSUM12+(DX1-DMEAN1)*(DX2-DMEAN2)
  300 CONTINUE
      DSQRT1=0.0
      IF(DSUM1.GT.0.0D0)DSQRT1=DSQRT(DSUM1)
      DSQRT2=0.0
      IF(DSUM2.GT.0.0D0)DSQRT2=DSQRT(DSUM2)
      XYRACR=DSUM12/(DSQRT1*DSQRT2)
C
C               *************************************************
C               **  STEP 2B--                                  **
C               **  NOW COMPUTE CDF, PVALUE, AND CRITICAL      **
C               **  VALUES.                                    **
C               *************************************************
C
C     USE TABLED CRITICAL VALUES FROM TABLE A10 OF CONOVER FOR N <= 30.
C     OTHERWISE, USE
C
C           W(p) = Z(p)/SQRT(N-1)
C
      AN=REAL(N)
      ANUM=1.0
      DENOM=SQRT(AN-1.0)
      AFACT=ANUM/DENOM
      ATEMP=XYRACR/AFACT
      CALL NORCDF(ATEMP,STATCD)
      PVALLT=STATCD
      PVALUT=1.0 - STATCD
      PVAL=2.0*MIN(PVALLT,PVALUT)
C
      IF(N.GT.30 .OR. IRCRTA.EQ.'NORM')THEN
        P=0.90
        CALL NORPPF(P,CUTU90)
        P=0.95
        CALL NORPPF(P,CUTU95)
        P=0.975
        CALL NORPPF(P,CTU975)
        P=0.99
        CALL NORPPF(P,CUTU99)
        P=0.995
        CALL NORPPF(P,CTU995)
        P=0.999
        CALL NORPPF(P,CTU999)
        CUTU90=AFACT*CUTU90
        CUTU95=AFACT*CUTU95
        CTU975=AFACT*CTU975
        CUTU99=AFACT*CUTU99
        CTU995=AFACT*CTU995
        CTU999=AFACT*CTU999
      ELSE
        CUTU90=WP900(N)
        CUTU95=WP950(N)
        CTU975=WP975(N)
        CUTU99=WP990(N)
        CTU995=WP995(N)
        CTU999=WP999(N)
      ENDIF
      CUTL90=-CUTU90
      CUTL95=-CUTU95
      CTL975=-CTU975
      CUTL95=-CUTU95
      CTL995=-CTU995
      CTL999=-CTU999
      IF(CUTU90.LT.-9.0)CUTU90=CPUMIN
      IF(CUTU95.LT.-9.0)CUTU95=CPUMIN
      IF(CTU975.LT.-9.0)CTU975=CPUMIN
      IF(CUTU99.LT.-9.0)CUTU99=CPUMIN
      IF(CTU995.LT.-9.0)CTU995=CPUMIN
      IF(CTU999.LT.-9.0)CTU999=CPUMIN
      IF(CUTL90.GT.9.0)CUTL90=CPUMIN
      IF(CUTL95.GT.9.0)CUTL95=CPUMIN
      IF(CTL975.GT.9.0)CTL975=CPUMIN
      IF(CUTL99.GT.9.0)CUTL99=CPUMIN
      IF(CTL995.GT.9.0)CTL995=CPUMIN
      IF(CTL999.GT.9.0)CTL999=CPUMIN
C
C               *******************************
C               **  STEP 3--                 **
C               **  WRITE OUT A LINE         **
C               **  OF SUMMARY INFORMATION.  **
C               *******************************
C
      IF(IFEEDB.EQ.'ON' .AND. IWRITE.EQ.'ON')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,811)N,XYRACR
  811   FORMAT('THE RANK CORRELATION COEFFICIENT OF THE ',I8,
     1         ' OBSERVATIONS = ',G15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'NKCR')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END       OF RANKCR--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9012)IERROR
 9012   FORMAT('IERROR = ',A4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9014)DN,DMEAN1,DMEAN2,DSUM12
 9014   FORMAT('DN,DMEAN1,DMEAN2,DSUM12 = ',4D15.7)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9015)XYRACR
 9015   FORMAT('XYRACR = ',G15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      RETURN
      END
      SUBROUTINE RANKCV(X,Y,N,IWRITE,XTEMP,YTEMP,XTEMP2,
     1MAXNXT,XYRACV,
     1IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE
C              SPEARMAN RANK COVARIANCE COEFFICIENT
C              BETWEEN THE 2 SETS OF DATA IN THE INPUT VECTORS X AND Y.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF
C                                (UNSORTED OR SORTED) OBSERVATIONS
C                                WHICH CONSTITUTE THE FIRST SET
C                                OF DATA.
C                     --Y      = THE SINGLE PRECISION VECTOR OF
C                                (UNSORTED OR SORTED) OBSERVATIONS
C                                WHICH CONSTITUTE THE SECOND SET
C                                OF DATA.
C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR X, OR EQUIVALENTLY,
C                                THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR Y.
C     OUTPUT ARGUMENTS--XYRACV = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED SPEARMAN RANK COVARIANCE
C                                COEFFICIENT BETWEEN THE 2 SETS OF DATA
C                                IN THE INPUT VECTORS X AND Y.
C                                THIS SINGLE PRECISION VALUE
C                                WILL BE BETWEEN -1.0 AND 1.0
C                                (INCLUSIVELY).
C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
C             SPEARMAN RANK COVARIANCE COEFFICIENT BETWEEN THE 2 SETS
C             OF DATA IN THE INPUT VECTORS X AND Y.
C     OTHER DATAPAC   SUBROUTINES NEEDED--RANK AND SORT.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--KENDALL AND STUART, THE ADVANCED THEORY OF
C                 STATISTICS, VOLUME 2, EDITION 1, 1961, PAGES 476-477.
C               --SNEDECOR AND COCHRAN, STATISTICAL METHODS,
C                 EDITION 6, 1967, PAGES 193-195.
C               --DIXON AND MASSEY, INTRODUCTION TO STATISTICAL
C                 ANALYSIS, EDITION 2, 1957, PAGES 294-295.
C               --MOOD AND GRABLE, 'INTRODUCTION TO THE THEORY
C                 OF STATISTICS, EDITION 2, 1963, PAGE 424.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (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         --OCTOBER   1974.
C     UPDATED         --JANUARY   1975.
C     UPDATED         --SEPTEMBER 1975.
C     UPDATED         --NOVEMBER  1975.
C     UPDATED         --FEBRUARY  1976.
C     UPDATED         --JUNE      1979.
C     UPDATED         --JULY      1979.
C     UPDATED         --JULY      1981.
C     UPDATED         --AUGUST    1981.
C     UPDATED         --MAY       1982.
C     UPDATED         --JANUARY   2007.  CALL LIST TO RANK
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 IWRIT2
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DN
      DOUBLE PRECISION DX1
      DOUBLE PRECISION DX2
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DSUM2
      DOUBLE PRECISION DSUM12
      DOUBLE PRECISION DMEAN1
      DOUBLE PRECISION DMEAN2
C
      DIMENSION X(*)
      DIMENSION Y(*)
C
      DIMENSION XTEMP(*)
      DIMENSION YTEMP(*)
      DIMENSION XTEMP2(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='RANK'
      ISUBN2='CV  '
      IERROR='NO'
C
      DN=0.0D0
      DMEAN1=0.0D0
      DMEAN2=0.0D0
      DSUM12=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 RANKCV--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)IBUGA3
   52 FORMAT('IBUGA3 = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)N
   53 FORMAT('N = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO55I=1,N
      WRITE(ICOUT,56)I,X(I),Y(I)
   56 FORMAT('I,X(I),Y(I) = ',I8,2E15.7)
      CALL DPWRST('XXX','BUG ')
   55 CONTINUE
   90 CONTINUE
C
C               ********************************************
C               **  COMPUTE RANK COVARIANCE  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.MAXNXT)GOTO119
      IERROR='YES'
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,111)
  111 FORMAT('***** ERROR IN RANKCV--')
      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 RANK COVARIANCE COEFFICIENT IS TO BE')
      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 RANKCV--',
     1'THE THIRD INPUT ARGUMENT (N) HAS THE VALUE 1')
      CALL DPWRST('XXX','BUG ')
      XYRACV=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 RANKCV--',
     1'THE 1ST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      XYRACV=0.0
      GOTO9000
  139 CONTINUE
C
      HOLD=Y(1)
      DO145I=2,N
      IF(Y(I).NE.HOLD)GOTO149
  145 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,146)HOLD
  146 FORMAT('***** NON-FATAL DIAGNOSTIC IN RANKCV--',
     1'THE 2ND INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      XYRACV=0.0
      GOTO9000
  149 CONTINUE
C
C               *************************************************
C               **  STEP 2--                                   **
C               **  COMPUTE THE RANK COVARIANCE  COEFFICIENT.  **
C               *************************************************
C
      IWRIT2=IBUGA3
      CALL RANK(X,N,IWRIT2,XTEMP,XTEMP2,MAXNXT,IBUGA3,IERROR)
      CALL RANK(Y,N,IWRIT2,YTEMP,XTEMP2,MAXNXT,IBUGA3,IERROR)
C
      DN=N
      DSUM1=0.0D0
      DSUM2=0.0D0
      DO200I=1,N
      DX1=XTEMP(I)
      DX2=YTEMP(I)
      DSUM1=DSUM1+DX1
      DSUM2=DSUM2+DX2
  200 CONTINUE
      DMEAN1=DSUM1/DN
      DMEAN2=DSUM2/DN
C
      DSUM12=0.0D0
      DO300I=1,N
      DX1=XTEMP(I)
      DX2=YTEMP(I)
      DSUM12=DSUM12+(DX1-DMEAN1)*(DX2-DMEAN2)
  300 CONTINUE
      XYRACV=DSUM12/DN
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,XYRACV
  811 FORMAT('THE RANK COVARIANCE COEFFICIENT OF THE ',I8,
     1' OBSERVATIONS = ',E15.7)
      CALL DPWRST('XXX','BUG ')
  890 CONTINUE
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'OFF')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF RANKCV--')
      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,DMEAN1,DMEAN2,DSUM12
 9014 FORMAT('DN,DMEAN1,DMEAN2,DSUM12 = ',4D15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9015)XYRACV
 9015 FORMAT('XYRACV = ',E15.7)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE RANKSB(K,N,ISEED,X,ITEMP1)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM K-SUBSET OF
C              AN N-SET.
C     INPUT  ARGUMENTS--K      = THE INTEGER NUMBER DENOTING THE
C                                SIZE OF THE SUBSET.
C                     --N      = THE INTEGER NUMBER DENOTING THE
C                                SIZE OF THE N-SET.
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST K)
C                                INTO WHICH THE GENERATED
C                                RANDOM K-SUBSET OF THE N-SET WILL BE
C                                PLACED.
C     OUTPUT--A RANDOM K-SUBSET OF AN N-SET.
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.   HOWEVER, K <= N.
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     REFERENCE: NIJENHUIS, ALBERT AND WILF, HERBERT S., 'COMBINATORIAL
C                ALGORITHMS', ACADEMIC PRESS, 1975, CH. x, p. 43.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2008/5
C     ORIGINAL VERSION--MAY       2008.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
      INTEGER   ITEMP1(*)
C
      INTEGER IX
      INTEGER R
      INTEGER DS
      INTEGER P
      INTEGER S
      INTEGER C
C
      DIMENSION U(1)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(K.LT.1)THEN
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)K
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(K.GT.N)THEN
        WRITE(ICOUT,15)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)K
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,48)N
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
    5 FORMAT('***** ERROR--FOR THE RANDOM K-SET OF THE N-SET, ',
     1       'K IS NON-POSITIVE.')
   15 FORMAT('***** ERROR--FOR THE RANDOM K-SET OF THE N-SET, ',
     1       'K IS LARGER THAN N.')
   47 FORMAT('***** THE VALUE OF K IS ',I8)
   48 FORMAT('***** THE VALUE OF N IS ',I8)
C
C     GENERATE A RANDOM SUBSET OF N ELEMENTS
C
      I=0
      R=0
      NTEMP=1
      M0=0
      M=0
C
      C=K
      DO 100 I=1,K
        ITEMP1(I)=(I-1)*N/K
  100 CONTINUE
C
  110 CONTINUE
      CALL UNIRAN(NTEMP,ISEED,U)
      IX=1 + INT(REAL(N)*U(1))
      L=1 + (IX*K-1)/N
      IF(IX.LE.ITEMP1(L))GOTO 110
      ITEMP1(L)=ITEMP1(L)+1
      C=C-1
      IF(C.NE.0)GOTO 110
      P=0
      S=K
C
      DO 200 I=1,K
        M=ITEMP1(I)
        ITEMP1(I)=0
        IF(M.EQ.(I-1)*N/K) GOTO 200
        P=P+1
        ITEMP1(P)=M
  200 CONTINUE
C
  300 CONTINUE
      L=1 + (ITEMP1(P)*K-1)/N
      DS=ITEMP1(P) - (L-1)*N/K
      ITEMP1(P)=0
      ITEMP1(S)=L
      S=S-DS
      P=P-1
      IF(P.gt.0)GOTO 300
      L=K
C
  400 CONTINUE
      IF(ITEMP1(L).EQ.0)GOTO 500
      R=L
      M0=1 + (ITEMP1(L)-1)*N/K
      M=ITEMP1(L)*N/K - M0 + 1
C
  500 CONTINUE
      CALL UNIRAN(NTEMP,ISEED,U)
      IX=M0 + INT(REAL(M)*U(1))
      I=L
C
  600 CONTINUE
      I=I+1
      IF(I.LE.R)GOTO 800
C
  700 CONTINUE
      ITEMP1(I-1)=IX
      M=M-1
      L=L-1
      IF(L.EQ.0)THEN
        DO900I=1,K
          X(I)=REAL(ITEMP1(I))
  900   CONTINUE
        GOTO9000
      ENDIF
      GOTO 400
C
  800 CONTINUE
      IF(IX.LT.ITEMP1(I)) GOTO 700
      IX=IX+1
      ITEMP1(I-1)=ITEMP1(I)
      GOTO 600
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE RANLUX(RVEC,LENV)
C         Subtract-and-borrow random number generator proposed by
C         Marsaglia and Zaman, implemented by F. James with the name
C         RCARRY in 1991, and later improved by Martin Luescher
C         in 1993 to produce "Luxury Pseudorandom Numbers".
C     Fortran 77 coded by F. James, 1993
C
C       references:
C  M. Luscher, Computer Physics Communications  79 (1994) 100
C  F. James, Computer Physics Communications 79 (1994) 111
C
C   LUXURY LEVELS.
C   ------ ------      The available luxury levels are:
C
C  level 0  (p=24): equivalent to the original RCARRY of Marsaglia
C           and Zaman, very long period, but fails many tests.
C  level 1  (p=48): considerable improvement in quality over level 0,
C           now passes the gap test, but still fails spectral test.
C  level 2  (p=97): passes all known tests, but theoretically still
C           defective.
C  level 3  (p=223): DEFAULT VALUE.  Any theoretically possible
C           correlations have very small chance of being observed.
C  level 4  (p=389): highest possible luxury, all 24 bits chaotic.
C
C!!! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C!!!  Calling sequences for RANLUX:                                  ++
C!!!      CALL RANLUX (RVEC, LEN)   returns a vector RVEC of LEN     ++
C!!!                   32-bit random floating point numbers between  ++
C!!!                   zero (not included) and one (also not incl.). ++
C!!!      CALL RLUXGO(LUX,INT,K1,K2) initializes the generator from  ++
C!!!               one 32-bit integer INT and sets Luxury Level LUX  ++
C!!!               which is integer between zero and MAXLEV, or if   ++
C!!!               LUX .GT. 24, it sets p=LUX directly.  K1 and K2   ++
C!!!               should be set to zero unless restarting at a break++
C!!!               point given by output of RLUXAT (see RLUXAT).     ++
C!!!      CALL RLUXAT(LUX,INT,K1,K2) gets the values of four integers++
C!!!               which can be used to restart the RANLUX generator ++
C!!!               at the current point by calling RLUXGO.  K1 and K2++
C!!!               specify how many numbers were generated since the ++
C!!!               initialization with LUX and INT.  The restarting  ++
C!!!               skips over  K1+K2*E9   numbers, so it can be long.++
C!!!   A more efficient but less convenient way of restarting is by: ++
C!!!      CALL RLUXIN(ISVEC)    restarts the generator from vector   ++
C!!!                   ISVEC of 25 32-bit integers (see RLUXUT)      ++
C!!!      CALL RLUXUT(ISVEC)    outputs the current values of the 25 ++
C!!!                 32-bit integer seeds, to be used for restarting ++
C!!!      ISVEC must be dimensioned 25 in the calling program        ++
C!!! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C  MAY 2003: MODIFIED SLIGHTLY FOR INCORPORATION INTO DATAPLOT.
C            MOSTLY JUST THE I/O.
C
      DIMENSION RVEC(LENV)
      DIMENSION SEEDS(24), ISEEDS(24), ISDEXT(25)
      PARAMETER (MAXLEV=4, LXDFLT=3)
      DIMENSION NDSKIP(0:MAXLEV)
      DIMENSION NEXT(24)
      PARAMETER (TWOP12=4096., IGIGA=1000000000,JSDFLT=314159265)
      PARAMETER (ITWO24=2**24, ICONS=2147483563)
      SAVE NOTYET, I24, J24, CARRY, SEEDS, TWOM24, TWOM12, LUXLEV
      SAVE NSKIP, NDSKIP, IN24, NEXT, KOUNT, MKOUNT, INSEED
      INTEGER LUXLEV
      LOGICAL NOTYET
C
      INCLUDE 'DPCOP2.INC'
C
      DATA NOTYET, LUXLEV, IN24, KOUNT, MKOUNT /.TRUE., LXDFLT, 0,0,0/
      DATA I24,J24,CARRY/24,10,0./
C                               default
C  Luxury Level   0     1     2   *3*    4
      DATA NDSKIP/0,   24,   73,  199,  365 /
Corresponds to p=24    48    97   223   389
C     time factor 1     2     3     6    10   on slow workstation
C                 1    1.5    2     3     5   on fast mainframe
C
C  NOTYET is .TRUE. if no initialization has been performed yet.
C              Default Initialization by Multiplicative Congruential
      IF (NOTYET) THEN
         NOTYET = .FALSE.
         JSEED = JSDFLT
         INSEED = JSEED
CCCCC    WRITE(6,'(A,I12)') ' RANLUX DEFAULT INITIALIZATION: ',JSEED
         LUXLEV = LXDFLT
         NSKIP = NDSKIP(LUXLEV)
         LP = NSKIP + 24
         IN24 = 0
         KOUNT = 0
         MKOUNT = 0
CCCCC    WRITE(6,'(A,I2,A,I4)')  ' RANLUX DEFAULT LUXURY LEVEL =  ',
CCCCC+        LUXLEV,'      p =',LP
            TWOM24 = 1.
         DO 25 I= 1, 24
            TWOM24 = TWOM24 * 0.5
         K = JSEED/53668
         JSEED = 40014*(JSEED-K*53668) -K*12211
         IF (JSEED .LT. 0)  JSEED = JSEED+ICONS
         ISEEDS(I) = MOD(JSEED,ITWO24)
   25    CONTINUE
         TWOM12 = TWOM24 * 4096.
         DO 50 I= 1,24
         SEEDS(I) = REAL(ISEEDS(I))*TWOM24
         NEXT(I) = I-1
   50    CONTINUE
         NEXT(1) = 24
         I24 = 24
         J24 = 10
         CARRY = 0.
         IF (SEEDS(24) .EQ. 0.) CARRY = TWOM24
      ENDIF
C
C          The Generator proper: "Subtract-with-borrow",
C          as proposed by Marsaglia and Zaman,
C          Florida State University, March, 1989
C
      DO 100 IVEC= 1, LENV
      UNI = SEEDS(J24) - SEEDS(I24) - CARRY
      IF (UNI .LT. 0.)  THEN
         UNI = UNI + 1.0
         CARRY = TWOM24
      ELSE
         CARRY = 0.
      ENDIF
      SEEDS(I24) = UNI
      I24 = NEXT(I24)
      J24 = NEXT(J24)
      RVEC(IVEC) = UNI
C  small numbers (with less than 12 "significant" bits) are "padded".
      IF (UNI .LT. TWOM12)  THEN
         RVEC(IVEC) = RVEC(IVEC) + TWOM24*SEEDS(J24)
C        and zero is forbidden in case someone takes a logarithm
         IF (RVEC(IVEC) .EQ. 0.)  RVEC(IVEC) = TWOM24*TWOM24
      ENDIF
C        Skipping to luxury.  As proposed by Martin Luscher.
      IN24 = IN24 + 1
      IF (IN24 .EQ. 24)  THEN
         IN24 = 0
         KOUNT = KOUNT + NSKIP
         DO 90 ISK= 1, NSKIP
         UNI = SEEDS(J24) - SEEDS(I24) - CARRY
         IF (UNI .LT. 0.)  THEN
            UNI = UNI + 1.0
            CARRY = TWOM24
         ELSE
            CARRY = 0.
         ENDIF
         SEEDS(I24) = UNI
         I24 = NEXT(I24)
         J24 = NEXT(J24)
   90    CONTINUE
      ENDIF
  100 CONTINUE
      KOUNT = KOUNT + LENV
      IF (KOUNT .GE. IGIGA)  THEN
         MKOUNT = MKOUNT + 1
         KOUNT = KOUNT - IGIGA
      ENDIF
      RETURN
C
C           Entry to input and float integer seeds from previous run
      ENTRY RLUXIN(ISDEXT)
         TWOM24 = 1.
         DO 195 I= 1, 24
           NEXT(I) = I-1
           TWOM24 = TWOM24 * 0.5
  195    CONTINUE
         NEXT(1) = 24
         TWOM12 = TWOM24 * 4096.
CCCCC WRITE(6,'(A)') ' FULL INITIALIZATION OF RANLUX WITH 25 INTEGERS:'
CCCCC WRITE(6,'(5X,5I12)') ISDEXT
      DO 200 I= 1, 24
        SEEDS(I) = REAL(ISDEXT(I))*TWOM24
  200 CONTINUE
      CARRY = 0.
      IF (ISDEXT(25) .LT. 0)  CARRY = TWOM24
      ISD = IABS(ISDEXT(25))
      I24 = MOD(ISD,100)
      ISD = ISD/100
      J24 = MOD(ISD,100)
      ISD = ISD/100
      IN24 = MOD(ISD,100)
      ISD = ISD/100
      LUXLEV = ISD
        IF (LUXLEV .LE. MAXLEV) THEN
          NSKIP = NDSKIP(LUXLEV)
CCCCC     WRITE (6,'(A,I2)') ' RANLUX LUXURY LEVEL SET BY RLUXIN TO: ',
CCCCC+                         LUXLEV
        ELSE  IF (LUXLEV .GE. 24) THEN
          NSKIP = LUXLEV - 24
CCCCC     WRITE (6,'(A,I5)') ' RANLUX P-VALUE SET BY RLUXIN TO:',LUXLEV
        ELSE
          NSKIP = NDSKIP(MAXLEV)
          WRITE(ICOUT,999)
  999     FORMAT(1X)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,201)
  201     FORMAT('***** ERROR FROM LUXURY RANDOM NUMBER GENERATOR--')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,202)LUXLEV
  202     FORMAT('      ILLEGAL LUXURY LEVEL: ',I5)
          CALL DPWRST('XXX','BUG ')
CCCCC     WRITE (6,'(A,I5)') ' RANLUX ILLEGAL LUXURY RLUXIN: ',LUXLEV
          LUXLEV = MAXLEV
        ENDIF
      INSEED = -1
      RETURN
C
C                    Entry to ouput seeds as integers
      ENTRY RLUXUT(ISDEXT)
      DO 300 I= 1, 24
         ISDEXT(I) = INT(SEEDS(I)*TWOP12*TWOP12)
  300 CONTINUE
      ISDEXT(25) = I24 + 100*J24 + 10000*IN24 + 1000000*LUXLEV
      IF (CARRY .GT. 0.)  ISDEXT(25) = -ISDEXT(25)
      RETURN
C
C                    Entry to output the "convenient" restart point
      ENTRY RLUXAT(LOUT,INOUT,K1,K2)
      LOUT = LUXLEV
      INOUT = INSEED
      K1 = KOUNT
      K2 = MKOUNT
      RETURN
C
C                    Entry to initialize from one or three integers
      ENTRY RLUXGO(LUX,INS,K1,K2)
         IF (LUX .LT. 0) THEN
            LUXLEV = LXDFLT
         ELSE IF (LUX .LE. MAXLEV) THEN
            LUXLEV = LUX
         ELSE IF (LUX .LT. 24 .OR. LUX .GT. 2000) THEN
            LUXLEV = MAXLEV
CCCCC       WRITE (6,'(A,I7)') ' RANLUX ILLEGAL LUXURY RLUXGO: ',LUX
            WRITE(ICOUT,999)
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,301)
  301       FORMAT('***** ERROR FROM LUXURY RANDOM NUMBER GENERATOR--')
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,302)LUX
  302       FORMAT('      ILLEGAL LUXURY LEVEL: ',I7)
            CALL DPWRST('XXX','BUG ')
         ELSE
            LUXLEV = LUX
            DO 310 ILX= 0, MAXLEV
              IF (LUX .EQ. NDSKIP(ILX)+24)  LUXLEV = ILX
  310       CONTINUE
         ENDIF
      IF (LUXLEV .LE. MAXLEV)  THEN
         NSKIP = NDSKIP(LUXLEV)
CCCCC    WRITE(6,'(A,I2,A,I4)') ' RANLUX LUXURY LEVEL SET BY RLUXGO :',
CCCCC+        LUXLEV,'     P=', NSKIP+24
      ELSE
          NSKIP = LUXLEV - 24
CCCCC     WRITE (6,'(A,I5)') ' RANLUX P-VALUE SET BY RLUXGO TO:',LUXLEV
      ENDIF
      IN24 = 0
      IF (INS .LT. 0) THEN
CCCCC    WRITE (6,'(A)')
CCCCC+   ' Illegal initialization by RLUXGO, negative input seed'
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,401)
  401     FORMAT('***** ERROR FROM LUXURY RANDOM NUMBER GENERATOR--')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,402)
  402     FORMAT('      NEGATIVE INPUT SEED: ')
          CALL DPWRST('XXX','BUG ')
      ENDIF
      IF (INS .GT. 0)  THEN
        JSEED = INS
CCCCC   WRITE(6,'(A,3I12)') ' RANLUX INITIALIZED BY RLUXGO FROM SEEDS',
CCCCC+      JSEED, K1,K2
      ELSE
        JSEED = JSDFLT
CCCCC   WRITE(6,'(A)')' RANLUX INITIALIZED BY RLUXGO FROM DEFAULT SEED'
      ENDIF
      INSEED = JSEED
      NOTYET = .FALSE.
      TWOM24 = 1.
         DO 325 I= 1, 24
           TWOM24 = TWOM24 * 0.5
         K = JSEED/53668
         JSEED = 40014*(JSEED-K*53668) -K*12211
         IF (JSEED .LT. 0)  JSEED = JSEED+ICONS
         ISEEDS(I) = MOD(JSEED,ITWO24)
  325    CONTINUE
      TWOM12 = TWOM24 * 4096.
         DO 350 I= 1,24
         SEEDS(I) = REAL(ISEEDS(I))*TWOM24
         NEXT(I) = I-1
  350    CONTINUE
      NEXT(1) = 24
      I24 = 24
      J24 = 10
      CARRY = 0.
      IF (SEEDS(24) .EQ. 0.) CARRY = TWOM24
C        If restarting at a break point, skip K1 + IGIGA*K2
C        Note that this is the number of numbers delivered to
C        the user PLUS the number skipped (if luxury .GT. 0).
      KOUNT = K1
      MKOUNT = K2
      IF (K1+K2 .NE. 0)  THEN
        DO 500 IOUTER= 1, K2+1
          INNER = IGIGA
          IF (IOUTER .EQ. K2+1)  INNER = K1
          DO 450 ISK= 1, INNER
            UNI = SEEDS(J24) - SEEDS(I24) - CARRY
            IF (UNI .LT. 0.)  THEN
               UNI = UNI + 1.0
               CARRY = TWOM24
            ELSE
               CARRY = 0.
            ENDIF
            SEEDS(I24) = UNI
            I24 = NEXT(I24)
            J24 = NEXT(J24)
  450     CONTINUE
  500   CONTINUE
C         Get the right value of IN24 by direct calculation
        IN24 = MOD(KOUNT, NSKIP+24)
        IF (MKOUNT .GT. 0)  THEN
           IZIP = MOD(IGIGA, NSKIP+24)
           IZIP2 = MKOUNT*IZIP + IN24
           IN24 = MOD(IZIP2, NSKIP+24)
        ENDIF
C       Now IN24 had better be between zero and 23 inclusive
        IF (IN24 .GT. 23) THEN
CCCCC      WRITE (6,'(A/A,3I11,A,I5)')
CCCCC+    '  Error in RESTARTING with RLUXGO:','  The values', INS,
CCCCC+     K1, K2, ' cannot occur at luxury level', LUXLEV
           IN24 = 0
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,501)
  501     FORMAT('***** ERROR FROM LUXURY RANDOM NUMBER GENERATOR--')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,502)
  502     FORMAT('      ERROR IN RESTARTING WITH RLUXG0:')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,503)INS,K1,K2
  503     FORMAT('      THE VALUES ',3I11)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,504)LUXLEV
  504     FORMAT('      CANNOT OCCUR AT LUXURY LEVEL ',I5)
          CALL DPWRST('XXX','BUG ')
        ENDIF
      ENDIF
C
      RETURN
      END
      SUBROUTINE RANMVN( N, LOWER, UPPER, INFIN, CORREL, MAXPTS,
     &                   ABSEPS, RELEPS, ERROR, VALUE, INFORM )
*
*     A subroutine for computing multivariate normal probabilities.
*     This subroutine uses the Monte-Carlo algorithm given in the paper
*     "Numerical Computation of Multivariate Normal Probabilities", in
*     J. of Computational and Graphical Stat., 1(1992), pp. 141-149, by
*          Alan Genz
*          Department of Mathematics
*          Washington State University
*          Pullman, WA 99164-3113
*          Email : alangenz@wsu.edu
*
*  Parameters
*
*     N      INTEGER, the number of variables.
*     LOWER  REAL, array of lower integration limits.
*     UPPER  REAL, array of upper integration limits.
*     INFIN  INTEGER, array of integration limits flags:
*            if INFIN(I) < 0, Ith limits are (-infinity, infinity);
*            if INFIN(I) = 0, Ith limits are (-infinity, UPPER(I)];
*            if INFIN(I) = 1, Ith limits are [LOWER(I), infinity);
*            if INFIN(I) = 2, Ith limits are [LOWER(I), UPPER(I)].
*     CORREL REAL, array of correlation coefficients; the correlation
*            coefficient in row I column J of the correlation matrix
*            should be stored in CORREL( J + ((I-2)*(I-1))/2 ), for J < I.
*     MAXPTS INTEGER, maximum number of function values allowed. This
*            parameter can be used to limit the time taken. A
*            sensible strategy is to start with MAXPTS = 1000*N, and then
*            increase MAXPTS if ERROR is too large.
*     ABSEPS REAL absolute error tolerance.
*     RELEPS REAL relative error tolerance.
*     ERROR  REAL estimated absolute error, with 99% confidence level.
*     VALUE  REAL estimated value for the integral
*     INFORM INTEGER, termination status parameter:
*            if INFORM = 0, normal completion with ERROR < EPS;
*            if INFORM = 1, completion with ERROR > EPS and MAXPTS
*                           function vaules used; increase MAXPTS to
*                           decrease ERROR;
*            if INFORM = 2, N > 100 or N < 1.
*
      EXTERNAL MVNFNC
      INTEGER N, INFIN(*), MAXPTS, MPT, INFORM, INFIS, IVLS
      DOUBLE PRECISION
     &     CORREL(*), LOWER(*), UPPER(*), MVNFNC,
     &     ABSEPS, RELEPS, ERROR, VALUE, D, E, EPS, MVNNIT
      IF ( N .GT. 100 .OR. N .LT. 1 ) THEN
         INFORM = 2
         VALUE = 0
         ERROR = 1
         RETURN
      ENDIF
      INFORM = INT(MVNNIT(N,CORREL,LOWER,UPPER,INFIN,INFIS,D,E))
      IF ( N-INFIS .EQ. 0 ) THEN
         VALUE = 1
         ERROR = 0
      ELSE IF ( N-INFIS .EQ. 1 ) THEN
         VALUE = E - D
         ERROR = 2E-16
      ELSE
*
*        Call then Monte-Carlo integration subroutine
*
         MPT = 25 + 10*N
         CALL RCRUDE(N-INFIS-1, MPT, MVNFNC, ERROR, VALUE, 0)
         IVLS = MPT
 10      EPS = MAX( ABSEPS, RELEPS*ABS(VALUE) )
         IF ( ERROR .GT. EPS .AND. IVLS .LT. MAXPTS ) THEN
            MPT = MAX( MIN( INT(MPT*(ERROR/(EPS))**2),
     &                      MAXPTS-IVLS ), 10 )
            CALL RCRUDE(N-INFIS-1, MPT, MVNFNC, ERROR, VALUE, 1)
            IVLS = IVLS + MPT
            GO TO 10
         ENDIF
         IF ( ERROR. GT. EPS .AND. IVLS .GE. MAXPTS ) INFORM = 1
      ENDIF
C
      RETURN
      END
      SUBROUTINE RANMVT(N, NU, LOWER, UPPER, INFIN, CORREL, MAXPTS,
     *      ABSEPS, RELEPS, ERROR, VALUE, INFORM)
*
*     A subroutine for computing multivariate t probabilities.
*          Alan Genz
*          Department of Mathematics
*          Washington State University
*          Pullman, WA 99164-3113
*          Email : AlanGenz@wsu.edu
*
*  Parameters
*
*     N      INTEGER, the number of variables.
*     NU     INTEGER, the number of degrees of freedom.
*     LOWER  REAL, array of lower integration limits.
*     UPPER  REAL, array of upper integration limits.
*     INFIN  INTEGER, array of integration limits flags:
*            if INFIN(I) < 0, Ith limits are (-infinity, infinity);
*            if INFIN(I) = 0, Ith limits are (-infinity, UPPER(I)];
*            if INFIN(I) = 1, Ith limits are [LOWER(I), infinity);
*            if INFIN(I) = 2, Ith limits are [LOWER(I), UPPER(I)].
*     CORREL REAL, array of correlation coefficients; the correlation
*            coefficient in row I column J of the correlation matrix
*            should be stored in CORREL( J + ((I-2)*(I-1))/2 ), for J < I.
*     MAXPTS INTEGER, maximum number of function values allowed. This
*            parameter can be used to limit the time taken. A sensible
*            strategy is to start with MAXPTS = 1000*N, and then
*            increase MAXPTS if ERROR is too large.
*     ABSEPS REAL absolute error tolerance.
*     RELEPS REAL relative error tolerance.
*     ERROR  REAL, estimated absolute error, with 99% confidence level.
*     VALUE  REAL, estimated value for the integral
*     INFORM INTEGER, termination status parameter:
*            if INFORM = 0, normal completion with ERROR < EPS;
*            if INFORM = 1, completion with ERROR > EPS and MAXPTS
*                           function vaules used; increase MAXPTS to
*                           decrease ERROR;
*            if INFORM = 2, N > 20 or N < 1.
*
      DOUBLE PRECISION FNCMVT
      EXTERNAL FNCMVT
      INTEGER N, NU, INFIN(*), MAXPTS, INFORM, INFIS, MPT, IVLS
      DOUBLE PRECISION CORREL(*), LOWER(*), UPPER(*),
     *     ABSEPS, RELEPS, EPS, ERROR, VALUE, E, D, MVTNIT
      IF ( N .GT. 20 .OR. N .LT. 1 ) THEN
         INFORM = 2
         VALUE = 0
         ERROR = 1
         RETURN
      ENDIF
      INFORM = INT(MVTNIT(N,NU,CORREL,LOWER,UPPER,INFIN,INFIS,D,E))
      IF ( N-INFIS .EQ. 0 ) THEN
         VALUE = 1
         ERROR = 0.0D0
      ELSE IF ( N-INFIS .EQ. 1 ) THEN
         VALUE = E - D
         ERROR = 2E-16
      ELSE
*
*        Call the Monte-Carlo integration subroutine
*
         MPT = 25 + 10*N*N
         CALL RCRUDE(N-INFIS-1, MPT, FNCMVT, ERROR, VALUE, 0)
         IVLS = MPT
 10      EPS = MAX( ABSEPS, RELEPS*ABS(VALUE) )
         IF ( ERROR .GT. EPS .AND. IVLS .LT. MAXPTS ) THEN
            MPT = MAX(MIN( INT(MPT*(ERROR/(EPS))**2), MAXPTS-IVLS ), 10)
            CALL RCRUDE(N-INFIS-1, MPT, FNCMVT, ERROR, VALUE, 1)
            IVLS = IVLS + MPT
            GO TO 10
         ENDIF
         IF ( ERROR. GT. EPS .AND. IVLS .GE. MAXPTS ) INFORM = 1
      ENDIF
C
      RETURN
      END
      SUBROUTINE RANPAR(K,N,ISEED,X,MULT,P)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM PARTITION
C              OF THE INTEGER N INTO K NON-NEGATIVE INTEGERS.
C     INPUT  ARGUMENTS--K      = THE INTEGER NUMBER DENOTING THE
C                                NUMBER OF ELEMENTS IN THE
C                                COMPOSITION
C                     --N      = THE INTEGER NUMBER BEING COMPOSED.
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST K)
C                                INTO WHICH THE GENERATED
C                                RANDOM PARTITION IS PLACED.
C     OUTPUT--A RANDOM PARTITION OF THE INTEGER N INTO K ELEMENTS.
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.   HOWEVER, K <= N.
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     REFERENCE: NIJENHUIS, ALBERT AND WILF, HERBERT S., 'COMBINATORIAL
C                ALGORITHMS', ACADEMIC PRESS, 1975, P. 75.
C
C                THE CODE BELOW IMPLEMENTS THE NIJENHUIS, ALBERT,
C                AND WILF ROUTINE.
C
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2008/5
C     ORIGINAL VERSION--MAY       2008.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      REAL X(*)
      REAL U(1)
      INTEGER MULT(*)
      INTEGER P(*)
C
      INTEGER D
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)THEN
        WRITE(ICOUT,15)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,48)N
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
   15 FORMAT('***** ERROR--FOR THE RANDOM PARTITION OF N, THE ',
     1       'VALUE OF N IS NON-POSITIVE.')
   48 FORMAT('***** THE VALUE OF N IS ',I8)
C
C     GENERATE A RANDOM PARTITION OF N INTO K ELEMENTS
C
      NTEMP=1
C
      P(1)=1
      M=1
      IF(N.EQ.1)GOTO30
C
C     STEP 1: COMPUTE THE NUMBER OF PARTITIONS FOR I FOR
C             I = 1 TO N.
C
      DO21I=M,N
        ISUM=0
        DO22D=1,I
          IS=0
          I1=I
   24     CONTINUE
          I1=I1-D
          IF(I1.EQ.0)THEN
            IS=IS+1
          ELSEIF(I1.GT.0)THEN
            IS=IS+P(I1)
            GOTO24
          ENDIF
          ISUM=ISUM + IS*D
   22   CONTINUE
        P(I)=ISUM/I
   21 CONTINUE
C
C     STEP 2: NOW COMPUTE THE RANDOM PARTITION
C
   30 CONTINUE
      M=N
      K=0
      DO31I=1,N
        MULT(I)=0
   31 CONTINUE
C
   40 CONTINUE
      CALL UNIRAN(NTEMP,ISEED,U)
      Z=U(1)*REAL(M*P(M))
      D=0
  110 CONTINUE
      D=D+1
      I1=M
      J=0
  150 CONTINUE
      J=J+1
      I1=I1-D
      IF(I1.LT.0)THEN
        GOTO110
      ELSEIF(I1.EQ.0)THEN
        Z=Z-REAL(D)
        IF(Z.LE.0.0)GOTO145
        GOTO110
      ELSEIF(I1.GT.0)THEN
        Z=Z-REAL(D*P(I1))
        IF(Z.LE.0.0)GOTO145
        GOTO150
      ENDIF
C
  145 CONTINUE
      MULT(D)=MULT(D)+J
      K=K+J
      M=I1
      IF(M.NE.0)GOTO40
C
      ICNT=0
      DO200I=1,N
        IF(MULT(I).GT.0)THEN
          DO210J=1,MULT(I)
            ICNT=ICNT+1
            X(ICNT)=REAL(I)
  210     CONTINUE
        ENDIF
  200 CONTINUE
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE RANPER(N,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM PERMUTATION OF SIZE N
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF ITEMS IN THE PERMUTATION.
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST N)
C                                INTO WHICH THE GENERATED
C                                RANDOM PERMUTATION WILL BE PLACED.
C     OUTPUT--A RANDOM PERMUTATION OF SIZE N
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     NOTE--THE BASIC ALGORITHM WAS ORIGINALLY SUGGESTED
C           BY DAN LOZIER OF THE NAT. BUR. OF STANDARDS.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--89/1
C     ORIGINAL VERSION--DECEMBER  1988.
C     UPDATED         --DECEMBER  1989.  OUTER LOOP+ FOR MORE RANDOMNESS
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
C
CCCCC THE FOLLOWING DIMENSION WAS CHANGED DECEMBER 1989
CCCCC DIMENSION U(2)
      DIMENSION U(10)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      AN=N
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)GOTO50
      GOTO90
   50 WRITE(ICOUT, 5)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,47)N
      CALL DPWRST('XXX','BUG ')
      RETURN
   90 CONTINUE
    5 FORMAT('***** ERROR--THE FIRST ARGUMENT TO ',
     1       'RANPER IS NON-POSITIVE.')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,'.')
C
C     GENERATE A RANDOM PERMUTATION OF THE INTEGERS 1 TO N
C
C     START OFF WITH A RANDOM CYCLIC PERMUTATION
C
      CALL UNIRAN(10,ISEED,U)
      IFUDGE=INT(AN*U(10))
      IFUDGE=IFUDGE+1
      IF(IFUDGE.LE.1)IFUDGE=1
      IF(IFUDGE.GE.N)IFUDGE=N
      DO1100I=1,N
        IP=I+IFUDGE
        IF(IP.LE.N)X(I)=REAL(IP)
        IF(IP.GT.N)X(I)=REAL(IP-N)
 1100 CONTINUE
C
CCCCC THE FOLLOWING RANDOM NUMBER OF LOOPS WAS ADDED DECEMBER 1989
CCCCC BECAUSE OF 9 STRINGS OF 1,2 AND OTHER
CCCCC CORRELATED PATTERNS THAT DID NOT LOOK "RANDOM ENOUGH"
C
      NREP=2
      AREP=NREP
      CALL UNIRAN(NREP,ISEED,U)
      NLOOP=INT(AREP*U(NREP))
      NLOOP=NLOOP+1
      IF(NLOOP.LE.1)NLOOP=1
      IF(NLOOP.GE.NREP)NLOOP=NREP
C
CCCCC THE FOLLOWING "TRASHING" OF RANDOM NUMBERS WAS ADDED DECEMBER 1989
CCCCC BECAUSE OF 9 STRINGS OF 1,2 AND OTHER
CCCCC CORRELATED PATTERNS THAT DID NOT LOOK "RANDOM ENOUGH"
C
      DO1150ILOOP=1,NLOOP
      CALL UNIRAN(10,ISEED,U)
 1150 CONTINUE
C
CCCCC THE FOLLOWING OUTER LOOP WAS ADDED DECEMBER 1989
CCCCC BECAUSE OF 9 STRINGS OF 1,2 AND OTHER
CCCCC CORRELATED PATTERNS THAT DID NOT LOOK "RANDOM ENOUGH"
C
      DO1200ILOOP=1,NLOOP
      DO1300I=1,N
CCCCC THE FOLLOWING CALL WAS CHANGED DECEMBER 1989
CCCCC CALL UNIRAN(1,ISEED,U)
      CALL UNIRAN(NREP,ISEED,U)
CCCCC THE FOLLOWING LINE WAS CHANGED DECEMBER 1989
CCCCC U1=U(1)
      U1=U(ILOOP)
      PROD=AN*U1
      IPROD=INT(PROD)
      INDEX=IPROD+1
      IF(INDEX.LT.1)INDEX=1
      IF(INDEX.GT.N)INDEX=N
      HOLD1=X(I)
      HOLD2=X(INDEX)
      X(I)=HOLD2
      X(INDEX)=HOLD1
CCCCC WRITE(6,777)ISEED,U1
CC777 FORMAT('ISEED,U1 = ',I8,F10.4)
 1300 CONTINUE
 1200 CONTINUE
C
      CALL UNIRAN(5,ISEED,U)
      IFUDGE=INT(AN*U(5))
      IFUDGE=IFUDGE+1
      IF(IFUDGE.LE.1)IFUDGE=1
      IF(IFUDGE.GE.N)IFUDGE=N
      DO1400I=1,N
        IXI=INT(X(I)+0.5)
        IXIP=IXI+IFUDGE
        IF(IXIP.LE.N)X(I)=REAL(IXIP)
        IF(IXIP.GT.N)X(I)=REAL(IXIP-N)
 1400 CONTINUE
C
      RETURN
      END
      SUBROUTINE RANPE2(N,NKEEP,PVAL,NITER,IDIST,MAXNXT,ISEED,
     1                  Y,TAG,X,NOUT,
     1                  ISUBRO,IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE GENERATES RANDOM PERMUTATIONs OF SIZE N
C              IN A SIMULATION CONTEXT.  SPECIFICALLY,
C
C              1) ONLY THE FIRST NKEEP (1 <= NKEEP <= N) VALUES ARE
C                 KEPT.
C
C              2) THERE IS A PROBABILITY OF SUCCESS DEFINED BY PVAL
C                 (0 < PVAL <= 1).  THE N POSSIBLE VALUES ARE DIVIDED
C                 INTO TWO GROUPS BASED ON PVAL. FOR EXAMPLE, IF N = 10
C                 AND PVAL = 0.5, THEN RANDOM PERMUTATION VALUES 1 TO 5
C                 WILL BE KEPT WHILE RANDOM PERMUTATION VALUES 6 TO 10
C                 WILL NOT BE KEPT.  IF ALL VALUES ARE TO BE KEPT, THEN
C                 SET PVAL TO 1.
C
C              3) THE PERMUTATIONS WILL BE GENERATED NITER TIMES.
C
C              4) IF IDIST = 1 THEN ONLY DISTINCT VALUES FOR THE RANDOM
C                 PERMUTATION WILL BE KEPT.  IF IDIST = 0, THEN NO CHECK
C                 FOR DISTINCT VALUES WILL BE MADE.
C
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER OF ITEMS IN
C                                THE PERMUTATION.
C                     --ISEED  = THE INTEGER VALUE OF THE SEED FOR THE
C                                RANDOM NUMBER GENERATOR.
C                     --NKEEP  = THE INTEGER VALUE THAT SPECIFIES HOW
C                                MANY RANDOM PERMUTATION VALUES WILL BE
C                                KEPT.
C                     --PVAL   = THE PROBABILITY OF SUCCESS FOR A GIVEN
C                                RANDOM PERMUTATION VALUE.
C                     --NITER  = THE INTEGER VALUE THAT SPECIFIES HOW
C                                MANY SETS OF PERMUTATIONS WILL BE
C                                GENERATED.
C                     --IDIST  = AN INTEGER VALUE THAT SPECIFIES WHETHER
C                                THE OUTPUT ARRAY WILL BE CHECKED FOR
C                                DISTINCT VALUES.
C                     --MAXNXT = THE INTEGER VALUE THAT SPECIFIES THE
C                                MAXIMUM SIZE OF THE OUTPUT ARRAYS.
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR INTO WHICH
C                                THE GENERATED RANDOM PERMUTATIONS WILL
C                                BE PLACED.
C                     --TAG    = A SINGLE PRECISION VECTOR WHICH
C                                IDENTIFIES WHICH ITERATION THE RANDOM
C                                PERMUTATION CAME FROM
C     OUTPUT--A SET OF RANDOM PERMUTATIONS FROM MULTIPLE TRIALS.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     NOTE--THE RANDOM PERMUTATIONS ALGORITHM IS BASED ON A KNUTH
C           ALGORITHM (VOLUME 2, ALGORITM 3.4, P. 145) AS
C           ADAPTED BY H. D. KNOBLE (ROUTINE RPERM).  I DON'T HAVE
C           THE ORIGINAL RPERM SOURCE, THIS WAS ADAPTED FROM A
C           LISTING OF A FORTRAN 90 IMPLEMENTATION OF THAT ALGORITHM.
C     WRITTEN BY--ALAN HECKERT
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2899
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2017/08
C     ORIGINAL VERSION--AUGUST    2017.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION Y(*)
      DIMENSION TAG(*)
      DIMENSION X(*)
C
      CHARACTER*4 IBUGA3
      CHARACTER*4 ISUBRO
      CHARACTER*4 IERROR
C
      DIMENSION U(100)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'NPE2')THEN
        WRITE(ICOUT,51)
   51   FORMAT('AT THE BEGINNING OF RANPE2')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,53)
   53   FORMAT('N,NKEEP,NITER,IDIST,PVAL = ',2I8,2I5,F10.5)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)THEN
        WRITE(ICOUT,101)
  101   FORMAT('***** ERROR IN THE SAMPLE RANDOM PERMUTATION--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,103)
  103   FORMAT('      THE SIZE OF THE RANDOM PERMUTATION, N, IS ',
     1         'NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,105)N
  105   FORMAT('      THE VALUE OF N IS ',I8)
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        GOTO9000
      ELSEIF(N.GT.MAXNXT)THEN
        WRITE(ICOUT,101)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,107)MAXNXT
  107   FORMAT('      THE SIZE OF THE RANDOM PERMUTATION, N, IS ',
     1         'GREATER THAN ',I10,'.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,105)N
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        GOTO9000
      ELSEIF(NKEEP.LT.1 .OR. NKEEP.GT.N)THEN
        WRITE(ICOUT,101)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,113)
  113   FORMAT('      THE NUMBER OF VALUES TO KEEP, NKEEP,  FOR A ',
     1         'SINGLE ITERATION')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,115)N
  115   FORMAT('      IS LESS THAN ONE OR GREATER THAN ',I8)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,117)NKEEP
  117   FORMAT('      THE VALUE OF NKEEP IS ',I8)
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        GOTO9000
      ELSEIF(NITER.LT.1)THEN
        WRITE(ICOUT,101)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,123)
  123   FORMAT('      THE NUMBER OF ITERATIONS IS LESS THAN ONE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,127)NITER
  127   FORMAT('      THE NUMBER OF ITERATIONS IS ',I8)
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        GOTO9000
      ELSEIF(PVAL.LE.0.0 .OR. PVAL.GT.1.0)THEN
        WRITE(ICOUT,101)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,133)
  133   FORMAT('      THE PROBABILITY OF SUCCESS IS LESS THAN OR ',
     1         'EQUAL TO ZERO OR GREATER THAN ONE')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,137)PVAL
  137   FORMAT('      THE PROBABILITY OF SUCCESS IS ',F10.5)
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        GOTO9000
      ENDIF
C
      AN=N
      NOUT=0
C
C     BASED ON PVAL, DETERMINE CUT-OFF FOR KEEPING
C     RANDOM PERMUTATION VALUE.
C
      IF(PVAL.GE.1.0)THEN
        NCUT=N
      ELSE
        AVAL=PVAL*AN
        NCUT=INT(AVAL+0.5)
      ENDIF
C
      DO1000ITER=1,NITER
C
        IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'NPE2')THEN
          WRITE(ICOUT,1001)ITER
 1001     FORMAT('AT LOOP 1000: ITER = ',I10)
          CALL DPWRST('XXX','BUG ')
        ENDIF
C
C       GENERATE A RANDOM PERMUTATION OF THE INTEGERS 1 TO N, BUT
C       ONLY GENERATE THE FIRST NKEEP VALUES
C
C       USE ALGORITHM DUE TO KNUTH TO GENERATE RANDOM PERMUTATIONS
C       OF SIZE N.
C
        DO1110I=1,N
          X(I)=REAL(I)
 1110   CONTINUE
C
        DO1120I=1,N,100
          M=MIN(N-I+1,100)
          CALL UNIRAN(M,ISEED,U)
          DO1130J=1,M
            IPJ=I+J-1
            K=INT(U(J)*(N-IPJ+1)) + IPJ
            ATEMP=X(IPJ)
            X(IPJ)=X(K)
            X(K)=ATEMP
 1130     CONTINUE
 1120   CONTINUE
C
C       NOW DETERMINE WHICH ONES TO KEEP
C
C          1) ONLY FIRST NKEEP VALUES CONSIDERED
C          2) ONLY KEEP IF VALUE IS < NCUT
C          3) CHECK IF VALUE HAS ALREADY BEEN SELECTED
C             IN PREVIOUS ITERATION
C
        IF(IDIST.EQ.0)THEN
          DO2000I=1,NKEEP
            IF(X(I).GT.NCUT)GOTO2000
            IF(NOUT.GE.MAXNXT)THEN
              WRITE(ICOUT,101)
              CALL DPWRST('XXX','BUG ')
              WRITE(ICOUT,2001)
 2001         FORMAT('      THE MAXIMUM NUMBER OF OUTPUT POINTS (',I8,
     1               ') HAS BEEN EXCEEDED.')
              CALL DPWRST('XXX','BUG ')
              IERROR='YES'
              GOTO9000
            ENDIF
            NOUT=NOUT+1
            Y(NOUT)=X(I)
            TAG(NOUT)=REAL(ITER)
 2000     CONTINUE
        ELSE
          DO3000I=1,NKEEP
            IF(X(I).GT.NCUT)GOTO3000
            IF(NOUT.GE.1)THEN
              DO3100J=1,NOUT
                IF(X(I).EQ.Y(J))GOTO3000
 3100         CONTINUE
              IF(NOUT.GE.MAXNXT)THEN
                WRITE(ICOUT,101)
                CALL DPWRST('XXX','BUG ')
                WRITE(ICOUT,2001)
                CALL DPWRST('XXX','BUG ')
                IERROR='YES'
                GOTO9000
              ENDIF
              NOUT=NOUT+1
              Y(NOUT)=X(I)
              TAG(NOUT)=REAL(ITER)
            ELSE
              NOUT=NOUT+1
              Y(NOUT)=X(I)
              TAG(NOUT)=REAL(ITER)
            ENDIF
 3000     CONTINUE
        ENDIF
C
 1000 CONTINUE
C
 9000 CONTINUE
C
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'NPE2')THEN
        WRITE(ICOUT,9001)
 9001   FORMAT('AT THE END OF RANPE2')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9003)NOUT,NCUT,IERROR
 9003   FORMAT('NOUT,NCUT,IERROR = ',2I8,2X,A4)
        CALL DPWRST('XXX','BUG ')
        IF(NOUT.GE.1)THEN
          DO9010I=1,NOUT
            WRITE(ICOUT,9013)I,Y(I),TAG(I)
 9013       FORMAT('I,Y(I),TAG(I) = ',I8,2F15.1)
        CALL DPWRST('XXX','BUG ')
 9010     CONTINUE
        ENDIF
      ENDIF
C
      RETURN
      END
      SUBROUTINE RANSUB(N,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SUBSET OF SIZE N
C              IN A RANDOM SUBSET OF SIZE N, THERE WILL BE N ELEMENTS
C              RETURNED, WHERE EACH IS EITHER A 0 (NOT INCLUDED) OR
C              1 (INCLUDED).
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF ITEMS IN THE PERMUTATION.
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST N)
C                                INTO WHICH THE GENERATED
C                                RANDOM SUBSET WILL BE PLACED.
C     OUTPUT--A RANDOM SUBSET OF SIZE N
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCE: NIJENHUIS, ALBERT AND WILF, HERBERT S., 'COMBINATORIAL
C                ALGORITHMS', SECOND EDITION, ACADEMIC PRESS, 1978, CH. 2.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2008/5
C     ORIGINAL VERSION--MAY       2008.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DIMENSION X(*)
C
C-----COMMON---------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)THEN
        WRITE(ICOUT, 5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
    5 FORMAT('***** ERROR--THE REQUESTED NUMBER OF ELEMENTS IN THE ',
     1       'RANDOM SUBSET IS NON-POSITIVE.')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8)
C
C     GENERATE A RANDOM SUBSET OF N ELEMENTS
C
      NPAR=1
      CALL DUNRAN(N,NPAR,ISEED,X)
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE RAYCDF(X,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE RAYLEIGH DISTRIBUTION.
C              THIS DISTRIBUTION IS DEFINED FOR NON-NEGATIVE X AND
C              HAS THE CUMULATIVE DISTRIBUTION FUNCTION
C                 F(X) = 1 - EXP(-0.5*X**2)       X > 0
C              NOTE THAT THE RAYLEIGH IS A SPECIAL CASE OF THE
C              FOLLOWING:
C              1) A CHI DISTRIBUTION WITH NU = 2
C              2) A WEIBULL DISTRIBUTION WITH GAMMA = 2 AND SCALE
C                 PARAMETER SQRT(2)
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     OUTPUT ARGUMENTS--CDF   = THE SINGLE PRECISION PROBABILITY
C                               DENSITY FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION FUNCTION
C             VALUE CDF FOR THE RAYLEIGH DISTRIBUTION
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--EXP.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     REFERENCE--JOHNSON, KOTZ, AND BALAKRISHNAN (1994).
C                "CONTINUOUS UNIVARIATE DISTRIBUTIONS--VOLUME 1",
C                SECOND EDITION, WILEY, PP. 453, 686.
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 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004.6
C     ORIGINAL VERSION--JUNE      2004.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DCDF
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOMC.INC'
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C               ************************************
C               **  STEP 1--                      **
C               **  COMPUTE THE DENSITY FUNCTION  **
C               ************************************
C
      IF(X.LE.0.0)THEN
        CDF=0.0
      ELSE
        DX=DBLE(X)
        IF(DX.GE.DSQRT(D1MACH(2)))THEN
          CDF=1.0
          GOTO9000
        ENDIF
C
        DCDF=1.0D0 - DEXP(-0.5D0*(DBLE(X)**2))
        CDF=REAL(DCDF)
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      DOUBLE PRECISION FUNCTION RAYFUN(UHAT,X)
C
C     PURPOSE--THIS ROUTINE IS USED IN FINDING THE MAXIMUM LIKELIHOOD
C              ESTIMATE OF THE LOCATION PARAMETER OF THE 2-PARAMETER
C              RAYLEIGH DISTRIBUTION.  THIS FUNCTION FINDS THE ROOT OF
C              THE EQUATION:
C
C              N*(XBAR - UHAT)/(SUM[i=1 to N][1/(X(i) - UHAT)] -
C              (1/(2*N))*SUM[i=1 to N][(X(i) - UHAT)**2] = 0
C
C              CALLED BY DFZER2 ROUTINE FOR FINDING THE ROOT OF A
C              FUNCTION.
C     EXAMPLE--RAYLEIGH MAXIMUM LIKELIHOOD Y
C     REFERENCE--COHEN AND WHITTEN (1988), "PARAMETER ESTIMATION IN
C                RELIABILITY AND LIFE SPAN MODELS", MARCEL DEKKER, INC.,
C                CHAPTER 10.
C     WRITTEN BY--ALAN HECKERT
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBUG, MD 20899-8980
C                 PHONE--301-975-2899
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2010/7
C     ORIGINAL VERSION--JULY       2010.
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION UHAT
      DOUBLE PRECISION X(*)
C
      INTEGER N
      DOUBLE PRECISION DXBAR
      COMMON/RAYCOM/DXBAR,N
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DSUM2
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DX
      DOUBLE PRECISION DN
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      DN=DBLE(N)
      DTERM1=DN*(DXBAR - UHAT)
      DTERM2=1.0D0/(2.0D0*DN)
      DSUM1=0.0D0
      DSUM2=0.0D0
      DO100I=1,N
        DX=X(I) - UHAT
        DSUM1=DSUM1 + 1.0D0/DX
        DSUM2=DSUM1 + DX**2
  100 CONTINUE
C
      RAYFUN=(DTERM1/DSUM1) - DTERM2*DSUM2
C
      RETURN
      END
      SUBROUTINE RAYLI1(Y,N,ICASPL,
     1                  ALOC,SCALE,
     1                  ALIK,AIC,AICC,BIC,
     1                  ISUBRO,IBUGA3,IERROR)
C
C     PURPOSE--THIS ROUTINE COMPUTES THE LIKELIHOOD FUNCTION FOR
C              THE RAYLEIGH DISTRIBUTION.  THIS IS FOR THE RAW DATA
C              CASE (I.E., NO GROUPING AND NO CENSORING).
C
C              IT IS ASSUMED THAT BASIC ERROR CHECKING HAS ALREADY BEEN
C              PERFORMED.
C
C     REFERENCE--KARL BURY, "STATISTICAL DISTRIBUTIONS IN ENGINEERING",
C                CAMBRIDGE UNIVERSITY PRESS, 1999, P. 187.
C     WRITTEN BY--ALAN HECKERT
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2899
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2010/7
C     ORIGINAL VERSION--JULY      2010.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 ICASPL
      CHARACTER*4 ISUBRO
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 IWRITE
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 ISTEPN
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DS
      DOUBLE PRECISION DU
      DOUBLE PRECISION DN
      DOUBLE PRECISION DNP
      DOUBLE PRECISION DLIK
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DSUM2
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
C
C---------------------------------------------------------------------
C
      DIMENSION Y(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='RAYL'
      ISUBN2='I1  '
      IERROR='NO'
C
      ALIK=-99.0
      AIC=-99.0
      AICC=-99.0
      BIC=-99.0
C
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'YLI1')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,51)
   51   FORMAT('**** AT THE BEGINNING OF RAYLI1--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,52)IBUGA3,ISUBRO
   52   FORMAT('IBUGA3,ISUBRO = ',A4,2X,A4)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,55)N,ALOC,SCALE
   55   FORMAT('N,ALOC,SCALE = ',I8,2G15.7)
        CALL DPWRST('XXX','WRIT')
        DO56I=1,MIN(N,100)
          WRITE(ICOUT,57)I,Y(I)
   57     FORMAT('I,Y(I) = ',I8,G15.7)
          CALL DPWRST('XXX','WRIT')
   56   CONTINUE
      ENDIF
C
C               ******************************************
C               **  STEP 1--                            **
C               **  COMPUTE LIKELIHOOD FUNCTION         **
C               ******************************************
C
      ISTEPN='1'
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'YLI1')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IERFLG=0
      IERROR='NO'
      IWRITE='OFF'
      IF(ICASPL.EQ.'1RAY')ALOC=0.0
C
C     THE LOG-LIKELIHOOD FUNCTION IS
C
C     -2*N*LOG(S) + SUM[i=1][N][LOG(Y(i) - U) -
C     (1/(2*S**2)*SUM[i=1][N][Y(i) - U]
C
      DN=DBLE(N)
      DS=DBLE(SCALE)
      DU=DBLE(ALOC)
      DTERM1=-2.0D0*DN*DLOG(DS)
      DTERM2=1.0D0/(2.0D0*DS*DS)
      DSUM1=0.0D0
      DSUM2=0.0D0
      DO1000I=1,N
        DX=DBLE(Y(I))
        DSUM1=DSUM1 + DLOG(DX-DU)
        DSUM2=DSUM2 + (DX-DU)
 1000 CONTINUE
      DLIK=DTERM1 + DSUM1 - DTERM2*DSUM2
C
      ALIK=REAL(DLIK)
      DNP=2.0D0
      IF(ICASPL.EQ.'1RAY')DNP=1.0D0
      AIC=REAL(-2.0D0*DLIK + 2.0D0*DNP)
      DTERM3=(2.0D0*DNP*(DNP+1.0D0))/(DN-DNP-1.0D0)
      AICC=REAL(-2.0D0*DLIK + 2.0D0*DNP + DTERM3)
      BIC=REAL(-2.0D0*DLIK + DNP*LOG(DN))
C
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'YLI1')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9011)
 9011   FORMAT('**** AT THE END OF RAYLI1--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9013)DSUM1,DSUM2,DTERM1,DTERM3
 9013   FORMAT('DSUM1,DSUM2,DTERM1,DTERM3 = ',3G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9014)ALIK,AIC,AICC,BIC
 9014   FORMAT('ALIK,AIC,AICC,BIC = ',4G15.7)
        CALL DPWRST('XXX','WRIT')
      ENDIF
C
      RETURN
      END
      SUBROUTINE RAYML1(Y,N,ICASPL,
     1                  DTEMP1,
     1                  XMEAN,XSD,XMIN,XMAX,
     1                  ALOCML,SCALML,SCALSE,
     1                  ALOCMM,SCALMM,SCA2SE,
     1                  ALOCMO,SCALMO,ALOCLM,SCALLM,ALOCPE,SCALPE,
     1                  ALOCSE,ALAMBA,ALAMSE,
     1                  ISUBRO,IBUGA3,IERROR)
C
C     PURPOSE--THIS ROUTINE COMPUTES THE MAXIMUM LIKELIHOOD ESTIMATES
C              FOR THE RAYLEIGH DISTRIBUTION FOR THE RAW DATA CASE (I.E.,
C              NO CENSORING AND NO GROUPING).
C
C              IT IS ASSUMED THAT BASIC ERROR CHECKING HAS ALREADY BEEN
C              PERFORMED.
C
C              PUT THIS IN A SEPARATE ROUTINE AS IT MAY BE CALLED
C              FROM MULTIPLE PLACES (DPMLR1 WILL GENERATE THE OUTPUT
C              FOR THE RAYLEIGH MLE COMMAND).
C
C     REFERENCE--COHEN AND WHITTEN (1988), "PARAMETER ESTIMATION IN
C                RELIABILITY AND LIFE SPAN MODELS", MARCEL DEKKER, INC.,
C                CHAPTER 10.
C              --KARL BURY, "STATISTICAL DISTRIBUTIONS IN
C                ENGINEERING", CAMBRIDGE UNIVERSITY PRESS,
C                1999, PP. 331-332.
C              --DEY, DEY, AND KUNDU (xxxx), "TWO-PARAMETER RAYLEIGH
C                DISTRIBUTION: DIFFERENT METHODS OF ESTIMATION",
C                SUBMITTED.
C              --MAHDI (2006), "IMPROVED PARAMETER ESTIMATION IN
C                RAYLEIGH MODEL", METODOLOSKIZVEZKI, VOL. 3,
C                NO. 1, PP. 63-74.
C     WRITTEN BY--ALAN HECKERT
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2899
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2010/07
C     ORIGINAL VERSION--JULY      2010. EXTRACTED AS A SEPARATE
C                                       SUBROUTINE (FROM DPMLRA),
C                                       SUPPORT 2-PARAMETER CASE
C     UPDATED         --MAY       2014. ADDITIONAL METHODS FOR
C                                       2-PARAMETER CASE
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 ICASPL
      CHARACTER*4 ISUBRO
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 IWRITE
      CHARACTER*40 IDIST
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 ISTEPN
C
      DIMENSION Y(*)
      DOUBLE PRECISION DTEMP1(*)
C
      DOUBLE PRECISION DPI
      DOUBLE PRECISION DP
      DOUBLE PRECISION DX
      DOUBLE PRECISION DN
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DSUM2
      DOUBLE PRECISION DSUM3
      DOUBLE PRECISION DVAR
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
      DOUBLE PRECISION DTERM4
      DOUBLE PRECISION DTERM5
      DOUBLE PRECISION DEPS
      DOUBLE PRECISION DA
      DOUBLE PRECISION DB
      DOUBLE PRECISION DC
      DOUBLE PRECISION DL1
      DOUBLE PRECISION DL2
C
      DOUBLE PRECISION DAE
      DOUBLE PRECISION DRE
      DOUBLE PRECISION DXSTRT
      DOUBLE PRECISION DXLOW
      DOUBLE PRECISION DXUP
      DOUBLE PRECISION XLOWSV
      DOUBLE PRECISION XUPSV
C
      DOUBLE PRECISION DGAMMA
      EXTERNAL DGAMMA
      DOUBLE PRECISION DLNGAM
      EXTERNAL DLNGAM
C
      DOUBLE PRECISION RAYFUN
      EXTERNAL RAYFUN
C
      INTEGER IN
      DOUBLE PRECISION DXBAR
      COMMON/RAYCOM/DXBAR,IN
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
      DATA DPI/ 3.14159265358979D+00/
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='RAYM'
      ISUBN2='L1  '
      IWRITE='OFF'
      IERROR='NO'
C
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'YML1')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,51)
   51   FORMAT('**** AT THE BEGINNING OF RAYML1--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,52)IBUGA3,ISUBRO,N,MAXNXT
   52   FORMAT('IBUGA3,ISUBRO,N,MAXNXT = ',2(A4,2X),2I8)
        CALL DPWRST('XXX','WRIT')
        DO56I=1,MIN(N,100)
          WRITE(ICOUT,57)I,Y(I)
   57     FORMAT('I,Y(I) = ',I8,G15.7)
          CALL DPWRST('XXX','WRIT')
   56   CONTINUE
      ENDIF
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CARRY OUT CALCULATIONS                **
C               **  FOR RAYLEIGH MLE ESTIMATE             **
C               ********************************************
C
      ISTEPN='1'
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'YML1')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IDIST='RAYLEIGH'
      IFLAG=0
      IF(ICASPL.EQ.'1')IFLAG=1
      CALL SUMRAW(Y,N,IDIST,IFLAG,
     1            XMEAN,XVAR,XSD,XMIN,XMAX,
     1            ISUBRO,IBUGA3,IERROR)
      IF(IERROR.EQ.'YES')GOTO9000
      CALL SORT(Y,N,Y)
C
      ALOCML=CPUMIN
      SCALML=CPUMIN
      ALOCMM=CPUMIN
      SCALMM=CPUMIN
      SCALSE=CPUMIN
      SCA2SE=CPUMIN
      DN=DBLE(N)
C
      IF(ICASPL.EQ.'1')THEN
C
C       ONE-PARAMETER MODEL
C
C       MAXIMUM LIKELIHOOD ESTIMATE OF SIGMA:
C
C       SIGMAHAT = SUM[i=1 to N][SQRT(X(i)**2/(2*N)]
C
C       FORMULA FOR STANDARD ERROR GIVEN ON PAGE 201 OF
C       COHEN AND WHITTEN.
C
        DP=2.0D0
        DSUM1=0.0D0
        DO1010I=1,N
          DX=DBLE(Y(I))
          DSUM1=DSUM1 + DX*DX/(DP*DN)
 1010   CONTINUE
        DSUM1=DSQRT(DSUM1)
        SCALML=REAL(DSUM1)
        DTERM1=DSUM1**2/(2.0D0*DN*DP)
        DTERM2=2.0D0*DN*DP
C
C       USE LOG GAMMA FUNCTION IN CASE N GETS LARGE
C
CCCCC   DTERM3=DGAMMA((DN*DP+1.0D0)/2.0D0)
CCCCC   DTERM4=DGAMMA(DN*DP/2.0D0)
        DTERM3=DLNGAM((DN*DP+1.0D0)/2.0D0)
        DTERM4=DLNGAM(DN*DP/2.0D0)
        DTERM5=2.0D0*(DLOG(2.0D0) + DTERM3 - DTERM4)
        DTERM5=DEXP(DTERM5)
C
        DVAR=DTERM1*(DTERM2 - DTERM5)
        SCALSE=REAL(DSQRT(DVAR))
      ELSE
C
C       MOMENT ESTIMATES ARE:
C
C       SIGMAHAT = S*SQRT(2/(4 - PI))
C       UHAT     = XBAR - SIGMAHAT*SQRT(PI/2)
C
        DTERM1=DBLE(XSD)*DSQRT(2.0D0/(4.0D0 - DPI))
        SCALMO=REAL(DTERM1)
        DTERM2=DBLE(XMEAN) - DTERM1*DSQRT(DPI/2.0D0)
        ALOCMO=REAL(DTERM2)
C
C       L-MOMENT ESTIMATES ARE:
C
C       UHAT      = L1 - (SQRT(2)/(SQRT(2) - 1))*L2
C       LAMBDAHAT = GAMMA(3/2)**2*(3 - 2*SQRT(2))/(2*L2**2)
C
C       WHERE L1 AND L2 ARE THE FIRST TWO SAMPLE MOMENTS
C
C       L1 = XBAR
C       L2 = (2/(N*(N-1)))*SUM[i=1 to N][(i-1)*X(i) - L1]
C
        DTERM1=DGAMMA(1.5D0)
        DL1=DBLE(XMEAN)
        DSUM1=0.0D0
        DO1110I=1,N
          DSUM1=DSUM1 + DBLE(I-1)*DBLE(Y(I))
 1110   CONTINUE
        DTERM3=2.0D0/(DN*(DN-1.0D0))
        DL2=(DTERM3*DSUM1) - DL1
        DTERM2=DL1 - (DSQRT(2.0D0)/(DSQRT(2.0D0) - 1.0D0))*DL2
        ALOCLM=REAL(DTERM2)
        DTERM2=DTERM1**2/DL2**2
        DTERM3=(3.0D0 - 2.0D0*DSQRT(2.0D0))/2.0D0
        DTERM4=DTERM2*DTERM3
        SCALLM=REAL(DTERM4)
        SCALLM=SQRT(1.0/(2.0*SCALLM))
C
C       PERCENTILE ESTIMATES ARE:
C
C       SIGMAHAT = (A - B**2)**2/(C - B*XBAR)**2
C       UHAT     = (A*XBAR - B*C)/(A - B**2)
C
C       WHERE
C
C       A = SUM[i=1 to N][-LOG(1 - P(i)]/N
C       B = SUM[i=1 to N][SQRT(-LOG(1 - P(i)))]/N
C       C = SUM[i=1 to N][X(i)*SQRT(-LOG(1 - P(i)))]
C       P(i) = i/(N+1)
C
        DSUM1=0.0D0
        DSUM2=0.0D0
        DSUM3=0.0D0
        DO1120I=1,N
          DTERM1=-DLOG(1.0D0 - DBLE(I)/(DN+1.0D0))
          DSUM1=DSUM1 + DTERM1
          DSUM2=DSUM2 + DSQRT(DTERM1)
          DSUM3=DSUM3 + DBLE(Y(I))*DSQRT(DTERM1)
 1120   CONTINUE
        DA=DSUM1/DN
        DB=DSUM2/DN
        DC=DSUM3/DN
        DTERM1=(DA*DBLE(XMEAN) - DB*DC)/(DA - DB**2)
        ALOCPE=REAL(DTERM1)
        DTERM1=(DA - DB*DB)**2/(DC - DB*DBLE(XMEAN))**2
        SCALPE=REAL(DTERM1)
        SCALPE=SQRT(1.0/(2.0*SCALPE))
C
C       MODIFIED MOMENT ESTIMATES ARE:
C
C       SIGMAHAT = (XBAR - XMEAN)/(SQRT(PI/2) - SQRT(PI/(2*N))
C       UHAT = XBAR - SIGMAHAT*SQRT(PI/2)
C
        DN=DBLE(N)
        DTERM1=DSQRT(DPI/2.0D0)
        DTERM2=DSQRT(DPI/(2.0D0*DN))
        SCALMM=(XMEAN - XMIN)/REAL(DTERM1 - DTERM2)
        ALOCMM=XMEAN - SCALMM*REAL(DTERM1)
C
C       MAXIMUM LIKELIHOOD ESTIMATES ARE:
C
C       TO ESTIMATE U, SOLVE THE FOLLOWING EQUATION:
C
C       N*(XBAR - UHAT)/(SUM[i=1 to N][1/(X(i) - UHAT)] -
C       (1/(2*N))*SUM[i=1 to N][(X(i) - UHAT)**2] = 0
C
C       THEN
C
C       SIGMAHAT = (1/(2*N))*SUM[i=1 to N][(X(i) - UHAT)**2]
C
        DXBAR=DBLE(XMEAN)
        IN=N
        DO2010I=1,N
          DTEMP1(I)=DBLE(Y(I))
 2010   CONTINUE
C
        DEPS=1.0D-12
        DXSTRT=DBLE(ALOCMM)
        DAE=2.0*0.000001D0*DXSTRT
        DRE=DAE
        IFLAG=0
        IF(DXSTRT.GE.0.0D0)THEN
          DXLOW=DXSTRT/3.0D0
        ELSE
          DXLOW=DXSTRT*3.0D0
        ENDIF
        DXUP=DBLE(XMIN) - DEPS
        ITBRAC=0
 4105   CONTINUE
        XLOWSV=DXLOW
        XUPSV=DXUP
        CALL DFZER2(RAYFUN,DXLOW,DXUP,DXSTRT,DRE,DAE,IFLAG,DTEMP1)
C
        IF(IFLAG.EQ.4 .AND. ITBRAC.LE.100)THEN
          IF(DXLOW.GE.0.0D0)THEN
            DXLOW=XLOWSV/2.0D0
          ELSE
            DXLOW=XLOWSV*2.0D0
          ENDIF
          ITBRAC=ITBRAC+1
          GOTO4105
        ENDIF
C
        IF(IFLAG.EQ.2)THEN
C
C         NOTE: SUPPRESS THIS MESSAGE FOR NOW.
CCCCC     WRITE(ICOUT,999)
CCCCC     CALL DPWRST('XXX','BUG ')
CCCCC     WRITE(ICOUT,111)
CC111     FORMAT('***** WARNING FROM RAYLEIGH MAXIMUM ',
CCCCC1           'LIKELIHOOD--')
CCCCC     CALL DPWRST('XXX','BUG ')
CCCCC     WRITE(ICOUT,113)
CC113     FORMAT('      ESTIMATE OF MU MAY NOT BE COMPUTED TO ',
CCCCC1           'DESIRED TOLERANCE.')
CCCCC     CALL DPWRST('XXX','BUG ')
        ELSEIF(IFLAG.EQ.3)THEN
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,121)
  121     FORMAT('***** WARNING FROM RAYLEIGH MAXIMUM LIKELIHOOD--')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,123)
  123     FORMAT('      ESTIMATE OF MU MAY BE NEAR A SINGULAR POINT.')
          CALL DPWRST('XXX','BUG ')
        ELSEIF(IFLAG.EQ.4)THEN
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,131)
  131     FORMAT('***** ERROR FROM RAYLEIGH MAXIMUM LIKELIHOOD--')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,133)
  133     FORMAT('      APPROPRIATE BRACKETING INTERVAL NOT FOUND.')
          CALL DPWRST('XXX','BUG ')
        ELSEIF(IFLAG.EQ.5)THEN
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,121)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,143)
  143     FORMAT('      MAXIMUM ITERATIONS EXCEEDED.')
          CALL DPWRST('XXX','BUG ')
        ENDIF
C
        ALOCML=REAL(DXLOW)
        DSUM1=0.0D0
        DO2030I=1,N
          DX=DTEMP1(I) - DXLOW
          DSUM1=DSUM1 + DX**2
 2030   CONTINUE
        DTERM1=DSUM1/(2.0D0*DN)
        SCALML=REAL(DSQRT(DTERM1))
C
C       FORMULAS FOR STANDARD ERRORS ARE GIVEN IN KUNDU PAPER.
C       NOTE THAT HE IS OBTAINING THE VARIANCE FOR "LAMBDA"
C       RATHER THAN THE SCALE PARAMETER.
C
C          VAR(LAMBDA) = LAMBDA**2/N
C          VAR(U) = 1/{2*U + SUM[i=1 to N][Y(i) - U)**2/N}
C
C       THE MAHDI PAPER GIVES AN APPROXIMATE VARIANCE IN TERMS
C       OF THE SCALE PARAMETER:
C
C           VAR(SCALE) = SCALE**2/
C                        {4*[4 + 3*U**2/SCALE**2 + 6*U*SQRT(PI/2)/SCALE]}
C
        AN=REAL(N)
        ALAMBA=1.0/(2.0*SCALML**2)
        ALAMSE=ALAMBA/SQRT(AN)
        DSUM1=0.0D0
        DO5010I=1,N
          DX=DBLE(Y(I)) - DBLE(ALOCML)
          DSUM1=DSUM1 + 1.0D0/DX**2
 5010   CONTINUE
        DTERM1=DSQRT(1.0D0/(2.0D0*DBLE(ALOCML) + DSUM1/DN))
        ALOCSE=REAL(DTERM1)
        DTERM1=6.0D0*DBLE(ALOCML)*DSQRT(DPI/2.0D0)/DBLE(SCALML)
        DTERM2=4.0D0 + 3.0D0*DBLE(ALOCML)**2/DBLE(SCALML)**2
        DTERM3=DBLE(SCALML)**2/(DBLE(N)*(DTERM1+DTERM2))
        DTERM3=DSQRT(DTERM3)
        SCALSE=REAL(DTERM3)
C
      ENDIF
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'YML1')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9011)
 9011   FORMAT('**** AT THE END OF RAYML1--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9055)N,XMEAN,XSD,XMIN,XMAX
 9055   FORMAT('N,XMEAN,XSD,XMIN,XMAX = ',I8,6G15.7)
        CALL DPWRST('XXX','WRIT')
        IF(ICASPL.EQ.'1')THEN
          WRITE(ICOUT,9056)SCALMM,SCALSE
 9056     FORMAT('SCALMM,SCALSE = ',2G15.7)
          CALL DPWRST('XXX','WRIT')
        ELSE
          WRITE(ICOUT,9057)ALOCMM,SCALMM
 9057     FORMAT('ALOCMM,SCALMM = ',2G15.7)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,9058)ALOCML,SCALML
 9058     FORMAT('ALOCML,SCALML = ',2G15.7)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,9060)ALAMBA,ALAMSE,ALOCSE
 9060     FORMAT('ALAMBA,ALAMSE,ALOCSE = ',3G15.7)
          CALL DPWRST('XXX','WRIT')
        ENDIF
      ENDIF
C
      RETURN
      END
      SUBROUTINE RAYPDF(X,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE RAYLEIGH DISTRIBUTION.
C              THIS DISTRIBUTION IS DEFINED FOR NON-NEGATIVE X AND
C              HAS THE PROBABILITY DENSITY FUNCTION
C                 F(X) = X*EXP(-X**2/2)    X > 0
C              NOTE THAT THE RAYLEIGH IS A SPECIAL CASE OF THE
C              FOLLOWING:
C              1) A CHI DISTRIBUTION WITH NU = 2
C              2) A WEIBULL DISTRIBUTION WITH GAMMA = 2 AND SCALE
C                 PARAMETER = SQRT(2)
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     OUTPUT ARGUMENTS--PDF   = THE SINGLE PRECISION PROBABILITY
C                               DENSITY FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY FUNCTION
C             VALUE PDF FOR THE RAYLEIGH DISTRIBUTION
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--EXP, LOG.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     REFERENCE--JOHNSON, KOTZ, AND BALAKRISHNAN (1994).
C                "CONTINUOUS UNIVARIATE DISTRIBUTIONS--VOLUME 1",
C                SECOND EDITION, WILEY, PP. 453, 686.
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 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004.6
C     ORIGINAL VERSION--JUNE      2004.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DPDF
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOMC.INC'
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C               ************************************
C               **  STEP 1--                      **
C               **  COMPUTE THE DENSITY FUNCTION  **
C               ************************************
C
      IF(X.LT.0.0)THEN
        WRITE(ICOUT,8)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,48)X
        CALL DPWRST('XXX','WRIT')
        PDF=0.0
        GOTO9000
      ENDIF
    8 FORMAT('***** ERROR: VALUE OF THE FIRST ARGUMENT TO RAYPDF ',
     1       'IS NEGATIVE.')
   48 FORMAT('      VALUE OF ARGUMENT IS: ',G15.7)
C
      IF(X.EQ.0.0)THEN
        PDF=0.0
      ELSE
        DX=DBLE(X)
        IF(DX.GE.DSQRT(D1MACH(2)))THEN
          PDF=0.0
          GOTO9000
        ENDIF
C
        DTERM1=DLOG(DX)
        DTERM2=-DX*DX/2.0D0
        DPDF=DTERM1 + DTERM2
        DPDF=DEXP(DPDF)
        PDF=REAL(DPDF)
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE RAYPPF(P,PPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE RAYLEIGH DISTRIBUTION.
C              THIS DISTRIBUTION IS DEFINED FOR NON-NEGATIVE X AND
C              HAS THE PERCENT POINT FUNCTION
C                 G(P) = SQRT(2*LOG(1/(1-P)))    0 <= P < 1
C              NOTE THAT THE RAYLEIGH IS A SPECIAL CASE OF THE
C              FOLLOWING:
C              1) A CHI DISTRIBUTION WITH NU = 2
C              2) A WEIBULL DISTRIBUTION WITH GAMMA = 2 AND SCALE
C                 PARAMETER = SQRT(2)
C     INPUT  ARGUMENTS--P     = THE SINGLE PRECISION VALUE AT
C                               WHICH THE PERCENT POINT
C                               FUNCTION IS TO BE EVALUATED.
C                               0 <= P < 1.
C     OUTPUT ARGUMENTS--PPF   = THE SINGLE PRECISION PROBABILITY
C                               DENSITY FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PERCENT POINT FUNCTION
C             VALUE FOR THE RAYLEIGH DISTRIBUTION
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--LOG.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     REFERENCE--JOHNSON, KOTZ, AND BALAKRISHNAN (1994).
C                "CONTINUOUS UNIVARIATE DISTRIBUTIONS--VOLUME 1",
C                SECOND EDITION, WILEY, PP. 453, 686.
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 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004.6
C     ORIGINAL VERSION--JUNE      2004.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DOUBLE PRECISION DP
      DOUBLE PRECISION DPPF
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C               ************************************
C               **  STEP 1--                      **
C               **  COMPUTE THE DENSITY FUNCTION  **
C               ************************************
C
      IF(P.LT.0.0 .OR. P.GE.1.0)THEN
        WRITE(ICOUT,8)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,48)P
        CALL DPWRST('XXX','WRIT')
        PPF=0.0
        GOTO9000
      ENDIF
    8 FORMAT('***** ERROR: VALUE OF THE FIRST ARGUMENT TO RAYPPF ',
     1       'IS OUTSIDE THE [0,1) INTERVAL.')
   48 FORMAT('      VALUE OF ARGUMENT IS: ',G15.7)
      IF(P.EQ.0.0)THEN
        PPF=0.0
      ELSE
        DP=DBLE(P)
        DPPF=DSQRT(2.0D0*DLOG(1.0D0/(1.0D0-DP)))
        PPF=REAL(DPPF)
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE RAYRAN(N,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE RAYLEIGH DISTRIBUTION.
C              THIS DISTRIBUTION IS DEFINED FOR NON-NEGATIVE X AND HAS
C              THE PROBABILITY DENSITY FUNCTION
C                 F(X) = X*EXP(-X**2/2)
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST N)
C                                INTO WHICH THE GENERATED
C                                RANDOM SAMPLE WILL BE PLACED.
C     OUTPUT--A RANDOM SAMPLE OF SIZE N
C             FROM THE RAYLEIGH DISTRIBUTION
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCE--JOHNSON, KOTZ, AND BALAKRISHNAN (1994).
C                "CONTINUOUS UNIVARIATE DISTRIBUTIONS--VOLUME 1",
C                SECOND EDITION, WILEY, P. 453.
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 TRMAXMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004.6
C     ORIGINAL VERSION--JUNE      2004.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DIMENSION X(*)
C
      DOUBLE PRECISION DP
      DOUBLE PRECISION DPPF
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)THEN
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,6)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
C
    5 FORMAT('***** ERROR--FOR THE RAYLEIGH DISTRIBUTION, THE')
    6 FORMAT('      REQUESTED NUMBER OF RANDOM NUMBERS WAS ',
     1      'NON-POSITIVE.')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,'.')
C
C     USE PERCENT POINT TRANSFORMATION METHOD.
C
      CALL UNIRAN(N,ISEED,X)
      DO100I=1,N
        DP=DBLE(X(I))
        DPPF=DSQRT(2.0D0*DLOG(1.0D0/(1.0D0-DP)))
        X(I)=REAL(DPPF)
  100 CONTINUE
C
 9999 CONTINUE
      RETURN
      END
      REAL FUNCTION RC (X, Y, IER)
C***BEGIN PROLOGUE  RC
C***PURPOSE  Calculate an approximation to
C             RC(X,Y) = Integral from zero to infinity of
C                              -1/2     -1
C                    (1/2)(t+X)    (t+Y)  dt,
C            where X is nonnegative and Y is positive.
C***LIBRARY   SLATEC
C***CATEGORY  C14
C***TYPE      SINGLE PRECISION (RC-S, DRC-D)
C***KEYWORDS  DUPLICATION THEOREM, ELEMENTARY FUNCTIONS,
C             ELLIPTIC INTEGRAL, TAYLOR SERIES
C***AUTHOR  Carlson, B. C.
C             Ames Laboratory-DOE
C             Iowa State University
C             Ames, IA  50011
C           Notis, E. M.
C             Ames Laboratory-DOE
C             Iowa State University
C             Ames, IA  50011
C           Pexton, R. L.
C             Lawrence Livermore National Laboratory
C             Livermore, CA  94550
C***DESCRIPTION
C
C   1.     RC
C          Standard FORTRAN function routine
C          Single precision version
C          The routine calculates an approximation to
C           RC(X,Y) = Integral from zero to infinity of
C
C                              -1/2     -1
C                    (1/2)(t+X)    (t+Y)  dt,
C
C          where X is nonnegative and Y is positive.  The duplication
C          theorem is iterated until the variables are nearly equal,
C          and the function is then expanded in Taylor series to fifth
C          order.  Logarithmic, inverse circular, and inverse hyper-
C          bolic functions can be expressed in terms of RC.
C
C
C   2.     Calling Sequence
C          RC( X, Y, IER )
C
C          Parameters on Entry
C          Values assigned by the calling routine
C
C          X      - Single precision, nonnegative variable
C
C          Y      - Single precision, positive variable
C
C
C
C          On Return  (values assigned by the RC routine)
C
C          RC     - Single precision approximation to the integral
C
C          IER    - Integer to indicate normal or abnormal termination.
C
C                     IER = 0 Normal and reliable termination of the
C                             routine.  It is assumed that the requested
C                             accuracy has been achieved.
C
C                     IER > 0 Abnormal termination of the routine
C
C          X and Y are unaltered.
C
C
C   3.    Error Messages
C
C         Value of IER assigned by the RC routine
C
C                  Value Assigned         Error Message Printed
C                  IER = 1                X.LT.0.0E0.OR.Y.LE.0.0E0
C                      = 2                X+Y.LT.LOLIM
C                      = 3                MAX(X,Y) .GT. UPLIM
C
C
C   4.     Control Parameters
C
C                  Values of LOLIM, UPLIM, and ERRTOL are set by the
C                  routine.
C
C          LOLIM and UPLIM determine the valid range of X and Y
C
C          LOLIM  - Lower limit of valid arguments
C
C                   Not less  than 5 * (machine minimum)  .
C
C          UPLIM  - Upper limit of valid arguments
C
C                   Not greater than (machine maximum) / 5 .
C
C
C                     Acceptable values for:   LOLIM       UPLIM
C                     IBM 360/370 SERIES   :   3.0E-78     1.0E+75
C                     CDC 6000/7000 SERIES :   1.0E-292    1.0E+321
C                     UNIVAC 1100 SERIES   :   1.0E-37     1.0E+37
C                     CRAY                 :   2.3E-2466   1.09E+2465
C                     VAX 11 SERIES        :   1.5E-38     3.0E+37
C
C          ERRTOL determines the accuracy of the answer
C
C                 The value assigned by the routine will result
C                 in solution precision within 1-2 decimals of
C                 "machine precision".
C
C
C          ERRTOL  - Relative error due to truncation is less than
C                    16 * ERRTOL ** 6 / (1 - 2 * ERRTOL).
C
C
C              The accuracy of the computed approximation to the inte-
C              gral can be controlled by choosing the value of ERRTOL.
C              Truncation of a Taylor series after terms of fifth order
C              introduces an error less than the amount shown in the
C              second column of the following table for each value of
C              ERRTOL in the first column.  In addition to the trunca-
C              tion error there will be round-off error, but in prac-
C              tice the total error from both sources is usually less
C              than the amount given in the table.
C
C
C
C          Sample Choices:  ERRTOL   Relative Truncation
C                                    error less than
C                           1.0E-3    2.0E-17
C                           3.0E-3    2.0E-14
C                           1.0E-2    2.0E-11
C                           3.0E-2    2.0E-8
C                           1.0E-1    2.0E-5
C
C
C                    Decreasing ERRTOL by a factor of 10 yields six more
C                    decimal digits of accuracy at the expense of one or
C                    two more iterations of the duplication theorem.
C
C *Long Description:
C
C   RC Special Comments
C
C
C
C
C                  Check: RC(X,X+Z) + RC(Y,Y+Z) = RC(0,Z)
C
C                  where X, Y, and Z are positive and X * Y = Z * Z
C
C
C          On Input:
C
C          X and Y are the variables in the integral RC(X,Y).
C
C          On Output:
C
C          X and Y are unaltered.
C
C
C
C                    RC(0,1/4)=RC(1/16,1/8)=PI=3.14159...
C
C                    RC(9/4,2)=LN(2)
C
C
C
C          ********************************************************
C
C          Warning: Changes in the program may improve speed at the
C                   expense of robustness.
C
C
C   --------------------------------------------------------------------
C
C   Special Functions via RC
C
C
C
C                  LN X                X .GT. 0
C
C                                            2
C                  LN(X) = (X-1) RC(((1+X)/2)  , X )
C
C
C   --------------------------------------------------------------------
C
C                  ARCSIN X            -1 .LE. X .LE. 1
C
C                                      2
C                  ARCSIN X = X RC (1-X  ,1 )
C
C   --------------------------------------------------------------------
C
C                  ARCCOS X            0 .LE. X .LE. 1
C
C
C                                     2      2
C                  ARCCOS X = SQRT(1-X ) RC(X  ,1 )
C
C   --------------------------------------------------------------------
C
C                  ARCTAN X            -INF .LT. X .LT. +INF
C
C                                       2
C                  ARCTAN X = X RC(1,1+X  )
C
C   --------------------------------------------------------------------
C
C                  ARCCOT X            0 .LE. X .LT. INF
C
C                                 2   2
C                  ARCCOT X = RC(X  ,X +1 )
C
C   --------------------------------------------------------------------
C
C                  ARCSINH X           -INF .LT. X .LT. +INF
C
C                                      2
C                  ARCSINH X = X RC(1+X  ,1 )
C
C   --------------------------------------------------------------------
C
C                  ARCCOSH X           X .GE. 1
C
C                                    2        2
C                  ARCCOSH X = SQRT(X -1) RC(X  ,1 )
C
C   --------------------------------------------------------------------
C
C                  ARCTANH X           -1 .LT. X .LT. 1
C
C                                        2
C                  ARCTANH X = X RC(1,1-X  )
C
C   --------------------------------------------------------------------
C
C                  ARCCOTH X           X .GT. 1
C
C                                  2   2
C                  ARCCOTH X = RC(X  ,X -1 )
C
C   --------------------------------------------------------------------
C
C***REFERENCES  B. C. Carlson and E. M. Notis, Algorithms for incomplete
C                 elliptic integrals, ACM Transactions on Mathematical
C                 Software 7, 3 (September 1981), pp. 398-403.
C               B. C. Carlson, Computing elliptic integrals by
C                 duplication, Numerische Mathematik 33, (1979),
C                 pp. 1-16.
C               B. C. Carlson, Elliptic integrals of the first kind,
C                 SIAM Journal of Mathematical Analysis 8, (1977),
C                 pp. 231-242.
C***ROUTINES CALLED  R1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   790801  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   891009  Removed unreferenced statement labels.  (WRB)
C   891009  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   900510  Changed calls to XERMSG to standard form, and some
C           editorial changes.  (RWC))
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  RC
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOMC.INC'
      INCLUDE 'DPCOP2.INC'
C
CCCCC CHARACTER*16 XERN3, XERN4, XERN5
      INTEGER IER
      REAL C1, C2, ERRTOL, LAMDA, LOLIM
      REAL MU, S, SN, UPLIM, X, XN, Y, YN
      LOGICAL FIRST
      SAVE ERRTOL,LOLIM,UPLIM,C1,C2,FIRST
      DATA FIRST /.TRUE./
C
C***FIRST EXECUTABLE STATEMENT  RC
      IF (FIRST) THEN
         ERRTOL = (R1MACH(3)/16.0E0)**(1.0E0/6.0E0)
         LOLIM  = 5.0E0 * R1MACH(1)
         UPLIM  = R1MACH(2) / 5.0E0
C
         C1 = 1.0E0/7.0E0
         C2 = 9.0E0/22.0E0
      ENDIF
      FIRST = .FALSE.
C
C         CALL ERROR HANDLER IF NECESSARY.
C
      RC = 0.0E0
      IF (X.LT.0.0E0.OR.Y.LE.0.0E0) THEN
         IER = 1
CCCCC    WRITE (XERN3, '(1PE15.6)') X
CCCCC    WRITE (XERN4, '(1PE15.6)') Y
         WRITE(ICOUT,1)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,9)X
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,19)Y
         CALL DPWRST('XXX','BUG ')
         RETURN
      ENDIF
    1 FORMAT('***** ERORR FROM RC, EITHER THE FIRST ARGUMENT IS ',
     *       'NEGATIVE OR THE SECOND ARGUMENT IS NON-POSITIVE ***')
    9 FORMAT('***** THE VALUE OF THE FIRST ARGUMENT IS ',E15.8,' *****')
   19 FORMAT('***** THE VALUE OF THE SECOND ARGUMENT IS ',E15.8,' ***')
C
CCCCC IF (MAX(X,Y).GT.UPLIM) THEN
      IF (X.GT.UPLIM) THEN
         IER = 3
CCCCC    WRITE (XERN3, '(1PE15.6)') X
CCCCC    WRITE (XERN4, '(1PE15.6)') Y
CCCCC    WRITE (XERN5, '(1PE15.6)') UPLIM
         WRITE(ICOUT,2)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,9)X
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,8)UPLIM
         CALL DPWRST('XXX','BUG ')
         RETURN
      ENDIF
    2 FORMAT('***** ERORR FROM RC, THE FIRST INPUT ARGUMENT IS LARGER',
     *       'THAN THE UPPER LIMIT. *****')
      IF (Y.GT.UPLIM) THEN
         IER = 3
         WRITE(ICOUT,3)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,19)Y
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,8)UPLIM
         CALL DPWRST('XXX','BUG ')
         RETURN
      ENDIF
    3 FORMAT('***** ERORR FROM RC, THE SECOND INPUT ARGUMENT IS ',
     *       'LARGER THAN THE UPPER LIMIT. *****')
    8 FORMAT('***** THE VALUE OF THE UPPER LIMIT IS ',E15.8,' *****')
C
      IF (X+Y.LT.LOLIM) THEN
         IER = 2
CCCCC    WRITE (XERN3, '(1PE15.6)') X
CCCCC    WRITE (XERN4, '(1PE15.6)') Y
CCCCC    WRITE (XERN5, '(1PE15.6)') LOLIM
         WRITE(ICOUT,4)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,9)X
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,9)Y
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,7)UPLIM
         CALL DPWRST('XXX','BUG ')
         RETURN
      ENDIF
    4 FORMAT('***** ERORR FROM RC, THE SUM OF THE TWO ARGUMENTS IS ',
     *       'LESS THAN THE LOWER LIMIT. *****')
    7 FORMAT('***** THE VALUE OF THE LOWER LIMIT IS ',E15.8,' *****')
C
      IER = 0
      XN = X
      YN = Y
C
   30 MU = (XN+YN+YN)/3.0E0
      SN = (YN+MU)/MU - 2.0E0
      IF (ABS(SN).LT.ERRTOL) GO TO 40
      LAMDA = 2.0E0*SQRT(XN)*SQRT(YN) + YN
      XN = (XN+LAMDA)*0.250E0
      YN = (YN+LAMDA)*0.250E0
      GO TO 30
C
   40 S = SN*SN*(0.30E0+SN*(C1+SN*(0.3750E0+SN*C2)))
      RC = (1.0E0+S)/SQRT(MU)
      RETURN
      END
      SUBROUTINE RCRUDE(NDIM, MAXPTS, FUNCTN, ABSEST, FINEST, IR)
*
*     Crude Monte-Carlo Algorithm with simple antithetic variates
*      and weighted results on restart
*
      EXTERNAL FUNCTN
      INTEGER NDIM, MAXPTS, M, K, IR, NPTS
      DOUBLE PRECISION FINEST, ABSEST, X(100), FUN, FUNCTN, UNI,
     &     VARSQR, VAREST, VARPRD, FINDIF, FINVAL
      SAVE VAREST
      IF ( IR .LE. 0 ) THEN
         VAREST = 0.0D0
         FINEST = 0.0D0
      ENDIF
      FINVAL = 0.0D0
      VARSQR = 0.0D0
      NPTS = MAXPTS/2
      IRESET=0
      DO 100 M = 1,NPTS
         DO 200 K = 1,NDIM
            X(K) = UNI(IRESET)
  200    CONTINUE
         FUN = FUNCTN(NDIM, X)
         DO 300 K = 1,NDIM
            X(K) = 1.0D0 - X(K)
  300    CONTINUE
         FUN = ( FUNCTN(NDIM, X) + FUN )/2.0D0
         FINDIF = ( FUN - FINVAL )/DBLE(M)
         VARSQR = DBLE( M - 2 )*VARSQR/DBLE(M) + FINDIF**2
         FINVAL = FINVAL + FINDIF
  100 CONTINUE
      VARPRD = VAREST*VARSQR
      FINEST = FINEST + ( FINVAL - FINEST )/(1.0D0 + VARPRD)
      IF ( VARSQR .GT. 0.0D0 ) VAREST = (1.0D0 + VARPRD)/VARSQR
      ABSEST = 3.0D0*SQRT( VARSQR/( 1.0D0 + VARPRD ) )
C
      RETURN
      END
      SUBROUTINE RCSWAP(P, Q, A, B, INFIN, N, C)
*
*     Swaps rows and columns P and Q in situ.
*
      DOUBLE PRECISION A(*), B(*), C(*), T
      INTEGER INFIN(*), P, Q, N, I, J, II, JJ
      T = A(P)
      A(P) = A(Q)
      A(Q) = T
      T = B(P)
      B(P) = B(Q)
      B(Q) = T
      J = INFIN(P)
      INFIN(P) = INFIN(Q)
      INFIN(Q) = J
      JJ = (P*(P-1))/2
      II = (Q*(Q-1))/2
      T = C(JJ+P)
      C(JJ+P) = C(II+Q)
      C(II+Q) = T
      DO 100 J = 1, P-1
         T = C(JJ+J)
         C(JJ+J) = C(II+J)
         C(II+J) = T
  100 CONTINUE
      JJ = JJ + P
      DO 200 I = P+1, Q-1
         T = C(JJ+P)
         C(JJ+P) = C(II+I)
         C(II+I) = T
         JJ = JJ + I
  200 CONTINUE
      II = II + Q
      DO 300 I = Q+1, N
         T = C(II+P)
         C(II+P) = C(II+Q)
         C(II+Q) = T
         II = II + I
  300 CONTINUE
C
      RETURN
      END
      REAL FUNCTION RD (X, Y, Z, IER)
C***BEGIN PROLOGUE  RD
C***PURPOSE  Compute the incomplete or complete elliptic integral of the
C            2nd kind.  For X and Y nonnegative, X+Y and Z positive,
C             RD(X,Y,Z) = Integral from zero to infinity of
C                                -1/2     -1/2     -3/2
C                      (3/2)(t+X)    (t+Y)    (t+Z)    dt.
C            If X or Y is zero, the integral is complete.
C***LIBRARY   SLATEC
C***CATEGORY  C14
C***TYPE      SINGLE PRECISION (RD-S, DRD-D)
C***KEYWORDS  COMPLETE ELLIPTIC INTEGRAL, DUPLICATION THEOREM,
C             INCOMPLETE ELLIPTIC INTEGRAL, INTEGRAL OF THE SECOND KIND,
C             TAYLOR SERIES
C***AUTHOR  Carlson, B. C.
C             Ames Laboratory-DOE
C             Iowa State University
C             Ames, IA  50011
C           Notis, E. M.
C             Ames Laboratory-DOE
C             Iowa State University
C             Ames, IA  50011
C           Pexton, R. L.
C             Lawrence Livermore National Laboratory
C             Livermore, CA  94550
C***DESCRIPTION
C
C   1.     RD
C          Evaluate an INCOMPLETE (or COMPLETE) ELLIPTIC INTEGRAL
C          of the second kind
C          Standard FORTRAN function routine
C          Single precision version
C          The routine calculates an approximation result to
C          RD(X,Y,Z) = Integral from zero to infinity of
C                              -1/2     -1/2     -3/2
C                    (3/2)(t+X)    (t+Y)    (t+Z)    dt,
C          where X and Y are nonnegative, X + Y is positive, and Z is
C          positive.  If X or Y is zero, the integral is COMPLETE.
C          The duplication theorem is iterated until the variables are
C          nearly equal, and the function is then expanded in Taylor
C          series to fifth order.
C
C   2.     Calling Sequence
C
C          RD( X, Y, Z, IER )
C
C          Parameters on Entry
C          Values assigned by the calling routine
C
C          X      - Single precision, nonnegative variable
C
C          Y      - Single precision, nonnegative variable
C
C                   X + Y is positive
C
C          Z      - Real, positive variable
C
C
C
C          On Return     (values assigned by the RD routine)
C
C          RD     - Real approximation to the integral
C
C
C          IER    - Integer
C
C                   IER = 0 Normal and reliable termination of the
C                           routine.  It is assumed that the requested
C                           accuracy has been achieved.
C
C                   IER >  0 Abnormal termination of the routine
C
C
C          X, Y, Z are unaltered.
C
C   3.    Error Messages
C
C         Value of IER assigned by the RD routine
C
C                  Value Assigned         Error Message Printed
C                  IER = 1                MIN(X,Y) .LT. 0.0E0
C                      = 2                MIN(X + Y, Z ) .LT. LOLIM
C                      = 3                MAX(X,Y,Z) .GT. UPLIM
C
C
C   4.     Control Parameters
C
C                  Values of LOLIM, UPLIM, and ERRTOL are set by the
C                  routine.
C
C          LOLIM and UPLIM determine the valid range of X, Y, and Z
C
C          LOLIM  - Lower limit of valid arguments
C
C                    Not less  than 2 / (machine maximum) ** (2/3).
C
C          UPLIM  - Upper limit of valid arguments
C
C                    Not greater than (0.1E0 * ERRTOL / machine
C                    minimum) ** (2/3), where ERRTOL is described below.
C                    In the following table it is assumed that ERRTOL
C                    will never be chosen smaller than 1.0E-5.
C
C
C                    Acceptable Values For:   LOLIM      UPLIM
C                    IBM 360/370 SERIES   :   6.0E-51     1.0E+48
C                    CDC 6000/7000 SERIES :   5.0E-215    2.0E+191
C                    UNIVAC 1100 SERIES   :   1.0E-25     2.0E+21
C                    CRAY                 :   3.0E-1644   1.69E+1640
C                    VAX 11 SERIES        :   1.0E-25     4.5E+21
C
C
C          ERRTOL determines the accuracy of the answer
C
C                 The value assigned by the routine will result
C                 in solution precision within 1-2 decimals of
C                 "machine precision".
C
C          ERRTOL    Relative error due to truncation is less than
C                    3 * ERRTOL ** 6 / (1-ERRTOL) ** 3/2.
C
C
C
C              The accuracy of the computed approximation to the inte-
C              gral can be controlled by choosing the value of ERRTOL.
C              Truncation of a Taylor series after terms of fifth order
C              introduces an error less than the amount shown in the
C              second column of the following table for each value of
C              ERRTOL in the first column.  In addition to the trunca-
C              tion error there will be round-off error, but in prac-
C              tice the total error from both sources is usually less
C              than the amount given in the table.
C
C
C
C
C          Sample Choices:  ERRTOL   Relative Truncation
C                                    error less than
C                           1.0E-3    4.0E-18
C                           3.0E-3    3.0E-15
C                           1.0E-2    4.0E-12
C                           3.0E-2    3.0E-9
C                           1.0E-1    4.0E-6
C
C
C                    Decreasing ERRTOL by a factor of 10 yields six more
C                    decimal digits of accuracy at the expense of one or
C                    two more iterations of the duplication theorem.
C
C *Long Description:
C
C   RD Special Comments
C
C
C
C          Check: RD(X,Y,Z) + RD(Y,Z,X) + RD(Z,X,Y)
C          = 3 /  SQRT(X * Y * Z), where X, Y, and Z are positive.
C
C
C          On Input:
C
C          X, Y, and Z are the variables in the integral RD(X,Y,Z).
C
C
C          On Output:
C
C
C          X, Y, and Z are unaltered.
C
C
C
C          ********************************************************
C
C           WARNING: Changes in the program may improve speed at the
C                    expense of robustness.
C
C
C
C    -------------------------------------------------------------------
C
C
C   Special Functions via RD and RF
C
C
C                  Legendre form of ELLIPTIC INTEGRAL of 2nd kind
C                  ----------------------------------------------
C
C
C                                            2         2   2
C                  E(PHI,K) = SIN(PHI) RF(COS (PHI),1-K SIN (PHI),1) -
C
C                     2      3            2         2   2
C                  -(K/3) SIN (PHI) RD(COS (PHI),1-K SIN (PHI),1)
C
C
C                                 2        2           2
C                  E(K) = RF(0,1-K ,1) - (K/3) RD(3,1-K ,1)
C
C
C                         PI/2     2   2      1/2
C                       = INT  (1-K SIN (PHI) )  D PHI
C                          0
C
C
C
C                  Bulirsch form of ELLIPTIC INTEGRAL of 2nd kind
C                  ----------------------------------------------
C
C                                              2 2    2
C                  EL2(X,KC,A,B) = AX RF(1,1+KC X ,1+X ) +
C
C                                              3         2 2    2
C                                 +(1/3)(B-A) X RD(1,1+KC X ,1+X )
C
C
C
C                  Legendre form of alternative ELLIPTIC INTEGRAL of 2nd
C                  -----------------------------------------------------
C                        kind
C                        ----
C
C                            Q     2       2   2  -1/2
C                  D(Q,K) = INT SIN P  (1-K SIN P)     DP
C                            0
C
C
C
C                                   3          2     2   2
C                  D(Q,K) =(1/3)(SIN Q)  RD(COS Q,1-K SIN Q,1)
C
C
C
C
C
C                  Lemniscate constant B
C                  ---------------------
C
C
C
C                       1    2    4 -1/2
C                  B = INT  S (1-S )    DS
C                       0
C
C
C                  B =(1/3)RD (0,2,1)
C
C
C
C
C                  Heuman's LAMBDA function
C                  ------------------------
C
C
C
C                  (PI/2) LAMBDA0(A,B) =
C
C                                       2                2
C                     = SIN(B) (RF(0,COS (A),1)-(1/3) SIN (A) *
C
C                               2              2         2       2
C                      *RD(0,COS (A),1)) RF(COS (B),1-COS (A) SIN (B),1)
C
C                               2       3            2
C                     -(1/3) COS (A) SIN (B) RF(0,COS (A),1) *
C
C                             2         2       2
C                      *RD(COS (B),1-COS (A) SIN (B),1)
C
C
C
C                  Jacobi ZETA function
C                  --------------------
C
C
C                             2                2       2   2
C                  Z(B,K) = (K/3) SIN(B) RF(COS (B),1-K SIN (B),1)
C
C
C                                      2            2
C                             *RD(0,1-K ,1)/RF(0,1-K ,1)
C
C                               2       3          2       2   2
C                            -(K /3) SIN (B) RD(COS (B),1-K SIN (B),1)
C
C
C    -------------------------------------------------------------------
C
C***REFERENCES  B. C. Carlson and E. M. Notis, Algorithms for incomplete
C                 elliptic integrals, ACM Transactions on Mathematical
C                 Software 7, 3 (September 1981), pp. 398-403.
C               B. C. Carlson, Computing elliptic integrals by
C                 duplication, Numerische Mathematik 33, (1979),
C                 pp. 1-16.
C               B. C. Carlson, Elliptic integrals of the first kind,
C                 SIAM Journal of Mathematical Analysis 8, (1977),
C                 pp. 231-242.
C***ROUTINES CALLED  R1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   790801  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   900510  Modify calls to XERMSG to put in standard form.  (RWC)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  RD
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOMC.INC'
      INCLUDE 'DPCOP2.INC'
C
CCCCC CHARACTER*16 XERN3, XERN4, XERN5, XERN6
      INTEGER IER
      REAL LOLIM, UPLIM, EPSLON, ERRTOL
      REAL C1, C2, C3, C4, EA, EB, EC, ED, EF, LAMDA
      REAL MU, POWER4, SIGMA, S1, S2, X, XN, XNDEV
      REAL XNROOT, Y, YN, YNDEV, YNROOT, Z, ZN, ZNDEV, ZNROOT
      LOGICAL FIRST
      SAVE ERRTOL, LOLIM, UPLIM, C1, C2, C3, C4, FIRST
      DATA FIRST /.TRUE./
C
C***FIRST EXECUTABLE STATEMENT  RD
      IF (FIRST) THEN
         ERRTOL = (R1MACH(3)/3.0E0)**(1.0E0/6.0E0)
         LOLIM  = 2.0E0/(R1MACH(2))**(2.0E0/3.0E0)
         TUPLIM = R1MACH(1)**(1.0E0/3.0E0)
         TUPLIM = (0.10E0*ERRTOL)**(1.0E0/3.0E0)/TUPLIM
         UPLIM  = TUPLIM**2.0E0
C
         C1 = 3.0E0/14.0E0
         C2 = 1.0E0/6.0E0
         C3 = 9.0E0/22.0E0
         C4 = 3.0E0/26.0E0
      ENDIF
      FIRST = .FALSE.
C
C         CALL ERROR HANDLER IF NECESSARY.
C
      RD = 0.0E0
      IF( MIN(X,Y).LT.0.0E0) THEN
         IER = 1
CCCCC    WRITE (XERN3, '(1PE15.6)') X
CCCCC    WRITE (XERN4, '(1PE15.6)') Y
         WRITE(ICOUT,1)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,9)X
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,8)Y
         CALL DPWRST('XXX','BUG ')
         RETURN
      ENDIF
    1 FORMAT('***** ERORR FROM RD, THE MINIMUM OF THE FIRST TWO ',
     *       'AGRUMENTS IS NEGATIVE. ***')
    9 FORMAT('***** THE VALUE OF THE FIRST ARGUMENT IS ',E15.8,' ***')
    8 FORMAT('***** THE VALUE OF THE SECOND ARGUMENT IS ',E15.8,' ***')
    7 FORMAT('***** THE VALUE OF THE THIRD ARGUMENT IS ',E15.8,' ***')
C
      IF (MAX(X,Y,Z).GT.UPLIM) THEN
         IER = 3
CCCCC    WRITE (XERN3, '(1PE15.6)') X
CCCCC    WRITE (XERN4, '(1PE15.6)') Y
CCCCC    WRITE (XERN5, '(1PE15.6)') Z
CCCCC    WRITE (XERN6, '(1PE15.6)') UPLIM
         WRITE(ICOUT,2)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,9)X
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,8)Y
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,7)Z
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,6)UPLIM
         CALL DPWRST('XXX','BUG ')
         RETURN
      ENDIF
    2 FORMAT('***** ERORR FROM RD, ONE OF THE THREE ARGUMENTS EXCEEDS',
     *       ' THE LARGEST ALLOWABLE VALUE. ****')
    6 FORMAT('***** THE VALUE OF THE UPPER LIMIT IS ',E15.8,' *****')
C
      IF (MIN(X+Y,Z).LT.LOLIM) THEN
         IER = 2
CCCCC    WRITE (XERN3, '(1PE15.6)') X
CCCCC    WRITE (XERN4, '(1PE15.6)') Y
CCCCC    WRITE (XERN5, '(1PE15.6)') Z
CCCCC    WRITE (XERN6, '(1PE15.6)') LOLIM
         WRITE(ICOUT,3)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,4)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,9)X
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,8)Y
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,7)Z
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,5)LOLIM
         CALL DPWRST('XXX','BUG ')
         RETURN
      ENDIF
    3 FORMAT('***** ERORR FROM RC, THE MINIMUM OF THE SUM OF THE ',
     *       'FIRST TWO ARGUMENTS ')
    4 FORMAT('AND THE THIRD ARGUMENT IS LESS THAN THE LOWER LIMIT. ')
    5 FORMAT('***** THE VALUE OF THE LOWER LIMIT IS ',E15.8,' *****')
C
      IER = 0
      XN = X
      YN = Y
      ZN = Z
      SIGMA = 0.0E0
      POWER4 = 1.0E0
C
   30 MU = (XN+YN+3.0E0*ZN)*0.20E0
      XNDEV = (MU-XN)/MU
      YNDEV = (MU-YN)/MU
      ZNDEV = (MU-ZN)/MU
      EPSLON = MAX(ABS(XNDEV), ABS(YNDEV), ABS(ZNDEV))
      IF (EPSLON.LT.ERRTOL) GO TO 40
      XNROOT = SQRT(XN)
      YNROOT = SQRT(YN)
      ZNROOT = SQRT(ZN)
      LAMDA = XNROOT*(YNROOT+ZNROOT) + YNROOT*ZNROOT
      SIGMA = SIGMA + POWER4/(ZNROOT*(ZN+LAMDA))
      POWER4 = POWER4*0.250E0
      XN = (XN+LAMDA)*0.250E0
      YN = (YN+LAMDA)*0.250E0
      ZN = (ZN+LAMDA)*0.250E0
      GO TO 30
C
   40 EA = XNDEV*YNDEV
      EB = ZNDEV*ZNDEV
      EC = EA - EB
      ED = EA - 6.0E0*EB
      EF = ED + EC + EC
      S1 = ED*(-C1+0.250E0*C3*ED-1.50E0*C4*ZNDEV*EF)
      S2 = ZNDEV*(C2*EF+ZNDEV*(-C3*EC+ZNDEV*C4*EA))
      RD = 3.0E0*SIGMA + POWER4*(1.0E0+S1+S2)/(MU* SQRT(MU))
C
      RETURN
      END
      DOUBLE PRECISION FUNCTION rexp(x)
C-----------------------------------------------------------------------
C            EVALUATION OF THE FUNCTION EXP(X) - 1
C-----------------------------------------------------------------------
C     .. Scalar Arguments ..
      DOUBLE PRECISION x
C     ..
C     .. Local Scalars ..
      DOUBLE PRECISION p1,p2,q1,q2,q3,q4,w
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC abs,exp
C     ..
C     .. Data statements ..
      DATA p1/.914041914819518D-09/,p2/.238082361044469D-01/,
     +     q1/-.499999999085958D+00/,q2/.107141568980644D+00/,
     +     q3/-.119041179760821D-01/,q4/.595130811860248D-03/
C     ..
C     .. Executable Statements ..
C-----------------------
      IF (abs(x).GT.0.15D0) GO TO 10
      rexp = x* (((p2*x+p1)*x+1.0D0)/ ((((q4*x+q3)*x+q2)*x+q1)*x+1.0D0))
      RETURN
C
   10 w = exp(x)
      IF (x.GT.0.0D0) GO TO 20
      rexp = (w-0.5D0) - 0.5D0
      RETURN

   20 rexp = w* (0.5D0+ (0.5D0-1.0D0/w))
      RETURN

      END
      SUBROUTINE RGTCDF(X,ALPHA,BETA,A,B,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE
C              REFLECTED GENERALIZED TOPP AND LEONE DISTRIBUTION.
C              THE CUMULATIVE DISTRIBUTION FUNCTION IS:
C
C                  F(X;ALPHA,BETA,A,B) = 1 -
C                     ((B - X)/(B-A))**BETA*
C                     {ALPHA - (ALPHA-1)*((B-X)/(B-A))}**BETA
C                                    A <= X <= B, BETA > 0,
C                                    0 < ALPHA <= 2
C
C              WITH ALPHA AND BETA DENOTING THE SHAPE PARAMETERS.
C
C     INPUT  ARGUMENTS--X      = THE DOUBLE PRECISION VALUE AT
C                                WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C                     --ALPHA  = THE DOUBLE PRECISION FIRST SHAPE
C                                PARAMETER
C                     --BETA   = THE DOUBLE PRECISION SECOND SHAPE
C                                PARAMETER
C     OUTPUT ARGUMENTS--CDF    = THE DOUBLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE DOUBLE 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--DLOG, DEXP.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN.
C     REFERENCES--KOTZ AND VAN DORP (2004), "BEYOND BETA: OTHER
C                 CONTINUOUS FAMILIES OF DISTRIBUTIONS WITH BOUNDED
C                 SUPPORT AND APPLICATIONS", WORLD SCIENTFIC
C                 PUBLISHING COMPANY, CHAPTER 7.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE:  301-975-2855
C     ORIGINAL VERSION--FEBRUARY  2007.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DOUBLE PRECISION X
      DOUBLE PRECISION ALPHA
      DOUBLE PRECISION BETA
      DOUBLE PRECISION A
      DOUBLE PRECISION B
      DOUBLE PRECISION CDF
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DX
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(B.LT.A)THEN
        TERM1=B
        B=A
        A=TERM1
      ENDIF
C
      IF(X.LT.A)THEN
CCCCC   WRITE(ICOUT,2)
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   WRITE(ICOUT,3)A,B
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   WRITE(ICOUT,46)X
CCCCC   CALL DPWRST('XXX','BUG ')
        CDF=0.0D0
        GOTO9000
      ELSEIF(X.GT.B)THEN
        CDF=1.0D0
        GOTO9000
      ELSEIF(ALPHA.LE.0.0D0 .OR. ALPHA.GT.2.0)THEN
        WRITE(ICOUT,12)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)BETA
        CALL DPWRST('XXX','BUG ')
        CDF=0.0D0
        GOTO9000
      ELSEIF(BETA.LE.0.0D0)THEN
        WRITE(ICOUT,14)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)BETA
        CALL DPWRST('XXX','BUG ')
        CDF=0.0D0
        GOTO9000
      ELSEIF(B.EQ.A)THEN
        WRITE(ICOUT,16)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,48)A
        CALL DPWRST('XXX','BUG ')
        CDF=0.0D0
      ENDIF
CCCC2 FORMAT('***** ERROR--THE FIRST ARGUMENT TO RGTCDF IS OUTSIDE THE')
CCCC3 FORMAT('      (',G15.7,',',G15.7,') INTERVAL.')
   12 FORMAT('***** ERROR--THE SECOND ARGUMENT TO RGTCDF IS ',
     1       'OUTSIDE THE [0,2) INTERVAL')
   14 FORMAT('***** ERROR--THE THIRD ARGUMENT TO RGTCDF IS ',
     1       'IS NON-POSITIVE.')
   16 FORMAT('***** ERROR--THE LOWER AND UPPER LIMITS FOR RGTCDF ',
     1       'ARE EQUAL')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
   48 FORMAT('***** THE VALUE OF THE LIMIT IS ',G15.7)
C
C-----START POINT-----------------------------------------------------
C
      DX=(B-X)/(B-A)
      IF(X.LE.A)THEN
        CDF=0.0D0
      ELSEIF(X.GE.B)THEN
        CDF=1.0D0
      ELSE
        DTERM1=BETA*DLOG(DX)
        DTERM2=BETA*DLOG(ALPHA - (ALPHA-1.0D0)*DX)
        CDF=1.0D0 - DEXP(DTERM1 + DTERM2)
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      DOUBLE PRECISION FUNCTION RGTFUN(ALPHA,X)
C
C     PURPOSE--THIS ROUTINE IS USED IN FINDING THE ROOT OF THE
C              FOLLOWING EQUATION:
C
C              G(alpha) = {(N/SUM[i=1 to m]
C              [n(i)*LOG(1/(alpha*y(i)-(alpha-1)*y(i)**2))] - 1}*
C              SUM[i=1 to m][n(i)*(1 - y(i))/(alpha - (alpha-1)*y(i))]
C              + SUM[i=1 to m][n(i)*(1 - 2*y(i))/
C              (alpha - 2*(alpha-1)*y(i))]
C
C              WHERE
C
C              M       = NUMBER OF GROUPS
C              n(i)    = NUMBER OF OBSERVATIONS IN GROUP i
C              N       = TOTAL NUMBER OF OBSERVATIONS
C              y(i)    = 1 - XBAR(i)
C              XBAR(i) = MEAN OF THE iTH INTERVAL
C
C              THIS EQUATION IS USED TO PROVIDE AN APPROXIMATE
C              MAXIMUM LIKELIHOOD SOLUTION FOR THE
C              REFLECTED GENERALIZED TOPP AND LEONE DISTRIBUTION.
C
C              THIS ALGORITHM CAN IN FACT BE USED FOR RAW DATA,
C              GROUPS WITH EQUAL BIN SIZES, AND GROUPS WITH
C              UNEQUAL BIN SIZES.
C
C     EXAMPLE--REFLECTED GENERALIZED TOPP AND LEONE  MLE Y
C            --REFLECTED GENERALIZED TOPP AND LEONE  MLE Y X
C            --REFLECTED GENERALIZED TOPP AND LEONE  MLE Y XLOW XHIGH
C     REFERENCE--KOTZ AND VAN DORP (2004), "BEYOND BETA: OTHER
C                CONTINUOUS FAMILIES OF DISTRIBUTIONS WITH BOUNDED
C                SUPPORT AND APPLICATIONS", WORLD SCIENTIFIC,
C                PP. 211-213.
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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2007/7
C     ORIGINAL VERSION--JULY       2007.
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION ALPHA
      DOUBLE PRECISION X(*)
C
      COMMON/RGTCOM/NTOT,NCLASS,MAXGRP
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DSUM2
      DOUBLE PRECISION DSUM3
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DXI
      DOUBLE PRECISION DNI
      DOUBLE PRECISION DYI
      DOUBLE PRECISION DN
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      DSUM1=0.0D0
      DSUM2=0.0D0
      DSUM3=0.0D0
C
      DN=DBLE(NTOT)
      DO100I=1,NCLASS
        DXI=X(I)
        DNI=X(I+MAXGRP)
C
        DYI=1.0D0 - DXI
        DTERM1=ALPHA*DYI - (ALPHA-1.0D0)*DYI**2
C
        DSUM1=DSUM1 + DNI*DLOG(1.0D0/DTERM1)
        DSUM2=DSUM2 + DNI*(1.0D0 - DYI)/(ALPHA-(ALPHA-1.0D0)*DYI)
        DSUM3=DSUM3 + DNI*(1.0D0 - 2.0D0*DYI)/
     1        (ALPHA-2.0D0*(ALPHA-1.0D0)*DYI)
C
  100 CONTINUE
C
      RGTFUN=((DN/DSUM1) - 1.0D0)*DSUM2 + DSUM3
C
      RETURN
      END
      SUBROUTINE RGTLI1(Y,N,
     1                  A,B,ALPHA,BETA,
     1                  ALIK,AIC,AICC,BIC,
     1                  ISUBRO,IBUGA3,IERROR)
C
C     PURPOSE--THIS ROUTINE COMPUTES THE LOG-LIKIHOOD FUNCTION FOR
C              THE REFLECTED GENERALIZED TOPP AND LEONE DISTRIBUTION.
C              THIS IS FOR THE RAW DATA CASE (I.E., NO GROUPING AND NO
C              CENSORING).
C
C              NOTE THAT THE LOWER AND UPPER LIMITS MUST BE EXPLICITLY
C              GIVEN.
C
C     REFERENCE --KOTZ AND VAN DORP (2004), "BEYOND BETA: OTHER
C                 CONTINUOUS FAMILIES OF DISTRIBUTIONS WITH
C                 BOUNDED SUPPORT AND APPLICATIONS", WORLD
C                 SCIENTIFIC PUBLISHING CO., PP. 211-213.
C     WRITTEN BY--ALAN HECKERT
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2899
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2013/06
C     ORIGINAL VERSION--JUNE      2013.
C
      CHARACTER*4 ISUBRO
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 IWRITE
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 ISTEPN
C
      DOUBLE PRECISION DA
      DOUBLE PRECISION DB
      DOUBLE PRECISION DALPHA
      DOUBLE PRECISION DBETA
      DOUBLE PRECISION DN
      DOUBLE PRECISION DNP
      DOUBLE PRECISION DLIK
      DOUBLE PRECISION DPDF
C
C---------------------------------------------------------------------
C
      DIMENSION Y(*)
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='RGTL'
      ISUBN2='I1  '
      IWRITE='OFF'
      IERROR='NO'
C
      ALIK=CPUMIN
      AIC=CPUMIN
      AICC=CPUMIN
      BIC=CPUMIN
C
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'TLI1')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,51)
   51   FORMAT('**** AT THE BEGINNING OF RGTLI1--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,52)IBUGA3,ISUBRO,N,A,B,ALPHA,BETA
   52   FORMAT('IBUGA3,ISUBRO,N,A,B,ALPHA,BETA = ',2(A4,2X),I8,4G15.7)
        CALL DPWRST('XXX','WRIT')
        DO56I=1,MIN(N,100)
          WRITE(ICOUT,57)I,Y(I)
   57     FORMAT('I,Y(I) = ',I8,G15.7)
          CALL DPWRST('XXX','WRIT')
   56   CONTINUE
      ENDIF
C
C               ******************************************
C               **  STEP 1--                            **
C               **  COMPUTE LIKELIHOOD FUNCTION         **
C               ******************************************
C
      ISTEPN='1'
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'TLI1')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      CALL MINIM(Y,N,IWRITE,YMIN,IBUGA3,IERROR)
      CALL MAXIM(Y,N,IWRITE,YMAX,IBUGA3,IERROR)
      IF(A.GE.YMIN .OR. B.LE.YMAX)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,101)
  101   FORMAT('**** ERROR IN REFLECTED GENERALIZED TOPP AND LEONE ',
     1         'LOG-LIKELIHOOD--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,103)
  103   FORMAT('     INVALID LIMITS:')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,105)A
  105   FORMAT('     LOWER LIMIT    = ',G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,106)YMIN
  106   FORMAT('     DATA MINIMUM   = ',G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,107)B
  107   FORMAT('     UPPER LIMIT    = ',G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,108)YMAX
  108   FORMAT('     DATA MAXIMUM   = ',G15.7)
        CALL DPWRST('XXX','WRIT')
        IERROR='YES'
        GOTO9000
      ENDIF
C
C     COMPUTE THE LOG-LIKELIHOOD BY BRUTE FORCE (I.E., SUM  OF LOG OF
C     PDF VALUES.
C
      DALPHA=DBLE(ALPHA)
      DBETA=DBLE(BETA)
      DA=DBLE(A)
      DB=DBLE(B)
      DN=DBLE(N)
C
      DLIK=0.0D0
      DO1010I=1,N
        CALL RGTPDF(DBLE(Y(I)),DALPHA,DBETA,DA,DB,DPDF)
        IF(DPDF.GE.0.0D0)DLIK=DLIK + DLOG(DPDF)
 1010 CONTINUE
C
      ALIK=REAL(DLIK)
      DNP=2.0D0
      AIC=REAL(-2.0D0*DLIK + 2.0D0*DNP)
      DTERM3=(2.0D0*DNP*(DNP+1.0D0))/(DN-DNP-1.0D0)
      AICC=REAL(-2.0D0*DLIK + 2.0D0*DNP + DTERM3)
      BIC=REAL(-2.0D0*DLIK + DNP*LOG(DN))
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'TLI1')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9011)
 9011   FORMAT('**** AT THE END OF RGTLI1--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9057)ALIK,AIC,AICC,BIC
 9057   FORMAT('ALIK,AIC,AICC,BIC = ',4G15.7)
        CALL DPWRST('XXX','WRIT')
      ENDIF
C
      RETURN
      END
      SUBROUTINE RGTML1(Y,XLOW,XHIGH,N,NUMV,MAXNXT,NTOT,
     1                  DTEMP1,TEMP1,TEMP2,TEMP3,TEMP4,
     1                  XMIN,XMAX,XMEAN,XSD,
     1                  ALPHSV,A,B,
     1                  ALPHML,BETAML,ALOWML,AUPPML,
     1                  ISUBRO,IBUGA3,IERROR)
C
C     PURPOSE--THIS ROUTINE COMPUTES THE MAXIMUM LIKELIHOOD
C              ESTIMATES FOR THE REFLECTED GENERALIZED TOPP AND LEONE
C              DISTRIBUTION.
C
C              THE MAXIMUM LIKELIHOOD ESTIMATE OF BETA IS:
C
C                  BETAHAT = N/[SUM[i=1 to M]
C                  [n(i)*LOG(1/(ALPHA*Y(i) - (ALPHA - 1)Y(i)**2)]
C
C              WITH N(i) DENOTING THE SAMPLE SIZE OF GROUP i
C              AND Y(I) DENOTING 1 - XBAR(i) WHERE XBAR(i) IS
C              THE MEAN OF GROUP i.
C
C              ALPHA IS THE SOLUTION OF THE EQUATION
C
C              [N/[SUM[i=1 to M]
C              [n(i)*LOG(1/(ALPHA*Y(i) - (ALPHA - 1)Y(i)**2)]]*
C              SUM[i=1 to m][n(i)*(1 - y(i))/(ALPHA - (ALPHA - 1)*
C              Y(i)] +
C              SUM[i=1 to m][n(i)*(1 - 2*y(i))/(ALPHA -
C              2*(ALPHA - 1)*Y(i)]
C
C     EXAMPLE--REFLECTED GENERALIZED TOPP AND LEONE MAXIMUM LIKELIHOOD Y
C     REFERENCE --KOTZ AND VAN DORP (2004), "BEYOND BETA: OTHER
C                 CONTINUOUS FAMILIES OF DISTRIBUTIONS WITH
C                 BOUNDED SUPPORT AND APPLICATIONS", WORLD
C                 SCIENTIFIC PUBLISHING CO., PP. 211-213.
C     WRITTEN BY--ALAN HECKERT
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2899
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2010/07
C     ORIGINAL VERSION--JULY      2010. EXTRACTED AS A SEPARATE
C                                       SUBROUTINE (FROM DPMLRG)
C
      CHARACTER*4 ISUBRO
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 IWRITE
      CHARACTER*40 IDIST
C
      DIMENSION Y(*)
      DIMENSION XLOW(*)
      DIMENSION XHIGH(*)
      DIMENSION TEMP1(*)
      DIMENSION TEMP2(*)
      DIMENSION TEMP3(*)
      DIMENSION TEMP4(*)
      DOUBLE PRECISION DTEMP1(*)
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 ISTEPN
C
      INTEGER IFLAG
C
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DTERM1
C
      DOUBLE PRECISION RGTFUN
      EXTERNAL RGTFUN
C
      COMMON/RGTCOM/NTOT2,NCLASS,MAXGRP
C
      DOUBLE PRECISION DA
      DOUBLE PRECISION DAE
      DOUBLE PRECISION DRE
      DOUBLE PRECISION DXSTRT
      DOUBLE PRECISION DXLOW
      DOUBLE PRECISION DXUP
C
      DOUBLE PRECISION DXI
      DOUBLE PRECISION DNI
      DOUBLE PRECISION DYI
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='RGTM'
      ISUBN2='L1  '
      IWRITE='OFF'
      IERROR='NO'
C
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'TML1')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,51)
   51   FORMAT('**** AT THE BEGINNING OF RGTML1--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,52)IBUGA3,ISUBRO,N,NUMV,MAXGRP
   52   FORMAT('IBUGA3,ISUBRO,N,NUMV,MAXGRP = ',A4,2X,A4,2X,3I8)
        CALL DPWRST('XXX','WRIT')
        DO56I=1,MIN(N,100)
          WRITE(ICOUT,57)I,Y(I)
   57     FORMAT('I,Y(I) = ',I8,G15.7)
          CALL DPWRST('XXX','WRIT')
   56   CONTINUE
      ENDIF
C
C               ******************************************
C               **  STEP 1--                            **
C               **  CARRY OUT CALCULATIONS              **
C               **  FOR REFLECTED GENERALIZED TOPP AND  **
C               **  LEONE MLE ESTIMATE                  **
C               ******************************************
C
      ISTEPN='1'
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'TML1')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IDIST='REFLECTED GENERALIZED TOPP AND LEONE'
      MAXGRP=MAXNXT/2
      IF(NUMV.EQ.1)THEN
        IFLAG=0
        CALL SUMRAW(Y,N,IDIST,IFLAG,
     1              XMEAN,XVAR,XSD,XMIN,XMAX,
     1              ISUBRO,IBUGA3,IERROR)
        IF(IERROR.EQ.'YES')GOTO9000
        CALL SORT(Y,N,Y)
        DO180I=1,N
          DTEMP1(I)=DBLE(Y(I))
          DTEMP1(I+MAXGRP)=1.0D0
  180   CONTINUE
        NTOT2=N
        NCLASS=N
C
      ELSEIF(NUMV.EQ.2)THEN
        IFLAG1=1
        IFLAG2=0
        CALL SUMGRP(Y,XLOW,N,IDIST,IFLAG1,IFLAG2,
     1              TEMP1,TEMP2,TEMP3,MAXNXT,
     1              XMEAN,XVAR,XSD,XMIN,XMAX,NTOT,
     1              ISUBRO,IBUGA3,IERROR)
        IF(IERROR.EQ.'YES')GOTO9000
        CALL SORTC(XLOW,Y,N,TEMP1,TEMP2)
        DO220I=1,N
          XLOW(I)=TEMP1(I)
          Y(I)=TEMP2(I)
  220   CONTINUE
        DELTA=(XLOW(2) - XLOW(1))/2.0
C
        NCLASS=N
        NTOT2=NTOT
        DO230I=1,NCLASS
          DTEMP1(I)=DBLE(XLOW(I))
          DTEMP1(I+MAXGRP)=DBLE(Y(I))
  230   CONTINUE
C
      ELSEIF(NUMV.EQ.3)THEN
        IFLAG1=1
        IFLAG2=0
        CALL SUMGR2(Y,XLOW,XHIGH,N,IDIST,IFLAG1,IFLAG2,
     1              TEMP1,TEMP2,TEMP3,MAXNXT,
     1              XMEAN,XVAR,XSD,XMIN,XMAX,NTOT,
     1              ISUBRO,IBUGA3,IERROR)
        IF(IERROR.EQ.'YES')GOTO9000
        CALL SORTC(XLOW,Y,N,TEMP1,TEMP2)
        CALL SORTC(XLOW,XHIGH,N,TEMP3,TEMP4)
        DO320I=1,N
          XLOW(I)=TEMP1(I)
          XHIGH(I)=TEMP4(I)
          Y(I)=TEMP2(I)
  320   CONTINUE
C
        DO340I=1,N
          DTEMP1(I)=DBLE((XHIGH(I) + XLOW(I))/2.0)
          DTEMP1(I+MAXGRP)=DBLE(Y(I))
  340   CONTINUE
C
        NCLASS=N
      ELSE
        IERROR='YES'
        GOTO9000
      ENDIF
C
C     NOW PERFORM THE MAXIMUM LIKELIHOOD ESTIMATION
C
C     STEP 1: NEED TO SCALE IF NOT WITHIN (0,1) INTERVAL.
C
C             IF USER SPECIFIES LIMITS, THEN USE THOSE.  IF NOT,
C             USE DATA MINIMUM/MAXIMUM.
C
      IFIX=1
C
      IF(A.NE.CPUMIN .AND. B.NE.CPUMIN .AND.
     1   A.LE.XMIN .AND. B.GE.XMAX) THEN
        IFIX=0
        ZLOC=A
        ZUPPLM=B
        ZSCALE=ZUPPLM - ZLOC
        DO2110I=1,NCLASS
          DTEMP1(I)=(DTEMP1(I) - DBLE(A))/DBLE(ZSCALE)
 2110   CONTINUE
      ELSEIF(XMIN.LT.0.0 .OR. XMAX.GT.1.0)THEN
        EPS=(XMAX-XMIN)*0.001
        ZLOC=XMIN - EPS
        ZUPPLM=XMAX+EPS
        ZSCALE=ZUPPLM - ZLOC
        DO2120I=1,NCLASS
          DTEMP1(I)=(DTEMP1(I) - DBLE(ZLOC))/DBLE(ZSCALE)
 2120   CONTINUE
      ELSE
        ZLOC=0.0
        ZUPPLM=1.0
        ZSCALE=1.0
      ENDIF
C
C     STEP 2: FIND ML ESTIMATE FOR ALPHA
C
      NTOT2=NTOT
      DXSTRT=1.5D0
      IF(ALPHSV.GE.0.0 .AND. ALPHSV.LE.2.0)DXSTRT=DBLE(ALPHSV)
      DXLOW=0.0D0
      DXUP=2.0D0
      DAE=2.0*0.000001D0*DXSTRT
      DRE=DAE
      IFLAG=0
      ITBRAC=0
      CALL DFZER2(RGTFUN,DXLOW,DXUP,DXSTRT,DRE,DAE,IFLAG,DTEMP1)
      ALPHML=REAL(DXLOW)
C
C     STEP 3: FIND ML ESTIMATE FOR BETA
C
      DSUM1=0.0D0
      DA=DBLE(ALPHML)
      DO2210I=1,NCLASS
        DXI=DTEMP1(I)
        DNI=DTEMP1(I+MAXGRP)
        DYI=1.0D0 - DXI
        DTERM1=1.0D0/(DA*DYI - (DA-1.0D0)*DYI**2)
        DSUM1=DSUM1 + DNI*DLOG(DTERM1)
 2210 CONTINUE
      BETAML=DBLE(NTOT2)/DSUM1
C
      ALOWML=ZLOC
      AUPPML=ZUPPLM
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'TML1')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9011)
 9011   FORMAT('**** AT THE END OF RGTML1--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9055)N,XMEAN,XSD,XMIN,XMAX
 9055   FORMAT('N,XMEAN,XSD,XMIN,XMAX = ',I8,4G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9057)ALPHML,BETAML,ALOWML,AUPPML
 9057   FORMAT('ALPHML,BETAML,ALOWML,AUPPML = ',4G15.7)
        CALL DPWRST('XXX','WRIT')
      ENDIF
C
      RETURN
      END
      SUBROUTINE RGTPDF(X,ALPHA,BETA,A,B,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE
C              REFLECTED GENERALIZED TOPP AND LEONE DISTRIBUTION.
C              THE PROBABILITY DENSITY FUNCTION IS:
C
C                  f(X;ALPHA,BETA,A,B) = (BETA/(B-A))*
C                     ((B-X)/(B-A))**(BETA-1)*
C                     {ALPHA - (ALPHA-1)*((B-X)/(B-A))}**(BETA-1)*
C                     {ALPHA - 2*(ALPHA-1)*((B-X)/(B-A))}
C                     A <= X <= B, BETA > 0, 0 < ALPHA <= 2
C
C              WITH ALPHA AND BETA DENOTING THE SHAPE PARAMETERS.
C
C     INPUT  ARGUMENTS--X      = THE DOUBLE PRECISION VALUE AT
C                                WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                     --ALPHA  = THE DOUBLE PRECISION FIRST SHAPE
C                                PARAMETER
C                     --BETA   = THE DOUBLE PRECISION SECOND SHAPE
C                                PARAMETER
C     OUTPUT ARGUMENTS--PDF    = THE DOUBLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE DOUBLE 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--DLOG, DEXP.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN.
C     REFERENCES--KOTZ AND VAN DORP (2004), "BEYOND BETA: OTHER
C                 CONTINUOUS FAMILIES OF DISTRIBUTIONS WITH BOUNDED
C                 SUPPORT AND APPLICATIONS", WORLD SCIENTFIC
C                 PUBLISHING COMPANY, CHAPTER 7.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE:  301-975-2855
C     ORIGINAL VERSION--FEBRUARY  2007.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION X
      DOUBLE PRECISION ALPHA
      DOUBLE PRECISION BETA
      DOUBLE PRECISION A
      DOUBLE PRECISION B
      DOUBLE PRECISION PDF
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
      DOUBLE PRECISION DX
      DOUBLE PRECISION DEPS
C
      INCLUDE 'DPCOP2.INC'
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(B.LT.A)THEN
        TERM1=B
        B=A
        A=TERM1
      ENDIF
C
      IF(X.LT.A .OR. X.GT.B)THEN
        WRITE(ICOUT,2)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,3)A,B
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        PDF=0.0D0
        GOTO9000
      ELSEIF(ALPHA.LE.0.0D0 .OR. ALPHA.GT.2.0)THEN
        WRITE(ICOUT,12)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)BETA
        CALL DPWRST('XXX','BUG ')
        PDF=0.0D0
        GOTO9000
      ELSEIF(BETA.LE.0.0D0)THEN
        WRITE(ICOUT,14)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)BETA
        CALL DPWRST('XXX','BUG ')
        PDF=0.0D0
        GOTO9000
      ELSEIF(B.EQ.A)THEN
        WRITE(ICOUT,16)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,48)A
        CALL DPWRST('XXX','BUG ')
        PDF=0.0D0
      ENDIF
    2 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO RGTPDF IS ',
     1       'OUTSIDE THE')
    3 FORMAT('      (',G15.7,',',G15.7,') INTERVAL.')
   12 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO RGTPDF IS ',
     1       'OUTSIDE THE [0,2) INTERVAL')
   14 FORMAT('***** ERROR--THE THIRD INPUT ARGUMENT TO RGTPDF IS ',
     1       'IS NON-POSITIVE.')
   16 FORMAT('***** ERROR--THE LOWER AND UPPER LIMITS FOR RGTPDF ',
     1       'ARE EQUAL')
   22 FORMAT('***** ERROR--FOR RGTPDF, WHEN BETA < 1, X SHOULD NOT',
     1       ' EQUAL THE UPPER LIMIT')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
   48 FORMAT('***** THE VALUE OF THE LIMIT IS ',G15.7)
   49 FORMAT('***** THE VALUE OF X IS ',G15.7)
   50 FORMAT('***** THE VALUE OF THE UPPER LIMIT IS ',G15.7)
C
C-----START POINT-----------------------------------------------------
C
      DX=(B-X)/(B-A)
      DEPS=1.0D-7
C
      IF(X.LE.A)THEN
        PDF=BETA*(2.0D0 - ALPHA)/(B-A)
      ELSEIF(X.GE.B)THEN
        IF(ABS(BETA-1.0D0).LE.DEPS)THEN
          PDF=BETA*ALPHA/(B-A)
        ELSEIF(BETA-1.0D0.GT.DEPS)THEN
          PDF=0.0D0
        ELSE
          WRITE(ICOUT,22)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,49)X
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,50)BETA
          CALL DPWRST('XXX','BUG ')
          PDF=0.0D0
          GOTO9000
        ENDIF
      ELSE
        DTERM1=DLOG(BETA) - DLOG(B-A)
        DTERM2=(BETA-1.0D0)*DLOG(DX)
        DTERM3=(BETA-1.0D0)*DLOG(ALPHA - (ALPHA-1.0D0)*DX)
        DTERM4=DLOG(ALPHA - 2.0D0*(ALPHA-1.0D0)*DX)
        PDF=DEXP(DTERM1 + DTERM2 + DTERM3 + DTERM4)
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE RGTPPF(P,ALPHA,BETA,PPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE
C              REFLECTED GENERALIZED TOPP AND LEONE DISTRIBUTION.
C              THE PERCENT POINT FUNCTION IS:
C
C              G(P;ALPHA,BETA,A,B) =
C                  1-{ALPHA-SQRT(ALPHA**2-4*(ALPHA-1)*(1-P)**(1/BETA)}/
C                  {2*(ALPHA-1)}            FOR 1 < ALPHA <= 2
C                   1 - (1-P)**(1/BETA)     FOR ALPHA = 1
C                  1-{ALPHA+SQRT(ALPHA**2-4*(ALPHA-1)*(1-P)**(1/BETA)}/
C                  {2*(ALPHA-1)}            FOR 0 < ALPHA <= 2
C                  A <= X <= B, BETA > 0, 0 < ALPHA <= 2
C
C              WITH ALPHA AND BETA DENOTING THE SHAPE PARAMETERS.
C
C     INPUT  ARGUMENTS--X      = THE DOUBLE PRECISION VALUE AT
C                                WHICH THE PERCENT POINT
C                                FUNCTION IS TO BE EVALUATED.
C                     --ALPHA  = THE DOUBLE PRECISION FIRST SHAPE
C                                PARAMETER
C                     --BETA   = THE DOUBLE PRECISION SECOND SHAPE
C                                PARAMETER
C     OUTPUT ARGUMENTS--PPF    = THE DOUBLE PRECISION PERCENT POINT
C                                FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION PERCENT POINT FUNCTION VALUE PPF.
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--DLOG, DEXP.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN.
C     REFERENCES--KOTZ AND VAN DORP (2004), "BEYOND BETA: OTHER
C                 CONTINUOUS FAMILIES OF DISTRIBUTIONS WITH BOUNDED
C                 SUPPORT AND APPLICATIONS", WORLD SCIENTFIC
C                 PUBLISHING COMPANY, CHAPTER 7.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE:  301-975-2855
C     ORIGINAL VERSION--FEBRUARY  2007.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION P
      DOUBLE PRECISION ALPHA
      DOUBLE PRECISION BETA
      DOUBLE PRECISION PPF
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DEPS
C
      INCLUDE 'DPCOP2.INC'
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(P.LT.0.0D0 .OR. P.GT.1.0D0)THEN
        WRITE(ICOUT,2)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)P
        CALL DPWRST('XXX','BUG ')
        PPF=0.0D0
        GOTO9000
      ELSEIF(ALPHA.LE.0.0D0 .OR. ALPHA.GT.2.0)THEN
        WRITE(ICOUT,12)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)BETA
        CALL DPWRST('XXX','BUG ')
        PPF=0.0D0
        GOTO9000
      ELSEIF(BETA.LE.0.0D0)THEN
        WRITE(ICOUT,14)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)BETA
        CALL DPWRST('XXX','BUG ')
        PPF=0.0D0
        GOTO9000
      ENDIF
    2 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO RGTPPF IS ',
     1       'OUTSIDE THE (0,1) INTERVAL.')
   12 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO RGTPPF IS ',
     1       'OUTSIDE THE [0,2) INTERVAL')
   14 FORMAT('***** ERROR--THE THIRD INPUT ARGUMENT TO RGTPPF IS ',
     1       'IS NON-POSITIVE.')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
C
C-----START POINT-----------------------------------------------------
C
      DEPS=1.0D-7
      IF(P.LE.0.0D0)THEN
        PPF=0.0D0
      ELSEIF(P.GE.1.0D0)THEN
        PPF=1.0D0
      ELSE
        IF(DABS(ALPHA-1.0D0).LE.DEPS)THEN
          PPF=1.0D0 - (1.0D0 - P)**(1.0D0/BETA)
        ELSEIF(DABS(ALPHA-1.0D0).GT.DEPS)THEN
          DTERM1=ALPHA - DSQRT(ALPHA**2 - 4.0D0*(ALPHA - 1.0D0)*
     1           (1.0D0 - P)**(1.0D0/BETA))
          DTERM2=2.0D0*(ALPHA - 1.0D0)
          PPF=1.0D0 - DTERM1/DTERM2
        ELSEIF(DABS(ALPHA-1.0D0).LT.DEPS)THEN
          DTERM1=ALPHA + DSQRT(ALPHA**2 - 4.0D0*(ALPHA - 1.0D0)*
     1           (1.0D0 - P)**(1.0D0/BETA))
          DTERM2=2.0D0*(ALPHA - 1.0D0)
          PPF=1.0D0 - DTERM1/DTERM2
        ENDIF
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE RGTRAN(N,ALPHA,BETA,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE REFLECTED GENERALIZED TOPP AND LEONE
C              DISTRIBUTION WITH SHAPE PARAMETERS ALPHA AND BETA.
C
C              THE PROBABILITY DENSITY FUNCTION IS:
C
C                  f(X;ALPHA,BETA,A,B) = (BETA/(B-A))*
C                     ((B-X)/(B-A))**(BETA-1)*
C                     {ALPHA - (ALPHA-1)*((B-X)/(B-A))}**(BETA-1)*
C                     {ALPHA - 2*(ALPHA-1)*((B-X)/(B-A))}
C                     A <= X <= B, BETA > 0, 0 < ALPHA <= 2
C
C              WITH ALPHA AND BETA DENOTING THE SHAPE PARAMETERS.
C
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --ALPHA  = THE DOUBLE PRECISION FIRST SHAPE
C                                PARAMETER
C                     --BETA   = THE DOUBLE PRECISION VALUE OF THE
C                                SHAPE PARAMETER BETA.
C                                BETA SHOULD BE IN THE RANGE (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 REFLECTED GENERALIZED TOPP AND LEONE
C             DISTRIBUTION WITH SHAPE PARAMETERS ALPHA AND BETA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN, RGTPPF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--KOTZ AND VAN DORP (2004), "BEYOND BETA: OTHER
C                 CONTINUOUS FAMILIES OF DISTRIBUTIONS WITH BOUNDED
C                 SUPPORT AND APPLICATIONS", WORLD SCIENTFIC
C                 PUBLISHING COMPANY, CHAPTER 7.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHMOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2007.2
C     ORIGINAL VERSION--FEBRUARY  2007.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DOUBLE PRECISION ALPHA
      DOUBLE PRECISION BETA
      DOUBLE PRECISION DTEMP
      DIMENSION X(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)THEN
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,6)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
    5 FORMAT('***** ERROR--THE REQUESTED NUMBER OF ',
     1'REFLECTED GENERALIZED TOPP AND LEONE')
    6 FORMAT('      RANDOM NUMBERS IS NON-POSITIVE')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8)
C
      IF(BETA.LE.0.0D0)THEN
        WRITE(ICOUT,201)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,203)BETA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
  201 FORMAT('***** ERROR--THE BETA SHAPE PARAMETER IS ',
     1       'NON-POSITIVE.')
  203 FORMAT('      THE VALUE OF BETA IS ',G15.7)
C
      IF(ALPHA.LE.0.0D0 .OR. ALPHA.GT.2.0D0)THEN
        WRITE(ICOUT,301)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,303)ALPHA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
  301 FORMAT('***** ERROR--THE ALPHA SHAPE PARAMETER IS ',
     1       'OUTSIDE THE [0,2) INTERVAL.')
  303 FORMAT('      THE VALUE OF ALPHA IS ',G15.7)
C
C     GENERATE N UNIFORM (0,1) RANDOM NUMBERS;
C
      CALL UNIRAN(N,ISEED,X)
C
C     GENERATE N REFLECTED GENERALIZED TOPP AND LEONE DISTRIBUTION
C     RANDOM NUMBERS USING THE PERCENT POINT FUNCTION TRANSFORMATION
C     METHOD.
C
      DO300I=1,N
        ZTEMP=X(I)
        CALL RGTPPF(DBLE(ZTEMP),ALPHA,BETA,DTEMP)
        X(I)=REAL(DTEMP)
  300 CONTINUE
C
 9000 CONTINUE
      RETURN
      END
      REAL FUNCTION RF (X, Y, Z, IER)
C***BEGIN PROLOGUE  RF
C***PURPOSE  Compute the incomplete or complete elliptic integral of the
C            1st kind.  For X, Y, and Z non-negative and at most one of
C            them zero, RF(X,Y,Z) = Integral from zero to infinity of
C                                -1/2     -1/2     -1/2
C                      (1/2)(t+X)    (t+Y)    (t+Z)    dt.
C            If X, Y or Z is zero, the integral is complete.
C***LIBRARY   SLATEC
C***CATEGORY  C14
C***TYPE      SINGLE PRECISION (RF-S, DRF-D)
C***KEYWORDS  COMPLETE ELLIPTIC INTEGRAL, DUPLICATION THEOREM,
C             INCOMPLETE ELLIPTIC INTEGRAL, INTEGRAL OF THE FIRST KIND,
C             TAYLOR SERIES
C***AUTHOR  Carlson, B. C.
C             Ames Laboratory-DOE
C             Iowa State University
C             Ames, IA  50011
C           Notis, E. M.
C             Ames Laboratory-DOE
C             Iowa State University
C             Ames, IA  50011
C           Pexton, R. L.
C             Lawrence Livermore National Laboratory
C             Livermore, CA  94550
C***DESCRIPTION
C
C   1.     RF
C          Evaluate an INCOMPLETE (or COMPLETE) ELLIPTIC INTEGRAL
C          of the first kind
C          Standard FORTRAN function routine
C          Single precision version
C          The routine calculates an approximation result to
C          RF(X,Y,Z) = Integral from zero to infinity of
C
C                               -1/2     -1/2     -1/2
C                     (1/2)(t+X)    (t+Y)    (t+Z)    dt,
C
C          where X, Y, and Z are nonnegative and at most one of them
C          is zero.  If one of them is zero, the integral is COMPLETE.
C          The duplication theorem is iterated until the variables are
C          nearly equal, and the function is then expanded in Taylor
C          series to fifth order.
C
C   2.     Calling Sequence
C          RF( X, Y, Z, IER )
C
C          Parameters on Entry
C          Values assigned by the calling routine
C
C          X      - Single precision, nonnegative variable
C
C          Y      - Single precision, nonnegative variable
C
C          Z      - Single precision, nonnegative variable
C
C
C
C          On Return     (values assigned by the RF routine)
C
C          RF     - Single precision approximation to the integral
C
C          IER    - Integer
C
C                   IER = 0 Normal and reliable termination of the
C                           routine.  It is assumed that the requested
C                           accuracy has been achieved.
C
C                   IER >  0 Abnormal termination of the routine
C
C          X, Y, Z are unaltered.
C
C
C   3.    Error Messages
C
C         Value of IER assigned by the RF routine
C
C                  Value assigned         Error Message Printed
C                  IER = 1                MIN(X,Y,Z) .LT. 0.0E0
C                      = 2                MIN(X+Y,X+Z,Y+Z) .LT. LOLIM
C                      = 3                MAX(X,Y,Z) .GT. UPLIM
C
C
C
C   4.     Control Parameters
C
C                  Values of LOLIM, UPLIM, and ERRTOL are set by the
C                  routine.
C
C          LOLIM and UPLIM determine the valid range of X, Y and Z
C
C          LOLIM  - Lower limit of valid arguments
C
C                   Not less than 5 * (machine minimum).
C
C          UPLIM  - Upper limit of valid arguments
C
C                   Not greater than (machine maximum) / 5.
C
C
C                     Acceptable Values For:   LOLIM      UPLIM
C                     IBM 360/370 SERIES   :   3.0E-78     1.0E+75
C                     CDC 6000/7000 SERIES :   1.0E-292    1.0E+321
C                     UNIVAC 1100 SERIES   :   1.0E-37     1.0E+37
C                     CRAY                 :   2.3E-2466   1.09E+2465
C                     VAX 11 SERIES        :   1.5E-38     3.0E+37
C
C
C
C          ERRTOL determines the accuracy of the answer
C
C                 The value assigned by the routine will result
C                 in solution precision within 1-2 decimals of
C                 "machine precision".
C
C
C
C          ERRTOL - Relative error due to truncation is less than
C                   ERRTOL ** 6 / (4 * (1-ERRTOL)  .
C
C
C
C              The accuracy of the computed approximation to the inte-
C              gral can be controlled by choosing the value of ERRTOL.
C              Truncation of a Taylor series after terms of fifth order
C              introduces an error less than the amount shown in the
C              second column of the following table for each value of
C              ERRTOL in the first column.  In addition to the trunca-
C              tion error there will be round-off error, but in prac-
C              tice the total error from both sources is usually less
C              than the amount given in the table.
C
C
C
C
C
C          Sample Choices:  ERRTOL   Relative Truncation
C                                    error less than
C                           1.0E-3    3.0E-19
C                           3.0E-3    2.0E-16
C                           1.0E-2    3.0E-13
C                           3.0E-2    2.0E-10
C                           1.0E-1    3.0E-7
C
C
C                    Decreasing ERRTOL by a factor of 10 yields six more
C                    decimal digits of accuracy at the expense of one or
C                    two more iterations of the duplication theorem.
C
C *Long Description:
C
C   RF Special Comments
C
C
C
C          Check by addition theorem: RF(X,X+Z,X+W) + RF(Y,Y+Z,Y+W)
C          = RF(0,Z,W), where X,Y,Z,W are positive and X * Y = Z * W.
C
C
C          On Input:
C
C          X, Y, and Z are the variables in the integral RF(X,Y,Z).
C
C
C          On Output:
C
C
C          X, Y, and Z are unaltered.
C
C
C
C          ********************************************************
C
C          Warning: Changes in the program may improve speed at the
C                   expense of robustness.
C
C
C
C   Special Functions via RF
C
C
C                  Legendre form of ELLIPTIC INTEGRAL of 1st kind
C                  ----------------------------------------------
C
C
C                                            2         2   2
C                  F(PHI,K) = SIN(PHI) RF(COS (PHI),1-K SIN (PHI),1)
C
C
C                                 2
C                  K(K) = RF(0,1-K ,1)
C
C                         PI/2     2   2      -1/2
C                       = INT  (1-K SIN (PHI) )   D PHI
C                          0
C
C
C
C
C
C                  Bulirsch form of ELLIPTIC INTEGRAL of 1st kind
C                  ----------------------------------------------
C
C
C                                         2 2    2
C                  EL1(X,KC) = X RF(1,1+KC X ,1+X )
C
C
C
C
C                  Lemniscate constant A
C                  ---------------------
C
C
C                       1      4 -1/2
C                  A = INT (1-S )    DS = RF(0,1,2) = RF(0,2,1)
C                       0
C
C
C    -------------------------------------------------------------------
C
C***REFERENCES  B. C. Carlson and E. M. Notis, Algorithms for incomplete
C                 elliptic integrals, ACM Transactions on Mathematical
C                 Software 7, 3 (September 1981), pp. 398-403.
C               B. C. Carlson, Computing elliptic integrals by
C                 duplication, Numerische Mathematik 33, (1979),
C                 pp. 1-16.
C               B. C. Carlson, Elliptic integrals of the first kind,
C                 SIAM Journal of Mathematical Analysis 8, (1977),
C                 pp. 231-242.
C***ROUTINES CALLED  R1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   790801  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   891009  Removed unreferenced statement labels.  (WRB)
C   891009  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   900510  Changed calls to XERMSG to standard form, and some
C           editorial changes.  (RWC))
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  RF
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOMC.INC'
      INCLUDE 'DPCOP2.INC'
C
CCCCC CHARACTER*16 XERN3, XERN4, XERN5, XERN6
      INTEGER IER
      REAL LOLIM, UPLIM, EPSLON, ERRTOL
      REAL C1, C2, C3, E2, E3, LAMDA
      REAL MU, S, X, XN, XNDEV
      REAL XNROOT, Y, YN, YNDEV, YNROOT, Z, ZN, ZNDEV,
     * ZNROOT
      LOGICAL FIRST
      SAVE ERRTOL,LOLIM,UPLIM,C1,C2,C3,FIRST
      DATA FIRST /.TRUE./
C
C***FIRST EXECUTABLE STATEMENT  RF
C
      IF (FIRST) THEN
         ERRTOL = (4.0E0*R1MACH(3))**(1.0E0/6.0E0)
         LOLIM  = 5.0E0 * R1MACH(1)
         UPLIM  = R1MACH(2)/5.0E0
C
         C1 = 1.0E0/24.0E0
         C2 = 3.0E0/44.0E0
         C3 = 1.0E0/14.0E0
      ENDIF
      FIRST = .FALSE.
C
C         CALL ERROR HANDLER IF NECESSARY.
C
      RF = 0.0E0
      IF (MIN(X,Y,Z).LT.0.0E0) THEN
         IER = 1
CCCCC    WRITE (XERN3, '(1PE15.6)') X
CCCCC    WRITE (XERN4, '(1PE15.6)') Y
CCCCC    WRITE (XERN5, '(1PE15.6)') Z
         WRITE(ICOUT,1)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,9)X
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,8)Y
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,7)Z
         CALL DPWRST('XXX','BUG ')
         RETURN
      ENDIF
    1 FORMAT('***** ERORR FROM RF, ONE OF THE THREE ARGUMENTS IS',
     *       ' NEGATIVE. ***')
    9 FORMAT('***** THE VALUE OF THE FIRST ARGUMENT IS ',E15.8,' ***')
    8 FORMAT('***** THE VALUE OF THE SECOND ARGUMENT IS ',E15.8,' ***')
    7 FORMAT('***** THE VALUE OF THE THIRD ARGUMENT IS ',E15.8,' ***')
C
      IF (MAX(X,Y,Z).GT.UPLIM) THEN
         IER = 3
CCCCC    WRITE (XERN3, '(1PE15.6)') X
CCCCC    WRITE (XERN4, '(1PE15.6)') Y
CCCCC    WRITE (XERN5, '(1PE15.6)') Z
CCCCC    WRITE (XERN6, '(1PE15.6)') UPLIM
         WRITE(ICOUT,2)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,9)X
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,8)Y
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,7)Z
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,6)UPLIM
         CALL DPWRST('XXX','BUG ')
         RETURN
      ENDIF
    2 FORMAT('***** ERORR FROM RF, ONE OF THE THREE ARGUMENTS EXCEEDS',
     *       ' THE LARGEST ALLOWABLE VALUE')
    6 FORMAT('***** THE VALUE OF THE UPPER LIMIT IS ',E15.8,' *****')
C
      IF (MIN(X+Y,X+Z,Y+Z).LT.LOLIM) THEN
         IER = 2
CCCCC    WRITE (XERN3, '(1PE15.6)') X
CCCCC    WRITE (XERN4, '(1PE15.6)') Y
CCCCC    WRITE (XERN5, '(1PE15.6)') Z
CCCCC    WRITE (XERN6, '(1PE15.6)') LOLIM
         WRITE(ICOUT,3)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,9)X
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,8)Y
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,7)Z
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,5)LOLIM
         CALL DPWRST('XXX','BUG ')
         RETURN
      ENDIF
    3 FORMAT('***** ERORR FROM RF, THE MINIMUM OF THE PAIRWISE SUMS ',
     *       'OF THE ARGUMENTS IS LESS THAN THE LOWER LIMIT.')
    5 FORMAT('***** THE VALUE OF THE LOWER LIMIT IS ',E15.8,' *****')
C
      IER = 0
      XN = X
      YN = Y
      ZN = Z
C
   30 MU = (XN+YN+ZN)/3.0E0
      XNDEV = 2.0E0 - (MU+XN)/MU
      YNDEV = 2.0E0 - (MU+YN)/MU
      ZNDEV = 2.0E0 - (MU+ZN)/MU
      EPSLON = MAX(ABS(XNDEV), ABS(YNDEV), ABS(ZNDEV))
      IF (EPSLON.LT.ERRTOL) GO TO 40
      XNROOT =  SQRT(XN)
      YNROOT =  SQRT(YN)
      ZNROOT =  SQRT(ZN)
      LAMDA = XNROOT*(YNROOT+ZNROOT) + YNROOT*ZNROOT
      XN = (XN+LAMDA)*0.250E0
      YN = (YN+LAMDA)*0.250E0
      ZN = (ZN+LAMDA)*0.250E0
      GO TO 30
C
   40 E2 = XNDEV*YNDEV - ZNDEV*ZNDEV
      E3 = XNDEV*YNDEV*ZNDEV
      S  = 1.0E0 + (C1*E2-0.10E0-C2*E3)*E2 + C3*E3
      RF = S/SQRT(MU)
C
      RETURN
      END
      REAL FUNCTION RJ (X, Y, Z, P, IER)
C***BEGIN PROLOGUE  RJ
C***PURPOSE  Compute the incomplete or complete (X or Y or Z is zero)
C            elliptic integral of the 3rd kind.  For X, Y, and Z non-
C            negative, at most one of them zero, and P positive,
C             RJ(X,Y,Z,P) = Integral from zero to infinity of
C                                  -1/2     -1/2     -1/2     -1
C                        (3/2)(t+X)    (t+Y)    (t+Z)    (t+P)  dt.
C***LIBRARY   SLATEC
C***CATEGORY  C14
C***TYPE      SINGLE PRECISION (RJ-S, DRJ-D)
C***KEYWORDS  COMPLETE ELLIPTIC INTEGRAL, DUPLICATION THEOREM,
C             INCOMPLETE ELLIPTIC INTEGRAL, INTEGRAL OF THE THIRD KIND,
C             TAYLOR SERIES
C***AUTHOR  Carlson, B. C.
C             Ames Laboratory-DOE
C             Iowa State University
C             Ames, IA  50011
C           Notis, E. M.
C             Ames Laboratory-DOE
C             Iowa State University
C             Ames, IA  50011
C           Pexton, R. L.
C             Lawrence Livermore National Laboratory
C             Livermore, CA  94550
C***DESCRIPTION
C
C   1.     RJ
C          Standard FORTRAN function routine
C          Single precision version
C          The routine calculates an approximation result to
C          RJ(X,Y,Z,P) = Integral from zero to infinity of
C
C                                -1/2     -1/2     -1/2     -1
C                      (3/2)(t+X)    (t+Y)    (t+Z)    (t+P)  dt,
C
C          where X, Y, and Z are nonnegative, at most one of them is
C          zero, and P is positive.  If X or Y or Z is zero, the
C          integral is COMPLETE.  The duplication theorem is iterated
C          until the variables are nearly equal, and the function is
C          then expanded in Taylor series to fifth order.
C
C
C   2.     Calling Sequence
C          RJ( X, Y, Z, P, IER )
C
C          Parameters On Entry
C          Values assigned by the calling routine
C
C          X      - Single precision, nonnegative variable
C
C          Y      - Single precision, nonnegative variable
C
C          Z      - Single precision, nonnegative variable
C
C          P      - Single precision, positive variable
C
C
C          On  Return     (values assigned by the RJ routine)
C
C          RJ     - Single precision approximation to the integral
C
C          IER    - Integer
C
C                   IER = 0 Normal and reliable termination of the
C                           routine.  It is assumed that the requested
C                           accuracy has been achieved.
C
C                   IER >  0 Abnormal termination of the routine
C
C
C          X, Y, Z, P are unaltered.
C
C
C   3.    Error Messages
C
C         Value of IER assigned by the RJ routine
C
C                  Value Assigned        Error Message Printed
C                  IER = 1               MIN(X,Y,Z) .LT. 0.0E0
C                      = 2               MIN(X+Y,X+Z,Y+Z,P) .LT. LOLIM
C                      = 3               MAX(X,Y,Z,P) .GT. UPLIM
C
C
C
C   4.     Control Parameters
C
C                  Values of LOLIM, UPLIM, and ERRTOL are set by the
C                  routine.
C
C
C          LOLIM and UPLIM determine the valid range of X Y, Z, and P
C
C          LOLIM is not less than the cube root of the value
C          of LOLIM used in the routine for RC.
C
C          UPLIM is not greater than 0.3 times the cube root of
C          the value of UPLIM used in the routine for RC.
C
C
C                     Acceptable Values For:   LOLIM      UPLIM
C                     IBM 360/370 SERIES   :   2.0E-26     3.0E+24
C                     CDC 6000/7000 SERIES :   5.0E-98     3.0E+106
C                     UNIVAC 1100 SERIES   :   5.0E-13     6.0E+11
C                     CRAY                 :   1.32E-822   1.4E+821
C                     VAX 11 SERIES        :   2.5E-13     9.0E+11
C
C
C
C          ERRTOL determines the accuracy of the answer
C
C                 The value assigned by the routine will result
C                 in solution precision within 1-2 decimals of
C                 "machine precision".
C
C
C
C
C          Relative error due to truncation of the series for RJ
C          is less than 3 * ERRTOL ** 6 / (1 - ERRTOL) ** 3/2.
C
C
C
C              The accuracy of the computed approximation to the inte-
C              gral can be controlled by choosing the value of ERRTOL.
C              Truncation of a Taylor series after terms of fifth order
C              Introduces an error less than the amount shown in the
C              second column of the following table for each value of
C              ERRTOL in the first column.  In addition to the trunca-
C              tion error there will be round-off error, but in prac-
C              tice the total error from both sources is usually less
C              than the amount given in the table.
C
C
C
C          Sample choices:  ERRTOL   Relative Truncation
C                                    error less than
C                           1.0E-3    4.0E-18
C                           3.0E-3    3.0E-15
C                           1.0E-2    4.0E-12
C                           3.0E-2    3.0E-9
C                           1.0E-1    4.0E-6
C
C                    Decreasing ERRTOL by a factor of 10 yields six more
C                    decimal digits of accuracy at the expense of one or
C                    two more iterations of the duplication theorem.
C
C *Long Description:
C
C   RJ Special Comments
C
C
C          Check by addition theorem: RJ(X,X+Z,X+W,X+P)
C          + RJ(Y,Y+Z,Y+W,Y+P) + (A-B) * RJ(A,B,B,A) + 3 / SQRT(A)
C          = RJ(0,Z,W,P), where X,Y,Z,W,P are positive and X * Y
C          = Z * W,  A = P * P * (X+Y+Z+W),  B = P * (P+X) * (P+Y),
C          and B - A = P * (P-Z) * (P-W).  The sum of the third and
C          fourth terms on the left side is 3 * RC(A,B).
C
C
C          On Input:
C
C          X, Y, Z, and P are the variables in the integral RJ(X,Y,Z,P).
C
C
C          On Output:
C
C
C          X, Y, Z, and P are unaltered.
C
C          ********************************************************
C
C          Warning: Changes in the program may improve speed at the
C                   expense of robustness.
C
C ------------------------------------------------------------
C
C
C   Special Functions via RJ and RF
C
C
C                  Legendre form of ELLIPTIC INTEGRAL of 3rd kind
C                  ----------------------------------------------
C
C
C                               PHI         2         -1
C                  P(PHI,K,N) = INT (1+N SIN (THETA) )   *
C                                0
C
C                                      2    2         -1/2
C                                 *(1-K  SIN (THETA) )     D THETA
C
C
C                                         2          2   2
C                       = SIN (PHI) RF(COS (PHI), 1-K SIN (PHI),1)
C
C                                  3            2         2   2
C                        -(N/3) SIN (PHI) RJ(COS (PHI),1-K SIN (PHI),
C
C                                 2
C                        1,1+N SIN (PHI))
C
C
C
C                  Bulirsch form of ELLIPTIC INTEGRAL of 3rd kind
C                  ----------------------------------------------
C
C
C                                           2 2    2
C                  EL3(X,KC,P) = X RF(1,1+KC X ,1+X ) +
C
C                                            3          2 2    2     2
C                               +(1/3)(1-P) X  RJ(1,1+KC X ,1+X ,1+PX )
C
C
C                                           2
C                  CEL(KC,P,A,B) = A RF(0,KC ,1) +
C
C                                                     2
C                                 +(1/3)(B-PA) RJ(0,KC ,1,P)
C
C
C
C
C                  Heuman's LAMBDA function
C                  ------------------------
C
C
C                                 2                     2      2    1/2
C                  L(A,B,P) = (COS(A)SIN(B)COS(B)/(1-COS (A)SIN (B))   )
C
C                                           2         2       2
C                            *(SIN(P) RF(COS (P),1-SIN (A) SIN (P),1)
C
C                                 2       3            2       2
C                            +(SIN (A) SIN (P)/(3(1-COS (A) SIN (B))))
C
C                                   2         2       2
C                            *RJ(COS (P),1-SIN (A) SIN (P),1,1-
C
C                                2       2          2       2
C                            -SIN (A) SIN (P)/(1-COS (A) SIN (B))))
C
C
C
C
C                  (PI/2) LAMBDA0(A,B) =L(A,B,PI/2) =
C
C
C                    2                         2       2    -1/2
C               = COS (A)  SIN(B) COS(B) (1-COS (A) SIN (B))
C
C                           2                  2       2
C                  *RF(0,COS (A),1) + (1/3) SIN (A) COS (A)
C
C                                       2       2    -3/2
C                  *SIN(B) COS(B) (1-COS (A) SIN (B))
C
C                           2         2       2          2       2
C                  *RJ(0,COS (A),1,COS (A) COS (B)/(1-COS (A) SIN (B)))
C
C
C
C                  Jacobi ZETA function
C                  --------------------
C
C
C                             2                     2   2    1/2
C                  Z(B,K) = (K/3) SIN(B) COS(B) (1-K SIN (B))
C
C
C                                      2      2   2                2
C                             *RJ(0,1-K ,1,1-K SIN (B)) / RF (0,1-K ,1)
C
C
C    -------------------------------------------------------------------
C
C***REFERENCES  B. C. Carlson and E. M. Notis, Algorithms for incomplete
C                 elliptic integrals, ACM Transactions on Mathematical
C                 Software 7, 3 (September 1981), pp. 398-403.
C               B. C. Carlson, Computing elliptic integrals by
C                 duplication, Numerische Mathematik 33, (1979),
C                 pp. 1-16.
C               B. C. Carlson, Elliptic integrals of the first kind,
C                 SIAM Journal of Mathematical Analysis 8, (1977),
C                 pp. 231-242.
C***ROUTINES CALLED  R1MACH, RC, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   790801  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   891009  Removed unreferenced statement labels.  (WRB)
C   891009  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   900510  Changed calls to XERMSG to standard form, and some
C           editorial changes.  (RWC)).
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  RJ
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOMC.INC'
      INCLUDE 'DPCOP2.INC'
C
CCCCC CHARACTER*16 XERN3, XERN4, XERN5, XERN6, XERN7
      INTEGER IER
      REAL ALFA, BETA, C1, C2, C3, C4, EA, EB, EC, E2, E3
      REAL LOLIM, UPLIM, EPSLON, ERRTOL
      REAL LAMDA, MU, P, PN, PNDEV
      REAL POWER4, RC, SIGMA, S1, S2, S3, X, XN, XNDEV
      REAL XNROOT, Y, YN, YNDEV, YNROOT, Z, ZN, ZNDEV,
     * ZNROOT
      LOGICAL FIRST
      SAVE ERRTOL,LOLIM,UPLIM,C1,C2,C3,C4,FIRST
      DATA FIRST /.TRUE./
C
C***FIRST EXECUTABLE STATEMENT  RJ
      IF (FIRST) THEN
         ERRTOL = (R1MACH(3)/3.0E0)**(1.0E0/6.0E0)
         LOLIM  = (5.0E0 * R1MACH(1))**(1.0E0/3.0E0)
         UPLIM  = 0.30E0*( R1MACH(2) / 5.0E0)**(1.0E0/3.0E0)
C
         C1 = 3.0E0/14.0E0
         C2 = 1.0E0/3.0E0
         C3 = 3.0E0/22.0E0
         C4 = 3.0E0/26.0E0
      ENDIF
      FIRST = .FALSE.
C
C         CALL ERROR HANDLER IF NECESSARY.
C
      RJ = 0.0E0
      IF (MIN(X,Y,Z).LT.0.0E0) THEN
         IER = 1
CCCCC    WRITE (XERN3, '(1PE15.6)') X
CCCCC    WRITE (XERN4, '(1PE15.6)') Y
CCCCC    WRITE (XERN5, '(1PE15.6)') Z
         WRITE(ICOUT,1)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,9)X
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,8)Y
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,7)Z
         CALL DPWRST('XXX','BUG ')
         RETURN
      ENDIF
    1 FORMAT('***** ERORR FROM RJ, ONE OF THE THREE ARGUMENTS IS',
     *       ' NEGATIVE. ***')
    9 FORMAT('***** THE VALUE OF THE FIRST ARGUMENT IS ',E15.8,' ***')
    8 FORMAT('***** THE VALUE OF THE SECOND ARGUMENT IS ',E15.8,' ***')
    7 FORMAT('***** THE VALUE OF THE THIRD ARGUMENT IS ',E15.8,' ***')
   11 FORMAT('***** THE VALUE OF THE FOURTH ARGUMENT IS ',E15.8,' ***')
C
      IF (MAX(X,Y,Z,P).GT.UPLIM) THEN
         IER = 3
CCCCC    WRITE (XERN3, '(1PE15.6)') X
CCCCC    WRITE (XERN4, '(1PE15.6)') Y
CCCCC    WRITE (XERN5, '(1PE15.6)') Z
CCCCC    WRITE (XERN6, '(1PE15.6)') P
CCCCC    WRITE (XERN7, '(1PE15.6)') UPLIM
         WRITE(ICOUT,2)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,9)X
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,8)Y
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,7)Z
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,11)P
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,6)UPLIM
         CALL DPWRST('XXX','BUG ')
         RETURN
      ENDIF
    2 FORMAT('***** ERORR FROM RJ, ONE OF THE FOUR ARGUMENTS EXCEEDS',
     *       'THE LARGEST ALLOWABLE VALUE')
    6 FORMAT('***** THE VALUE OF THE UPPER LIMIT IS ',E15.8,' *****')
C
      IF (MIN(X+Y,X+Z,Y+Z,P).LT.LOLIM) THEN
         IER = 2
CCCCC    WRITE (XERN3, '(1PE15.6)') X
CCCCC    WRITE (XERN4, '(1PE15.6)') Y
CCCCC    WRITE (XERN5, '(1PE15.6)') Z
CCCCC    WRITE (XERN6, '(1PE15.6)') P
CCCCC    WRITE (XERN7, '(1PE15.6)') LOLIM
         WRITE(ICOUT,3)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,4)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,9)X
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,8)Y
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,7)Z
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,11)P
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,5)LOLIM
         CALL DPWRST('XXX','BUG ')
         RETURN
      ENDIF
    3 FORMAT('***** ERORR FROM RJ, THE MINIMUM OF THE PAIRWISE SUMS ',
     *       'OF THE FIRST THREE ARGUMENTS ')
    4 FORMAT('      OR THE FOURTH ARGUMENT IS LESS THAN THE LOWER ',
     *       'LIMIT.')
    5 FORMAT('***** THE VALUE OF THE LOWER LIMIT IS ',E15.8,' *****')
C
      IER = 0
      XN = X
      YN = Y
      ZN = Z
      PN = P
      SIGMA = 0.0E0
      POWER4 = 1.0E0
C
   30 MU = (XN+YN+ZN+PN+PN)*0.20E0
      XNDEV = (MU-XN)/MU
      YNDEV = (MU-YN)/MU
      ZNDEV = (MU-ZN)/MU
      PNDEV = (MU-PN)/MU
      EPSLON = MAX(ABS(XNDEV), ABS(YNDEV), ABS(ZNDEV), ABS(PNDEV))
      IF (EPSLON.LT.ERRTOL) GO TO 40
      XNROOT =  SQRT(XN)
      YNROOT =  SQRT(YN)
      ZNROOT =  SQRT(ZN)
      LAMDA = XNROOT*(YNROOT+ZNROOT) + YNROOT*ZNROOT
      ALFA = PN*(XNROOT+YNROOT+ZNROOT) + XNROOT*YNROOT*ZNROOT
      ALFA = ALFA*ALFA
      BETA = PN*(PN+LAMDA)*(PN+LAMDA)
      SIGMA = SIGMA + POWER4*RC(ALFA,BETA,IER)
      POWER4 = POWER4*0.250E0
      XN = (XN+LAMDA)*0.250E0
      YN = (YN+LAMDA)*0.250E0
      ZN = (ZN+LAMDA)*0.250E0
      PN = (PN+LAMDA)*0.250E0
      GO TO 30
C
   40 EA = XNDEV*(YNDEV+ZNDEV) + YNDEV*ZNDEV
      EB = XNDEV*YNDEV*ZNDEV
      EC = PNDEV*PNDEV
      E2 = EA - 3.0E0*EC
      E3 = EB + 2.0E0*PNDEV*(EA-EC)
      S1 = 1.0E0 + E2*(-C1+0.750E0*C3*E2-1.50E0*C4*E3)
      S2 = EB*(0.50E0*C2+PNDEV*(-C3-C3+PNDEV*C4))
      S3 = PNDEV*EA*(C2-PNDEV*C3) - C2*PNDEV*EC
      RJ = 3.0E0*SIGMA + POWER4*(S1+S2+S3)/(MU* SQRT(MU))
      RETURN
      END
      SUBROUTINE RDMNOR(AMU,SIG,LDSIG,N,LTF,ZM,IFLAG,ISEED)
C
C-----------------------------------------------------------------------
C   RDMNOR   WRITTEN BY CHARLES P. REEVE, STATISTICAL ENGINEERING
C            DIVISION, NATION INSTITUTE OF STANDARDS AND TECHNOLOGY, GAITHERSBURG,
C            MARYLAND  20899
C
C   FOR: COMPUTING A VECTOR OF PSEUDO-RANDOM MULTIVARIATE NORMAL
C        DEVIATES WITH MEAN AMU AND VARIANCE SIG.  BEFORE THE FIRST
C        CALL WITH A GIVEN SIG, THE LOGICAL VARIABLE LTF MUST BE
C        ASSIGNED THE VALUE .TRUE. SO THAT A CHOLESKY FACTORIZATION
C        OF SIG IS PERFORMED AS IN THE REFERENCE.  THE RESULT IS A
C        LOWER TRIANGULAR MATRIX L, STORED IN THE LOWER TRIANGLE OF
C        SIG, SUCH THAT SIG=LL'.  FURTHER CALL TO RDMNOR USE ONLY THE
C        LOWER TRIANGLE OF SIG (L) IN COMPUTING THE DEVIATES UNTIL THE
C        VALUE OF LTF IS RESET TO .TRUE., EVEN IS SIG IS REDEFINED.
C
C   NOTE: BEFORE THE FIRST CALL TO THIS ROUTINE THE CALL
C
C                           Z = RDNOR(ISEED)
C
C         FOR DATAPLOT, PASS SEED AS AGRUMENT
C
C         SHOULD BE MADE IN ORDER TO INITIALIZE THE NORMAL RANDOM
C         NUMBER GENERATOR WHERE ISEED IS A POSITIVE INTEGER.  THIS
C         ALLOWS THE USER TO ESTABLISH A REPEATABLE SEQUENCE OF
C         DEVIATES.
C
C   SUBPROGRAMS CALLED: RDNOR (PSEUDO-RANDOM NORMAL GENERATOR)
C
C                       FOR DATAPLOT, REPLACE WITH NORRAN
C
C   CURRENT VERSION COMPLETED MAY 15, 1987
C
C   REFERENCE: STEWART, G.W., 'INTRODUCTION TO MATRIX COMPUTATIONS',
C              ACADEMIC PRESS, ALGORITHM 3.9, P 142.
C-----------------------------------------------------------------------
C   DEFINITION OF PASSED PARAMETERS:
C
C     * AMU = MEAN VECTOR (LENGTH N) OF THE MULTIVARIATE NORMAL
C             DEVIATES ZM (REAL)
C
C     * SIG = COVARIANCE MATRIX (SIZE NXN) OF THE MULTIVARIATE NORMAL
C             DEVIATES ZM (REAL)
C
C   * LDSIG = THE LEADING DIMENSION OF MATRIX SIG (>=N) (INTEGER)
C
C       * N = THE LENGTH OF THE VECTOR OF DEVIATES ZM (INTEGER)
C
C     * LTF = AN INDICATOR VARIABLE FOR PERFORMING A CHOLESKY
C             FACTORIZATION OF A NEW COVARIANCE MATRIX SIG (LOGICAL)
C
C        ZM = A PSEUDO-RANDOM MULTIVARIATE NORMAL VECTOR (LENGTH N)
C             WITH MEAN AMU AND VARIANCE SIG (REAL)
C
C     IFLAG = AN ERROR INDICATOR ON OUTPUT (INTEGER)   INTERPRETATION:
C             0 -> NO ERRORS DETECTED
C             1 -> THE MATRIX SIG IS NOT POSITIVE SEMIDEFINITE, THUS
C                  CANNOT BE A COVARIANCE MATRIX - NO DEVIATE GENERATED
C
C     ISEED = AN INTEGER THAT SPECIFIES THE SEED FOR THE DATAPLOT
C             RANDOM NUMBER GENERATOR.
C
C   * INDICATES VARIABLES REQUIRING INPUT VALUES
C-----------------------------------------------------------------------
      DIMENSION AMU(*),SIG(LDSIG,*),ZM(*)
      LOGICAL LTF
C
C--- IF NEW MATRIX SIG, PERFORM CHOLESKY FACTORIZATION.  SET ERROR
C--- FLAG IF SIG IS NOT POSITIVE DEFINITE
C
      IF (LTF) THEN
         DO 40 K = 1, N
            DO 20 I = 1, K-1
               S = 0.0
               DO 10 J = 1, I-1
                  S = S+SIG(I,J)*SIG(K,J)
   10          CONTINUE
               SIG(K,I) = (SIG(K,I)-S)/SIG(I,I)
   20       CONTINUE
            S = 0.0
            DO 30 J = 1, K-1
               S = S+SIG(K,J)**2
   30       CONTINUE
            Q = SIG(K,K)-S
            IF (Q.LT.0.0) THEN
               IFLAG = 1
               RETURN
            ELSE
               IF(Q.GT.0.0)THEN
                 SIG(K,K) = SQRT(Q)
               ELSE
                 SIG(K,K)=0.0
               ENDIF
            ENDIF
   40    CONTINUE
         LTF = .FALSE.
      ENDIF
      IFLAG = 0
C
C--- COMPUTE N INDEPENDENT N(0,1) PSEUDO-RANDOM DEVIATES IN ZM
C
CCCCC DO 50 I = 1, N
CCCCC    ZM(I) = RDNOR(0)
CCC50 CONTINUE
      CALL NORRAN(N,ISEED,ZM)
C
C--- COMPUTE THE PSEUDO-RANDOM MULTIVARIATE NORMAL DEVIATES IN ZM
C
      DO 70 I = N, 1, -1
         S = 0.0
         DO 60 J = 1, I
            S = S+SIG(I,J)*ZM(J)
   60    CONTINUE
         ZM(I) = AMU(I)+S
   70 CONTINUE
      RETURN
      END
      FUNCTION RDT (DF,ISEED)
C
C-----------------------------------------------------------------------
C   RDT   WRITTEN BY CHARLES P. REEVE, STATISTICAL ENGINEERING
C         DIVISION, NATIONAL BUREAU OF STANDARDS, GAITHERSBURG,
C
C   FOR: GENERATING A RANDOM DEVIATE FROM THE T(DF) DISTRIBUTION.
C        ONE OF THREE METHODS IS USED DEPENDING ON THE VALUE OF THE
C        PARAMETER DF (WHICH DOES NOT HAVE TO BE AN INTEGER):
C
C             VALUE OF DF             METHOD USED
C            -------------         ------------------
C              0 < DF < 1          NORMAL/SQRT(CHI-SQUARED/DF)
C                DF = 1            TANGENT TRANSFORMATION (CST)
C                DF > 1            KINDERMAN-MONAHAN-RAMAGE (TIR)
C
C        IF DF <= 0 AN ERROR MESSAGE IS PRINTED AND EXECUTION IS
C        TERMINATED.
C
C        DESCRIPTIONS OF EACH OF THESE ALGORITHMS CAN BE FOUND IN
C        THE REFERENCE GIVEN BELOW.
C
C   SUBPROGRAMS CALLED:  RDUNI (STSPAC) - UNIFORM(0,1) GENERATOR
C                        RDNOR (STSPAC) - NORMAL(0,1) GENERATOR
C                       RDCHI2 (STSPAC) - CHI-SQUARED GENERATOR
C
C   CURRENT VERSION COMPLETED FEBRUARY 28, 1986
C
C   REFERENCE: KINDERMAN, A.J., MONAHAN, J.F., AND RAMAGE, J.G.,
C              "COMPUTER METHODS FOR SAMPLING FROM STUDENT'S T
C              DISTRIBUTION", MATHEMATICS OF COMPUTATION, VOLUME 31,
C              NUMBER 140, OCTOBER 1977, PP. 1009-1018
C
C   ADAPTED FOR DATAPLOT.  USE THIS ALGORITHM FOR THE CASE OF
C   NON-INTEGER DEGREES OF FREEDOM.  CHANGE TO USE DATAPLOT UNIFORM
C   RANDOM NUMBER GENERATOR.
C
      REAL XTEMP(1)
C
C-----------------------------------------------------------------------
C
      F(X,A) = (1.0+X*X/A)**(-(A+1.0)/2.0)
C
      RDT=0.0
      IF (DF.GT.1.0) THEN
C
C
C   KINDERMAN-MONAHAN-RAMAGE ALGORITHM (TIR)
C
C--- STEP 1
C
   10    CONTINUE
CCCCC    U = RDUNI(0)
         CALL UNIRAN(1,ISEED,XTEMP)
         U=XTEMP(1)
         IF (U.GE.0.23079283) GO TO 20
         RDT = 4.0*U-0.46158566
C
C--- STEP 2
C
CCCCC    V = RDUNI(0)
         CALL UNIRAN(1,ISEED,XTEMP)
         V=XTEMP(1)
         IF (V.LE.1.0-0.5*ABS(RDT)) RETURN
         IF (V.LE.F(RDT,DF)) RETURN
         GO TO 10
C
C--- STEP 3
C
   20    IF (U.GE.0.5) GO TO 40
         S = 4.0*U-1.46158566
         RDT = SIGN(ABS(S)+0.46158566,S)
CCCCC    V = RDUNI(0)
         CALL UNIRAN(1,ISEED,XTEMP)
         V=XTEMP(1)
C
C--- STEP 4
C
   30    IF (V.LE.1.0-0.5*ABS(RDT)) RETURN
         IF (V.GE.1.2130613/(1.0+RDT*RDT)) GO TO 10
         IF (V.LE.F(RDT,DF)) RETURN
         GO TO 10
C
C--- STEP 5
C
   40    IF (U.GE.0.75) GO TO 50
         S = 8.0*U-5.0
         RDT = 2.0/SIGN(ABS(S)+1.0,S)
CCCCC    V = RDUNI(0)/(RDT*RDT)
         CALL UNIRAN(1,ISEED,XTEMP)
         V=XTEMP(1)
         GO TO 30
C
C--- STEP 6
C
   50    RDT = 2.0/(8.0*U-7.0)
CCCCC    V = RDUNI(0)
         CALL UNIRAN(1,ISEED,XTEMP)
         V=XTEMP(1)
         IF (V.LT.RDT*RDT*F(RDT,DF)) RETURN
         GO TO 10
C
      ELSEIF (DF.EQ.1.0) THEN
C
C
C   SYNTHETIC TANGENT ALGORITHM (CST)
C
C--- STEP 1
C
   60    CONTINUE
CCCCC    U = RDUNI(0)
         CALL UNIRAN(1,ISEED,XTEMP)
         U=XTEMP(1)
CCCCC    V = 2.0*RDUNI(0)-1.0
         CALL UNIRAN(1,ISEED,XTEMP)
         V=2.0*XTEMP(1)-1.0
C
C--- STEP 2
C
         IF (U*U+V*V.GT.1.0) GO TO 60
         RDT = V/U
         RETURN
C
      ELSEIF (DF.GT.0.0) THEN
C
C
C   RATIO OF STANDARD NORMAL AND SQUARE ROOT OF
C   CHI-SQUARED DIVIDED BY ITS DEGREES OF FREEDOM
C
C
CCCCC    D = SQRT(RDCHI2(DF)/DF)
         CALL CHSRAN(1,DF,ISEED,XTEMP)
         D = SQRT(XTEMP(1)/DF)
CCCCC    RDT = RDNOR(0)/D
         CALL NORRAN(1,ISEED,XTEMP)
         RDT = XTEMP(1)/D
      ELSE
CCCCC    PRINT *,' *** DEGREES OF FREEDOM MUST BE > 0'
CCCCC    PRINT *,' *** EXECUTION STOPPED IN FUNCTION RDT'
CCCCC    STOP
C
      ENDIF
      RETURN
      END
      SUBROUTINE RECCDF(X,B,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE RECIPROCAL
C              DISTRIBUTION WITH SINGLE PRECISION
C              TAIL LENGTH PARAMETER = B.
C              THE RECIPROCAL DISTRIBUTION USED
C              HEREIN IS DEFINED FOR 1/B <= x < 1.
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C              F(X) = 1/(X*LOG(B))
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE
C                                AT WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE GREATER THAN
C                                OR EQUAL TO 1.
C                     --B      = THE SINGLE PRECISION VALUE
C                                OF THE TAIL LENGTH PARAMETER.
C                                B SHOULD BE > 1.
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 RECIPROCAL
C             DISTRIBUTION WITH TAIL LENGTH PARAMETER VALUE = B.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--B SHOULD BE > 1.
C                 --X SHOULD BE POSITIVE AND LESS THAN 1.
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--R. W. HAMMING, NUMERICAL METHODS FOR SCIENTISTS
C                 AND ENGINEERS, 2ND. ED., 1973, PAGE 34.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY
C                 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE:  301-975-2855
C     ORIGINAL VERSION--MAY       1996.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DB
      DOUBLE PRECISION DCDF
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(B.LE.1.0)THEN
        WRITE(ICOUT,15)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)B
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ENDIF
   15 FORMAT('***** FATAL DIAGNOSTIC--THE SECOND INPUT ARGUMENT ',
     1'TO RECPDF IS LESS THAN OR EQUAL TO 1')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
      IF(X.LT.(1./B))THEN
        CDF=0.0
        GOTO9999
      ENDIF
      IF(X.GE.1.0)THEN
        CDF=1.0
        GOTO9999
      ENDIF
C
C-----START POINT-----------------------------------------------------
C
      DX=DBLE(X)
      DB=DBLE(B)
      DCDF=(DLOG(DX)+DLOG(DB))/DLOG(DB)
      CDF=SNGL(DCDF)
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE RECIPG(X,ODD,EVEN,RG)
C THIS ROUTINE IS A TRANSLATION INTO FORTRAN OF THE ALGOL PROCEDURE
C RECIPGAMMA GIVEN IN   N. M. TEMME, ON THE NUMERICAL EVALUATION OF THE
C MODIFIED BESSEL FUNCTION OF THE THIRD KIND, J. COMP. PHYSICS, VOLUME
C 19, PAGE 324 (1975).
      DIMENSION B(12)
C-----------------------------------------------------------------------
C
C  MACHINE DEPENDENT CONSTANTS.
C  ---------------------------
C
      DATA B(1), B(2), B(3), B(4), B(5), B(6), B(7), B(8), B(9), B(10),
     *     B(11), B(12)
     *      /-.28387 65422 7602,-.07685 28408 44786,.00170 63050 71096,
     1 .00127 19271 36655,.00007 63095 97586,-.4971736704E-5,-.865920800
     2 E-6,-.33126120E-7,.1745136E-8,.242310E-9,.9161E-11,-.170E-12/
C
C-----------------------------------------------------------------------
      X2=8.*X*X
      ALFA=-1.E-15
      BETA=0.
      DO 1 N=1,11,2
        BETA=-(BETA+2.*ALFA)
        ITEMP = 13 - N
        ALFA = - X2 * BETA - ALFA + B(ITEMP)
    1 CONTINUE
      EVEN=(ALFA+.5*BETA)*X2-ALFA+.92187 02936 5045
      ALFA=-.34E-13
      BETA=0.
      DO 2 N=2,12,2
        BETA=-(BETA+2.*ALFA)
        ITEMP = 13 - N
        ALFA = - X2 * BETA - ALFA + B(ITEMP)
    2 CONTINUE
      ODD=2.*(ALFA+BETA)
      RG=ODD*X+EVEN
      RETURN
      END
      SUBROUTINE RECPDF(X,B,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE RECIPROCAL
C              DISTRIBUTION WITH SINGLE PRECISION
C              TAIL LENGTH PARAMETER = B.
C              THE RECIPROCAL DISTRIBUTION USED
C              HEREIN IS DEFINED FOR 1/B <= x < 1.
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C              F(X) = 1/(X*LOG(B))
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE
C                                AT WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE GREATER THAN
C                                OR EQUAL TO 1.
C                     --B      = THE SINGLE PRECISION VALUE
C                                OF THE TAIL LENGTH PARAMETER.
C                                B SHOULD BE > 1.
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 RECIPROCAL
C             DISTRIBUTION WITH TAIL LENGTH PARAMETER VALUE = B.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--B SHOULD BE POSITIVE.
C                 --X SHOULD BE POSITIVE AND LESS THAN 1.
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--R. W. HAMMING, NUMERICAL METHODS FOR SCIENTISTS
C                 AND ENGINEERS, 2ND. ED., 1973, PAGE 34.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY
C                 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE:  301-975-2855
C     ORIGINAL VERSION--MAY       1996.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DB
      DOUBLE PRECISION DPDF
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(B.LE.1.0)THEN
        WRITE(ICOUT,15)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)B
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ENDIF
   15 FORMAT('***** FATAL DIAGNOSTIC--THE SECOND INPUT ARGUMENT ',
     1'TO RECPDF IS LESS THAN OR EQUAL TO 1')
      IF(X.LT.(1./B).OR.X.GE.1.0)THEN
        WRITE(ICOUT,4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ENDIF
    4 FORMAT('***** FATAL DIAGNOSTIC--THE FIRST  INPUT ARGUMENT ',
     1'TO RECPDF IS OUTSIDE THE (1/B,1) INTERVAL')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
C-----START POINT-----------------------------------------------------
C
      DX=DBLE(X)
      DB=DBLE(B)
      DPDF=1.0D0/(DX*DLOG(DB))
      PDF=SNGL(DPDF)
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE RECPPF(P,B,PPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE RECIPROCAL
C              DISTRIBUTION WITH SINGLE PRECISION
C              TAIL LENGTH PARAMETER = B.
C              THE RECIPROCAL DISTRIBUTION USED
C              HEREIN IS DEFINED FOR 1/B <= X < 1.
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C              F(X) = 1/(X*LOG(B))
C     INPUT  ARGUMENTS--P      = THE SINGLE PRECISION VALUE
C                                SPECIFYING THE PROBABILITY VALUE.
C                                P SHOULD BE GREATER THAN OR EQUAL TO 0
C                                AND LESS THAN OR EQUAL TO 1.
C                     --B      = THE SINGLE PRECISION VALUE
C                                OF THE TAIL LENGTH PARAMETER.
C                                B SHOULD BE > 1.
C     OUTPUT ARGUMENTS--PPF    = THE SINGLE PRECISION PERCENT
C                                POINT FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PERCENT POINT
C             FUNCTION VALUE PPF FOR THE RECIPROCAL
C             DISTRIBUTION WITH TAIL LENGTH PARAMETER VALUE = B.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--B SHOULD BE > 1.
C                 --P SHOULD BE >= 0 AND <= 1
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--R. W. HAMMING, NUMERICAL METHODS FOR SCIENTISTS
C                 AND ENGINEERS, 2ND. ED., 1973, PAGE 34.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY
C                 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE:  301-975-2855
C     ORIGINAL VERSION--MAY       1996.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DOUBLE PRECISION DP
      DOUBLE PRECISION DB
      DOUBLE PRECISION DPPF
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(P.LT.0.0.OR.P.GT.1.0)THEN
        WRITE(ICOUT,4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)P
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ENDIF
    4 FORMAT('***** FATAL DIAGNOSTIC--THE FIRST  INPUT ARGUMENT ',
     1'TO RECPPF IS OUTSIDE THE (0,1) INTERVAL')
      IF(B.LE.1.0)THEN
        WRITE(ICOUT,15)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)B
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ENDIF
   15 FORMAT('***** FATAL DIAGNOSTIC--THE SECOND INPUT ARGUMENT ',
     1'TO RECPDF IS LESS THAN OR EQUAL TO 0')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
      IF(P.EQ.0.0)THEN
        PPF=1.0/B
        GOTO9999
      ENDIF
      IF(P.EQ.1.0)THEN
        PPF=1.0
        GOTO9999
      ENDIF
C
C-----START POINT-----------------------------------------------------
C
      DP=DBLE(P)
      DB=DBLE(B)
      DPPF=DEXP(DLOG(DB)*(DP-1.0D0))
      PPF=SNGL(DPPF)
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE RECRAN(N,B,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE RECIROCAL DISTRIBUTION
C              WITH SHAPE PARAMETER VALUE = B.
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.
C                                B SHOULD BE POSITIVE.
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST N)
C                                INTO WHICH THE GENERATED
C                                RANDOM SAMPLE WILL BE PLACED.
C     OUTPUT--A RANDOM SAMPLE OF SIZE N
C             FROM THE RECIROCAL 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 SHOULD BE POSITIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--XX
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2001.10
C     ORIGINAL VERSION--OCTOBER   2001.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DIMENSION X(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)THEN
        WRITE(ICOUT, 5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
      IF(B.LE.1.0)THEN
        WRITE(ICOUT,15)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)B
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
    5 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO THE ',
     1'RECRAN SUBROUTINE IS NON-POSITIVE *****')
   15 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO THE ',
     1'RECRAN SUBROUTINE 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 UNIFORM (0,1) RANDOM NUMBERS;
C
      CALL UNIRAN(N,ISEED,X)
C
C     GENERATE N RECIROCAL DISTRIBUTION RANDOM NUMBERS
C     USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD.
C
      DO100I=1,N
        CALL RECPPF(X(I),B,XTEMP)
        X(I)=XTEMP
  100 CONTINUE
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE REGDAT (NPAR, NTOT, NBCH, NPTS, XPTS, Y, COEF,
CCCCC CALL LIST CHANGED TO REFLECT SWAPPING TO USE LESS MEMORY.
CCCCC$                  U1, S1, V1, U2, TLM0, TLM1, ETA0, ETA1,
     $                  SCRTCH, S1, V1, TLM0, TLM1, ETA0, ETA1,
     $                  WK1, XM, T, X, NLVL,
     $                  ICASRE, IFLAG, ISUBRO, IBUGA2, IERROR)
C
C         SUBROUTINE REGDAT PERFORMS ALL OF THE REGRESSION TOLERANCE LIMIT
C     CALCULATIONS WHICH INVOLVE THE RESPONSE (Y) DATA.  REGINI MUST BE
C     CALLED BEFORE REGDAT, BUT IF MULTIPLE SETS OF Y DATA ARE TO BE
C     ANALYZED (E.G., IN A SIMULATION), THEN REGINI NEED ONLY BE CALLED
C     ONCE.
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      INCLUDE 'DPCOPA.INC'
C
      LOGICAL CONFND
      CHARACTER*4 ICASRE
C
      CHARACTER*4 ISUBRO
      CHARACTER*4 IERROR
      CHARACTER*4 IBUGA2
      CHARACTER*4 IBUGA3
      CHARACTER*4 IOP
      CHARACTER*4 IFLAG
CCCCC CHARACTER*80 IFILE
      CHARACTER (LEN=MAXFNC) :: IFILE
C
CCCCC DIMENSION U1(*),   S1(*),   V1(*),   U2(*),   Y(*),    COEF(*),
      DIMENSION SCRTCH(*),   S1(*),   V1(*),   Y(*),    COEF(*),
     $          XPTS(*), ETA0(*), ETA1(*), TLM0(*), TLM1(*), XM(*),
     $          T(*),    WK1(*), X(*)
C
      COMMON /RECIPA/ IRANK1, IRANK2, TR1, TR2, GNU0, GNU1, CONFND
      COMMON /RECIPB/ NUMXX, NUMU1, NUMU2, NUMH
      COMMON /RECSIM/ RSSA
C
      INCLUDE 'DPCOP2.INC'
C
      DATA ZERO /0.D0/
      DATA ONE/1.D0/
C
      IF(IBUGA2.EQ.'ON')THEN
        WRITE(ICOUT,12)NPAR,NTOT,NBCH,NPTS
   12   FORMAT('NPAR,NTOT,NBCH,NPTS = ',4I8)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      IBUGA3='OFF'
C   -- OLS COEFFICIENTS
      IERROR='NO'
      CALL DSET (NTOT*NPAR, WK1, ZERO)
C
C   -- FOR DATAPLOT, READ U1 ARRAY BACK IN
      IOP='READ'
      IFILE='DPRE2F.DAT'
      CALL DPSWA2(IOP,IFILE,SCRTCH,NUMU1,IBUGA3,ISUBRO,IERROR)
      IF(IERROR.EQ.'YES')RETURN
C
      DO 60 I=1, IRANK1
         CALL DGER (NPAR, NTOT, ONE/S1(I), V1((I-1)*NPAR+1), 1,
CCCCC$              U1((I-1)*NTOT+1), 1, WK1, NPAR, IERROR)
     $              SCRTCH((I-1)*NTOT+1), 1, WK1, NPAR, IERROR)
         IF(IERROR.EQ.'YES')RETURN
 60   CONTINUE
      CALL DGEMV ('N', NPAR, NTOT, ONE, WK1, NPAR,
     $             Y, 1, ZERO, COEF, 1, IERROR)
      IF(IERROR.EQ.'YES')RETURN
C
C    -- CALCULATE RESIDUAL SUMS OF SQUARES FOR BOTH MODELS
      SY = DDOT (NTOT, Y, 1, Y, 1)
CCCCC CALL DGEMV ('T', NTOT, IRANK1, ONE, U1, NTOT, Y, 1, ZERO, WK1, 1,
      CALL DGEMV ('T', NTOT, IRANK1, ONE, SCRTCH, NTOT, Y, 1, ZERO,
     1 WK1, 1, IERROR)
      IF(IERROR.EQ.'YES')RETURN
      RSSA = SY -DDOT (IRANK1, WK1, 1, WK1, 1)
C   -- FOR DATAPLOT, READ U2 ARRAY BACK IN
      IOP='READ'
      IFILE='DPRE3F.DAT'
      CALL DPSWA2(IOP,IFILE,SCRTCH,NUMU2,IBUGA3,ISUBRO,IERROR)
      IF(IERROR.EQ.'YES')RETURN
C
CCCCC CALL DGEMV ('T', NTOT, IRANK2, ONE, U2, NTOT, Y, 1, ZERO, WK1, 1,
      CALL DGEMV ('T', NTOT, IRANK2, ONE, SCRTCH, NTOT, Y, 1, ZERO,
     1  WK1, 1, IERROR)
      IF(IERROR.EQ.'YES')RETURN
      RSSB = SY - DDOT (IRANK2, WK1, 1, WK1, 1)
C
C    -- VARIANCE COMPONENT ESTIMATES
      RMSA = RSSA /(NTOT -IRANK1)
      RMSB = RSSB /(NTOT -IRANK2)
      TMSA = RMSA
      IF (RMSA .LT. RMSB) TMSA = RMSB
      IF (CONFND) THEN
          S2B = ZERO
      ELSE
          S2B  = GNU0 /TR1 *(RMSA -RMSB)
      END IF
      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'GDAT')THEN
        WRITE(ICOUT,2001)TR1
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,2002)TR2
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,2003)S2B
        CALL DPWRST('XXX','BUG ')
      END IF
 2001 FORMAT('TR1 = ',E15.7)
 2002 FORMAT('TR2 = ',E15.7)
 2003 FORMAT('S2B = ',E15.7)
      IF (S2B .LT. ZERO) S2B = ZERO
      S2W  = RMSB
      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'GDAT')THEN
        WRITE(ICOUT,2004)S2W,NPTS
        CALL DPWRST('XXX','BUG ')
      END IF
 2004 FORMAT('S2W, NPTS = ',E15.7,I8)
      S    = SQRT(S2B +S2W)
C
C     -- TOLERANCE LIMIT FACTORS AND TOLERANCE LIMITS
      DO 10 I=1, NPTS
         SMEAN = SQRT(S2B/ETA1(I) +S2W/ETA0(I))
         TFCT  = (SQRT(ETA0(I)*ETA1(I)) *(TLM1(I) -TLM0(I))*SMEAN +
     $           (TLM0(I)*SQRT(ETA0(I)) -TLM1(I)*SQRT(ETA1(I)))*S)/
     $           (SQRT(TMSA) *(SQRT(ETA0(I)) -SQRT(ETA1(I))))
         XM(I) = DDOT (NPAR, XPTS(I), NPTS, COEF, 1)
         IF(IBUGA2.EQ.'ON')THEN
           WRITE(ICOUT,119)I,XM(I)
           CALL DPWRST('XXX','BUG ')
         ENDIF
         T (I) = XM(I) -TFCT*SQRT(RMSA)
 10   CONTINUE
C
C     -- FOR FIT CASE, CALCULATE PREDICTED VALUES AT
C     -- DESIGN POINTS
      IF(IBUGA2.EQ.'ON')THEN
        WRITE(ICOUT,118)ICASRE,NLVL,NPAR
 118    FORMAT('ICASRE,NLVL,NPAR=',A4,1X,2I8)
        CALL DPWRST('XXX','BUG ')
        DO116I=1,NPAR*NLVL
          WRITE(ICOUT,117)I,X(I)
 117      FORMAT('I,X(I)=',I8,E15.7)
          CALL DPWRST('XXX','BUG ')
 116    CONTINUE
        DO115I=1,NPAR*NPTS
          WRITE(ICOUT,114)I,XPTS(I)
 114      FORMAT('I,XPTS(I)=',I8,E15.7)
          CALL DPWRST('XXX','BUG ')
 115    CONTINUE
      ENDIF
      IF(ICASRE.EQ.'FREC')THEN
        DO 19 I=1, NLVL
          XM(I) = DDOT (NPAR, X(I), NLVL, COEF, 1)
          IF(IBUGA2.EQ.'ON')THEN
            WRITE(ICOUT,119)I,XM(I)
 119        FORMAT('I,XM(I)=',I8,E15.7)
            CALL DPWRST('XXX','BUG ')
          ENDIF
 19     CONTINUE
      ENDIF
C   -- FOR DATAPLOT, READ XX ARRAY BACK IN
C   -- FOR RECIPE, READ THIS MATRIX BACK IN, FOR SIMCOV DO NOT
C   -- (SIMCOV MAKES MULTIPLE CALLS TO REGDAT, WANT TO LEAVE
C   -- WK1 MATRIX AS THE SVDC MATRIX)
      IF(IFLAG.EQ.'RECI')THEN
        IOP='READ'
        IFILE='DPRE1F.DAT'
        NUMXX=NTOT*NPAR
        CALL DPSWA2(IOP,IFILE,WK1,NUMXX,IBUGA3,ISUBRO,IERROR)
        IF(IERROR.EQ.'YES')RETURN
      ENDIF
C
      RETURN
      END
      SUBROUTINE REGINI (
CCCCC CALL LIST CHANGED TO REFLECT SWAPPING TO USE LESS MEMORY.
     &             NLVL, NPAR, NTOT, NBCH, NPTS, X, XPTS, IP,
CCCCC$             IQ, CONT, CONF, XX, XTX, XTXI, XN, H,
     $             IQ, CONT, CONF, XX, XTX, XTXI, XN, SCRTCH,
CCCCC$             U1, S1, V1, U2, S2, V2, TLM0, TLM1, ETA0, ETA1,
     $             S1, V1, S2, V2, TLM0, TLM1, ETA0, ETA1,
CCCCC$             SATT, IN2, WK1, WK2, WK3,
     $             SATT, IN2, WK2, WK3,
     $             CRT,ISEED, MAXREP,MAXLVL,
     $             ICASRE,ISUBRO,IBUGA2, IERROR)
C
C        SUBROUTINE REGINI PERFORMS ALL OF THE CALCULATIONS FOR REGRESSION
C     TOLERANCE LIMITS WHICH DO NOT INVOLVE THE RESPONSE (Y) DATA.
C
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      INCLUDE 'DPCOPA.INC'
      REAL AJUNK
      REAL XTMP(1)
C
      LOGICAL CONFND, SATT
CCCCC CHARACTER*10 DUMCHR
      DIMENSION X(*),    XPTS(*), IP(*),  IQ(*),   XX(*), XTX(*),
CCCCC$          XTXI(*), XN(*),   H(*),   U1(*),   S1(*), V1(*),
CCCCC$          U2(*),   S2(*),   V2(*),  TLM0(*), TLM1(*),
CCCCC$          ETA0(*), ETA1(*), WK1(*), WK2(*),  WK3(*)
     $          XTXI(*), XN(*),   SCRTCH(*),   S1(*),   V1(*),
     $          S2(*),   V2(*),  TLM0(*), TLM1(*),
     $          ETA0(*), ETA1(*), WK2(*),  WK3(*), CRT(*)
C
      COMMON /RECIPA/ IRANK1, IRANK2, TR1, TR2, GNU0, GNU1, CONFND
      COMMON /RECIPB/ NUMXX, NUMU1, NUMU2, NUMH
C
      CHARACTER*4 IOP
      CHARACTER*4 IMATCH
CCCCC CHARACTER*80 IFILE
      CHARACTER (LEN=MAXFNC) :: IFILE
C
      CHARACTER*4 ICASRE
C
      CHARACTER*4 IERROR
      CHARACTER*4 IBUGA2
      CHARACTER*4 IBUGA3
      CHARACTER*4 ISUBRO
C
      INCLUDE 'DPCOP2.INC'
C
      DATA ONE /1.D0/
      DATA ZERO/0.D0/
      DATA EPS /1.D-7/
C
      IF(IBUGA3.EQ.'ON')THEN
        WRITE(ICOUT,12)IN2
   12   FORMAT('IN2 = ',I8)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      IBUGA3='OFF'
      IERROR='NO'
C      -- BUILD FULL DATA MATRIX FROM UNIQUE ROWS
C      -- NOTE: DATAPLOT PASSES IN FULL DESIGN MATRIX (MINUS
C               THE BATCH VARIABLE).  NEED TO RECONSTRUCT THE
C               X ARRAY.
C      -- NOTE: FOR EXAMPLE, THE 2-D ARRAY
C                   1 -3 -2
C                   1 -3 0
C                   1  1 -2
C                   1  1 0
C               IS STORED AS
C                   1 1 1 1 -3 -3 1 1 -2 0 -2 0
C               IN THE 1-D ARRAY
C
C      --       A DATAPLOT COMPLICATION IS THAT WE START WITH
C               THE FULL DESIGN MATRIX, BUT WE DON'T KNOW WHAT
C               NLVL IS IN ADVANCE (THAT IS BEING CACLUCATED
C               HERE).  THEREFORE, IN CREATING THE REDUCED DESIGN
C               MATRIX, X, WE NEED TO MAKE AN INITIAL PASS TO
C               DETERMINE THE VALUE OF "NLVL".  DO THIS BY LOOPING
C               THROUGH AND COMPARING EACH ROW OF XX WITH ALL PREVIOUS
C               ROWS OF XX.  INCREMENT NLVL IF NO MATCH FOUND.
C
CCCCC DO 10 I=1, NTOT
CCCCC    DO 20 J=1, NPAR
CCCCC       XX((J-1)*NTOT+I) = X((J-1)*NLVL+IP(I))
C20      CONTINUE
C10   CONTINUE
C
      NLVL=1
      DEPS=1.0D-10
      DO110I=2,NTOT
        IMATCH='NO'
        DO120J=1,I-1
          DO125KK=1,NPAR
            DTERM1=XX((KK-1)*NTOT+I)
            DTERM2=XX((KK-1)*NTOT+J)
CCCCC       IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'GINI')THEN
CCCCC         WRITE(ICOUT,126)I,J,KK,DTERM1,DTERM2
CC126         FORMAT('I,J,KK=',3I8,2D15.7)
CCCCC         CALL DPWRST('XXX','BUG ')
CCCCC       ENDIF
            IF(DABS(DTERM1-DTERM2).GT.DEPS)THEN
              GOTO120
            ENDIF
  125    CONTINUE
         IMATCH='YES'
         GOTO110
  120  CONTINUE
       IF(IMATCH.EQ.'NO')NLVL=NLVL+1
  110 CONTINUE
C
      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'GINI')THEN
        WRITE(ICOUT,132)NLVL
        CALL DPWRST('XXX','BUG ')
      ENDIF
  132 FORMAT('NLVL=',I8)
C
      DO5J=1,NPAR
        X((J-1)*NLVL+1)=XX((J-1)*NTOT+1)
    5 CONTINUE
      ITEST=1
      IP(1)=ITEST
C
      DO10I=2,NTOT
        IMATCH='NO'
        DO20J=1,ITEST
          DO25K=1,NPAR
            DTERM1=XX((K-1)*NTOT+I)
            DTERM2=X((K-1)*NLVL+J)
CCCCC       IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'GINI')THEN
CCCCC         WRITE(ICOUT,136)I,J,K,DTERM1,DTERM2
CC136         FORMAT('I,J,KK=',3I8,2D15.7)
CCCCC         CALL DPWRST('XXX','BUG ')
CCCCC       ENDIF
            IF(DABS(DTERM1-DTERM2).GT.DEPS)THEN
              GOTO20
            ENDIF
   25     CONTINUE
          IP(I)=J
          GOTO10
   20   CONTINUE
        ITEST=ITEST+1
        DO35KK=1,NPAR
          X((KK-1)*NLVL+ITEST)=XX((KK-1)*NTOT+I)
   35   CONTINUE
        IP(I)=ITEST
   10 CONTINUE
C
      IF(ITEST.NE.NLVL)THEN
        WRITE(ICOUT,142)NLVL,ITEST
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        RETURN
      ENDIF
  142 FORMAT('***** INTERNAL ERROR FROM REGINI--NUMBER OF LEVELS ',
     1'PASS 1 = ',I8,' NUMBER OF LEVELS PASS 2 = ',I8)
      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'GINI')THEN
        DO1001I=1,NLVL*NPAR
        WRITE(ICOUT,1002)I,X(I)
        CALL DPWRST('XXX','BUG ')
 1001   CONTINUE
        DO1006I=1,NTOT
        WRITE(ICOUT,1007)I,IP(I)
        CALL DPWRST('XXX','BUG ')
 1006   CONTINUE
      ENDIF
 1002 FORMAT('I,X(I)=',I8,D15.7)
 1007 FORMAT('I,IP(I)=',2I8)
C
      IF(NLVL.GT.MAXLVL)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,101)NLVL
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,102)MAXLVL
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        RETURN
      ENDIF
  101 FORMAT('**** ERROR FROM REGINI:  THE NUMBER OF LEVELS IN THE ',
     1'DESIGN MATRIX ',I8)
  102 FORMAT('     EXCEEDS THE MAXIMUM ALLOWABLE ',I8)
C
C   --FOR RECIPE FIT CASE, XPTS IS CREATED FROM USER SUPPLIED DATA.
C   --FOR RECIPE ANOVA CASE, XPTS IS EQUAL TO X MATRIX (THAT IS,
C   --WE WILL COMPUTE A TOLERANCE VALUE AT ALL UNIQUE DESIGN
C   --POINTS.
C   --FOR ANOVA CASE, XPTS SHOULD BE ALL ZERO'S.  FOR FIT CASE
C   --FIRST NTOT ROWS SHOULD BE 1 (CORRESPONDING TO THE CONSTANT).
C
      IF(ICASRE.EQ.'AREC'.OR.(ICASRE.EQ.'FREC'.AND.NPTS.EQ.0))THEN
        NPTS=NLVL
        DO42I=1,NPAR*NLVL
          XPTS(I)=X(I)
 42     CONTINUE
      ENDIF
C
C   -- NEED COPY OF XX, BECAUSE DSVDC DESTROYS INPUT MATRIX
C   -- FOR DATAPLOT, COPY XX FILE TO A SWAP FILE, USE XX IN SUBSEQUENT
C      CALCULATIONS.
      IOP='WRIT'
      IFILE='DPRE1F.DAT'
      NUMXX=NTOT*NPAR
      CALL DPSWA2(IOP,IFILE,XX,NUMXX,IBUGA3,ISUBRO,IERROR)
      IF(IERROR.EQ.'YES')RETURN
C
CCCCC CALL DCOPY (NTOT*NPAR, XX, 1, WK1, 1)
C
C   --  XX^T *XX
      CALL DGEMM ('T', 'N', NPAR, NPAR, NTOT, ONE, XX, NTOT,
     $             XX, NTOT, ZERO, XTX, NPAR,IERROR)
      IF(IERROR.EQ.'YES')RETURN
C
C    --  SVD OF DESIGN MATRIX XX (COPY IN WK1)
      IJOB = 21
      LDU  = NTOT
      LDV  = NPAR
      TOL  = 1.D-7
CCCCC CALL DSVDC (WK1 , NTOT, NTOT, NPAR, S1, WK2, U1, LDU, V1, LDV,
      CALL DSVDC (XX , NTOT, NTOT, NPAR, S1, WK2, SCRTCH, LDU, V1, LDV,
     $            WK3, IJOB, INFO)
C   -- FOR DATAPLOT, COPY U1 (=SCRTCH) FILE TO A SWAP FILE
      IOP='WRIT'
      IFILE='DPRE2F.DAT'
      NUMU1=NTOT*NPAR
      CALL DPSWA2(IOP,IFILE,SCRTCH,NUMU1,IBUGA3,ISUBRO,IERROR)
      IF(IERROR.EQ.'YES')RETURN
C
C    -- RANK (XX)
      IRANK1 = 0
      DO 30 I=1, NPAR
         IF (ABS(S1(I)) .LT. TOL) GO TO 40
         IRANK1 = IRANK1 +1
 30   CONTINUE
 40   CONTINUE
C
C     -- DO "SIMRAT" CODE HERE
      IF(.NOT.SATT)THEN
        IOP='WRIT'
        IFILE='DPRE3F.DAT'
        NUMXX=NTOT*NPAR
        CALL DPSWA2(IOP,IFILE,XX,NUMXX,IBUGA3,ISUBRO,IERROR)
        IF(IERROR.EQ.'YES')RETURN
C
        IOP='WRIT'
        IFILE='DPRE4F.DAT'
        NUMXPT=NPTS*NPAR
        CALL DPSWA2(IOP,IFILE,XPTS,NUMXPT,IBUGA3,ISUBRO,IERROR)
        IF(IERROR.EQ.'YES')RETURN
C
        CALL NODPPF(CONT,ZCONT)
        NREP=MAXREP
        NRAN=1
        DO 900 I=1, NPTS
CCCCC    Z = RNOR(ISEED)
         CALL NORRAN(NRAN,ISEED,XTMP)
         Z=DBLE(XTMP(1))
CCCCC    CALL DCOPY(NPAR,  XPTS(I), NPTS, W, 1)
         CALL SIMRAT
CCCCC$     (U1,S1,V1,IQ,W,NBCH,NTOT,NPAR,NREP,IRK,ZCONT,CONF,
CCCCC$      WK1,WK2,VALS,QUANT)
     $     (SCRTCH,S1,V1,IQ,XPTS,NBCH,NTOT,NPAR,NREP,IRK,ZCONT,CONF,
     $      WK2,WK3,XX,QUANT, IERROR)
           IF(IERROR.EQ.'YES')RETURN
           CRT(I)=QUANT
 900  CONTINUE
C
        IOP='READ'
        IFILE='DPRE2F.DAT'
        CALL DPSWA2(IOP,IFILE,SCRTCH,NUMU1,IBUGA3,ISUBRO,IERROR)
        IF(IERROR.EQ.'YES')RETURN
C
        IOP='READ'
        IFILE='DPRE3F.DAT'
        NUMXX=NTOT*NPAR
        CALL DPSWA2(IOP,IFILE,XX,NUMXX,IBUGA3,ISUBRO,IERROR)
        IF(IERROR.EQ.'YES')RETURN
C
        IOP='READ'
        IFILE='DPRE4F.DAT'
        NUMXPT=NPTS*NPAR
        CALL DPSWA2(IOP,IFILE,XPTS,NUMXPT,IBUGA3,ISUBRO,IERROR)
        IF(IERROR.EQ.'YES')RETURN
      ENDIF
C
C     -- INVERSE (XX^T XX)
      CALL DSET (NPAR*NPAR, XTXI, ZERO)
      DO 50 I=1, IRANK1
         CALL DGER (NPAR, NPAR, ONE/S1(I)**2, V1((I-1)*NPAR+1), 1,
     $              V1((I-1)*NPAR+1), 1, XTXI, NPAR,IERROR)
         IF(IERROR.EQ.'YES')RETURN
 50   CONTINUE
C
C     -- H = X *INVERSE(XX^T XX) *X^T
      CALL DGEMM ('N', 'N', NLVL, NPAR, NPAR, ONE, X, NLVL,
CCCCC$              XTXI, NPAR, ZERO, WK1, NLVL,IERROR)
     $              XTXI, NPAR, ZERO, XX, NLVL,IERROR)
      IF(IERROR.EQ.'YES')RETURN
CCCCC CALL DGEMM ('N', 'T', NLVL, NLVL, NPAR, ONE, WK1, NLVL,
CCCCC$             X, NLVL, ZERO, H, NLVL,IERROR)
      CALL DGEMM ('N', 'T', NLVL, NLVL, NPAR, ONE, XX, NLVL,
     $             X, NLVL, ZERO, SCRTCH, NLVL,IERROR)
C   -- FOR DATAPLOT, COPY H (=SCRTCH) FILE TO A SWAP FILE
      IOP='WRIT'
      IFILE='DPRE4F.DAT'
      NUMH=NLVL*NLVL
      CALL DPSWA2(IOP,IFILE,SCRTCH,NUMH,IBUGA3,ISUBRO,IERROR)
      IF(IERROR.EQ.'YES')RETURN
C
      IF(IERROR.EQ.'YES')RETURN
C
C    -- AUGMENT THE XX MATRIX WITH BATCH INDICATORS
C    -- FOR DATAPLOT, READ ORIGINAL XX MATRIX BACK IN
      IOP='READ'
      IFILE='DPRE1F.DAT'
      NUMXX=NTOT*NPAR
      CALL DPSWA2(IOP,IFILE,XX,NUMXX,IBUGA3,ISUBRO,IERROR)
      IF(IERROR.EQ.'YES')RETURN
C
      CALL DSET (NTOT*NBCH, XX(NTOT*NPAR+1), ZERO)
      DO 70 I=1, NTOT
        XX((IQ(I)+NPAR-1)*NTOT +I) = ONE
 70   CONTINUE
C
C     -- DO AN SVD ON THE AUGMENTED MATRIX
      IJOB = 21
      LDU  = NTOT
      NCOL = NPAR+NBCH
      LDV  = NCOL
      TOL  = 1.D-7
CCCCC CALL DCOPY (NTOT*NCOL, XX, 1, WK1, 1)
CCCCC CALL DSVDC (WK1, NTOT, NTOT, NCOL, S2, WK2, U2,
CCCCC$            LDU, V2, LDV,  WK3, IJOB, INFO)
      CALL DSVDC (XX, NTOT, NTOT, NCOL, S2, WK2, SCRTCH,
     $            LDU, V2, LDV,  WK3, IJOB, INFO)
C   -- FOR DATAPLOT, COPY U2 (=SCRTCH) FILE TO A SWAP FILE
      IOP='WRIT'
      IFILE='DPRE3F.DAT'
CCCCC NUMU2=NTOT*(NPAR+NUMBCH)
      NUMU2=NTOT*(NPAR+NBCH)
      CALL DPSWA2(IOP,IFILE,SCRTCH,NUMU2,IBUGA3,ISUBRO,IERROR)
      IF(IERROR.EQ.'YES')RETURN
C
C    -- GET RANK OF AUGMENTED DESIGN MATRIX
      IRANK2 = 0
      DO 80 I=1, NPAR+NBCH
         IF (ABS(S2(I)) .LT. TOL) GO TO 90
         IRANK2 = IRANK2 +1
 80   CONTINUE
 90   CONTINUE
C
      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'GINI')THEN
        WRITE(ICOUT,91)IRANK2
        CALL DPWRST('XXX','BUG ')
      ENDIF
   91 FORMAT('FROM REGINI--IRANK2=',I8)
C
C     -- CALCULATE N, M, B =M-N^T*H*N, TR(B), AND TR(B^2)
      CALL DSET (NBCH*NLVL, XN, ZERO)
      DO 100 I=1, NTOT
        IDX = (IQ(I)-1)*NLVL +IP(I)
        XN(IDX) = XN(IDX) +1
 100  CONTINUE
CCCCC CALL DGEMM  ('T', 'N', NBCH, NLVL, NLVL, ONE, XN, NLVL,
CCCCC$             H, NLVL, ZERO, WK1, NBCH,IERROR)
C   -- FOR DATAPLOT, READ H (=SCRTCH) FROM SWAP FILE
      IOP='READ'
      IFILE='DPRE4F.DAT'
      NUMH=NLVL*NLVL
      CALL DPSWA2(IOP,IFILE,SCRTCH,NUMH,IBUGA3,ISUBRO,IERROR)
      IF(IERROR.EQ.'YES')RETURN
C
      CALL DGEMM  ('T', 'N', NBCH, NLVL, NLVL, ONE, XN, NLVL,
     1             SCRTCH, NLVL, ZERO, XX, NBCH,IERROR)
      IF(IERROR.EQ.'YES')RETURN
CCCCC CALL DGEMM  ('N', 'N', NBCH , NBCH, NLVL, ONE, WK1, NBCH,
      CALL DGEMM  ('N', 'N', NBCH , NBCH, NLVL, ONE, XX, NBCH,
     $             XN, NLVL, ZERO, WK2, NBCH,IERROR)
      IF(IERROR.EQ.'YES')RETURN
CCCCC CALL DSET   (NLVL, WK1, ONE)
      CALL DSET   (NLVL, XX, ONE)
CCCCC CALL DGEMV  ('T', NLVL, NBCH, ONE, XN, NLVL, WK1, 1,ZERO,WK3,1,
      CALL DGEMV  ('T', NLVL, NBCH, ONE, XN, NLVL, XX, 1,ZERO,WK3,1,
     $             IERROR)
      IF(IERROR.EQ.'YES')RETURN
      CALL DSCAL  (NBCH*NBCH, -ONE, WK2, 1)
      CALL DAXPY  (NBCH, ONE, WK3, 1, WK2, NBCH+1)
      TR1 = DSUM  (NBCH, WK2, NBCH+1)
      TR2 = DDOT  (NBCH*NBCH, WK2, 1, WK2, 1)
C
C    -- CHECK TO SEE IF BETWEEN-BATCH VARIANCE IS CONFOUNDED WITH FIXED PART
C
      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'GINI')THEN
        WRITE(ICOUT,191)TR1,TR2,EPS
        CALL DPWRST('XXX','BUG ')
      ENDIF
  191 FORMAT('FROM REGINI--TR1,TR2,EPS=',3D15.7)
      IF (TR2 .LE. EPS) THEN
         IF(ICASRE.NE.'UREC')THEN
         WRITE(ICOUT,999)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,2001)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,2002)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,2003)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,2004)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,999)
         CALL DPWRST('XXX','BUG ')
         ENDIF
         CONFND = .TRUE.
      ELSE
         CONFND = .FALSE.
      END IF
  999 FORMAT(' ')
 2001 FORMAT(' REGINI : WARNING: BETWEEN-BATCH VARIANCE CANNOT')
 2002 FORMAT('          BE ESTIMATED FROM THESE DATA. RESULTS')
 2003 FORMAT('          WILL BE BASED ON THE ASSUMPTION THAT THE')
 2004 FORMAT('          BETWEEN-BATCH VARIABILITY IS NEGLIGIBLE.')
C
C    -- VARIANCE OF MEAN WHEN S2W = 0
      CALL DGEMM ('T', 'N', NBCH, NPAR, NLVL, ONE, XN, NLVL, X,
CCCCC$             NLVL, ZERO, WK1, NBCH, IERROR)
     $             NLVL, ZERO, XX, NBCH, IERROR)
      IF(IERROR.EQ.'YES')RETURN
CCCCC CALL DGEMM ('T', 'N', NPAR, NPAR, NBCH, ONE, WK1, NBCH, WK1,
      CALL DGEMM ('T', 'N', NPAR, NPAR, NBCH, ONE, XX, NBCH, XX,
     $             NBCH, ZERO, WK2, NPAR, IERROR)
      IF(IERROR.EQ.'YES')RETURN
      CALL DGEMM ('N', 'N', NPAR, NPAR, NPAR, ONE, XTXI, NPAR, WK2,
CCCCC$             NPAR, ZERO, WK1, NPAR, IERROR)
     $             NPAR, ZERO, XX, NPAR, IERROR)
      IF(IERROR.EQ.'YES')RETURN
CCCCC CALL DGEMM ('N', 'N', NPAR, NPAR, NPAR, ONE, WK1, NPAR, XTXI,
      CALL DGEMM ('N', 'N', NPAR, NPAR, NPAR, ONE, XX, NPAR, XTXI,
     $             NPAR, ZERO, WK2, NPAR, IERROR)
      IF(IERROR.EQ.'YES')RETURN
C
C     -- TOLERANCE LIMIT FACTORS
C     8/97.  REPLACE WITH DATAPLOT NODPPF ROUTINE.
CCCCC ZCONT = PPND16 (CONT, IFAULT)
      CALL NODPPF (CONT, ZCONT)
      IF (.NOT. CONFND) GNU1 = TR1**2 /TR2
      GNU0 = NTOT -IRANK1
      NDF  = IRANK2 -IRANK1
      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'GINI')THEN
        WRITE(ICOUT,2011)CONT,ZCONT,GNU0, NDF
        CALL DPWRST('XXX','BUG ')
      ENDIF
 2011 FORMAT('CONT,ZCONT, GNU0, NDF = ',3D15.7,I8)
C
C     -- IF SIMULATED CRITICAL VALUES ARE TO BE USED, SKIP
C        THE HEADER LINE IN THE CRITICAL VALUE FILE
CCCCC NOTE: FOR DATAPLOT, NOT ACTUALLY READING FILE, SO SKIP
CCCCC       THIS STEP.
CCCCC IF (.NOT. SATT) THEN
CCCCC    READ (IN2,'(A)') DUMCHR
CCCCC END IF
      DO 130 I=1, NPTS
         CALL DGEMV ('N', NPAR, NPAR, ONE, XTXI, NPAR, XPTS(I), NPTS,
CCCCC$               ZERO, WK1, 1, IERROR)
     $               ZERO, XX, 1, IERROR)
         IF(IERROR.EQ.'YES')RETURN
CCCCC    ETA0(I) = ONE /DDOT (NPAR, WK1, 1, XPTS(I), NPTS)
         ETA0(I) = ONE /DDOT (NPAR, XX, 1, XPTS(I), NPTS)
         CALL DGEMV ('N', NPAR, NPAR, ONE, WK2, NPAR, XPTS(I),
CCCCC$               NPTS, ZERO, WK1, 1, IERROR)
     $               NPTS, ZERO, XX, 1, IERROR)
         IF(IERROR.EQ.'YES')RETURN
CCCCC    ETA1(I) = ONE /DDOT (NPAR, WK1, 1, XPTS(I), NPTS)
         ETA1(I) = ONE /DDOT (NPAR, XX, 1, XPTS(I), NPTS)
         XNCP0 = ZCONT *SQRT(ETA0(I))
         XNCP1 = ZCONT *SQRT(ETA1(I))
         IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'GINI')THEN
           WRITE(ICOUT,2021)I,XNCP0,XNCP1
           CALL DPWRST('XXX','BUG ')
         ENDIF
 2021 FORMAT('I,XNCP0, XNCP1 = ',I8,D15.7,D15.7)
C

CCCCC 8/97.  REPLACE FOLLOWING NON-CENTRAL T PPF WITH DATAPLOT
CCCCC        VERSION NCTPPF.
CCCCC    CALL INVNCT (CONF, GNU0, XNCP0,  TLM0(I))
         CALL NCTPPF (SNGL(CONF), SNGL(GNU0), SNGL(XNCP0),  AJUNK)
         TLM0(I)=DBLE(AJUNK)
         IF (CONFND) THEN
             TLM1(I) = TLM0(I)
         ELSE
CCCCC 8/97.  REPLACE FOLLOWING NON-CENTRAL T PPF WITH DATAPLOT
CCCCC        VERSION DNTPPF.
CCCCC       CALL INVNCT (CONF, GNU1, XNCP1,  TLM1(I))
            CALL NCTPPF (SNGL(CONF), SNGL(GNU1), SNGL(XNCP1), AJUNK)
            TLM1(I)=DBLE(AJUNK)
            IF (.NOT. SATT) THEN
CCCCC         READ (IN2,*) CRT
              TLM1(I) = CRT(I) *SQRT(TR1 *ETA1(I)/GNU0)
            END IF
         END IF
         TLM0(I) = TLM0(I)/SQRT(ETA0(I))
         TLM1(I) = TLM1(I)/SQRT(ETA1(I))
         IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'GINI')THEN
           WRITE(ICOUT,2031)I,TLM0(I),TLM1(I),ETA0(I),ETA1(I)
           CALL DPWRST('XXX','BUG ')
         ENDIF
 2031 FORMAT('I,TLM0(I),TLM1(I),ETA0(I),ETA1(I) = ',I8,4D15.7)
 130  CONTINUE
      RETURN
      END
      SUBROUTINE RELRSK(X,N1,Y,N2,PSTAMV,IWRITE,XIDTEM,STAT,
     1                  IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE RELATIVE RISK
C              (= P1/P2 WHERE P1 = PROBABILITY OF SUCCESS FOR
C              VARIABLE 1 AND P2 = PROBABILITY OF SUCCESS FOR
C              VARIABLE 2)
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF
C                                (UNSORTED) OBSERVATIONS
C                                WHICH CONSTITUTE THE FIRST SET
C                                OF DATA.
C                     --N1     = THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR X.
C                     --Y      = THE SINGLE PRECISION VECTOR OF
C                                (UNSORTED) OBSERVATIONS
C                                WHICH CONSTITUTE THE SECOND SET
C                                OF DATA.
C                     --N2     = THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR Y.
C                     --PSTAMV = THE MISSING VALUE CODE.
C     OUTPUT ARGUMENTS--STAT   = THE SINGLE PRECISION VALUE OF THE
C                                RELATIVE RISK BETWEEN THE 2 SETS
C                                OF DATA IN THE INPUT VECTORS
C                                X AND Y.
C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
C             RELATIVE RISK BETWEEN THE 2 SETS
C             OF DATA IN THE INPUT VECTORS X AND Y.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--ODDDIS.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTIUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2899
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2007/4
C     ORIGINAL VERSION--APRIL     2007.
C     UPDATED         --AUGUST    2007. IF 2X2 CASE, CHECK IF SUM
C                                       OF ENTRIES IS <= 4.  IN THIS
C                                       CASE, ASSUME WE HAVE RAW DATA
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISTEPN
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
      DIMENSION Y(*)
      DIMENSION XIDTEM(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='RELR'
      ISUBN2='SK  '
      IERROR='NO'
C
C
      IF(IBUGA3.EQ.'ON')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,51)
   51   FORMAT('***** AT THE BEGINNING OF RELRSK--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,52)IBUGA3
   52   FORMAT('IBUGA3 = ',A4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,53)N1,N2
   53   FORMAT('N1,N2 = ',2I8)
        CALL DPWRST('XXX','BUG ')
        DO55I=1,MAX(N1,N2)
          WRITE(ICOUT,56)I,X(I),Y(I)
   56     FORMAT('I,X(I),Y(I) = ',I8,2G15.7)
          CALL DPWRST('XXX','BUG ')
   55   CONTINUE
      ENDIF
C
C               ********************************************
C               **  STEP 21--                             **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      ISTEPN='21'
      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(N1.LT.2)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,1201)
 1201   FORMAT('***** ERROR IN THE RELATIVE RISK')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,1203)
 1203   FORMAT('      THE NUMBER OF OBSERVATIONS FOR THE FIRST ',
     1         'RESPONSE VARIABLES IS LESS THAN TWO')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,1205)N1
 1205   FORMAT('SAMPLE SIZE = ',I8)
        CALL DPWRST('XXX','WRIT')
        IERROR='YES'
        GOTO9000
      ENDIF
C
      IF(N2.LT.2)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,1201)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,1213)
 1213   FORMAT('      THE NUMBER OF OBSERVATIONS FOR THE SECOND ',
     1         'RESPONSE VARIABLES IS LESS THAN TWO')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,1205)N2
        CALL DPWRST('XXX','WRIT')
        IERROR='YES'
        GOTO9000
      ENDIF
C
C     NOTE: CHECK FOR SPECIAL CASE N = 2.  IN THIS CASE,
C           ASSUME WE HAVE A 2X2 TABLE OF COUNTS INSTEAD
C           OF RAW DATA.
C
      IF(N1.EQ.2 .AND. N2.EQ.2)THEN
        N11=INT(X(1)+0.5)
        N21=INT(X(2)+0.5)
        N12=INT(Y(1)+0.5)
        N22=INT(Y(2)+0.5)
C
C       CHECK IF ALL ENTRIES 0 OR 1. IF SO, ASSUME
C       RAW DATA CASE.
C
        IF((N11.EQ.0 .OR. N11.EQ.1) .AND.
     1     (N12.EQ.0 .OR. N12.EQ.1) .AND.
     1     (N21.EQ.0 .OR. N21.EQ.1) .AND.
     1     (N22.EQ.0 .OR. N22.EQ.1)) GOTO1349
C
        IF(N11.LT.0)THEN
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,1201)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,1311)
 1311     FORMAT('      ROW 1 COLUMN 1 OF THE COUNTS TABLE IS ',
     1           'NEGATIVE.')
          CALL DPWRST('XXX','BUG ')
        ELSEIF(N21.LT.0)THEN
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,1201)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,1321)
 1321     FORMAT('      ROW 2 COLUMN 1 OF THE COUNTS TABLE IS ',
     1           'NEGATIVE.')
          CALL DPWRST('XXX','BUG ')
        ELSEIF(N12.LT.0)THEN
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,1201)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,1331)
 1331     FORMAT('      ROW 1 COLUMN 2 OF THE COUNTS TABLE IS ',
     1           'NEGATIVE.')
          CALL DPWRST('XXX','BUG ')
        ELSEIF(N22.LT.0)THEN
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,1201)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,1341)
 1341     FORMAT('      ROW 2 COLUMN 2 OF THE COUNTS TABLE IS ',
     1           'NEGATIVE.')
          CALL DPWRST('XXX','BUG ')
        ENDIF
C
        AN11=REAL(N11)
        AN21=REAL(N21)
        AN12=REAL(N12)
        AN22=REAL(N22)
        GOTO3000
      ENDIF
C
 1349 CONTINUE
C
      CALL ODDDIS(X,N1,PSTAMV,IWRITE,XIDTEM,N11,N21,NOUT,
     1            IBUGA3,IERROR)
      IF(IERROR.EQ.'YES' .OR. IERROR.EQ.'ON')GOTO9000
      CALL ODDDIS(Y,N2,PSTAMV,IWRITE,XIDTEM,N12,N22,NOUT,
     1            IBUGA3,IERROR)
      IF(IERROR.EQ.'YES' .OR. IERROR.EQ.'ON')GOTO9000
      AN11=REAL(N11)
      AN21=REAL(N21)
      AN12=REAL(N12)
      AN22=REAL(N22)
      GOTO3000
C
C     COMPUTE THE BIAS CORRECTED LOG OF THE ODDS RATIO.
C
 3000 CONTINUE
      AN1=AN11+AN21
      AN2=AN12+AN22
      AN=AN1 + AN2
C
      P11=AN11/AN1
      P21=AN21/AN1
      P12=AN12/AN2
      P22=AN22/AN2
C
      IF(P12.GT.0.0)THEN
        STAT=(P11/AN)/(P12/AN)
      ELSE
        STAT=0.0
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,1201)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,2411)
 2411   FORMAT('      PROBABILITY OF SUCCESS FOR VARIABLE TWO')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,2413)
 2413   FORMAT('      IS ZERO.  UNABLE TO COMPUTE RELATIVE RISK.')
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
C
C               *******************************
C               **  STEP 3--                 **
C               **  WRITE OUT A LINE         **
C               **  OF SUMMARY INFORMATION.  **
C               *******************************
C
      IF(IFEEDB.EQ.'OFF')GOTO890
      IF(IWRITE.EQ.'OFF' .OR. IWRITE.EQ.'NO')GOTO890
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,811)STAT
  811 FORMAT('THE RELATIVE RISK = ',G15.7)
      CALL DPWRST('XXX','BUG ')
  890 CONTINUE
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'ON')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END OF RELRSK--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9012)IBUGA3,IERROR
 9012   FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9013)N,N11,N12,N21,N22
 9013   FORMAT('N,N11,N12,N21,N22 = ',5I10)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9014)P11,P12,P21,P22
 9014   FORMAT('P11,P12,P21,P22 = ',4G15.7)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9015)STAT
 9015   FORMAT('STAT = ',G15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      RETURN
      END
      SUBROUTINE RELSD(X,N,IWRITE,XRELSD,IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE
C              SAMPLE RELATIVE STANDARD DEVIATION
C              OF THE DATA IN THE INPUT VECTOR X.
C              THE SAMPLE RELATIVE STANDARD DEVIATION = 100 * (THE SAMPLE
C              STANDARD DEVIATION)/(THE SAMPLE MEAN).
C              THE DENOMINATOR N-1 IS USED IN COMPUTING THE
C              SAMPLE STANDARD DEVIATION.
C              THE SAMPLE RELATIVE STANDARD DEVIATION IS ALTERNATIVELY
C              REFERRED TO AS THE SAMPLE COEFFICIENT OF VARIATION.
C              THE SAMPLE STANDARD DEVIATION = SQRT((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--XRELSD = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED SAMPLE RELATIVE STANDARD DEVIATION.
C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
C             SAMPLE RELATIVE STANDARD DEVIATION.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--DSQRT.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--KENDALL AND STUART, THE ADVANCED THEORY OF
C                 STATISTICS, VOLUME 1, EDITION 2, 1963, PAGES 47, 233.
C               --SNEDECOR AND COCHRAN, STATISTICAL METHODS,
C                 EDITION 6, 1967, PAGES 62-65.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (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         --AUGUST    1981.
C     UPDATED         --MAY       1982.
C     UPDATED         --FEBRUARY  1994. USE ABS OF MEAN
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
      DOUBLE PRECISION DSD
C
      DIMENSION X(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='RELS'
      ISUBN2='D   '
      IERROR='NO'
C
      DMEAN=0.0D0
      DSD=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 RELSD--')
      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 RELATIVE STANDARD DEVIATION  **
C               *******************************************
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      AN=N
C
      IF(N.GE.1)GOTO119
      IERROR='YES'
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,111)
  111 FORMAT('***** ERROR IN RELSD--')
      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 RELATIVE STANDARD DEVIATION IS TO BE ',
     1'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 RELSD--',
     1'THE SECOND INPUT ARGUMENT (N) HAS THE VALUE 1')
      CALL DPWRST('XXX','BUG ')
      XRELSD=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 RELSD--',
     1'THE FIRST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      XRELSD=0.0
      GOTO9000
  139 CONTINUE
C
C               ************************************************
C               **  STEP 2--                                  **
C               **  COMPUTE THE RELATIVE STANDARD DEVIATION.  **
C               ************************************************
C
      DN=N
      DSUM=0.0D0
      DO200I=1,N
      DX=X(I)
      DSUM=DSUM+DX
  200 CONTINUE
      DMEAN=DSUM/DN
      XMEAN=DMEAN
C
      DSUM=0.0D0
      DO300I=1,N
      DX=X(I)
      DSUM=DSUM+(DX-DMEAN)**2
  300 CONTINUE
      DVAR=DSUM/(DN-1.0D0)
      DSD=0.0D0
      IF(DVAR.GT.0.0D0)DSD=DSQRT(DVAR)
CCCCC MODIFY FOLLOWING LINE.  FEBRUARY 1994.
CCCCC XRELSD=100.0D0*DSD/DMEAN
      XRELSD=100.0D0*DSD/ABS(DMEAN)
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,XRELSD
  811 FORMAT('THE RELATIVE STANDARD DEVIATION OF THE ',I8,
     1' OBSERVATIONS = ',E15.7,' PERCENT')
      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 RELSD--')
      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,DSD
 9014 FORMAT('DMEAN,DSD = ',2D15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9015)XRELSD
 9015 FORMAT('XRELSD = ',E15.7)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE REPEAZ(Y,X,XIDTEM,TEMP,N,IWRITE,XREP,
     1ISUBRO,IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE SAMPLE REPEATABILITY
C              STANDARD DEVIATION OF THE DATA IN THE INPUT VECTOR Y
C              WITH LAB ID VECTOR X.  THE REPEATABILITY STANDARD
C              DEVIATION IS DEFINED AS:
C
C                 Sr = SQRT(SUM[i=1 to p][s(i)**2/p]
C
C              WITH
C                 p      = NUMBER OF LABS
C                 s(i)   = STANDARD DEVIATION OF GROUP i.
C
C     INPUT  ARGUMENTS--Y      = THE SINGLE PRECISION VECTOR OF
C                                (UNSORTED OR SORTED) OBSERVATIONS.
C                     --X      = THE SINGLE PRECISION VECTOR OF
C                                GROUP ID's.
C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR Y.
C     OUTPUT ARGUMENTS--XREP   = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED SAMPLE REPEATABILITY SD.
C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
C             SAMPLE REPEATABILITY SD.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--SORT, DISTIN, SD.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--SQRT.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--"Standard Practice for Conducting an
C                 Interlaboratory Study to Determine the Precision
C                 of a Test Method", ASTM International,
C                 100 Barr Harbor Drive, PO BOX C700,
C                 West Conshohoceken, PA 19428-2959, USA.
C                 This document is in support of
C                 ASTM Standard E 691 - 99.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2005.2
C     ORIGINAL VERSION--FEBRUARY  2005.
C     UPDATED         --NOVEMBER  2009. MODIFY NAME TO AVOID CONFLICT
C                                       WITH INTRINSIC REPEAT FUNCTION
C                                       ON SOME FORTRAN 90 COMPILERS
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGA3
      CHARACTER*4 ISUBRO
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DSUM
C
      DIMENSION Y(*)
      DIMENSION X(*)
      DIMENSION XIDTEM(*)
      DIMENSION TEMP(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='REPE'
      ISUBN2='AT  '
      IERROR='NO'
C
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'PEAT')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,51)
   51   FORMAT('***** AT THE BEGINNING OF REPEAT--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,52)IBUGA3,ISUBRO,N
   52   FORMAT('IBUGA3,ISUBRO,N = ',A4,1X,A4,1X,I8)
        CALL DPWRST('XXX','BUG ')
        DO55I=1,N
          WRITE(ICOUT,56)I,Y(I),X(I)
   56     FORMAT('I,Y(I),X(I) = ',I8,2E15.7)
          CALL DPWRST('XXX','BUG ')
   55   CONTINUE
      ENDIF
C
C               **********************
C               **  COMPUTE REPEAT  **
C               ********************
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      AN=N
C
      IF(N.LE.1)THEN
        IERROR='YES'
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,111)
  111   FORMAT('***** ERROR IN COMPUTING REPEATABILITY SD--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,112)
  112   FORMAT('      THE INPUT NUMBER OF OBSERVATIONS IN THE')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,114)
  114   FORMAT('      VARIABLES FOR WHICH THE REPEATABILITY SD IS ')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,115)
  115   FORMAT('      TO BE COMPUTED MUST BE 2 OR LARGER.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,116)
  116   FORMAT('      SUCH WAS NOT THE CASE HERE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,117)N
  117   FORMAT('      THE INPUT NUMBER OF OBSERVATIONS = ',I8,'.')
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        GOTO9000
      ENDIF
C
C               ****************************************************
C               **  STEP 2--                                      **
C               **  COMPUTE THE REPEATABILTY STANDARD DEVIATION.  **
C               ****************************************************
C
      IWRITE='OFF'
      CALL DISTIN(X,N,IWRITE,XIDTEM,NUMSET,IBUGA3,IERROR)
      CALL SORT(XIDTEM,NUMSET,XIDTEM)
C
      IF(NUMSET.LT.1)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,111)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,192)
  192   FORMAT('      NUMBER OF LABS    NUMSET < 1')
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        GOTO9000
      ENDIF
C
      AN=N
      ANUMSE=NUMSET
C
      DSUM=0.0D0
      J=0
      DO1110ISET1=1,NUMSET
        K=0
        DO1130I=1,N
          IF(XIDTEM(ISET1).EQ.X(I))THEN
            K=K+1
            TEMP(K)=Y(I)
          ENDIF
 1130   CONTINUE
        NTEMP=K
        CALL SD(TEMP,NTEMP,IWRITE,XSD,IBUGA3,IERROR)
        DSUM=DSUM + DBLE(XSD)**2
        IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'PEAT')THEN
          WRITE(ICOUT,1131)ISET1,NTEMP,XSD
 1131     FORMAT('***** GROUP ',I8,': N, SD = ',I8,2X,G15.7)
          CALL DPWRST('XXX','BUG ')
        ENDIF
 1110 CONTINUE
C
      XREP=REAL(DSQRT(DSUM/DBLE(NUMSET)))
C
C               *******************************
C               **  STEP 3--                 **
C               **  WRITE OUT A LINE         **
C               **  OF SUMMARY INFORMATION.  **
C               *******************************
C
      IF(IFEEDB.EQ.'ON' .AND. IWRITE.EQ.'ON')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,811)XREP
  811   FORMAT('THE REPEATABILITY STANDARD DEVIATION = ',E15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'PEAT')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END       OF REPEAT--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9012)IBUGA3,ISUBRO,IERROR
 9012   FORMAT('IBUGA3,ISUBRO,IERROR = ',A4,2X,A4,2X,A4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9013)N,NUMSET
 9013   FORMAT('N,NUMSET = ',I8,1X,I8)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9015)XREP
 9015   FORMAT('XREP = ',E15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      RETURN
      END
      SUBROUTINE REPLAC(X,Z,NX,VAL,NVAL,IWRITE,Y,ICASE,
     1                  ISUBRO,IBUGA3,IERROR)
C
C     PURPOSE--THIS COMMAND IS A VARIANT OF THE MATCH COMMAND.
C              THE SYNTAX
C                  LET Y2 = REPLACE GROUPID GROUP2 Y1
C              DOES THE FOLLOWING:
C              1) IT MATCHES THE VALUES IN GROUP2 AGAINST
C                 GROUPID AND RETURNS THE INDICES OF THE
C                 MATCHING ROWS FOR THE GROUPID ARRAY.
C              2) THE INDEX IS USED TO ACCESS THE CORRESPONDING
C                 VALUE IN THE Y1 ARRAY.
C              3) THE CORRESPONDING ROW OF Y2 IS REPLACED WITH
C                 THE Y1 VALUE.
C              NOTE THAT Y2, GROUPID, AND Y1 SHOULD HAVE THE
C              SAME LENGTH.  ALSO, IT IS ASSUMED THAT Y1
C              ALREADY EXISTS.  THIS SHOULD BE CHECKED FOR BEFORE
C              CALLING THIS ROUTINE.
C
C              THE SHORTHAND SYNTAX
C                  LET Y2 = REPLACE GROUPID GROUP
C              SIMPLY ASSIGNS A VALUE OF 1 IN THE CORRESPONDING
C              ROW OF Y2 (THIS IS A CONVENIENT SYNTAX FOR
C              CREATING A TAG VARIABLE).  THIS CASE IS IDENTIFIED
C              WITH THE "ICASE=INDE" OPTION.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2006/2
C     ORIGINAL VERSION--FEBRUARY  2006.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES----------------
C
      CHARACTER*4 ICASE
      CHARACTER*4 IWRITE
      CHARACTER*4 ISUBRO
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C
C------------------------------------------------------------------
C
      DIMENSION X(*)
      DIMENSION Y(*)
      DIMENSION Z(*)
      DIMENSION VAL(*)
C
C-----COMMOMN---------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT--------------------------------------------------
C
      ISUBN1='MATC'
      ISUBN2='H   '
      IERROR='NO'
C
      IF(ISUBRO.EQ.'PLAC' .OR. IBUGA3.EQ.'ON')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,51)
   51   FORMAT('***** AT THE BEGINNING OF REPLAC--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,52)IBUGA3,IWRITE,NX,NVAL
   52   FORMAT('IBUGA3,IWRITE,NX,NVAL = ',2(A4,2X),2I8)
        CALL DPWRST('XXX','BUG ')
        DO55I=1,NX
          WRITE(ICOUT,56)I,X(I),Z(I),Y(I)
   56     FORMAT('I,X(I),Z(I),Y(I) = ',I8,3G15.7)
          CALL DPWRST('XXX','BUG ')
   55   CONTINUE
        DO65I=1,NVAL
          WRITE(ICOUT,66)I,VAL(I)
   66     FORMAT('I,VAL(I) = ',I8,G15.7)
          CALL DPWRST('XXX','BUG ')
   65   CONTINUE
      ENDIF
C
C               ****************************************
C               **  COMPUTE INDICES OF MATCHING VALUES *
C               ****************************************
C
      DO100I=1,NVAL
        VALTMP=VAL(I)
        INDTMP=1
        YDIFF=CPUMAX
        DO200J=1,NX
          APROD=X(J)*VALTMP
          TERM1=MAX(X(J),VALTMP)
          TERM2=MIN(X(J),VALTMP)
          IF(APROD.GT.0.0)THEN
            ADIFF=ABS(ABS(TERM1) - ABS(TERM2))
          ELSEIF(APROD.LT.0.0)THEN
            ADIFF=TERM1+ABS(TERM2)
          ELSE
            ADIFF=ABS(TERM1-TERM2)
          ENDIF
          IF(ADIFF.LT.YDIFF)THEN
            INDTMP=J
            YDIFF=ADIFF
          ENDIF
  200   CONTINUE
        IF(ICASE.EQ.'INDE')THEN
          Y(INDTMP)=1.0
        ELSE
          Y(INDTMP)=Z(INDTMP)
        ENDIF
  100 CONTINUE
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
      IF(ISUBRO.EQ.'PLAC' .OR. IBUGA3.EQ.'ON')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END       OF REPLAC--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9012)IBUGA3,IERROR,NX
 9012   FORMAT('IBUGA3,IERROR,NX = ',2(A4,2X),I8)
        CALL DPWRST('XXX','BUG ')
        DO9015I=1,NX
          WRITE(ICOUT,9016)I,X(I),Z(I),Y(I)
 9016     FORMAT('I,X(I),Z(I),Y(I) = ',I8,3G15.7)
          CALL DPWRST('XXX','BUG ')
 9015   CONTINUE
      ENDIF
C
      RETURN
      END
      SUBROUTINE REPROD(Y,X,XIDTEM,TEMP,TEMP2,N,IWRITE,XREP,
     1ISUBRO,IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE SAMPLE REPRODUCABILITY
C              STANDARD DEVIATION OF THE DATA IN THE INPUT VECTOR Y
C              WITH LAB ID VECTOR X.  THE REPRODUCABILITY STANDARD
C              DEVIATION IS DEFINED AS:
C
C                 SR = MAX(SR*,Sr)
C
C              WITH
C
C                 SR* = SQRT(s(x)**2 + (Sr**2*(n-1)/n)
C
C                 s(xbar)    = STANDARD DEVIATION OF THE CELL
C                              AVERAGES
C                 n          = CELL SAMPLE SIZE (CURRENTLY, EQUAL
C                              CELL SIZES EXPECTED)
C
C              AND Sr DENOTING THE REPEATABILITY STANDARD DEVIATION
C
C                 Sr = SQRT(SUM[i=1 to p][s(i)**2/p]
C
C              WITH
C                 p      = NUMBER OF LABS
C                 s(i)   = STANDARD DEVIATION OF GROUP i.
C
C     INPUT  ARGUMENTS--Y      = THE SINGLE PRECISION VECTOR OF
C                                (UNSORTED OR SORTED) OBSERVATIONS.
C                     --X      = THE SINGLE PRECISION VECTOR OF
C                                GROUP ID's.
C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR Y.
C     OUTPUT ARGUMENTS--XREP   = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED SAMPLE REPRODUCABILITY SD.
C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
C             SAMPLE REPRODUCABILITY SD.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--SORT, DISTIN, SD.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--SQRT.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--"Standard Practice for Conducting an
C                 Interlaboratory Study to Determine the Precision
C                 of a Test Method", ASTM International,
C                 100 Barr Harbor Drive, PO BOX C700,
C                 West Conshohoceken, PA 19428-2959, USA.
C                 This document is in support of
C                 ASTM Standard E 691 - 99.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2005.2
C     ORIGINAL VERSION--FEBRUARY  2005.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGA3
      CHARACTER*4 ISUBRO
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DSUM
      DOUBLE PRECISION DXREP
      DOUBLE PRECISION XREPRD
C
      DIMENSION Y(*)
      DIMENSION X(*)
      DIMENSION XIDTEM(*)
      DIMENSION TEMP(*)
      DIMENSION TEMP2(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='REPE'
      ISUBN2='AT  '
      IERROR='NO'
C
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'PROD')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,51)
   51   FORMAT('***** AT THE BEGINNING OF REPROD--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,52)IBUGA3,ISUBRO,N
   52   FORMAT('IBUGA3,ISUBRO,N = ',A4,1X,A4,1X,I8)
        CALL DPWRST('XXX','BUG ')
        DO55I=1,N
          WRITE(ICOUT,56)I,Y(I),X(I)
   56     FORMAT('I,Y(I),X(I) = ',I8,2E15.7)
          CALL DPWRST('XXX','BUG ')
   55   CONTINUE
      ENDIF
C
C               **********************
C               **  COMPUTE REPROD  **
C               **********************
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      AN=N
C
      IF(N.LE.1)THEN
        IERROR='YES'
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,111)
  111   FORMAT('***** ERROR IN COMPUTING REPRODUCABILITY SD--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,112)
  112   FORMAT('      THE INPUT NUMBER OF OBSERVATIONS IN THE')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,114)
  114   FORMAT('      VARIABLES FOR WHICH THE REPRODUCABILITY SD IS ')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,115)
  115   FORMAT('      TO BE COMPUTED MUST BE 2 OR LARGER.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,116)
  116   FORMAT('      SUCH WAS NOT THE CASE HERE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,117)N
  117   FORMAT('      THE INPUT NUMBER OF OBSERVATIONS = ',I8,'.')
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        GOTO9000
      ENDIF
C
C               ****************************************************
C               **  STEP 2--                                      **
C               **  COMPUTE THE REPRODABILTY STANDARD DEVIATION.  **
C               ****************************************************
C
      IWRITE='OFF'
      CALL DISTIN(X,N,IWRITE,XIDTEM,NUMSET,IBUGA3,IERROR)
      CALL SORT(XIDTEM,NUMSET,XIDTEM)
C
      IF(NUMSET.LT.1)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,111)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,192)
  192   FORMAT('      NUMBER OF LABS    NUMSET < 1')
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        GOTO9000
      ENDIF
C
      AN=N
      ANUMSE=NUMSET
C
      DSUM=0.0D0
      J=0
      DO1110ISET1=1,NUMSET
        K=0
        DO1130I=1,N
          IF(XIDTEM(ISET1).EQ.X(I))THEN
            K=K+1
            TEMP(K)=Y(I)
          ENDIF
 1130   CONTINUE
        NTEMP=K
C
        IF(ISET1.EQ.1)THEN
          NHOLD=NTEMP
        ELSE
          IF(NTEMP.NE.NHOLD)THEN
            WRITE(ICOUT,999)
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,111)
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,1131)ISET1,NHOLD,NTEMP
 1131       FORMAT('      FOR GROUP ',I8,', ',I8,
     1             'ELEMENTS EXPECTED BUT ',I8,' ELEMENTS FOUND.')
            CALL DPWRST('XXX','BUG ')
            IERROR='YES'
            GOTO9000
          ENDIF
        ENDIF
C
        CALL MEAN(TEMP,NTEMP,IWRITE,XMEAN,IBUGA3,IERROR)
        CALL SD(TEMP,NTEMP,IWRITE,XSD,IBUGA3,IERROR)
        DSUM=DSUM + DBLE(XSD)**2
        TEMP2(ISET1)=XMEAN
        IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'PROD')THEN
          WRITE(ICOUT,1151)NUMSET,XSD
 1151     FORMAT('***** GROUP ',I8,': MEAN, SD = ',2G15.7)
          CALL DPWRST('XXX','BUG ')
        ENDIF
 1110 CONTINUE
C
      DXREP=DSUM/DBLE(NUMSET)
      CALL SD(TEMP2,NUMSET,IWRITE,SXBAR,IBUGA3,IERROR)
      XREPRD=DSQRT(DBLE(SXBAR**2) + DXREP*DBLE(NHOLD-1)/DBLE(NHOLD))
      XREP=REAL(MAX(DSQRT(DXREP),XREPRD))
C
C               *******************************
C               **  STEP 3--                 **
C               **  WRITE OUT A LINE         **
C               **  OF SUMMARY INFORMATION.  **
C               *******************************
C
      IF(IFEEDB.EQ.'ON' .AND. IWRITE.EQ.'ON')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,811)XREP
  811   FORMAT('THE REPRODUCABILITY STANDARD DEVIATION = ',E15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'PROD')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END       OF REPROD--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9012)IBUGA3,ISUBRO,IERROR
 9012   FORMAT('IBUGA3,ISUBRO,IERROR = ',A4,2X,A4,2X,A4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9013)N,NUMSET
 9013   FORMAT('N,NUMSET = ',I8,1X,I8)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9015)XREP,DXREP,XREPRD
 9015   FORMAT('XREP,DXREP,XREPRD = ',3G15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      RETURN
      END
      SUBROUTINE RESULT(NR,N,X,F,G,A,P,ITNCNT,IFLG)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C PURPOSE
C -------
C PRINT INFORMATION  (FOR OPTIMIZE COMMAND)
C
C PARAMETERS
C ----------
C NR           --> ROW DIMENSION OF MATRIX
C N            --> DIMENSION OF PROBLEM
C X(N)         --> ITERATE X[K]
C F            --> FUNCTION VALUE AT X[K]
C G(N)         --> GRADIENT AT X[K]
C A(N,N)       --> HESSIAN AT X[K]
C P(N)         --> STEP TAKEN
C ITNCNT       --> ITERATION NUMBER K
C IFLG         --> FLAG CONTROLLING INFO TO PRINT
C IPR          --> DEVICE TO WHICH TO SEND OUTPUT
C
      DIMENSION X(N),G(N),P(N),A(NR,1)
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C PRINT ITERATION NUMBER
      WRITE(ICOUT,903) ITNCNT
      CALL DPWRST('XXX','BUG ')
      IF(IFLG.EQ.0) GO TO 120
C
C PRINT STEP
      WRITE(ICOUT,907)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,905) (P(I),I=1,MIN(5,N))
      CALL DPWRST('XXX','BUG ')
C
C PRINT CURRENT ITERATE
  120 CONTINUE
      WRITE(ICOUT,904)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,905) (X(I),I=1,MIN(5,N))
      CALL DPWRST('XXX','BUG ')
C
C PRINT FUNCTION VALUE
      WRITE(ICOUT,906)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,905) F
      CALL DPWRST('XXX','BUG ')
C
C PRINT GRADIENT
      WRITE(ICOUT,908)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,905) (G(I),I=1,MIN(5,N))
      CALL DPWRST('XXX','BUG ')
C
C PRINT HESSIAN FROM ITERATION K
      IF(IFLG.EQ.0) GO TO 140
      WRITE(ICOUT,901)
      CALL DPWRST('XXX','BUG ')
      DO 130 I=1,N
        WRITE(ICOUT,900) I
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,902) (A(I,J),J=1,I)
        CALL DPWRST('XXX','BUG ')
  130 CONTINUE
        WRITE(ICOUT,902) (A(I,J),J=1,I)
        CALL DPWRST('XXX','BUG ')
C
  900 FORMAT('****** FROM RESULT     ROW',I5)
  901 FORMAT('****** FROM RESULT       HESSIAN AT X(K)')
  902 FORMAT('****** FROM RESULT       ',5(2X,E20.13))
  903 FORMAT('****** FROM RESULT    ITERATE K=',I5)
  904 FORMAT('****** FROM RESULT       X(K)')
  905 FORMAT('****** FROM RESULT       ',5(2X,E20.13))
  906 FORMAT('****** FROM RESULT       FUNCTION AT X(K)')
  907 FORMAT('****** FROM RESULT       STEP')
  908 FORMAT('****** FROM RESULT       GRADIENT AT X(K)')
  140 RETURN
      END
      SUBROUTINE REVERS(X,NX,IWRITE,Y,YTEMP,IBUGA3,IERROR)
C
C     PURPOSE--REVERSE THE ORDER OF AN ARRAY.  THAT IS,
C              Y(1)=X(N), ..., Y(N)=X(1).
C     NOTE--IT IS PERMISSIBLE TO HAVE THE OUTPUT VECTOR Y(.)
C           BEING IDENTICAL TO THE INPUT VECTOR X(.).
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--98/5
C     ORIGINAL VERSION--MAY       1998.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
      DIMENSION Y(*)
      DIMENSION YTEMP(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='REVE'
      ISUBN2='RS  '
      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 REVERS--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,52)IBUGA3,IWRITE,NX
   52   FORMAT('IBUGA3,IWRITE,NX = ',2(A4,2X),I8)
        CALL DPWRST('XXX','BUG ')
        DO55I=1,NX
          WRITE(ICOUT,56)I,X(I)
   56     FORMAT('I,X(I) = ',I8,G15.7)
          CALL DPWRST('XXX','BUG ')
   55   CONTINUE
      ENDIF
C
C               **************************************
C               **  FLIP ORDER OF ARRAY             **
C               **************************************
C
      DO100I=1,NX
        IREV=NX-I+1
        YTEMP(I)=X(IREV)
  100 CONTINUE
      DO200I=1,NX
        Y(I)=YTEMP(I)
  200 CONTINUE
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
      IF(IBUGA3.EQ.'ON')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END       OF REVERS--')
        CALL DPWRST('XXX','BUG ')
        DO9015I=1,NX
          WRITE(ICOUT,9016)I,X(I),Y(I)
 9016     FORMAT('I,X(I),Y(I) = ',I8,2G15.7)
          CALL DPWRST('XXX','BUG ')
 9015   CONTINUE
      ENDIF
C
      RETURN
      END
      SUBROUTINE REVRT(X, M)
C
C     ALGORITHM AS 97.1  APPL. STATIST. (1976) VOL.25, NO. 2
C
C     Inverse discrete Fourier transform in one dimension of real
C     data using complex transform subroutine FASTG.
C
C     X = array of Fourier components as output from subroutine FORRT,
C         type real, dimension M.
C     M = length of the inverse transform, must be a power of 2.
C     The minimum length is 8, maximum 2**21.
C
C     Auxiliary routines required: SCRAG & FASTG from AS 83, but
C     with SCRAG modified as described on page 168 of the paper for
C     this algorithm.
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      DOUBLE PRECISION X(M)
      DATA ZERO/0.0D0/, HALF/0.5D0/, ONE/1.0D0/, ONE5/1.5D0/,
     *      TWO/2.0D0/, FOUR/4.0D0/
C
C     Check for valid transform size.
C
      II = 8
      DO 2 K = 3, 21
      IPOW = K
      IF (II .EQ. M) GO TO 3
      II = II * 2
    2 CONTINUE
C
C     If this point is reached, an illegal size was specified.
C
      RETURN
    3 PIE = FOUR * ATAN(ONE)
      N = M / 2
      NN = N / 2
C
C     Undo the spectrum into that of two interleaved series.
C     First, the special cases.
C
      Z = X(1) + X(N+1)
      X(N+1) = X(1) - X(N+1)
      X(1) = Z
      NN1 = NN + 1
      NN2 = NN1 + N
      X(NN1) = TWO * X(NN1)
      X(NN2) = -TWO * X(NN2)
      Z = PIE / N
      BCOS = -TWO * (SIN(Z / TWO) **2)
      BSIN = SIN(Z)
      UN = ONE
      VN = ZERO
      DO 4 K = 2, NN
      Z = UN * BCOS + VN * BSIN + UN
      VN = VN * BCOS - UN * BSIN + VN
      SAVE1 = ONE5 - HALF * (Z * Z + VN * VN)
      UN = Z * SAVE1
      VN = VN * SAVE1
      KI = N + K
      L = N + 2 - K
      LI = N + L
      AN = X(K) + X(L)
      BN = X(KI) - X(LI)
      PN = X(K) - X(L)
      QN = X(KI) + X(LI)
      CN = UN * PN + VN * QN
      DN = UN * QN - VN * PN
      X(K) = AN - DN
      X(KI) = BN + CN
      X(L) = AN + DN
      X(LI) = CN - BN
    4 CONTINUE
C
C     Now do the inverse transform
C
      CALL FASTG(X, X(N+1), N, -1)
C
C     Now undo the order - the half arrays are already bit reversed;
C     bit reverse the whole array.
C
      CALL SCRAG(X, M, IPOW)
      RETURN
      END
      SUBROUTINE RIGCDF(DX,DGAMMA,DMU,DCDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE RECIPROCAL INVERSE GAUSSIAN
C              DISTRIBUTION WITH SHAPE PARAMETERS GAMMA AND MU.
C              THE RECIPROCAL INVERSE GAUSSIAN DISTRIBUTION IS
C              THE DISTRIBUTION OF Y = 1/X WHEN X HAS AN INVERSE
C              GAUSSIAN DISTRIBUTION.
C              THE FORMULA FOR THE CDF OF THE RECIROCAL INVERSE
C              GAUSIAN DISTRIBUTION IS:
C              F(X,GAMMA,MU) = NORCDF{-[1/(MU*X) - 1]*SQRT(GAMMA*X)} -
C              EXP[2*GAMMA/MU]*NORCDF{-[1/(MU*X) - 1]*SQRT(GAMMA*X)} -
C              X, GAMMA, MU > 0
C     NOTE--THE RECIPROCAL INVERSE GAUSSIA DISTRIBUTION CAN BE
C           COMPUTED IN TERMS OF THE INVERSE GAUSSIAN CDF:
C              RIGCDF(X,GAMMA,MU) = 1 - IGCDF(1/X,GAMMA,MU)
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE POSITIVE.
C                     --GAMMA  = THE SHAPE PARAMETER
C                                GAMMA SHOULD BE POSITIVE.
C                     --AMU    = THE SHAPE PARAMETER
C                                MU SHOULD BE POSITIVE.
C     OUTPUT ARGUMENTS--CDF    = THE SINGLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE CDF FOR THE RECIPROCAL INVERSE
C             GAUSSIAN DISTRIBUTION
C             WITH SHAPE PARAMETERS GAMMA AND MU
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE POSITIVE.
C                 --GAMMA SHOULD BE POSITIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--IGCDF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--SAM SAUNDERS TALK, MAY 1990
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1970, PAGES
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--90.6
C     ORIGINAL VERSION--MAY       1990.
C     UPDATED         --DECEMBER  2003. SUPPORT FOR GENERAL MU
C     UPDATED         --APRIL     2014. CONVERT TO DOUBLE PRECISION
C     UPDATED         --APRIL     2014. SUPPORT FOR CHAN PARAMETERIZATION
C                                       (THIS ACTUALLY DONE IN IGCDF)
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DGAMMA
      DOUBLE PRECISION DMU
      DOUBLE PRECISION DCDF
      DOUBLE PRECISION DX2
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      DCDF=0.0D0
      IF(DGAMMA.LE.0.0D0)THEN
         WRITE(ICOUT,51)
   51    FORMAT('***** ERROR--THE FIRST SHAPE PARAMETER TO RIGCDF ',
     1          'IS NON-POSITIVE.')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,52)DGAMMA
   52    FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
         CALL DPWRST('XXX','BUG ')
         GOTO9000
      ELSEIF(DMU.LE.0.0D0)THEN
         WRITE(ICOUT,71)
   71    FORMAT('***** ERROR--THE SECOND SHAPE PARAMETER TO RIGCDF ',
     1          'IS NON-POSITIVE.')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,52)DMU
         CALL DPWRST('XXX','BUG ')
         GOTO9000
      ENDIF
C
      IF(DX.LE.0.0D0)GOTO9000
C
      DX2=1.0D0/DX
      CALL IGCDF(DX2,DGAMMA,DMU,DCDF)
      DCDF=1.0D0 - DCDF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE RIGCHA(DX,DGAMMA,DMU,DHAZ)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE HAZARD
C              FUNCTION VALUE FOR THE RECIPROCAL INVERSE GAUSSIAN
C              DISTRIBUTION WITH SHAPE PARAMETERS GAMMA AND MU.
C              THE RECIPROCAL INVERSE GAUSSIAN DISTRIBUTION IS
C              THE DISTRIBUTION OF Y = 1/X WHEN X HAS AN INVERSE
C              GAUSSIAN DISTRIBUTION.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE POSITIVE.
C                     --GAMMA  = THE SHAPE PARAMETER
C                                GAMMA SHOULD BE POSITIVE.
C                     --AMU    = THE SHAPE PARAMETER
C                                MU SHOULD BE POSITIVE.
C     OUTPUT ARGUMENTS--HAZ    = THE SINGLE PRECISION CUMULATIVE HAZARD
C                                FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION CUMULATIVE HAZARD
C             FUNCTION VALUE PDF FOR THE RECIPROCAL INVERSE GAUSSIAN
C             DISTRIBUTION WITH SHAPE PARAMETERS GAMMA AND MU
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE POSITIVE.
C                 --GAMMA AND MU SHOULD BE POSITIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--RIGDF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--SAM SAUNDERS TALK, MAY 1990
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1970, PAGES
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--98.6
C     ORIGINAL VERSION--APRIL     1998.
C     UPDATED         --DECEMBER  2003. SUPPORT FOR GENERAL MU
C     UPDATED         --APRIL     2014. CONVERT TO DOUBLE PRECISION
C     UPDATED         --APRIL     2014. SUPPORT FOR CHAN PARAMETERIZATION
C                                       (ACTUALLY DONE IN IGCDF ROUTINE)
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DGAMMA
      DOUBLE PRECISION DMU
      DOUBLE PRECISION DHAZ
      DOUBLE PRECISION DCDF
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      DHAZ=0.0D0
      IF(DGAMMA.LE.0.0D0)THEN
         WRITE(ICOUT,51)
   51    FORMAT('***** ERROR--THE FIRST SHAPE PARAMETER TO RIGCHA ',
     1          'IS NON-POSITIVE.')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,52)DGAMMA
   52    FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
         CALL DPWRST('XXX','BUG ')
         GOTO9000
      ELSEIF(DMU.LE.0.0D0)THEN
         WRITE(ICOUT,71)
   71    FORMAT('***** ERROR--THE SECOND SHAPE PARAMETER TO RIGCHA ',
     1          'IS NON-POSITIVE.')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,52)DMU
         CALL DPWRST('XXX','BUG ')
         GOTO9000
      ELSEIF(DX.LT.0.0D0)THEN
         WRITE(ICOUT,61)
   61    FORMAT('***** ERROR--THE FIRST  INPUT ARGUMENT TO RIGCHA ',
     1          'IS NON-POSITIVE.')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,52)X
         CALL DPWRST('XXX','BUG ')
         GOTO9000
      ENDIF
C
      IF(DX.EQ.0.0D0)GOTO9000
      CALL RIGCDF(DX,DGAMMA,DMU,DCDF)
      DCDF=1.0D0-DCDF
      IF(DCDF.GT.0.0D0)THEN
        DHAZ=-DLOG(DCDF)
      ELSE
        WRITE(ICOUT,162)X
  162   FORMAT('***** FOR THE VALUE OF THE ARGUMENT ',G15.7,
     1     ' THE CDF IS ESSENTIALLY 1, CUMULATIVE HAZARD SET TO 0.')
        CALL DPWRST('XXX','BUG ')
        DHAZ=0.0D0
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE RIGHAZ(DX,DGAMMA,DMU,DHAZ)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE HAZARD
C              FUNCTION VALUE FOR THE RECIPROCAL INVERSE GAUSSIAN
C              DISTRIBUTION WITH SHAPE PARAMETERS GAMMA AND MU.
C              THE RECIPROCAL INVERSE GAUSSIAN DISTRIBUTION IS
C              THE DISTRIBUTION OF Y = 1/X WHEN X HAS AN INVERSE
C              GAUSSIAN DISTRIBUTION.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE POSITIVE.
C                     --GAMMA  = THE SHAPE PARAMETER
C                                GAMMA SHOULD BE POSITIVE.
C                     --AMU    = THE SHAPE PARAMETER
C                                MU SHOULD BE POSITIVE.
C     OUTPUT ARGUMENTS--HAZ    = THE SINGLE PRECISION HAZARD
C                                FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION HAZARD
C             FUNCTION VALUE HAZARD FOR THE RECIPROCAL INVERSE
C             GAUSSIAN DISTRIBUTION
C             WITH SHAPE PARAMETERS GAMMA AND MU
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE POSITIVE.
C                 --GAMMA AND MU SHOULD BE POSITIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--RIGCDF, RIGPDF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--SAM SAUNDERS TALK, MAY 1990
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1970, PAGES
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--98.6
C     ORIGINAL VERSION--APRIL     1998.
C     UPDATED         --DECEMBER  2003. USE GENERAL VALUE OF MU
C                                       INSTEAD OF ASSUMING MU=1
C     UPDATED         --APRIL     2014. CONVERT TO DOUBLE PRECISION
C     UPDATED         --APRIL     2014. SUPPORT FOR CHAN PARAMETERIZATION
C                                       (ACTUALLY DONE IN IGCDF AND
C                                       IGPDF ROUTINES)
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DGAMMA
      DOUBLE PRECISION DMU
      DOUBLE PRECISION DHAZ
      DOUBLE PRECISION DCDF
      DOUBLE PRECISION DPDF
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(DGAMMA.LE.0.0D0)THEN
         WRITE(ICOUT,51)
   51    FORMAT('***** ERROR--THE FIRST SHAPE PARAMETER TO RIGHAZ ',
     1          'IS NON-POSITIVE.')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,52)DGAMMA
   52    FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
         CALL DPWRST('XXX','BUG ')
         GOTO9000
      ELSEIF(DMU.LE.0.0D0)THEN
         WRITE(ICOUT,71)
   71    FORMAT('***** ERROR--THE SECOND SHAPE PARAMETER TO RIGHAZ ',
     1          'IS NON-POSITIVE.')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,52)DMU
         CALL DPWRST('XXX','BUG ')
         GOTO9000
      ELSEIF(DX.LT.0.0D0)THEN
         WRITE(ICOUT,61)
   61    FORMAT('***** ERROR--THE FIRST ARGUMENT TO RIGHAZ ',
     1          'IS NON-POSITIVE.')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,52)DX
         CALL DPWRST('XXX','BUG ')
         GOTO9000
      ENDIF
C
      IF(DX.EQ.0.0D0)GOTO9000
C
      CALL RIGCDF(DX,DGAMMA,DMU,DCDF)
      DCDF=1.0D0 - DCDF
      IF(DCDF.GT.0.0D0)THEN
        CALL RIGPDF(DX,DGAMMA,DMU,DPDF)
        DHAZ=DPDF/DCDF
      ELSE
        WRITE(ICOUT,162)DX
  162   FORMAT('***** FOR THE VALUE OF THE ARGUMENT ',
     1            E15.8,' THE CDF IS ESSENTIALLY 1, HAZARD SET TO 0.')
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE RIGPDF(DX,DGAMMA,DMU,DPDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE RECIPROCAL INVERSE GAUSSIAN
C              DISTRIBUTION WITH SHAPE PARAMETERS GAMMA AND MU.
C              THE RECIPROCAL INVERSE GAUSSIAN DISTRIBUTION IS
C              THE DISTRIBUTION OF Y = 1/X WHEN X HAS AN INVERSE
C              GAUSSIAN DISTRIBUTION.
C              THE FORMULA FOR THE RECIPROCAL INVERSE GAUSSIAN
C              PROBABILITY DENSITY FUNCTION IS:
C              f(X,GAMMA,MU)=SQRT(GAMMA/(2*PI*X)]*
C                            EXP[-GAMMA*(1-MU*X)**2/(2*MU**2*X)]
C                            X, GAMMA, MU > 0
C     NOTE--THE RECIPROCAL INVERSE GAUSSIA DISTRIBUTION CAN BE
C           COMPUTED IN TERMS OF THE INVERSE GAUSSIAN PDF:
C           RIGPDF(X,GAMMA,MU)=IGPDF(1/X,GAMMA,MU)/(X**2)
C     NOTE--THE RECIPROCAL INVERSE GAUSSIAN DISTRIBUTION--
C              GOES FROM 0 TO INFINITY
C              HAS MEAN = (GAMMA + MU)/(GAMMA*MU)
C              HAS STANDARD DEVIATION=SQRT((GAMMA+2*MU)/(GAMMA**2*MU))
C              IS NEAR-SYMMETRIC AND MODERATE-TAILED FOR SMALL GAMMA
C              IS HIGHLY-SKEWED AND LONG-TAILED FOR LARGE GAMMA
C              APPROACHES NORMALITY AS GAMMA APPROACHES 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 POSITIVE.
C                     --GAMMA  = THE SHAPE PARAMETER
C                                GAMMA SHOULD BE POSITIVE.
C                     --AMU    = THE SHAPE PARAMETER
C                                MU SHOULD BE POSITIVE.
C     OUTPUT ARGUMENTS--PDF    = THE SINGLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE PDF FOR THE RECIPROCAL INVERSE GAUSSIAN
C             DISTRIBUTION WITH SHAPE PARAMETERS GAMMA AND MU
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE POSITIVE.
C                 --GAMMA AND MU SHOULD BE POSITIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--IGPDF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--SAM SAUNDERS TALK, MAY 1990
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1970, PAGES
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--90.6
C     ORIGINAL VERSION--MAY       1990.
C     UPDATED         --DECEMBER  2003. USE GENERAL VALUE OF MU
C                                       INSTEAD OF ASSUMING MU=1
C     UPDATED         --APRIL     2014. CONVERT TO DOUBLE PRECISION
C     UPDATED         --APRIL     2014. SUPPORT FOR CHAN PARAMETERIZATION
C                                       (THIS ACTUALLY DONE IN IGCDF)
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DGAMMA
      DOUBLE PRECISION DMU
      DOUBLE PRECISION DPDF
      DOUBLE PRECISION DX2
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      DPDF=0.0D0
      IF(DGAMMA.LE.0.0D0)THEN
         WRITE(ICOUT,51)
   51    FORMAT('***** ERROR--THE FIRST SHAPE PARAMETER TO RIGPDF ',
     1          'IS NON-POSITIVE.')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,52)DGAMMA
   52    FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
         CALL DPWRST('XXX','BUG ')
         GOTO9000
      ELSEIF(DMU.LE.0.0D0)THEN
         WRITE(ICOUT,71)
   71    FORMAT('***** ERROR--THE SECOND SHAPE PARAMETER TO RIGPDF ',
     1          'IS NON-POSITIVE.')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,52)DMU
         CALL DPWRST('XXX','BUG ')
         GOTO9000
      ELSEIF(DX.LT.0.0D0)THEN
         WRITE(ICOUT,61)
   61    FORMAT('***** ERROR--THE FIRST ARGUMENT TO RIGPDF ',
     1          'IS NON-POSITIVE.')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,52)DX
         CALL DPWRST('XXX','BUG ')
         GOTO9000
      ENDIF
C
      IF(DX.EQ.0.0D0)GOTO9000
C
      DX2=1.0D0/DX
      CALL IGPDF(DX2,DGAMMA,DMU,DPDF)
      DPDF=DPDF/(DX**2)
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE RIGPPF(DP,DGAMMA,DMU,DPPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE RECIPROCAL INVERSE GAUSSIAN
C              DISTRIBUTION WITH SHAPE PARAMETERS GAMMA AND MU.
C              THE RECIPROCAL INVERSE GAUSSIAN DISTRIBUTION IS
C              THE DISTRIBUTION OF Y = 1/X WHEN X HAS AN INVERSE
C              GAUSSIAN DISTRIBUTION.
C     NOTE--THE RECIPROCAL INVERSE GAUSSIAN PPF CAN BE
C           COMPUTED IN TERMS OF THE INVERSE GAUSSIAN PPF:
C              RIGPPF(P,GAMMA,MU) = 1/IGPPF(1-P,GAMMA,MU)
C     INPUT  ARGUMENTS--P      = THE SINGLE PRECISION VALUE
C                                (BETWEEN 0.0 AND 1.0)
C                                AT WHICH THE PERCENT POINT
C                                FUNCTION IS TO BE EVALUATED.
C                     --GAMMA  = THE SHAPE PARAMETER
C                                GAMMA SHOULD BE POSITIVE.
C                     --AMU    = THE SHAPE PARAMETER
C                                MU SHOULD BE POSITIVE.
C     OUTPUT ARGUMENTS--PPF    = THE SINGLE PRECISION PERCENT POINT
C                                FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PERCENT POINT
C             FUNCTION VALUE PPF FOR THE INVERSE GAUSSIAN DISRIBUTION
C             WITH SHAPE PARAMETERS GAMMA AND MU
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--P SHOULD BE BETWEEN
C                   0.0 (INCLUSIVELY) AND 1.0 (EXCLUSIVELY).
C                 --GAMMA AND MU SHOULD BE POSITIVE
C     OTHER DATAPAC   SUBROUTINES NEEDED--IGPPF
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--SAM SAUNDERS TALK, MAY 1990
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1970, PAGES
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--90.6
C     ORIGINAL VERSION--MAY       1990.
C     UPDATED         --DECEMBER  2003. USE GENERAL VALUE OF MU
C                                       INSTEAD OF ASSUMING MU=1
C     UPDATED         --APRIL     2014. CONVERT TO DOUBLE PRECISION
C     UPDATED         --APRIL     2014. SUPPORT FOR CHAN PARAMETERIZATION
C                                       (THIS ACTUALLY DONE IN IGCDF)
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DP
      DOUBLE PRECISION DP2
      DOUBLE PRECISION DGAMMA
      DOUBLE PRECISION DMU
      DOUBLE PRECISION DPPF
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      DPPF=0.0D0
      IF(DGAMMA.LE.0.0D0)THEN
         WRITE(ICOUT,51)
   51    FORMAT('***** ERROR--THE FIRST SHAPE PARAMETER TO RIGPPF ',
     1          'IS NON-POSITIVE.')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,52)DGAMMA
   52    FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
         CALL DPWRST('XXX','BUG ')
         GOTO9000
      ELSEIF(DMU.LE.0.0D0)THEN
         WRITE(ICOUT,71)
   71    FORMAT('***** ERROR--THE SECOND SHAPE PARAMETER TO RIGPPF ',
     1          'IS NON-POSITIVE.')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,52)DMU
         CALL DPWRST('XXX','BUG ')
         GOTO9000
      ELSEIF(DP.LT.0.0D0 .OR. DP.GE.1.0D0)THEN
        WRITE(ICOUT,61)
   61   FORMAT('***** ERROR--THE FIRST ARGUMENT TO RIGPPF IS OUTSIDE ',
     1         'THE ALLOWABLE [0,1) INTERVAL.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,52)DP
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
      IF(DP.LE.0.0D0)GOTO9000
C
      DP2=1.0D0 - DP
      CALL IGPPF(DP2,DGAMMA,DMU,DPPF)
      DPPF=1.0D0/DPPF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE RIGRAN(N,GAMMA,AMU,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE RECIPROCAL INVERSE GAUSSIAN DISTRIBUTION
C              WITH SHAPE PARAMETERS GAMMA AND MU.
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                     --AMU    = THE SHAPE PARAMETER
C                                MU SHOULD BE POSITIVE.
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST N)
C                                INTO WHICH THE GENERATED
C                                RANDOM SAMPLE WILL BE PLACED.
C     OUTPUT--A RANDOM SAMPLE OF SIZE N
C             FROM THE RECIPROCAL INVERSE GAUSSIAN DISTRIBUTION
C             WITH TAIL LENGTH PARAMETERS GAMMA AND MU.
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 AND MU SHOULD BE POSITIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN, RIGPPF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON AND KOTZ
C               --SAM SAUNDERS
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--90.6
C     ORIGINAL VERSION--MAY       1990.
C     UPDATED         --DECEMBER  2003. USE GENERAL VALUE OF MU
C                                       INSTEAD OF ASSUMING MU=1
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
C
      DOUBLE PRECISION DPPF
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)THEN
         WRITE(ICOUT,51)
   51    FORMAT('***** ERROR--THE REQUESTED NUMBER OF ',
     1          'RECIPROCAL INVERSE GAUSSIAN RANDOM NUMBERS IS')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,52)N
   52    FORMAT('      NON-POSITIVE.  THE VALUE OF THE ARGUMENT IS ',
     1          I8,'.')
         CALL DPWRST('XXX','BUG ')
         GOTO9000
      ELSEIF(GAMMA.LE.0.0)THEN
         WRITE(ICOUT,61)
   61    FORMAT('***** ERROR--THE GAMMA SHAPE PARAMETER FOR THE',
     1          ' RECIPROCAL INVERSE GAUSSIAN')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,62)
   62    FORMAT('      RANDOM NUMBERS IS NON-POSITIVE.')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,63)GAMMA
   63    FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7,'.')
         CALL DPWRST('XXX','BUG ')
         GOTO9000
      ELSEIF(AMU.LE.0.0)THEN
         WRITE(ICOUT,71)
   71    FORMAT('***** ERROR--THE MU SHAPE PARAMETER FOR THE',
     1          ' RECIPROCAL INVERSE GAUSSIAN')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,72)
   72    FORMAT('      RANDOM NUMBERS IS NON-POSITIVE.')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,63)AMU
         CALL DPWRST('XXX','BUG ')
         GOTO9000
      ENDIF
C
C     GENERATE N UNIFORM (0,1) RANDOM NUMBERS;
C
      CALL UNIRAN(N,ISEED,X)
C
C     GENERATE N RECIP. INV. GAUS. DISTRIBUTION RANDOM NUMBERS
C     USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD.
C
      DO100I=1,N
        XTEMP=X(I)
        CALL RIGPPF(DBLE(XTEMP),DBLE(GAMMA),DBLE(AMU),DPPF)
        X(I)=REAL(DPPF)
  100 CONTINUE
C
 9000 CONTINUE
      RETURN
      END
      DOUBLE PRECISION FUNCTION rlog1(x)
C-----------------------------------------------------------------------
C             EVALUATION OF THE FUNCTION X - LN(1 + X)
C-----------------------------------------------------------------------
C     .. Scalar Arguments ..
      DOUBLE PRECISION x
C     ..
C     .. Local Scalars ..
      DOUBLE PRECISION a,b,h,p0,p1,p2,q1,q2,r,t,w,w1
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC dble,dlog
C     ..
C     .. Data statements ..
C------------------------
      DATA a/.566749439387324D-01/
      DATA b/.456512608815524D-01/
      DATA p0/.333333333333333D+00/,p1/-.224696413112536D+00/,
     +     p2/.620886815375787D-02/
      DATA q1/-.127408923933623D+01/,q2/.354508718369557D+00/
C     ..
C     .. Executable Statements ..
C------------------------
      IF (x.LT.-0.39D0 .OR. x.GT.0.57D0) GO TO 40
      IF (x.LT.-0.18D0) GO TO 10
      IF (x.GT.0.18D0) GO TO 20
C
C              ARGUMENT REDUCTION
C
      h = x
      w1 = 0.0D0
      GO TO 30
C
   10 h = dble(x) + 0.3D0
      h = h/0.7D0
      w1 = a - h*0.3D0
      GO TO 30
C
   20 h = 0.75D0*dble(x) - 0.25D0
      w1 = b + h/3.0D0
C
C               SERIES EXPANSION
C
   30 r = h/ (h+2.0D0)
      t = r*r
      w = ((p2*t+p1)*t+p0)/ ((q2*t+q1)*t+1.0D0)
      rlog1 = 2.0D0*t* (1.0D0/ (1.0D0-r)-r*w) + w1
      RETURN
C
C
   40 w = (x+0.5D0) + 0.5D0
      rlog1 = x - dlog(w)
      RETURN

      END
      SUBROUTINE RMS(X,N,IWRITE,XRMS,IBUGA3,ISUBRO,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE SAMPLE ROOT MEANS SQUARE
C              ERROR
C
C                  RMS = SQRT(SUM[i=1 to n][X(i)**2]/N)
C
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--XRMS    = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED SAMPLE ROOT MEAN SQUARE ERROR.
C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
C             SAMPLE ROOT MEAN SQUARE ERROR.
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--DSQRT.
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                 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2010.1
C     ORIGINAL VERSION--JANUARY   2010.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGA3
      CHARACTER*4 ISUBRO
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DSUM
      DOUBLE PRECISION DRMS
C
      DIMENSION X(*)
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='RMS '
      ISUBN2='    '
      IERROR='NO'
C
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'RMS ')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,51)
   51   FORMAT('***** AT THE BEGINNING OF RMS--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,52)IBUGA3,N
   52   FORMAT('IBUGA3,N = ',A4,2X,I8)
        CALL DPWRST('XXX','BUG ')
        DO55I=1,N
          WRITE(ICOUT,56)I,X(I)
   56     FORMAT('I,X(I) = ',I8,G15.7)
          CALL DPWRST('XXX','BUG ')
   55   CONTINUE
      ENDIF
C
C               **************************************
C               **  COMPUTE ROOT MEAN SQUARE ERROR  **
C               **************************************
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      IF(N.LT.1)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,111)
  111   FORMAT('***** ERROR IN ROOT MEAN SQUARE ERROR--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,112)
  112   FORMAT('      THE NUMBER OF OBSERVATIONS FOR THE RESPONSE ',
     1         'VARIABLE IS LESS THAN 1.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,117)N
  117   FORMAT('      THE INPUT NUMBER OF OBSERVATIONS = ',I8)
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        GOTO9000
      ENDIF
C
C               *******************************************
C               **  STEP 2--                             **
C               **  COMPUTE THE ROOT MEAN SQUARE ERROR.  **
C               *******************************************
C
      DSUM=0.0D0
      DO200I=1,N
        DX=X(I)
        DSUM=DSUM + DX*DX
  200 CONTINUE
      DRMS=DSQRT(DSUM/DBLE(N))
      XRMS=REAL(DRMS)
C
C               *******************************
C               **  STEP 3--                 **
C               **  WRITE OUT A LINE         **
C               **  OF SUMMARY INFORMATION.  **
C               *******************************
C
      IF(IFEEDB.EQ.'ON' .AND. IWRITE.EQ.'ON')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,811)N,XRMS
  811   FORMAT('THE ROOT MEAN SQUARE ERROR OF THE ',I8,
     1         ' OBSERVATIONS = ',G15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'RMS')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END       OF SD--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9012)IERROR
 9012   FORMAT('IERROR = ',A4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9013)N,DSUM,DRMS,XRMS
 9013   FORMAT('N,DSUM,DRMS,XRMS = ',I8,3G15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      RETURN
      END
      REAL FUNCTION RND(X,IDIGIT)
C
C     PURPOSE--ROUND A REAL VALUE TO THE SPECIFIED NUMBER OF DIGITS
C     WRITTEN BY--ALAN HECKERT
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABOARATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2899
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2009/10
C     ORIGINAL VERSION--OCTOBER   2009.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      REAL X
CCCCC REAL ABSX
CCCCC REAL AMULT
      REAL SAVE1
CCCCC REAL TERM
CCCCC REAL TEMP1
CCCCC REAL TEMP2
CCCCC REAL TEMP3
CCCCC REAL TEMP4
      INTEGER IDIGIT
      INTEGER IPOWER
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
      IF(IDIGIT.LT.-10)IDIGIT=-10
      IF(IDIGIT.GT.10)IDIGIT=10
C
CCCCC SAVE1=REAL(IDIGIT)
CCCCC ABSX=ABS(X)
CCCCC IPOWER=0
CCCCC IF(SAVE1.GT.0.0)IPOWER=AINT(SAVE1+0.5)
CCCCC AMULT=10.0**IPOWER
CCCCC TEMP2=ABSX*AMULT
CCCCC TEMP3=AINT(TEMP2+0.5)
CCCCC TEMP4=TEMP3/AMULT
CCCCC TERM=TEMP4
CCCCC IF(X.LT.0.0)TERM=(-TEMP4)
CCCCC RND=TERM
C
C     2014/12: ABOVE ALGORITHM DID NOT WORK AS EXPECTED FOR 64-BIT
C              INTEL FORTRAN COMPILER FOR WINDOWS.  USE DIFFERENT
C              ALGORITHM.
C
      SAVE1=REAL(IDIGIT)
      IF(SAVE1.LT.0.0)SAVE1=0.0
      IPOWER=INT(AINT(SAVE1+0.5))
      RND=REAL(INT(X*10**IPOWER + 0.5))/10**IPOWER
C
      RETURN
      END
      DOUBLE PRECISION FUNCTION RNOR()
*
*     RNOR generates normal random numbers with zero mean and unit
*     standard deviation, often denoted N(0,1),adapted from G. Marsaglia
*     and W. W. Tsang: "A Fast, Easily Implemented Method for Sampling
*     from Decreasing or Symmetric Unimodal Density Functions"
*      SIAM J. Sci. Stat. Comput. 5(1984), pp. 349-359.
*
      INTEGER J, N, TN
      DOUBLE PRECISION TWOPIS, AA, B, C, XDN
      PARAMETER ( N = 64, TN = 2*N, TWOPIS = TN/2.506628274631000D0 )
      PARAMETER ( XDN = 0.3601015713011893D0, B = 0.4878991777603940D0 )
      PARAMETER (  AA =  12.37586029917064D0, C =  12.67705807886560D0 )
      DOUBLE PRECISION XT, XX, Y, UNI
      DOUBLE PRECISION X(0:N)
      SAVE X
      DATA ( X(J), J = 0, 31 ) /
     &  0.3409450287039653D+00,  0.4573145918669259D+00,
     &  0.5397792816116612D+00,  0.6062426796530441D+00,
     &  0.6631690627645207D+00,  0.7136974590560222D+00,
     &  0.7596124749339174D+00,  0.8020356003555283D+00,
     &  0.8417226679789527D+00,  0.8792102232083114D+00,
     &  0.9148948043867484D+00,  0.9490791137530882D+00,
     &  0.9820004812398864D+00,  0.1013849238029940D+01,
     &  0.1044781036740172D+01,  0.1074925382028552D+01,
     &  0.1104391702268125D+01,  0.1133273776243940D+01,
     &  0.1161653030133931D+01,  0.1189601040838737D+01,
     &  0.1217181470700870D+01,  0.1244451587898246D+01,
     &  0.1271463480572119D+01,  0.1298265041883197D+01,
     &  0.1324900782180860D+01,  0.1351412509933371D+01,
     &  0.1377839912870011D+01,  0.1404221063559975D+01,
     &  0.1430592868502691D+01,  0.1456991476137671D+01,
     &  0.1483452656603219D+01,  0.1510012164318519D+01 /
      DATA ( X(J), J = 32, 64 ) /
     &  0.1536706093359520D+01,  0.1563571235037691D+01,
     &  0.1590645447014253D+01,  0.1617968043674446D+01,
     &  0.1645580218369081D+01,  0.1673525509567038D+01,
     &  0.1701850325062740D+01,  0.1730604541317782D+01,
     &  0.1759842199038300D+01,  0.1789622321566574D+01,
     &  0.1820009890130691D+01,  0.1851077020230275D+01,
     &  0.1882904397592872D+01,  0.1915583051943031D+01,
     &  0.1949216574916360D+01,  0.1983923928905685D+01,
     &  0.2019843052906235D+01,  0.2057135559990095D+01,
     &  0.2095992956249391D+01,  0.2136645022544389D+01,
     &  0.2179371340398135D+01,  0.2224517507216017D+01,
     &  0.2272518554850147D+01,  0.2323933820094302D+01,
     &  0.2379500774082828D+01,  0.2440221797979943D+01,
     &  0.2507511701865317D+01,  0.2583465835225429D+01,
     &  0.2671391590320836D+01,4*0.2776994269662875D+01 /
      IRESET=0
      Y = UNI(IRESET)
      J = MOD( INT( TN*UNI(IRESET) ), N )
      XT = X(J+1)
      RNOR = ( Y + Y - 1 )*XT
      IF ( ABS(RNOR) .GT. X(J) ) THEN
         XX = B*( XT - ABS(RNOR) )/( XT - X(J) )
         Y = UNI(IRESET)
         IF ( Y .GT. C - AA*EXP( -XX**2/2 ) ) THEN
            RNOR = SIGN( XX, RNOR )
         ELSE
            IF ( EXP(-XT**2/2)+Y/(TWOPIS*XT).GT.EXP(-RNOR**2/2) ) THEN
 10            XX = XDN*LOG( UNI(IRESET) )
               IF ( -2*LOG( UNI(IRESET) ) .LE. XX**2 ) GO TO 10
               RNOR = SIGN( X(N) - XX, RNOR )
            END IF
         END IF
      END IF
C
      RETURN
      END
      SUBROUTINE RNORM(U1, U2, ISEED)
C
C     ALGORITHM AS 53.1  APPL. STATIST. (1972) VOL.21, NO.3
C
C     Sets U1 and U2 to two independent standardized random normal
C     deviates.   This is a Fortran version of the method given in
C     Knuth(1969).
C
C     Function RAND must give a result randomly and rectangularly
C     distributed between the limits 0 and 1 exclusive.
C
      REAL U1, U2
      REAL XTEMP(1)
C
C     Local variables
C
      REAL X, Y, S, ONE, TWO
      DATA ONE /1.0/, TWO /2.0/
C
    1 CONTINUE
      N1 = 1
      CALL UNIRAN(N1,ISEED,XTEMP)
      X = XTEMP(1)
      CALL UNIRAN(N1,ISEED,XTEMP)
      Y = XTEMP(1)
C
      X = TWO * X - ONE
      Y = TWO * Y - ONE
      S = X * X + Y * Y
      IF (S .GT. ONE) GO TO 1
      S = SQRT(- TWO * LOG(S) / S)
      U1 = X * S
      U2 = Y * S
      RETURN
      END
      SUBROUTINE ROBPSD(X,N,NREPL,XTEMP1,ICASE,IWRITE,MAXNXT,
     1                  XSC,IERROR,ISUBRO,IBUGA3)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES A ROBUST POOLED STANDARD
C              DEVIATION.  THIS IS THE "ALGORITHM S" DESCRIBED IN
C              ISO STANDARD 1358 (IT WAS ORIGINALLY GIVEN IN ISO
C              STANDARD 5725-5).
C
C     REFERENCE--ISO 13528 (2005), "Statistical Methods for use in
C                proficiency testing by interlaboratory comparisons,"
C                Section C.2 Algorithm S.
C
C     WRITTEN BY--ALAN HECKERT
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
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 TECHNOOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2010/12
C     ORIGINAL VERSION--DECEMBER  2010.
C
C     NOTE--THE X ARRAY MAY CONTAIN EITHER STANDARD DEVIATIONS OR
C           RANGES (ICASE SPECIFIES WHICH IS BEING USED).
C
      REAL    X(*)
      REAL    XTEMP1(*)
      REAL    XSC
      REAL    ANU
      REAL    EPS
      REAL    PHI
      REAL    WSTAR
      REAL    WSTARU
      REAL    DIFF
      REAL    XMED
C
      CHARACTER*4 ICASE
      CHARACTER*4 IWRITE
      CHARACTER*4 IERROR
      CHARACTER*4 ISUBRO
      CHARACTER*4 IBUGA3
C
      DOUBLE PRECISION DSUM
      DOUBLE PRECISION DTEMP1
C
      INTEGER N
      INTEGER MAXNXT
      INTEGER I
      INTEGER NU
      INTEGER ITER
C
      INCLUDE 'DPCOP2.INC'
C
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'BPSD ')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,51)
   51   FORMAT('***** AT THE BEGINNING OF ROBPSD--')
        CALL DPWRST('XXX','BUG ')
        DO55I=1,N
          WRITE(ICOUT,56)I,X(I)
   56     FORMAT('I,X(I) = ',I8,G15.7)
          CALL DPWRST('XXX','BUG ')
   55   CONTINUE
      ENDIF
C
C     NEED AT LEAST 2 VALUES AND ALL VALUES SHOULD BE
C     NON-NEGATIVE.
C
      IF(N.LT.2)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,101)
  101   FORMAT('***** ERROR IN ROBUST POOLED STANDARD DEVIATION--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,103)
  103   FORMAT('      THE NUMBER OF OBSERVATIONS IS LESS THAN TWO.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,105)N
  105   FORMAT('      THE NUMBER OF OBSERVATIONS = ',I6)
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        GOTO9000
      ENDIF
C
      IF(ICASE.EQ.'SD' .AND. NREPL.LT.1)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,101)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,107)
  107   FORMAT('      THE NUMBER OF REPLICATIONS FOR EACH SD IS ',
     1         'LESS THAN ONE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,109)NREPL
  109   FORMAT('      THE NUMBER OF REPLICATIONS = ',I6)
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        GOTO9000
      ENDIF
C
      DO110I=1,N
        IF(X(I).LT.0.0)THEN
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,101)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,113)I,X(I)
  113     FORMAT('      ROW ',I8,' CONTAINS A NEGATIVE VALUE (',
     1           G15.7,').')
          CALL DPWRST('XXX','BUG ')
          IERROR='YES'
          GOTO9000
        ENDIF
  110 CONTINUE
C
C     STEP 1: SORT THE STANDARD DEVIATIONS (RANGES)
C             AND COMPUTE THE MEDIAN
C
CCCCC CALL SORT(X,N,X)
      CALL MEDIAN(X,N,IWRITE,XTEMP1,MAXNXT,XMED,IBUGA3,IERROR)
      WSTAR=XMED
C
C     STEP 2: UPDATE WSTAR VIA:
C
C             1) CALCULATE PHI = NU*WSTAR
C             2) FOR EACH X(I), CALCULATE
C
C                XSTAR(I) = PHI     IF  X(I) > PHI
C                         = X(I)    OTHERWISE
C             3) UPDATED WSTAR = EPS*SQRT(SUM[i=1 to n][(XSTAR(I)**2)/N])
C
      NU=0
      IF(ICASE.EQ.'SD')THEN
        NU=NREPL-1
      ELSEIF(ICASE.EQ.'RANG')THEN
        NU=1
      ENDIF
C
      IF(NU.EQ.1)THEN
        ANU=1.645
        EPS=1.097
      ELSEIF(NU.EQ.2)THEN
        ANU=1.517
        EPS=1.054
      ELSEIF(NU.EQ.3)THEN
        ANU=1.444
        EPS=1.039
      ELSEIF(NU.EQ.4)THEN
        ANU=1.395
        EPS=1.032
      ELSEIF(NU.EQ.5)THEN
        ANU=1.359
        EPS=1.027
      ELSEIF(NU.EQ.6)THEN
        ANU=1.332
        EPS=1.024
      ELSEIF(NU.EQ.7)THEN
        ANU=1.310
        EPS=1.021
      ELSEIF(NU.EQ.8)THEN
        ANU=1.292
        EPS=1.019
      ELSEIF(NU.EQ.9)THEN
        ANU=1.277
        EPS=1.018
      ELSEIF(NU.EQ.10)THEN
        ANU=1.264
        EPS=1.017
      ELSE
        CALL CHSPPF(0.9,NU,APPF)
        ANU=SQRT(APPF/REAL(NU))
        IDF=NU+2
        TERM1=REAL(NU)*ANU*ANU
        CALL CHSCDF(TERM1,IDF,CDF)
        EPS=1.0/SQRT(CDF + 0.1*ANU*ANU)
      ENDIF
C
      ITER=1
 1000 CONTINUE
      PHI=ANU*WSTAR
      DSUM=0.0D0
      DO1010I=1,N
        IF(X(I).GT.PHI)THEN
          XTEMP1(I)=PHI
          DSUM=DSUM + DBLE(PHI)**2
        ELSE
          DSUM=DSUM + DBLE(X(I))**2
        ENDIF
 1010 CONTINUE
      DTEMP1=DBLE(EPS)*DSQRT(DSUM/DBLE(N))
      WSTARU=REAL(DTEMP1)
      DIFF=ABS(WSTAR - WSTARU)
      RATIO=WSTAR/WSTARU
C
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'BPSD ')THEN
        WRITE(ICOUT,1022)ITER,WSTAR,WSTARU,DIFF,RATIO
 1022   FORMAT('ITER,WSTAR,WSTARU,DIFF,RATIO =',I5,4G15.7)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,1024)ANU,EPS,PHI
 1024   FORMAT('ANU,EPS,PHI =',3G15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      ITER=ITER+1
      IF(ITER.GT.50)GOTO1099
      IF(ABS(RATIO - 1.0) .LT. 1.0E-4)GOTO1099
      IF(DIFF.LT.0.0000001)GOTO1099
      WSTAR=WSTARU
      GOTO1000
C
 1099 CONTINUE
      WSTAR=WSTARU
      XSC=WSTAR
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'BPSD ')THEN
        WRITE(ICOUT,9010)
 9010   FORMAT('AT THE END OF ROBPSD')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9012)XSC
 9012   FORMAT('XSC=',G15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      RETURN
      END
      SUBROUTINE RPOCDF(X,C,CDF)
C
C     NOTE--THE STANDARD REFLECTED POWER FUNCTION
C           CUMULATIVE DISTRIBUTION FUNCTION IS:
C
C           F(X,C) = 1 - (1-X)**C        0 <= X <= 1, C > 0
C
C           WITH C DENOTING THE SCALE PARAMETER.
C     REFERENCE --KOTZ AND VAN DORP (2004), "BEYOND BETA: OTHER
C                 CONTINUOUS FAMILIES OF DISTRIBUTIONS WITH BOUNDED
C                 SUPPORT AND APPLICATION", WORLD SCIENTIFIC, PP. 199-201.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2007/12
C     ORIGINAL VERSION--DECEMBER  2007.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DC
      DOUBLE PRECISION DCDF
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      IF(X.LE.0.0)THEN
        CDF=0.0
        GOTO9999
      ELSEIF(X.GE.1.0)THEN
        CDF=1.0
        GOTO9999
      ENDIF
C
      IF(C.LE.0.0)THEN
        WRITE(ICOUT,311)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,302)C
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9999
      ENDIF
  311 FORMAT('***** ERROR IN RPOCDF--THE SECOND ARGUMENT IS ',
     1       'NON-POSITIVE.')
  302 FORMAT('      THE VALUE OF THE ARGUMENT IS ',G15.7)
C
      DX=DBLE(X)
      DC=DBLE(C)
      DCDF=1.0D0 - (1.0D0-DX)**DC
      CDF=REAL(DCDF)
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE RPOCHA(X,C,HAZ)
C
C     NOTE--THE STANDARD REFLECTED POWER FUNCTION CUMULATIVE HAZARD
C           FUNCTION IS:
C
C              H(X;C) = -LOG((1 - X)**C)       0 <= X <= 1, C > 0
C
C           WHERE C IS THE SHAPE PARAMETER.
C     REFERENCE --KOTZ AND VAN DORP (2004), "BEYOND BETA: OTHER
C                 CONTINUOUS FAMILIES OF DISTRIBUTIONS WITH BOUNDED
C                 SUPPORT AND APPLICATION", WORLD SCIENTIFIC, PP. 199-201.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2007/12
C     ORIGINAL VERSION--DECEMBER  2007.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DX
      DOUBLE PRECISION DC
      DOUBLE PRECISION DHAZ
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      HAZ=0.0
      IF(X.LT.0.0 .OR. X.GT.1.0)THEN
        WRITE(ICOUT,301)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,302)X
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ELSEIF(C.LE.0.0)THEN
        WRITE(ICOUT,311)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,302)C
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
  301 FORMAT('***** ERROR IN RPOCHAZ--THE FIRST ARGUMENT IS NOT IN ',
     1       'THE INTERVAL (0,1).')
  311 FORMAT('***** ERROR IN RPOCHAZ--THE SECOND ARGUMENT IS ',
     1       'NON-POSITIVE.')
  302 FORMAT('      THE VALUE OF THE ARGUMENT IS ',G15.7)
C
      DX=DBLE(X)
      DC=DBLE(C)
      DTERM1=(1.0D0 - DX)**DC
      IF(DTERM1.GT.0.0D0)THEN
        DHAZ=-DLOG(DTERM1)
        HAZ=REAL(DHAZ)
      ELSE
        WRITE(ICOUT,401)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,402)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,302)X
        CALL DPWRST('XXX','BUG ')
      ENDIF
  401 FORMAT('***** ERROR IN RPOCHAZ')
  402 FORMAT('      THE COMPUTED VALUE OF THE HAZARD FUNCTION ',
     1       'OVERFLOWS.')
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE RPOHAZ(X,C,HAZ)
C
C     NOTE--THE STANDARD REFLECTED POWER FUNCTION HAZARD
C           FUNCTION IS:
C
C              h(X;C) = C/(1 - X)     0 <= X <= 1, C > 0
C
C           WHERE C IS THE SHAPE PARAMETER.
C     REFERENCE --KOTZ AND VAN DORP (2004), "BEYOND BETA: OTHER
C                 CONTINUOUS FAMILIES OF DISTRIBUTIONS WITH BOUNDED
C                 SUPPORT AND APPLICATION", WORLD SCIENTIFIC, PP. 199-201.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2007/12
C     ORIGINAL VERSION--DECEMBER  2007.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DC
      DOUBLE PRECISION DHAZ
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      HAZ=0.0
      IF(X.LT.0.0 .OR. X.GE.1.0)THEN
        WRITE(ICOUT,301)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,302)X
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ELSEIF(C.LE.0.0)THEN
        WRITE(ICOUT,311)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,302)C
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
  301 FORMAT('***** ERROR IN RPOHAZ--THE FIRST ARGUMENT IS NOT IN ',
     1       'THE INTERVAL (0,1).')
  311 FORMAT('***** ERROR IN RPOHAZ--THE SECOND ARGUMENT IS ',
     1       'NON-POSITIVE.')
  302 FORMAT('      THE VALUE OF THE ARGUMENT IS ',G15.7)
C
      DX=DBLE(X)
      DC=DBLE(C)
      DHAZ=DC/(1.0D0 - DX)
      HAZ=REAL(DHAZ)
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE RPOPDF(X,C,PDF)
C
C     NOTE--THE STANDARD REFLECTED POWER FUNCTION PROBABILITY DENSITY
C           FUNCTION IS:
C
C              f(X;C) = C*(1-X)**(C-1)    0 <= X <= 1, C > 0
C
C           WITH C DENOTING THE SHAPE PARAMETER.
C     REFERENCE --KOTZ AND VAN DORP (2004), "BEYOND BETA: OTHER
C                 CONTINUOUS FAMILIES OF DISTRIBUTIONS WITH BOUNDED
C                 SUPPORT AND APPLICATION", WORLD SCIENTIFIC, PP. 199-201.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2007/12
C     ORIGINAL VERSION--DECEMBER  2007.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DC
      DOUBLE PRECISION DPDF
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      PDF=0.0
      IF(X.LT.0.0 .OR. X.GT.1.0)THEN
        WRITE(ICOUT,301)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,302)X
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ELSEIF(C.LE.0.0)THEN
        WRITE(ICOUT,311)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,302)C
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ELSEIF(X.GE.1.0 .AND. C.LT.1.0)THEN
        WRITE(ICOUT,301)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,302)X
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
  301 FORMAT('***** ERROR IN RPOPDF--THE FIRST ARGUMENT IS NOT IN ',
     1       'THE INTERVAL (0,1).')
  311 FORMAT('***** ERROR IN RPOPDF--THE SECOND ARGUMENT IS ',
     1       'NON-POSITIVE.')
  302 FORMAT('      THE VALUE OF THE ARGUMENT IS ',G15.7)
C
      DX=DBLE(X)
      DC=DBLE(C)
      DPDF=DC*(1.0D0 - DX)**(DC-1.0D0)
      PDF=REAL(DPDF)
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE RPOPPF(P,C,PPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT FUNCTION
C              VALUE FOR THE REFLECTED POWER FUNCTION DISTRIBUTION.
C              THE STANDARD REFLECTED POWER FUNCTION PPF IS:
C
C              G(P;C) = 1 - (1-P)**(1/C)    0 <= P <= 1, C > 0
C
C           WITH C DENOTING THE SHAPE PARAMETER.
C     REFERENCE --KOTZ AND VAN DORP (2004), "BEYOND BETA: OTHER
C                 CONTINUOUS FAMILIES OF DISTRIBUTIONS WITH BOUNDED
C                 SUPPORT AND APPLICATION", WORLD SCIENTIFIC, PP. 199-201.
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                     --C      = THE SINGLE PRECISION VALUE OF THE SHAPE
C                                PARAMETER.
C     OUTPUT ARGUMENTS--PPF    = THE SINGLE PRECISION PERCENT
C                                POINT FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PERCENT POINT
C             FUNCTION VALUE PPF.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--P SHOULD BE BETWEEN 0.0 AND 1.0, 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                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2007.12
C     ORIGINAL VERSION--DECEMBER  2007.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DOUBLE PRECISION DP
      DOUBLE PRECISION DC
      DOUBLE PRECISION DPPF
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      PPF=0.0
      IF(P.LT.0.0 .OR. P.GT.1.0)THEN
        WRITE(ICOUT,301)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,302)P
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ELSEIF(C.LE.0.0)THEN
        WRITE(ICOUT,311)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,302)C
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
  301 FORMAT('***** ERROR IN RPOPPF--THE FIRST ARGUMENT IS NOT IN ',
     1       'THE INTERVAL (0,1).')
  311 FORMAT('***** ERROR IN RPOPPF--THE SECOND ARGUMENT IS ',
     1       'NON-POSITIVE.')
  302 FORMAT('      THE VALUE OF THE ARGUMENT IS ',G15.7)
C
C-----START POINT-----------------------------------------------------
C
      IF(P.EQ.0.0)THEN
        PPF=0.0
      ELSEIF(P.EQ.1.0)THEN
        PPF=1.0
      ELSE
        DP=DBLE(P)
        DC=DBLE(C)
        DPPF=1.0D0 - (1.0D0-DP)**(1.0D0/DC)
        PPF=REAL(DPPF)
      ENDIF
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE RPORAN(N,C,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE THE REFLECTED POWER FUNCTION.
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --C      = A SINGLE PRECISION VALUE THAT SPECIFIES
C                                THE VALUE OF THE SHAPE PARAMETER.
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST N)
C                                INTO WHICH THE GENERATED
C                                RANDOM SAMPLE WILL BE PLACED.
C     OUTPUT--A RANDOM SAMPLE OF SIZE N
C             FROM THE REFLECTED POWER DISTRIBUTION
C             WITH MEAN = 0 AND STANDARD DEVIATION = 1.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCE --KOTZ AND VAN DORP (2004), "BEYOND BETA: OTHER
C                 CONTINUOUS FAMILIES OF DISTRIBUTIONS WITH BOUNDED
C                 SUPPORT AND APPLICATION", WORLD SCIENTIFIC, PP. 199-201.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2007.12
C     ORIGINAL VERSION--DECEMBER  2007.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DIMENSION X(*)
      DOUBLE PRECISION DX
      DOUBLE PRECISION DC
      DOUBLE PRECISION DTEMP
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)THEN
        WRITE(ICOUT, 5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(C.LE.0.0)THEN
        WRITE(ICOUT,311)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,312)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,302)C
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
    5 FORMAT('***** ERROR--THE REQUESTED NUMBER OF REFLECTED POWER ',
     1       'FUNCTION RANDOM NUMBERS IS NON-POSITIVE.')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8)
  311 FORMAT('***** ERROR IN REFLECTED POWER FUNCTION RANDOM NUMBERS.')
  312 FORMAT('      THE VALUE OF THE SHAPE PARAMETER IS NON-POSITIVE.')
  302 FORMAT('      THE VALUE OF THE ARGUMENT IS ',G15.7)
C
C     GENERATE N UNIFORM (0,1) RANDOM NUMBERS;
C
      CALL UNIRAN(N,ISEED,X)
C
C     REFLECTED POWER FUNCTION RANDOM NUMBERS = (UNIFORM)**(1/C)
C
      DC=DBLE(C)
      DO200I=1,N
        DX=DBLE(X(I))
        DTEMP=1.0D0 - (1.0D0-DX)**(1.0D0/DC)
        X(I)=REAL(DTEMP)
  200 CONTINUE
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE RSCSUM(X,N,XCAP,IWRITE,XRSCSU,IBUGA3,ISUBRO,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE RESCALED SUM OF SCORES
C
C                  RSCSUM = SUM[i=1 to n][X(i)]/SQRT(N)
C
C              OF THE DATA IN THE INPUT VECTOR X.
C
C              SOME AUTHORS RECOMMEND CAPPING THE VALUE OF
C              OUTLIERS TO LESSEN THE EFFECT OF SEVERE OUTLIERS
C              (THIS CAP IS TYPICALLY SET TO EITHER +/-3 OR
C              +/- 4).  SET XOUT TO CPUMIN IF CAPPING IS NOT
C              DESIRED.
C
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF
C                                (UNSORTED OR SORTED) OBSERVATIONS.
C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR X.
C     OUTPUT ARGUMENTS--RSCSUM = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED RESCALED SUM.
C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE RESCALED SUM.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     WRITTEN BY--ALAN HECKERT
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2012.2
C     ORIGINAL VERSION--FEBRUARY  2012.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGA3
      CHARACTER*4 ISUBRO
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DN
      DOUBLE PRECISION DX
      DOUBLE PRECISION DSUM
C
      DIMENSION X(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='RSCS'
      ISUBN2='UM  '
      IERROR='NO'
C
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CSUM')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,51)
   51   FORMAT('***** AT THE BEGINNING OF RSCSUM--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,52)IBUGA3,N,XCAP
   52   FORMAT('IBUGA3,N,XCAP = ',A4,2X,I8,2X,G15.7)
        CALL DPWRST('XXX','BUG ')
        DO55I=1,N
          WRITE(ICOUT,56)I,X(I)
   56     FORMAT('I,X(I) = ',I8,G15.7)
          CALL DPWRST('XXX','BUG ')
   55   CONTINUE
      ENDIF
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      IF(N.LT.1)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,111)
  111   FORMAT('***** ERROR IN RESCALED SUM ERROR--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,112)
  112   FORMAT('      THE NUMBER OF OBSERVATIONS FOR THE RESPONSE ',
     1         'VARIABLE IS LESS THAN 1.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,117)N
  117   FORMAT('      THE INPUT NUMBER OF OBSERVATIONS = ',I8)
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        GOTO9000
      ENDIF
C
C               ******************************************
C               **  STEP 2--                            **
C               **  COMPUTE THE SUM OF RESCALED SCORES. **
C               ******************************************
C
      DSUM=0.0D0
      IF(XCAP.EQ.CPUMIN)THEN
        DO200I=1,N
          DX=X(I)
          DSUM=DSUM + DX
  200   CONTINUE
      ELSE
        DO300I=1,N
          DX=X(I)
          IF(DABS(DX).GT.DBLE(XCAP))THEN
            IF(DX.GT.0.0D0)THEN
              DX=ABS(XCAP)
            ELSE
              DX=-ABS(XCAP)
            ENDIF
          ENDIF
          DSUM=DSUM + DX
  300   CONTINUE
      ENDIF
      DN=DBLE(N)
      XRSCSU=REAL(DSUM/DSQRT(DN))
C
C               *******************************
C               **  STEP 3--                 **
C               **  WRITE OUT A LINE         **
C               **  OF SUMMARY INFORMATION.  **
C               *******************************
C
      IF(IFEEDB.EQ.'ON' .AND. IWRITE.EQ.'ON')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,811)N,XRSCSS
  811   FORMAT('THE RESCALED SUM OF THE ',I8,' OBSERVATIONS = ',G15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CSUM')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END OF RSCSUM--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9013)IERROR,N,DSUM,XRSCSU
 9013   FORMAT('IERROR,N,DSUM,XRSCSU = ',A4,2X,I8,2G15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      RETURN
      END
      SUBROUTINE RSURF(X,Y,NP,KOLR,FRM,
     1           XTEMP,YTEMP,TATEMP,NTEMP,NTRACE,
     1           IBUGG3,ISUBRO,IERROR)
C
C     PURPOSE--PAINT IN THE ENCLOSED REGION
C              DEFINED BY THE NP COORDINATES
C              IN X(.) AND Y(.).
C              USE FILL COLOR AS SPECIFIED BY THE INTEGER KOLR
C              (WHERE KOLR = 0 IMPLIES NO FILL).
C
C     WRITTEN BY--DAVID W. BEHRINGER NOAA/AOML (MIAMI).
C                 AS PART OF NOAA'S CONCX V.3   MARCH 1988.
C     ORIGINAL VERSION (IN DATAPLOT)--AUGUST    1988.
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IBUGG3
      CHARACTER*4 ISUBRO
      CHARACTER*4 IERROR
C
      DIMENSION X(*)
      DIMENSION Y(*)
C
      DIMENSION XTEMP(*)
      DIMENSION YTEMP(*)
      DIMENSION TATEMP(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      IERROR='NO'
      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'SURF')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,1011)NP,KOLR,NTEMP,NTRACE,FRM
 1011   FORMAT('FROM RSURF--NP,KOLR,NTEMP,NTRACE,FRM = ',4I8,F10.5)
        CALL DPWRST('XXX','BUG ')
        DO1015I=1,NP
          WRITE(ICOUT,1016)I,X(I),Y(I),TATEMP(I),XTEMP(I),YTEMP(I)
 1016     FORMAT('I,X(I),Y(I),TATEMP(I),XTEMP(I),YTEMP(I) = ',
     1           I8,5G15.7)
          CALL DPWRST('XXX','BUG ')
 1015   CONTINUE
      ENDIF
C
CCCCC NTRACE=NTRACE+1
CCCCC DO1100I=1,NP
CCCCC NTEMP=NTEMP+1
CCCCC XTEMP(NTEMP)=X(I)
CCCCC YTEMP(NTEMP)=Y(I)
CCCCC TATEMP(NTEMP)=NTRACE
C1100 CONTINUE
C
      RETURN
      END
      SUBROUTINE RULNRM( LENRUL, NUMNUL, RULPTS, W, RULCON )
      INTEGER LENRUL, NUMNUL, I, J, K, RULPTS(*)
      DOUBLE PRECISION ALPHA, NORMCF, NORMNL, W(LENRUL, *), RULCON
*
*     Compute orthonormalized null rules.
*
      NORMCF = 0
      DO 100 I = 1,LENRUL
         NORMCF = NORMCF + RULPTS(I)*W(I,1)*W(I,1)
  100 CONTINUE
      DO 200 K = 2,NUMNUL
         DO 300 I = 1,LENRUL
            W(I,K) = W(I,K) - W(I,1)
  300    CONTINUE
         DO 400 J = 2,K-1
            ALPHA = 0
            DO 500 I = 1,LENRUL
               ALPHA = ALPHA + RULPTS(I)*W(I,J)*W(I,K)
  500       CONTINUE
            ALPHA = -ALPHA/NORMCF
            DO 600 I = 1,LENRUL
               W(I,K) = W(I,K) + ALPHA*W(I,J)
  600       CONTINUE
  400    CONTINUE
         NORMNL = 0
         DO 700 I = 1,LENRUL
            NORMNL = NORMNL + RULPTS(I)*W(I,K)*W(I,K)
  700    CONTINUE
         ALPHA = SQRT(NORMCF/NORMNL)
         DO 800 I = 1,LENRUL
            W(I,K) = ALPHA*W(I,K)
  800    CONTINUE
  200 CONTINUE
      DO 900 J = 2, NUMNUL
         DO 950 I = 1,LENRUL
            W(I,J) = W(I,J)/RULCON
  950    CONTINUE
  900 CONTINUE
C
      RETURN
      END
      FUNCTION RUNIF(T,N)
C***BEGIN PROLOGUE  RUNIF
C***DATE WRITTEN   770401   (YYMMDD)
C***REVISION DATE  820801   (YYMMDD)
C***REVISION HISTORY  (YYMMDD)
C   000330  Modified array declarations.  (JEC)
C***CATEGORY NO.  L6A21
C***KEYWORDS  RANDOM NUMBER,SPECIAL FUNCTION,UNIFORM
C***AUTHOR  FULLERTON, W., (LANL)
C***PURPOSE  A portable random number genaerator.
C***DESCRIPTION
C
C This random number generator is portable among a wide variety of
C computers.  It generates a random number between 0.0 and 1.0 accord-
C ing to the algorithm presented by Bays and Durham (TOMS, 2, 59,
C 1976).  The motivation for using this scheme, which resembles the
C Maclaren-Marsaglia method, is to greatly increase the period of the
C random sequence.  If the period of the basic generator (RAND) is P,
C then the expected mean period of the sequence generated by RUNIF is
C given by   new mean P = SQRT (PI*FACTORIAL(N)/(8*P)),
C where FACTORIAL(N) must be much greater than P in this asymptotic
C formula.  Generally, N should be around 32 if P=4.E6 as for RAND.
C
C             Input Argument --
C N      IABS(N) is the number of random numbers in an auxiliary table.
C        Note though that IABS(N)+1 is the number of items in array T.
C        If N is positive and differs from its value in the previous
C        invocation, then the table is initialized for the new value of
C        N.  If N is negative, IABS(N) is the number of items in an
C        auxiliary table, but the tables are now assumed already to
C        be initialized.  This option enables the user to save the
C        table T at the end of a long computer run and to restart with
C        the same sequence.  Normally, RUNIF would be called at most
C        once with negative N.  Subsequent invocations would have N
C        positive and of the correct magnitude.
C
C             Input and Output Argument  --
C T      an array of IABS(N)+1 random numbers from a previous invocation
C        of RUNIF.  Whenever N is positive and differs from the old
C        N, the table is initialized.  The first IABS(N) numbers are the
C        table discussed in the reference, and the N+1 -st value is Y.
C        This array may be saved in order to restart a sequence.
C
C             Output Value --
C RUNIF  a random number between 0.0 and 1.0.
C***REFERENCES  (NONE)
C***ROUTINES CALLED  RAND
C***END PROLOGUE  RUNIF
      DIMENSION T(*)
      EXTERNAL RANDDP
      DATA NOLD /-1/
C***FIRST EXECUTABLE STATEMENT  RUNIF
C
      FLOATN=0.0
C
      IF (N.EQ.NOLD) GO TO 20
C
      NOLD = IABS(N)
      FLOATN = NOLD
      IF (N.LT.0) DUMMY = RANDDP (T(NOLD+1))
      IF (N.LT.0) GO TO 20
C
      DO 10 I=1,NOLD
        T(I) = RANDDP (0.)
 10   CONTINUE
      T(NOLD+1) = RANDDP (0.)
C
 20   J = INT(T(NOLD+1)*FLOATN + 1.)
      T(NOLD+1) = T(J)
      RUNIF = T(J)
      T(J) = RANDDP (0.)
C
      RETURN
      END
      subroutine rwts(y,n,fit,rw)
c
c  This routine is part of the Bill Cleveland seasonal loess
c  program.
c
      integer mid(2), n
      real y(n), fit(n), rw(n), cmad, c9, c1, r
      do 23097 i = 1,n
      rw(i) = abs(y(i)-fit(i))
23097 continue
      mid(1) = n/2+1
      mid(2) = n-mid(1)+1
      call psort(rw,n,mid,2)
      cmad = 3.0*(rw(mid(1))+rw(mid(2)))
      c9 = .999*cmad
      c1 = .001*cmad
      do 23099 i = 1,n
      r = abs(y(i)-fit(i))
      if(.not.(r .le. c1))goto 23101
      rw(i) = 1.
      goto 23102
23101 continue
      if(.not.(r .le. c9))goto 23103
      rw(i) = (1.0-(r/cmad)**2)**2
      goto 23104
23103 continue
      rw(i) = 0.
23104 continue
23102 continue
23099 continue
      return
      end
      SUBROUTINE R9AIMP (X, AMPL, THETA)
C***BEGIN PROLOGUE  R9AIMP
C***SUBSIDIARY
C***PURPOSE  Evaluate the Airy modulus and phase.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C10D
C***TYPE      SINGLE PRECISION (R9AIMP-S, D9AIMP-D)
C***KEYWORDS  AIRY FUNCTION, FNLIB, MODULUS, PHASE, SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C Evaluate the Airy modulus and phase for X .LE. -1.0
C
C Series for AM21       on the interval -1.25000D-01 to  0.
C                                        with weighted error   2.89E-17
C                                         log weighted error  16.54
C                               significant figures required  14.15
C                                    decimal places required  17.34
C
C Series for ATH1       on the interval -1.25000D-01 to  0.
C                                        with weighted error   2.53E-17
C                                         log weighted error  16.60
C                               significant figures required  15.15
C                                    decimal places required  17.38
C
C Series for AM22       on the interval -1.00000D+00 to -1.25000D-01
C                                        with weighted error   2.99E-17
C                                         log weighted error  16.52
C                               significant figures required  14.57
C                                    decimal places required  17.28
C
C Series for ATH2       on the interval -1.00000D+00 to -1.25000D-01
C                                        with weighted error   2.57E-17
C                                         log weighted error  16.59
C                               significant figures required  15.07
C                                    decimal places required  17.34
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  CSEVL, INITS, R1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770701  DATE WRITTEN
C   890206  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900720  Routine changed from user-callable to subsidiary.  (WRB)
C***END PROLOGUE  R9AIMP
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOMC.INC'
      INCLUDE 'DPCOP2.INC'
C
      DIMENSION AM21CS(40), ATH1CS(36), AM22CS(33), ATH2CS(32)
      LOGICAL FIRST
      SAVE AM21CS, ATH1CS, AM22CS, ATH2CS, PI4, NAM21,
     1 NATH1, NAM22, NATH2, XSML, FIRST
      DATA AM21CS( 1) /    .0065809191 761485E0 /
      DATA AM21CS( 2) /    .0023675984 685722E0 /
      DATA AM21CS( 3) /    .0001324741 670371E0 /
      DATA AM21CS( 4) /    .0000157600 904043E0 /
      DATA AM21CS( 5) /    .0000027529 702663E0 /
      DATA AM21CS( 6) /    .0000006102 679017E0 /
      DATA AM21CS( 7) /    .0000001595 088468E0 /
      DATA AM21CS( 8) /    .0000000471 033947E0 /
      DATA AM21CS( 9) /    .0000000152 933871E0 /
      DATA AM21CS(10) /    .0000000053 590722E0 /
      DATA AM21CS(11) /    .0000000020 000910E0 /
      DATA AM21CS(12) /    .0000000007 872292E0 /
      DATA AM21CS(13) /    .0000000003 243103E0 /
      DATA AM21CS(14) /    .0000000001 390106E0 /
      DATA AM21CS(15) /    .0000000000 617011E0 /
      DATA AM21CS(16) /    .0000000000 282491E0 /
      DATA AM21CS(17) /    .0000000000 132979E0 /
      DATA AM21CS(18) /    .0000000000 064188E0 /
      DATA AM21CS(19) /    .0000000000 031697E0 /
      DATA AM21CS(20) /    .0000000000 015981E0 /
      DATA AM21CS(21) /    .0000000000 008213E0 /
      DATA AM21CS(22) /    .0000000000 004296E0 /
      DATA AM21CS(23) /    .0000000000 002284E0 /
      DATA AM21CS(24) /    .0000000000 001232E0 /
      DATA AM21CS(25) /    .0000000000 000675E0 /
      DATA AM21CS(26) /    .0000000000 000374E0 /
      DATA AM21CS(27) /    .0000000000 000210E0 /
      DATA AM21CS(28) /    .0000000000 000119E0 /
      DATA AM21CS(29) /    .0000000000 000068E0 /
      DATA AM21CS(30) /    .0000000000 000039E0 /
      DATA AM21CS(31) /    .0000000000 000023E0 /
      DATA AM21CS(32) /    .0000000000 000013E0 /
      DATA AM21CS(33) /    .0000000000 000008E0 /
      DATA AM21CS(34) /    .0000000000 000005E0 /
      DATA AM21CS(35) /    .0000000000 000003E0 /
      DATA AM21CS(36) /    .0000000000 000001E0 /
      DATA AM21CS(37) /    .0000000000 000001E0 /
      DATA AM21CS(38) /    .0000000000 000000E0 /
      DATA AM21CS(39) /    .0000000000 000000E0 /
      DATA AM21CS(40) /    .0000000000 000000E0 /
      DATA ATH1CS( 1) /   -.0712583781 5669365E0 /
      DATA ATH1CS( 2) /   -.0059047197 9831451E0 /
      DATA ATH1CS( 3) /   -.0001211454 4069499E0 /
      DATA ATH1CS( 4) /   -.0000098860 8542270E0 /
      DATA ATH1CS( 5) /   -.0000013808 4097352E0 /
      DATA ATH1CS( 6) /   -.0000002614 2640172E0 /
      DATA ATH1CS( 7) /   -.0000000605 0432589E0 /
      DATA ATH1CS( 8) /   -.0000000161 8436223E0 /
      DATA ATH1CS( 9) /   -.0000000048 3464911E0 /
      DATA ATH1CS(10) /   -.0000000015 7655272E0 /
      DATA ATH1CS(11) /   -.0000000005 5231518E0 /
      DATA ATH1CS(12) /   -.0000000002 0545441E0 /
      DATA ATH1CS(13) /   -.0000000000 8043412E0 /
      DATA ATH1CS(14) /   -.0000000000 3291252E0 /
      DATA ATH1CS(15) /   -.0000000000 1399875E0 /
      DATA ATH1CS(16) /   -.0000000000 0616151E0 /
      DATA ATH1CS(17) /   -.0000000000 0279614E0 /
      DATA ATH1CS(18) /   -.0000000000 0130428E0 /
      DATA ATH1CS(19) /   -.0000000000 0062373E0 /
      DATA ATH1CS(20) /   -.0000000000 0030512E0 /
      DATA ATH1CS(21) /   -.0000000000 0015239E0 /
      DATA ATH1CS(22) /   -.0000000000 0007758E0 /
      DATA ATH1CS(23) /   -.0000000000 0004020E0 /
      DATA ATH1CS(24) /   -.0000000000 0002117E0 /
      DATA ATH1CS(25) /   -.0000000000 0001132E0 /
      DATA ATH1CS(26) /   -.0000000000 0000614E0 /
      DATA ATH1CS(27) /   -.0000000000 0000337E0 /
      DATA ATH1CS(28) /   -.0000000000 0000188E0 /
      DATA ATH1CS(29) /   -.0000000000 0000105E0 /
      DATA ATH1CS(30) /   -.0000000000 0000060E0 /
      DATA ATH1CS(31) /   -.0000000000 0000034E0 /
      DATA ATH1CS(32) /   -.0000000000 0000020E0 /
      DATA ATH1CS(33) /   -.0000000000 0000011E0 /
      DATA ATH1CS(34) /   -.0000000000 0000007E0 /
      DATA ATH1CS(35) /   -.0000000000 0000004E0 /
      DATA ATH1CS(36) /   -.0000000000 0000002E0 /
      DATA AM22CS( 1) /   -.0156284448 0625341E0 /
      DATA AM22CS( 2) /    .0077833644 5239681E0 /
      DATA AM22CS( 3) /    .0008670577 7047718E0 /
      DATA AM22CS( 4) /    .0001569662 7315611E0 /
      DATA AM22CS( 5) /    .0000356396 2571432E0 /
      DATA AM22CS( 6) /    .0000092459 8335425E0 /
      DATA AM22CS( 7) /    .0000026211 0161850E0 /
      DATA AM22CS( 8) /    .0000007918 8221651E0 /
      DATA AM22CS( 9) /    .0000002510 4152792E0 /
      DATA AM22CS(10) /    .0000000826 5223206E0 /
      DATA AM22CS(11) /    .0000000280 5711662E0 /
      DATA AM22CS(12) /    .0000000097 6821090E0 /
      DATA AM22CS(13) /    .0000000034 7407923E0 /
      DATA AM22CS(14) /    .0000000012 5828132E0 /
      DATA AM22CS(15) /    .0000000004 6298826E0 /
      DATA AM22CS(16) /    .0000000001 7272825E0 /
      DATA AM22CS(17) /    .0000000000 6523192E0 /
      DATA AM22CS(18) /    .0000000000 2490471E0 /
      DATA AM22CS(19) /    .0000000000 0960156E0 /
      DATA AM22CS(20) /    .0000000000 0373448E0 /
      DATA AM22CS(21) /    .0000000000 0146417E0 /
      DATA AM22CS(22) /    .0000000000 0057826E0 /
      DATA AM22CS(23) /    .0000000000 0022991E0 /
      DATA AM22CS(24) /    .0000000000 0009197E0 /
      DATA AM22CS(25) /    .0000000000 0003700E0 /
      DATA AM22CS(26) /    .0000000000 0001496E0 /
      DATA AM22CS(27) /    .0000000000 0000608E0 /
      DATA AM22CS(28) /    .0000000000 0000248E0 /
      DATA AM22CS(29) /    .0000000000 0000101E0 /
      DATA AM22CS(30) /    .0000000000 0000041E0 /
      DATA AM22CS(31) /    .0000000000 0000017E0 /
      DATA AM22CS(32) /    .0000000000 0000007E0 /
      DATA AM22CS(33) /    .0000000000 0000002E0 /
      DATA ATH2CS( 1) /    .0044052734 5871877E0 /
      DATA ATH2CS( 2) /   -.0304291945 2318455E0 /
      DATA ATH2CS( 3) /   -.0013856532 8377179E0 /
      DATA ATH2CS( 4) /   -.0001804443 9089549E0 /
      DATA ATH2CS( 5) /   -.0000338084 7108327E0 /
      DATA ATH2CS( 6) /   -.0000076781 8353522E0 /
      DATA ATH2CS( 7) /   -.0000019678 3944371E0 /
      DATA ATH2CS( 8) /   -.0000005483 7271158E0 /
      DATA ATH2CS( 9) /   -.0000001625 4615505E0 /
      DATA ATH2CS(10) /   -.0000000505 3049981E0 /
      DATA ATH2CS(11) /   -.0000000163 1580701E0 /
      DATA ATH2CS(12) /   -.0000000054 3420411E0 /
      DATA ATH2CS(13) /   -.0000000018 5739855E0 /
      DATA ATH2CS(14) /   -.0000000006 4895120E0 /
      DATA ATH2CS(15) /   -.0000000002 3105948E0 /
      DATA ATH2CS(16) /   -.0000000000 8363282E0 /
      DATA ATH2CS(17) /   -.0000000000 3071196E0 /
      DATA ATH2CS(18) /   -.0000000000 1142367E0 /
      DATA ATH2CS(19) /   -.0000000000 0429811E0 /
      DATA ATH2CS(20) /   -.0000000000 0163389E0 /
      DATA ATH2CS(21) /   -.0000000000 0062693E0 /
      DATA ATH2CS(22) /   -.0000000000 0024260E0 /
      DATA ATH2CS(23) /   -.0000000000 0009461E0 /
      DATA ATH2CS(24) /   -.0000000000 0003716E0 /
      DATA ATH2CS(25) /   -.0000000000 0001469E0 /
      DATA ATH2CS(26) /   -.0000000000 0000584E0 /
      DATA ATH2CS(27) /   -.0000000000 0000233E0 /
      DATA ATH2CS(28) /   -.0000000000 0000093E0 /
      DATA ATH2CS(29) /   -.0000000000 0000037E0 /
      DATA ATH2CS(30) /   -.0000000000 0000015E0 /
      DATA ATH2CS(31) /   -.0000000000 0000006E0 /
      DATA ATH2CS(32) /   -.0000000000 0000002E0 /
      DATA PI4 / 0.7853981633 9744831 E0 /
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  R9AIMP
      IF (FIRST) THEN
         ETA = 0.1*R1MACH(3)
         NAM21 = INITS (AM21CS, 40, ETA)
         NATH1 = INITS (ATH1CS, 36, ETA)
         NAM22 = INITS (AM22CS, 33, ETA)
         NATH2 = INITS (ATH2CS, 32, ETA)
C
         XSML = -1.0/R1MACH(3)**0.3333
      ENDIF
      FIRST = .FALSE.
C
      IF (X.GE.(-2.0)) GO TO 20
      Z = 1.0
      IF (X.GT.XSML) Z = 16.0/X**3 + 1.0
      AMPL = 0.3125 + CSEVL(Z, AM21CS, NAM21)
      THETA = -0.625 + CSEVL (Z, ATH1CS, NATH1)
      GO TO 30
C
 20   IF (X .GT. (-1.0)) THEN
        WRITE(ICOUT,1)
    1   FORMAT('***** ERORR FROM R9AIMP, X MUST BE LESS THAN OR EQUAL',
     1         ' TO -1.  *******')
        CALL DPWRST('XXX','BUG ')
        RETURN
      ENDIF
C
      Z = (16.0/X**3 + 9.0)/7.0
      AMPL = 0.3125 + CSEVL (Z, AM22CS, NAM22)
      THETA = -0.625 + CSEVL (Z, ATH2CS, NATH2)
C
 30   SQRTX = SQRT(-X)
      AMPL = SQRT (AMPL/SQRTX)
      THETA = PI4 - X*SQRTX * THETA
C
      RETURN
      END
      SUBROUTINE SAMLMR(X,N,XMOM,NMOM,A,B)
C===================================================== SAMLMR.FOR
C***********************************************************************
C*                                                                     *
C*  FORTRAN CODE WRITTEN FOR INCLUSION IN IBM RESEARCH REPORT RC20525, *
C*  'FORTRAN ROUTINES FOR USE WITH THE METHOD OF L-MOMENTS, VERSION 3' *
C*                                                                     *
C*  J. R. M. HOSKING                                                   *
C*  IBM RESEARCH DIVISION                                              *
C*  T. J. WATSON RESEARCH CENTER                                       *
C*  YORKTOWN HEIGHTS                                                   *
C*  NEW YORK 10598, U.S.A.                                             *
C*                                                                     *
C*  VERSION 3     AUGUST 1996                                          *
C*                                                                     *
C***********************************************************************
C
C  SAMPLE L-MOMENTS OF A DATA ARRAY
C
C  PARAMETERS OF ROUTINE:
C  X      * INPUT* ARRAY OF LENGTH N. CONTAINS THE DATA, IN ASCENDING
C                  ORDER.
C  N      * INPUT* NUMBER OF DATA VALUES
C  XMOM   *OUTPUT* ARRAY OF LENGTH NMOM. ON EXIT, CONTAINS THE SAMPLE
C                  L-MOMENTS L-1, L-2, T-3, T-4, ... .
C  NMOM   * INPUT* NUMBER OF L-MOMENTS TO BE FOUND. AT MOST MAX(N,20).
C  A      * INPUT* ) PARAMETERS OF PLOTTING
C  B      * INPUT* ) POSITION (SEE BELOW)
C
C  FOR UNBIASED ESTIMATES (OF THE LAMBDA'S) SET A=B=ZERO. OTHERWISE,
C  PLOTTING-POSITION ESTIMATORS ARE USED, BASED ON THE PLOTTING POSITION
C  (J+A)/(N+B)  FOR THE J'TH SMALLEST OF N OBSERVATIONS. FOR EXAMPLE,
C  A=-0.35D0 AND B=0.0D0 YIELDS THE ESTIMATORS RECOMMENDED BY
C  HOSKING ET AL. (1985, TECHNOMETRICS) FOR THE GEV DISTRIBUTION.
C
C  MODIFIED 6/2005 FOR INCLUSION INTO DATAPLOT BY ALAN HECKERT.
C  NOTE THAT THE CHANGES WERE ONLY FOR THE I/O, NO CHANGE IN
C  COMPUTATIONAL ASPECTS.
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DOUBLE PRECISION X(N),XMOM(NMOM),SUM(20)
C
      INCLUDE 'DPCOP2.INC'
C
      DATA ZERO/0D0/,ONE/1D0/
C
      IF(NMOM.GT.20.OR.NMOM.GT.N)THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,7000)
 7000   FORMAT('****** ERROR IN ROUTINE SAMLMR: PARAMETER NMOM ',
     1         '(NUMBER OF MOMENTS) INVALID')
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      DO 10 J=1,NMOM
         SUM(J)=ZERO
   10 CONTINUE
      IF(A.EQ.ZERO.AND.B.EQ.ZERO)THEN
C
C         UNBIASED ESTIMATES OF PWM'S
C
         DO 70 I=1,N
            Z=I
            TERM=X(I)
            SUM(1)=SUM(1)+TERM
            DO 60 J=2,NMOM
               Z=Z-ONE
               TERM=TERM*Z
               SUM(J)=SUM(J)+TERM
   60       CONTINUE
   70    CONTINUE
         Y=N
         Z=N
         SUM(1)=SUM(1)/Z
         DO 80 J=2,NMOM
            Y=Y-ONE
            Z=Z*Y
            SUM(J)=SUM(J)/Z
   80    CONTINUE
      ELSE
         IF(A.LE.-ONE.OR.A.GE.B)THEN
            WRITE(ICOUT,999)
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,7010)
 7010       FORMAT('****** ERROR IN ROUTINE SAMLMR :')
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,7011)
 7011       FORMAT('       PLOTTING-POSITION PARAMETERS INVALID')
            CALL DPWRST('XXX','BUG ')
            RETURN
         ENDIF
C
C         PLOTTING-POSITION ESTIMATES OF PWM'S
C
         DO 30 I=1,N
            PPOS=(I+A)/(N+B)
            TERM=X(I)
            SUM(1)=SUM(1)+TERM
            DO 20 J=2,NMOM
               TERM=TERM*PPOS
               SUM(J)=SUM(J)+TERM
   20       CONTINUE
   30    CONTINUE
         DO 40 J=1,NMOM
            SUM(J)=SUM(J)/N
   40    CONTINUE
      ENDIF
C
C         L-MOMENTS
C
      K=NMOM
      P0=ONE
      IF(NMOM-NMOM/2*2.EQ.1)P0=-ONE
      DO 120 KK=2,NMOM
         AK=K
         P0=-P0
         P=P0
         TEMP=P*SUM(1)
         DO 110 I=1,K-1
            AI=I
            P=-P*(AK+AI-ONE)*(AK-AI)/(AI*AI)
            TEMP=TEMP+P*SUM(I+1)
  110    CONTINUE
         SUM(K)=TEMP
         K=K-1
  120 CONTINUE
      XMOM(1)=SUM(1)
      IF(NMOM.EQ.1)RETURN
      XMOM(2)=SUM(2)
      IF(SUM(2).EQ.ZERO)THEN
         WRITE(ICOUT,999)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,7020)
 7020    FORMAT('****** ERROR IN ROUTINE SAMLMR: ALL DATA VALUES ',
     1          'EQUAL.')
         CALL DPWRST('XXX','BUG ')
         RETURN
      ENDIF
      IF(NMOM.EQ.2)RETURN
      DO 130 K=3,NMOM
         XMOM(K)=SUM(K)/SUM(2)
  130 CONTINUE
C
      RETURN
      END
      SUBROUTINE SAMLMU(X,N,XMOM,NMOM)
C===================================================== SAMLMU.FOR
C***********************************************************************
C*                                                                     *
C*  FORTRAN CODE WRITTEN FOR INCLUSION IN IBM RESEARCH REPORT RC20525, *
C*  'FORTRAN ROUTINES FOR USE WITH THE METHOD OF L-MOMENTS, VERSION 3' *
C*                                                                     *
C*  J. R. M. HOSKING                                                   *
C*  IBM RESEARCH DIVISION                                              *
C*  T. J. WATSON RESEARCH CENTER                                       *
C*  YORKTOWN HEIGHTS                                                   *
C*  NEW YORK 10598, U.S.A.                                             *
C*                                                                     *
C*  VERSION 3     AUGUST 1996                                          *
C*                                                                     *
C***********************************************************************
C
C  SAMPLE L-MOMENTS OF A DATA ARRAY
C
C  PARAMETERS OF ROUTINE:
C  X      * INPUT* ARRAY OF LENGTH N. CONTAINS THE DATA, IN ASCENDING
C                  ORDER.
C  N      * INPUT* NUMBER OF DATA VALUES
C  XMOM   *OUTPUT* ARRAY OF LENGTH NMOM. CONTAINS THE SAMPLE L-MOMENTS,
C                  STORED AS DESCRIBED BELOW.
C  NMOM   * INPUT* NUMBER OF L-MOMENTS TO BE FOUND. AT MOST 100.
C
C  MODIFIED 6/2005 FOR INCLUSION INTO DATAPLOT BY ALAN HECKERT.
C  NOTE THAT THE CHANGES WERE ONLY FOR THE I/O, NO CHANGE IN
C  COMPUTATIONAL ASPECTS.
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (MAXMOM=100)
      DOUBLE PRECISION X(N),XMOM(NMOM),COEF(2,MAXMOM)
C
      INCLUDE 'DPCOP2.INC'
C
      DATA ZERO/0.0D0/,ONE/1.0D0/,TWO/2.0D0/
C
      IF(NMOM.GT.MAXMOM)THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,7000)
 7000   FORMAT('****** ERROR IN ROUTINE SAMLMU: PARAMETER NMOM ',
     1         '(NUMBER OF MOMENTS) INVALID')
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      DN=N
      DO 10 J=1,NMOM
         XMOM(J)=ZERO
   10 CONTINUE
      IF(NMOM.LE.2)THEN
C
C         AT MOST TWO L-MOMENTS
C
         SUM1=ZERO
         SUM2=ZERO
         TEMP=-DN+ONE
         DO 110 I=1,N
            SUM1=SUM1+X(I)
            SUM2=SUM2+X(I)*TEMP
            TEMP=TEMP+TWO
  110    CONTINUE
         XMOM(1)=SUM1/DN
         IF(NMOM.EQ.1)RETURN
         XMOM(2)=SUM2/(DN*(DN-ONE))
         RETURN
      ELSE
C
C         UNBIASED ESTIMATES OF L-MOMENTS -- THE 'DO 30' LOOP
C         RECURSIVELY CALCULATES DISCRETE LEGENDRE POLYNOMIALS, VIA
C         EQ.(9) OF NEUMAN AND SCHONBACH (1974, INT.J.NUM.METH.ENG.)
C
         DO 20 J=3,NMOM
           TEMP=ONE/DBLE((J-1)*(N-J+1))
           COEF(1,J)=DBLE(J+J-3)*TEMP
           COEF(2,J)=DBLE((J-2)*(N+J-2))*TEMP
   20    CONTINUE
         TEMP=-DN-ONE
         CONST=ONE/(DN-ONE)
         NHALF=N/2
         DO 40 I=1,NHALF
            TEMP=TEMP+TWO
            XI=X(I)
            XII=X(N+1-I)
            TERMP=XI+XII
            TERMN=XI-XII
            XMOM(1)=XMOM(1)+TERMP
            S1=ONE
            S=TEMP*CONST
            XMOM(2)=XMOM(2)+S*TERMN
            DO 30 J=3,NMOM,2
               S2=S1
               S1=S
               S=COEF(1,J)*TEMP*S1-COEF(2,J)*S2
               XMOM(J)=XMOM(J)+S*TERMP
               IF(J.EQ.NMOM)GOTO 30
               JJ=J+1
               S2=S1
               S1=S
               S=COEF(1,JJ)*TEMP*S1-COEF(2,JJ)*S2
               XMOM(JJ)=XMOM(JJ)+S*TERMN
   30       CONTINUE
   40    CONTINUE
         IF(N.EQ.NHALF+NHALF)GOTO 60
           TERM=X(NHALF+1)
           S=ONE
           XMOM(1)=XMOM(1)+TERM
           DO 50 J=3,NMOM,2
              S=-COEF(2,J)*S
              XMOM(J)=XMOM(J)+S*TERM
   50      CONTINUE
C
C         L-MOMENT RATIOS
C
   60    CONTINUE
         XMOM(1)=XMOM(1)/DN
         IF(XMOM(2).EQ.ZERO)THEN
            WRITE(ICOUT,999)
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,7020)
 7020       FORMAT('****** ERROR IN ROUTINE SAMLMU: ALL DATA VALUES ',
     1             'EQUAL.')
            CALL DPWRST('XXX','BUG ')
            DO 1020 J=1,NMOM
               XMOM(J)=ZERO
 1020       CONTINUE
            RETURN
         ENDIF
         DO 70 J=3,NMOM
            XMOM(J)=XMOM(J)/XMOM(2)
   70    CONTINUE
         XMOM(2)=XMOM(2)/DN
         RETURN
      ENDIF
C
C
      RETURN
      END
      SUBROUTINE SAMPWM(X,N,XMOM,NMOM,A,B,KIND)
C===================================================== SAMPWM.FOR
C***********************************************************************
C*                                                                     *
C*  FORTRAN CODE WRITTEN FOR INCLUSION IN IBM RESEARCH REPORT RC20525, *
C*  'FORTRAN ROUTINES FOR USE WITH THE METHOD OF L-MOMENTS, VERSION 3' *
C*                                                                     *
C*  J. R. M. HOSKING                                                   *
C*  IBM RESEARCH DIVISION                                              *
C*  T. J. WATSON RESEARCH CENTER                                       *
C*  YORKTOWN HEIGHTS                                                   *
C*  NEW YORK 10598, U.S.A.                                             *
C*                                                                     *
C*  VERSION 3     AUGUST 1996                                          *
C*                                                                     *
C***********************************************************************
C
C  PROBABILITY WEIGHTED MOMENTS OF A DATA ARRAY
C
C  PARAMETERS OF ROUTINE:
C  X      * INPUT* ARRAY OF LENGTH N. CONTAINS THE DATA, IN ASCENDING
C                  ORDER.
C  N      * INPUT* NUMBER OF DATA VALUES
C  XMOM   *OUTPUT* ARRAY OF LENGTH NMOM. ON EXIT, CONTAINS THE SAMPLE
C                  PROBABILITY WEIGHTED MOMENTS. XMOM(I) CONTAINS
C                  ALPHA-SUB-(I-1) OR BETA-SUB-(I-1).
C  NMOM   * INPUT* NUMBER OF PROBABILITY WEIGHTED MOMENTS TO BE FOUND.
C                  AT MOST MAX(N,20).
C  A      * INPUT* ) PARAMETERS OF PLOTTING
C  B      * INPUT* ) POSITION (SEE BELOW)
C  KIND   * INPUT* SPECIFIES WHICH KIND OF PWM'S ARE TO BE FOUND.
C                  1  ALPHA-SUB-R = E ( X (1-F(X))**R )
C                  2  BETA -SUB-R = E ( X F(X)**R )
C
C  FOR UNBIASED ESTIMATES SET A AND B EQUAL TO ZERO. OTHERWISE,
C  PLOTTING-POSITION ESTIMATORS ARE USED, BASED ON THE PLOTTING POSITION
C  (J+A)/(N+B)  FOR THE J'TH SMALLEST OF N OBSERVATIONS. FOR EXAMPLE,
C  A=-0.35D0 AND B=0.0D0 YIELDS THE ESTIMATORS RECOMMENDED BY
C  HOSKING ET AL. (1985, TECHNOMETRICS) FOR THE GEV DISTRIBUTION.
C
C  MODIFIED 6/2005 FOR INCLUSION INTO DATAPLOT BY ALAN HECKERT.
C  NOTE THAT THE CHANGES WERE ONLY FOR THE I/O, NO CHANGE IN
C  COMPUTATIONAL ASPECTS.
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DOUBLE PRECISION X(N),XMOM(NMOM)
C
      INCLUDE 'DPCOP2.INC'
C
      DATA ZERO/0D0/,ONE/1D0/
      IF(NMOM.GT.20.OR.NMOM.GT.N)THEN
         WRITE(ICOUT,999)
  999    FORMAT(1X)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,7000)
 7000    FORMAT('****** ERROR IN ROUTINE SAMPWM: PARAMETER NMOM ',
     1          '(NUMBER OF MOMENTS) INVALID')
         CALL DPWRST('XXX','BUG ')
      ENDIF
C
      IF(KIND.NE.1.AND.KIND.NE.2)THEN
         WRITE(ICOUT,999)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,7010)
 7010    FORMAT('****** ERROR IN ROUTINE SAMPWM : PARAMETER KIND ',
     1          'INVALID.')
         CALL DPWRST('XXX','BUG ')
         RETURN
      ENDIF
      DO 10 J=1,NMOM
         XMOM(J)=ZERO
   10 CONTINUE
      DN=N
      IF(A.EQ.ZERO.AND.B.EQ.ZERO)THEN
C
C         UNBIASED ESTIMATES OF PWM'S
C
         DO 70 I=1,N
            DI=I
            WEIGHT=ONE/DN
            XMOM(1)=XMOM(1)+WEIGHT*X(I)
            DO 60 J=2,NMOM
               DJ=J-ONE
               IF(KIND.EQ.1)THEN
                  WEIGHT=WEIGHT*(DN-DI-DJ+ONE)/(DN-DJ)
               ELSEIF(KIND.EQ.2)THEN
                  WEIGHT=WEIGHT*(DI-DJ)/(DN-DJ)
               ENDIF
               XMOM(J)=XMOM(J)+WEIGHT*X(I)
   60       CONTINUE
   70    CONTINUE
      ELSE
         IF(A.LE.-ONE.OR.A.GE.B)THEN
            WRITE(ICOUT,999)
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,7020)
 7020       FORMAT('****** ERROR IN ROUTINE SAMPWM:',
     *             ' PLOTTING-POSITION PARAMETERS INVALID')
            CALL DPWRST('XXX','BUG ')
            RETURN
         ENDIF
C
C         PLOTTING-POSITION ESTIMATES OF PWM'S
C
         DO 30 I=1,N
            PPOS=(I+A)/(N+B)
            IF(KIND.EQ.1)PPOS=ONE-PPOS
            TERM=X(I)
            XMOM(1)=XMOM(1)+TERM
            DO 20 J=2,NMOM
               TERM=TERM*PPOS
               XMOM(J)=XMOM(J)+TERM
   20       CONTINUE
   30    CONTINUE
         DO 40 J=1,NMOM
            XMOM(J)=XMOM(J)/DN
   40    CONTINUE
      ENDIF
C
      RETURN
      END
      REAL FUNCTION SASUM(N,SX,INCX)
C***BEGIN PROLOGUE  SASUM
C***DATE WRITTEN   791001   (YYMMDD)
C***REVISION DATE  820801   (YYMMDD)
C***CATEGORY NO.  D1A3A
C***KEYWORDS  ADD,BLAS,LINEAR ALGEBRA,MAGNITUDE,SUM,VECTOR
C***AUTHOR  LAWSON, C. L., (JPL)
C           HANSON, R. J., (SNLA)
C           KINCAID, D. R., (U. OF TEXAS)
C           KROGH, F. T., (JPL)
C***PURPOSE  Sum of magnitudes of s.p vector components
C***DESCRIPTION
C
C                B L A S  Subprogram
C    Description of Parameters
C
C     --Input--
C        N  number of elements in input vector(S)
C       SX  single precision vector with N elements
C     INCX  storage spacing between elements of SX
C
C     --Output--
C    SASUM  single precision result (zero if N .LE. 0)
C
C     Returns sum of magnitudes of single precision SX.
C     SASUM = sum from 0 to N-1 of  ABS(SX(1+I*INCX))
C***REFERENCES  LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T.,
C                 *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*,
C                 ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL
C                 SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323
C***ROUTINES CALLED  (NONE)
C***END PROLOGUE  SASUM
C
      REAL SX(*)
C***FIRST EXECUTABLE STATEMENT  SASUM
      SASUM = 0.0E0
      IF(N.LE.0)RETURN
      IF(INCX.EQ.1)GOTO 20
C
C        CODE FOR INCREMENTS NOT EQUAL TO 1.
C
      NS = N*INCX
          DO 10 I=1,NS,INCX
          SASUM = SASUM + ABS(SX(I))
   10     CONTINUE
      RETURN
C
C        CODE FOR INCREMENTS EQUAL TO 1.
C
C
C        CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 6.
C
   20 M = MOD(N,6)
      IF( M .EQ. 0 ) GO TO 40
      DO 30 I = 1,M
        SASUM = SASUM + ABS(SX(I))
   30 CONTINUE
      IF( N .LT. 6 ) RETURN
   40 MP1 = M + 1
      DO 50 I = MP1,N,6
        SASUM = SASUM + ABS(SX(I)) + ABS(SX(I + 1)) + ABS(SX(I + 2))
     1  + ABS(SX(I + 3)) + ABS(SX(I + 4)) + ABS(SX(I + 5))
   50 CONTINUE
      RETURN
      END
      SUBROUTINE SADMVN( N, LOWER, UPPER, INFIN, CORREL, MAXPTS,
     &                   ABSEPS, RELEPS, ERROR, VALUE, INFORM )
*
*     A subroutine for computing multivariate normal probabilities.
*     This subroutine uses an algorithm given in the paper
*     "Numerical Computation of Multivariate Normal Probabilities", in
*     J. of Computational and Graphical Stat., 1(1992), pp. 141-149, by
*          Alan Genz
*          Department of Mathematics
*          Washington State University
*          Pullman, WA 99164-3113
*          Email : alangenz@wsu.edu
*
*  Parameters
*
*     N      INTEGER, the number of variables.
*     LOWER  REAL, array of lower integration limits.
*     UPPER  REAL, array of upper integration limits.
*     INFIN  INTEGER, array of integration limits flags:
*            if INFIN(I) < 0, Ith limits are (-infinity, infinity);
*            if INFIN(I) = 0, Ith limits are (-infinity, UPPER(I)];
*            if INFIN(I) = 1, Ith limits are [LOWER(I), infinity);
*            if INFIN(I) = 2, Ith limits are [LOWER(I), UPPER(I)].
*     CORREL REAL, array of correlation coefficients; the correlation
*            coefficient in row I column J of the correlation matrix
*            should be stored in CORREL( J + ((I-2)*(I-1))/2 ), for J < I.
*     MAXPTS INTEGER, maximum number of function values allowed. This
*            parameter can be used to limit the time taken. A
*            sensible strategy is to start with MAXPTS = 1000*N, and then
*            increase MAXPTS if ERROR is too large.
*     ABSEPS REAL absolute error tolerance.
*     RELEPS REAL relative error tolerance.
*     ERROR  REAL estimated absolute error, with 99% confidence level.
*     VALUE  REAL estimated value for the integral
*     INFORM INTEGER, termination status parameter:
*            if INFORM = 0, normal completion with ERROR < EPS;
*            if INFORM = 1, completion with ERROR > EPS and MAXPTS
*                           function vaules used; increase MAXPTS to
*                           decrease ERROR;
*            if INFORM = 2, N > 20 or N < 1.
*
      EXTERNAL MVNFNC
      INTEGER N, NL, M, INFIN(*), LENWRK, MAXPTS, INFORM, INFIS,
     &     RULCLS, TOTCLS, NEWCLS, MAXCLS
      DOUBLE PRECISION
     &     CORREL(*), LOWER(*), UPPER(*), ABSEPS, RELEPS, ERROR, VALUE,
     &     OLDVAL, D, E, MVNNIT, MVNFNC
      PARAMETER ( NL = 20 )
      PARAMETER ( LENWRK = 20*NL**2 )
      DOUBLE PRECISION WORK(LENWRK)
      IF ( N .GT. 20 .OR. N .LT. 1 ) THEN
         INFORM = 2
         VALUE = 0
         ERROR = 1
         RETURN
      ENDIF
      INFORM = INT(MVNNIT(N,CORREL,LOWER,UPPER,INFIN,INFIS,D,E))
      M = N - INFIS
      IF ( M .EQ. 0 ) THEN
         VALUE = 1
         ERROR = 0
      ELSE IF ( M .EQ. 1 ) THEN
         VALUE = E - D
         ERROR = 2E-16
      ELSE
*
*        Call the subregion adaptive integration subroutine
*
         M = M - 1
         RULCLS = 1
         CALL ADAPT( M, RULCLS, 0, MVNFNC, ABSEPS, RELEPS,
     &               LENWRK, WORK, ERROR, VALUE, INFORM )
         MAXCLS = MIN( 10*RULCLS, MAXPTS )
         TOTCLS = 0
         CALL ADAPT(M, TOTCLS, MAXCLS, MVNFNC, ABSEPS, RELEPS,
     &        LENWRK, WORK, ERROR, VALUE, INFORM)
         IF ( ERROR .GT. MAX( ABSEPS, RELEPS*ABS(VALUE) ) ) THEN
 10         OLDVAL = VALUE
            MAXCLS = MAX( 2*RULCLS, MIN( 3*MAXCLS/2, MAXPTS - TOTCLS ) )
            NEWCLS = -1
            CALL ADAPT(M, NEWCLS, MAXCLS, MVNFNC, ABSEPS, RELEPS,
     &           LENWRK, WORK, ERROR, VALUE, INFORM)
            TOTCLS = TOTCLS + NEWCLS
            ERROR = ABS(VALUE-OLDVAL) + SQRT(RULCLS*ERROR**2/TOTCLS)
            IF ( ERROR .GT. MAX( ABSEPS, RELEPS*ABS(VALUE) ) ) THEN
               IF ( MAXPTS - TOTCLS .GT. 2*RULCLS ) GO TO 10
            ELSE
               INFORM = 0
            END IF
         ENDIF
      ENDIF
C
      RETURN
      END
      SUBROUTINE SADMVT(N, NU, LOWER, UPPER, INFIN, CORREL, MAXPTS,
     *      ABSEPS, RELEPS, ERROR, VALUE, INFORM)
*
*     A subroutine for computing multivariate t probabilities.
*          Alan Genz
*          Department of Mathematics
*          Washington State University
*          Pullman, WA 99164-3113
*          Email : AlanGenz@wsu.edu
*
*  Parameters
*
*     N      INTEGER, the number of variables.
*     NU     INTEGER, the number of degrees of freedom.
*     LOWER  REAL, array of lower integration limits.
*     UPPER  REAL, array of upper integration limits.
*     INFIN  INTEGER, array of integration limits flags:
*            if INFIN(I) < 0, Ith limits are (-infinity, infinity);
*            if INFIN(I) = 0, Ith limits are (-infinity, UPPER(I)];
*            if INFIN(I) = 1, Ith limits are [LOWER(I), infinity);
*            if INFIN(I) = 2, Ith limits are [LOWER(I), UPPER(I)].
*     CORREL REAL, array of correlation coefficients; the correlation
*            coefficient in row I column J of the correlation matrix
*            should be stored in CORREL( J + ((I-2)*(I-1))/2 ), for J < I.
*     MAXPTS INTEGER, maximum number of function values allowed. This
*            parameter can be used to limit the time taken. A sensible
*            strategy is to start with MAXPTS = 1000*N, and then
*            increase MAXPTS if ERROR is too large.
*     ABSEPS REAL absolute error tolerance.
*     RELEPS REAL relative error tolerance.
*     ERROR  REAL, estimated absolute error, with 99% confidence level.
*     VALUE  REAL, estimated value for the integral
*     INFORM INTEGER, termination status parameter:
*            if INFORM = 0, normal completion with ERROR < EPS;
*            if INFORM = 1, completion with ERROR > EPS and MAXPTS
*                           function vaules used; increase MAXPTS to
*                           decrease ERROR;
*            if INFORM = 2, N > 20 or N < 1.
*
      EXTERNAL FNCMVT
      DOUBLE PRECISION FNCMVT
      INTEGER NL, N, NU, M, INFIN(*), LENWRK, MAXPTS, INFORM, INFIS,
     &     RULCLS, TOTCLS, NEWCLS, MAXCLS
      DOUBLE PRECISION CORREL(*), LOWER(*), UPPER(*), ABSEPS, RELEPS,
     &     ERROR, VALUE, OLDVAL, D, E, MVTNIT
      PARAMETER ( NL = 20 )
      PARAMETER ( LENWRK = 20*NL**2 )
      DOUBLE PRECISION WORK(LENWRK)
      IF ( N .GT. 20 .OR. N .LT. 1 ) THEN
         INFORM = 2
         VALUE = 0.0D0
         ERROR = 1.0D0
         RETURN
      ENDIF
      INFORM = INT(MVTNIT(N,NU,CORREL,LOWER,UPPER,INFIN,INFIS,D,E))
      M = N - INFIS
      IF ( M .EQ. 0 ) THEN
         VALUE = 1.0D0
         ERROR = 0.0D0
      ELSE IF ( M .EQ. 1 ) THEN
         VALUE = E - D
         ERROR = 2E-16
      ELSE
*
*        Call the subregion adaptive integration subroutine
*
         M = M - 1
         RULCLS = 1
         CALL ADAPT( M, RULCLS, 0, FNCMVT, ABSEPS, RELEPS,
     *               LENWRK, WORK, ERROR, VALUE, INFORM )
         MAXCLS = MIN( 10*RULCLS, MAXPTS )
         TOTCLS = 0
         CALL ADAPT( M, TOTCLS, MAXCLS, FNCMVT, ABSEPS, RELEPS,
     *               LENWRK, WORK, ERROR, VALUE, INFORM )
         IF ( ERROR .GT. MAX( ABSEPS, RELEPS*ABS(VALUE) ) ) THEN
 10         OLDVAL = VALUE
            MAXCLS = MAX( 2*RULCLS, MIN( 3*MAXCLS/2, MAXPTS - TOTCLS ) )
            NEWCLS = -1
            CALL ADAPT( M, NEWCLS, MAXCLS, FNCMVT, ABSEPS, RELEPS,
     *                  LENWRK, WORK, ERROR, VALUE, INFORM  )
            TOTCLS = TOTCLS + NEWCLS
            ERROR = ABS(VALUE-OLDVAL) +
     *              SQRT(REAL(RULCLS)*ERROR**2/REAL(TOTCLS))
            IF ( ERROR .GT. MAX( ABSEPS, RELEPS*ABS(VALUE) ) ) THEN
               IF ( MAXPTS - TOTCLS .GT. 2*RULCLS ) GO TO 10
            ELSE
               INFORM = 0
            END IF
         ENDIF
      ENDIF
C
      RETURN
      END
      SUBROUTINE SAXPY(N,SA,SX,INCX,SY,INCY)
C***BEGIN PROLOGUE  SAXPY
C***DATE WRITTEN   791001   (YYMMDD)
C***REVISION DATE  820801   (YYMMDD)
C***CATEGORY NO.  D1A7
C***KEYWORDS  BLAS,LINEAR ALGEBRA,TRIAD,VECTOR
C***AUTHOR  LAWSON, C. L., (JPL)
C           HANSON, R. J., (SNLA)
C           KINCAID, D. R., (U. OF TEXAS)
C           KROGH, F. T., (JPL)
C***PURPOSE  S.P. computation y = a*x + y
C***DESCRIPTION
C
C                B L A S  Subprogram
C    Description of Parameters
C
C     --Input--
C        N  number of elements in input vector(s)
C       SA  single precision scalar multiplier
C       SX  single precision vector with N elements
C     INCX  storage spacing between elements of SX
C       SY  single precision vector with N elements
C     INCY  storage spacing between elements of SY
C
C     --Output--
C       SY  single precision result (unchanged if N .LE. 0)
C
C     Overwrite single precision SY with single precision SA*SX +SY.
C     For I = 0 to N-1, replace  SY(LY+I*INCY) with SA*SX(LX+I*INCX) +
C       SY(LY+I*INCY), where LX = 1 if INCX .GE. 0, else LX = (-INCX)*N
C       and LY is defined in a similar way using INCY.
C***REFERENCES  LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T.,
C                 *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*,
C                 ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL
C                 SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323
C***ROUTINES CALLED  (NONE)
C***END PROLOGUE  SAXPY
C
      REAL SX(*),SY(*),SA
C***FIRST EXECUTABLE STATEMENT  SAXPY
      IF(N.LE.0.OR.SA.EQ.0.E0) RETURN
C
CCCCC JULY 2008: MODIFY FOLLOWING LINE SO THAT IT
CCCCC            DOES NOT GENERATE WARNING MESSAGE
CCCCC            FOR FORTRAN 95 COMPILER.
C
CCCCC IF(INCX.EQ.INCY) IF(INCX-1) 5,20,60
      IF(INCX.EQ.INCY) THEN
        IF(INCX-1.EQ.0)THEN
          GOTO20
        ELSEIF(INCX-1.GT.0)THEN
          GOTO60
        ELSE
          GOTO5
        ENDIF
      ENDIF
    5 CONTINUE
C
C        CODE FOR NONEQUAL OR NONPOSITIVE INCREMENTS.
C
      IX = 1
      IY = 1
      IF(INCX.LT.0)IX = (-N+1)*INCX + 1
      IF(INCY.LT.0)IY = (-N+1)*INCY + 1
      DO 10 I = 1,N
        SY(IY) = SY(IY) + SA*SX(IX)
        IX = IX + INCX
        IY = IY + INCY
   10 CONTINUE
      RETURN
C
C        CODE FOR BOTH INCREMENTS EQUAL TO 1
C
C
C        CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 4.
C
   20 M = MOD(N,4)
      IF( M .EQ. 0 ) GO TO 40
      DO 30 I = 1,M
        SY(I) = SY(I) + SA*SX(I)
   30 CONTINUE
      IF( N .LT. 4 ) RETURN
   40 MP1 = M + 1
      DO 50 I = MP1,N,4
        SY(I) = SY(I) + SA*SX(I)
        SY(I + 1) = SY(I + 1) + SA*SX(I + 1)
        SY(I + 2) = SY(I + 2) + SA*SX(I + 2)
        SY(I + 3) = SY(I + 3) + SA*SX(I + 3)
   50 CONTINUE
      RETURN
C
C        CODE FOR EQUAL, POSITIVE, NONUNIT INCREMENTS.
C
   60 CONTINUE
      NS = N*INCX
          DO 70 I=1,NS,INCX
          SY(I) = SA*SX(I) + SY(I)
   70     CONTINUE
      RETURN
      END
      SUBROUTINE SBFIT(XBAR, SIGMA, RTB1, B2, GAMMA, DELTA, XLAM,
     $  XI, FAULT)
C
C        ALGORITHM AS 99.2  APPL. STATIST. (1976) VOL.25, P.180
C
C        FINDS PARAMETERS OF JOHNSON SB CURVE WITH
C        GIVEN FIRST FOUR MOMENTS
C
      REAL HMU(6), DERIV(4), DD(4), XBAR, SIGMA, RTB1, B2, GAMMA,
     $  DELTA, XLAM, XI, TT, TOL, RB1, B1, E, U, X, Y, W, F, D,
     $  G, S, H2, T, H2A, H2B, H3, H4, RBET, BET2, ZERO, ONE,
     $  TWO, THREE, FOUR, SIX, HALF, QUART, ONE5, A1, A2, A3,
     $  A4, A5, A6, A7, A8, A9, A10, A11, A12, A13, A14, A15,
     $  A16, A17, A18, A19, A20, A21, A22, ZABS, ZLOG, ZSQRT
      LOGICAL NEG, FAULT
C
      DATA TT, TOL, LIMIT /1.0E-4, 0.01, 50/
      DATA ZERO, ONE, TWO, THREE, FOUR, SIX, HALF, QUART, ONE5
     $     /0.0, 1.0, 2.0,   3.0,  4.0, 6.0,  0.5,  0.25,  1.5/
      DATA     A1,     A2,     A3,     A4,     A5,     A6,
     $         A7,     A8,     A9,    A10,    A11,    A12,
     $        A13,    A14,    A15,    A16,    A17,    A18,
     $        A19,    A20,    A21,    A22
     $    /0.0124, 0.0623, 0.4043,  0.408,  0.479,  0.485,
     $     0.5291, 0.5955,  0.626,   0.64, 0.7077, 0.7466,
     $        0.8, 0.9281, 1.0614,   1.25, 1.7973,    1.8,
     $      2.163,    2.5, 8.5245, 11.346/
C
      ZABS(X) = ABS(X)
      ZLOG(X) = LOG(X)
      ZSQRT(X) = SQRT(X)
C
      RB1 = ZABS(RTB1)
      B1 = RB1 * RB1
      NEG = RTB1 .LT. ZERO
C
C        GET D AS FIRST ESTIMATE OF DELTA
C
      E = B1 + ONE
      X = HALF * B1 + ONE
      Y = ZABS(RB1) * ZSQRT(QUART * B1 + ONE)
      U = (X + Y) ** (ONE / THREE)
      W = U + ONE / U - ONE
      F = W * W * (THREE + W * (TWO + W)) - THREE
      E = (B2 - E) / (F - E)
      IF (ZABS(RB1) .GT. TOL) GOTO 5
      F = TWO
      GOTO 20
    5 D = ONE / ZSQRT(ZLOG(W))
      IF (D .LT. A10) GOTO 10
      F = TWO - A21 / (D * (D * (D - A19) + A22))
      GOTO 20
   10 F = A16 * D
   20 F = E * F + ONE
      IF (F .LT. A18) GOTO 25
      D = (A9 * F - A4) * (THREE - F) ** (-A5)
      GOTO 30
   25 D = A13 * (F - ONE)
C
C        GET G AS FIRST ESTIMATE OF GAMMA
C
   30 G = ZERO
      IF (B1 .LT. TT) GOTO 70
      IF (D .GT. ONE) GOTO 40
      G = (A12 * D ** A17 + A8) * B1 ** A6
      GOTO 70
   40 IF (D .LE. A20) GOTO 50
      U = A1
      Y = A7
      GOTO 60
   50 U = A2
      Y = A3
   60 G = B1 ** (U * D + Y) * (A14 + D * (A15 * D - A11))
   70 M = 0
C
C        MAIN ITERATION STARTS HERE
C
   80 M = M + 1
      FAULT = M .GT. LIMIT
      IF (FAULT) RETURN
C
C        GET FIRST SIX MOMENTS FOR LATEST G AND D VALUES
C
      CALL MOM(G, D, HMU, FAULT)
      IF (FAULT) RETURN
      S = HMU(1) * HMU(1)
      H2 = HMU(2) - S
      FAULT = H2 .LE. ZERO
      IF (FAULT) RETURN
      T = ZSQRT(H2)
      H2A = T * H2
      H2B = H2 * H2
      H3 = HMU(3) - HMU(1) * (THREE * HMU(2) - TWO * S)
      RBET = H3 / H2A
      H4 = HMU(4) - HMU(1) * (FOUR * HMU(3) - HMU(1) *
     $  (SIX * HMU(2) - THREE * S))
      BET2 = H4 / H2B
      W = G * D
      U = D * D
C
C        GET DERIVATIVES
C
      DO 120 J = 1, 2
      DO 110 K = 1, 4
      T = K
      IF (J .EQ. 1) GOTO 90
      S = ((W - T) * (HMU(K) - HMU(K + 1)) + (T + ONE) *
     $  (HMU(K + 1) - HMU(K + 2))) / U
      GOTO 100
   90 S = HMU(K + 1) - HMU(K)
  100 DD(K) = T * S / D
  110 CONTINUE
      T = TWO * HMU(1) * DD(1)
      S = HMU(1) * DD(2)
      Y = DD(2) - T
      DERIV(J) = (DD(3) - THREE * (S + HMU(2) * DD(1) - T * HMU(1))
     $  - ONE5 * H3 * Y / H2) / H2A
      DERIV(J + 2) = (DD(4) - FOUR * (DD(3) * HMU(1) + DD(1) * HMU(3))
     $  + SIX * (HMU(2) * T + HMU(1) * (S - T * HMU(1)))
     $  - TWO * H4 * Y / H2) / H2B
  120 CONTINUE
      T = ONE / (DERIV(1) * DERIV(4) - DERIV(2) * DERIV(3))
      U = (DERIV(4) * (RBET - RB1) - DERIV(2) * (BET2 - B2)) * T
      Y = (DERIV(1) * (BET2 - B2) - DERIV(3) * (RBET - RB1)) * T
C
C        FORM NEW ESTIMATES OF G AND D
C
      G = G - U
      IF (B1 .EQ. ZERO .OR. G .LT. ZERO) G = ZERO
      D = D - Y
      IF (ZABS(U) .GT. TT .OR. ZABS(Y) .GT. TT) GOTO 80
C
C        END OF ITERATION
C
      DELTA = D
      XLAM = SIGMA / ZSQRT(H2)
      IF (NEG) GOTO 130
      GAMMA = G
      GOTO 140
  130 GAMMA = -G
      HMU(1) = ONE - HMU(1)
  140 XI = XBAR - XLAM * HMU(1)
      RETURN
      END
      SUBROUTINE SCATTI(N,A,IINDEX,B,NOUT,MAXOBV,ISUBRO,IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE DISPERSES VALUES FROM CONTIGUOUS
C              ELEMENTS IN ARRAY B AND STORES THEM IN ARRAY A
C              WHERE THE STORAGE LOCATIONS ARE DEFINED BY THE
C              ARRAY IINDEX.
C
C              THIS IS EQUIVALENT TO SCATTR ROUTINE EXCEPT THAT THE
C              A AND B ARRAYS ARE INTEGERS IN THIS ROUTINE.
C
C     INPUT  ARGUMENTS--IINDEX = THE INTEGER VECTOR THAT SPECIFIES
C                                THE ELEMENTS OF B THAT WILL BE
C                                EXTRACTED.
C                       B      = A SINGLE PRECISION VECTOR FROM WHIC
C                                DATA VALUES WILL BE EXTRACTED.
C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
C                                TO BE EXTRACTED.
C     OUTPUT ARGUMENTS--A      = THE OUTPUT ARRAY THAT WILL CONTAIN
C                                N ELEMENTS.
C                       NOUT   = THE INTEGER SCALAR THAT SPECIFIES THE
C                                MAXIMUM INDEX VALUE.
C     OUTPUT--THE COMPUTED SINGLE PRECISION ARRAY A.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     WRITTEN BY--ALAN HECKERT
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2899
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2011.8
C     ORIGINAL VERSION--AUGUST    2011.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C
      INTEGER N
      INTEGER IINDEX(*)
      INTEGER A(*)
      INTEGER B(*)
C
      CHARACTER*4 ISUBRO
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'THER')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,51)
   51   FORMAT('***** AT THE BEGINNING OF GATHER--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,52)IBUGA3,ISUBRO,N
   52   FORMAT('IBUGA3,ISUBRO,N = ',A4,2X,A4,2X,I8)
        CALL DPWRST('XXX','BUG ')
        IF(N.GT.0)THEN
          DO55I=1,N
            WRITE(ICOUT,56)I,IINDEX(I),B(I)
   56       FORMAT('I,IINDX(I),B(I) = ',I8,2X,2I8)
            CALL DPWRST('XXX','BUG ')
   55     CONTINUE
        ENDIF
      ENDIF
C
      NOUT=-99
      DO 1010 I = 1,N
         ITEMP=IINDEX(I)
         IF(ITEMP.GE.1 .AND. ITEMP.LE.MAXOBV)THEN
           A(ITEMP) = B(I)
           IF(ITEMP.GT.NOUT) NOUT=ITEMP
         ELSE
           WRITE(ICOUT,1011)
 1011      FORMAT('***** ERROR IN SCATTER OPERATION--')
           CALL DPWRST('XXX','BUG ')
           WRITE(ICOUT,1013)I
 1013      FORMAT('      FOR ROW ',I8,' THE INDEX VALUE IS OUTSIDE THE')
           CALL DPWRST('XXX','BUG ')
           WRITE(ICOUT,1015)MAXOBV
 1015      FORMAT('      THE INTERVAL (1,',I10,').')
           CALL DPWRST('XXX','BUG ')
           IERROR='YES'
           GOTO9000
         ENDIF
 1010 CONTINUE
C
 9000 CONTINUE
C
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'THER')THEN
        WRITE(ICOUT,9051)
 9051   FORMAT('***** AT THE END OF SCATTER--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9053)NOUT
 9053   FORMAT('NOUT = ',I8)
        CALL DPWRST('XXX','BUG ')
        IF(NOUT.GT.0)THEN
          DO9055I=1,NOUT
            WRITE(ICOUT,9056)I,A(I)
 9056       FORMAT('I,A(I) = ',2I8)
            CALL DPWRST('XXX','BUG ')
 9055     CONTINUE
        ENDIF
      ENDIF
C
      RETURN
      END
      SUBROUTINE SCATTR(N,A,IINDEX,B,NOUT,MAXOBV,ISUBRO,IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE DISPERSES VALUES FROM CONTIGUOUS
C              ELEMENTS IN ARRAY B AND STORES THEM IN ARRAY A
C              WHERE THE STORAGE LOCATIONS ARE DEFINED BY THE
C              ARRAY IINDEX.
C     INPUT  ARGUMENTS--IINDEX = THE INTEGER VECTOR THAT SPECIFIES
C                                THE ELEMENTS OF B THAT WILL BE
C                                EXTRACTED.
C                       B      = A SINGLE PRECISION VECTOR FROM WHIC
C                                DATA VALUES WILL BE EXTRACTED.
C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
C                                TO BE EXTRACTED.
C     OUTPUT ARGUMENTS--A      = THE OUTPUT ARRAY THAT WILL CONTAIN
C                                N ELEMENTS.
C                       NOUT   = THE INTEGER SCALAR THAT SPECIFIES THE
C                                MAXIMUM INDEX VALUE.
C     OUTPUT--THE COMPUTED SINGLE PRECISION ARRAY A.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     WRITTEN BY--ALAN HECKERT
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2899
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2008.11
C     ORIGINAL VERSION--NOVEMBER  2008.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C
      INTEGER N
      INTEGER IINDEX(*)
      REAL A(*)
      REAL B(*)
C
      CHARACTER*4 ISUBRO
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'THER')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,51)
   51   FORMAT('***** AT THE BEGINNING OF GATHER--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,52)IBUGA3,ISUBRO,N
   52   FORMAT('IBUGA3,ISUBRO,N = ',A4,2X,A4,2X,I8)
        CALL DPWRST('XXX','BUG ')
        IF(N.GT.0)THEN
          DO55I=1,N
            WRITE(ICOUT,56)I,IINDEX(I),B(I)
   56       FORMAT('I,IINDX(I),B(I) = ',I8,2X,I8,G15.7)
            CALL DPWRST('XXX','BUG ')
   55     CONTINUE
        ENDIF
      ENDIF
C
      NOUT=-99
      DO 1010 I = 1,N
         ITEMP=IINDEX(I)
         IF(ITEMP.GE.1 .AND. ITEMP.LE.MAXOBV)THEN
           A(ITEMP) = B(I)
           IF(ITEMP.GT.NOUT) NOUT=ITEMP
         ELSE
           WRITE(ICOUT,1011)
 1011      FORMAT('***** ERROR IN SCATTER OPERATION--')
           CALL DPWRST('XXX','BUG ')
           WRITE(ICOUT,1013)I
 1013      FORMAT('      FOR ROW ',I8,' THE INDEX VALUE IS OUTSIDE THE')
           CALL DPWRST('XXX','BUG ')
           WRITE(ICOUT,1015)MAXOBV
 1015      FORMAT('      THE INTERVAL (1,',I10,').')
           CALL DPWRST('XXX','BUG ')
           IERROR='YES'
           GOTO9000
         ENDIF
 1010 CONTINUE
C
 9000 CONTINUE
C
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'THER')THEN
        WRITE(ICOUT,9051)
 9051   FORMAT('***** AT THE END OF SCATTER--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9053)NOUT
 9053   FORMAT('NOUT = ',I8)
        CALL DPWRST('XXX','BUG ')
        IF(NOUT.GT.0)THEN
          DO9055I=1,NOUT
            WRITE(ICOUT,9056)I,A(I)
 9056       FORMAT('I,A(I) = ',I8,2X,G15.7)
            CALL DPWRST('XXX','BUG ')
 9055     CONTINUE
        ENDIF
      ENDIF
C
      RETURN
      END
      SUBROUTINE SCLMUL(N,S,V,Z)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C PURPOSE
C -------
C MULTIPLY VECTOR BY SCALAR
C RESULT VECTOR MAY BE OPERAND VECTOR
C
C PARAMETERS
C ----------
C N            --> DIMENSION OF VECTORS
C S            --> SCALAR
C V(N)         --> OPERAND VECTOR
C Z(N)        <--  RESULT VECTOR
      DIMENSION V(N),Z(N)
      DO 100 I=1,N
        Z(I)=S*V(I)
  100 CONTINUE
      RETURN
      END
      SUBROUTINE SCOPY(N,SX,INCX,SY,INCY)
C***BEGIN PROLOGUE  SCOPY
C***DATE WRITTEN   791001   (YYMMDD)
C***REVISION DATE  820801   (YYMMDD)
C***CATEGORY NO.  D1A5
C***KEYWORDS  BLAS,COPY,LINEAR ALGEBRA,VECTOR
C***AUTHOR  LAWSON, C. L., (JPL)
C           HANSON, R. J., (SNLA)
C           KINCAID, D. R., (U. OF TEXAS)
C           KROGH, F. T., (JPL)
C***PURPOSE  Copy s.p. vector y = x
C***DESCRIPTION
C
C                B L A S  Subprogram
C    Description of Parameters
C
C     --Input--
C        N  number of elements in input vector(s)
C       SX  single precision vector with N elements
C     INCX  storage spacing between elements of SX
C       SY  single precision vector with N elements
C     INCY  storage spacing between elements of SY
C
C     --Output--
C       SY  copy of vector SX (unchanged if N .LE. 0)
C
C     Copy single precision SX to single precision SY.
C     For I = 0 to N-1, copy  SX(LX+I*INCX) to SY(LY+I*INCY),
C     where LX = 1 if INCX .GE. 0, else LX = (-INCX)*N, and LY is
C     defined in a similar way using INCY.
C***REFERENCES  LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T.,
C                 *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*,
C                 ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL
C                 SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323
C***ROUTINES CALLED  (NONE)
C***END PROLOGUE  SCOPY
C
      REAL SX(1),SY(1)
C***FIRST EXECUTABLE STATEMENT  SCOPY
      IF(N.LE.0)RETURN
C
CCCCC JUNE 2008: MODIFY FOLLOWING LINE SO THAT IT DOES NOT
CCCCC            GENERATE WARNING MESSAGE ON FORTRAN 95 COMPILERS.
C
CCCCC IF(INCX.EQ.INCY) IF(INCX-1) 5,20,60
      IF(INCX.EQ.INCY) THEN
        IF(INCX-1.LT.0)THEN
          GOTO5
        ELSEIF(INCX-1.EQ.0)THEN
          GOTO20
        ELSE
          GOTO60
        ENDIF
      ENDIF
    5 CONTINUE
C
C        CODE FOR UNEQUAL OR NONPOSITIVE INCREMENTS.
C
      IX = 1
      IY = 1
      IF(INCX.LT.0)IX = (-N+1)*INCX + 1
      IF(INCY.LT.0)IY = (-N+1)*INCY + 1
      DO 10 I = 1,N
        SY(IY) = SX(IX)
        IX = IX + INCX
        IY = IY + INCY
   10 CONTINUE
      RETURN
C
C        CODE FOR BOTH INCREMENTS EQUAL TO 1
C
C
C        CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 7.
C
   20 M = MOD(N,7)
      IF( M .EQ. 0 ) GO TO 40
      DO 30 I = 1,M
        SY(I) = SX(I)
   30 CONTINUE
      IF( N .LT. 7 ) RETURN
   40 MP1 = M + 1
      DO 50 I = MP1,N,7
        SY(I) = SX(I)
        SY(I + 1) = SX(I + 1)
        SY(I + 2) = SX(I + 2)
        SY(I + 3) = SX(I + 3)
        SY(I + 4) = SX(I + 4)
        SY(I + 5) = SX(I + 5)
        SY(I + 6) = SX(I + 6)
   50 CONTINUE
      RETURN
C
C        CODE FOR EQUAL, POSITIVE, NONUNIT INCREMENTS.
C
   60 CONTINUE
      NS = N*INCX
          DO 70 I=1,NS,INCX
          SY(I) = SX(I)
   70     CONTINUE
      RETURN
      END
      SUBROUTINE SCOPYM(N,SX,INCX,SY,INCY)
C***BEGIN PROLOGUE  SCOPYM
C***DATE WRITTEN   801001   (YYMMDD)
C***REVISION DATE  820801   (YYMMDD)
C***CATEGORY NO.  D1A5
C***KEYWORDS  BLAS,COPY,VECTOR
C***AUTHOR  KAHANER,DAVID(NBS)
C***PURPOSE  Copy negative of real SX to real SY.
C***DESCRIPTION
C
C       Description of Parameters
C           The * Flags Output Variables
C
C       N   Number of elements in vector(s)
C      SX   Real vector with N elements
C    INCX   Storage spacing between elements of SX
C      SY*  Real negative copy of SX
C    INCY   Storage spacing between elements of SY
C
C      ***  Note that SY = -SX  ***
C
C  Copy negative of real SX to real SY.  For I=0 to N-1,
C   copy  -SX(LX+I*INCX) to SY(LY+I*INCY), where LX=1 if
C   INCX .GE. 0, else LX = (-INCX)*N, and LY is defined
C   in a similar way using INCY.
C***REFERENCES  (NONE)
C***ROUTINES CALLED  (NONE)
C***END PROLOGUE  SCOPYM
      REAL SX(1),SY(1)
C***FIRST EXECUTABLE STATEMENT  SCOPYM
      IF(N.LE.0) RETURN
C
CCCCC JUNE 2008: MODIFY FOLLOWING LINE SO THAT IT DOES NOT
CCCCC            GENERATE WARNING MESSAGE ON FORTRAN 95 COMPILERS.
C
CCCCC IF(INCX.EQ.INCY) IF(INCX-1) 5,20,60
      IF(INCX.EQ.INCY) THEN
        IF(INCX-1.LT.0)THEN
          GOTO5
        ELSEIF(INCX-1.EQ.0)THEN
          GOTO20
        ELSE
          GOTO60
        ENDIF
      ENDIF
    5 CONTINUE
C
C         CODE FOR UNEQUAL OR NONPOSITIVE INCREMENTS
C
      IX=1
      IY=1
      IF(INCX.LT.0)IX = (-N+1)*INCX + 1
      IF(INCY.LT.0)IY = (-N+1)*INCY + 1
      DO 10 I=1,N
        SY(IY) = -SX(IX)
        IX = IX + INCX
        IY = IY + INCY
   10 CONTINUE
      RETURN
C
C        CODE FOR BOTH INCREMENTS EQUAL TO 1
C
C
C        CLEAN UP LOOP SO REMAINING VECTOR LENGTH IS MULTIPLE OF 7
C
   20 M = MOD(N,7)
      IF( M .EQ. 0 ) GO TO 40
      DO 30 I=1,M
        SY(I) = -SX(I)
   30 CONTINUE
      IF( N .LT. 7 ) RETURN
   40 MP1 = M + 1
      DO 50 I= MP1,N,7
        SY(I) = -SX(I)
        SY(I + 1) = -SX(I + 1)
        SY(I + 2) = -SX(I + 2)
        SY(I + 3) = -SX(I + 3)
        SY(I + 4) = -SX(I + 4)
        SY(I + 5) = -SX(I + 5)
        SY(I + 6) = -SX(I + 6)
   50 CONTINUE
      RETURN
C
C          CODE FOR EQUAL, POSITIVE, NONUNIT INCREMENTS
C
   60 CONTINUE
      NS = N*INCX
          DO 70 I=1,NS,INCX
          SY(I) = -SX(I)
   70     CONTINUE
      RETURN
      END
      subroutine scrag(xreal, n, ipow)
c
c       Algorithm AS 83.3 Appl. Statist. (1975) vol.24, no.1
c ***   MODIFIED FOR USE WITH AS 97 ***
c
c       Subroutine for unscrambling FFT data.
c
      implicit double precision (A-H, O-Z)
      double precision  xreal(n)
      integer l(19)
      equivalence (l1,l(1)), (l2,l(2)), (l3,l(3)), (l4,l(4)),
     +          (l5,l(5)), (l6,l(6)), (l7,l(7)), (l8,l(8)), (l9,l(9)),
     +          (l10,l(10)), (l11,l(11)), (l12,l(12)), (l13,l(13)),
     +          (l14,l(14)), (l15,l(15)), (l16,l(16)), (l17,l(17)),
     +          (l18,l(18)), (l19,l(19))
c
      ii = 1
      itop = 2 ** (ipow - 1)
      i = 20 - ipow
      do 5 k = 1, i
        l(k) = ii
    5 continue
      l0 = ii
      i = i + 1
      do 6 k = i, 19
        ii = ii * 2
        l(k) = ii
    6 continue
c
      ii = 0
      do 30 j1 = 1, l1, l0
        do 29 j2 = j1, l2, l1
          do 28 j3 = j2, l3, l2
            do 27 j4 = j3, l4, l3
            do 26 j5 = j4, l5, l4
              do 25 j6 = j5, l6, l5
                do 24 j7 = j6, l7, l6
                  do 23 j8 = j7, l8, l7
                  do 22 j9 = j8, l9, l8
                    do 21 j10 = j9, l10, l9
                      do 20 j11 = j10, l11, l10
                        do 19 j12 = j11, l12, l11
                        do 18 j13 = j12, l13, l12
                          do 17 j14 = j13, l14, l13
                            do 16 j15 = j14, l15, l14
                              do 15 j16 = j15, l16, l15
                              do 14 j17 = j16, l17, l16
                                do 13 j18 = j17, l18, l17
                                  do 12 j19 = j18, l19, l18
                                    j20 = j19
                                    do 11 i = 1, 2
                                      ii = ii + 1
                                      if (ii .lt. j20) then
c
c                                       J20 is the bit-reverse of
c                                       II pairwise interchange.
c
                                        tempr = xreal(ii)
                                        xreal(ii) = xreal(j20)
                                        xreal(j20) = tempr
                                      end if
                                      j20 = j20 + itop
   11                               continue
   12                             continue
   13                           continue
   14                         continue
   15                         continue
   16                       continue
   17                     continue
   18                   continue
   19                   continue
   20                 continue
   21               continue
   22             continue
   23             continue
   24           continue
   25         continue
   26       continue
   27       continue
   28     continue
   29   continue
   30 continue
c
      return
      end
      SUBROUTINE SCRUDE( NDIM, MAXPTS, ABSEST, FINEST, IR )
*
*     Crude Monte-Carlo Algorithm for Deak method with
*      weighted results on restart
*
CCCCC INTEGER NDIM, MAXPTS, M, K, IR, NPTS
      INTEGER NDIM, MAXPTS, M, IR
      DOUBLE PRECISION FINEST, ABSEST, SPNRML,
     &     VARSQR, VAREST, VARPRD, FINDIF, FINVAL
      SAVE VAREST
      IF ( IR .LE. 0 ) THEN
         VAREST = 0
         FINEST = 0
      ENDIF
      FINVAL = 0
      VARSQR = 0
      DO 100 M = 1,MAXPTS
         FINDIF = ( SPNRML(NDIM) - FINVAL )/DBLE(M)
         FINVAL = FINVAL + FINDIF
         VARSQR = DBLE( M - 2 )*VARSQR/DBLE(M) + FINDIF**2
 100  CONTINUE
      VARPRD = VAREST*VARSQR
      FINEST = FINEST + ( FINVAL - FINEST )/(1.0D0 + VARPRD)
      IF ( VARSQR .GT. 0.0D0 ) VAREST = (1.0D0 + VARPRD)/VARSQR
      ABSEST = 3.0D0*SQRT( VARSQR/( 1.0D0 + VARPRD ) )
C
      RETURN
      END
      SUBROUTINE SD(X,N,IWRITE,XSD,IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE SAMPLE STANDARD DEVIATION
C              (WITH DENOMINATOR N-1) OF THE DATA IN THE INPUT VECTOR X.
C              THE SAMPLE STANDARD DEVIATION = SQRT((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--XSD    = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED SAMPLE STANDARD DEVIATION.
C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
C             SAMPLE STANDARD DEVIATION (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--DSQRT.
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, PAGES 19, 76.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1966)
C     VERSION NUMBER--82.6
C     ORIGINAL VERSION--JUNE      1972.
C     UPDATED         --SEPTEMBER 1975.
C     UPDATED         --NOVEMBER  1975.
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
      DOUBLE PRECISION DSD
C
      DIMENSION X(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='SD  '
      ISUBN2='    '
      IERROR='NO'
C
      XSD=0.0
      DMEAN=0.0D0
      AN=N
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 SD--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,52)IBUGA3,N
   52   FORMAT('IBUGA3,N = ',A4,2X,I8)
        CALL DPWRST('XXX','BUG ')
        DO55I=1,N
          WRITE(ICOUT,56)I,X(I)
   56     FORMAT('I,X(I) = ',I8,G15.7)
          CALL DPWRST('XXX','BUG ')
   55   CONTINUE
      ENDIF
C
C               **********************************
C               **  COMPUTE STANDARD DEVIATION  **
C               **********************************
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      IF(N.LT.1)THEN
        IERROR='YES'
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,111)
  111   FORMAT('***** ERROR IN SD--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,112)
  112   FORMAT('      THE NUMBER OF OBSERVATIONS FOR THE RESPONSE')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,115)
  115   FORMAT('      VARIABLE IS LESS THAN 1.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,117)N
  117   FORMAT('      THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8,'.')
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(N.EQ.1)THEN
        GOTO800
      ENDIF
C
      HOLD=X(1)
      DO135I=2,N
        IF(X(I).NE.HOLD)GOTO139
  135 CONTINUE
      GOTO800
  139 CONTINUE
C
C               ***************************************
C               **  STEP 2--                         **
C               **  COMPUTE THE STANDARD DEVIATION.  **
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)
      DSD=0.0D0
      IF(DVAR.GT.0.0D0)DSD=DSQRT(DVAR)
      XSD=DSD
C
C               *******************************
C               **  STEP 3--                 **
C               **  WRITE OUT A LINE         **
C               **  OF SUMMARY INFORMATION.  **
C               *******************************
C
  800 CONTINUE
      IF(IFEEDB.EQ.'ON' .AND. IWRITE.EQ.'ON')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,811)N,XSD
  811   FORMAT('THE STANDARD DEVIATION OF THE ',I8,' OBSERVATIONS = ',
     1         E15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'ON')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END       OF SD--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9012)IERROR,DMEAN,XSD
 9012   FORMAT('IERROR,DMEAN,XSD = ',A4,2X,2G15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      RETURN
      END
      SUBROUTINE SDDP(X,N,IWRITE,XSD,IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE
C              SAMPLE STANDARD DEVIATION (WITH DENOMINATOR N-1)
C              OF THE DATA IN THE INPUT VECTOR X.
C              THE SAMPLE STANDARD DEVIATION = SQRT((THE SUM OF THE
C              SQUARED DEVIATIONS ABOUT THE SAMPLE MEAN)/(N-1)).
C            --THIS IS A DOUBLE PRECISION VERSION OF
C              THE SD SUBROUTINE.
C     INPUT  ARGUMENTS--X      = THE DOUBLE PRECISION VECTOR OF
C                                (UNSORTED OR SORTED) OBSERVATIONS.
C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR X.
C     OUTPUT ARGUMENTS--XSD    = THE DOUBLE PRECISION VALUE OF THE
C                                COMPUTED SAMPLE STANDARD DEVIATION.
C     OUTPUT--THE COMPUTED DOUBLE PRECISION VALUE OF THE
C             SAMPLE STANDARD DEVIATION (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--DSQRT.
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, PAGES 19, 76.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2006.4
C     ORIGINAL VERSION--APRIL     2006.
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
      DOUBLE PRECISION DSD
      DOUBLE PRECISION XSD
      DOUBLE PRECISION HOLD
C
      DOUBLE PRECISION X(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='SDDP'
      ISUBN2='    '
      IERROR='NO'
C
      DMEAN=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 SD--')
      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,G15.7)
      CALL DPWRST('XXX','BUG ')
   55 CONTINUE
   90 CONTINUE
C
C               **********************************
C               **  COMPUTE STANDARD DEVIATION  **
C               **********************************
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      DN=N
C
      IF(N.GE.1)GOTO119
      IERROR='YES'
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,111)
  111 FORMAT('***** ERROR IN SDDP--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,112)
  112 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS IN THE VARIABLE')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,114)
  114 FORMAT('      FOR WHICH THE 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 ')
      GOTO9000
  119 CONTINUE
C
      IF(N.EQ.1)THEN
        XSD=0.0D0
        GOTO9000
      ENDIF
C
      HOLD=X(1)
      DO135I=2,N
      IF(X(I).NE.HOLD)GOTO139
  135 CONTINUE
      XSD=0.0D0
      GOTO9000
  139 CONTINUE
C
C               ***************************************
C               **  STEP 2--                         **
C               **  COMPUTE THE STANDARD DEVIATION.  **
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)
      DSD=0.0D0
      IF(DVAR.GT.0.0D0)DSD=DSQRT(DVAR)
      XSD=DSD
C
C               *******************************
C               **  STEP 3--                 **
C               **  WRITE OUT A LINE         **
C               **  OF SUMMARY INFORMATION.  **
C               *******************************
C
      IF(IFEEDB.EQ.'OFF')GOTO890
      IF(IWRITE.EQ.'OFF')GOTO890
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,811)N,XSD
  811 FORMAT('THE STANDARD DEVIATION 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 SDDP--')
      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)XSD
 9015 FORMAT('XSD = ',E15.7)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE SDECDF(X,ALMBDA,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE SKEW-LAPLACE DISTRIBUTION
C              (OR SKEW-DOUBLE EXPONENTIAL)
C              WITH SHAPE PARAMETER = LAMBDA.
C              THIS DISTRIBUTION IS DEFINED FOR ALL X AND HAS
C              THE CUMULATIVE DISTRIBUTION FUNCTION
C                 SDECDF(X,LAMBDA) = 0.5*EXP((1+LAMBDA)*X)/(1+LAMMBDA)
C                                                          X <= 0
C                                  = 1 + (1)*EXP(-X) -
C                                    0.5/(EXP((1+LAMBDA)*X)*(-1-LAMBDA))
C                                                          X > 0
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C                     --ALMBDA = THE SHAPE PARAMETER
C     OUTPUT ARGUMENTS--CDF    = THE SINGLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE CDF FOR THE SKEWED-LAPLACE DISTRIBUTION
C             WITH SHAPE PARAMETER = LAMBDA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--EXP.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--KOTZ, KOZUBOWSKI, AND PODGORSKI, "THE LAPLACE
C                 DISTRIBUTION AND GENERALIZATIONS: A REVISIT WITH
C                 APPLICATIONS TO COMMUNICATIONS, ECONOMICS,
C                 ENGINEERING, AND FINANCE", BIRKHAUSR, 2001,
C                 PP. 134.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004.6
C     ORIGINAL VERSION--JUNE      2004.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DLMBDA
      DOUBLE PRECISION DCDF
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C               ************************************
C               **  STEP 1--                      **
C               **  COMPUTE THE DENSITY FUNCTION  **
C               ************************************
C
      IF(ALMBDA.LT.0.0)THEN
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,48)ALMBDA
        CALL DPWRST('XXX','WRIT')
        CDF=0.0
        GOTO9000
      ENDIF
    5 FORMAT('***** ERROR: VALUE OF SHAPE PARAMETER IN SDECDF ',
     1       'ROUTINE IS NEGATIVE.')
   48 FORMAT('      VALUE OF ARGUMENT IS: ',G15.7)
C
      DX=DBLE(X)
      DLMBDA=DBLE(ALMBDA)
C
      IF(ALMBDA.EQ.0)THEN
        CALL DEXCDF(X,CDF)
        GOTO9000
      ELSE
        IF(X.LE.0.0)THEN
          DCDF=0.5D0*DEXP((1.0D0 + DLMBDA)*DX)/(1.0D0 + DLMBDA)
        ELSE
          DCDF=1.0D0 - DEXP(-DX) -
     1         0.5D0/(DEXP((1.0D0 + DLMBDA)*DX)*(-1.0D0-DLMBDA))
        ENDIF
        CDF=REAL(DCDF)
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      REAL FUNCTION SDEFUN(X)
C
C     PURPOSE--SDEPPF CALLS FZERO TO FIND A ROOT FOR THE PERCENT
C              POINT FUNCTION.  SDEFUN IS THE FUNCTION FOR WHICH
C              THE ZERO IS FOUND.  IT IS:
C                 P - SDECDF(X,LAMBDA)
C              WHERE P IS THE DESIRED PERCENT POINT.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C     OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE SDEFUN.
C     PRINTING--NONE.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--SDECDF.
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                 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004.6
C     ORIGINAL VERSION--JUNE      2004.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      REAL P
      COMMON/SDECOM/P,ALAMB
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      CALL SDECDF(X,ALAMB,CDF)
      SDEFUN=P - CDF
C
      RETURN
      END
      SUBROUTINE SDEPDF(X,ALMBDA,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE SKEW-LAPLACE DISTRIBUTION
C              (OR SKEW-DOUBLE EXPONENTIAL)
C              WITH SHAPE PARAMETER = LAMBDA.
C              THIS DISTRIBUTION IS DEFINED FOR ALL X AND HAS
C              THE PROBABILITY DENSITY FUNCTION
C                 SDEPDF(X,LAMBDA) = 0.5*EXP((1+LAMBDA)*X)   X <= 0
C                                  = EXP(-X) - 0.5*EXP((1+LAMBDA)*X)
C                                                            X > 0
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                     --ALMBDA = 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 SKEWED-LAPLACE DISTRIBUTION
C             WITH SHAPE PARAMETER = LAMBDA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--EXP.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--KOTZ, KOZUBOWSKI, AND PODGORSKI, "THE LAPLACE
C                 DISTRIBUTION AND GENERALIZATIONS: A REVISIT WITH
C                 APPLICATIONS TO COMMUNICATIONS, ECONOMICS,
C                 ENGINEERING, AND FINANCE", BIRKHAUSR, 2001,
C                 PP. 134.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004.6
C     ORIGINAL VERSION--JUNE      2004.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DLMBDA
      DOUBLE PRECISION DPDF
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C               ************************************
C               **  STEP 1--                      **
C               **  COMPUTE THE DENSITY FUNCTION  **
C               ************************************
C
      IF(ALMBDA.LT.0.0)THEN
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,48)ALMBDA
        CALL DPWRST('XXX','WRIT')
        PDF=0.0
        GOTO9000
      ENDIF
    5 FORMAT('***** ERROR: VALUE OF SHAPE PARAMETER IN SDEPDF ',
     1       'ROUTINE IS NEGATIVE.')
   48 FORMAT('      VALUE OF ARGUMENT IS: ',G15.7)
C
      DX=DBLE(X)
      DLMBDA=DBLE(ALMBDA)
C
      IF(ALMBDA.EQ.0.0)THEN
        CALL DEXPDF(X,PDF)
        GOTO9000
      ELSE
        IF(X.LE.0.0)THEN
          DPDF=0.5D0*DEXP((1.0D0 + DLMBDA)*DX)
        ELSE
          DPDF=DEXP(-DX) - 0.5D0*DEXP(-(1.0D0 + DLMBDA)*DX)
        ENDIF
        PDF=REAL(DPDF)
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE SDEPPF(P,ALMBDA,PPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE SKEW DOUBLE EXPONENTIAL
C              DISTRIBUTION WITH SHAPE PARAMETER = LAMBDA.
C              THIS DISTRIBUTION IS DEFINED FOR ALL X AND THE
C              PERCENT POINT FUNCTION IS COMPUTED BY:
C              1) COMPUTE PCUT = SDECDF(0,LAMBDA)
C              2) IF P <= PCUT, USE CLOSED FORM FORMULA:
C                    PPF = LOG[2*P*(1+LAMBDA)]/(1+LAMBDA)
C
C              3) IF P > PCUT, NUMERICALLY INVERT THE CDF FUNCTION.
C     INPUT  ARGUMENTS--P      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE PERCENT POINT
C                                FUNCTION IS TO BE EVALUATED.
C                     --ALMBDA = THE SHAPE PARAMETER
C     OUTPUT ARGUMENTS--PPF    = THE SINGLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PERCENT POINT
C             FUNCTION VALUE PPF.
C     PRINTING--NONE.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--FZERO.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--KOTZ, KOZUBOWSKI, AND PODGORSKI, "THE LAPLACE
C                 DISTRIBUTION AND GENERALIZATIONS: A REVISIT WITH
C                 APPLICATIONS TO COMMUNICATIONS, ECONOMICS,
C                 ENGINEERING, AND FINANCE", BIRKHAUSR, 2001,
C                 PP. 134.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004.6
C     ORIGINAL VERSION--JUNE      2004.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      REAL PPF
      DOUBLE PRECISION DP
      DOUBLE PRECISION DPPF
      DOUBLE PRECISION DLMBDA
C
      REAL SDEFUN
      EXTERNAL SDEFUN
C
      REAL P2,ALAMB
      COMMON/SDECOM/P2,ALAMB
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C
      IF(P.LE.0.0.OR.P.GE.1.0)THEN
         WRITE(ICOUT,61)
   61    FORMAT('***** ERROR--THE FIRST  INPUT ARGUMENT ',
     1          'TO THE SDEPPF SUBROUTINE ')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,62)
   62    FORMAT('      IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL.')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,63)P
   63    FORMAT('      VALUE OF ARGUMENT = ',G15.7)
         CALL DPWRST('XXX','BUG ')
         PPF=0.0
         GOTO9000
      ENDIF
C
      IF(ALMBDA.LT.0.0)THEN
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,48)ALMBDA
        CALL DPWRST('XXX','WRIT')
        PDF=0.0
        GOTO9000
      ENDIF
    5 FORMAT('***** ERROR: VALUE OF SHAPE PARAMETER IN SDEPPF ',
     1       'ROUTINE IS NEGATIVE.')
   48 FORMAT('      VALUE OF ARGUMENT IS: ',G15.7)
C
      DP=DBLE(P)
      DLMBDA=DBLE(ALMBDA)
C
      IF(ALMBDA.EQ.0.0)THEN
        CALL DEXPPF(P,PPF)
        GOTO9000
      ENDIF
C
C  STEP 1: COMPUTE SDECDF(0,LAMBDA).  CLOSED FORM FOR P < PCUT.
C
      CALL SDECDF(0.0,ALMBDA,PCUT)
      IF(P.LE.PCUT)THEN
        DPPF=DLOG(2.0D0*DP*(1.0D0+DLMBDA))/(1.0D0+DLMBDA)
        PPF=REAL(DPPF)
        GOTO9000
      ENDIF
C
C  STEP 2: FIND BRACKETING INTERVAL.  PCUT IS LOWER BOUND, PPF OF
C          EXPONENTIAL DISTRIBUTION IS UPPER BOUND.
C
      XLOW=PCUT
      CALL EXPPPF(P,XUP)
      XLOW=XLOW - 1.0
      XUP=XUP + 10.0
C
      AE=1.E-6
      RE=1.E-6
      ALAMB=ALMBDA
      P2=P
      CALL FZERO(SDEFUN,XLOW,XUP,XUP,RE,AE,IFLAG)
C
      PPF=XLOW
      IF(IFLAG.EQ.2)THEN
C
C  NOTE: SUPPRESS THIS MESSAGE FOR NOW.
CCCCC   WRITE(ICOUT,999)
  999   FORMAT(1X)
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   WRITE(ICOUT,111)
CC111   FORMAT('***** WARNING FROM SDEPPF--')
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   WRITE(ICOUT,113)
CC113   FORMAT('      PPF VALUE MAY NOT BE COMPUTED TO DESIRED ',
CCCCC1         'TOLERANCE.')
CCCCC   CALL DPWRST('XXX','BUG ')
      ELSEIF(IFLAG.EQ.3)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,121)
  121   FORMAT('***** WARNING FROM SDEPPF--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,123)
  123   FORMAT('      PPF VALUE MAY BE NEAR A SINGULAR POINT.')
        CALL DPWRST('XXX','BUG ')
      ELSEIF(IFLAG.EQ.4)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,131)
  131   FORMAT('***** ERROR FROM SDEPPF--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,133)
  133   FORMAT('      APPROPRIATE BRACKETING INTERVAL NOT FOUND.')
        CALL DPWRST('XXX','BUG ')
      ELSEIF(IFLAG.EQ.5)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,141)
  141   FORMAT('***** WARNING FROM SDEPPF--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,143)
  143   FORMAT('      MAXIMUM ITERATIONS EXCEEDED.')
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE SDERAN(N,ALMBDA,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE SKEWED DOUBLE EXPONENTIAL (LAPLACE)
C              DISTRIBUTION WITH SHAPE PARAMETER = ALMBDA.
C              THIS DISTRIBUTION IS DEFINED FOR ALL X AND HAS
C              THE PROBABILITY DENSITY FUNCTION
C                 SDEPDF(X,LAMBDA) = 0.5*EXP((1+LAMBDA)*X)   X <= 0
C                                  = EXP(-X) - 0.5*EXP((1+LAMBDA)*X)
C                                                            X > 0
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --ALMBDA = THE SHAPE (PARAMETER) FOR THE
C                                SKEWED DOUBLE EXPONENTIAL
C                                DISTRIBUTION.
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST N)
C                                INTO WHICH THE GENERATED
C                                RANDOM SAMPLE WILL BE PLACED.
C     OUTPUT--A RANDOM SAMPLE OF SIZE N
C             FROM THE SKEWED DOUBLE EXPONENTIAL DISTRIBUTION
C             WITH SHAPE PARAMETER = ALMBDA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C                 --ALMBDA CAN BE ANY REAL NUMBER.
C     OTHER DATAPAC   SUBROUTINES NEEDED--SDEPPF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--KOTZ, KOZUBOWSKI, AND PODGORSKI, "THE LAPLACE
C                 DISTRIBUTION AND GENERALIZATIONS: A REVISIT WITH
C                 APPLICATIONS TO COMMUNICATIONS, ECONOMICS,
C                 ENGINEERING, AND FINANCE", BIRKHAUSR, 2001,
C                 PP. 134.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004.6
C     ORIGINAL VERSION--JUNE      2004.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)THEN
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,6)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
      IF(ALMBDA.LT.0.0)THEN
        WRITE(ICOUT,15)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,48)ALMBDA
        CALL DPWRST('XXX','WRIT')
        PDF=0.0
        GOTO9999
      ENDIF
    5 FORMAT('***** ERROR--FOR THE SKEWED DOUBLE EXPONENTIAL ',
     1       'DISTRIBUTION,')
    6 FORMAT('       THE REQUESTED NUMBER OF RANDOM NUMBERS WAS ',
     1      'NON-POSITIVE.')
   15 FORMAT('***** ERROR: VALUE OF LAMBDA FOR SKEW DOUBLE ',
     1       'EXPONENTIAL RANDOM NUMBERS IS NEGATIVE.')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,'.')
   48 FORMAT('      VALUE OF ARGUMENT IS: ',G15.7)
C
C     USE PERCENT POINT TRANSFORMATION METHOD.
C
      CALL UNIRAN(N,ISEED,X)
C
      DO100I=1,N
        ATEMP=X(I)
        CALL SDEPPF(ATEMP,ALMBDA,APPF)
        X(I)=APPF
  100 CONTINUE
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE SDMEAN(X,N,IWRITE,XSDM,IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE
C              STANDARD DEVIATION OF THE MEAN (AVERAGE).
C              IT IS HERE COMPUTED AS THE RATIO OF THE
C              SAMPLE STANDARD DEVIATION (WITH DENOMINATOR N-1)
C              OF THE DATA IN THE INPUT VECTOR X,
C              DIVIDED BY THE SQUARE ROOT OF THE
C              NUMBER N OF OBSERVATIONS IN X.
C              THE SAMPLE STANDARD DEVIATION = SQRT((THE SUM OF THE
C              SQUARED DEVIATIONS ABOUT THE SAMPLE MEAN)/(N-1)).
C              THE STANDARD DEVIATION OF THE MEAN =
C              THE SAMPLE STANDARD DEVIATION / SQRT(N).
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF
C                                (UNSORTED OR SORTED) OBSERVATIONS.
C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR X.
C     OUTPUT ARGUMENTS--XSDM   = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED STANDARD DEVIATION
C                                OF THE SAMPLE MEAN.
C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
C             STANDARD DEVIATION OF THE SAMPLE MEAN.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--DSQRT.
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, PAGES 19, 76.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--82.6
C     ORIGINAL VERSION--JANUARY   1978.
C     UPDATED         --JUNE      1979.
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
      DOUBLE PRECISION DSD
C
      DIMENSION X(*)
C
C-----COMMON---------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='SDME'
      ISUBN2='AN  '
      IERROR='NO'
C
      DMEAN=0.0D0
      DSD=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 SDMEAN--')
      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 STANDARD DEVIATION OF THE MEAN  **
C               **********************************************
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      AN=N
C
      IF(N.GE.1)GOTO119
      IERROR='YES'
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,111)
  111 FORMAT('***** ERROR IN SDMEAN--')
      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 STANDARD DEVIATION OF THE 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 ')
      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 SDMEAN--',
     1'THE 2ND INPUT ARGUMENT (N) HAS THE VALUE 1')
      CALL DPWRST('XXX','BUG ')
      XSDM=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 SDMEAN--',
     1'THE FIRST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      XSDM=0.0
      GOTO9000
  139 CONTINUE
C
C               ***************************************************
C               **  STEP 2--                                     **
C               **  COMPUTE THE STANDARD DEVIATION OF THE MEAN.  **
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)
      DSD=0.0D0
      IF(DVAR.GT.0.0D0)DSD=DSQRT(DVAR)
      XSDM=DSD/DSQRT(DN)
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,XSDM
  811 FORMAT('THE STANDARD DEVIATION OF THE MEAN BASED ON ',I8,
     1' OBSERVATIONS = ',E15.7)
      CALL DPWRST('XXX','BUG ')
  890 CONTINUE
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'OFF')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF SDMEAN--')
      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,DSD
 9014 FORMAT('DMEAN,DSD = ',2D15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9015)XSDM
 9015 FORMAT('XSDM = ',E15.7)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE SDMLE(X,N,IWRITE,XSD,IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE SAMPLE STANDARD DEVIATION
C              (WITH DENOMINATOR N) OF THE DATA IN THE INPUT VECTOR X.
C              THE SAMPLE STANDARD DEVIATION = SQRT((THE SUM OF THE
C              SQUARED DEVIATIONS ABOUT THE SAMPLE MEAN)/N).
C
C              NOTE THAT THIS IS SIMILAR TO SUBROUTINE SD.  THE
C              DISTINCTION IS THAT THIS ROUTINE USES N RATHER THAN
C              N-1 AS THE DIVISOR.  THIS IS THE MAXIMUM LIKELIHOOD
C              VERSION OF THE ESTIMATOR.  THIS WAS ADDED PRIMARILY
C              FOR INTERNAL USE (E.G., COEFFICIENT OF VARIATION
C              CONFIDENCE LIMITS MAY USE THIS).
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--XSD    = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED SAMPLE STANDARD DEVIATION.
C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
C             SAMPLE STANDARD DEVIATION (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--DSQRT.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     WRITTEN BY--ALAN HECKERT
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2899
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2016.12
C     ORIGINAL VERSION--DECEMBER  2016.
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
      DOUBLE PRECISION DSD
C
      DIMENSION X(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='SDML'
      ISUBN2='E   '
      IERROR='NO'
C
      DMEAN=0.0D0
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 SDMLE--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,52)IBUGA3,N
   52   FORMAT('IBUGA3,N = ',A4,2X,I8)
        CALL DPWRST('XXX','BUG ')
        DO55I=1,N
          WRITE(ICOUT,56)I,X(I)
   56     FORMAT('I,X(I) = ',I8,G15.7)
          CALL DPWRST('XXX','BUG ')
   55   CONTINUE
      ENDIF
C
C               **********************************
C               **  COMPUTE STANDARD DEVIATION  **
C               **********************************
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      AN=N
C
      IF(N.LT.1)THEN
        IERROR='YES'
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,111)
  111   FORMAT('***** ERROR IN SD (MLE FORM)--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,112)
  112   FORMAT('      THE NUMBER OF OBSERVATIONS FOR THE RESPONSE')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,115)
  115   FORMAT('      VARIABLE IS LESS THAN 1.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,117)N
  117   FORMAT('      THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8,'.')
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
      XSD=0.0
      IF(N.EQ.1)GOTO800
C
      HOLD=X(1)
      DO135I=2,N
        IF(X(I).NE.HOLD)GOTO139
  135 CONTINUE
      GOTO800
  139 CONTINUE
C
C               ***************************************
C               **  STEP 2--                         **
C               **  COMPUTE THE STANDARD DEVIATION.  **
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
      DSD=0.0D0
      IF(DVAR.GT.0.0D0)DSD=DSQRT(DVAR)
      XSD=DSD
C
C               *******************************
C               **  STEP 3--                 **
C               **  WRITE OUT A LINE         **
C               **  OF SUMMARY INFORMATION.  **
C               *******************************
C
  800 CONTINUE
      IF(IFEEDB.EQ.'ON' .AND. IWRITE.EQ.'ON')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,811)N,XSD
  811   FORMAT('THE STANDARD DEVIATION (MLE) OF THE ',I8,
     1         ' OBSERVATIONS = ',E15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'ON')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END       OF SD--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9012)IERROR,DMEAN,XSD
 9012   FORMAT('IERROR,DMEAN,XSD = ',A4,2X,2G15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      RETURN
      END
      REAL FUNCTION SDOT(N,SX,INCX,SY,INCY)
C
C***BEGIN PROLOGUE  SDOT
C***DATE WRITTEN   791001   (YYMMDD)
C***REVISION DATE  820801   (YYMMDD)
C***CATEGORY NO.  D1A4
C***KEYWORDS  BLAS,INNER PRODUCT,LINEAR ALGEBRA,VECTOR
C***AUTHOR  LAWSON, C. L., (JPL)
C           HANSON, R. J., (SNLA)
C           KINCAID, D. R., (U. OF TEXAS)
C           KROGH, F. T., (JPL)
C***PURPOSE  S.P. inner product of s.p. vectors
C***DESCRIPTION
C
C                B L A S  Subprogram
C    Description of Parameters
C
C     --Input--
C        N  number of elements in input vector(s)
C       SX  single precision vector with N elements
C     INCX  storage spacing between elements of SX
C       SY  single precision vector with N elements
C     INCY  storage spacing between elements of SY
C
C     --Output--
C     SDOT  single precision dot product (zero if N .LE. 0)
C
C     where LX = 1 if INCX .GE. 0, else LX = (-INCX)*N, and LY is
C     defined in a similar way using INCY.
C***REFERENCES  LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T.,
C                 *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*,
C                 ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL
C                 SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323
C***ROUTINES CALLED  (NONE)
C***END PROLOGUE  SDOT
C
      REAL SX(*),SY(*)
C***FIRST EXECUTABLE STATEMENT  SDOT
      SDOT = 0.0E0
      IF(N.LE.0)RETURN
C
CCCCC JUNE 2008: MODIFY FOLLOWING LINE SO THAT IT DOES NOT
CCCCC            GENERATE WARNING MESSAGE ON FORTRAN 95 COMPILERS.
C
CCCCC IF(INCX.EQ.INCY) IF(INCX-1)5,20,60
      IF(INCX.EQ.INCY) THEN
        IF(INCX-1.LT.0)THEN
          GOTO5
        ELSEIF(INCX-1.EQ.0)THEN
          GOTO20
        ELSE
          GOTO60
        ENDIF
      ENDIF
    5 CONTINUE
C
C        CODE FOR UNEQUAL INCREMENTS OR NONPOSITIVE INCREMENTS.
C
      IX = 1
      IY = 1
      IF(INCX.LT.0)IX = (-N+1)*INCX + 1
      IF(INCY.LT.0)IY = (-N+1)*INCY + 1
      DO 10 I = 1,N
        SDOT = SDOT + SX(IX)*SY(IY)
        IX = IX + INCX
        IY = IY + INCY
   10 CONTINUE
      RETURN
C
C        CODE FOR BOTH INCREMENTS EQUAL TO 1
C
C
C        CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 5.
C
   20 M = MOD(N,5)
      IF( M .EQ. 0 ) GO TO 40
      DO 30 I = 1,M
        SDOT = SDOT + SX(I)*SY(I)
   30 CONTINUE
      IF( N .LT. 5 ) RETURN
   40 MP1 = M + 1
      DO 50 I = MP1,N,5
        SDOT = SDOT + SX(I)*SY(I) + SX(I + 1)*SY(I + 1) +
     1   SX(I + 2)*SY(I + 2) + SX(I + 3)*SY(I + 3) + SX(I + 4)*SY(I + 4)
   50 CONTINUE
      RETURN
C
C        CODE FOR POSITIVE EQUAL INCREMENTS .NE.1.
C
   60 CONTINUE
      NS=N*INCX
      DO 70 I=1,NS,INCX
        SDOT = SDOT + SX(I)*SY(I)
   70   CONTINUE
      RETURN
      END
      REAL FUNCTION SDSDOT(N,X,INCX,Y,INCY,C)
CCCCC REAL FUNCTION SDSDOT(N,SB,SX,INCX,SY,INCY)
CCCCC OCTOBER 1993.  USE VERSION AS CODED IN LINPACK MANUAL
C***BEGIN PROLOGUE  SDSDOT
C***DATE WRITTEN   791001   (YYMMDD)
C***REVISION DATE  820801   (YYMMDD)
C***CATEGORY NO.  D1A4
C***KEYWORDS  BLAS,INNER PRODUCT,LINEAR ALGEBRA,VECTOR
C***AUTHOR  LAWSON, C. L., (JPL)
C           HANSON, R. J., (SNLA)
C           KINCAID, D. R., (U. OF TEXAS)
C           KROGH, F. T., (JPL)
C***PURPOSE  S.P. result with inner product accumulated in d.p.
C***DESCRIPTION
C
C                B L A S  Subprogram
C    Description of Parameters
C
C     --Input--
C        N  number of elements in input vector(s)
C        C  single precision scalar to be added to inner product
C        X  single precision vector with N elements
C     INCX  storage spacing between elements of SX
C        Y  single precision vector with N elements
C     INCY  storage spacing between elements of SY
C
C     --Output--
C   SDSDOT  single precision dot product (zero if N .LE. 0)
C
C     Returns S.P. result with dot product accumulated in D.P.
C     SDSDOT = SB + sum for I = 0 to N-1 of SX(LX+I*INCX)*SY(LY+I*INCY)
C     where LX = 1 if INCX .GE. 0, else LX = (-INCX)*N, and LY is
C     defined in a similar way using INCY.
C***REFERENCES  LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T.,
C                 *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*,
C                 ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL
C                 SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323
C***ROUTINES CALLED  (NONE)
C***END PROLOGUE  SDSDOT
C
      REAL X(INCX,*),Y(INCY,*),C
      DOUBLE PRECISION SUM
C***FIRST EXECUTABLE STATEMENT  SDSDOT
      SUM = 0.0D0
      IF(N .LE. 0) GO TO 20
      DO 10 I = 1,N
        SUM = SUM + DBLE(X(1,I))*DBLE(Y(1,I))
   10 CONTINUE
   20 SUM = SUM + DBLE(C)
      SDSDOT = SNGL(SUM)
      RETURN
      END
      SUBROUTINE SECFAC(NR,N,X,G,A,XPLS,GPLS,EPSM,ITNCNT,RNF,
     +     IAGFLG,NOUPDT,S,Y,U,W)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C PURPOSE
C -------
C UPDATE HESSIAN BY THE BFGS FACTORED METHOD
C
C PARAMETERS
C ----------
C NR           --> ROW DIMENSION OF MATRIX
C N            --> DIMENSION OF PROBLEM
C X(N)         --> OLD ITERATE, X[K-1]
C G(N)         --> GRADIENT OR APPROXIMATE AT OLD ITERATE
C A(N,N)      <--> ON ENTRY: CHOLESKY DECOMPOSITION OF HESSIAN IN
C                    LOWER PART AND DIAGONAL.
C                  ON EXIT:  UPDATED CHOLESKY DECOMPOSITION OF HESSIAN
C                    IN LOWER TRIANGULAR PART AND DIAGONAL
C XPLS(N)      --> NEW ITERATE, X[K]
C GPLS(N)      --> GRADIENT OR APPROXIMATE AT NEW ITERATE
C EPSM         --> MACHINE EPSILON
C ITNCNT       --> ITERATION COUNT
C RNF          --> RELATIVE NOISE IN OPTIMIZATION FUNCTION FCN
C IAGFLG       --> =1 IF ANALYTIC GRADIENT SUPPLIED, =0 ITHERWISE
C NOUPDT      <--> BOOLEAN: NO UPDATE YET
C                  [RETAIN VALUE BETWEEN SUCCESSIVE CALLS]
C S(N)         --> WORKSPACE
C Y(N)         --> WORKSPACE
C U(N)         --> WORKSPACE
C W(N)         --> WORKSPACE
C
      DIMENSION X(*),XPLS(*),G(*),GPLS(*)
      DIMENSION A(NR,*)
      DIMENSION S(*),Y(*),U(*),W(*)
      LOGICAL NOUPDT,SKPUPD
C
      IF(ITNCNT.EQ.1) NOUPDT=.TRUE.
      DO 10 I=1,N
        S(I)=XPLS(I)-X(I)
        Y(I)=GPLS(I)-G(I)
   10 CONTINUE
      DEN1=DDOT(N,S,1,Y,1)
      SNORM2=DNRM2(N,S,1)
      YNRM2=DNRM2(N,Y,1)
      IF(DEN1.LT.SQRT(EPSM)*SNORM2*YNRM2) GO TO 110
C     IF(DEN1.GE.SQRT(EPSM)*SNORM2*YNRM2)
C     THEN
        CALL MVMLTU(NR,N,A,S,U)
        DEN2=DDOT(N,U,1,U,1)
C
C       L <-- SQRT(DEN1/DEN2)*L
C
        ALP=SQRT(DEN1/DEN2)
        IF(.NOT.NOUPDT) GO TO 50
C       IF(NOUPDT)
C       THEN
          DO 30 J=1,N
            U(J)=ALP*U(J)
            DO 20 I=J,N
              A(I,J)=ALP*A(I,J)
   20       CONTINUE
   30     CONTINUE
          NOUPDT=.FALSE.
          DEN2=DEN1
          ALP=1.0
C       ENDIF
   50   SKPUPD=.TRUE.
C
C       W = L(L+)S = HS
C
        CALL MVMLTL(NR,N,A,U,W)
        I=1
        IF(IAGFLG.NE.0) GO TO 55
C       IF(IAGFLG.EQ.0)
C       THEN
          RELTOL=SQRT(RNF)
          GO TO 60
C       ELSE
   55     RELTOL=RNF
C       ENDIF
   60   IF(I.GT.N .OR. .NOT.SKPUPD) GO TO 70
C       IF(I.LE.N .AND. SKPUPD)
C       THEN
          IF(ABS(Y(I)-W(I)) .LT. RELTOL*MAX(ABS(G(I)),ABS(GPLS(I))))
     +         GO TO 65
C         IF(ABS(Y(I)-W(I)) .GE. RELTOL*AMAX1(ABS(G(I)),ABS(GPLS(I))))
C         THEN
            SKPUPD=.FALSE.
            GO TO 60
C         ELSE
   65       I=I+1
            GO TO 60
C         ENDIF
C       ENDIF
   70   IF(SKPUPD) GO TO 110
C       IF(.NOT.SKPUPD)
C       THEN
C
C         W=Y-ALP*L(L+)S
C
          DO 75 I=1,N
            W(I)=Y(I)-ALP*W(I)
   75     CONTINUE
C
C         ALP=1/SQRT(DEN1*DEN2)
C
          ALP=ALP/DEN1
C
C         U=(L+)/SQRT(DEN1*DEN2) = (L+)S/SQRT((Y+)S * (S+)L(L+)S)
C
          DO 80 I=1,N
            U(I)=ALP*U(I)
   80     CONTINUE
C
C         COPY L INTO UPPER TRIANGULAR PART.  ZERO L.
C
          IF(N.EQ.1) GO TO 93
          DO 90 I=2,N
            IM1=I-1
            DO 85 J=1,IM1
              A(J,I)=A(I,J)
              A(I,J)=0.
   85       CONTINUE
   90     CONTINUE
C
C         FIND Q, (L+) SUCH THAT  Q(L+) = (L+) + U(W+)
C
   93     CALL QRUPDT(NR,N,A,U,W)
C
C         UPPER TRIANGULAR PART AND DIAGONAL OF A NOW CONTAIN UPDATED
C         CHOLESKY DECOMPOSITION OF HESSIAN.  COPY BACK TO LOWER
C         TRIANGULAR PART.
C
          IF(N.EQ.1) GO TO 110
          DO 100 I=2,N
            IM1=I-1
            DO 95 J=1,IM1
              A(I,J)=A(J,I)
   95       CONTINUE
  100     CONTINUE
C       ENDIF
C     ENDIF
  110 RETURN
      END
      SUBROUTINE SECUNF(NR,N,X,G,A,UDIAG,XPLS,GPLS,EPSM,ITNCNT,
     +     RNF,IAGFLG,NOUPDT,S,Y,T)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C PURPOSE
C -------
C UPDATE HESSIAN BY THE BFGS UNFACTORED METHOD
C
C PARAMETERS
C ----------
C NR           --> ROW DIMENSION OF MATRIX
C N            --> DIMENSION OF PROBLEM
C X(N)         --> OLD ITERATE, X[K-1]
C G(N)         --> GRADIENT OR APPROXIMATE AT OLD ITERATE
C A(N,N)      <--> ON ENTRY: APPROXIMATE HESSIAN AT OLD ITERATE
C                    IN UPPER TRIANGULAR PART (AND UDIAG)
C                  ON EXIT:  UPDATED APPROX HESSIAN AT NEW ITERATE
C                    IN LOWER TRIANGULAR PART AND DIAGONAL
C                  [LOWER TRIANGULAR PART OF SYMMETRIC MATRIX]
C UDIAG        --> ON ENTRY: DIAGONAL OF HESSIAN
C XPLS(N)      --> NEW ITERATE, X[K]
C GPLS(N)      --> GRADIENT OR APPROXIMATE AT NEW ITERATE
C EPSM         --> MACHINE EPSILON
C ITNCNT       --> ITERATION COUNT
C RNF          --> RELATIVE NOISE IN OPTIMIZATION FUNCTION FCN
C IAGFLG       --> =1 IF ANALYTIC GRADIENT SUPPLIED, =0 OTHERWISE
C NOUPDT      <--> BOOLEAN: NO UPDATE YET
C                  [RETAIN VALUE BETWEEN SUCCESSIVE CALLS]
C S(N)         --> WORKSPACE
C Y(N)         --> WORKSPACE
C T(N)         --> WORKSPACE
C
      DIMENSION X(N),G(N),XPLS(N),GPLS(N)
      DIMENSION A(NR,1)
      DIMENSION UDIAG(N)
      DIMENSION S(N),Y(N),T(N)
      LOGICAL NOUPDT,SKPUPD
C
C COPY HESSIAN IN UPPER TRIANGULAR PART AND UDIAG TO
C LOWER TRIANGULAR PART AND DIAGONAL
C
      DO 5 J=1,N
        A(J,J)=UDIAG(J)
        IF(J.EQ.N) GO TO 5
        JP1=J+1
        DO 4 I=JP1,N
          A(I,J)=A(J,I)
    4   CONTINUE
    5 CONTINUE
C
      IF(ITNCNT.EQ.1) NOUPDT=.TRUE.
      DO 10 I=1,N
        S(I)=XPLS(I)-X(I)
        Y(I)=GPLS(I)-G(I)
   10 CONTINUE
      DEN1=DDOT(N,S,1,Y,1)
      SNORM2=DNRM2(N,S,1)
      YNRM2=DNRM2(N,Y,1)
      IF(DEN1.LT.SQRT(EPSM)*SNORM2*YNRM2) GO TO 100
C     IF(DEN1.GE.SQRT(EPSM)*SNORM2*YNRM2)
C     THEN
        CALL MVMLTS(NR,N,A,S,T)
        DEN2=DDOT(N,S,1,T,1)
        IF(.NOT. NOUPDT) GO TO 50
C       IF(NOUPDT)
C       THEN
C
C         H <-- [(S+)Y/(S+)HS]H
C
          GAM=DEN1/DEN2
          DEN2=GAM*DEN2
          DO 30 J=1,N
            T(J)=GAM*T(J)
            DO 20 I=J,N
              A(I,J)=GAM*A(I,J)
   20       CONTINUE
   30     CONTINUE
          NOUPDT=.FALSE.
C       ENDIF
   50   SKPUPD=.TRUE.
C
C       CHECK UPDATE CONDITION ON ROW I
C
        DO 60 I=1,N
          TOL=RNF*MAX(ABS(G(I)),ABS(GPLS(I)))
          IF(IAGFLG.EQ.0) TOL=TOL/SQRT(RNF)
          IF(ABS(Y(I)-T(I)).LT.TOL) GO TO 60
C         IF(ABS(Y(I)-T(I)).GE.TOL)
C         THEN
            SKPUPD=.FALSE.
            GO TO 70
C         ENDIF
   60   CONTINUE
   70   IF(SKPUPD) GO TO 100
C       IF(.NOT.SKPUPD)
C       THEN
C
C         BFGS UPDATE
C
          DO 90 J=1,N
            DO 80 I=J,N
              A(I,J)=A(I,J)+Y(I)*Y(J)/DEN1-T(I)*T(J)/DEN2
   80       CONTINUE
   90     CONTINUE
C       ENDIF
C     ENDIF
  100 RETURN
      END
      SUBROUTINE SEMCDF(X,R,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE SEMI-CIRCULAR
C              DISTRIBUTION ON THE INTERVAL (-R,R).
C              THE CUMULATIVE DISTRIBUTION FUNCTION IS
C
C                  F(X;R) = 0.5 + X*SQRT(R**2-X**2)/(PI*R**2) +
C                           ARCSIN(X/R)/PI
C
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C                     --R      = THE SINGLE PRECISION VALUE OF
C                                THE SHAPE PARAMETER (RADIUS)
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 -R AND R, INCLUSIVELY.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--SQRT, ATAN.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--XXXXX.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--82.6
C     ORIGINAL VERSION--NOVEMBER  1977.
C     UPDATED         --DECEMBER  1981.
C     UPDATED         --MAY       1982.
C     UPDATED         --OCTOBER   2006. GENERALIZE TO CASE WHERE
C                                       RADIUS NOT EQUAL TO 1
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----DATA STATEMENTS-------------------------------------------------
C
      DATA PI/3.14159265359/
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(R.LE.0.0)THEN
        WRITE(ICOUT,1)
    1   FORMAT('***** ERROR--THE SECOD INPUT ARGUMENT ',
     1         'TO SEMCDF IS NON-POSITIVE')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)R
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9000
      ENDIF
      IF(X.LT.-R .OR. X.GT.R)THEN
        WRITE(ICOUT,2)
    2   FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT ',
     1         'TO SEMCDF IS OUTSIDE THE (-R,R) INTERVAL')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
   46   FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)R
   47   FORMAT('***** THE VALUE OF R            IS ',G15.7)
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9000
      ENDIF
C
      IF(X.EQ.-R)THEN
        CDF=0.0
      ELSEIF(X.EQ.R)THEN
        CDF=1.0
      ELSE
        TERM1=0.5
        TERM2=X*SQRT(R**2 - X*X)/(PI*R**2)
        TERM3=ASIN(X/R)/PI
        CDF=TERM1 + TERM2 + TERM3
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE SEMPDF(X,R,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE SEMI-CIRCULAR
C              DISTRIBUTION ON THE INTERVAL (-R,R).
C              THIS DISTRIBUTION HAS MEAN = 0.0
C              AND STANDARD DEVIATION = SQRT(R**2/4)
C              THIS DISTRIBUTION HAS THE PROBABILITY
C              DENSITY FUNCTION
C
C                  F(X;R) = 2*SQRT(R**2-X**2)/(PI*R**2)
C
C              (A SEMI-CIRCLE FOR R=1, AN ELLIPSE OTHERWISE).
C              THIS DISTRIBUTION IS IMPORTANT IN THAT IT IS
C              THE DISTRIBUTION ONTO ONE AXIS
C              OF POINTS WHICH ARE UNIFORMLY
C              DISTRIBUTED WITHIN A CIRCLE OF UNIT RADIUS.
C              IT IS USEFUL IN TESTING FOR
C              2-DIMENSIONAL UNIFORMITY.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                     --R      = THE SINGLE PRECISION VALUE THAT
C                                DEFINES THE RADIUS
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 -R AND R, INCLUSIVELY.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--SQRT
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--XXXXX.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--94.4
C     ORIGINAL VERSION--APRIL     1994
C     UPDATED         --OCTOBER   2006. GENERALIZE TO CASES WHERE
C                                       R NOT EQUAL TO 1.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----DATA STATEMENTS-------------------------------------------------
C
      DATA PI/3.14159265359/
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(R.LE.0.0)THEN
        WRITE(ICOUT,1)
    1   FORMAT('***** ERROR--THE SECOD INPUT ARGUMENT ',
     1         'TO SEMPDF IS NON-POSITIVE')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)R
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9000
      ENDIF
      IF(X.LT.-R .OR. X.GT.R)THEN
        WRITE(ICOUT,2)
    2   FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT ',
     1         'TO SEMPDF IS OUTSIDE THE (-R,R) INTERVAL')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
   46   FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)R
   47   FORMAT('***** THE VALUE OF R            IS ',G15.7)
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9000
      ENDIF
C
      IF(X.EQ.-R)THEN
        PDF=0.0
      ELSEIF(X.EQ.R)THEN
        PDF=0.0
      ELSE
        PDF=2.0*SQRT(R**2 - X*X)/(R**2*PI)
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE SEMPPF(P,R,PPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE SEMI-CIRCULAR
C              DISTRIBUTION ON THE INTERVAL (-R,R).
C              THIS DISTRIBUTION HAS MEAN = 0.0
C              AND STANDARD DEVIATION = SQRT(R**2/4)
C              THIS DISTRIBUTION HAS THE PROBABILITY
C              DENSITY FUNCTION
C
C                  F(X;R) = 2*SQRT(R**2-X**2)/(PI*R**2)
C
C              (A SEMI-CIRCLE FOR R=1, AN ELLIPSE OTHERWISE).
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                     --R      = THE SINGLE PRECISION VALUE THAT
C                                DEFINES THE RADIUS
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--SEMCDF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--ABS.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--FILLIBEN, SIMPLE AND ROBUST LINEAR ESTIMATION
C                 OF THE LOCATION PARAMETER OF A SYMMETRIC
C                 DISTRIBUTION (UNPUBLISHED PH.D. DISSERTATION,
C                 PRINCETON UNIVERSITY), 1969, PAGES 21-44, 229-231.
C               --FILLIBEN, 'THE PERCENT POINT FUNCTION',
C                 (UNPUBLISHED MANUSCRIPT), 1970, PAGES 28-31.
C               --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--2, 1970, PAGES 57-74.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--82.6
C     ORIGINAL VERSION--DECEMBER  1977.
C     UPDATED         --DECEMBER  1981.
C     UPDATED         --MAY       1982.
C     UPDATED         --OCTOBER   2006. GENERALIZE TO THE CASE
C                                       WHERE R NOT EQUAL TO 1
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(P.LT.0.0 .OR. P.GT.1.0)THEN
        WRITE(ICOUT,1)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)P
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
    1 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO ',
     1       'SEMPPF IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
      IF(R.LE.0.0)THEN
        WRITE(ICOUT,2)
    2   FORMAT('***** ERROR--THE SECOD INPUT ARGUMENT ',
     1         'TO SEMPDF IS NON-POSITIVE')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)R
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
        GOTO9000
      ENDIF
C
      PHOLD=P
      IF(PHOLD.EQ.0.0)THEN
        PPF=-R
      ELSEIF(PHOLD.EQ.1.0)THEN
        PPF=R
      ELSE
        CONTINUE
        TOL=0.000001
        MAXIT=100
C
        XMIN=-R
        XMAX=R
C
        XMID=(XMIN+XMAX)/2.0
        XLOW=XMIN
        XUP=XMAX
        ICOUNT=0
C
  210   CONTINUE
        X=XMID
        CALL SEMCDF(X,R,PCALC)
        IF(PCALC.EQ.PHOLD)GOTO240
        IF(PCALC.GT.PHOLD)GOTO220
C
        XLOW=XMID
        XMID=(XMID+XUP)/2.0
        GOTO230
C
  220   CONTINUE
        XUP=XMID
        XMID=(XMID+XLOW)/2.0
C
  230   CONTINUE
        XDEL=ABS(XMID-XLOW)
        ICOUNT=ICOUNT+1
        IF(XDEL.LT.TOL.OR.ICOUNT.GT.MAXIT)GOTO240
        GOTO210
C
  240   CONTINUE
        PPF=XMID
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE SEMRAN(N,R,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE SEMI-CIRCULAR DISTRIBUTION.
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --R      = THE SINGLE PRECISION VALUE THAT
C                                DEFINES THE RADIUS
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 SEMI-CIRCULAR DISTRIBUTION
C             WITH MEAN = 0 AND STANDARD DEVIATION = ZZZ
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, SEMPPF
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--TOCHER, THE ART OF SIMULATION,
C                 1963, PAGES 14-15.
C               --HAMMERSLEY AND HANDSCOMB, MONTE CARLO METHODS,
C                 1964, PAGE 36.
C               --FILLIBEN, SIMPLE AND ROBUST LINEAR ESTIMATION
C                 OF THE LOCATION PARAMETER OF A SYMMETRIC
C                 DISTRIBUTION (UNPUBLISHED PH.D. DISSERTATION,
C                 PRINCETON UNIVERSITY), 1969, PAGE 230.
C               --FILLIBEN, 'THE PERCENT POINT FUNCTION',
C                 (UNPUBLISHED MANUSCRIPT), 1970, PAGES 28-31.
C               --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--2, 1970, PAGES ZZZ.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--82.6
C     ORIGINAL VERSION--JUNE      1978.
C     UPDATED         --DECEMBER  1981.
C     UPDATED         --MAY       1982.
C     UPDATED         --OCTOBER   2006. GENERALIZE TO CASES WHERE
C                                       R NOT EQUAL TO 1.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)THEN
        WRITE(ICOUT, 5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
    5 FORMAT('***** ERROR--THE REQUESTED NUMBER OF SEMI-CIRCULAR ',
     1       'RANDOM NUMBERS IS NON-POSITIVE')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8)
C
      IF(R.LE.0.0)THEN
        WRITE(ICOUT,8)
    8   FORMAT('***** ERROR--THE SHAPE PARAMETER, R, FOR THE ',
     1       'SEMI-CIRCULAR RANDOM NUMBERS IS NON-POSITIVE')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)R
   46   FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
C     GENERATE N UNIFORM (0,1) RANDOM NUMBERS;
C
      CALL UNIRAN(N,ISEED,X)
C
C     GENERATE N SEMI-CIRCULAR RANDOM NUMBERS
C     USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD.
C
      DO100I=1,N
      CALL SEMPPF(X(I),R,ATEMP)
      X(I)=ATEMP
  100 CONTINUE
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE SENSIT(X,Y,N,IWRITE,XIDTEM,STAT,IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE TEST SENSITIVITY
C              BETWEEN TWO VARIABLES.
C
C              THIS IS SPECIFICALLY FOR THE 2X2 CASE.  THAT IS,
C              EACH VARIABLE HAS TWO MUTUALLY EXCLUSIVE
C              CHOICES CODED AS 1 (FOR SUCCESS) OR 0 (FOR
C              FAILURE).  TEST SENSITIVITY IS DEFINED AS THE
C              CONDITIONAL PROBABILITY OF A POSITIVE TEST GiVEN
C              THAT THE DISEASE IS PRESENT.
C
C              A TYPICAL EXAMPLE WOULD BE WHERE VARIABLE ONE
C              DENOTES THE GROUND TRUTH AND A VALUE OF 1
C              INDICATES "PRESENT" AND A VALUE OF 0 INDICATES
C              "NOT PRESENT".  VARIABLE TWO REPRESENTS SOME TYPE
C              OF DETECTION DEVICE WHERE A VALUE OF 1 INDICATES
C              THE DEVICE DETECTED THE SPECIFIED OBJECT WHILE A
C              VALUE OF 0 INDICATES THAT THE OBJECT WAS NOT
C              DETECTED.  TEST SENSITIVITY IS THEN DEFINED AS
C              THE PROBABILITY OF DETECTING THE OBJECT GIVEN
C              THAT THE OBJECT IS ACTUALLY THERE.
C
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF
C                                (UNSORTED) OBSERVATIONS
C                                WHICH CONSTITUTE THE FIRST SET
C                                OF DATA.
C                     --Y      = THE SINGLE PRECISION VECTOR OF
C                                (UNSORTED) OBSERVATIONS
C                                WHICH CONSTITUTE THE SECOND SET
C                                OF DATA.
C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR X, OR EQUIVALENTLY,
C                                THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR Y.
C     OUTPUT ARGUMENTS--STAT   = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED TEST SENSITIVITY
C                                BETWEEN THE 2 SETS OF DATA
C                                IN THE INPUT VECTORS X AND Y.
C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
C             SAMPLE TEST SENSITIVITY 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--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTIUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2899
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2007/3
C     ORIGINAL VERSION--MARCH     2007.
C     UPDATED         --AUGUST    2007. IF 2X2 CASE, CHECK IF SUM
C                                       OF ENTRIES IS <= 4.  IN THIS
C                                       CASE, ASSUME WE HAVE RAW DATA
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISTEPN
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
      DIMENSION Y(*)
      DIMENSION XIDTEM(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='SENS'
      ISUBN2='IT  '
      IERROR='NO'
C
C
      IF(IBUGA3.EQ.'ON')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,51)
   51   FORMAT('***** AT THE BEGINNING OF SENSIT--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,52)IBUGA3
   52   FORMAT('IBUGA3 = ',A4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,53)N
   53   FORMAT('N = ',I8)
        CALL DPWRST('XXX','BUG ')
        DO55I=1,N
          WRITE(ICOUT,56)I,X(I),Y(I)
   56     FORMAT('I,X(I),Y(I) = ',I8,2G15.7)
          CALL DPWRST('XXX','BUG ')
   55   CONTINUE
      ENDIF
C
C               ********************************************
C               **  STEP 21--                             **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      ISTEPN='21'
      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(N.LT.2)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,1201)
 1201   FORMAT('***** ERROR IN THE TEST SENSITIVITY')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,1203)
 1203   FORMAT('      THE NUMBER OF OBSERVATIONS FOR THE RESPONSE ',
     1         'VARIABLES IS LESS THAN TWO')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,1205)N
 1205   FORMAT('SAMPLE SIZE = ',I8)
        CALL DPWRST('XXX','WRIT')
        IERROR='YES'
        GOTO9000
      ENDIF
C
C               ********************************************
C               **  STEP 22--                             **
C               **  CHECK THAT THE VARIABLES HAVE AT MOST **
C               **  TWO DISTINCT VALUES (1 INDICATES A    **
C               **  SUCCESS, 0 INDICATES A FAILURE).      **
C               ********************************************
C
      ISTEPN='22'
      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
C     NOTE: CHECK FOR SPECIAL CASE N = 2.  IN THIS CASE,
C           ASSUME WE HAVE A 2X2 TABLE OF COUNTS INSTEAD
C           OF RAW DATA.
C
      IF(N.EQ.2)THEN
        N11=INT(X(1)+0.5)
        N21=INT(X(2)+0.5)
        N12=INT(Y(1)+0.5)
        N22=INT(Y(2)+0.5)
C
C       CHECK IF ALL ENTRIES 0 OR 1. IF SO, ASSUME
C       RAW DATA CASE.
C
        IF((N11.EQ.0 .OR. N11.EQ.1) .AND.
     1     (N12.EQ.0 .OR. N12.EQ.1) .AND.
     1     (N21.EQ.0 .OR. N21.EQ.1) .AND.
     1     (N22.EQ.0 .OR. N22.EQ.1)) GOTO1349
C
        IF(N11.LT.0)THEN
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,1201)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,1311)
 1311     FORMAT('      ROW 1 COLUMN 1 OF THE COUNTS TABLE IS ',
     1           'NEGATIVE.')
          CALL DPWRST('XXX','BUG ')
        ELSEIF(N21.LT.0)THEN
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,1201)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,1321)
 1321     FORMAT('      ROW 2 COLUMN 1 OF THE COUNTS TABLE IS ',
     1           'NEGATIVE.')
          CALL DPWRST('XXX','BUG ')
        ELSEIF(N12.LT.0)THEN
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,1201)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,1331)
 1331     FORMAT('      ROW 1 COLUMN 2 OF THE COUNTS TABLE IS ',
     1           'NEGATIVE.')
          CALL DPWRST('XXX','BUG ')
        ELSEIF(N22.LT.0)THEN
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,1201)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,1341)
 1341     FORMAT('      ROW 2 COLUMN 2 OF THE COUNTS TABLE IS ',
     1           'NEGATIVE.')
          CALL DPWRST('XXX','BUG ')
        ENDIF
C
        AN11=REAL(N11)
        AN21=REAL(N21)
        AN12=REAL(N12)
        AN22=REAL(N22)
        STAT=AN11/(AN11+AN12)
        GOTO3000
      ENDIF
C
 1349 CONTINUE
C
      CALL DISTIN(X,N,IWRITE,XIDTEM,NDIST,IBUGA3,IERROR)
      IF(NDIST.EQ.1)THEN
        AVAL=XIDTEM(1)
        IF(ABS(AVAL).LE.0.5)THEN
          AVAL=0.0
        ELSE
          AVAL=1.0
        ENDIF
        DO2202I=1,N
          X(I)=1.0
 2202   CONTINUE
      ELSEIF(NDIST.EQ.2)THEN
        IF(XIDTEM(1).EQ.1.0 .OR. XIDTEM(2).EQ.1.0)THEN
          DO2203I=1,N
            IF(X(I).NE.1.0)X(I)=0.0
 2203     CONTINUE
        ELSE
          ATEMP1=MIN(XIDTEM(1),XIDTEM(2))
          ATEMP2=MAX(XIDTEM(1),XIDTEM(2))
          DO2208I=1,N
            IF(X(I).EQ.ATEMP1)X(I)=0.0
            IF(X(I).EQ.ATEMP2)X(I)=1.0
 2208     CONTINUE
        ENDIF
      ELSE
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,1201)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,2211)
 2211   FORMAT('      RESPONSE VARIABLE ONE SHOULD CONTAIN AT MOST')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,2213)
 2213   FORMAT('      TWO DISTINCT VALUES.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,2215)NDIST
 2215   FORMAT('      ',I8,' DISTINCT VALUES FOUND.')
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        GOTO9000
      ENDIF
C
      CALL DISTIN(Y,N,IWRITE,XIDTEM,NDIST,IBUGA3,IERROR)
      IF(NDIST.EQ.1)THEN
        AVAL=XIDTEM(1)
        IF(ABS(AVAL).LE.0.5)THEN
          AVAL=0.0
        ELSE
          AVAL=1.0
        ENDIF
        DO2302I=1,N
          Y(I)=1.0
 2302   CONTINUE
      ELSEIF(NDIST.EQ.2)THEN
        IF(XIDTEM(1).EQ.1.0 .OR. XIDTEM(2).EQ.1.0)THEN
          DO2303I=1,N
            IF(Y(I).NE.1.0)Y(I)=0.0
 2303     CONTINUE
        ELSE
          ATEMP1=MIN(XIDTEM(1),XIDTEM(2))
          ATEMP2=MAX(XIDTEM(1),XIDTEM(2))
          DO2308I=1,N
            IF(Y(I).EQ.ATEMP1)Y(I)=0.0
            IF(Y(I).EQ.ATEMP2)Y(I)=1.0
 2308     CONTINUE
        ENDIF
      ELSE
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,1201)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,2311)
 2311   FORMAT('      RESPONSE VARIABLE TWO SHOULD CONTAIN AT MOST')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,2313)
 2313   FORMAT('      TWO DISTINCT VALUES.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,2315)NDIST
 2315   FORMAT('      ',I8,' DISTINCT VALUES FOUND.')
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        GOTO9000
      ENDIF
C
      N11=0
      N12=0
      N21=0
      N22=0
      DO2410I=1,N
        IF(X(I).EQ.1.0 .AND. Y(I).EQ.1.0)THEN
          N11=N11+1
        ELSEIF(X(I).EQ.0.0 .AND. Y(I).EQ.0.0)THEN
          N22=N22+1
        ELSEIF(X(I).EQ.1.0 .AND. Y(I).EQ.0.0)THEN
          N12=N12+1
        ELSEIF(X(I).EQ.0.0 .AND. Y(I).EQ.1.0)THEN
          N21=N21+1
        ENDIF
 2410 CONTINUE
C
      STAT=REAL(N11)/REAL(N11+N12)
C
 3000 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' .OR. IWRITE.EQ.'NO')GOTO890
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,811)STAT
  811 FORMAT('THE TEST SENSITIVITY PROPORTION = ',G15.7)
      CALL DPWRST('XXX','BUG ')
  890 CONTINUE
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'ON')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END OF SENSIT--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9012)IBUGA3,IERROR
 9012   FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9013)N,N11,N12,N21,N22
 9013   FORMAT('N,N11,N12,N21,N22 = ',5I10)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9015)STAT
 9015   FORMAT('STAT = ',G15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      RETURN
      END
      SUBROUTINE SEQDIF(X,NX,IWRITE,Y,NY,ISTAT,
     1                  IBUGA3,ISUBRO,IERROR)
C
C     PURPOSE--COMPUTE SEQUENTIAL DIFFERENCE OF A VARIABLE--
C              Y(1) = X(2)-X(1)
C              Y(2) = X(3)-X(2)
C              Y(3) = X(4)-X(3)
C              ETC.
C     NOTE--CODE UPDATED TO ALSO ALLOW
C              SEQUENTIAL MEAN
C              SEQUENTIAL SUM
C              SEQUENTIAL MINIMUM
C              SEQUENTIAL MAXIMUM
C              SEQUENTIAL PRODUCT
C              SEQUENTIAL LOWER
C              SEQUENTIAL UPPER
C     NOTE--IT IS PERMISSIBLE TO HAVE THE OUTPUT VECTOR Y(.)
C           BEING IDENTICAL TO THE INPUT VECTOR X(.).
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--82.6
C     ORIGINAL VERSION--FEBRUARY  1979.
C     UPDATED         --APRIL     1979.
C     UPDATED         --JULY      1979.
C     UPDATED         --AUGUST    1981.
C     UPDATED         --MAY       1982.
C     UPDATED         --FEBRUARY  2016. SUPPORT FOR MEAN, SUM, PRODUCT,
C                                       MIN, AND MAX CASES
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 ISTAT
      CHARACTER*4 IWRITE
      CHARACTER*4 ISUBRO
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
      DIMENSION Y(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='SEQD'
      ISUBN2='IF  '
      IERROR='NO'
C
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'QDIF')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,51)
   51   FORMAT('***** AT THE BEGINNING OF SEQDIF--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,52)IBUGA3,IWRITE,ISTAT,NX
   52   FORMAT('IBUGA3,IWRITE,ISTAT,NX = ',3(A4,2X),I8)
        CALL DPWRST('XXX','BUG ')
        DO55I=1,NX
          WRITE(ICOUT,56)I,X(I)
   56     FORMAT('I,X(I) = ',I8,G15.7)
          CALL DPWRST('XXX','BUG ')
   55   CONTINUE
      ENDIF
C
C               **************************************
C               **  COMPUTE SEQUENTIAL DIFFERENCE.  **
C               **************************************
C
      NXM1=NX-1
      IF(NXM1.LT.1)THEN
        IERROR='YES'
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,151)
  151   FORMAT('***** ERROR IN SEQUENTIAL DIFFERENCE--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,152)
  152   FORMAT('      THE NUMBER OF OBSERVATIONS FOR THE RESPONSE ',
     1         'VARIABLE IS LESS THAN 2.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,157)NX
  157   FORMAT('      THE NUMBER OF OBSERVATIONS = ',I8,'.')
        CALL DPWRST('XXX','BUG ')
      ELSE
        IF(ISTAT.EQ.'MEAN')THEN
          DO110I=1,NXM1
            IP1=I+1
            Y(I)=(X(IP1)+X(I))/2.0
  110     CONTINUE
          NY=NXM1
        ELSEIF(ISTAT.EQ.'MINI')THEN
          DO120I=1,NXM1
            IP1=I+1
            Y(I)=MIN(X(IP1),X(I))
  120     CONTINUE
          NY=NXM1
        ELSEIF(ISTAT.EQ.'MAXI')THEN
          DO130I=1,NXM1
            IP1=I+1
            Y(I)=MAX(X(IP1),X(I))
  130     CONTINUE
          NY=NXM1
        ELSEIF(ISTAT.EQ.'SUM ')THEN
          DO140I=1,NXM1
            IP1=I+1
            Y(I)=X(IP1)+X(I)
  140     CONTINUE
          NY=NXM1
        ELSEIF(ISTAT.EQ.'PROD')THEN
          DO150I=1,NXM1
            IP1=I+1
            Y(I)=X(IP1)*X(I)
  150     CONTINUE
          NY=NXM1
        ELSEIF(ISTAT.EQ.'LOWE')THEN
          DO160I=1,NXM1
            Y(I)=X(I)
  160     CONTINUE
          NY=NXM1
        ELSEIF(ISTAT.EQ.'UPPE')THEN
          DO170I=1,NXM1
            IP1=I+1
            Y(I)=X(IP1)
  170     CONTINUE
          NY=NXM1
        ELSE
          DO100I=1,NXM1
            IP1=I+1
            Y(I)=X(IP1)-X(I)
  100     CONTINUE
          NY=NXM1
        ENDIF
      ENDIF
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'QDIF')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END       OF SEQDIF--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9013)IERROR,NX,NY
 9013   FORMAT('IERROR,NX,NY = ',A4,2X,2I8)
        CALL DPWRST('XXX','BUG ')
        DO9015I=1,NX
          WRITE(ICOUT,9016)I,X(I),Y(I)
 9016     FORMAT('I,X(I),Y(I) = ',I8,2G15.7)
          CALL DPWRST('XXX','BUG ')
 9015   CONTINUE
      ENDIF
C
      RETURN
      END
      SUBROUTINE SEQDI2(X,XGROUP,NX,IWRITE,Y,YGROUP,NY,ISTAT,
     1                  XDIST,XTEMP,
     1                  IBUGA3,ISUBRO,IERROR)
C
C     PURPOSE--THIS IS A VARIANT OF THE SEQDIF (SEQUENTIAL DIFFERENCE)
C              ROUTINE.  THE DISTINCTION IS THAT THIS ROUTINE INCLUDES
C              A GROUP-ID VARIABLE.  THAT IS, THE SEQUENTIAL DIFFERENCE
C              WILL BE COMPUTED WITHIN EACH GROUP.  NOTE THAT ALTHOUGH
C              THE DATA DO NOT NEED TO BE PRE-SORTED BY GROUP, THE ORDER
C              WITHIN A GROUP WILL BE MAINTAINED.  THE COMMAND IS
C
C                  LET Y YGROUP = SEQUENTIAL DIFFERENCE X XGROUP
C
C     NOTE--CODE ALSO SUPPORTS THE FOLLOWING
C              SEQUENTIAL MEAN
C              SEQUENTIAL SUM
C              SEQUENTIAL MINIMUM
C              SEQUENTIAL MAXIMUM
C              SEQUENTIAL PRODUCT
C              SEQUENTIAL LOWER
C              SEQUENTIAL UPPER
C     NOTE--IT IS PERMISSIBLE TO HAVE THE OUTPUT VECTOR Y(.)
C           BEING IDENTICAL TO THE INPUT VECTOR X(.).
C     WRITTEN BY--ALAN HECKERT
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2899
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2016.02
C     ORIGINAL VERSION--FEBRUARY  2016.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 ISTAT
      CHARACTER*4 IWRITE
      CHARACTER*4 ISUBRO
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
      DIMENSION XGROUP(*)
      DIMENSION Y(*)
      DIMENSION YGROUP(*)
      DIMENSION XDIST(*)
      DIMENSION XTEMP(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='SEQD'
      ISUBN2='I2  '
      IERROR='NO'
C
      NY=0
C
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'QDI2')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,51)
   51   FORMAT('***** AT THE BEGINNING OF SEQDI2--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,52)IBUGA3,ISTAT,NX
   52   FORMAT('IBUGA3,ISTAT,NX = ',2(A4,2X),I8)
        CALL DPWRST('XXX','BUG ')
        DO55I=1,NX
          WRITE(ICOUT,56)I,XGROUP(I),X(I)
   56     FORMAT('I,XGROUP(I),X(I) = ',I8,2G15.7)
          CALL DPWRST('XXX','BUG ')
   55   CONTINUE
      ENDIF
C
C               **************************************
C               **  COMPUTE SEQUENTIAL DIFFERENCE.  **
C               **************************************
C
      IF(NX.LT.2)THEN
        IERROR='YES'
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,151)
  151   FORMAT('***** ERROR IN GROUP SEQUENTIAL DIFFERENCE--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,152)
  152   FORMAT('      THE NUMBER OF OBSERVATIONS FOR THE RESPONSE ',
     1         'VARIABLE IS LESS THAN 2.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,157)NX
  157   FORMAT('      THE NUMBER OF OBSERVATIONS = ',I8,'.')
        CALL DPWRST('XXX','BUG ')
      ELSE
C
C       DETERMINE THE DISTINCT GROUPS
C
        CALL DISTIN(XGROUP,NX,IWRITE,XDIST,NXDIST,IBUGA3,IERROR)
        IF(NX.EQ.NXDIST)THEN
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,151)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,201)
  201     FORMAT('      THE NUMBER OF OBSERVATIONS IS EQUAL TO THE ',
     1           'NUMBER OF GROUPS.')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,203)
  203     FORMAT('      NOTHING DONE.')
          CALL DPWRST('XXX','BUG ')
          IERROR='YES'
          GOTO9000
        ENDIF
C
        DO300K=1,NXDIST
          NTEMP=0
          HOLD=XDIST(K)
          DO301J=1,NX
            IF(XGROUP(J).EQ.HOLD)THEN
              NTEMP=NTEMP+1
              XTEMP(NTEMP)=X(J)
            ENDIF
  301     CONTINUE
C
          NXM1=NTEMP-1
          IF(NXM1.GE.1)THEN
            IF(ISTAT.EQ.'MEAN')THEN
              DO410I=1,NXM1
                IP1=I+1
                NY=NY+1
                Y(NY)=(XTEMP(IP1)+XTEMP(I))/2.0
                YGROUP(NY)=REAL(K)
  410         CONTINUE
            ELSEIF(ISTAT.EQ.'MINI')THEN
              DO420I=1,NXM1
                IP1=I+1
                NY=NY+1
                Y(NY)=MIN(XTEMP(IP1),XTEMP(I))
                YGROUP(NY)=REAL(K)
  420         CONTINUE
            ELSEIF(ISTAT.EQ.'MAXI')THEN
              DO430I=1,NXM1
                IP1=I+1
                NY=NY+1
                Y(NY)=MAX(XTEMP(IP1),XTEMP(I))
                YGROUP(NY)=REAL(K)
  430         CONTINUE
            ELSEIF(ISTAT.EQ.'SUM ')THEN
              DO440I=1,NXM1
                IP1=I+1
                NY=NY+1
                Y(NY)=XTEMP(IP1)+XTEMP(I)
                YGROUP(NY)=REAL(K)
  440         CONTINUE
            ELSEIF(ISTAT.EQ.'PROD')THEN
              DO450I=1,NXM1
                IP1=I+1
                NY=NY+1
                Y(NY)=XTEMP(IP1)*XTEMP(I)
                YGROUP(NY)=REAL(K)
  450         CONTINUE
            ELSEIF(ISTAT.EQ.'DIFF')THEN
              DO460I=1,NXM1
                IP1=I+1
                NY=NY+1
                Y(NY)=XTEMP(IP1)-XTEMP(I)
                YGROUP(NY)=REAL(K)
  460         CONTINUE
            ELSEIF(ISTAT.EQ.'LOWE')THEN
              DO470I=1,NXM1
                IP1=I+1
                NY=NY+1
                Y(NY)=XTEMP(I)
                YGROUP(NY)=REAL(K)
  470         CONTINUE
            ELSEIF(ISTAT.EQ.'UPPE')THEN
              DO480I=1,NXM1
                IP1=I+1
                NY=NY+1
                Y(NY)=XTEMP(IP1)
                YGROUP(NY)=REAL(K)
  480         CONTINUE
            ENDIF
          ENDIF
  300   CONTINUE
      ENDIF
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
C
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'QDI2')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END       OF SEQDI2--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9013)IERROR,NX,NY
 9013   FORMAT('IERROR,NX,NY = ',A4,2X,2I8)
        CALL DPWRST('XXX','BUG ')
        DO9015I=1,NY
          WRITE(ICOUT,9016)I,YGROUP(I),Y(I)
 9016     FORMAT('I,YGROUP(I),Y(I) = ',I8,2G15.7)
          CALL DPWRST('XXX','BUG ')
 9015   CONTINUE
      ENDIF
C
      RETURN
      END
      SUBROUTINE SETARI(Y1,Y2,N1,N2,IACASE,IWRITE,
     1                  Y3,Y4,N3,SCAL3,ITYP3,
     1                  Y1HOLD,Y2HOLD,
     1                  IBUGA3,ISUBRO,IERROR)
C
C     PURPOSE--CARRY OUT SET        ARITHMETIC OPERATIONS
C              OF THE REAL DATA IN Y1 AND Y2.
C
C     OPERATIONS--UNION
C                 INTERSECTION
C                 COMPLEMENT
C                 CARDINALITY
C                 CARTESIAN PRODUCT
C                 ELEMENTS (DISTINCT)
C
C     INPUT  ARGUMENTS--Y1 (REAL)
C                     --Y2 (REAL)
C     OUTPUT ARGUMENTS--Y3 (REAL)
C                       SCAL3
C                       ITYP3
C                     --Y4 (REAL)
C
C     NOTE--IT IS NOT PERMISSIBLE TO HAVE THE OUTPUT SETS Y3(.) & Y4(.)
C           BEING IDENTICAL TO THE INPUT SETS   Y1(.) OR Y2(.).
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--87/9
C     ORIGINAL VERSION--AUGUST   1987.
C     UPDATED         --JUNE      1990. TEMPORARY ARRAYS TO GARBAGE COMMON
C     UPDATED         --SEPTEMBER 1993. FIX CARTESIAN PRODUCT (ALAN)
C     UPDATED         --JULY      2019. MOVE CREATION OF SCRATCH
C                                       STORAGE TO CALLING ROUTINE
C                                       SOME RECODING FOR BETTER
C                                       READABILITY (BUT NO SUBSTANATIVE
C                                       CHANGE)
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IACASE
      CHARACTER*4 IWRITE
      CHARACTER*4 ITYP3
      CHARACTER*4 IBUGA3
      CHARACTER*4 ISUBRO
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOPA.INC'
C
      DIMENSION Y1(*)
      DIMENSION Y2(*)
      DIMENSION Y3(*)
      DIMENSION Y4(*)
      DIMENSION Y1HOLD(*)
      DIMENSION Y2HOLD(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='SETA'
      ISUBN2='RI  '
      IERROR='NO'
      SCAL3=(-999.0)
      ITYP3='VECT'
C
      TOL=0.00001
C
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'TARI')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,51)
   51   FORMAT('***** AT THE BEGINNING OF SETARI--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,52)IBUGA3,ISUBRO,IACASE,IWRITE,N1
   52   FORMAT('IBUGA3,ISUBRO,IACASE,IWRITE,N1 = ',4(A4,2X),I8)
        CALL DPWRST('XXX','BUG ')
        DO55I=1,N1
          WRITE(ICOUT,56)I,Y1(I),Y2(I)
   56     FORMAT('I,Y1(I),Y2(I) = ',I8,2G15.7)
          CALL DPWRST('XXX','BUG ')
   55   CONTINUE
      ENDIF
C
C               **************************************************
C               **  CARRY OUT SET        ARITHMETIC OPERATIONS  **
C               **************************************************
C
C               ********************************************
C               **  STEP 11--                             **
C               **  CHECK NUMBER OF INPUT OBSERVATIONS.   **
C               ********************************************
C
      IF(N1.LT.1 .OR. N2.LT.1)THEN
        IF(N1.GT.1 .AND.
     1    (IACASE.EQ.'SECA' .OR. IACASE.EQ.'SEEL'))GOTO1190
        IERROR='YES'
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,1151)
 1151   FORMAT('***** ERROR IN SET ARITHMETIC (SETARI)--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,1152)
 1152   FORMAT('      THE NUMBER OF OBSERVATIONS IN THE VARIABLE ',
     1         'FOR WHICH')
        CALL DPWRST('XXX','BUG ')
        IF(IACASE.EQ.'SEUN')THEN
          WRITE(ICOUT,1161)
 1161     FORMAT('      THE  SET UNION  IS TO BE COMPUTED')
          CALL DPWRST('XXX','BUG ')
        ELSEIF(IACASE.EQ.'SEIN')THEN
          WRITE(ICOUT,1162)
 1162     FORMAT('      THE  SET INTERSECTION  IS TO BE COMPUTED')
          CALL DPWRST('XXX','BUG ')
        ELSEIF(IACASE.EQ.'SECO')THEN
          WRITE(ICOUT,1163)
 1163     FORMAT('      THE  SET COMPLEMENT  IS TO BE COMPUTED')
          CALL DPWRST('XXX','BUG ')
        ELSEIF(IACASE.EQ.'SECA')THEN
          WRITE(ICOUT,1164)
 1164     FORMAT('      THE  SET CARDINALITY  IS TO BE COMPUTED')
          CALL DPWRST('XXX','BUG ')
        ELSEIF(IACASE.EQ.'SECP')THEN
          WRITE(ICOUT,1165)
 1165     FORMAT('      THE  SET CARTESIAN PRODUCT  IS TO BE COMPUTED')
          CALL DPWRST('XXX','BUG ')
        ELSEIF(IACASE.EQ.'SEEL')THEN
          WRITE(ICOUT,1166)
 1166     FORMAT('      THE  SET ELEMENTS  IS TO BE COMPUTED')
          CALL DPWRST('XXX','BUG ')
        ENDIF
        WRITE(ICOUT,1181)
 1181   FORMAT('      MUST BE 1 OR LARGER.  SUCH WAS NOT THE ',
     1         'CASE HERE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,1183)N1
 1183   FORMAT('      THE NUMBER OF OBSERVATIONS = ',I8,'.')
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
 1190 CONTINUE
C
C               *********************************
C               **  STEP 12--                  **
C               **  BRANCH TO THE PROPER CASE  **
C               *********************************
C
      IF(IACASE.EQ.'SEUN')THEN
C
C               *********************************************
C               **  STEP 21--                              **
C               **  TREAT THE SET        UNION       CASE  **
C               *********************************************
C
        K=1
        Y3(K)=Y1(K)
C
        IF(N1.GT.1)THEN
          DO2110I=1,N1
            TARGET=Y1(I)
            DO2120J=1,K
              Y3JL=Y3(J)-TOL
              Y3JU=Y3(J)+TOL
              IF(Y3JL.LE.TARGET.AND.TARGET.LE.Y3JU)GOTO2110
 2120       CONTINUE
            K=K+1
            Y3(K)=TARGET
 2110     CONTINUE
        ENDIF
C
        DO2130I=1,N2
          TARGET=Y2(I)
          DO2140J=1,K
            Y3JL=Y3(J)-TOL
            Y3JU=Y3(J)+TOL
            IF(Y3JL.LE.TARGET.AND.TARGET.LE.Y3JU)GOTO2130
 2140     CONTINUE
          K=K+1
          Y3(K)=TARGET
 2130   CONTINUE
C
        ITYP3='VECT'
        N3=K
      ELSEIF(IACASE.EQ.'SEIN')THEN
C
C               *********************************************
C               **  STEP 22--                              **
C               **  TREAT THE SET        INTERSECTION CASE **
C               *********************************************
C
        K=0
C
        DO2210I=1,N1
          TARGET=Y1(I)
          DO2220J=1,N2
            Y2JL=Y2(J)-TOL
            Y2JU=Y2(J)+TOL
            IF(Y2JL.LE.TARGET.AND.TARGET.LE.Y2JU)GOTO2215
 2220     CONTINUE
          GOTO2210
 2215     CONTINUE
          K=K+1
          Y3(K)=TARGET
 2210   CONTINUE
C
        ITYP3='VECT'
        N3=K
      ELSEIF(IACASE.EQ.'SECO')THEN
C
C               ************************************************
C               **  STEP 23--                                 **
C               **  TREAT THE SET        COMPLEMENT     CASE  **
C               ************************************************
C
        K=0
C
        DO2310I=1,N2
          TARGET=Y2(I)
          DO2320J=1,N1
            Y1JL=Y1(J)-TOL
            Y1JU=Y1(J)+TOL
            IF(Y1JL.LE.TARGET.AND.TARGET.LE.Y1JU)GOTO2310
 2320     CONTINUE
          K=K+1
          Y3(K)=TARGET
 2310   CONTINUE
C
        ITYP3='VECT'
        N3=K
      ELSEIF(IACASE.EQ.'SECA')THEN
C
C               ************************************************
C               **  STEP 24--                                 **
C               **  TREAT THE SET        CARDINALITY    CASE  **
C               ************************************************
C
        K=1
        Y3(K)=Y1(K)
C
        IF(N1.GT.1)THEN
          DO2410I=1,N1
            TARGET=Y1(I)
            DO2420J=1,K
              Y3JL=Y3(J)-TOL
              Y3JU=Y3(J)+TOL
              IF(Y3JL.LE.TARGET.AND.TARGET.LE.Y3JU)GOTO2410
 2420       CONTINUE
            K=K+1
 2410     CONTINUE
        ENDIF
        SCAL3=K
C
        ITYP3='SCAL'
        N3=1
      ELSEIF(IACASE.EQ.'SECP')THEN
C
C               ***************************************************
C               **  STEP 25--                                    **
C               **  TREAT THE SET        CARTESIAN PRODUCT CASE  **
C               ***************************************************
C
        K1=1
        Y1HOLD(K1)=Y1(K1)
        IF(N1.GT.1)THEN
          DO2510I=1,N1
            TARGET=Y1(I)
            DO2520J=1,K1
              Y1JL=Y1HOLD(J)-TOL
              Y1JU=Y1HOLD(J)+TOL
              IF(Y1JL.LE.TARGET.AND.TARGET.LE.Y1JU)GOTO2510
 2520       CONTINUE
            K1=K1+1
            Y1HOLD(K1)=TARGET
 2510     CONTINUE
        ENDIF
C
CCCCC   THE FOLLOWING SECTION WAS CORRECTED (ALAN) SEPTEMBER 1993
        K2=1
        Y2HOLD(K2)=Y2(K2)
        IF(N2.GT.1)THEN
          DO2530I=1,N2
            TARGET=Y2(I)
            DO2540J=1,K2
              Y2JL=Y2HOLD(J)-TOL
              Y2JU=Y2HOLD(J)+TOL
              IF(Y2JL.LE.TARGET.AND.TARGET.LE.Y2JU)GOTO2530
 2540       CONTINUE
            K2=K2+1
            Y2HOLD(K2)=TARGET
 2530     CONTINUE
        ENDIF
C
CCCCC   THE FOLLOWING SECTION WAS CORRECTED   (ALAN) SEPTEMBER 1993
        K=0
        DO2550I=1,K1
          DO2560J=1,K2
            K=K+1
            Y3(K)=Y1HOLD(I)
            Y4(K)=Y2HOLD(J)
 2560     CONTINUE
 2550   CONTINUE
C
        ITYP3='VECT'
        N3=K
      ELSEIF(IACASE.EQ.'SEEL')THEN
C
C               *******************************************************
C               **  STEP 26--                                        **
C               **  TREAT THE SET        ELEMENTS (DISTINCT)   CASE  **
C               *******************************************************
C
        K=1
        Y3(K)=Y1(K)
C
        IF(N1.GT.1)THEN
          DO2610I=1,N1
            TARGET=Y1(I)
            DO2620J=1,K
              Y3JL=Y3(J)-TOL
              Y3JU=Y3(J)+TOL
              IF(Y3JL.LE.TARGET.AND.TARGET.LE.Y3JU)GOTO2610
 2620       CONTINUE
            K=K+1
            Y3(K)=TARGET
 2610     CONTINUE
        ENDIF
C
        ITYP3='VECT'
        N3=K
      ELSE
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,1211)
 1211   FORMAT('***** INTERNAL ERROR IN SETARI--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,1212)
 1212   FORMAT('      IACASE NOT EQUAL TO')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,1213)
 1213   FORMAT('      SEUN, SEIN, SECO, SECA, SECP OR SEEL')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,1215)
 1215   FORMAT('      IACASE = ',A4)
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        GOTO9000
      ENDIF
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
C
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'TARI')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END       OF SETARI--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9017)N1,N2,N3
 9017   FORMAT('N1,N2,N3 = ',3I8)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9018)SCAL3,ITYP3,IERROR
 9018   FORMAT('SCAL3,ITYP3,IERROR = ',G15.7,2(2X,A4))
        CALL DPWRST('XXX','BUG ')
        IF(ITYP3.NE.'SCAL')THEN
          DO9021I=1,N1
            WRITE(ICOUT,9022)I,Y1(I)
 9022       FORMAT('I,Y1(I) = ',I8,G15.7)
            CALL DPWRST('XXX','BUG ')
 9021     CONTINUE
          DO9031I=1,N2
            WRITE(ICOUT,9032)I,Y2(I)
 9032       FORMAT('I,Y2(I) = ',I8,G15.7)
            CALL DPWRST('XXX','BUG ')
 9031     CONTINUE
          DO9041I=1,N3
            WRITE(ICOUT,9042)I,Y3(I),Y4(I)
 9042       FORMAT('I,Y3(I),Y4(I) = ',I8,2G15.7)
            CALL DPWRST('XXX','BUG ')
 9041     CONTINUE
        ENDIF
      ENDIF
C
      RETURN
      END
      REAL FUNCTION SGAMMA(ISEED,A)
CCCCC REAL FUNCTION SGAMMA(IR,A)
C                                                                       SGA   10
C**********************************************************************CSGA   20
C**********************************************************************CSGA   30
C                                                                      CSGA   40
C                                                                      CSGA   50
C     (STANDARD-)  G A M M A  DISTRIBUTION                             CSGA   60
C                                                                      CSGA   70
C                                                                      CSGA   80
C**********************************************************************CSGA   90
C**********************************************************************CSGA  100
C                                                                      CSGA  110
C               PARAMETER  A >= 1.0  ]                                 CSGA  120
C                                                                      CSGA  130
C**********************************************************************CSGA  140
C                                                                      CSGA  150
C     FOR DETAILS SEE:                                                 CSGA  160
C                                                                      CSGA  170
C               AHRENS, J.H. AND DIETER, U.                            CSGA  180
C               GENERATING GAMMA VARIATES BY A                         CSGA  190
C               MODIFIED REJECTION TECHNIQUE.                          CSGA  200
C               COMM. ACM, 25,1 (JAN. 1982), 47 - 54.                  CSGA  210
C                                                                      CSGA  220
C     STEP NUMBERS CORRESPOND TO ALGORITHM 'GD' IN THE ABOVE PAPER     CSGA  230
C                                 (STRAIGHTFORWARD IMPLEMENTATION)     CSGA  240
C                                                                      CSGA  250
C**********************************************************************CSGA  260
C                                                                      CSGA  270
C               PARAMETER  0.0 < A < 1.0  ]                            CSGA  280
C                                                                      CSGA  290
C**********************************************************************CSGA  300
C                                                                      CSGA  310
C     FOR DETAILS SEE:                                                 CSGA  320
C                                                                      CSGA  330
C               AHRENS, J.H. AND DIETER, U.                            CSGA  340
C               COMPUTER METHODS FOR SAMPLING FROM GAMMA,              CSGA  350
C               BETA, POISSON AND BINOMIAL DISTRIBUTIONS.              CSGA  360
C               COMPUTING, 12 (1974), 223 - 246.                       CSGA  370
C                                                                      CSGA  380
C     (ADAPTED IMPLEMENTATION OF ALGORITHM 'GS' IN THE ABOVE PAPER)    CSGA  390
C                                                                      CSGA  400
C**********************************************************************CSGA  410
C                                                                       SGA  420
C
C     INPUT:  IR=CURRENT STATE OF BASIC RANDOM NUMBER GENERATOR
C             A =PARAMETER (MEAN) OF THE STANDARD GAMMA DISTRIBUTION
C     OUTPUT: SGAMMA = SAMPLE FROM THE GAMMA-(A)-DISTRIBUTION
C
C     COEFFICIENTS Q(K) - FOR Q0 = SUM(Q(K)*A**(-K))
C     COEFFICIENTS A(K) - FOR Q = Q0+(T*T/2)*SUM(A(K)*V**K)
C     COEFFICIENTS E(K) - FOR EXP(Q)-1 = SUM(E(K)*Q**K)
C
C  MAY, 2003: SOME MODIFICATIONS MADE IN ORDER TO INCORPORATE
C             INTO DATAPLOT.
C
C             1) REPLACE CALLS TO SUNIF WITH CALLS TO DATAPLOT
C                UNIFORM RANDOM NUMBER ROUTINE "UNIRAN".
C             2) REPLACE IR WITH ISEED
C             3) REPLACE CALLS TO "SNORM" WITH "NORRAN"
C
C  JANUARY, 2005: THERE WAS A BUG IF GAMMA RAND NUMBER ROUTINE
C                 CALLED MORE THAN ONCE.  NEED TO RESET VALUE OF
C                 AA AND AAA TO 0.  DO THIS BY STORING IN COMMON
C                 AND HAVING CALLING ROUTINE RESET.
C
      REAL XTEMP(1)
C
      COMMON/SGAMM/AA,AAA
C
      DATA Q1,Q2,Q3,Q4,Q5,Q6,Q7 /.04166669,.02083148,
     ,.00801191,.00144121,-.00007388,.00024511,.00024240/
      DATA A1,A2,A3,A4,A5,A6,A7 /.3333333,-.2500030,
     ,.2000062,-.1662921,.1423657,-.1367177,.1233795/
      DATA E1,E2,E3,E4,E5 /1.,.4999897,.1668290,.0407753,.0102930/
C
C     PREVIOUS A PRE-SET TO ZERO - AA IS A', AAA IS A"
C     SQRT32 IS THE SQUAREROOT OF 32 = 5.656854249492380
C
CCCCC DATA AA /0.0/, AAA /0.0/, SQRT32 /5.656854/
      DATA SQRT32 /5.656854/
C
      SI=0.0
      Q0=0.0
      C=0.0
      B=0.0
      S=0.0
      D=0.0
      S2=0.0
C
      IF (A .EQ. AA) GO TO 1
      IF (A .LT. 1.0) GO TO 12
C
C     STEP  1:  RECALCULATIONS OF S2,S,D IF A HAS CHANGED
C
      AA=A
      S2=A-0.5
      S=SQRT(S2)
      D=SQRT32-12.0*S
C
C     STEP  2:  T=STANDARD NORMAL DEVIATE,
C               X=(S,1/2)-NORMAL DEVIATE.
C               IMMEDIATE ACCEPTANCE (I)
C
CCC1  T=SNORM(IR)
   1  CONTINUE
      NTEMP=1
      CALL NORRAN(NTEMP,ISEED,XTEMP)
      T=XTEMP(1)
      X=S+0.5*T
      SGAMMA=X*X
      IF (T .GE. 0.0) RETURN
C
C     STEP  3:  U= 0,1 -UNIFORM SAMPLE. SQUEEZE ACCEPTANCE (S)
C
CCCCC U=SUNIF(IR)
      NTEMP=1
      CALL UNIRAN(NTEMP,ISEED,XTEMP)
      U=XTEMP(1)
      IF (D*U .LE. T*T*T) RETURN
C
C     STEP  4:  RECALCULATIONS OF Q0,B,SI,C IF NECESSARY
C
      IF (A .EQ. AAA) GO TO 4
      AAA=A
      R=1.0/A
      Q0=((((((Q7*R+Q6)*R+Q5)*R+Q4)*R+Q3)*R+Q2)*R+Q1)*R
C
C               APPROXIMATION DEPENDING ON SIZE OF PARAMETER A
C               THE CONSTANTS IN THE EXPRESSIONS FOR B, SI AND
C               C WERE ESTABLISHED BY NUMERICAL EXPERIMENTS
C
      IF (A .LE. 3.686) GO TO 3
      IF (A .LE. 13.022) GO TO 2
C
C               CASE 3:  A .GT. 13.022
C
      B=1.77
      SI=.75
      C=.1515/S
      GO TO 4
C
C               CASE 2:  3.686 .LT. A .LE. 13.022
C
   2  B=1.654+.0076*S2
      SI=1.68/S+.275
      C=.062/S+.024
      GO TO 4
C
C               CASE 1:  A .LE. 3.686
C
   3  B=.463+S-.178*S2
      SI=1.235
      C=.195/S-.079+.016*S
C
C     STEP  5:  NO QUOTIENT TEST IF X NOT POSITIVE
C
   4  IF (X .LE. 0.0) GO TO 7
C
C     STEP  6:  CALCULATION OF V AND QUOTIENT Q
C
      V=T/(S+S)
      IF (ABS(V) .LE. 0.25) GO TO 5
      Q=Q0-S*T+0.25*T*T+(S2+S2)*LOG(1.0+V)
      GO TO 6
   5  Q=Q0+0.5*T*T*((((((A7*V+A6)*V+A5)*V+A4)*V+A3)*V+A2)*V+A1)*V
C
C     STEP  7:  QUOTIENT ACCEPTANCE (Q)
C
   6  IF (LOG(1.0-U) .LE. Q) RETURN
C
C     STEP  8:  E=STANDARD EXPONENTIAL DEVIATE
C               U= 0,1 -UNIFORM DEVIATE
C               T=(B,SI)-DOUBLE EXPONENTIAL (LAPLACE) SAMPLE
C
CCC7  E=SEXPO(IR)
   7  CONTINUE
      NTEMP=1
      CALL EXPRAN(NTEMP,ISEED,XTEMP)
      E=XTEMP(1)
      CALL UNIRAN(NTEMP,ISEED,XTEMP)
CCCCC U=SUNIF(IR)
      U=XTEMP(1)
      U=U+U-1.0
      T=B+SIGN(SI*E,U)
C
C     STEP  9:  REJECTION IF T .LT. TAU(1) = -.71874483771719
C
      IF (T .LT. (-.7187449)) GO TO 7
C
C     STEP 10:  CALCULATION OF V AND QUOTIENT Q
C
      V=T/(S+S)
      IF (ABS(V) .LE. 0.25) GO TO 8
      Q=Q0-S*T+0.25*T*T+(S2+S2)*LOG(1.0+V)
      GO TO 9
   8  Q=Q0+0.5*T*T*((((((A7*V+A6)*V+A5)*V+A4)*V+A3)*V+A2)*V+A1)*V
C
C     STEP 11:  HAT ACCEPTANCE (H) (IF Q NOT POSITIVE GO TO STEP 8)
C
   9  IF (Q .LE. 0.0) GO TO 7
      IF (Q .LE. 0.5) GO TO 10
      W=EXP(Q)-1.0
      GO TO 11
  10  W=((((E5*Q+E4)*Q+E3)*Q+E2)*Q+E1)*Q
C
C               IF T IS REJECTED, SAMPLE AGAIN AT STEP 8
C
  11  IF (C*ABS(U) .GT. W*EXP(E-0.5*T*T)) GO TO 7
      X=S+0.5*T
      SGAMMA=X*X
      RETURN
C
C     ALTERNATE METHOD FOR PARAMETERS A BELOW 1  (.3678794=EXP(-1.))
C
  12  AA=0.0
      B=1.0+.3678794*A
CC13  P=B*SUNIF(IR)
  13  CONTINUE
      NTEMP=1
      CALL UNIRAN(NTEMP,ISEED,XTEMP)
      P=B*XTEMP(1)
      IF (P .GE. 1.0) GO TO 14
      SGAMMA=EXP(LOG(P)/A)
CCCCC IF (SEXPO(IR) .LT. SGAMMA) GO TO 13
      NTEMP=1
      CALL EXPRAN(NTEMP,ISEED,XTEMP)
      IF (XTEMP(1) .LT. SGAMMA) GO TO 13
      RETURN
  14  SGAMMA=-LOG((B-P)/A)
CCCCC IF (SEXPO(IR) .LT. (1.0-A)*LOG(SGAMMA)) GO TO 13
      NTEMP=1
      CALL EXPRAN(NTEMP,ISEED,XTEMP)
      IF (XTEMP(1) .LT. (1.0-A)*LOG(SGAMMA)) GO TO 13
      RETURN
      END
      SUBROUTINE SGECO(A,LDA,N,IPVT,RCOND,Z)
C***BEGIN PROLOGUE  SGECO
C***DATE WRITTEN   780814   (YYMMDD)
C***REVISION DATE  820801   (YYMMDD)
C***CATEGORY NO.  D2A1
C***KEYWORDS  CONDITION,FACTOR,LINEAR ALGEBRA,LINPACK,MATRIX
C***AUTHOR  MOLER, C. B., (U. OF NEW MEXICO)
C***PURPOSE  Factors a real matrix by Gaussian elimination and estimates
C            the condition number of the matrix.
C***DESCRIPTION
C
C     SGECO factors a real matrix by Gaussian elimination
C     and estimates the condition of the matrix.
C
C     If  RCOND  is not needed, SGEFA is slightly faster.
C     To solve  A*X = B , follow SGECO by SGESL.
C     To compute  INVERSE(A)*C , follow SGECO by SGESL.
C     To compute  DETERMINANT(A) , follow SGECO by SGEDI.
C     To compute  INVERSE(A) , follow SGECO by SGEDI.
C
C     On Entry
C
C        A       REAL(LDA, N)
C                the matrix to be factored.
C
C        LDA     INTEGER
C                the leading dimension of the array  A .
C
C        N       INTEGER
C                the order of the matrix  A .
C
C     On Return
C
C        A       an upper triangular matrix and the multipliers
C                which were used to obtain it.
C                The factorization can be written  A = L*U , where
C                L  is a product of permutation and unit lower
C                triangular matrices and  U  is upper triangular.
C
C        IPVT    INTEGER(N)
C                an integer vector of pivot indices.
C
C        RCOND   REAL
C                an estimate of the reciprocal condition of  A .
C                For the system  A*X = B , relative perturbations
C                in  A  and  B  of size  EPSILON  may cause
C                relative perturbations in  X  of size  EPSILON/RCOND .
C                If  RCOND  is so small that the logical expression
C                           1.0 + RCOND .EQ. 1.0
C                is true, then  A  may be singular to working
C                precision.  In particular,  RCOND  is zero  if
C                exact singularity is detected or the estimate
C                underflows.
C
C        Z       REAL(N)
C                a work vector whose contents are usually unimportant.
C                If  A  is close to a singular matrix, then  Z  is
C                an approximate null vector in the sense that
C                NORM(A*Z) = RCOND*NORM(A)*NORM(Z) .
C
C     LINPACK.  This version dated 08/14/78 .
C     Cleve Moler, University of New Mexico, Argonne National Lab.
C
C     Subroutines and Functions
C
C     LINPACK SGEFA
C     BLAS SAXPY,SDOT,SSCAL,SASUM
C     Fortran ABS,AMAX1,SIGN
C***REFERENCES  DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W.,
C                 *LINPACK USERS  GUIDE*, SIAM, 1979.
C***ROUTINES CALLED  SASUM,SAXPY,SDOT,SGEFA,SSCAL
C***END PROLOGUE  SGECO
      INTEGER LDA,N,IPVT(*)
      REAL A(LDA,*),Z(*)
      REAL RCOND
C
      REAL SDOT,EK,T,WK,WKM
      REAL ANORM,S,SASUM,SM,YNORM
      INTEGER INFO,J,K,KB,KP1,L
C
C     COMPUTE 1-NORM OF A
C
C***FIRST EXECUTABLE STATEMENT  SGECO
      ANORM = 0.0E0
      DO 10 J = 1, N
         ANORM = AMAX1(ANORM,SASUM(N,A(1,J),1))
   10 CONTINUE
C
C     FACTOR
C
      CALL SGEFA(A,LDA,N,IPVT,INFO)
C
C     RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) .
C     ESTIMATE = NORM(Z)/NORM(Y) WHERE  A*Z = Y  AND  TRANS(A)*Y = E .
C     TRANS(A)  IS THE TRANSPOSE OF A .  THE COMPONENTS OF  E  ARE
C     CHOSEN TO CAUSE MAXIMUM LOCAL GROWTH IN THE ELEMENTS OF W  WHERE
C     TRANS(U)*W = E .  THE VECTORS ARE FREQUENTLY RESCALED TO AVOID
C     OVERFLOW.
C
C     SOLVE TRANS(U)*W = E
C
      EK = 1.0E0
      DO 20 J = 1, N
         Z(J) = 0.0E0
   20 CONTINUE
      DO 100 K = 1, N
         IF (Z(K) .NE. 0.0E0) EK = SIGN(EK,-Z(K))
         IF (ABS(EK-Z(K)) .LE. ABS(A(K,K))) GO TO 30
            S = ABS(A(K,K))/ABS(EK-Z(K))
            CALL SSCAL(N,S,Z,1)
            EK = S*EK
   30    CONTINUE
         WK = EK - Z(K)
         WKM = -EK - Z(K)
         S = ABS(WK)
         SM = ABS(WKM)
         IF (A(K,K) .EQ. 0.0E0) GO TO 40
            WK = WK/A(K,K)
            WKM = WKM/A(K,K)
         GO TO 50
   40    CONTINUE
            WK = 1.0E0
            WKM = 1.0E0
   50    CONTINUE
         KP1 = K + 1
         IF (KP1 .GT. N) GO TO 90
            DO 60 J = KP1, N
               SM = SM + ABS(Z(J)+WKM*A(K,J))
               Z(J) = Z(J) + WK*A(K,J)
               S = S + ABS(Z(J))
   60       CONTINUE
            IF (S .GE. SM) GO TO 80
               T = WKM - WK
               WK = WKM
               DO 70 J = KP1, N
                  Z(J) = Z(J) + T*A(K,J)
   70          CONTINUE
   80       CONTINUE
   90    CONTINUE
         Z(K) = WK
  100 CONTINUE
      S = 1.0E0/SASUM(N,Z,1)
      CALL SSCAL(N,S,Z,1)
C
C     SOLVE TRANS(L)*Y = W
C
      DO 120 KB = 1, N
         K = N + 1 - KB
         IF (K .LT. N) Z(K) = Z(K) + SDOT(N-K,A(K+1,K),1,Z(K+1),1)
         IF (ABS(Z(K)) .LE. 1.0E0) GO TO 110
            S = 1.0E0/ABS(Z(K))
            CALL SSCAL(N,S,Z,1)
  110    CONTINUE
         L = IPVT(K)
         T = Z(L)
         Z(L) = Z(K)
         Z(K) = T
  120 CONTINUE
      S = 1.0E0/SASUM(N,Z,1)
      CALL SSCAL(N,S,Z,1)
C
      YNORM = 1.0E0
C
C     SOLVE L*V = Y
C
      DO 140 K = 1, N
         L = IPVT(K)
         T = Z(L)
         Z(L) = Z(K)
         Z(K) = T
         IF (K .LT. N) CALL SAXPY(N-K,T,A(K+1,K),1,Z(K+1),1)
         IF (ABS(Z(K)) .LE. 1.0E0) GO TO 130
            S = 1.0E0/ABS(Z(K))
            CALL SSCAL(N,S,Z,1)
            YNORM = S*YNORM
  130    CONTINUE
  140 CONTINUE
      S = 1.0E0/SASUM(N,Z,1)
      CALL SSCAL(N,S,Z,1)
      YNORM = S*YNORM
C
C     SOLVE  U*Z = V
C
      DO 160 KB = 1, N
         K = N + 1 - KB
         IF (ABS(Z(K)) .LE. ABS(A(K,K))) GO TO 150
            S = ABS(A(K,K))/ABS(Z(K))
            CALL SSCAL(N,S,Z,1)
            YNORM = S*YNORM
  150    CONTINUE
         IF (A(K,K) .NE. 0.0E0) Z(K) = Z(K)/A(K,K)
         IF (A(K,K) .EQ. 0.0E0) Z(K) = 1.0E0
         T = -Z(K)
         CALL SAXPY(K-1,T,A(1,K),1,Z(1),1)
  160 CONTINUE
C     MAKE ZNORM = 1.0
      S = 1.0E0/SASUM(N,Z,1)
      CALL SSCAL(N,S,Z,1)
      YNORM = S*YNORM
C
      IF (ANORM .NE. 0.0E0) RCOND = YNORM/ANORM
      IF (ANORM .EQ. 0.0E0) RCOND = 0.0E0
      RETURN
      END
      SUBROUTINE SGEDI(A,LDA,N,IPVT,DET,WORK,JOB)
C***BEGIN PROLOGUE  SGEDI
C***DATE WRITTEN   780814   (YYMMDD)
C***REVISION DATE  820801   (YYMMDD)
C***CATEGORY NO.  D2A1,D3A1
C***KEYWORDS  DETERMINANT,FACTOR,INVERSE,LINEAR ALGEBRA,LINPACK,MATRIX
C***AUTHOR  MOLER, C. B., (U. OF NEW MEXICO)
C***PURPOSE  Computes the determinant and inverse of a matrix
C            using the factors computed by SGECO or SGEFA.
C***DESCRIPTION
C
C     SGEDI computes the determinant and inverse of a matrix
C     using the factors computed by SGECO or SGEFA.
C
C     On Entry
C
C        A       REAL(LDA, N)
C                the output from SGECO or SGEFA.
C
C        LDA     INTEGER
C                the leading dimension of the array  A .
C
C        N       INTEGER
C                the order of the matrix  A .
C
C        IPVT    INTEGER(N)
C                the pivot vector from SGECO or SGEFA.
C
C        WORK    REAL(N)
C                work vector.  Contents destroyed.
C
C        JOB     INTEGER
C                = 11   both determinant and inverse.
C                = 01   inverse only.
C                = 10   determinant only.
C
C     On Return
C
C        A       inverse of original matrix if requested.
C                Otherwise unchanged.
C
C        DET     REAL(2)
C                determinant of original matrix if requested.
C                Otherwise not referenced.
C                Determinant = DET(1) * 10.0**DET(2)
C                with  1.0 .LE. ABS(DET(1)) .LT. 10.0
C                or  DET(1) .EQ. 0.0 .
C
C     Error Condition
C
C        A division by zero will occur if the input factor contains
C        a zero on the diagonal and the inverse is requested.
C        It will not occur if the subroutines are called correctly
C        and if SGECO has set RCOND .GT. 0.0 or SGEFA has set
C        INFO .EQ. 0 .
C
C     LINPACK.  This version dated 08/14/78 .
C     Cleve Moler, University of New Mexico, Argonne National Lab.
C
C     Subroutines and Functions
C
C     BLAS SAXPY,SSCAL,SSWAP
C     Fortran ABS,MOD
C***REFERENCES  DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W.,
C                 *LINPACK USERS  GUIDE*, SIAM, 1979.
C***ROUTINES CALLED  SAXPY,SSCAL,SSWAP
C***END PROLOGUE  SGEDI
      INTEGER LDA,N,IPVT(1),JOB
      REAL A(LDA,1),DET(2),WORK(1)
C
      REAL T
      REAL TEN
      INTEGER I,J,K,KB,KP1,L,NM1
C
C     COMPUTE DETERMINANT
C
C***FIRST EXECUTABLE STATEMENT  SGEDI
      IF (JOB/10 .EQ. 0) GO TO 70
         DET(1) = 1.0E0
         DET(2) = 0.0E0
         TEN = 10.0E0
         DO 50 I = 1, N
            IF (IPVT(I) .NE. I) DET(1) = -DET(1)
            DET(1) = A(I,I)*DET(1)
C        ...EXIT
            IF (DET(1) .EQ. 0.0E0) GO TO 60
   10       IF (ABS(DET(1)) .GE. 1.0E0) GO TO 20
               DET(1) = TEN*DET(1)
               DET(2) = DET(2) - 1.0E0
            GO TO 10
   20       CONTINUE
   30       IF (ABS(DET(1)) .LT. TEN) GO TO 40
               DET(1) = DET(1)/TEN
               DET(2) = DET(2) + 1.0E0
            GO TO 30
   40       CONTINUE
   50    CONTINUE
   60    CONTINUE
   70 CONTINUE
C
C     COMPUTE INVERSE(U)
C
      IF (MOD(JOB,10) .EQ. 0) GO TO 150
         DO 100 K = 1, N
            A(K,K) = 1.0E0/A(K,K)
            T = -A(K,K)
            CALL SSCAL(K-1,T,A(1,K),1)
            KP1 = K + 1
            IF (N .LT. KP1) GO TO 90
            DO 80 J = KP1, N
               T = A(K,J)
               A(K,J) = 0.0E0
               CALL SAXPY(K,T,A(1,K),1,A(1,J),1)
   80       CONTINUE
   90       CONTINUE
  100    CONTINUE
C
C        FORM INVERSE(U)*INVERSE(L)
C
         NM1 = N - 1
         IF (NM1 .LT. 1) GO TO 140
         DO 130 KB = 1, NM1
            K = N - KB
            KP1 = K + 1
            DO 110 I = KP1, N
               WORK(I) = A(I,K)
               A(I,K) = 0.0E0
  110       CONTINUE
            DO 120 J = KP1, N
               T = WORK(J)
               CALL SAXPY(N,T,A(1,J),1,A(1,K),1)
  120       CONTINUE
            L = IPVT(K)
            IF (L .NE. K) CALL SSWAP(N,A(1,K),1,A(1,L),1)
  130    CONTINUE
  140    CONTINUE
  150 CONTINUE
      RETURN
      END
      SUBROUTINE SGEEV(A,LDA,N,E,V,LDV,WORK,JOB,INFO)
C***BEGIN PROLOGUE  SGEEV
C***DATE WRITTEN   800808   (YYMMDD)
C***REVISION DATE  820801   (YYMMDD)
C***CATEGORY NO.  D4A2
C***KEYWORDS  EIGENVALUE,EIGENVECTOR,GENERAL MATRIX,REAL
C***AUTHOR  KAHANER, D. K., (NBS)
C           MOLER, C. B., (U. OF NEW MEXICO)
C           STEWART, G. W., (U. OF MARYLAND)
C***PURPOSE  To compute the eigenvalues and, optionally, the eigen-
C            vectors of a GENERAL real matrix.
C***DESCRIPTION
C
C     LICEPACK.    This version dated 08/08/80.
C     David Kahaner, Cleve Moler, G. W. Stewart,
C       N.B.S.         U.N.M.      N.B.S./U.MD.
C
C     Abstract
C      SGEEV computes the eigenvalues and, optionally,
C      the eigenvectors of a general real matrix.
C
C     Call Sequence Parameters-
C       (The values of parameters marked with * (star) will be changed
C         by SGEEV.)
C
C        A*      REAL(LDA,N)
C                real nonsymmetric input matrix.
C
C        LDA     INTEGER
C                set by the user to
C                the leading dimension of the real array A.
C
C        N       INTEGER
C                set by the user to
C                the order of the matrices A and V, and
C                the number of elements in E.
C
C        E*      COMPLEX(N)
C                on return from SGEEV, E contains the eigenvalues of A.
C                See also INFO below.
C
C        V*      COMPLEX(LDV,N)
C                on return from SGEEV, if the user has set JOB
C                = 0        V is not referenced.
C                = nonzero  the N eigenvectors of A are stored in the
C                first N columns of V.  See also INFO below.
C                (Note that if the input matrix A is nearly degenerate,
C                 V may be badly conditioned, i.e., may have nearly
C                 dependent columns.)
C
C        LDV     INTEGER
C                set by the user to
C                the leading dimension of the array V if JOB is also
C                set nonzero.  In that case, N must be .LE. LDV.
C                If JOB is set to zero, LDV is not referenced.
C
C        WORK*   REAL(2N)
C                temporary storage vector.  Contents changed by SGEEV.
C
C        JOB     INTEGER
C                set by the user to
C                = 0        eigenvalues only to be calculated by SGEEV.
C                           Neither V nor LDV is referenced.
C                = nonzero  eigenvalues and vectors to be calculated.
C                           In this case, A & V must be distinct arrays.
C                           Also, if LDA .GT. LDV, SGEEV changes all the
C                           elements of A thru column N.  If LDA < LDV,
C                           SGEEV changes all the elements of V through
C                           column N. If LDA = LDV, only A(I,J) and V(I,
C                           J) for I,J = 1,...,N are changed by SGEEV.
C
C        INFO*   INTEGER
C                on return from SGEEV the value of INFO is
C                = 0  normal return, calculation successful.
C                = K  if the eigenvalue iteration fails to converge,
C                     eigenvalues K+1 through N are correct, but
C                     no eigenvectors were computed even if they were
C                     requested (JOB nonzero).
C
C      Error Messages
C           No. 1  recoverable  N is greater than LDA
C           No. 2  recoverable  N is less than one.
C           No. 3  recoverable  JOB is nonzero and N is greater than LDV
C           No. 4  warning      LDA > LDV, elements of A other than the
C                               N by N input elements have been changed.
C           No. 5  warning      LDA < LDV, elements of V other than the
C                               N x N output elements have been changed.
C
C
C     Subroutines used
C
C     EISPACK-  BALANC,BALBAK, ORTHES, ORTRAN, HQR, HQR2
C     BLAS-  SCOPY, SCOPYM
C     SLATEC- XERROR
C***REFERENCES  (NONE)
C***ROUTINES CALLED  BALANC,BALBAK,HQR,HQR2,ORTHES,ORTRAN,SCOPY,SCOPYM,
C                    XERROR
C***END PROLOGUE  SGEEV
CCCCC INTEGER I,IHI,ILO,INFO,J,JB,JOB,K,KM,KP,L,LDA,LDV,
      INTEGER IHI,ILO,INFO,J,JOB,K,L,LDA,LDV,
     1        MDIM,MIN0,N
      REAL A(*),E(*),WORK(*),V(*)
C***FIRST EXECUTABLE STATEMENT  SGEEV
      IF(N .GT. LDA)THEN
CCCCC   WRITE(*,*) 'FROM SGEEV: N > LDA'
        INFO = -1
        RETURN
      ENDIF
      IF(N .LT. 1) THEN
CCCCC   WRITE(*,*) 'FROM SGEEV: N < 1'
        INFO = -1
        RETURN
      END IF
      IF(N .EQ. 1 .AND. JOB .EQ. 0) GO TO 35
      MDIM = LDA
      IF(JOB .EQ. 0) GO TO 5
      IF(N .GT. LDV)THEN
CCCCC   WRITE(*,*) 'FROM SGEEV: JOB NON-ZERO AND N > LDV'
        INFO = -1
        RETURN
      ENDIF
      IF(N .EQ. 1) GO TO 35
C
C       REARRANGE A IF NECESSARY WHEN LDA.GT.LDV AND JOB .NE.0
C
      MDIM = MIN0(LDA,LDV)
      IF(LDA.LT.LDV) THEN
CCCCC  WRITE(*,*) 'FROM SGEEV: LDA < LDV, ELEMENTS OF V OTHER'
CCCCC  WRITE(*,*) 'THAN THE N BY N OUTPUT ELEMENTS HAVE BEEN CHANGED.'
      ENDIF
      IF(LDA.LE.LDV) GO TO 5
CCCCC WRITE(*,*) 'FROM SGEEV: LDA > LDV, ELEMENTS OF A OTHER THAN THE'
CCCCC WRITE(*,*) 'N BY N INPUT ELEMENTS HAVE BEEN CHANGED.'
      L = N - 1
      DO 4 J=1,L
         M = 1+J*LDV
         K = 1+J*LDA
         CALL SCOPY(N,A(K),1,A(M),1)
    4 CONTINUE
    5 CONTINUE
C
C     SCALE AND ORTHOGONAL REDUCTION TO HESSENBERG.
C
      CALL BALANC(MDIM,N,A,ILO,IHI,WORK(1))
      CALL ORTHES(MDIM,N,ILO,IHI,A,WORK(N+1))
      IF(JOB .NE. 0) GO TO 10
C
C     EIGENVALUES ONLY
C
      CALL HQR(LDA,N,ILO,IHI,A,E(1),E(N+1),INFO)
      GO TO 30
C
C     EIGENVALUES AND EIGENVECTORS.
C
   10 CALL ORTRAN(MDIM,N,ILO,IHI,A,WORK(N+1),V)
      CALL HQR2(MDIM,N,ILO,IHI,A,E(1),E(N+1),V,INFO)
      IF (INFO .NE. 0) GO TO 30
      CALL BALBAK(MDIM,N,ILO,IHI,WORK(1),N,V)
C
C     CONVERT EIGENVECTORS TO COMPLEX STORAGE.
C
CCCCC JULY 1993.  FOR DATAPLOT PURPOSES, DO NOT CONVERT TO COMPLEX
CCCCC FORMAT (I.E., ROWS 1 TO N CORRESPOND TO REAL PART, ROWS N+1
CCCCC TO 2*N CORRESPOND TO IMAGINARY PART).
CNIST DO 20 JB = 1,N
CNIST    J=N+1-JB
CNIST    I=N+J
CNIST    K=(J-1)*MDIM+1
CNIST    KP=K+MDIM
CNIST    KM=K-MDIM
CNIST    IF(E(I).GE.0.0E0) CALL SCOPY(N,V(K),1,WORK(1),2)
CNIST    IF(E(I).LT.0.0E0) CALL SCOPY(N,V(KM),1,WORK(1),2)
CNIST    IF(E(I).EQ.0.0E0) CALL SCOPY(N,0.0E0,0,WORK(2),2)
CNIST    IF(E(I).GT.0.0E0) CALL SCOPY(N,V(KP),1,WORK(2),2)
CNIST    IF(E(I).LT.0.0E0) CALL SCOPYM(N,V(K),1,WORK(2),2)
CNIST    L=2*(J-1)*LDV+1
CNIST    CALL SCOPY(2*N,WORK(1),1,V(L),1)
CCC20 CONTINUE
C
C     CONVERT EIGENVALUES TO COMPLEX STORAGE.
C
CCCCC JULY 1993.  FOR DATAPLOT PURPOSES, DO NOT CONVERT TO COMPLEX
CCCCC FORMAT (I.E., ROWS 1 TO N CORRESPOND TO REAL PART, ROWS N+1
CCCCC TO 2*N CORRESPOND TO IMAGINARY PART).
   30 CONTINUE
CNIST CALL SCOPY(N,E(1),1,WORK(1),1)
CNIST CALL SCOPY(N,E(N+1),1,E(2),2)
CNIST CALL SCOPY(N,WORK(1),1,E(1),2)
      RETURN
C
C     TAKE CARE OF N=1 CASE
C
   35 E(1) = A(1)
      E(2) = 0.E0
      INFO = 0
      IF(JOB .EQ. 0) RETURN
      V(1) = A(1)
      V(2) = 0.E0
      RETURN
      END
      SUBROUTINE SGEFA(A,LDA,N,IPVT,INFO)
C***BEGIN PROLOGUE  SGEFA
C***DATE WRITTEN   780814   (YYMMDD)
C***REVISION DATE  820801   (YYMMDD)
C***CATEGORY NO.  D2A1
C***KEYWORDS  FACTOR,LINEAR ALGEBRA,LINPACK,MATRIX
C***AUTHOR  MOLER, C. B., (U. OF NEW MEXICO)
C***PURPOSE  Factors a real matrix by Gaussian elimination.
C***DESCRIPTION
C
C     SGEFA factors a real matrix by Gaussian elimination.
C
C     SGEFA is usually called by SGECO, but it can be called
C     directly with a saving in time if  RCOND  is not needed.
C     (Time for SGECO) = (1 + 9/N)*(Time for SGEFA) .
C
C     On Entry
C
C        A       REAL(LDA, N)
C                the matrix to be factored.
C
C        LDA     INTEGER
C                the leading dimension of the array  A .
C
C        N       INTEGER
C                the order of the matrix  A .
C
C     On Return
C
C        A       an upper triangular matrix and the multipliers
C                which were used to obtain it.
C                The factorization can be written  A = L*U , where
C                L  is a product of permutation and unit lower
C                triangular matrices and  U  is upper triangular.
C
C        IPVT    INTEGER(N)
C                an integer vector of pivot indices.
C
C        INFO    INTEGER
C                = 0  normal value.
C                = K  if  U(K,K) .EQ. 0.0 .  This is not an error
C                     condition for this subroutine, but it does
C                     indicate that SGESL or SGEDI will divide by zero
C                     if called.  Use  RCOND  in SGECO for a reliable
C                     indication of singularity.
C
C     LINPACK.  This version dated 08/14/78 .
C     Cleve Moler, University of New Mexico, Argonne National Lab.
C
C     Subroutines and Functions
C
C     BLAS SAXPY,SSCAL,ISAMAX
C***REFERENCES  DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W.,
C                 *LINPACK USERS  GUIDE*, SIAM, 1979.
C***ROUTINES CALLED  ISAMAX,SAXPY,SSCAL
C***END PROLOGUE  SGEFA
      INTEGER LDA,N,IPVT(*),INFO
      REAL A(LDA,*)
C
      REAL T
      INTEGER ISAMAX,J,K,KP1,L,NM1
C
C     GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING
C
C***FIRST EXECUTABLE STATEMENT  SGEFA
      INFO = 0
      NM1 = N - 1
      IF (NM1 .LT. 1) GO TO 70
      DO 60 K = 1, NM1
         KP1 = K + 1
C
C        FIND L = PIVOT INDEX
C
         L = ISAMAX(N-K+1,A(K,K),1) + K - 1
         IPVT(K) = L
C
C        ZERO PIVOT IMPLIES THIS COLUMN ALREADY TRIANGULARIZED
C
         IF (A(L,K) .EQ. 0.0E0) GO TO 40
C
C           INTERCHANGE IF NECESSARY
C
            IF (L .EQ. K) GO TO 10
               T = A(L,K)
               A(L,K) = A(K,K)
               A(K,K) = T
   10       CONTINUE
C
C           COMPUTE MULTIPLIERS
C
            T = -1.0E0/A(K,K)
            CALL SSCAL(N-K,T,A(K+1,K),1)
C
C           ROW ELIMINATION WITH COLUMN INDEXING
C
            DO 30 J = KP1, N
               T = A(L,J)
               IF (L .EQ. K) GO TO 20
                  A(L,J) = A(K,J)
                  A(K,J) = T
   20          CONTINUE
               CALL SAXPY(N-K,T,A(K+1,K),1,A(K+1,J),1)
   30       CONTINUE
         GO TO 50
   40    CONTINUE
            INFO = K
   50    CONTINUE
   60 CONTINUE
   70 CONTINUE
      IPVT(N) = N
      IF (A(N,N) .EQ. 0.0E0) INFO = N
      RETURN
      END
      SUBROUTINE SGESL(A,LDA,N,IPVT,B,JOB)
C***BEGIN PROLOGUE  SGESL
C***DATE WRITTEN   780814   (YYMMDD)
C***REVISION DATE  820801   (YYMMDD)
C***CATEGORY NO.  D2A1
C***KEYWORDS  LINEAR ALGEBRA,LINPACK,MATRIX,SOLVE
C***AUTHOR  MOLER, C. B., (U. OF NEW MEXICO)
C***PURPOSE  Solves the real system A*X=B or TRANS(A)*X=B
C            using the factors of SGECO or SGEFA
C***DESCRIPTION
C
C     SGESL solves the real system
C     A * X = B  or  TRANS(A) * X = B
C     using the factors computed by SGECO or SGEFA.
C
C     On Entry
C
C        A       REAL(LDA, N)
C                the output from SGECO or SGEFA.
C
C        LDA     INTEGER
C                the leading dimension of the array  A .
C
C        N       INTEGER
C                the order of the matrix  A .
C
C        IPVT    INTEGER(N)
C                the pivot vector from SGECO or SGEFA.
C
C        B       REAL(N)
C                the right hand side vector.
C
C        JOB     INTEGER
C                = 0         to solve  A*X = B ,
C                = nonzero   to solve  TRANS(A)*X = B  where
C                            TRANS(A)  is the transpose.
C
C     On Return
C
C        B       the solution vector  X .
C
C     Error Condition
C
C        A division by zero will occur if the input factor contains a
C        zero on the diagonal.  Technically, this indicates singularity,
C        but it is often caused by improper arguments or improper
C        setting of LDA .  It will not occur if the subroutines are
C        called correctly and if SGECO has set RCOND .GT. 0.0
C        or SGEFA has set INFO .EQ. 0 .
C
C     To compute  INVERSE(A) * C  where  C  is a matrix
C     with  P  columns
C           CALL SGECO(A,LDA,N,IPVT,RCOND,Z)
C           IF (RCOND is too small) GO TO ...
C           DO 10 J = 1, P
C              CALL SGESL(A,LDA,N,IPVT,C(1,J),0)
C        10 CONTINUE
C
C     LINPACK.  This version dated 08/14/78 .
C     Cleve Moler, University of New Mexico, Argonne National Lab.
C
C     Subroutines and Functions
C
C     BLAS SAXPY,SDOT
C***REFERENCES  DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W.,
C                 *LINPACK USERS  GUIDE*, SIAM, 1979.
C***ROUTINES CALLED  SAXPY,SDOT
C***END PROLOGUE  SGESL
      INTEGER LDA,N,IPVT(*),JOB
      REAL A(LDA,*),B(*)
C
      REAL SDOT,T
      INTEGER K,KB,L,NM1
C***FIRST EXECUTABLE STATEMENT  SGESL
      NM1 = N - 1
      IF (JOB .NE. 0) GO TO 50
C
C        JOB = 0 , SOLVE  A * X = B
C        FIRST SOLVE  L*Y = B
C
         IF (NM1 .LT. 1) GO TO 30
         DO 20 K = 1, NM1
            L = IPVT(K)
            T = B(L)
            IF (L .EQ. K) GO TO 10
               B(L) = B(K)
               B(K) = T
   10       CONTINUE
            CALL SAXPY(N-K,T,A(K+1,K),1,B(K+1),1)
   20    CONTINUE
   30    CONTINUE
C
C        NOW SOLVE  U*X = Y
C
         DO 40 KB = 1, N
            K = N + 1 - KB
            B(K) = B(K)/A(K,K)
            T = -B(K)
            CALL SAXPY(K-1,T,A(1,K),1,B(1),1)
   40    CONTINUE
      GO TO 100
   50 CONTINUE
C
C        JOB = NONZERO, SOLVE  TRANS(A) * X = B
C        FIRST SOLVE  TRANS(U)*Y = B
C
         DO 60 K = 1, N
            T = SDOT(K-1,A(1,K),1,B(1),1)
            B(K) = (B(K) - T)/A(K,K)
   60    CONTINUE
C
C        NOW SOLVE TRANS(L)*X = Y
C
         IF (NM1 .LT. 1) GO TO 90
         DO 80 KB = 1, NM1
            K = N - KB
            B(K) = B(K) + SDOT(N-K,A(K+1,K),1,B(K+1),1)
            L = IPVT(K)
            IF (L .EQ. K) GO TO 70
               T = B(L)
               B(L) = B(K)
               B(K) = T
   70       CONTINUE
   80    CONTINUE
   90    CONTINUE
  100 CONTINUE
      RETURN
      END
      SUBROUTINE SGEMM (TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB,
     $   BETA, C, LDC,
     $   IERROR)
*DECK SGEMM
C***BEGIN PROLOGUE  SGEMM
C***PURPOSE  Multiply a real general matrix by a real general matrix.
C***LIBRARY   SLATEC (BLAS)
C***CATEGORY  D1B6
C***TYPE      SINGLE PRECISION (SGEMM-S, DGEMM-D, CGEMM-C)
C***KEYWORDS  LEVEL 3 BLAS, LINEAR ALGEBRA
C***AUTHOR  Dongarra, J., (ANL)
C           Duff, I., (AERE)
C           Du Croz, J., (NAG)
C           Hammarling, S. (NAG)
C***DESCRIPTION
C
C  SGEMM  performs one of the matrix-matrix operations
C
C     C := alpha*op( A )*op( B ) + beta*C,
C
C  where  op( X ) is one of
C
C     op( X ) = X   or   op( X ) = X',
C
C  alpha and beta are scalars, and A, B and C are matrices, with op( A )
C  an m by k matrix,  op( B )  a  k by n matrix and  C an m by n matrix.
C
C  Parameters
C  ==========
C
C  TRANSA - CHARACTER*1.
C           On entry, TRANSA specifies the form of op( A ) to be used in
C           the matrix multiplication as follows:
C
C              TRANSA = 'N' or 'n',  op( A ) = A.
C
C              TRANSA = 'T' or 't',  op( A ) = A'.
C
C              TRANSA = 'C' or 'c',  op( A ) = A'.
C
C           Unchanged on exit.
C
C  TRANSB - CHARACTER*1.
C           On entry, TRANSB specifies the form of op( B ) to be used in
C           the matrix multiplication as follows:
C
C              TRANSB = 'N' or 'n',  op( B ) = B.
C
C              TRANSB = 'T' or 't',  op( B ) = B'.
C
C              TRANSB = 'C' or 'c',  op( B ) = B'.
C
C           Unchanged on exit.
C
C  M      - INTEGER.
C           On entry,  M  specifies  the number  of rows  of the  matrix
C           op( A )  and of the  matrix  C.  M  must  be at least  zero.
C           Unchanged on exit.
C
C  N      - INTEGER.
C           On entry,  N  specifies the number  of columns of the matrix
C           op( B ) and the number of columns of the matrix C. N must be
C           at least zero.
C           Unchanged on exit.
C
C  K      - INTEGER.
C           On entry,  K  specifies  the number of columns of the matrix
C           op( A ) and the number of rows of the matrix op( B ). K must
C           be at least  zero.
C           Unchanged on exit.
C
C  ALPHA  - REAL            .
C           On entry, ALPHA specifies the scalar alpha.
C           Unchanged on exit.
C
C  A      - REAL             array of DIMENSION ( LDA, ka ), where ka is
C           k  when  TRANSA = 'N' or 'n',  and is  m  otherwise.
C           Before entry with  TRANSA = 'N' or 'n',  the leading  m by k
C           part of the array  A  must contain the matrix  A,  otherwise
C           the leading  k by m  part of the array  A  must contain  the
C           matrix A.
C           Unchanged on exit.
C
C  LDA    - INTEGER.
C           On entry, LDA specifies the first dimension of A as declared
C           in the calling (sub) program. When  TRANSA = 'N' or 'n' then
C           LDA must be at least  max( 1, m ), otherwise  LDA must be at
C           least  max( 1, k ).
C           Unchanged on exit.
C
C  B      - REAL             array of DIMENSION ( LDB, kb ), where kb is
C           n  when  TRANSB = 'N' or 'n',  and is  k  otherwise.
C           Before entry with  TRANSB = 'N' or 'n',  the leading  k by n
C           part of the array  B  must contain the matrix  B,  otherwise
C           the leading  n by k  part of the array  B  must contain  the
C           matrix B.
C           Unchanged on exit.
C
C  LDB    - INTEGER.
C           On entry, LDB specifies the first dimension of B as declared
C           in the calling (sub) program. When  TRANSB = 'N' or 'n' then
C           LDB must be at least  max( 1, k ), otherwise  LDB must be at
C           least  max( 1, n ).
C           Unchanged on exit.
C
C  BETA   - REAL            .
C           On entry,  BETA  specifies the scalar  beta.  When  BETA  is
C           supplied as zero then C need not be set on input.
C           Unchanged on exit.
C
C  C      - REAL             array of DIMENSION ( LDC, n ).
C           Before entry, the leading  m by n  part of the array  C must
C           contain the matrix  C,  except when  beta  is zero, in which
C           case C need not be set on entry.
C           On exit, the array  C  is overwritten by the  m by n  matrix
C           ( alpha*op( A )*op( B ) + beta*C ).
C
C  LDC    - INTEGER.
C           On entry, LDC specifies the first dimension of C as declared
C           in  the  calling  (sub)  program.   LDC  must  be  at  least
C           max( 1, m ).
C           Unchanged on exit.
C
C***REFERENCES  Dongarra, J., Du Croz, J., Duff, I., and Hammarling, S.
C                 A set of level 3 basic linear algebra subprograms.
C                 ACM TOMS, Vol. 16, No. 1, pp. 1-17, March 1990.
C***ROUTINES CALLED  LSAME, XERBLA
C***REVISION HISTORY  (YYMMDD)
C   890208  DATE WRITTEN
C   910605  Modified to meet SLATEC prologue standards.  Only comment
C           lines were modified.  (BKS)
C***END PROLOGUE  SGEMM
C     .. Scalar Arguments ..
      CHARACTER*1        TRANSA, TRANSB
      INTEGER            M, N, K, LDA, LDB, LDC
      REAL               ALPHA, BETA
C     .. Array Arguments ..
      REAL               A( LDA, * ), B( LDB, * ), C( LDC, * )
C     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
C     .. External Subroutines ..
CCCCC EXTERNAL           XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC          MAX
C     .. Local Scalars ..
      LOGICAL            NOTA, NOTB
      INTEGER            I, INFO, J, L, NCOLA, NROWA, NROWB
      REAL               TEMP
C     .. Parameters ..
      REAL               ONE         , ZERO
      PARAMETER        ( ONE = 1.0E+0, ZERO = 0.0E+0 )
C
      CHARACTER*4 IERROR
C
      INCLUDE 'DPCOP2.INC'
C
C***FIRST EXECUTABLE STATEMENT  SGEMM
C
C     Set  NOTA  and  NOTB  as  true if  A  and  B  respectively are not
C     transposed and set  NROWA, NCOLA and  NROWB  as the number of rows
C     and  columns of  A  and the  number of  rows  of  B  respectively.
C
      IERROR='NO'
C
      NOTA  = LSAME( TRANSA, 'N' )
      NOTB  = LSAME( TRANSB, 'N' )
      IF( NOTA )THEN
         NROWA = M
         NCOLA = K
      ELSE
         NROWA = K
         NCOLA = M
      END IF
      IF( NOTB )THEN
         NROWB = K
      ELSE
         NROWB = N
      END IF
C
C     Test the input parameters.
C
      INFO = 0
      IF(      ( .NOT.NOTA                 ).AND.
     $         ( .NOT.LSAME( TRANSA, 'C' ) ).AND.
     $         ( .NOT.LSAME( TRANSA, 'T' ) )      )THEN
         INFO = 1
      ELSE IF( ( .NOT.NOTB                 ).AND.
     $         ( .NOT.LSAME( TRANSB, 'C' ) ).AND.
     $         ( .NOT.LSAME( TRANSB, 'T' ) )      )THEN
         INFO = 2
      ELSE IF( M  .LT.0               )THEN
         INFO = 3
      ELSE IF( N  .LT.0               )THEN
         INFO = 4
      ELSE IF( K  .LT.0               )THEN
         INFO = 5
      ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN
         INFO = 8
      ELSE IF( LDB.LT.MAX( 1, NROWB ) )THEN
         INFO = 10
      ELSE IF( LDC.LT.MAX( 1, M     ) )THEN
         INFO = 13
      END IF
      IF( INFO.NE.0 )THEN
CCCCC    CALL XERBLA( 'SGEMM ', INFO )
         WRITE(ICOUT,1001)
         CALL DPWRST('XXX','BUG ')
         IERROR='YES'
 1001 FORMAT('***** INTERNAL ERROR FROM SGEMM, INVALID',
     1' ARGUMENTS.')
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR.
     $    ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) )
     $   RETURN
C
C     And if  alpha.eq.zero.
C
      IF( ALPHA.EQ.ZERO )THEN
         IF( BETA.EQ.ZERO )THEN
            DO 20, J = 1, N
               DO 10, I = 1, M
                  C( I, J ) = ZERO
   10          CONTINUE
   20       CONTINUE
         ELSE
            DO 40, J = 1, N
               DO 30, I = 1, M
                  C( I, J ) = BETA*C( I, J )
   30          CONTINUE
   40       CONTINUE
         END IF
         RETURN
      END IF
C
C     Start the operations.
C
      IF( NOTB )THEN
         IF( NOTA )THEN
C
C           Form  C := alpha*A*B + beta*C.
C
            DO 90, J = 1, N
               IF( BETA.EQ.ZERO )THEN
                  DO 50, I = 1, M
                     C( I, J ) = ZERO
   50             CONTINUE
               ELSE IF( BETA.NE.ONE )THEN
                  DO 60, I = 1, M
                     C( I, J ) = BETA*C( I, J )
   60             CONTINUE
               END IF
               DO 80, L = 1, K
                  IF( B( L, J ).NE.ZERO )THEN
                     TEMP = ALPHA*B( L, J )
                     DO 70, I = 1, M
                        C( I, J ) = C( I, J ) + TEMP*A( I, L )
   70                CONTINUE
                  END IF
   80          CONTINUE
   90       CONTINUE
         ELSE
C
C           Form  C := alpha*A'*B + beta*C
C
            DO 120, J = 1, N
               DO 110, I = 1, M
                  TEMP = ZERO
                  DO 100, L = 1, K
                     TEMP = TEMP + A( L, I )*B( L, J )
  100             CONTINUE
                  IF( BETA.EQ.ZERO )THEN
                     C( I, J ) = ALPHA*TEMP
                  ELSE
                     C( I, J ) = ALPHA*TEMP + BETA*C( I, J )
                  END IF
  110          CONTINUE
  120       CONTINUE
         END IF
      ELSE
         IF( NOTA )THEN
C
C           Form  C := alpha*A*B' + beta*C
C
            DO 170, J = 1, N
               IF( BETA.EQ.ZERO )THEN
                  DO 130, I = 1, M
                     C( I, J ) = ZERO
  130             CONTINUE
               ELSE IF( BETA.NE.ONE )THEN
                  DO 140, I = 1, M
                     C( I, J ) = BETA*C( I, J )
  140             CONTINUE
               END IF
               DO 160, L = 1, K
                  IF( B( J, L ).NE.ZERO )THEN
                     TEMP = ALPHA*B( J, L )
                     DO 150, I = 1, M
                        C( I, J ) = C( I, J ) + TEMP*A( I, L )
  150                CONTINUE
                  END IF
  160          CONTINUE
  170       CONTINUE
         ELSE
C
C           Form  C := alpha*A'*B' + beta*C
C
            DO 200, J = 1, N
               DO 190, I = 1, M
                  TEMP = ZERO
                  DO 180, L = 1, K
                     TEMP = TEMP + A( L, I )*B( J, L )
  180             CONTINUE
                  IF( BETA.EQ.ZERO )THEN
                     C( I, J ) = ALPHA*TEMP
                  ELSE
                     C( I, J ) = ALPHA*TEMP + BETA*C( I, J )
                  END IF
  190          CONTINUE
  200       CONTINUE
         END IF
      END IF
C
      RETURN
C
C     End of SGEMM .
C
      END
      SUBROUTINE SGTSL(N,C,D,E,B,INFO)
C***BEGIN PROLOGUE  SGTSL
C***DATE WRITTEN   780814   (YYMMDD)
C***REVISION DATE  820801   (YYMMDD)
C***CATEGORY NO.  D2A2A
C***KEYWORDS  LINEAR ALGEBRA,LINPACK,MATRIX,SOLVE,TRIDIAGONAL
C***AUTHOR  DONGARRA, J., (ANL)
C***PURPOSE  Solves the system A*X=B where a is TRIDIAGONAL
C***DESCRIPTION
C
C     SGTSL given a general tridiagonal matrix and a right hand
C     side will find the solution.
C
C     On Entry
C
C        N       INTEGER
C                is the order of the tridiagonal matrix.
C
C        C       REAL(N)
C                is the subdiagonal of the tridiagonal matrix.
C                C(2) through C(N) should contain the subdiagonal.
C                On output, C is destroyed.
C
C        D       REAL(N)
C                is the diagonal of the tridiagonal matrix.
C                On output, D is destroyed.
C
C        E       REAL(N)
C                is the superdiagonal of the tridiagonal matrix.
C                E(1) through E(N-1) should contain the superdiagonal.
C                On output, E is destroyed.
C
C        B       REAL(N)
C                is the right hand side vector.
C
C     On Return
C
C        B       is the solution vector.
C
C        INFO    INTEGER
C                = 0 normal value.
C                = K if the K-th element of the diagonal becomes
C                    exactly zero.  The subroutine returns when
C                    this is detected.
C
C     LINPACK.  This version dated 08/14/78 .
C     Jack Dongarra, Argonne National Laboratory.
C
C     No externals
C     Fortran ABS
C***REFERENCES  DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W.,
C                 *LINPACK USERS  GUIDE*, SIAM, 1979.
C***ROUTINES CALLED  (NONE)
C***END PROLOGUE  SGTSL
      INTEGER N,INFO
      REAL C(1),D(1),E(1),B(1)
C
      INTEGER K,KB,KP1,NM1,NM2
      REAL T
C     BEGIN BLOCK PERMITTING ...EXITS TO 100
C
C***FIRST EXECUTABLE STATEMENT  SGTSL
         INFO = 0
         C(1) = D(1)
         NM1 = N - 1
         IF (NM1 .LT. 1) GO TO 40
            D(1) = E(1)
            E(1) = 0.0E0
            E(N) = 0.0E0
C
            DO 30 K = 1, NM1
               KP1 = K + 1
C
C              FIND THE LARGEST OF THE TWO ROWS
C
               IF (ABS(C(KP1)) .LT. ABS(C(K))) GO TO 10
C
C                 INTERCHANGE ROW
C
                  T = C(KP1)
                  C(KP1) = C(K)
                  C(K) = T
                  T = D(KP1)
                  D(KP1) = D(K)
                  D(K) = T
                  T = E(KP1)
                  E(KP1) = E(K)
                  E(K) = T
                  T = B(KP1)
                  B(KP1) = B(K)
                  B(K) = T
   10          CONTINUE
C
C              ZERO ELEMENTS
C
               IF (C(K) .NE. 0.0E0) GO TO 20
                  INFO = K
C     ............EXIT
                  GO TO 100
   20          CONTINUE
               T = -C(KP1)/C(K)
               C(KP1) = D(KP1) + T*D(K)
               D(KP1) = E(KP1) + T*E(K)
               E(KP1) = 0.0E0
               B(KP1) = B(KP1) + T*B(K)
   30       CONTINUE
   40    CONTINUE
         IF (C(N) .NE. 0.0E0) GO TO 50
            INFO = N
         GO TO 90
   50    CONTINUE
C
C           BACK SOLVE
C
            NM2 = N - 2
            B(N) = B(N)/C(N)
            IF (N .EQ. 1) GO TO 80
               B(NM1) = (B(NM1) - D(NM1)*B(N))/C(NM1)
               IF (NM2 .LT. 1) GO TO 70
               DO 60 KB = 1, NM2
                  K = NM2 - KB + 1
                  B(K) = (B(K) - D(K)*B(K+1) - E(K)*B(K+2))/C(K)
   60          CONTINUE
   70          CONTINUE
   80       CONTINUE
   90    CONTINUE
  100 CONTINUE
C
      RETURN
      END
      SUBROUTINE SHANDI(Y,N,IWRITE,RIGHT,TEMP1,TEMP2,ICASE1,ICASE2,
     1                  IBUGA3,ISUBRO,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE SHANNON DIVERSITY INDEX.
C
C              THE FOLLOWING CASES ARE SUPPORTED:
C
C              1) IF ICASE1 = 'RAW', THEN "Y" IS A GROUP-ID VARIABLE.
C                 DATAPLOT WILL GENERATE A FREQUENCY TABLE FOR THE
C                 GROUPS AND THEN COMPUTE THE SHANNON DIVERSITY INDEX AS
C
C                     H = {N*LOG(N) - SUM[i=1 to K][F(i)*LOG(F(i))]}/N
C
C                 WHERE N IS THE COUNT OVER ALL GROUPS, K IS THE NUMBER OF
C                 GROUPS, AND F(I) IS THE FREQUENCY OF THE I-TH GROUP.
C
C                 THIS STATISTIC IS THEN NORMALIZED BY DIVIDING BY LOG(K).
C
C             2) IF ICASE1 = 'SUMMARY', THEN
C
C                a) SUM THE VALUES IN Y.  IF THIS SUM EQUALS 1, THEN ASSUME
C                   THAT Y DENOTES THE PROPORTIONS FOR EACH GROUP AND
C                   COMPUTE THE STATISTIC AS
C
C                        H = -SUM[i=1 to K][P(i)*LOG(P(i))]
C
C                b) IF THE SUM IS NOT EQUAL TO 1, THEN ASSUME THAT Y DENOTES
C                   THE COUNTS FOR EACH GROUP AND COMPUTE THE STATISTIC AS
C                   FOR THE RAW CASE (I.E., JUST SKIP THE BINNING STEP).
C
C     INPUT  ARGUMENTS--Y      = THE SINGLE PRECISION VECTOR OF OBSERVATIONS.
C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR Y.
C     OUTPUT ARGUMENTS--RIGHT  = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED SHANNON DIVERSITY INDEX.
C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
C             SAMPLE SHANNON DIVERSITY INDEX.
C     REFERENCE--BRANI VIDAKOVIC (2011), "STATISTICS FOR
C                BIOENGINEERING SCIENCES: WITH MATLAB AND WINBUGS
C                SUPPORT", SPRINGER, P. 23.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--FREQUE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     WRITTEN BY--ALAN HECKERT
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2899
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2011/12
C     ORIGINAL VERSION--DECEMBER  2011.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 ICASE1
      CHARACTER*4 ICASE2
      CHARACTER*4 IBUGA3
      CHARACTER*4 ISUBRO
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
      DOUBLE PRECISION DSUM
      DOUBLE PRECISION DSUM2
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DYI
      DOUBLE PRECISION EPS
C
C---------------------------------------------------------------------
C
      DIMENSION Y(*)
      DIMENSION TEMP1(*)
      DIMENSION TEMP2(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
      DATA EPS /1.0D-12/
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='SHAN'
      ISUBN2='DI  '
      IERROR='NO'
      RIGHT=CPUMIN
C
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'ANDI')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,51)
   51   FORMAT('***** AT THE BEGINNING OF SHANDI--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,52)IBUGA3,ISUBRO,N
   52   FORMAT('IBUGA3,ISUBRO,N = ',2(A4,2X),I8)
        CALL DPWRST('XXX','BUG ')
        DO55I=1,N
          WRITE(ICOUT,56)I,Y(I)
   56     FORMAT('I,Y(I) = ',I8,G15.7)
          CALL DPWRST('XXX','BUG ')
   55   CONTINUE
      ENDIF
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      IF(N.LT.1)THEN
        IERROR='YES'
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,111)
  111   FORMAT('***** ERROR IN SHANNON DIVERSITY INDEX--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,112)
  112   FORMAT('      THE NUMBER OF OBSERVATIONS FOR THE RESPONSE')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,113)
  113   FORMAT('      VARIABLES IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,117)N
  117   FORMAT('      THE NUMBER OF OBSERVATIONS      = ',I8)
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
      IF(ICASE1.EQ.'RAW')THEN
        NUMVAR=1
        ND=0
        CALL FREQUE(Y,N,TEMP1,ND,NUMVAR,IWRITE,
     1              TEMP2,K,IBUGA3,IERROR)
        IF(IERROR.EQ.'YES')GOTO9000
        DSUM=0.0D0
        DSUM2=0.0D0
        DO1210I=1,K
          ITEMP=INT(TEMP2(I)+0.5)
          IF(ITEMP.GT.0)THEN
            DYI=DBLE(ITEMP)
            DSUM=DSUM + DYI*DLOG(DYI)
            DSUM2=DSUM2 + DBLE(ITEMP)
          ENDIF
 1210   CONTINUE
        IF(DSUM2.LE.0.0D0)THEN
          IERROR='YES'
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,111)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,1212)
 1212     FORMAT('      THE TOTAL FREQUENCY COUNT WAS NON-POSITIVE.')
          CALL DPWRST('XXX','BUG ')
          GOTO9000
        ELSE
          DTERM1=(DSUM2*DLOG(DSUM2) - DSUM)/DSUM2
          IF(ICASE2.EQ.'EQUI')THEN
            RIGHT=REAL(DTERM1)/DBLE(K)
          ELSE
            RIGHT=REAL(DTERM1)
          ENDIF
        ENDIF
      ELSE
        DSUM=0.0D0
        DO2000I=1,N
          IF(Y(I).LT.0.0)THEN
            IERROR='YES'
            WRITE(ICOUT,999)
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,111)
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,2012)
 2012       FORMAT('      A NEGATIVE PROPORTION OR COUNT WAS ',
     1             'ENCOUNTERED.')
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,2013)I,Y(I)
 2013       FORMAT('      ROW ',I8,' = ',G15.7)
            CALL DPWRST('XXX','BUG ')
            GOTO9000
          ENDIF
          DSUM=DSUM + DBLE(Y(I))
 2000   CONTINUE
C
        IF(DABS(DSUM - 1.0D0).LE.EPS)THEN
          DSUM=0.0D0
          DO2110I=1,N
            IF(Y(I).GT.0.0)THEN
              DYI=DBLE(Y(I))
              DSUM=DSUM + DYI*DLOG(DYI)
            ENDIF
 2110     CONTINUE
          IF(ICASE2.EQ.'EQUI')THEN
            RIGHT=-REAL(DSUM)/LOG(REAL(N))
          ELSE
            RIGHT=-REAL(DSUM)
          ENDIF
        ELSE
          DSUM=0.0D0
          DSUM2=0.0D0
          DO2210I=1,N
            ITEMP=INT(Y(I)+0.5)
            IF(ITEMP.GT.0)THEN
              DYI=DBLE(ITEMP)
              DSUM=DSUM + DYI*DLOG(DYI)
              DSUM2=DSUM2 + DBLE(ITEMP)
            ENDIF
 2210     CONTINUE
          IF(DSUM2.LE.0.0D0)THEN
            IERROR='YES'
            WRITE(ICOUT,999)
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,111)
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,2212)
 2212       FORMAT('      THE TOTAL FREQUENCY COUNT WAS NON-POSITIVE.')
            CALL DPWRST('XXX','BUG ')
            GOTO9000
          ELSE
            DTERM1=(DSUM2*DLOG(DSUM2) - DSUM)/DSUM2
            IF(ICASE2.EQ.'EQUI')THEN
              RIGHT=REAL(DTERM1)/LOG(REAL(N))
            ELSE
              RIGHT=REAL(DTERM1)
            ENDIF
          ENDIF
        ENDIF
      ENDIF
C
C               *******************************
C               **  STEP 3--                 **
C               **  WRITE OUT A LINE         **
C               **  OF SUMMARY INFORMATION.  **
C               *******************************
C
      IF(IFEEDB.EQ.'ON' .AND. IWRITE.EQ.'ON')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,811)RIGHT
  811   FORMAT('THE SHANNON DIVERSITY INDEX = ',G15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'ANDI')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END       OF SHANDI--')
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      RETURN
      END
      SUBROUTINE SHMIDM(X,N,IWRITE,XTEMP,MAXNXT,XMIDM,
     1                  ISUBRO,IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE SAMPLE SHORTEST HALF
C              MIDMEAN.  THE FORMULA FOR THIS STATISTIC IS
C
C                   M = SUM[i=k to k+m][X(i)]/m   FOR THE MINIMUM
C                                                 (X(k+m) - X(k))
C                       m = n/2              n ODD
C                       m = INT(n/2) + 1     n EVEN
C
C              THIS IS ESSENTIALLY AN ASYMETRIC VERSION OF THE MID-MEAN.
C              ALTHOUGH IT HAS RATHER LOW EFFICIENY (LOWER THAN THE
C              MEDIAN), IT IS LESS SENSITIVE TO ASYMMETRICALLY
C              DISTRIBUTED OUTLIERS.
C
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF
C                                (UNSORTED OR SORTED) OBSERVATIONS.
C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR X.
C     OUTPUT ARGUMENTS--XMIDM  = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED SAMPLE SHORTEST HALF MIDMEAN.
C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE SAMPLE SHMIDMN.
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 DUEWER (2008), "A COMPARISON OF LOCATION
C                 ESTIMATORS FOR INTERLABORATORY DATA CONTAMINATED
C                 WITH VALUE AND UNCERTAINTY OUTLIERS",
C                 ACCREDITED QUALITY ASSURANCE, VOL. 13, PP. 193-216.
C     WRITTEN BY--ALAN HECKERT
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2899
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2017.02
C     ORIGINAL VERSION--FEBRUARY  2017.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 ISUBRO
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DK
      DOUBLE PRECISION DX
      DOUBLE PRECISION DSUM
C
      DIMENSION X(*)
      DIMENSION XTEMP(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='SHMI'
      ISUBN2='DM  '
      IERROR='NO'
      XMIDM=CPUMIN
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 SHMIDM--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,52)ISUBRO,IBUGA3,N
   52   FORMAT('ISUBRO,IBUGA3,N = ',2(A4,2X),I8)
        CALL DPWRST('XXX','BUG ')
        DO55I=1,N
          WRITE(ICOUT,56)I,X(I)
   56     FORMAT('I,X(I) = ',I8,G15.7)
          CALL DPWRST('XXX','BUG ')
   55   CONTINUE
      ENDIF
C
C               ***********************
C               **  COMPUTE SHMIDMN  **
C               ***********************
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      AN=N
C
      IF(N.LT.1 .OR. N.GT.MAXNXT)THEN
        IERROR='YES'
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,111)
  111   FORMAT('***** ERROR IN SHORTEST HALF MIDMEAN--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,112)
  112   FORMAT('      THE NUMBER OF OBSERVATIONS IN THE RESPONSE')
        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,'.')
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
      IF(N.EQ.1)THEN
        XMIDM=X(1)
        GOTO800
      ELSEIF(N.EQ.2)THEN
        XMIDM=(X(1)+X(2))/2.0
        GOTO800
      ELSEIF(N.EQ.3)THEN
        XMIDM=(X(1)+X(2)+X(3))/3.0
        GOTO800
      ENDIF
C
      HOLD=X(1)
      DO135I=2,N
        IF(X(I).NE.HOLD)GOTO139
  135 CONTINUE
      XMIDM=HOLD
      GOTO800
  139 CONTINUE
C
C               ****************************
C               **  STEP 2--              **
C               **  COMPUTE THE SHMIDMN.  **
C               ****************************
C
      CALL SORT(X,N,XTEMP)
C
C     FIND K
C
      M=(N/2)
      IF(MOD(N,2).EQ.1)M=M+1
      NLAST=N-M
      DIFF=XTEMP(1+M)-XTEMP(1)
      K=1
      DO200I=2,NLAST
        HOLD=XTEMP(I+M) - XTEMP(I)
        IF(HOLD.LT.DIFF)THEN
          DIFF=HOLD
          K=I
        ENDIF
  200 CONTINUE
C
      DSUM=0.0
      DO210I=K,K+M
        DX=XTEMP(I)
        DSUM=DSUM+DX
  210 CONTINUE
      DK=DBLE(M+1)
      XMIDM=DSUM/DK
C
C               *******************************
C               **  STEP 3--                 **
C               **  WRITE OUT A LINE         **
C               **  OF SUMMARY INFORMATION.  **
C               *******************************
C
  800 CONTINUE
      IF(IFEEDB.EQ.'ON' .AND. IWRITE.EQ.'ON')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,821)N,XMIDM
  821   FORMAT('THE SHORTEST HALF MIDMEAN OF THE ',I8,
     1         ' OBSERVATIONS = ',G15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'ON')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END       OF SHMIDM--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9012)IBUGA3,IERROR,K,M,XMIIDM
 9012   FORMAT('IBUGA3,IERROR,K,M,XMIDM = ',2(A4,2X),2I8,G15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      RETURN
      END
      SUBROUTINE SHMIDR(X,N,IWRITE,XTEMP,MAXNXT,XMIDR,
     1                  ISUBRO,IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE SAMPLE SHORTEST HALF
C              MIDRANGE.  THE FORMULA FOR THIS STATISTIC IS
C
C                   SHMIDRM = (X(k) + X(k+m))/2   FOR THE MINIMUM
C                                                 (X(k+m) - X(k))
C                       m = n/2              n ODD
C                       m = INT(n/2) + 1     n EVEN
C
C              THIS IS ESSENTIALLY AN ASYMETRIC VERSION OF THE MID-RANGE.
C              ALTHOUGH IT HAS RATHER LOW EFFICIENY (LOWER THAN THE
C              MEDIAN), IT IS LESS SENSITIVE TO ASYMMETRICALLY
C              DISTRIBUTED OUTLIERS.
C
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF
C                                (UNSORTED OR SORTED) OBSERVATIONS.
C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR X.
C     OUTPUT ARGUMENTS--XMIDR  = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED SAMPLE SHORTEST HALF MIDRANGE.
C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE SAMPLE SHMIDR.
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 DUEWER (2008), "A COMPARISON OF LOCATION
C                 ESTIMATORS FOR INTERLABORATORY DATA CONTAMINATED
C                 WITH VALUE AND UNCERTAINTY OUTLIERS",
C                 ACCREDITED QUALITY ASSURANCE, VOL. 13, PP. 193-216.
C     WRITTEN BY--ALAN HECKERT
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2899
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2017.02
C     ORIGINAL VERSION--FEBRUARY  2017.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 ISUBRO
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
      DIMENSION XTEMP(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='SHMI'
      ISUBN2='DR  '
      IERROR='NO'
      XMIDR=CPUMIN
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 SHMIDR--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,52)ISUBRO,IBUGA3,N
   52   FORMAT('ISUBRO,IBUGA3,N = ',2(A4,2X),I8)
        CALL DPWRST('XXX','BUG ')
        DO55I=1,N
          WRITE(ICOUT,56)I,X(I)
   56     FORMAT('I,X(I) = ',I8,G15.7)
          CALL DPWRST('XXX','BUG ')
   55   CONTINUE
      ENDIF
C
C               ***********************
C               **  COMPUTE SHMIDRN  **
C               ***********************
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      AN=N
C
      IF(N.LT.1 .OR. N.GT.MAXNXT)THEN
        IERROR='YES'
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,111)
  111   FORMAT('***** ERROR IN SHORTEST HALF MIDRANGE--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,112)
  112   FORMAT('      THE NUMBER OF OBSERVATIONS IN THE RESPONSE')
        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,'.')
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
      IF(N.EQ.1)THEN
        XMIDR=X(1)
        GOTO800
      ELSEIF(N.EQ.2)THEN
        XMIDR=(X(1)+X(2))/2.0
        GOTO800
      ELSEIF(N.EQ.3)THEN
        XMIDR=(X(1)+X(2)+X(3))/3.0
        GOTO800
      ENDIF
C
      HOLD=X(1)
      DO135I=2,N
        IF(X(I).NE.HOLD)GOTO139
  135 CONTINUE
      XMIDR=HOLD
      GOTO800
  139 CONTINUE
C
C               ****************************
C               **  STEP 2--              **
C               **  COMPUTE THE SHMIDRN.  **
C               ****************************
C
      CALL SORT(X,N,XTEMP)
C
C     FIND K
C
      M=(N/2)
      IF(MOD(N,2).EQ.1)M=M+1
      NLAST=N-M
      DIFF=XTEMP(1+M)-XTEMP(1)
      K=1
      DO200I=2,NLAST
        HOLD=XTEMP(I+M) - XTEMP(I)
        IF(HOLD.LT.DIFF)THEN
          DIFF=HOLD
          K=I
        ENDIF
  200 CONTINUE
C
      XMIDR=(XTEMP(K) + XTEMP(K+M))/2.0
C
C               *******************************
C               **  STEP 3--                 **
C               **  WRITE OUT A LINE         **
C               **  OF SUMMARY INFORMATION.  **
C               *******************************
C
  800 CONTINUE
      IF(IFEEDB.EQ.'ON' .AND. IWRITE.EQ.'ON')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,821)N,XMIDR
  821   FORMAT('THE SHORTEST HALF MIDRANGE OF THE ',I8,
     1         ' OBSERVATIONS = ',G15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'ON')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END       OF SHMIDR--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9012)IBUGA3,IERROR,K,M,XMIIDM
 9012   FORMAT('IBUGA3,IERROR,K,M,XMIDR = ',2(A4,2X),2I8,G15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      RETURN
      END
      SUBROUTINE SIMPDI(Y,N,IWRITE,RIGHT,TEMP1,TEMP2,ICASE1,
     1                  IBUGA3,ISUBRO,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE SIMPSON DIVERSITY INDEX.
C
C              THE FOLLOWING CASES ARE SUPPORTED:
C
C              1) IF ICASE1 = 'RAW', THEN "Y" IS A GROUP-ID VARIABLE.
C                 DATAPLOT WILL GENERATE A FREQUENCY TABLE FOR THE
C                 GROUPS AND THEN COMPUTE THE SIMPSON DIVERSITY INDEX AS
C
C                     D = SUM[i=1 TO K][(F(i)/N)**2]
C
C                 WHERE N IS THE COUNT OVER ALL GROUPS, K IS THE NUMBER OF
C                 GROUPS, AND F(i) IS THE FREQUENCY OF THE i-TH GROUP.
C
C             2) IF ICASE1 = 'SUMMARY', THEN
C
C                a) SUM THE VALUES IN Y.  IF THIS SUM EQUALS 1, THEN ASSUME
C                   THAT Y DENOTES THE PROPORTIONS FOR EACH GROUP AND
C                   COMPUTE THE STATISTIC AS
C
C                        D = SUM[i=1 TO K][P(i)**2]
C
C                b) IF THE SUM IS NOT EQUAL TO 1, THEN ASSUME THAT Y
C                   DENOTES THE COUNTS FOR EACH GROUP AND COMPUTE THE
C                   STATISTIC AS FOR THE RAW CASE (I.E., JUST SKIP THE
C                   BINNING STEP).
C
C     INPUT  ARGUMENTS--Y      = THE SINGLE PRECISION VECTOR OF OBSERVATIONS.
C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR Y.
C     OUTPUT ARGUMENTS--RIGHT  = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED SIMPSON DIVERSITY INDEX.
C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
C             SAMPLE SIMPSON DIVERSITY INDEX.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--FREQUE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     WRITTEN BY--ALAN HECKERT
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2899
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2011/12
C     ORIGINAL VERSION--DECEMBER  2011.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 ICASE1
      CHARACTER*4 IBUGA3
      CHARACTER*4 ISUBRO
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
      DOUBLE PRECISION DSUM
      DOUBLE PRECISION DSUM2
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DYI
      DOUBLE PRECISION EPS
C
C---------------------------------------------------------------------
C
      DIMENSION Y(*)
      DIMENSION TEMP1(*)
      DIMENSION TEMP2(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
      DATA EPS /1.0D-12/
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='SIMP'
      ISUBN2='DI  '
      IERROR='NO'
      RIGHT=CPUMIN
C
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'MPDI')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,51)
   51   FORMAT('***** AT THE BEGINNING OF SIMPDI--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,52)IBUGA3,ISUBRO,N
   52   FORMAT('IBUGA3,ISUBRO,N = ',2(A4,2X),I8)
        CALL DPWRST('XXX','BUG ')
        DO55I=1,N
          WRITE(ICOUT,56)I,Y(I)
   56     FORMAT('I,Y(I) = ',I8,G15.7)
          CALL DPWRST('XXX','BUG ')
   55   CONTINUE
      ENDIF
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      IF(N.LT.1)THEN
        IERROR='YES'
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,111)
  111   FORMAT('***** ERROR IN SIMPSON DIVERSITY INDEX--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,112)
  112   FORMAT('      THE NUMBER OF OBSERVATIONS FOR THE RESPONSE')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,113)
  113   FORMAT('      VARIABLES IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,117)N
  117   FORMAT('      THE NUMBER OF OBSERVATIONS      = ',I8)
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
      IF(ICASE1.EQ.'RAW')THEN
        NUMVAR=1
        ND=0
        CALL FREQUE(Y,N,TEMP1,ND,NUMVAR,IWRITE,
     1              TEMP2,K,IBUGA3,IERROR)
        IF(IERROR.EQ.'YES')GOTO9000
        DSUM=0.0D0
        DSUM2=0.0D0
        DO1210I=1,K
          ITEMP=INT(TEMP2(I)+0.5)
          IF(ITEMP.GT.0)THEN
            DYI=DBLE(ITEMP)
            DSUM=DSUM + DYI**2
            DSUM2=DSUM2 + DBLE(ITEMP)
          ENDIF
 1210   CONTINUE
        IF(DSUM2.LE.0.0D0)THEN
          IERROR='YES'
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,111)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,1212)
 1212     FORMAT('      THE TOTAL FREQUENCY COUNT WAS NON-POSITIVE.')
          CALL DPWRST('XXX','BUG ')
          GOTO9000
        ELSE
          DTERM1=DSUM/DSUM2**2
          RIGHT=REAL(DTERM1)
        ENDIF
      ELSE
        DSUM=0.0D0
        DO2000I=1,N
          IF(Y(I).LT.0.0)THEN
            IERROR='YES'
            WRITE(ICOUT,999)
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,111)
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,2012)
 2012       FORMAT('      A NEGATIVE PROPORTION OR COUNT WAS ',
     1             'ENCOUNTERED.')
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,2013)I,Y(I)
 2013       FORMAT('      ROW ',I8,' = ',G15.7)
            CALL DPWRST('XXX','BUG ')
            GOTO9000
          ENDIF
          DSUM=DSUM + DBLE(Y(I))
 2000   CONTINUE
C
        IF(DABS(DSUM - 1.0D0).LE.EPS)THEN
          DSUM=0.0D0
          DO2110I=1,N
            IF(Y(I).GT.0.0)THEN
              DYI=DBLE(Y(I))
              DSUM=DSUM + DYI**2
            ENDIF
 2110     CONTINUE
          RIGHT=REAL(DSUM)
        ELSE
          DSUM=0.0D0
          DSUM2=0.0D0
          DO2210I=1,N
            ITEMP=INT(Y(I)+0.5)
            IF(ITEMP.GT.0)THEN
              DYI=DBLE(ITEMP)
              DSUM=DSUM + DYI**2
              DSUM2=DSUM2 + DBLE(ITEMP)
            ENDIF
 2210     CONTINUE
          IF(DSUM2.LE.0.0D0)THEN
            IERROR='YES'
            WRITE(ICOUT,999)
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,111)
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,2212)
 2212       FORMAT('      THE TOTAL FREQUENCY COUNT WAS NON-POSITIVE.')
            CALL DPWRST('XXX','BUG ')
            GOTO9000
          ELSE
            DTERM1=DSUM/DSUM2**2
            RIGHT=REAL(DTERM1)
          ENDIF
        ENDIF
      ENDIF
C
C               *******************************
C               **  STEP 3--                 **
C               **  WRITE OUT A LINE         **
C               **  OF SUMMARY INFORMATION.  **
C               *******************************
C
      IF(IFEEDB.EQ.'ON' .AND. IWRITE.EQ.'ON')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,811)RIGHT
  811   FORMAT('THE SIMPSON DIVERSITY INDEX = ',G15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'MPDI')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END       OF SIMPDI--')
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      RETURN
      END
      SUBROUTINE SHIFTC(X,N1,NSHIFT,MAXOBV,Y,N2,
     1                  ISUBRO,IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE SETS THE VECTOR Y EQUAL TO THE
C              VECTOR Y AND THEN CIRCULAR SHIFTS THE ELEMENTS IN Y
C              EITHER TO THE LEFT (IF NSHIFT < 0) OR TO THE RIGHT
C              (IF NSHIFT > 0).
C     INPUT  ARGUMENTS--X      = A SINGLE PRECISION VECTOR CONTAINING
C                                THE DATA TO BE SHIFTED.
C                     --N1     = THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE INPUT VECTOR.
C                     --NSHIFT = THE INTEGER NUMBER THAT SPECIFIES
C                                THE NUMBER OF ELEMENTS TO SHIFT
C     OUTPUT ARGUMENTS--Y      = THE OUTPUT ARRAY THAT WILL CONTAIN
C                                SHIFTED ELEMENTS.
C                     --N2     = THE NUMBER OF ELEMENTS IN THE OUTPUT
C                                ARRAY.
C     OUTPUT--THE COMPUTED SINGLE PRECISION ARRAY Y.
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                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2009.6
C     ORIGINAL VERSION--JUNE      2009.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C
      INTEGER N1
      INTEGER N2
      INTEGER NSHIFT
      REAL X(*)
      REAL Y(*)
C
      CHARACTER*4 ISUBRO
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'IFTC')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,51)
   51   FORMAT('***** AT THE BEGINNING OF SHIFTC--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,52)IBUGA3,ISUBRO,N1,MAXOBV
   52   FORMAT('IBUGA3,ISUBRO,N1,MAXOBV = ',2(A4,2X),2I8)
        CALL DPWRST('XXX','BUG ')
        IF(N1.GT.0)THEN
          DO55I=1,N1
            WRITE(ICOUT,56)I,X(I)
   56       FORMAT('I,X(I) = ',I8,2X,G15.7)
            CALL DPWRST('XXX','BUG ')
   55     CONTINUE
        ENDIF
      ENDIF
C
      NTEMP=0
C
      IF(N1.LT.1)THEN
        WRITE(ICOUT,1011)
 1011   FORMAT('***** ERROR IN CIRCULAR SHIFT OPERATION--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,1013)N1
 1013   FORMAT('      THE NUMBER OF ELEMENTS IN THE INPUT VARIABLE ',
     1         'IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        GOTO9000
      ENDIF
C
      DO2000I=1,N1
        Y(I)=X(I)
 2000 CONTINUE
C
      IF(NSHIFT.GT.0)THEN
        DO2100I=1,N1
          IINDX=MOD(I+NSHIFT-1,N1)+1
          Y(IINDX)=X(I)
C
          IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'IFTC')THEN
            WRITE(ICOUT,999)
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,2101)I,NSHIFT,IINDX
 2101       FORMAT('I,NSHIFT,IINDX=',3I8)
            CALL DPWRST('XXX','BUG ')
          ENDIF
C
 2100   CONTINUE
      ELSEIF(NSHIFT.LT.0)THEN
C
        IF(ABS(NTEMP).LE.N1)THEN
          NTEMP=NSHIFT
        ELSE
          NTEMP=MOD(ABS(NSHIFT),N1)
        ENDIF
C
        DO2200I=1,N1
          IINDX=MOD(I-NTEMP-1,N1)+1
          Y(I)=X(IINDX)
C
          IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'IFTC')THEN
            WRITE(ICOUT,999)
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,2201)I,NSHIFT,IINDX
 2201       FORMAT('I,NSHIFT,IINDX=',3I8)
            CALL DPWRST('XXX','BUG ')
          ENDIF
C
2200    CONTINUE
      ENDIF
C
      N2=N1
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'IFTC')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9051)
 9051   FORMAT('***** AT THE END OF SHIFTC--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9052)N2
 9052   FORMAT('N2 = ',I8)
        CALL DPWRST('XXX','BUG ')
        IF(N2.GT.0)THEN
          DO9055I=1,N2
            WRITE(ICOUT,9056)I,Y(I)
 9056       FORMAT('I,Y(I) = ',I8,2X,G15.7)
            CALL DPWRST('XXX','BUG ')
 9055     CONTINUE
        ENDIF
      ENDIF
C
      RETURN
      END
      SUBROUTINE SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1IBUGO2,IERROR)
C
C     PURPOSE--SHIFT TO THE LEFT (ONLY)
C              THE IHARG,IHARG2,IARG,ARG, AND IARGT VECTORS
C              AND ADJUST THE VALUE OF NUMARG ACCORDINGLY.
C              THE ADJUSTMENT RESULTS IN
C              ALL ELEMENTS BEING SHIFTED
C              ISHIFT STEPS TO THE LEFT.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--82/7
C     ORIGINAL VERSION--APRIL     1978.
C     UPDATED         --JUNE      1978.
C     UPDATED         --JANUARY   1981.
C     UPDATED         --JULY      1981.
C     UPDATED         --NOVEMBER  1981.
C     UPDATED         --MAY       1982.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IHARG
      CHARACTER*4 IHARG2
      CHARACTER*4 IARGT
C
      CHARACTER*4 IBUGO2
      CHARACTER*4 IERROR
C
C---------------------------------------------------------------------
C
      DIMENSION IHARG(*)
      DIMENSION IHARG2(*)
      DIMENSION IARG(*)
      DIMENSION ARG(*)
      DIMENSION IARGT(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      IERROR='NO'
C
      IF(IBUGO2.EQ.'OFF')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF SHIFTL--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)ISHIFT,NUMARG
   52 FORMAT('ISHIFT,NUMARG = ',2I8)
      CALL DPWRST('XXX','BUG ')
      DO55I=1,NUMARG
      WRITE(ICOUT,56)I,IHARG(I),IHARG2(I),IARG(I),ARG(I),IARGT(I)
   56 FORMAT('I,IHARG(I),IHARG2(I),IARG(I),ARG(I),IARGT(I) = ',
     1I8,2X,A4,A4,I8,E15.7,2X,A4)
      CALL DPWRST('XXX','BUG ')
   55 CONTINUE
   90 CONTINUE
C
      IMIN=1
      IMAX=NUMARG-ISHIFT
      DO100I=IMIN,IMAX
      IPSHIF=I+ISHIFT
      IHARG(I)=IHARG(IPSHIF)
      IHARG2(I)=IHARG2(IPSHIF)
      IARG(I)=IARG(IPSHIF)
      ARG(I)=ARG(IPSHIF)
      IARGT(I)=IARGT(IPSHIF)
  100 CONTINUE
C
      DO200I=IMAX+1,NUMARG
      IHARG(I)='    '
      IHARG2(I)='    '
      IARG(I)=-1
      ARG(I)=CPUMIN
      IARGT(I)='    '
  200 CONTINUE
C
      NUMARG=IMAX
      GOTO9000
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      IF(IBUGO2.EQ.'OFF')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF SHIFTL--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)ISHIFT,NUMARG
 9012 FORMAT('ISHIFT,NUMARG = ',2I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)IMIN,IMAX
 9013 FORMAT('IMIN,IMAX = ',2I8)
      CALL DPWRST('XXX','BUG ')
      DO9015I=1,NUMARG
      WRITE(ICOUT,9016)I,IHARG(I),IHARG2(I),IARG(I),ARG(I),IARGT(I)
 9016 FORMAT('I,IHARG(I),IHARG2(I),IARG(I),ARG(I),IARGT(I) = ',
     1I8,2X,A4,A4,I8,E15.7,2X,A4)
      CALL DPWRST('XXX','BUG ')
 9015 CONTINUE
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1IBUGO2,IERROR)
C
C     PURPOSE--SHIFT TO THE RIGHT (ONLY)
C              THE IHARG,IHARG2,IARG,ARG, AND IARGT VECTORS
C              AND ADJUST THE VALUE OF NUMARG ACCORDINGLY.
C              THE ADJUSTMENT RESULTS IN
C              ALL ELEMENTS BEING SHIFTED
C              ISHIFT STEPS TO THE RIGHT.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--82/7
C     ORIGINAL VERSION--APRIL     1978.
C     UPDATED         --JUNE      1978.
C     UPDATED         --JANUARY   1981.
C     UPDATED         --JULY      1981.
C     UPDATED         --NOVEMBER  1981.
C     UPDATED         --MAY       1982.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IHARG
      CHARACTER*4 IHARG2
      CHARACTER*4 IARGT
C
      CHARACTER*4 IBUGO2
      CHARACTER*4 IERROR
C
C---------------------------------------------------------------------
C
      DIMENSION IHARG(*)
      DIMENSION IHARG2(*)
      DIMENSION IARG(*)
      DIMENSION ARG(*)
      DIMENSION IARGT(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      IERROR='NO'
C
      IF(IBUGO2.EQ.'OFF')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF SHIFTR--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)ISHIFT,NUMARG
   52 FORMAT('ISHIFT,NUMARG = ',2I8)
      CALL DPWRST('XXX','BUG ')
      DO55I=1,NUMARG
      WRITE(ICOUT,56)I,IHARG(I),IHARG2(I),IARG(I),ARG(I),IARGT(I)
   56 FORMAT('I,IHARG(I),IHARG2(I),IARG(I),ARG(I),IARGT(I) = ',
     1I8,2X,A4,A4,I8,E15.7,2X,A4)
      CALL DPWRST('XXX','BUG ')
   55 CONTINUE
   90 CONTINUE
C
      IMIN=1+ISHIFT
      IMAX=NUMARG+ISHIFT
      DO100I=IMIN,IMAX
      IREV=IMAX-I+IMIN
      IREV2=IREV-ISHIFT
      IHARG(IREV)=IHARG(IREV2)
      IHARG2(IREV)=IHARG2(IREV2)
      IARG(IREV)=IARG(IREV2)
      ARG(IREV)=ARG(IREV2)
      IARGT(IREV)=IARGT(IREV2)
  100 CONTINUE
      NUMARG=IMAX
      GOTO9000
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      IF(IBUGO2.EQ.'OFF')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF SHIFTR--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)ISHIFT,NUMARG
 9012 FORMAT('ISHIFT,NUMARG = ',2I8)
      CALL DPWRST('XXX','BUG ')
      DO9015I=1,NUMARG
      WRITE(ICOUT,9016)I,IHARG(I),IHARG2(I),IARG(I),ARG(I),IARGT(I)
 9016 FORMAT('I,IHARG(I),IHARG2(I),IARG(I),ARG(I),IARGT(I) = ',
     1I8,2X,A4,A4,I8,E15.7,2X,A4)
      CALL DPWRST('XXX','BUG ')
 9015 CONTINUE
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE SHIFTZ(X,N1,NSHIFT,MAXOBV,Y,N2,
     1                  ISUBRO,IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE SETS THE VECTOR Y EQUAL TO THE
C              VECTOR Y AND THEN SHIFTS THE ELEMENTS IN Y EITHER
C              TO THE LEFT (IF NSHIFT < 0) OR TO THE RIGHT
C              (IF NSHIFT > 0).
C     INPUT  ARGUMENTS--X      = A SINGLE PRECISION VECTOR CONTAINING
C                                THE DATA TO BE SHIFTED.
C                     --N1     = THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE INPUT VECTOR.
C                     --NSHIFT = THE INTEGER NUMBER THAT SPECIFIES
C                                THE NUMBER OF ELEMENTS TO SHIFT
C     OUTPUT ARGUMENTS--Y      = THE OUTPUT ARRAY THAT WILL CONTAIN
C                                SHIFTED ELEMENTS.
C                     --N2     = THE NUMBER OF ELEMENTS IN THE OUTPUT
C                                ARRAY.
C     OUTPUT--THE COMPUTED SINGLE PRECISION ARRAY Y.
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                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2009.2
C     ORIGINAL VERSION--FEBRUARY  2009.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C
      INTEGER N1
      INTEGER N2
      INTEGER NSHIFT
      REAL X(*)
      REAL Y(*)
C
      CHARACTER*4 ISUBRO
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'IFTZ')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,51)
   51   FORMAT('***** AT THE BEGINNING OF SHIFTZ--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,52)IBUGA3,ISUBRO,N1
   52   FORMAT('IBUGA3,ISUBRO,N1 = ',A4,2X,A4,2X,I8)
        CALL DPWRST('XXX','BUG ')
        IF(N1.GT.0)THEN
          DO55I=1,N1
            WRITE(ICOUT,56)I,X(I)
   56       FORMAT('I,X(I) = ',I8,2X,G15.7)
            CALL DPWRST('XXX','BUG ')
   55     CONTINUE
        ENDIF
      ENDIF
C
      IF(N1.LT.1)THEN
        WRITE(ICOUT,1011)
 1011   FORMAT('***** ERROR IN SHIFT OPERATION--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,1013)N1
 1013   FORMAT('      THE NUMBER OF ELEMENTS IN THE INPUT VARIABLE ',
     1         'IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        GOTO9000
      ENDIF
C
      DO2000I=1,N1
        Y(I)=X(I)
 2000 CONTINUE
C
      IF(NSHIFT.GT.0)THEN
        N2=NSHIFT
        DO2100I=1,N1
          N2=N2+1
C
          IF(N2.GT.MAXOBV)THEN
            WRITE(ICOUT,1011)
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,2113)
 2113       FORMAT('      THE MAXIMUM NUMBER OF ROWS FOR THE OUTPUT')
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,2115)
 2115       FORMAT('      VARIABLE HAS BEEN EXCEEDED.')
            CALL DPWRST('XXX','BUG ')
            IERROR='YES'
            GOTO9000
          ENDIF
C
          Y(N2)=X(I)
2100    CONTINUE
      ELSEIF(NSHIFT.LT.0)THEN
        ICNT=0
        NSTRT=ABS(NSHIFT)+1
        DO2200I=NSTRT,N1
          ICNT=ICNT+1
          Y(ICNT)=X(I)
2200    CONTINUE
        N2=N1
      ENDIF
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'IFTZ')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9051)
 9051   FORMAT('***** AT THE END OF SHIFTZ--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9052)N2
 9052   FORMAT('N2 = ',I8)
        CALL DPWRST('XXX','BUG ')
        IF(N2.GT.0)THEN
          DO9055I=1,N1
            WRITE(ICOUT,9056)I,Y(I)
 9056       FORMAT('I,Y(I) = ',I8,2X,G15.7)
            CALL DPWRST('XXX','BUG ')
 9055     CONTINUE
        ENDIF
      ENDIF
C
      RETURN
      END
      SUBROUTINE SICIEI(IC,X,SI,CI,CII,EI,EXNEI,SHI,CHI,CHII,IERR)
C
C                         APPENDIX
C
C                   IMPLEMENTING PROGRAM
C LANGUAGE. AMERICAN NATIONAL STANDARD FORTRAN
C DEFINITIONS. X, A REAL VARIABLE
C     SI(X) =INTEGRAL(SIN T/T)DT FROM 0 TO X
C     SI(-X)=-SI(X)
C     CI(X) =GAMMA+LN X+INTEGRAL((COS T-1)/T)DT FROM 0 TO X
C     CI(-X)=CI(X)-I PI
C     EI(X) =-P.V.INTEGRAL(EXP(-T)/T)DT FROM -X TO INFINITY
C     EXNEI(X)=EXP(-X)*EI(X)                      (X .GT. 0)
C         INTEGRAL(EXP(-T)/T) DT FROM X TO INFINITY, OFTEN
C         DENOTED BY -EI(-X)=E1(X). (SEE AUTOMATIC COMPUTING
C         METHODS FOR SPECIAL FUNCTIONS, PART II. THE EXPO-
C         NENTIAL INTEGRAL EN(X), J. OF RESEARCH NBS, 78B,
C         OCTOBER-DECEMBER 1974, PP. 199-216.)
C     SHI(X) =INTEGRAL(SINH T/T)DT FROM 0 TO X
C     SHI(-X)=-SHI(X)
C     CHI(X)=GAMMA+LN X+INTEGRAL((COSH T-1)/T)DT FROM 0 TO X
C     CHI(-X)=CHI(X)-I PI
C                 GAMMA(EULER'S CONSTANT)=.5772156649...
C   SPECIAL CASES
C     X=0
C       SI(0)=SHI(0)=0
C       CI(0)=EI(0)=EXNEI(0)=CHI(0)=-INFINITY
C                                  =-MAX. MACH. VALUE (RINF)
C     LIMITING VALUES - X APPROACHES INFINITY
C       SI(X)=PI/2
C       CI(X)=0
C       EI(X)=SHI(X)=CHI(X)=INFINITY (RINF)
C       EXNEI(X)=0
C USAGE. CALL SICIEI (IC,X,SI,CI,CII,EI,EXNEI,SHI,CHI,CHII,
C                                                      IERR)
C     FORMAL PARAMETERS
C         IC      INTEGER TYPE                        INPUT
C                     IC  FUNCTIONS TO BE COMPUTED
C                      1    SI,CI
C                      2    EI,EXNEI
C                      3    EI,EXNEI,SHI,CHI
C                      4    SI,CI,EI,EXNEI,SHI,CHI
C         X       REAL OR DOUBLE PRECISION TYPE       INPUT
C         SI=SI(X)             (SAME TYPE AS X)       OUTPUT
C         CI+I CII=CI(X)              ''              OUTPUT
C         EI=EI(X)                    ''              OUTPUT
C         EXNEI=EXP(-X)*EI(X)         ''              OUTPUT
C         SHI=SHI(X)                  ''              OUTPUT
C         CHI+I CHII=CHI(X)           ''              OUTPUT
C         IERR    INTEGER TYPE                        OUTPUT
C                     IERR=0   X .GE. 0, NORMAL RETURN
C                     IERR=1   X .LT. 0, ERROR RETURN IF
C                                           IC=2
C MODIFICATIONS.
C     THE CODE IS SET UP FOR DOUBLE PRECISION COMPUTATION
C     WITH DOUBLE PRECISION TYPE STATEMENTS
C          DOUBLE PRECISION FUNCTION REFERENCES AND,PARTICU-
C     LARLY,FOR THE UNIVAC 1108 WITH (SEE DEFINITIONS BELOW)
C          RINF APPROX. 2**1023,ULSC=2**56,NBM=60 AND OTHER
C     CONSTANTS IN DOUBLE PRECISION FORMAT TO 19 SIGNIFICANT
C     FIGURES. ALL ABOVE ITEMS MUST BE CHANGED FOR SINGLE
C     PRECISION COMPUTATIONS WITH DATA ADJUSTMENTS FOR OTHER
C     COMPUTERS.
C   AUXILIARY FUNCTIONS
C       VARIOUS FUNCTIONS ARE AVAILABLE TO GREATER ACCURACY
C       AT INTERMEDIATE POINTS IN THE SUBROUTINE,NAMELY,
C           SI-(PI/2)=IMAG. PART OF THE CONTINUED FRACTION
C           CI(EI AND CHI)-GAMMA-LN X=SUM OF SERIES
C   CAUTION - THE SUBROUTINE CANNOT READILY BE ADAPTED TO
C             COMPUTE THE FUNCTIONS FOR COMPLEX ARGUMENTS.
C METHOD.   T=ABS(X)
C     POWER SERIES   T .LE. PSLSC(=2) FOR SI,CI
C                    T .LE. AELL(=-LN(TOLER)) FOR EI,SHI,CHI
C         SI=SUMS(SGN(RK)*TM(RK))  IP=-1  RK=1,3,...,RKO
C         CI=SUMC(SGN(RK)*TM(RK))  IP=+1  RK=2,4,...,RKE
C                +EULER+XLOG
C         SHI=SUMOT(TM(RK))        IP=-1  RK=1,3,...,RKO
C         CHI=SUMET(TM(RK))        IP=+1  RK=2,4,...,RKE
C                +EULER+XLOG
C         EI=SUMOT+SUMET+EULER+XLOG               (X .GT. 0)
C               SGN(1)=1
C               SGN(RK+1)=-SGN(RK)        RK=1,3,...
C               SGN(RK+1)=+SGN(RK)        RK=2,4,...
C               TM(RK)=((T**RK)/(1*2...RK))/RK
C                     =PTM(RK)/RK
C                   PTM(1)=T
C                   PTM(RK+1)=PTM(RK)*(T/(RK+1))   RK .GE. 1
C               IF TM(RK)/SUM .LT. TOLER
C                 RKE=RK WHERE SUM=ABS(SUMC)       IC=1 OR 4
C                              SUM=SUMET           IC=2 OR 3
C                                          IC=4,X .GT. PSLSC
C                 RKO=RK WHERE SUM=ABS(SUMS)       IC=1 OR 4
C                              SUM=SUMOT           IC=2 OR 3
C                                          IC=4,X .GT. PSLSC
C         EXNEI= EI/EXP(T/2)/EXP(T/2)
C              =(EI/EXPHT)/EXPHT
C     CONTINUED FRACTION    T .GT. PSLSC
C         -CI+I(SI-PI/2)=E1(IT)
C                       =EXP(-IT)*(1 I/I (1+IT)-
C                               1**2 I/I (3+IT)-
C                               2**2 I/I (5+IT)-...)
C                       =EXP(-IT)*II(AM(RM) I/I BM(RM))
C                                             RM=1,2,...,RMF
C                            AM(1)=1
C                            AM(RM)=-(RM-1)**2     RM .GT. 1
C                            BM(RM)=2*RM-1+IT=BMR+I BMI
C                       =EXP(-IT)*(FM/GM)
C                       =EXP(-IT)*(FMR+I FMI)/(GMR+I GMI)
C                       =EXP(-IT)*F(RM)
C                       =(COST-I SINT)*(FR+I FI)
C         -CI+I(SI-PI/2)=(FR*COST+FI*SINT)+
C                                         I(FI*COST-FR*SINT)
C                         IF RESQ(RM) .LE. TOLSQ(=TOLER**2)
C                             OR RESQ(RM) .GE. RESQ(RM-1)
C                               (RESQ .GE. RESQP)
C                         RMF=RM  WHERE
C                             RESQ=(MOD(1-F(RM-1)/F(RM)))**2
C     ASYMPTOTIC EXPANSION    T .GT. AELL
C         EI=(EXNEI*EXPHT)*EXPHT
C         EXNEI=(1+SUME(TM(RK)))/T            RK=1,2,...,RKF
C         SHI=CHI=EI/2
C             TM(RK)=(1*2...RK)/(T**RK)
C             TM(0)=1
C             TM(RK)=(RK/T)*TM(RK-1)               RK .GE. 1
C               IF TM(RK) .LT. TOLER (CONVERGENCE) RKF=RK OR
C                  TM(RK) .GE. TM(RK-1)(DIVERGENCE) RKF=RK-1
C RANGE.
C     FOR SI(X),CI(X), ABS(X) .LT. ULSC(UPPER LIMIT FOR
C                                           SIN,COS ROUTINE)
C         X=APPROXIMATELY 2**21, NBM=27
C                         2**56, NBM=60
C     FOR EXP(-X)*EI(X), X .LE. RINF
C     FOR EI(X), X .LT. XMAXEI (APPROXIMATELY 92.5,  NBC=8,
C                                            715.6,  NBC=11)
C                 NBC=NUMBER OF BINARY DIGITS IN THE BIASED
C                 CHARACTERISTIC OF A FLOATING POINT NUMBER
C     FOR SHI(X),CHI(X), ABS(X) .LT. XMAXHF
C         X=APPROXIMATELY 93.2,   NBC=8
C                        716.3,   NBC=11
C ACCURACY. THE MAXIMUM RELATIVE ERROR, EXCEPT FOR REGIONS
C           IN THE IMMEDIATE NEIGHBORHOOD OF ZEROS,ON THE
C           UNIVAC 1108 IS 4.5(-7) FOR SINGLE PRECISION COM-
C           PUTATION AND 7.5(-17) FOR DOUBLE PRECISION COM-
C           PUTATION.
C PRECISION. VARIABLE - BY SETTING THE DESIRED VALUE OF NBM
C                       OR A PREDETERMINED VALUE OF TOLER
C MAXIMUM     UNIVAC 1108 TIME/SHARING EXECUTIVE SYSTEM
C TIMING.      NBM=27   NBM=60
C (SECONDS)     .0093    .070
C STORAGE. 954 WORDS REQUIRED BY THE UNIVAC 1108 COMPILER
C
C
C          MACHINE DEPENDENT STATEMENTS
C               TYPE STATEMENTS
C
      INCLUDE 'DPCOMC.INC'
C
      DOUBLE PRECISION X,SI,CI,CII,EI,EXNEI,SHI,CHI,CHII
      DOUBLE PRECISION A,AELL,AM,AMIN,ASUMSC,
     1       BMI,BMR,COST,EXPL,EXPHT,
     2       FI,FIP,FMI,FMM1I,FMM1R,FMM2I,FMM2R,FMR,FR,FRP,
     3       GMI,GMM1I,GMM1R,GMM2I,GMM2R,GMR,
     4       PSLL,PSLSC,PTM,RE,RESQ,RESQP,RK,RM,
     5       SCC,SFMI,SFMR,SGMI,SGMR,SGN,
     6       SINT,SUMC,SUME,SUMEO,SUMET,SUMOT,SUMS,SUMSC,
     7       T,TEMP,TEMPA,TEMPB,TM,TMAX,TMM1,TOLER,TOLSQ,
     8       XLOG,XMAXEI,XMAXHF
      DOUBLE PRECISION RINF,ULSC,EULER,HALFPI,PI,ALOG2,
     1                 ZERO,ONE,TWO,FOUR
      DIMENSION A(4)
      EQUIVALENCE (FMR,A(1)), (FMI,A(2)), (GMR,A(3)),
     1            (GMI,A(4))
C               CONSTANTS
      DATA EULER/.5772156649015328606D0/
      DATA HALFPI/1.570796326794896619D0/
      DATA PI/3.141592653589793238D0/
      DATA ALOG2/.6931471805599453094D0/
      DATA ZERO,ONE,TWO,FOUR /
     1     0.0D0,1.D0,2.D0,4.D0/
C                 RINF=MAXIMUM MACHINE VALUE
C                 ULSC=MAXIMUM ARGUMENT FOR SIN,COS ROUTINE
C                        APPROX. 2**(NBM-6) OR 10**(S-2)
C                                   (S=SIGNIFICANT FIGURES)
C                 NBM=ACCURACY DESIRED OR THE
C                     MAXIMUM NUMBER OF BINARY DIGITS IN THE
C                       MANTISSA OF A FLOATING POINT NUMBER
C                 TOLER=UPPER LIMIT FOR RELATIVE ERRORS
C                      =2**(-NBM)=APPROX. 10**(-S)
C TOLER PRECOMPUTED MAY BE INSERTED IN A DATA STATEMENT AND
C THE NBM DATA STATEMENT ELIMINATED
CCCCC DATA RINF/.8988465674311579538D308 /
CCCCC DATA ULSC/.72057594037927936D17/
CCCCC DATA NBM / 60 /
C
      RINF=D1MACH(2)
      NBM=I1MACH(14)
      ULSC=TWO**(NBM-6)
      TOLER=TWO**(-NBM)
C
C NOTE - ARGUMENT CHECKS PRECEDING FUNCTION REFERENCES
C        NECESSITATE ADDITIONAL MACHINE DEPENDENT STATEMENTS           0
C        IN THE STATEMENT NUMBER RANGE 140-150
C          INITIALIZATION OF OUTPUT FUNCTIONS
      SI=RINF
      CI=RINF
      CII=RINF
      EI=ZERO
      EXNEI=RINF
      SHI=ZERO
      CHI=ZERO
      CHII=RINF
C          VALIDITY CHECK ON INPUT PARAMETERS
C               INDICATOR CHECK
C                 SET IND=IC
C                   CHANGE IND=4 IF IC .LT. 1 OR .GT. 4
      IND=IC
      IF (IND .LT. 1) GO TO 10
      IF (IND .GT. 4) GO TO 10
      GO TO 20
  10  IND=4
C               ARGUMENT CHECK
C                 X .GE. 0    IERR=0
C                 X .LT. 0    IERR=1
C                             (ERROR RETURN IF IC=2)
  20  IERR=0
      T=X
  30  CONTINUE
C
CCCCC JUNE 2008: MODIFY FOLLOWING LINE SO THAT IT DOES NOT
CCCCC            GENERATE WARNING MESSAGES WITH FORTRAN 95 COMPILERS.
C
CCCCC IF (T) 40,50,90
      IF (T.LT.0) THEN
        GOTO40
      ELSEIF (T.EQ.0) THEN
        GOTO50
      ELSE
        GOTO90
      ENDIF
  40  T=-T
      IF (IND .EQ. 1) GO TO 30
      IERR=1
      IF (IND .NE. 2) GO TO 30
      IF (X .LT. ZERO) RETURN
C          SPECIAL CASES
C               X=0
  50  CONTINUE
CCCCC IF (IND-2) 80,70,60
      IF (IND-2.LT.0) THEN
         GOTO80
      ELSEIF (IND-2.EQ.0) THEN
         GOTO70
      ELSE
         GOTO60
      ENDIF
  60  SHI=ZERO
      CHI=-RINF
      CHII=ZERO
  70  EI=-RINF
      EXNEI=-RINF
      IF (IND .NE. 4) RETURN
  80  SI=ZERO
      CI=-RINF
      CII=ZERO
      RETURN
  90  IF (T .LT. ULSC) GO TO 140
C               ABS(X) .GE. ULSC
CCCCC IF (IND-2) 130,110,100
      IF (IND-2.LT.0) THEN
         GOTO130
      ELSEIF (IND-2.EQ.0) THEN
         GOTO110
      ELSE
         GOTO100
      ENDIF
 100  SHI=RINF
      CHI=RINF
      CHII=ZERO
      IF (IERR .EQ. 1) GO TO 120
 110  EI=RINF
      EXNEI=(ONE+(ONE/T))/T
 120  IF (IND .NE. 4) GO TO 1000
 130  SI=HALFPI
      CI=ZERO
      CII=ZERO
      GO TO 1000
C          EVALUATIONS FOR ABS(X)(=T) .GT. 0 AND .LT. ULSC
C               ADDITIONAL MACHINE DEPENDENT STATEMENTS
C                    FUNCTION REFERENCES
C                    CONTROL VARIABLES
 140  XLOG=DLOG(T)
      SINT=DSIN(T)
      COST=DCOS(T)
      EXPL =DLOG(RINF)
      XMAXEI=EXPL+DLOG(EXPL+DLOG(EXPL)) -ONE/EXPL
      XMAXHF=XMAXEI+ALOG2
      AELL=-DLOG(TOLER)
      AMIN=ONE/RINF
      PSLL=TWO*DSQRT(AMIN)
      PSLSC=TWO
C               EXPONENTIAL FUNCTION DETERMINATION
      IF (T .LE. TOLER) GO TO 150
      IF (T .GE. XMAXHF) GO TO 160
      EXPHT=DEXP(T/TWO)
      GO TO 170
 150  EXPHT=ONE
      GO TO 170
 160  EXPHT=RINF
C               METHOD SELECTION
 170  IF (T .LE. PSLSC) GO TO 200
      IF (IND .EQ. 1) GO TO 500
      IF (IND .EQ. 4) GO TO 500
 180  IF (T .GT. AELL) GO TO 800
      GO TO 230
C                    INDICATOR TO COMPUTE EI,SHI,CHI
 190  IF (IND .EQ. 1) GO TO 1000
      IND=3
      GO TO 180
C                    METHOD --- POWER SERIES
C                      SI(X),CI(X),           T .LE. PSLSC
C                      EI(X),SHI(X),CHI(X),   T .LE. AELL
C                         LIMITING VALUES, T NEAR ZERO
 200  IF (T .GT. PSLL) GO TO 210
      SUMC=ZERO
      SUMET=ZERO
      SUMS=T
      SUMOT=T
      GO TO 360
C                         INITIALIZATION FOR SI,CI
 210  IF (IND .NE. 1) GO TO 230
 220  SUMS=ZERO
      SUMC=ZERO
      SUMSC=ZERO
      SGN=ONE
      GO TO 240
C                         INITIALIZATION FOR SHI,CHI(AND EI)
 230  SUMOT=ZERO
      SUMET=ZERO
      SUMEO=ZERO
      IF (IND .EQ. 4) GO TO 220
C                              IP -  INDICATOR FOR ODD OR
C                                      EVEN TERMS
 240  IP=-1
      RK=ONE
      PTM=T
C                         COMPUTATION OF (T**K)/(1*2...K)/K
 250  TM=PTM/RK
C                         SUMMATION FOR SI(CI)
        IF (IND .NE. 1) GO TO 310
 260    SUMSC=SGN*TM+SUMSC
C                         RELATIVE ERROR FOR SI(CI)
C PARTIAL SUM OF ALTERNATING ODD(EVEN) TERMS MAY EQUAL ZERO
        ASUMSC=SUMSC
 270    CONTINUE
CCCCC   IF (ASUMSC) 280,300,290
        IF (ASUMSC.LT.0) THEN
           GOTO280
        ELSEIF (ASUMSC.EQ.0) THEN
           GOTO300
        ELSE
           GOTO290
        ENDIF
 280    ASUMSC=-ASUMSC
        GO TO 270
 290    RE=TM/ASUMSC
        GO TO 320
 300    RE=RINF
        GO TO 320
C                         SUMMATION FOR SHI(CHI)(AND EI)
 310    SUMEO=TM+SUMEO
        IF (IND .EQ. 4) GO TO 260
C                         RELATIVE ERROR FOR SHI(CHI)
        RE=TM/SUMEO
C                         SIGN CHANGE AND SELECTION
C                         OF SUMS OF ODD(EVEN) TERMS
 320    IF (IP .EQ. 1) GO TO 330
        SGN=-SGN
        SUMS=SUMSC
        SUMSC=SUMC
        SUMOT=SUMEO
        SUMEO=SUMET
        GO TO 340
 330    SUMC=SUMSC
        SUMSC=SUMS
        SUMET=SUMEO
        SUMEO=SUMOT
C                         RELATIVE ERROR CHECK
 340    IF (RE .LT. TOLER) GO TO 360
C                         ADDITIONAL TERMS
        RK=RK+ONE
C                              UNDERFLOW TEST
C UNDERFLOWS AFFECTING ACCURACY ARE AVOIDED. ALL OTHER
C UNDERFLOWS ARE ASSUMED TO BE SET EQUAL TO ZERO
        IF (T .GT. PSLSC) GO TO 350
        IF (PTM .LE. (AMIN*RK*RK)/T ) GO TO 360
 350    PTM=(T/RK)*PTM
        IP=-IP
        GO TO 250
C                         SI,CI EVALUATION
 360  IF (IND .NE. 1) GO TO 380
 370  SI=SUMS
      CI=(SUMC+XLOG)+EULER
      CII=ZERO
      GO TO 1000
C                         EI EVALUATION
 380  IF (X .LE. ZERO) GO TO 390
      EI=(SUMET+SUMOT+XLOG)+EULER
      EXNEI=(EI/EXPHT)/EXPHT
      IF (IND .EQ. 2) RETURN
C                         SHI,CHI EVALUATION
 390  SHI=SUMOT
      CHI=(EULER+SUMET)+XLOG
      CHII=ZERO
      IF (IND .NE. 4) GO TO 1000
      GO TO 370
C                    METHOD --- CONTINUED FRACTION
C                      SI(X),CI(X),       T .GT. PSLSC
C                      -CI(T) + I (SI(T)-HALFPI)=E1(IT)
C                         INITIALIZATION
 500  SCC=RINF/FOUR
      TOLSQ=TOLER*TOLER
      RM=ONE
      AM=ONE
      BMR=ONE
      BMI=T
      FMM2R=ONE
      FMM2I=ZERO
      GMM2R=ZERO
      GMM2I=ZERO
      FMM1R=ZERO
      FMM1I=ZERO
      GMM1R=ONE
      GMM1I=ZERO
      RESQP=RINF
      FRP=ZERO
      FIP=ZERO
C                         RECURRENCE RELATION
C                           FM=BM*FMM1 + AM*FMM2
C                           GM=BM*GMM1 + AM*GMM2
 510  FMR=BMR*FMM1R-BMI*FMM1I+AM*FMM2R
        FMI=BMI*FMM1R+BMR*FMM1I+AM*FMM2I
        GMR=BMR*GMM1R-BMI*GMM1I+AM*GMM2R
        GMI=BMI*GMM1R+BMR*GMM1I+AM*GMM2I
C                         CONVERGENT F=FM/GM
C                           TESTS TO AVOID INCORRECT RESULTS
C                               DUE TO OVERFLOWS(UNDERFLOWS)
C                             FINDING MAXIMUM(=TMAX) OF
C                               ABSOLUTE OF FMR,GMR,FMI,GMI
C                               FOR SCALING PURPOSES
        TMAX=ZERO
        I=1
 520    TEMP=A(I)
 530      CONTINUE
CCCCC     IF (TEMP) 540,560,550
          IF (TEMP.LT.0) THEN
             GOTO540
          ELSEIF (TEMP.EQ.0) THEN
             GOTO560
          ELSE
             GOTO550
          ENDIF
 540      TEMP=-TEMP
          GO TO 530
 550      IF (TEMP .LE. TMAX) GO TO 560
          TMAX=TEMP
 560      IF (I .GE. 4) GO TO 570
          I=I+1
          GO TO 520
 570    SFMR=FMR/TMAX
        SFMI=FMI/TMAX
        SGMR=GMR/TMAX
        SGMI=GMI/TMAX
        TEMP=SGMR*SGMR + SGMI*SGMI
        FR=(SFMR*SGMR+SFMI*SGMI)/TEMP
        FI=(SFMI*SGMR-SFMR*SGMI)/TEMP
C                         RELATIVE ERROR CHECK
        TEMP=FR*FR+FI*FI
        TEMPA=(FRP*FR+FIP*FI)/TEMP
        TEMPB=(FIP*FR-FRP*FI)/TEMP
        TEMP=ONE-TEMPA
        RESQ =TEMP*TEMP+TEMPB*TEMPB
        IF (RESQ  .LE. TOLSQ) GO TO 590
        IF (RESQ .GE. RESQP) GO TO 580
C                         ADDITIONAL CONVERGENTS
        AM=-RM*RM
        RM=RM+ONE
        BMR=BMR+TWO
        FMM2R=FMM1R
        FMM2I=FMM1I
        GMM2R=GMM1R
        GMM2I=GMM1I
        FMM1R=FMR
        FMM1I=FMI
        GMM1R=GMR
        GMM1I=GMI
        FRP=FR
        FIP=FI
        RESQP=RESQ
C                         SCALING
C SCALING SHOULD NOT BE DELETED AS THE VALUES OF FMR,FMI AND
C GMR,GMI MAY OVERFLOW FOR SMALL VALUES OF T
        IF (TMAX .LT. SCC/(BMR-AM ) ) GO TO 510
        FMM2R=FMM2R/TMAX
        FMM2I=FMM2I/TMAX
        GMM2R=GMM2R/TMAX
        GMM2I=GMM2I/TMAX
        FMM1R=FMM1R/TMAX
        FMM1I=FMM1I/TMAX
        GMM1R=GMM1R/TMAX
        GMM1I=GMM1I/TMAX
        GO TO 510
C                         DIVERGENCE OF RELATIVE ERROR
C                           ACCEPT PRIOR CONVERGENT
 580  FR=FRP
      FI=FIP
C                         SI,CI EVALUATION
 590  SI=FI*COST-FR*SINT+HALFPI
      CI=-(FR*COST+FI*SINT)
      CII=ZERO
      GO TO 190
C                    METHOD --- ASYMPTOTIC EXPANSION
C                      EI(X),EXNEI(X)         X .GT. AELL
C                      SHI(T)=CHI(T)=EI(T)/2  T .GT. AELL
C                         INITIALIZATION
 800  IF (IND .NE. 2) GO TO 880
 810  SUME=ZERO
      RK=ZERO
      TM=ONE
C                         ADDITIONAL TERMS
 820  TMM1=TM
        RK=RK+ONE
        TM=(RK/T)*TM
C                         TOLERANCE CHECK
        IF (TM .LT. TOLER) GO TO 840
        IF (TM .GE. TMM1) GO TO 830
        SUME=SUME+TM
        GO TO 820
C                         DIVERGENT PATH
 830  SUME=SUME-TMM1
C                         EXNEI EVALUATION
 840  IF (X .LT. ZERO) GO TO 870
      EXNEI=(ONE+SUME)/T
C                         EI EVALUATION - X .LT. XMAXEI
      IF (T .GE. XMAXEI) GO TO 850
      EI=(EXNEI*EXPHT)*EXPHT
      GO TO 860
C                         EI - LIMITING VALUE, X .GE. XMAXEI
 850  EI=RINF
C                         SHI,CHI EVALUATION - T .LT. XMAXHF
 860  IF (IND .EQ. 2) RETURN
 870  IF (T .GE. XMAXHF) GO TO 1000
      SHI=(((( ONE+SUME)/T)/TWO)*EXPHT)*EXPHT
      CHI=SHI
      CHII=ZERO
      GO TO 1000
C                         SHI,CHI - LIMITING VALUE
C                                              T .GE. XMAXHF
 880  IF ( T .LT. XMAXHF) GO TO 810
      SHI=RINF
      CHI=RINF
      CHII=ZERO
      IF ( X .GT. ZERO) GO TO 810
      GO TO 1010
C          ADJUSTMENTS FOR X .LT. 0
1000  IF (X .GT. ZERO) RETURN
1010  IF (IC .EQ. 3) GO TO 1020
      SI=-SI
      CII=-PI
      IF (IC .EQ. 1) RETURN
1020  SHI=-SHI
      CHII=-PI
      RETURN
      END
      SUBROUTINE SIDEDI(XC,YC,NS,D,IB,JB,X,Y)
C
C     PURPOSE--XX
C
C     WRITTEN BY--DAVID W. BEHRINGER NOAA/AOML (MIAMI).
C                 AS PART OF NOAA'S CONCX V.3   MARCH 1988.
C     ORIGINAL VERSION (IN DATAPLOT)--AUGUST    1988.
C     UPDATED         --JANUARY   1989.  MORE CHANGES TO STANDARD FORTRAN 77--
C                                        CHANGED DO WHILE/END DO (ALAN HECKERT).
C
C---------------------------------------------------------------------
C
      DIMENSION IB(*)
      DIMENSION JB(*)
      DIMENSION X(*)
      DIMENSION Y(*)
C
C-----START POINT-----------------------------------------------------
C
      EPS=0.001*AMIN1(ABS(X(2)-X(1)),ABS(Y(2)-Y(1)))
      NS=0
      D=0.
      NB=1
CCCCC DO WHILE (NS.EQ.0)                 JANUARY 1989
  100 CONTINUE
      IF(NS.NE.0)GOTO199
        IF (IB(NB).EQ.IB(NB+1)) THEN
          I=IB(NB)
          J1=JB(NB)
          J2=JB(NB+1)
          IF (ABS(XC-X(I)).LE.EPS.AND.
     1         ABS(YC-Y(J1)).LT.ABS(Y(J2)-Y(J1))) THEN
            D=D+ABS(YC-Y(J1))
            NS=NB
          ELSE
            D=D+ABS(Y(J2)-Y(J1))
          END IF
        ELSE
          J=JB(NB)
          I1=IB(NB)
          I2=IB(NB+1)
          IF (ABS(YC-Y(J)).LE.EPS.AND.
     1         ABS(XC-X(I1)).LT.ABS(X(I2)-X(I1))) THEN
            D=D+ABS(XC-X(I1))
            NS=NB
          ELSE
            D=D+ABS(X(I2)-X(I1))
          END IF
        END IF
        NB=NB+1
CCCCC END DO                             JANUARY 1989
      GOTO100
  199 CONTINUE
      RETURN
      END
      SUBROUTINE SIMCOV(ISEED,IBUGA2,IBUGA3,IBUGCO,IBUGEV,IBUGQ,
     1                  ISUBRO,IFOUND,IERROR)
C
C     PURPOSE--CARRY OUT MARK VANGEL'S SIMCOV PROGRAM
C              FOR LINEAR MODELS.
C     WRITTEN BY--ALAN HECKERT
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2899
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--97/9
C     ORIGINAL VERSION--SEPTEMBER   1997.
C     UPDATED         --JULY        2019. TWEAK SCRATCH SPACE
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IBUGA2
      CHARACTER*4 IBUGA3
      CHARACTER*4 IBUGCO
      CHARACTER*4 IBUGEV
      CHARACTER*4 IBUGQ
      CHARACTER*4 ISUBRO
      CHARACTER*4 IFOUND
      CHARACTER*4 IERROR
C
      CHARACTER*4 ICASRE
      CHARACTER*4 ICASDG
      CHARACTER*4 ICASEQ
      CHARACTER*4 IKEY
      CHARACTER*4 IHRIGH
      CHARACTER*4 IHRIG2
      CHARACTER*4 IFLAG
C
      CHARACTER*4 IHWUSE
      CHARACTER*4 MESSAG
      CHARACTER*4 IHLEFT
      CHARACTER*4 IHLEF2
C
      CHARACTER*4 IVARN1
      CHARACTER*4 IVARN2
C
      CHARACTER*4 IWRITE
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 ISTEPN
C
CCCCC CHARACTER*20 IMODEL
C
      LOGICAL SATT
C
      DOUBLE PRECISION PCT
      DOUBLE PRECISION ERR
      DOUBLE PRECISION SDW
      DOUBLE PRECISION SDB
      DOUBLE PRECISION RHO
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOPA.INC'
      INCLUDE 'DPCOZZ.INC'
      INCLUDE 'DPCOZI.INC'
      INCLUDE 'DPCOZD.INC'
C
      DIMENSION ILIS(100)
      DIMENSION ICOLR(100)
C
      REAL XTMP(1)
      DOUBLE PRECISION XDESGN(MAXOBV)
      DOUBLE PRECISION XPTS(MAXOBV)
      DOUBLE PRECISION V2(MAXOBV)
      DOUBLE PRECISION TLM0(MAXOBV)
      DOUBLE PRECISION TLM1(MAXOBV)
      DOUBLE PRECISION ETA0(MAXOBV)
      DOUBLE PRECISION ETA1(MAXOBV)
      DOUBLE PRECISION XM(MAXOBV)
      DOUBLE PRECISION WK2(MAXOBV)
      DOUBLE PRECISION WK3(MAXOBV)
      DOUBLE PRECISION XN(MAXOBV)
      DOUBLE PRECISION T(MAXOBV)
      DOUBLE PRECISION CRT(MAXOBV)
      DOUBLE PRECISION Y2(MAXOBV)
      DOUBLE PRECISION COV(MAXOBV)
C
      DIMENSION IP(MAXOBV)
      DIMENSION IQ(MAXOBV)
C
      DIMENSION PRED2(MAXOBV)
      DIMENSION RES2(MAXOBV)
C
      DOUBLE PRECISION XMAT(5*MAXOBV)
      DOUBLE PRECISION SCRTCH(10*MAXOBV)
C
      DOUBLE PRECISION XTX(100)
      DOUBLE PRECISION XTXI(100)
      DOUBLE PRECISION S1(100)
      DOUBLE PRECISION S2(100)
      DOUBLE PRECISION V1(100)
      DOUBLE PRECISION COEF(100)
C
CCCCC DIMENSION ICH(10)
C
      DIMENSION IVARN1(100)
      DIMENSION IVARN2(100)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOMC.INC'
      INCLUDE 'DPCOHK.INC'
      INCLUDE 'DPCOSU.INC'
      INCLUDE 'DPCODA.INC'
      INCLUDE 'DPCOHO.INC'
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
      EQUIVALENCE (COV(1),X(1))
      EQUIVALENCE (Y2(1),X3D(1))
      EQUIVALENCE (PRED2(1),D(1))
      EQUIVALENCE (RES2(1),D(MAXOBV+1))
      EQUIVALENCE (CRT(1),DSIZE(1))
      EQUIVALENCE (XN(1),DSYMB(1))
      EQUIVALENCE (T(1),DFILL(1))
      EQUIVALENCE (XTX(1),DCOLOR(1))
      EQUIVALENCE (XTXI(1),DCOLOR(1001))
      EQUIVALENCE (S1(1),DCOLOR(2001))
      EQUIVALENCE (S2(1),DCOLOR(3001))
      EQUIVALENCE (V1(1),DCOLOR(4001))
C
      EQUIVALENCE (GARBAG(IGARB1),XMAT(1))
      EQUIVALENCE (GARBAG(IGAR11),SCRTCH(1))
C
      EQUIVALENCE (DGARBG(IDGAR1),XDESGN(1))
      EQUIVALENCE (DGARBG(IDGAR2),XPTS(1))
      EQUIVALENCE (DGARBG(IDGAR3),V2(1))
      EQUIVALENCE (DGARBG(IDGAR4),TLM0(1))
      EQUIVALENCE (DGARBG(IDGAR5),TLM1(1))
      EQUIVALENCE (DGARBG(IDGAR6),ETA0(1))
      EQUIVALENCE (DGARBG(IDGAR7),ETA1(1))
      EQUIVALENCE (DGARBG(IDGAR8),XM(1))
      EQUIVALENCE (DGARBG(IDGAR9),WK2(1))
      EQUIVALENCE (DGARBG(IDGA10),WK3(1))
C
      EQUIVALENCE (IGARBG(IIGAR1),IQ(1))
      EQUIVALENCE (IGARBG(IIGAR2),IP(1))
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='SIMC'
      ISUBN2='OV  '
      IERROR='NO'
C
      MAXCP1=MAXCOL+1
      MAXCP2=MAXCOL+2
      MAXCP3=MAXCOL+3
      MAXCP4=MAXCOL+4
      MAXCP5=MAXCOL+5
      MAXCP6=MAXCOL+6
C
CCCCC IPAROC(1)='NONE'
C
      MAXV2=35
      MINN2=2
      ILOCXP=0
      ILOCB=0
      JMAX=0
      NUMVAR=0
C
      CPUEPS=R1MACH(3)
C
      MAXN2=MAXCHF
      MAXN3=MAXCHF
      MAXN4=MAXCHF
C
      MAXLVL=INT(SQRT(REAL(IGARB0)))
      MAXPT1=20*MAXOBV
      MAXPT2=10*MAXOBV
C
      NPAR=0
      NTOT=0
      NBCH=0
      NLEFT=0
C
C               *****************************
C               **  TREAT THE RECIPE CASE  **
C               *****************************
C
      IF(IBUGA2.EQ.'OFF'.AND.ISUBRO.NE.'MCOV')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF SIMCOV--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)IBUGA2,IBUGA3
   53 FORMAT('IBUGA2,IBUGA3 = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,54)IBUGCO,IBUGEV,IBUGQ
   54 FORMAT('IBUGCO,IBUGEV,IBUGQ = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,56)NUMNAM
   56 FORMAT('NUMNAM = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO57I=1,NUMNAM
      WRITE(ICOUT,58)I,IHNAME(I),IHNAM2(I),IUSE(I),IN(I),IVALUE(I),
     1VALUE(I)
   58 FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IN(I),IVALUE(I)',
     1'VALUE(I) = ',I8,2X,A4,A4,2X,A4,I8,I8,E15.7)
      CALL DPWRST('XXX','BUG ')
   57 CONTINUE
      WRITE(ICOUT,61)IRECSA,RECIDG,RECIPC,RECICO
   61 FORMAT('IRECSA,RECIDG,RECIPC,RECICO=',A4,1X,3(E15.7))
      CALL DPWRST('XXX','BUG ')
   90 CONTINUE
C
C               **********************************
C               **  STEP 1--                    **
C               **  EXTRACT THE COMMAND         **
C               **    SIMCOV FIT                **
C               **    SIMCOV ANOVA              **
C               **    SIMCOV Y <UNIVARIATE CASE **
C               **********************************
C
      ISTEPN='1'
      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'MCOV')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(ICOM.EQ.'SIMC'.AND.NUMARG.GE.1.AND.IHARG(1).EQ.'FIT')THEN
        IFOUND='YES'
        ICASRE='FREC'
        IJUNK=INT(RECIDG+0.5)
        ICASDG='1'
        IF(IJUNK.EQ.0)ICASDG='0'
        IF(IJUNK.EQ.1)ICASDG='1'
        IF(IJUNK.EQ.2)ICASDG='2'
        IF(IJUNK.EQ.3)ICASDG='3'
        IF(IJUNK.EQ.4)ICASDG='4'
        IF(IJUNK.EQ.5)ICASDG='5'
        IF(IJUNK.EQ.6)ICASDG='6'
        IF(IJUNK.EQ.7)ICASDG='7'
        IF(IJUNK.EQ.8)ICASDG='8'
        IF(IJUNK.EQ.9)ICASDG='9'
        IF(IJUNK.EQ.10)ICASDG='10'
      ELSEIF(ICOM.EQ.'SIMC'.AND.NUMARG.GE.1.AND.IHARG(1).EQ.'ANOV')THEN
        IFOUND='YES'
        ICASRE='AREC'
      ELSEIF(ICOM.EQ.'SIMC'.AND.NUMARG.GE.1)THEN
        IFOUND='YES'
        ICASRE='UREC'
      ENDIF
      IF(IBUGA2.EQ.'ON')THEN
        WRITE(ICOUT,66)ICASRE
   66   FORMAT('ICASRE=',A4)
        CALL DPWRST('XXX','BUG ')
      ENDIF
      IF(ICASRE.EQ.'    ')GOTO9000
C
C               *******************************************************
C               **  STEP 2--                                         **
C               **  CHECK FOR THE PROPER NUMBER OF INPUT ARGUMENTS.  **
C               *******************************************************
C
      ISTEPN='2'
      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'MCOV')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      MINNA=0
      MAXNA=100
      CALL CHECKA(NUMARG,MINNA,MAXNA,IANS,IWIDTH,ISUBN1,ISUBN2,
     1IERROR)
      IF(IERROR.EQ.'YES')GOTO9000
C
C               ******************************************************
C               **  STEP 3--                                        **
C               **  IN PARTICULAR, CHECK THAT THE NUMBER OF ARGUMENTS*
C               **  IS AT LEAST 1,                                  **
C               *******************************************************
C
      ISTEPN='3'
      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'MCOV')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(NUMARG.GE.1)GOTO2090
      WRITE(ICOUT,2001)
 2001 FORMAT('***** ERROR IN SIMCOV--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2002)
 2002 FORMAT('      NUMBER OF ARGUMENTS DETECTED')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2003)NUMARG
 2003 FORMAT('      IN RECIPE COMMAND = 0.  NUMARG = ',I6)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2007)IWIDTH
 2007 FORMAT('      NUMBER OF CHARACTERS IN COMMAND LINE = ',I8)
      CALL DPWRST('XXX','BUG ')
      IF(IWIDTH.GE.1)WRITE(ICOUT,2008)(IANS(J),J=1,MIN(IWIDTH,100))
 2008 FORMAT('      COMMAND LINE--',100A1)
      IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
 2090 CONTINUE
C
      DO2100J=1,NUMARG
      J1=J
      IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET  ')GOTO2110
      IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT  ')GOTO2110
      IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.'    ')GOTO2110
 2100 CONTINUE
      ILOCQ=NUMARG+1
      GOTO2120
 2110 CONTINUE
      ILOCQ=J1
      GOTO2120
 2120 CONTINUE
C
C               *******************************************************
C               **  STEP 4--                                         **
C               **  FOR RECIPE FIT AND RECIPE ANOVA,                 **
C               **  THE SECOND WORD AFTER  RECIPE SHOULD BE THE      **
C               **  RESPONSE VARIABLE (= THE DEPENDENT VARIABLE).    **
C               **  FOR RECIPE <Y>, RESPONSE VARIABLE IS FIRST WORD. **
C               **  EXTRACT THE RESPONSE VARIABLE AND DETERMINE      **
C               **  IF IT IS ALREADY IN THE NAME LIST AND IS, IN FACT,*
C               **  A VARIABLE (AS OPPOSED TO A PARAMETER).          **
C               *******************************************************
C
      ISTEPN='4'
      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'MCOV')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      ILOCY=2
      IF(ICASRE.EQ.'UREC')ILOCY=1
      IHLEFT=IHARG(ILOCY)
      IHLEF2=IHARG2(ILOCY)
      DO2350I=1,NUMNAM
      I2=I
      IF(IHLEFT.EQ.IHNAME(I2).AND.IHLEF2.EQ.IHNAM2(I2).AND.
     1IUSE(I2).EQ.'V')GOTO2379
 2350 CONTINUE
      WRITE(ICOUT,2361)
 2361 FORMAT('***** ERROR IN SIMCOV--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2362)
 2362 FORMAT('      THE NAME FOLLOWING THE WORD RECIPE FIT ',
     1'(OR RECIPE ANOVA')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2363)
 2363 FORMAT('      (WHICH SHOULD BE THE RESPONSE VARIABLE)')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2364)
 2364 FORMAT('      EITHER DOES NOT EXIST,')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2365)
 2365 FORMAT('      OR IS A PARAMETER (AS OPPOSED')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2366)
 2366 FORMAT('      TO A VARIABLE) IN THE CURRENT')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2367)
 2367 FORMAT('      LIST OF AVAILABLE VARIABLE AND PARAMETER')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2368)
 2368 FORMAT('      NAMES.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2369)IHLEFT,IHLEF2
 2369 FORMAT('      NAME AFTER THE WORD RECIPE FIT/ANOVA = ',A4,A4)
      CALL DPWRST('XXX','BUG ')
      IF(IWIDTH.GE.1)WRITE(ICOUT,2378)(IANS(J),J=1,MIN(IWIDTH,100))
 2378 FORMAT('      COMMAND LINE--',100A1)
      IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
 2379 CONTINUE
      ILOCV=I2
      ICOLL=IVALUE(ILOCV)
      NLEFT=IN(ILOCV)
C
C               *******************************************************
C               **  STEP 5--                                         **
C               **  FOR ALL VARIATIONS OF THE SIMCOV COMMAND,        **
C               **  CHECK THAT THE INPUT NUMBER OF OBSERVATIONS (NLEFT)
C               **  FOR THE RESPONSE VARIABLE IS 2 OR LARGER.        **
C               *******************************************************
C
      ISTEPN='5'
      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'MCOV')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(NLEFT.GE.MINN2)GOTO390
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,311)
  311 FORMAT('***** ERROR IN SIMCOV--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,312)IHLEFT,IHLEF2
  312 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS ',
     1'IN VARIABLE ',A4,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,313)
  313 FORMAT('      (FOR WHICH A RECIPE ANALYSIS ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,314)
  314 FORMAT('      WAS TO HAVE BEEN PERFORMED)')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,315)MINN2
  315 FORMAT('      MUST BE ',I8,' OR LARGER;')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,316)
  316 FORMAT('      SUCH WAS NOT THE CASE HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,317)NLEFT
  317 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS NLEFT = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,318)
  318 FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
      CALL DPWRST('XXX','BUG ')
      IF(IWIDTH.GE.1)WRITE(ICOUT,319)(IANS(I),I=1,IWIDTH)
  319 FORMAT(80A1)
      IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
C
  390 CONTINUE
C
C               **************************************************
C               **  STEP 12--                                   **
C               **  EXTRACT THE INDEPENDENT VARIABLES           **
C               **  FOR SIMCOV FIT:                             **
C               **      Y X <BATCH> <XPRED>                     **
C               **  FOR SIMCOV ANOVA:                           **
C               **      Y X1 ... XK <BATCH>                     **
C               **  FOR SIMCOV :                                **
C               **      Y <BATCH>                               **
C               **  IF THE   TO   FEATURE IS USED IN THE        **
C               **  ARGUMENT LIST, TRANSLATE THE   TO   TO      **
C               **  EXPLICIT VARIABLE NAMES             INTO    **
C               **************************************************
C
      ISTEPN='12'
      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'MCOV')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(ICASRE.EQ.'FREC')THEN
        MAXREC=3
        JMIN=ILOCY+1
        JMAX=ILOCQ-1
        CALL EXTVAR(IHARG,IHARG2,NUMARG,JMIN,JMAX,MAXREC,
     1  IHNAME,IHNAM2,IUSE,NUMNAM,
     1  IVARN1,IVARN2,NUMVAR,IBUGA2,ISUBRO,IERROR)
        IF(IERROR.EQ.'YES')GOTO9000
        IF(NUMVAR.EQ.1)THEN
          ILOCX=ILOCY+1
          ILOCB=-1
          ILOCXP=-1
        ELSEIF(NUMVAR.EQ.2)THEN
          ILOCX=ILOCY+1
          ILOCB=ILOCX+1
          ILOCXP=-1
        ELSEIF(NUMVAR.EQ.3)THEN
          ILOCX=ILOCY+1
          ILOCB=ILOCX+1
          ILOCXP=ILOCB+1
        ELSE
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,411)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,412)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,413)NUMVAR
          CALL DPWRST('XXX','BUG ')
          IERROR='YES'
          GOTO9000
        ENDIF
  411 FORMAT('***** ERROR IN SIMCOV (SIMCOV FIT)--')
  412 FORMAT('      BETWEEN 2 AND 4 VARIABLE NAMES CAN BE SPECIFIED '
     1      ,'FOR THIS COMMAND')
  413 FORMAT('      ',I8,' VARIABLES WERE GIVEN.')
      ELSEIF(ICASRE.EQ.'UREC')THEN
        MAXREC=1
        JMIN=ILOCY+1
        JMAX=ILOCQ-1
        CALL EXTVAR(IHARG,IHARG2,NUMARG,JMIN,JMAX,MAXREC,
     1  IHNAME,IHNAM2,IUSE,NUMNAM,
     1  IVARN1,IVARN2,NUMVAR,IBUGA2,ISUBRO,IERROR)
        IF(IERROR.EQ.'YES')GOTO9000
        ILOCX=-1
        ILOCXP=-1
        IF(NUMVAR.EQ.1)THEN
          ILOCB=ILOCX+1
        ELSEIF(NUMVAR.EQ.0)THEN
          ILOCB=-1
        ELSE
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,421)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,422)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,423)NUMVAR
          CALL DPWRST('XXX','BUG ')
          IERROR='YES'
          GOTO9000
        ENDIF
  421 FORMAT('***** ERROR IN SIMCOV (SIMCOV)--')
  422 FORMAT('      BETWEEN 0 AND 1 VARIABLE NAMES CAN BE SPECIFIED '
     1      ,'FOR THIS COMMAND')
  423 FORMAT('      ',I8,' VARIABLES WERE GIVEN.')
      ELSEIF(ICASRE.EQ.'AREC')THEN
        NUMFAC=INT(RECIFA+0.5)
CCCCC   IF(NUMFAC.GT.MAXPAR)THEN
CCCCC     WRITE(ICOUT,999)
CCCCC     CALL DPWRST('XXX','BUG ')
CCCCC     WRITE(ICOUT,511)
CCCCC     CALL DPWRST('XXX','BUG ')
CCCCC     WRITE(ICOUT,512)NUMFAC,MAXPAR
CCCCC     CALL DPWRST('XXX','BUG ')
CCCCC     IERROR='YES'
CCCCC     GOTO9000
CCCCC   ENDIF
CC511   FORMAT('***** ERROR IN SIMCOV (RECIPE ANOVA)--')
CC512   FORMAT('      THE REQUESTED NUMBER OF FACTORS ',I8,
CCCCC1        ' IS GREATER THAN THE ALLOWED MAXIMUM OF ',I8)
        MAXREC=NUMFAC+1
        JMIN=ILOCY+1
        JMAX=ILOCQ-1
        CALL EXTVAR(IHARG,IHARG2,NUMARG,JMIN,JMAX,MAXREC,
     1  IHNAME,IHNAM2,IUSE,NUMNAM,
     1  IVARN1,IVARN2,NUMVAR,IBUGA2,ISUBRO,IERROR)
        IF(IERROR.EQ.'YES')GOTO9000
        IF(NUMVAR.EQ.NUMFAC)THEN
          ILOCX=ILOCY+1
          ILOCB=-1
          ILOCXP=-1
        ELSEIF(NUMVAR.EQ.NUMFAC+1)THEN
          ILOCX=ILOCY+1
          ILOCB=ILOCX+NUMFAC
          ILOCXP=-1
        ELSE
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,611)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,612)NUMFAC,NUMVAR
          CALL DPWRST('XXX','BUG ')
          IERROR='YES'
          GOTO9000
        ENDIF
  611 FORMAT('***** ERROR IN SIMCOV (SIMCOV ANOVA)--')
  612 FORMAT('      ',I8,' FACTORS WERE SPECIFIED, BUT ONLY ',I8,
     1       ' VARIABLES WERE GIVEN ON THE COMMAND LINE.')
      ENDIF
C
      IF(IBUGA2.EQ.'ON')THEN
        WRITE(ICOUT,71)NUMVAR,NUMFAC
   71   FORMAT('NUMVAR,NUMFAC=',2I8)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
C               ***************************************
C               **  STEP 13--                        **
C               **  CHECK THE VALIDITY OF EACH       **
C               **  OF THE VARIABLES.                **
C               **  THE DESIGN MATRIX (X) AND BATCH  **
C               **  IDENTIFIER VARIABLE MUST HAVE THE**
C               **  SAME NUMER OF OBSERVATIONS AS THE**
C               **  Y VARIABLE.  THE XPRED VARIABLE  **
C               **  MUST HAVE AT LEAST 2 OBSERVATIONS**
C               ***************************************
C
      ISTEPN='13'
      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'MCOV')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(ICASRE.EQ.'UREC'.AND.NUMVAR.EQ.0)GOTO1399
      DO1300I=1,NUMVAR
C
      IHRIGH=IVARN1(I)
      IHRIG2=IVARN2(I)
      IHWUSE='V'
      MESSAG='YES'
      CALL CHECKN(IHRIGH,IHRIG2,IHWUSE,
     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
     1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR)
      IF(IERROR.EQ.'YES')GOTO9000
C
      NRIGHT=IN(ILOCV)
      ILIS(I)=ILOCV
      ICOLR(I)=IVALUE(ILOCV)
C
      IF(ILOCXP.GT.0 .AND. I.EQ.NUMVAR)NPRED=NRIGHT
      IF(NRIGHT.EQ.NLEFT)GOTO1390
      IF(ILOCXP.GT.0 .AND. I.EQ.NUMVAR .AND. NRIGHT.GT.2)GOTO1390
C
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1311)
 1311 FORMAT('***** ERROR IN SIMCOV--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1312)
 1312 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1321)
 1321 FORMAT('      FOR THE INDEPENDENT VARIABLES')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1322)
 1322 FORMAT('      MUST BE THE SAME AS THE DEPENDENT VARIABLE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1323)
 1323 FORMAT('      IN ADDITION, THE VARIABLE CONTAINING THE X ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1324)
 1324 FORMAT('      VALUES FOR THE TOLERANCE LIMITS MUST HAVE AT ',
     1'LEAST 2 ELEMENTS.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1327)
 1327 FORMAT('      SUCH WAS NOT THE CASE HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1328)
 1328 FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
      CALL DPWRST('XXX','BUG ')
      IF(IWIDTH.GE.1)WRITE(ICOUT,1329)(IANS(J),J=1,MIN(80,IWIDTH))
 1329 FORMAT('      ',80A1)
      IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
 1390 CONTINUE
C
 1300 CONTINUE
 1399 CONTINUE
C
C               **********************************************
C               **  STEP 6.3--                              **
C               **  FOR ALL VARIATIONS OF THE SIMCOV COMMAND,*
C               **  CHECK TO SEE THE TYPE CASE--            **
C               **    1) UNQUALIFIED (THAT IS, FULL);       **
C               **    2) SUBSET/EXCEPT; OR                  **
C               **    3) FOR.                               **
C               **********************************************
C
      ISTEPN='6.3'
      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'MCOV')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      ICASEQ='FULL'
      ILOCQ=NUMARG+1
      IF(NUMARG.LT.1)GOTO490
      DO400J=1,NUMARG
      J1=J
      IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET  ')GOTO410
      IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT  ')GOTO410
      IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.'    ')GOTO420
  400 CONTINUE
      GOTO490
  410 CONTINUE
      ICASEQ='SUBS'
      IKEY='SUBS'
      IF(IHARG(J1).EQ.'EXCE')IKEY='EXCE'
      ILOCQ=J1
      GOTO490
  420 CONTINUE
      ICASEQ='FOR'
      ILOCQ=J1
      GOTO490
  490 CONTINUE
      IF(IBUGA2.EQ.'OFF'.AND.ISUBRO.NE.'MCOV')GOTO495
      WRITE(ICOUT,491)NUMARG,ILOCQ
  491 FORMAT('NUMARG,ILOCQ = ',2I8)
      CALL DPWRST('XXX','BUG ')
  495 CONTINUE
C
C               *******************************************************
C               **  STEP 12--                                        **
C               **  BRANCH TO THE APPROPRIATE SUBCASE; THEN          **
C               **  COPY OVER THE RESPONSE VECTOR TO BE USED IN THE  **
C               **  MODEL INTO THE VECTOR Y2; AND                    **
C               **  COPY OVER THE VECTORS THAT WERE USED IN THE MODEL**
C               **  INTO THE FULL DESIGN MATRIX                      **
C               *******************************************************
C
      ISTEPN='12'
      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'MCOV')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'MCOV')WRITE(ICOUT,601)NLEFT,NUMVAR
  601 FORMAT('NLEFT,NUMVAR = ',2I8)
      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'MCOV')CALL DPWRST('XXX','BUG ')
C
      IF(ICASEQ.EQ.'FULL')GOTO610
      IF(ICASEQ.EQ.'SUBS')GOTO620
      IF(ICASEQ.EQ.'FOR')GOTO630
C
  610 CONTINUE
      DO615I=1,NLEFT
      ISUB(I)=1
  615 CONTINUE
      NQ=NLEFT
      GOTO650
C
  620 CONTINUE
      NIOLD=NLEFT
CCCCC CALL DPSUB2(NIOLD,ILOCS,NS,IBUGQ,IERROR)
      CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERROR)
      NQ=NIOLD
      GOTO650
C
  630 CONTINUE
      NIOLD=NLEFT
      CALL DPFOR(NIOLD,NFOR,IROW1,IROWN,
     1NLOCAL,ILOCS,NS,IBUGQ,IERROR)
      NQ=NFOR
      GOTO650
C
  650 CONTINUE
      NTOT=NQ
      K=ICOLL
      J=0
      DO4500I=1,NLEFT
      IF(ISUB(I).EQ.0)GOTO4500
      J=J+1
      IJ=MAXN*(K-1)+I
      IF(K.LE.MAXCOL)Y2(J)=DBLE(V(IJ))
      IF(K.EQ.MAXCP1)Y2(J)=DBLE(PRED(I))
      IF(K.EQ.MAXCP2)Y2(J)=DBLE(RES(I))
      IF(K.EQ.MAXCP3)Y2(J)=DBLE(YPLOT(I))
      IF(K.EQ.MAXCP4)Y2(J)=DBLE(XPLOT(I))
      IF(K.EQ.MAXCP5)Y2(J)=DBLE(X2PLOT(I))
      IF(K.EQ.MAXCP6)Y2(J)=DBLE(TAGPLO(I))
 4500 CONTINUE
      IF(IBUGA2.EQ.'ON')THEN
        DO4503I=1,NTOT
        WRITE(ICOUT,4504)I,Y2(I)
 4504   FORMAT('I,Y2(I)=',I8,2X,D15.7)
        CALL DPWRST('XXX','BUG ')
 4503   CONTINUE
      ENDIF
C
C     ********************************************************
C     ** DEFINE A VECTOR OF ALL 1'S (FOR THE CONSTANT TERM) **
C     ** IN THE DESIGN MATRIX.                              **
C     ********************************************************
C
      J=0
      DO380I=1,NLEFT
      IF(ISUB(I).EQ.0)GOTO380
      J=J+1
      XMAT(J)=1.0D0
  380 CONTINUE
C
C     ********************************************************
C     ** DETERMINE IF THERE IS A BATCH VARIABLE.  IF NOT,   **
C     ** CREATE ONE EQUAL TO ALL 1'S.  IF YES, DETERMINE    **
C     ** HOW MANY UNIQUE VALUES.                            **
C     ********************************************************
C
      IF(ILOCB.LE.0)THEN
        J=0
        DO4610I=1,NLEFT
          IF(ISUB(I).EQ.0)GOTO4610
          J=J+1
          IQ(J)=1
 4610   CONTINUE
        NBCH=1
        GOTO4699
      ENDIF
C
      IF(ICASRE.EQ.'FREC')THEN
        K=ICOLR(NUMVAR)
        IF(ILOCXP.GT.0)K=ICOLR(NUMVAR-1)
      ELSE
        K=ICOLR(NUMVAR)
      ENDIF
C
      J=0
      DO4600I=1,NLEFT
      IF(ISUB(I).EQ.0)GOTO4600
      J=J+1
      IJ=MAXN*(K-1)+I
      IF(K.LE.MAXCOL)RES2(J)=V(IJ)
      IF(K.EQ.MAXCP1)RES2(J)=PRED(I)
      IF(K.EQ.MAXCP2)RES2(J)=RES(I)
      IF(K.EQ.MAXCP3)RES2(J)=YPLOT(I)
      IF(K.EQ.MAXCP4)RES2(J)=XPLOT(I)
      IF(K.EQ.MAXCP5)RES2(J)=X2PLOT(I)
      IF(K.EQ.MAXCP6)RES2(J)=TAGPLO(I)
 4600 CONTINUE
C
      CALL SORT(RES2,NQ,PRED2)
      IWRITE='NO'
      CALL DISTIN(PRED2,NQ,IWRITE,PRED2,NBCH,IBUGA3,IERROR)
      IF(IERROR.EQ.'YES')GOTO9000
      DO4650I=1,NQ
        IQ(I)=0
        DO4660J=1,NBCH
          IF(RES2(I).EQ.PRED2(J))THEN
            IQ(I)=J
            GOTO4650
          ENDIF
 4660   CONTINUE
 4650 CONTINUE
C
 4699 CONTINUE
C
      IF(IBUGA2.EQ.'ON')THEN
        DO4603I=1,NTOT
        WRITE(ICOUT,4604)I,IQ(I)
 4604   FORMAT('I,IQ(I)=',I8,2X,I8)
        CALL DPWRST('XXX','BUG ')
 4603   CONTINUE
      ENDIF
C
C     ********************************************************
C     ** DETERMINE IF THERE IS A PREDICTED VARIABLE (FIT    **
C     ** CASE ONLY).  IF SO, EXTRACT AND PUT IN XPTS.       **
C     ********************************************************
C
      IF(ICASRE.EQ.'UREC')THEN
        XPTS(1)=1.D0
        NPRED=1
        NPAR=1
        GOTO4799
      ELSEIF(ILOCXP.LT.0.OR.ICASRE.EQ.'AREC')THEN
        XPTS(1:MAXOBV/2)=0.D0
        NPRED=0
        GOTO4799
      ENDIF
C
      K=ICOLR(NUMVAR)
      DO4703I=1,NPRED
        XPTS(I)=1.D0
 4703 CONTINUE
      J=NPRED
      DO4700I=1,NPRED
      IF(ISUB(I).EQ.0)GOTO4700
      J=J+1
      IJ=MAXN*(K-1)+I
      IF(K.LE.MAXCOL)XPTS(J)=DBLE(V(IJ))
      IF(K.EQ.MAXCP1)XPTS(J)=DBLE(PRED(I))
      IF(K.EQ.MAXCP2)XPTS(J)=DBLE(RES(I))
      IF(K.EQ.MAXCP3)XPTS(J)=DBLE(YPLOT(I))
      IF(K.EQ.MAXCP4)XPTS(J)=DBLE(XPLOT(I))
      IF(K.EQ.MAXCP5)XPTS(J)=DBLE(X2PLOT(I))
      IF(K.EQ.MAXCP6)XPTS(J)=DBLE(TAGPLO(I))
 4700 CONTINUE
C
 4799 CONTINUE
C
      IF(IBUGA2.EQ.'ON')THEN
        DO4713I=1,2*NPRED
        WRITE(ICOUT,4714)I,XPTS(I)
 4714   FORMAT('I,XPTS(I)=',I8,2X,D15.7)
        CALL DPWRST('XXX','BUG ')
 4713   CONTINUE
      ENDIF
C
C     ********************************************************
C     ** COPY OVER THE FULL DESIGN MATRIX.                  **
C     ********************************************************
C
      IF(ICASRE.EQ.'FREC')THEN
        NPAR=1
        IF(ICASDG.EQ.'0')GOTO379
        IF(ICASDG.EQ.'1')NLOOP=1
        IF(ICASDG.EQ.'2')NLOOP=2
        IF(ICASDG.EQ.'3')NLOOP=3
        IF(ICASDG.EQ.'4')NLOOP=4
        IF(ICASDG.EQ.'5')NLOOP=5
        IF(ICASDG.EQ.'6')NLOOP=6
        IF(ICASDG.EQ.'7')NLOOP=7
        IF(ICASDG.EQ.'8')NLOOP=8
        IF(ICASDG.EQ.'9')NLOOP=9
        IF(ICASDG.EQ.'10')NLOOP=10
        K=ICOLR(1)
        DO376IVAR=1,NLOOP
          J=IVAR*NTOT
          DO371I=1,NLEFT
            IF(ISUB(I).EQ.0)GOTO371
            J=J+1
            IJ=MAXN*(K-1)+I
            IF(K.LE.MAXCOL)XMAT(J)=DBLE(V(IJ)**NLOOP)
            IF(K.EQ.MAXCP1)XMAT(J)=DBLE(PRED(I)**NLOOP)
            IF(K.EQ.MAXCP2)XMAT(J)=DBLE(RES(I)**NLOOP)
            IF(K.EQ.MAXCP3)XMAT(J)=DBLE(YPLOT(I)**NLOOP)
            IF(K.EQ.MAXCP4)XMAT(J)=DBLE(XPLOT(I)**NLOOP)
            IF(K.EQ.MAXCP5)XMAT(J)=DBLE(X2PLOT(I)**NLOOP)
            IF(K.EQ.MAXCP6)XMAT(J)=DBLE(TAGPLO(I)**NLOOP)
  371     CONTINUE
  376   CONTINUE
        NPAR=NLOOP+1
  379   CONTINUE
C
      ELSEIF(ICASRE.EQ.'UREC')THEN
        NPAR=1
        J=NTOT
CCCCC   DO372I=1,NLEFT
CCCCC     IF(ISUB(I).EQ.0)GOTO372
CCCCC     J=J+1
CCCCC     XMAT(J)=1.D0
C372    CONTINUE
      ELSEIF(ICASRE.EQ.'AREC')THEN
        NLOOP=NUMVAR
        IF(ILOCB.GT.0)NLOOP=NUMVAR-1
        DO389IVAR=1,NLOOP
          K=ICOLR(IVAR)
          J=IVAR*NTOT
          DO381I=1,NLEFT
            IF(ISUB(I).EQ.0)GOTO381
            J=J+1
            IJ=MAXN*(K-1)+I
            IF(K.LE.MAXCOL)XMAT(J)=DBLE(V(IJ))
            IF(K.EQ.MAXCP1)XMAT(J)=DBLE(PRED(I))
            IF(K.EQ.MAXCP2)XMAT(J)=DBLE(RES(I))
            IF(K.EQ.MAXCP3)XMAT(J)=DBLE(YPLOT(I))
            IF(K.EQ.MAXCP4)XMAT(J)=DBLE(XPLOT(I))
            IF(K.EQ.MAXCP5)XMAT(J)=DBLE(X2PLOT(I))
            IF(K.EQ.MAXCP6)XMAT(J)=DBLE(TAGPLO(I))
  381     CONTINUE
  389   CONTINUE
        NPAR=NLOOP+1
      ENDIF
C
      IF(IBUGA2.EQ.'ON')THEN
        DO4803I=1,NTOT*NPAR
        WRITE(ICOUT,4804)I,XMAT(I)
 4804   FORMAT('I,XMAT(I)=',I8,2X,D15.7)
        CALL DPWRST('XXX','BUG ')
 4803   CONTINUE
      ENDIF
C
C               ******************************************************
C               **  STEP 14--                                       **
C               **  CARRY OUT THE ACTUAL FIT                        **
C               **  VIA CALLING                                     **
C               **  REGINI AND REGDAT                               **
C               ******************************************************
C
      NSTOR=NTOT*(NPAR+NBCH)
      IF(NSTOR.GT.MAXPT1)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,6071)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,6072)NSTOR
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,6073)MAXPT1
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        GOTO9000
      ENDIF
 6071 FORMAT('***** ERROR FROM SIMCOV--THE AMOUNT OF SCRATCH STORAGE ',
     1'REQUIRED')
 6072 FORMAT('     NUMBER OF POINTS*(NUMBER OF PARAMETERS + NUMBER OF',
     1' BATCHES) = ',I8)
 6073 FORMAT('     EXCEEDS THE MAXIMIM ALLOWABLE OF ',I8)
      ISTEPN='14'
      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'MCOV')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(IBUGA2.EQ.'OFF'.AND.ISUBRO.NE.'MCOV')GOTO6099
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,6081)
 6081 FORMAT('***** FROM SIMCOV, AS ABOUT TO CALL REGINI--')
      CALL DPWRST('XXX','BUG ')
 6099 CONTINUE
C
      SATT=.FALSE.
      IF(IRECSA.EQ.'YES'.OR.IRECSA.EQ.'TRUE'.OR.IRECSA.EQ.'ON')
     1SATT=.TRUE.
      NREPS=IRECR2
      MAXREP=10*MAXOBV
      IF(NREPS.GT.MAXREP)THEN
        NREPS=MAXREP
        WRITE(ICOUT,998)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,6531)NREPS,MAXREP
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,6532)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,998)
        CALL DPWRST('XXX','WRIT')
      ENDIF
  998 FORMAT(1X)
 6531 FORMAT('THE REQUESTED NUMBER OF SIMULATION REPLICATIONS ',I8,
     1' IS GREATER THAN THE ALLOWED MAXIMUM OF ',I8)
 6532 FORMAT('THE MAXIMUM ALLOWED NUMBER OF REPLICATIONS WILL BE ',
     1'USED.')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','WRIT')
      WRITE(ICOUT,1032)
 1032 FORMAT(20X,'RECIPE SIMCOV ANALYSIS')
      CALL DPWRST('XXX','WRIT')
      WRITE(ICOUT,1132)
 1132 FORMAT(22X,'(MARK VANGEL, NIST)')
      CALL DPWRST('XXX','WRIT')
      WRITE(ICOUT,998)
      CALL DPWRST('XXX','WRIT')
      WRITE(ICOUT,1033)NTOT
 1033 FORMAT('NUMBER OF OBSERVATIONS         = ',I8)
      CALL DPWRST('XXX','WRIT')
      WRITE(ICOUT,1035)NBCH
 1035 FORMAT('NUMBER OF BATCHES              = ',I8)
      CALL DPWRST('XXX','WRIT')
      WRITE(ICOUT,1036)IRECR1
 1036 FORMAT('NUMBER OF SIMCOV SIMULATIONS   = ',I8)
      CALL DPWRST('XXX','WRIT')
      WRITE(ICOUT,1037)RECIPC
 1037 FORMAT('PROBABILITY CONTENT            = ',G15.7)
      CALL DPWRST('XXX','WRIT')
      WRITE(ICOUT,1039)
 1039 FORMAT('NOTE: PLEASE BE PATIENT.  THE SIMULATION CAN TAKE ',
     1'SOME TIME.')
      CALL DPWRST('XXX','WRIT')
      WRITE(ICOUT,998)
      CALL DPWRST('XXX','WRIT')
      WRITE(ICOUT,1041)
 1041 FORMAT('  CORRELATION      PROBABILITY')
      CALL DPWRST('XXX','WRIT')
C
      CALL REGINI(NLVL,NPAR,NTOT,NBCH,NPRED,XDESGN,XPTS,IP,IQ,
     1            DBLE(RECIPC),DBLE(RECICO),XMAT,XTX,XTXI,XN,SCRTCH,
     1            S1,V1,S2,V2,TLM0,TLM1,ETA0,ETA1,
     1            SATT,IN2,WK2,WK3,
     1            CRT,ISEED,MAXREP,MAXLVL,
     1            ICASRE,ISUBRO,IBUGA2,IERROR)
      IF(IERROR.EQ.'YES')GOTO9000
      IF(IBUGA2.EQ.'OFF'.AND.ISUBRO.NE.'MCOV')GOTO6199
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,6181)
 6181 FORMAT('***** FROM SIMCOV, AS ABOUT TO PERFORM SIMULATION--')
      CALL DPWRST('XXX','BUG ')
 6199 CONTINUE
C
      NSIM=IRECR1
      NRHO=IRECC1
      NRAN=1
C
      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'MCOV')THEN
        WRITE(ICOUT,6185)NSIM,NRHO,NRAN,NPRED
 6185   FORMAT('NSIM,NRHO,NRAN,NPRED=',4I8)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
C  LOOP OVER INTRACLASS CORRELATION VALUES
C
      DO7000 IRHO=1,NRHO
        RHO=DBLE(IRHO-1)/DBLE(NRHO-1)
        IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'MCOV')THEN
          WRITE(ICOUT,7005)IRHO,RHO
 7005     FORMAT('IRHO,RHO=',I8,E15.7)
          CALL DPWRST('XXX','BUG ')
        ENDIF
        CALL NODPPF(DBLE(RECIPC),PCT)
        PCT=-PCT
        SDB=DSQRT(RHO)
        SDW=DSQRT(1.0D0-RHO)
        IF(NBCH.EQ.1)THEN
          SDB=0.0D0
          SDW=1.0D0
        ENDIF
        DO7049 IDX=1,NPRED
          COV(IDX)=0.D0
CCCCC     XMU(IDX)=0.D0
 7049   CONTINUE
        DO5000 IDX=1,NSIM
          CALL NORRAN(NBCH,ISEED,RES2)
          DO5021I=1,NTOT
            CALL NORRAN(NRAN,ISEED,XTMP)
            ERR=DBLE(XTMP(1))
            Y2(I)=DBLE(RES2(IQ(I)))*SDB + ERR*SDW
 5021     CONTINUE
C
        IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'MCOV')THEN
          WRITE(ICOUT,7009)
 7009     FORMAT('BEFORE CALL TO REGDAT')
          CALL DPWRST('XXX','BUG ')
        ENDIF
        IFLAG='SIMC'
        CALL REGDAT(NPAR,NTOT,NBCH,NPRED,XPTS,Y2,COEF,
     1            SCRTCH,S1,V1,TLM0,TLM1,ETA0,ETA1,
     1            XMAT,XM,T,XDESGN,NLVL,
     1            ICASRE,IFLAG,ISUBRO,IBUGA2,IERROR)
      IF(IERROR.EQ.'YES')GOTO9000
      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'MCOV')THEN
        WRITE(ICOUT,7019)
 7019   FORMAT('NPRED = ',I8)
        CALL DPWRST('XXX','BUG ')
      ENDIF
      DO4000I=1,NPRED
        IF(T(I).LT.PCT) COV(I) = COV(I)+1.0D0
 4000 CONTINUE
 5000 CONTINUE
C
      WRITE(ICOUT,998)
      CALL DPWRST('XXX','WRIT')
      DO6000I=1,NPRED
        WRITE(ICOUT,2000)RHO,COV(I)/DBLE(NSIM)
 2000   FORMAT(2F12.4)
        CALL DPWRST('XXX','WRIT')
 6000 CONTINUE
C
 7000 CONTINUE
C
C               ***************************************
C               **  STEP 16--                        **
C               **  STORE THE TOLERANCE VALUES       **
C               ***************************************
C7640 CONTINUE
CCCCC IH=IRECTN(1:4)
CCCCC IH2=IRECTN(5:8)
C
CCCCC NEWNAM='NO'
CCCCC DO7650I=1,NUMNAM
CCCCC I2=I
CCCCC IF(IH.EQ.IHNAME(I).AND.IH2.EQ.IHNAM2(I).AND.
CCCCC1IUSE(I).EQ.'V')THEN
CCCCC   ICOLL1=IVALUE(I2)
CCCCC   GOTO7680
CCCCC ENDIF
CCCCC IF(IH.EQ.IHNAME(I).AND.IH2.EQ.IHNAM2(I).AND.
CCCCC1IUSE(I).NE.'V')THEN
CCCCC   WRITE(ICOUT,7646)
C7646   FORMAT('***** ERROR IN SIMCOV--')
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   WRITE(ICOUT,7647)IRECTN
C7647   FORMAT('      THE REQUESTED NAME FOR THE TOLERANCE ',
CCCCC1         'VARIABLE, ',A8,', WAS FOUND IN THE')
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   WRITE(ICOUT,7648)
C7648   FORMAT('      CURRENT NAME LIST, BUT NOT AS A VARIABLE.')
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   WRITE(ICOUT,7649)
C7649   FORMAT('      THEREFORE THE TOLERANCE VARIABLE WAS NOT ',
CCCCC1         'UPDATED.')
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   GOTO7699
CCCCC ENDIF
C7650 CONTINUE
CCCCC NEWNAM='YES'
C
C  NEW VARIABLE, CHECK TO ENSURE MAXIMUM NAMES AND MAXIMUM
C  COLUMNS NOT EXCEEDED.
C
CCCCC IF(NUMNAM.GE.MAXNAM)THEN
CCCCC   WRITE(ICOUT,7651)
C7651   FORMAT('***** ERROR IN SIMCOV--')
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   WRITE(ICOUT,7652)
C7652   FORMAT('      THE TOTAL NUMBER OF (VARIABLE + PARAMETER)')
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   WRITE(ICOUT,7653)MAXNAM
C7653   FORMAT('      NAMES MUST BE AT MOST ',I8)
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   WRITE(ICOUT,7654)
C7654   FORMAT('      SUCH WAS NOT THE CASE HERE--')
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   WRITE(ICOUT,7655)
C7655   FORMAT('      THE MAXIMUM ALLOWABLE NUMBER OF NAMES')
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   WRITE(ICOUT,7656)
C7656   FORMAT('      WAS JUST EXCEEDED.')
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   WRITE(ICOUT,7657)
C7657   FORMAT('      SUGGESTED ACTION--ENTER     STAT')
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   WRITE(ICOUT,7658)
C7658   FORMAT('      TO DETERMINE THE IMPORTANT')
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   WRITE(ICOUT,7659)
C7659   FORMAT('      (VERSUS UNIMPORTANT) VARIABLES')
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   WRITE(ICOUT,7660)
C7660   FORMAT('      AND PARAMETERS, AND THEN REUSE SOME')
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   WRITE(ICOUT,7661)
C7661   FORMAT('      OF THE NAMES.')
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   WRITE(ICOUT,7662)
C7662   FORMAT('      THE TOLERANCE VARIABLE WAS NOT UPDATED--')
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   GOTO7699
CCCCC ENDIF
C
CCCCC IF(NUMCOL.GE.MAXCOL)THEN
CCCCC   WRITE(ICOUT,7665)
C7665   FORMAT('***** ERROR IN SIMCOV--')
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   WRITE(ICOUT,7666)
C7666   FORMAT('      THE NUMBER OF DATA COLUMNS')
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   WRITE(ICOUT,7667)MAXCOL
C7667   FORMAT('      HAS JUST EXCEEDED THE MAX ALLOWABLE ',I8,'  .')
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   WRITE(ICOUT,7668)
C7668   FORMAT('      SUGGESTED ACTION--')
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   WRITE(ICOUT,7669)
C7669   FORMAT('      ENTER      STATUS VARIABLES')
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   WRITE(ICOUT,7670)
C7670   FORMAT('      TO FIND OUT THE FULL LIST OF USED COLUMNS')
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   WRITE(ICOUT,7671)
C7671   FORMAT('      AND THEN DELETE SOME COLUMNS.')
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   WRITE(ICOUT,7672)
C7672   FORMAT('      THE TOLERANCE VARIABLE WAS NOT UPDATED--')
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   GOTO7699
CCCCC ENDIF
C
C7680 CONTINUE
CCCCC IF(NEWNAM.EQ.'YES')THEN
CCCCC   NUMCOL=NUMCOL+1
CCCCC   ICOLL1=NUMCOL
CCCCC   NUMNAM=NUMNAM+1
CCCCC   IHNAME(NUMNAM)=IH
CCCCC   IHNAM2(NUMNAM)=IH2
CCCCC   IUSE(NUMNAM)='V'
CCCCC   VALUE(NUMNAM)=ICOLL1
CCCCC   IVALUE(NUMNAM)=ICOLL1
CCCCC   NTEMP=NTOT
CCCCC   IF(ICASRE.EQ.'FREC'.AND.ILOCXP.GT.0)NTEMP=NPRED
CCCCC   IN(NUMNAM)=NTEMP
CCCCC   IF(IBUGA2.EQ.'ON')THEN
CCCCC     WRITE(ICOUT,7683)IN(NUMNAM)
C7683     FORMAT('IN(NUMNAM)=',I8)
CCCCC     CALL DPWRST('XXX','BUG ')
CCCCC   ENDIF
CCCCC ELSE
CCCCC   NTEMP=NTOT
CCCCC   IF(ICASRE.EQ.'FREC'.AND.ILOCXP.GT.0)NTEMP=NPRED
CCCCC   IF(ICASRE.EQ.'UREC')NTEMP=1
CCCCC   IN(ICOLL1)=NTEMP
CCCCC   IF(IBUGA2.EQ.'ON')THEN
CCCCC     WRITE(ICOUT,7686)IN(ICOLL1)
C7686     FORMAT('IN(ICOLL1)=',I8)
CCCCC     CALL DPWRST('XXX','BUG ')
CCCCC   ENDIF
CCCCC ENDIF
CCCCC IF(IBUGA2.EQ.'ON')THEN
CCCCC   WRITE(ICOUT,7681)NEWNAM,ICOLL1,NUMCOL,NUMNAM,NPRED,NTEMP
CCCCC   CALL DPWRST('XXX','BUG ')
C7681   FORMAT('NEWNAM,ICOLL1,NUMCOL,NUMNAM,NPRED,NTEMP =',
CCCCC1         A4,1X,5I8)
CCCCC ENDIF
CCCCC K=ICOLL1
CCCCC DO7682I=1,NTEMP
CCCCC   IJ=MAXN*(K-1)+I
CCCCC   IF(K.LE.MAXCOL)V(IJ)=T(I)
CCCCC   IF(K.EQ.MAXCP1)PRED(I)=T(I)
CCCCC   IF(K.EQ.MAXCP1)RES(I)=T(I)
CCCCC   IF(K.EQ.MAXCP1)YPLOT(I)=T(I)
CCCCC   IF(K.EQ.MAXCP1)XPLOT(I)=T(I)
CCCCC   IF(K.EQ.MAXCP1)X2PLOT(I)=T(I)
CCCCC   IF(K.EQ.MAXCP1)TAGPLO(I)=T(I)
C7682 CONTINUE
C
C7699 CONTINUE
C
C8000 CONTINUE
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA2.EQ.'OFF'.AND.ISUBRO.NE.'MCOV')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF SIMCOV--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IBUGA2,IBUGA3
 9012 FORMAT('IBUGA2,IBUGA3 = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)IBUGCO,IBUGEV,IBUGQ
 9013 FORMAT('IBUGCO,IBUGEV,IBUGQ = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9015)NPAR,NTOT,NBCH,NLVL,ICASRE
 9015 FORMAT('NPAR,NTOT,NBCH,NLEVL,ICASRE = ',4(I8,1X),2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9052)ICASEQ
 9052 FORMAT('ICASEQ = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9061)IWIDTH
 9061 FORMAT('IWIDTH = ',I8)
      CALL DPWRST('XXX','BUG ')
      IF(IWIDTH.GE.1)WRITE(ICOUT,9062)(IANS(I),I=1,MIN(100,IWIDTH))
 9062 FORMAT('(IANS(I),I=1,IWIDTH) = ',100A1)
      IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9069)IFOUND,IERROR
 9069 FORMAT('IFOUND,IERROR = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE SIMPLX(A,M,N,MP,NP,M1,M2,M3,
     1ICASE,IZROV,IPOSV,IBUGA3,ISUBRO,IERROR)
C
C     PURPOSE--CARRY OUT SIMPLEX LINEAR PROGRAMMING SOLUTION
C
C     INPUT  ARGUMENTS--
C
C     SOURCE--NUMERICAL RECIPES,
C             PRESS, FLANNERY, TEUKOLSKY, AND VETTERLING,
C             CAMBRIDGE UNIVERSITY PRESS, 1986.
C
C---------------------------------------------------------------------
C
CCCCC PARAMETER(MMAX=100,EPS=1.E-6)
CCCCC PARAMETER(MMAX=100,EPS=1.E-3)
      PARAMETER(MMAX=100)
C
      CHARACTER*4 IBUGA3
      CHARACTER*4 ISUBRO
      CHARACTER*4 IERROR
C
      DIMENSION A(MP,NP),IZROV(N),IPOSV(M),L1(MMAX),L2(MMAX),L3(MMAX)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      IERROR='NO'
C
      JMAX=0
      MP1=M+1
      NP1=N+1
C
      MP2=M+2
C
      IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'MPLX')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF SIMPLX--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)IBUGA3,ISUBRO
   52 FORMAT('IBUGA3,ISUBRO = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,61)M,N,MP,NP,M1,M2,M3
   61 FORMAT('M,N,MP,NP,M1,M2,M3 = ',7I8)
      CALL DPWRST('XXX','BUG ')
      IF(M.LE.0)GOTO69
      IF(N.LE.0)GOTO69
      JMAX=NP1
      IF(JMAX.GT.10)JMAX=10
      DO62I=1,MP2
      WRITE(ICOUT,63)I,(A(I,J),J=1,JMAX)
   63 FORMAT('I,A(I,.) = ',I8,10F10.2)
      CALL DPWRST('XXX','BUG ')
   62 CONTINUE
   69 CONTINUE
   90 CONTINUE
C
C     MAKE A CORRECTION (THANKS TO CHRIS WITZGEL, NBS)
C     ON THE VALUE OF EPSILON
C     TO CIRCUMVENT A BUG ARISING FROM
C     A TEST PROBLEM DRAWN FROM
C     BRONSON/SCHAUM OP. RES. (PROBLEM 1.7).
C     (SEPT, 1987)
C
      AM=M
      SUM=0.0
      DO1000I=1,M
      MP1=M+1
      SUM=SUM+A(MP1,1)
 1000 CONTINUE
      XBAR=SUM/AM
      EPSEXP=6.0
      IF(XBAR.GT.0.0)EPSEXP=6.0-AINT(LOG10(XBAR)+0.5)
      IF(EPSEXP.LT.1.0)EPSEXP=1.0
      EPS=10.0**(-EPSEXP)
C
CCCCC IF(M.NE.M1+M2+M3)PAUSE 'Bad input constraint counts.'
      IF(M.NE.M1+M2+M3)GOTO110
      GOTO119
  110 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,111)
  111 FORMAT('***** ERROR IN SIMPLX--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,112)
  112 FORMAT('      BAD INPUT CONSTRAINT COUNTS.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,113)M
  113 FORMAT('      M = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,114)M1,M2,M3
  114 FORMAT('      M1,M2,M3 = ',3I8)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
  119 CONTINUE
C
      NL1=N
      DO 11 K=1,N
        L1(K)=K
        IZROV(K)=K
11    CONTINUE
      NL2=M
      DO 12 I=1,M
C
CCCCC   IF(A(I+1,1).LT.0.)PAUSE 'Bad input tableau.'
      IF(A(I+1,1).LT.0.)GOTO120
      GOTO129
  120 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,121)
  121 FORMAT('***** ERROR IN SIMPLX--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,122)
  122 FORMAT('      BAD INPUT TABLEAU.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,123)
  123 FORMAT('      POSSIBLE CAUSE--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,124)
  124 FORMAT('      SOME CONSTRAINT LIMIT IS NEGATIVE')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,125)
  125 FORMAT('      (FORBIDDEN IN SIMPLEX METHOD)')
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
  129 CONTINUE
C
        L2(I)=I
        IPOSV(I)=N+I
12    CONTINUE
C
      DO 13 I=1,M2
        L3(I)=1
13    CONTINUE
C
      IR=0
      IF(M2+M3.EQ.0)GO TO 30
      IR=1
C
      DO 15 K=1,N+1
        Q1=0.
        DO 14 I=M1+1,M
          Q1=Q1+A(I+1,K)
14      CONTINUE
        A(M+2,K)=-Q1
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'MPLX')
     1WRITE(ICOUT,777)K,A(M+2,K)
  777 FORMAT('K,A(M+2,K) = ',I8,F10.2)
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'MPLX')
     1CALL DPWRST('XXX','BUG ')
15    CONTINUE
C
10    CONTINUE
      CALL SIMP1(A,MP,NP,M+1,L1,NL1,0,KP,BMAX)
      IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'MPLX')GOTO790
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      DO782I=1,MP2
      WRITE(ICOUT,783)I,(A(I,J),J=1,JMAX)
  783 FORMAT('I,A(I,.) = ',I8,10F10.2)
      CALL DPWRST('XXX','BUG ')
  782 CONTINUE
      WRITE(ICOUT,784)IR,BMAX,A(M+2,1),EPS,XBAR
  784 FORMAT('IR,BMAX,A(M+2,1),EPS,XBAR = ',I8,4E15.7)
      CALL DPWRST('XXX','BUG ')
  790 CONTINUE
C
      IF(BMAX.LE.EPS.AND.A(M+2,1).LT.-EPS)THEN
        ICASE=-1
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,211)
  211 FORMAT('***** ERROR IN SIMPLX (FROM CODE POINT 211)--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,212)
  212 FORMAT('      NO SOLUTION SATISFIES ALL CONSTRAINTS.')
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
CCCCC   RETURN
        GOTO9000
C
      ELSE IF(BMAX.LE.EPS.AND.A(M+2,1).LE.EPS)THEN
        M12=M1+M2+1
        IF(M12.LE.M)THEN
          DO 16 IP=M12,M
            IF(IPOSV(IP).EQ.IP+N)THEN
              CALL SIMP1(A,MP,NP,IP,L1,NL1,1,KP,BMAX)
              IF(BMAX.GT.0.)GO TO 1
            ENDIF
16        CONTINUE
        ENDIF
        IR=0
        M12=M12-1
        IF(M1+1.GT.M12)GO TO 30
C
        DO 18 I=M1+1,M12
          IF(L3(I-M1).EQ.1)THEN
            DO 17 K=1,N+1
              A(I+1,K)=-A(I+1,K)
17          CONTINUE
          ENDIF
18      CONTINUE
C
        GO TO 30
      ENDIF
      CALL SIMP2(A,M,N,MP,NP,L2,NL2,IP,KP,Q1)
      IF(IP.EQ.0)THEN
        ICASE=-1
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,221)
  221 FORMAT('***** ERROR IN SIMPLX (FROM CODE POINT 221)--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,222)
  222 FORMAT('      NO SOLUTION SATISFIES ALL CONSTRAINTS.')
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
CCCCC   RETURN
        GOTO9000
      ENDIF
C
1     CONTINUE
      CALL SIMP3(A,MP,NP,M+1,N,IP,KP)
      IF(IPOSV(IP).GE.N+M1+M2+1)THEN
        DO 19 K=1,NL1
          IF(L1(K).EQ.KP)GO TO 2
19      CONTINUE
2       CONTINUE
        NL1=NL1-1
        DO 21 IS=K,NL1
          L1(IS)=L1(IS+1)
21      CONTINUE
      ELSE
        IF(IPOSV(IP).LT.N+M1+1)GO TO 20
        KH=IPOSV(IP)-M1-N
        IF(L3(KH).EQ.0)GO TO 20
        L3(KH)=0
      ENDIF
      A(M+2,KP+1)=A(M+2,KP+1)+1.
      DO 22 I=1,M+2
        A(I,KP+1)=-A(I,KP+1)
22    CONTINUE
20    CONTINUE
      IS=IZROV(KP)
      IZROV(KP)=IPOSV(IP)
      IPOSV(IP)=IS
      IF(IR.NE.0)GO TO 10
30    CONTINUE
      CALL SIMP1(A,MP,NP,0,L1,NL1,0,KP,BMAX)
      IF(BMAX.LE.0.)THEN
        ICASE=0
CCCCC   RETURN
        GOTO9000
      ENDIF
      CALL SIMP2(A,M,N,MP,NP,L2,NL2,IP,KP,Q1)
      IF(IP.EQ.0)THEN
        ICASE=1
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,231)
  231 FORMAT('***** ERROR IN SIMPLX--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,232)
  232 FORMAT('      OBJECTIVE FUNCTION UNBOUNDED IN THIS REGION.')
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
CCCCC   RETURN
        GOTO9000
      ENDIF
      CALL SIMP3(A,MP,NP,M,N,IP,KP)
      GO TO 20
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'MPLX')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF SIMPLX--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IBUGA3,ISUBRO
 9012 FORMAT('IBUGA3,ISUBRO = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9021)M,N,MP,NP,M1,M2,M3,MP1,NP1
 9021 FORMAT('M,N,MP,NP,M1,M2,M3,MP1,NP1 = ',9I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9022)ICASE
 9022 FORMAT('ICASE = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9023)XBAR,EPS
 9023 FORMAT('XBAR,EPS = ',2E15.7)
      CALL DPWRST('XXX','BUG ')
      IF(M.LE.0)GOTO9039
      IF(N.LE.0)GOTO9039
      JMAX=NP1
      IF(JMAX.GT.10)JMAX=10
      DO9032I=1,MP1
      WRITE(ICOUT,9033)I,(A(I,J),J=1,JMAX)
 9033 FORMAT('I,A(I,.) = ',I8,10F10.2)
      CALL DPWRST('XXX','BUG ')
 9032 CONTINUE
 9039 CONTINUE
      DO9041I=1,M
      WRITE(ICOUT,9042)I,IPOSV(I)
 9042 FORMAT('I,IPOSV(I) = ',2I8)
      CALL DPWRST('XXX','BUG ')
 9041 CONTINUE
      DO9051I=1,N
      WRITE(ICOUT,9052)I,IZROV(I)
 9052 FORMAT('I,IZROV(I) = ',2I8)
      CALL DPWRST('XXX','BUG ')
 9051 CONTINUE
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE SIMP1(A,MP,NP,MM,LL,NLL,IABF,KP,BMAX)
C
C     PURPOSE--
C
C     SOURCE--NUMERICAL RECIPES,
C             PRESS, FLANNERY, TEUKOLSKY, AND VETTERLING,
C             CAMBRIDGE UNIVERSITY PRESS, 1986.
C
C
C---------------------------------------------------------------------
C
      DIMENSION A(MP,NP),LL(NP)
C
C-----START POINT-----------------------------------------------------
C
      KP=LL(1)
      BMAX=A(MM+1,KP+1)
      IF(NLL.LT.2)RETURN
      DO 11 K=2,NLL
        IF(IABF.EQ.0)THEN
          TEST=A(MM+1,LL(K)+1)-BMAX
        ELSE
          TEST=ABS(A(MM+1,LL(K)+1))-ABS(BMAX)
        ENDIF
        IF(TEST.GT.0.)THEN
          BMAX=A(MM+1,LL(K)+1)
          KP=LL(K)
        ENDIF
11    CONTINUE
C
      RETURN
      END
      SUBROUTINE SIMP2(A,M,N,MP,NP,L2,NL2,IP,KP,Q1)
C
C     PURPOSE--
C
C     SOURCE--NUMERICAL RECIPES,
C             PRESS, FLANNERY, TEUKOLSKY, AND VETTERLING,
C             CAMBRIDGE UNIVERSITY PRESS, 1986.
C
C---------------------------------------------------------------------
C
      PARAMETER (EPS=1.E-6)
      DIMENSION A(MP,NP),L2(MP)
C
      INCLUDE 'DPCOBE.INC'
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      IF(ISUBG4.EQ.'IMP2')THEN
        WRITE(ICOUT,1)M,N,MP,NP
    1   FORMAT('M,N,MP,NP = ',4I8)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      Q0=0.0
      QP=0.0
C
      IP=0
      IF(NL2.LT.1)RETURN
      DO 11 I=1,NL2
        IF(A(L2(I)+1,KP+1).LT.-EPS)GO TO 2
11    CONTINUE
      RETURN
2     Q1=-A(L2(I)+1,1)/A(L2(I)+1,KP+1)
      IP=L2(I)
      IF(I+1.GT.NL2)RETURN
      DO 13 I=I+1,NL2
        II=L2(I)
        IF(A(II+1,KP+1).LT.-EPS)THEN
          Q=-A(II+1,1)/A(II+1,KP+1)
          IF(Q.LT.Q1)THEN
            IP=II
            Q1=Q
          ELSE IF (Q.EQ.Q1) THEN
            DO 12 K=1,N
              QP=-A(IP+1,K+1)/A(IP+1,KP+1)
              Q0=-A(II+1,K+1)/A(II+1,KP+1)
              IF(Q0.NE.QP)GO TO 6
12          CONTINUE
6           IF(Q0.LT.QP)IP=II
          ENDIF
        ENDIF
13    CONTINUE
C
      RETURN
      END
      SUBROUTINE SIMP3(A,MP,NP,I1,K1,IP,KP)
C
C     PURPOSE--
C
C     SOURCE--NUMERICAL RECIPES,
C             PRESS, FLANNERY, TEUKOLSKY, AND VETTERLING,
C             CAMBRIDGE UNIVERSITY PRESS, 1986.
C
C---------------------------------------------------------------------
C
      DIMENSION A(MP,NP)
C
C-----START POINT-----------------------------------------------------
C
      PIV=1./A(IP+1,KP+1)
      IF(I1.GE.0)THEN
        DO 12 II=1,I1+1
          IF(II-1.NE.IP)THEN
            A(II,KP+1)=A(II,KP+1)*PIV
            DO 11 KK=1,K1+1
              IF(KK-1.NE.KP)THEN
                A(II,KK)=A(II,KK)-A(IP+1,KK)*A(II,KP+1)
              ENDIF
11          CONTINUE
          ENDIF
12      CONTINUE
      ENDIF
      DO 13 KK=1,K1+1
        IF(KK-1.NE.KP)A(IP+1,KK)=-A(IP+1,KK)*PIV
13    CONTINUE
      A(IP+1,KP+1)=PIV
C
      RETURN
      END
      SUBROUTINE SIMRAT
     $ (U1, S1, V1, IQ, W, NBCH, NTOT, NPAR, NREP, IRK,
     $ XNCP, CONF, WK1, WK2, VALS, QUANT,IERROR)
C
C      MARK VANGEL, APRIL 1995
C
C        SIMULATE THE PIVOTAL RATIO IN THE LIMIT OF ZERO
C     WITHIN-GROUP VARIANCE.
C
C     SINGULAR VALUE DECOMPOSITION OF THE DEISGN MATRIX:
C     U1, S1, V1  ---  (INPUT, D.P.)
C     IQ    ---   BATCH INDICATOR (INPUT, INT., LENGTH `NBCH')
C     W     ---   VECTOR OF COEFFICIENTS OF POINT AT WHICH TOL.
C             LIM. IS TO BE CALCULATED (INPUT, D.P., LENGTH `NREP')
C     NBCH  ---   NUMBER OF BATCHES (INPUT, INT.)
C     NTOT  ---   TOTAL NUMBER OF DATA VALUES (INPUT, INT.)
C     NPAR  ---   NUMBER OF REGRESSION COEFFICIENTS (INPUT, INT.)
C     NREP  ---   NUMBER OF SIMULATION REPLICATES (INPUT, INT.)
C     IRK   ---   RANK OF DESIGN MATRIX (INPUT, INT.)
C     XNCP  ---   NONCENTRALITY PARAMETER (Z_{\BETA}) (INPUT,D.P.)
C     CONF  ---   CONFIDENCE LEVEL (INPUT, D.P.)
C     WK1   ---   WORK ARRAY (OUTPUT, D.P., LENGTH MAX(NBCH, IRK))
C     WK2   ---   WORK ARRAY (OUTPUT, D.P., LENGTH NTOT)
C     VALS  ---   ARRAY OF SIM. VALUES (OUTPUT, D.P., LENGTH NREP)
C     QUANT ---   ESTIMATED QUANTILE (OUPUT, D.P.)
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
CCCCC REAL RNOR
      REAL XTMP(1)
      DOUBLE PRECISION DUM(1)
      CHARACTER*4 IERROR
      DIMENSION U1(1), S1(1), V1(1), IQ(1), W(1), WK1(1),
     $          WK2(1), VALS(1)
      DATA ZERO, ONE /0.D0, 1.D0/
C
C     -- LOOP OVER `NREP' REPLICATES
      NRAN=1
      DO 100 ISIM=1, NREP
C
C     -- GENERATE ONE N(0,1) R.V. FOR EACH LEVEL OF RANDOM
C        EFFECT.
         DO 10 I=1, NBCH
CCCCC      WK1(I) = RNOR(0)
           CALL NORRAN(NRAN,ISEED,XTMP)
           WK1(I)=DBLE(XTMP(1))
 10      CONTINUE
C
C     --  CREATE PSEUDO-RANDOM DATA FOR \SIGMA_{E}^2 = 0 CASE
         DO 20 I=1, NTOT
            WK2(I) = WK1(IQ(I))
 20      CONTINUE
         Y2 = DDOT (NTOT, WK2, 1, WK2, 1)
C
C     -- FORM VECTOR Q = (U^T)Y
         CALL DGEMV ('T', NTOT, IRK, ONE, U1, NTOT,
     $            WK2, 1, ZERO, WK1, 1, IERROR)
         IF(IERROR.EQ.'YES')RETURN
         Q2 = DDOT (IRK, WK1, 1, WK1, 1)
C
C     -- FORM VECTOR W = (V^T)W
         CALL DGEMV ('T', NPAR, NTOT, ONE, V1, NPAR,
     $            W,   1, ZERO, WK2,   1, IERROR)
         IF(IERROR.EQ.'YES')RETURN
C
C     -- CALCULATE W^T(L^(-))Q, WHERE L IS MATRIX OF SVS
         XNUM = 0
         DO 30 I=1, IRK
            XNUM = XNUM +WK2(I) *WK1(I) /S1(I)
 30      CONTINUE
C
C     -- CALCULATE RESIDUAL SUM OF SQUARES
         RSS = Y2 -Q2
C
C     -- FINALLY, FORM RATIO AND RETURN
         VALS (ISIM) = (XNUM+XNCP) /SQRT(RSS/(NTOT -IRK))
 100  CONTINUE
C
C     -- SORT THE SIMULATED PIVOT VALUES
      KFLAG=1
      CALL DSORT (VALS, DUM, NREP, KFLAG, IERROR)
C
C     -- RETURN THE DESIRED QUANTILE
      IDX   = INT(CONF*NREP)
      QUANT = VALS(IDX)
      RETURN
      END
      SUBROUTINE SINCDF(X,CDF)
C
C     NOTE--SINE CDF IS:
C              SINCDF(X) = SIN((X/2) + (PI/4))**2
C     WRITTEN BY--ALAN HECKERT
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS
C                 GAITHERSBURG, MD 20899
C                 PHONE--301-975-2899
C     REFERENCE--PETER BURROWS, "EXTREME STATISTICS FROM THE SINE
C                DISTRIBUTION", THE AMERICAN STATISTICIAN, AUGUST 1986,
C                VOL. 40, NO. 3, PP. 216-218.
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2013/3
C     ORIGINAL VERSION--MARCH     2013.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
      DATA PI/3.1415926535898E0/
C
C-----START POINT-----------------------------------------------------
C
      CDF=0.0
      PI2=PI/2.0
      PI4=PI/4.0
      IF(X.LE.-PI2)THEN
        CDF=0.0
      ELSEIF(X.GE.PI2)THEN
        CDF=1.0
      ELSE
        CDF=SIN((X/2.0) + PI4)**2
      ENDIF
C
      RETURN
      END
      SUBROUTINE SINFIT(X,TEMP,N,IWRITE,XSINFR,XSINAM,XRESSD,
     1ISUBRO,IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE
C              SINUSOIDAL FREQUENCY ESTIMATE
C              AND THE SINUSOIDAL AMPLITUDE ESTIMATE
C              OF THE DATA IN THE INPUT VECTOR X.
C              THE FREQUENCY AND AMPLITUDE ESTIMATE =
C              THAT APPROXIMATE LEAST SQUARES FIT FREQUENCY AND AMP.
C              WHICH BEST FITS THE DATA IN A 1-FREQUENCY SIN MODEL.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF
C                                (UNSORTED) OBSERVATIONS.
C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR X.
C     OUTPUT ARGUMENTS--XSINFR = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED SAMPLE AUTOCOVARIANCE
C                                COEFFICIENT.
C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
C             SINUSOIDAL FREQUENCY ESTIMATE AND AMPLITUDE ESTIMATE.
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     REFERENCE--BLOOMFIELD, PETER, FOURIER ANALYSIS OF TIME SERIES:
C                AN INTRODUCTION, WILEY, 1976, PAGES 14 AND 18.
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     VERSION NUMBER--88/1
C     ORIGINAL VERSION--JANUARY   1988.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 ISUBRO
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DN
      DOUBLE PRECISION DX
CCCCC DOUBLE PRECISION DX1
CCCCC DOUBLE PRECISION DX2
      DOUBLE PRECISION DSUM
      DOUBLE PRECISION DMEAN
C
      DIMENSION X(*)
      DIMENSION TEMP(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='SINF'
      ISUBN2='IT  '
      IERROR='NO'
C
      PI=3.1415926
C
      DN=0.0D0
      DMEAN=0.0D0
C
      IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'NFIT')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF SINFIT--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)ISUBRO,IBUGA3,N
   52 FORMAT('ISUBRO,IBUGA3,N = ',2(A4,2X),I8)
      CALL DPWRST('XXX','BUG ')
      DO55I=1,N
      WRITE(ICOUT,56)I,X(I)
   56 FORMAT('I,X(I) = ',I8,G15.7)
      CALL DPWRST('XXX','BUG ')
   55 CONTINUE
   90 CONTINUE
C
C               *******************************************
C               **  COMPUTE  APPROX. LEAST SQUARES FIT   **
C               **  ESTIMATE OF UENCY                    **
C               **  IN A 1-TERM SINUSOIDAL MODEL.        **
C               *******************************************
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      AN=N
C
      IF(N.LT.1)THEN
        IERROR='YES'
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,111)
  111   FORMAT('***** ERROR IN SINFIT--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,112)
  112   FORMAT('      THE INPUT NUMBER OF OBSERVATIONS MUST BE 1 OR ',
     1         'LARGER.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,116)
  116   FORMAT('      SUCH WAS NOT THE CASE HERE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,117)N
  117   FORMAT('      THE INPUT NUMBER OF OBSERVATIONS = ',I8,'.')
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(N.EQ.1)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,121)
  121   FORMAT('***** WARNING IN SINFIT--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,123)
  123   FORMAT('      THE INPUT NUMBER OF OBSERVATIONS IS EXACTLY ',
     1         'EQUAL TO ONE.')
        CALL DPWRST('XXX','BUG ')
        XSINFR=0.0
        GOTO9000
      ENDIF
C
      HOLD=X(1)
      DO135I=2,N
      IF(X(I).NE.HOLD)GOTO139
  135 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,121)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,136)HOLD
  136 FORMAT('      THE RESPONSE VARIABLE HAS ALL ELEMENTS = ',G15.7)
      CALL DPWRST('XXX','BUG ')
      XSINFR=0.0
      GOTO9000
  139 CONTINUE
C
C               ************************************************
C               **  STEP 2--                                  **
C               **  COMPUTE THE  APPROXIMATE LEAST SQUARES    **
C               **  SINUSOIDAL FREQUENCY ESTIMATE             **
C               ************************************************
C
      DN=N
      DSUM=0.0D0
      DO200I=1,N
      DX=X(I)
      DSUM=DSUM+DX
  200 CONTINUE
      DMEAN=DSUM/DN
      XMEAN=DMEAN
C
      DO300I=1,N
      TEMP(I)=X(I)-XMEAN
  300 CONTINUE
C
      SSQHOL=CPUMAX
      NLOOP=100
      ANLOOP=NLOOP
      DO500IANGLE=1,NLOOP
      AANGLE=IANGLE
      THETA=AANGLE/(2.0*ANLOOP)
      OMEGA=2.0*PI*THETA
C
      SUM1=0.0
      SUM2=0.0
      DO550I=1,N
      AI=I
      SUM1=SUM1+X(I)*COS(OMEGA*AI)
      SUM2=SUM2+X(I)*SIN(OMEGA*AI)
  550 CONTINUE
      A=(2.0/AN)*SUM1
      B=(2.0/AN)*SUM2
      AMP=A*A+B*B
      IF(AMP.GT.0.0)AMP=SQRT(AMP)
C
      SSQ=0.0
      DO560I=1,N
      AI=I
      PREDI=A*COS(OMEGA*AI)+B*SIN(OMEGA*AI)
      RESI=TEMP(I)-PREDI
      SSQ=SSQ+RESI**2
  560 CONTINUE
C
      IF(IANGLE.LE.1)GOTO561
      GOTO562
  561 CONTINUE
      FREHOL=THETA
      AMPHOL=AMP
      SSQHOL=SSQ
      GOTO569
  562 CONTINUE
      IF(SSQ.LT.SSQHOL)FREHOL=THETA
      IF(SSQ.LT.SSQHOL)AMPHOL=AMP
      IF(SSQ.LT.SSQHOL)SSQHOL=SSQ
      GOTO569
  569 CONTINUE
C
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'NFIT')THEN
        WRITE(ICOUT,563)AANGLE,THETA,SSQ,SSQHOL,A,B,AMP
  563   FORMAT('AANGLE,THETA,SSQ,SSQHOL,A,B,AMP = ',7E12.4)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
  500 CONTINUE
      XSINFR=FREHOL
      XSINAM=AMPHOL
      RESSD=SSQHOL/(AN-2.0)
      IF(RESSD.GT.0.0)RESSD=SQRT(RESSD)
C
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'NFIT')THEN
        WRITE(ICOUT,591)XSINFR,XSINAM,XRESSD
  591   FORMAT('XSINFR,XSINAM,XRESSD = ',3E15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
C               *******************************
C               **  STEP 3--                 **
C               **  WRITE OUT A LINE         **
C               **  OF SUMMARY INFORMATION.  **
C               *******************************
C
      IF(IFEEDB.EQ.'OFF')GOTO890
      IF(IWRITE.EQ.'OFF')GOTO890
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,811)N,XSINFR
  811 FORMAT('THE SINUSOIDAL FREQUENCY ESTIMATE FOR THE ',I8,
     1' OBSERVATIONS = ',G15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,812)N,XSINAM
  812 FORMAT('THE SINUSOIDAL AMPLITUDE ESTIMATE FOR THE ',I8,
     1' OBSERVATIONS = ',G15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,813)XRESSD
  813 FORMAT('THE RESIDUAL STANDARD DEVIATION = ',G15.7)
      CALL DPWRST('XXX','BUG ')
  890 CONTINUE
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'NFIT')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF SINFIT--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)ISUBRO,IBUGA3,IERROR
 9012 FORMAT('ISUBRO,IBUGA3,IERROR = ',2(A4,2X),A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9014)N,DN,DMEAN
 9014 FORMAT('N,DN,DMEAN = ',I8,2G15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9015)XSINFR,XSINAM,XRESSD
 9015 FORMAT('XSINFR,XSINAM,XRESSD = ',3G15.7)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE SINPDF(X,PDF)
C
C     NOTE--SINE PDF IS:
C              SINPDF(X) = 0.5*COS(X)
C     WRITTEN BY--ALAN HECKERT
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS
C                 GAITHERSBURG, MD 20899
C                 PHONE--301-975-2899
C     REFERENCE--PETER BURROWS, "EXTREME STATISTICS FROM THE SINE
C                DISTRIBUTION", THE AMERICAN STATISTICIAN, AUGUST 1986,
C                VOL. 40, NO. 3, PP. 216-218.
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2013/3
C     ORIGINAL VERSION--MARCH     2013.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
      DATA PI/3.1415926535898E0/
C
C-----START POINT-----------------------------------------------------
C
      PDF=0.0
      PI2=PI/2.0
      IF(X.LT.-PI2 .OR. X.GT.PI2)THEN
        WRITE(ICOUT,301)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,302)X
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
  301 FORMAT('***** ERROR--THE INPUT ARGUMENT TO SINPDF IS NOT IN THE ',
     1       'INTERVAL (-PI/2,PI/2).')
  302 FORMAT('      THE VALUE OF THE ARGUMENT IS ',G15.7)
C
      PDF=0.5*COS(X)
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE SINPPF(P,PPF)
C
C     NOTE--THE SINE PPF IS:
C
C               G(P) = 2*(ARCSIN(SQRT(P)) - (PI/4))
C     WRITTEN BY--ALAN HECKERT
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS
C                 GAITHERSBURG, MD 20899
C                 PHONE--301-975-2899
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2013/3
C     ORIGINAL VERSION--MARCH     2013.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
      DATA PI/3.1415926535898E0/
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)
    1   FORMAT('***** ERROR--THE FIRST ARGUMENT TO SINPPF IS OUTSIDE',
     1         ' THE ALLOWABLE (0,1) INTERVAL.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)P
   46   FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
        GOTO9000
      ENDIF
C
      IF(P.LE.0.0)THEN
        PPF=-PI/2.0
      ELSEIF(P.GE.1.0)THEN
        PPF=PI/2.0
      ELSE
        ARG=SQRT(P)
        ARG2=ARG/SQRT(1.0 - ARG*ARG)
        TERM1=ATAN(ARG2)
        PPF=2.0*(TERM1 - (PI/4.0))
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE SINRAN(N,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE SINE DISTRIBUTION
C              F(X) = 0.5*EXP(-ABS(X)).
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST N)
C                                INTO WHICH THE GENERATED
C                                RANDOM SAMPLE WILL BE PLACED.
C     OUTPUT--A RANDOM SAMPLE OF SIZE N FROM THE SINE DISTRIBUTION
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     WRITTEN BY--ALAN HECKER
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS
C                 GAITHERSBURG, MD 20899
C                 PHONE--301-975-2899
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2013/3
C     ORIGINAL VERSION--MARCH     2013.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)THEN
        WRITE(ICOUT, 5)
    5   FORMAT('***** ERROR--THE FIRST ARGUMENT TO SINRAN IS ',
     1         'NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
   47   FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8)
        CALL DPWRST('XXX','BUG ')
        RETURN
      ENDIF
C
C     GENERATE N UNIFORM (0,1) RANDOM NUMBERS;
C
      CALL UNIRAN(N,ISEED,X)
C
C     GENERATE N COSINE RANDOM NUMBERS
C     USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD.
C
      DO100I=1,N
        CALL SINPPF(X(I),XTEMP)
        X(I)=XTEMP
  100 CONTINUE
C
      RETURN
      END
      SUBROUTINE SINTRA(Y1,N1,IWRITE,Y2,N2,IBUGA3,IERROR)
C
C     PURPOSE--COMPUTE SINE TRANSFORM OF A VARIABLE--
C            = THE COEFFICIENTS OF THE SINE TERM
C              IN THE FINITE FOURIER RESPRESENTATION OF THE DATA IN Y1.
C              Y2(1) = B0 = 0
C              Y2(2) = B1
C              Y2(3) = B2
C              ETC.
C     NOTE--IT IS NOT PERMISSIBLE TO HAVE THE OUTPUT VECTOR Y2(.)
C           BEING IDENTICAL TO THE INPUT VECTOR Y1(.).
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--85/1
C     ORIGINAL VERSION--DECEMBER  1984.
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-----DOUBLE PRECISION STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DOUBLE PRECISION DPI
      DOUBLE PRECISION DN1
      DOUBLE PRECISION DDEL
      DOUBLE PRECISION DI
      DOUBLE PRECISION DSUM
      DOUBLE PRECISION DK
      DOUBLE PRECISION DOMEGA
      DOUBLE PRECISION DY1K
C
C---------------------------------------------------------------------
C
      DIMENSION Y1(*)
      DIMENSION Y2(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='SINT'
      ISUBN2='RA  '
      IERROR='NO'
C
      N1HALF=(-999)
      IMAX=(-999)
      IEVODD=(-999)
      DDEL=(-999.0D0)
C
      DN1=N1
C
      DPI=3.14159265358979D0
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 SINTRA--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,52)IBUGA3,IWRITE,N1,MAXOBV
   52   FORMAT('IBUGA3,IWRITE,N1,MAXOBV = ',2(A4,2X),2I8)
        CALL DPWRST('XXX','BUG ')
        DO55I=1,N1
          WRITE(ICOUT,56)I,Y1(I)
   56     FORMAT('I,Y1(I) = ',I8,G15.7)
          CALL DPWRST('XXX','BUG ')
   55   CONTINUE
      ENDIF
C
C               ***********************************
C               **  COMPUTE SINE TRANSFORM.      **
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 SINTRA--')
      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 ')
      WRITE(ICOUT,1154)
 1154 FORMAT('      THE SINE TRANSFORM IS TO BE COMPUTED')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1155)
 1155 FORMAT('      MUST BE 1 OR LARGER.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1156)
 1156 FORMAT('      SUCH WAS NOT THE CASE HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1157)N1
 1157 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8,
     1'.')
      CALL DPWRST('XXX','BUG ')
      GOTO9000
C
 1190 CONTINUE
C
      N1HALF=N1/2
      N1HALP=N1HALF+1
      IMAX=N1HALP
      IEVODD=N1-2*(N1/2)
      DDEL=(DN1+1.0D0)/2.0D0
      IF(IEVODD.EQ.0)DDEL=(DN1+2.0D0)/2.0D0
C
      J=0
      J=J+1
      Y2(J)=0.0
C
      DO1210IP1=2,IMAX
      J=J+1
      I=IP1-1
      DI=I
CCCCC FREQI=DI/DN1
      DSUM=0.0D0
C
      DO1220K=1,N1
      DK=K
      DOMEGA=2.0*DPI*(DI/DN1)
      DY1K=Y1(K)
      DSUM=DSUM+DY1K*DSIN(DOMEGA*(DK-DDEL))
 1220 CONTINUE
      COEF=DSUM/DN1
      IF(IBUGA3.EQ.'ON')WRITE(ICOUT,1221)J,I,DN1,DI,COEF
 1221 FORMAT('J,I,DN1,DI,COEF = ',I8,I8,2D15.7,E15.7)
      IF(IBUGA3.EQ.'ON')CALL DPWRST('XXX','BUG ')
C
      Y2(J)=COEF
C
 1210 CONTINUE
C
      N2=J
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
C
      IF(IBUGA3.EQ.'ON')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END       OF SINTRA--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9012)IERROR
 9012   FORMAT('IERROR = ',A4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9013)N1,N2,N1HALF,IMAX,IEVODD,DDEL
 9013   FORMAT('N1,N2,N1HALF,IMAX,IEVODD,DDEL = ',5I8,D15.7)
        CALL DPWRST('XXX','BUG ')
        DO9015I=1,N1
          WRITE(ICOUT,9016)I,Y1(I),Y2(I)
 9016     FORMAT('I,Y1(I),Y2(I) = ',I8,2G15.7)
          CALL DPWRST('XXX','BUG ')
 9015   CONTINUE
      ENDIF
C
      RETURN
      END
      SUBROUTINE SIZE(X,N,IWRITE,XSIZE,IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE    COMPUTES    THE
C              SAMPLE SIZE
C              OF THE DATA IN THE INPUT VECTOR X.
C              THE SAMPLE SIZE IS IDENTICALLY = THE INPUT ARGUMENT N
C              EXCEPT N IS AN INTEGER VARIABLE
C              WHEREAS THE OUTPUTTED XSIZE IS A SINGLE PRECISION VARIABLE.
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--XSIZE  = THE SINGLE PRECISION VALUE OF THE
C                                   COMPUTED    SAMPLE SIZE.
C     OUTPUT--THE    COMPUTED    SINGLE PRECISION VALUE OF THE
C             SAMPLE SIZE; THAT IS, A SINGLE PRECISION REPRESENTATION
C             OF THE INTEGER INPUT VARIABLE N.
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--NONE.
C     NOTE--ALTHOUGH THIS SUBROUTINE DOES    NOTHING
C           EXCEPT FORM THE SINGLE PRECISION VARIABLE XSIZE
C           WHICH IS EQUAL TO THE INTEGER INPUT VARIABLE N,
C           IT EXISTS AND HAS THE ARGUMENT STRUCTURE
C           THAT IT DOES SO AS TO HAVE AN IDENTICAL
C           CALLING SEQUENCE WITH MOST OF THE OTHER
C           SUBROUTINES IN THE INDIVIDUAL STATISTICS
C           CATEGORY OF THE DATAPAC LIBRARY.
C           THIS IS DESIRABLE FOR THE USE OF THE
C           SUBSET STATISTICS SUBROUTINES SSTAT1, SSTAT2, SSTAT3, ...
C           WHICH CARRY AN INDIVIDUAL STATISTICS CATEGORY SUBROUTINE
C           NAME (E. G., MEAN, MEDIAN, SD, RANGE, SIZE, ETC.)
C           AS ITS FIRST INPUT ARGUMENT SO AS TO SPECIFY
C           WHAT STATISTIC IS TO BE COMPUTED FOR THE SUBSETS OF
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--82.6
C     ORIGINAL VERSION--JUNE      1977.
C     UPDATED         --JUNE      1979.
C     UPDATED         --AUGUST    1981.
C     UPDATED         --MARCH     1982.
C     UPDATED         --MAY       1982.
C     UPDATED         --OCTOBER   2012. DON'T SET ERROR FLAG
C                                       FOR EMPTY SUBSET, JUST
C                                       SET SIZE TO 0.
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(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='SIZE'
      ISUBN2='    '
      IERROR='NO'
C
      IF(IBUGA3.EQ.'ON')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,51)
   51   FORMAT('***** AT THE BEGINNING OF SIZE--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,52)IBUGA3,N
   52   FORMAT('IBUGA3,N = ',A4,2X,I8)
        CALL DPWRST('XXX','BUG ')
        DO55I=1,N
          WRITE(ICOUT,56)I,X(I)
   56     FORMAT('I,X(I) = ',I8,G15.7)
          CALL DPWRST('XXX','BUG ')
   55   CONTINUE
      ENDIF
C
C               ********************
C               **  COMPUTE SIZE  **
C               ********************
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
CCCCC AN=N
C
CCCCC IF(N.GE.1)GOTO119
CCCCC IERROR='YES'
CCCCC WRITE(ICOUT,999)
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC WRITE(ICOUT,111)
CC111 FORMAT('***** ERROR IN SIZE--')
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC WRITE(ICOUT,112)
CC112 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS')
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC WRITE(ICOUT,113)
CC113 FORMAT('      IN THE VARIABLE FOR WHICH')
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC WRITE(ICOUT,114)
CC114 FORMAT('      THE SAMPLE SIZE IS TO BE COMPUTED')
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC WRITE(ICOUT,115)
CC115 FORMAT('      MUST BE 1 OR LARGER.')
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC WRITE(ICOUT,116)
CC116 FORMAT('      SUCH WAS NOT THE CASE HERE.')
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC WRITE(ICOUT,117)N
CC117 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8,
CCCCC1'.')
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC GOTO9000
CC119 CONTINUE
C
CCCCC IF(N.LE.1)GOTO120
CCCCC GOTO129
CC120 CONTINUE
CCCCC WRITE(ICOUT,999)
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC WRITE(ICOUT,121)N
CC121 FORMAT('***** NON-FATAL DIAGNOSTIC IN SIZE--',
CCCCC1'THE SECOND INPUT ARGUMENT (N) HAS THE VALUE ',I8)
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC XSIZE=N
CCCCC GOTO9000
CC129 CONTINUE
C
CCCCC HOLD=X(1)
CCCCC DO135I=2,N
CCCCC IF(X(I).NE.HOLD)GOTO139
CC135 CONTINUE
CCCCC WRITE(ICOUT,999)
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC WRITE(ICOUT,136)HOLD
CC136 FORMAT('***** NON-FATAL DIAGNOSTIC IN SIZE--',
CCCCC1'THE FIRST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7)
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC XSIZE=N
CCCCC GOTO9000
CC139 CONTINUE
C
CC190 CONTINUE
C
C               ********************************
C               **  STEP 2--                  **
C               **  COMPUTE THE SAMPLE SIZE.  **
C               ********************************
C
      XSIZE=N
C
C               *******************************
C               **  STEP 3--                 **
C               **  WRITE OUT A LINE         **
C               **  OF SUMMARY INFORMATION.  **
C               *******************************
C
      IF(IFEEDB.EQ.'ON' .AND. IWRITE.EQ.'ON')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,811)N,XSIZE
  811   FORMAT('THE SAMPLE SIZE OF THE ',I8,' OBSERVATIONS = ',G15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
      IF(IBUGA3.EQ.'ON')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END       OF SIZE--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9012)IBUGA3,IERROR,N,XSIZE
 9012   FORMAT('IBUGA3,IERROR,N,XSIZE = ',2(A4,2X),I8,G15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      RETURN
      END
      SUBROUTINE SLACDF(X,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION FROM THE THE SLASH DISTIBUTION WITH
C              LOCATION = 0 AND SCALE = 1.  THIS DISTRIBUTION IS
C              DEFINED FOR ALL X AND HAS THE PROBABILITY DENSITY
C              FUNCTION
C              F(X) = NORPDF(0) - NORPDF(X))/[X**2]     X <> 0
C                     0.5*NORPDF(0)                     X = 0
C              WHERE NORPDF IS THE PDF OF THE STANDARD NORMAL
C              DISTRIBUTION.  THE CUMULATIVE DISTRIBUTION IS
C              COMPUTED BY CALLING THE QAGI (FROM QUADPACK)
C              INTEGRATION ROUTINE.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C     OUTPUT ARGUMENTS--CDF    = THE SINGLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE CDF.
C     PRINTING--NONE.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--DQAGI.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE 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     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
      INTEGER LIMIT
      INTEGER LENW
      PARAMETER(LIMIT=100)
      PARAMETER(LENW=4*LIMIT)
      INTEGER INF
      INTEGER NEVAL
      INTEGER IER
      INTEGER LAST
      INTEGER IWORK(LIMIT)
      REAL X
      REAL CDF
      DOUBLE PRECISION EPSABS
      DOUBLE PRECISION EPSREL
      DOUBLE PRECISION DCDF
      DOUBLE PRECISION DX
      DOUBLE PRECISION ABSERR
      DOUBLE PRECISION WORK(LENW)
C
      DOUBLE PRECISION SLAFUN
      EXTERNAL SLAFUN
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C
      INF=-1
      EPSABS=0.0D0
      EPSREL=1.0D-7
      IER=0
      DCDF=0.0D0
C
C  NOTE: FOR X > 0, COMPUTE 1 - SLACDF(-X) FOR EFFICIENCY (INTEGRATING
C        OVER A SMALLER RANGE) AND GREATER ACCURACY.
C
      IFLAG=0
      DX=DBLE(X)
      IF(DX.GT.0.0D0)THEN
        IFLAG=1
        DX=-DX
      ENDIF
C
      CALL DQAGI(SLAFUN,DX,INF,EPSABS,EPSREL,DCDF,ABSERR,NEVAL,
     1          IER,LIMIT,LENW,LAST,IWORK,WORK)
C
      IF(IFLAG.EQ.0)THEN
        CDF=REAL(DCDF)
      ELSE
        DCDF=1.0D0 - DCDF
        CDF=REAL(DCDF)
      ENDIF
C
      IF(IER.EQ.1)THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,111)
  111   FORMAT('***** ERROR FROM SLACDF--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,113)
  113   FORMAT('      MAXIMUM NUMBER OF SUBDIVISIONS EXCEEDED.')
        CALL DPWRST('XXX','BUG ')
      ELSEIF(IER.EQ.2)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,121)
  121   FORMAT('***** ERROR FROM SLACDF--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,123)
  123   FORMAT('      ROUNDOFF ERROR PREVENTS REQUESTED TOLERANCE ',
     1         'FROM BEING ACHIEVED.')
        CALL DPWRST('XXX','BUG ')
      ELSEIF(IER.EQ.3)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,131)
  131   FORMAT('***** ERROR FROM SLACDF--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,133)
  133   FORMAT('      BAD INTEGRAND BEHAVIOUR DETECTED.')
        CALL DPWRST('XXX','BUG ')
      ELSEIF(IER.EQ.4)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,141)
  141   FORMAT('***** ERROR FROM SLACDF--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,143)
  143   FORMAT('      INTEGRATION DID NOT CONVERGE.')
        CALL DPWRST('XXX','BUG ')
      ELSEIF(IER.EQ.5)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,151)
  151   FORMAT('***** ERROR FROM SLACDF--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,153)
  153   FORMAT('      THE INTEGRATION IS PROBABLY DIVERGENT.')
        CALL DPWRST('XXX','BUG ')
      ELSEIF(IER.EQ.6)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,161)
  161   FORMAT('***** ERROR FROM SLACDF--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,163)
  163   FORMAT('      INVALID INPUT TO THE INTEGRATION ROUTINE.')
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      RETURN
      END
      DOUBLE PRECISION FUNCTION SLAFUN(DX)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION FROM THE THE SLASH DISTIBUTION WITH
C              LOCATION = 0 AND SCALE = 1.  IDENTICAL TO SLAPDF,
C              BUT DEFINE AS FUNCTION TO BE USED FOR INTEGRATION
C              CODE CALLED BY SLACDF.
C     INPUT  ARGUMENTS--DX     = THE DOUBLE PRECISION VALUE AT
C                                WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C     OUTPUT--THE DOUBLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE SLAFUN.
C     PRINTING--NONE.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NODPDF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--EXP.
C     MODE OF INTERNAL OPERATIONS--DOUBLE 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     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2003.12
C     ORIGINAL VERSION--DECEMBER  2003.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
      DOUBLE PRECISION DX
      DOUBLE PRECISION DPDF
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C
C     TRANSFORM THE NORMAL PDF
C
      CALL NODPDF(DX,DTERM3)
C
      IF(DX.EQ.0.0D0)THEN
        DPDF=0.5D0*DTERM3
      ELSE
        CALL NODPDF(0.0D0,DTERM2)
        DPDF=(DTERM2 - DTERM3)/(DX*DX)
      ENDIF
C
      SLAFUN=DPDF
C
      RETURN
      END
      REAL FUNCTION SLAFU2(X)
C
C     PURPOSE--SLAPPF CALLS FZERO TO FIND A ROOT FOR THE PERCENT
C              POINT FUNCTION.  SLAFU2 IS THE FUNCTION FOR WHICH
C              THE ZERO IS FOUND.  IT IS:
C                 P - SLACDF(X)
C              WHERE P IS THE DESIRED PERCENT POINT.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C     OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE SLAFU2.
C     PRINTING--NONE.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--SLACDF.
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     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2003.12
C     ORIGINAL VERSION--DECEMBER  2003.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      REAL P
      COMMON/SLACOM/P
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      CALL SLACDF(X,CDF)
      SLAFU2=P - CDF
C
      RETURN
      END
      DOUBLE PRECISION FUNCTION SLAFU3(SIGMA,X)
C
C     PURPOSE--THIS ROUTINE IS USED IN FINDING THE MAXIMUM LIKELIHOOD
C              ESTIMATE OF THE SCALE PARAMETER OF THE SLASH
C              DISTRIBUTION.  THIS FUNCTION FINDS THE ROOT OF
C              THE EQUATION:
C
C              (SIGMA**2/N)*SUM[i=1 to n][X(I)**2*W(X(I))] - 1 = 0
C
C              WHERE
C
C              X(I) = (Y(I) - MU)/SIGMA
C              W(X(I)) = (2/X**2) - 1/(EXP(X**2/2) - 1)
C
C              CALLED BY DFZER2 ROUTINE FOR FINDING THE ROOT OF A
C              FUNCTION.
C     EXAMPLE--SLASH MAXIMUM LIKELIHOOD Y
C     REFERENCE--KAREN KAFADAR, (1982), "A BIWEIGHT APPROACH TO
C                THE ONE-SAMPLE PROBLEM", JOURNAL OF THE
C                AMERICAN STATISTICAL ASSOCIATION, VOL. 77,
C                NO. 378, PP. 416-424.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBUG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2007/6
C     ORIGINAL VERSION--JUNE       2007.
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION SIGMA
      DOUBLE PRECISION X(*)
C
      INTEGER N
      DOUBLE PRECISION DMU
      COMMON/SL3COM/DMU,N
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DX
      DOUBLE PRECISION DWI
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      DSUM1=0.0D0
      DO100I=1,N
        DX=(X(I) - DMU)/SIGMA
        DWI=(2.0D0/DX**2) - 1.0D0/(DEXP(DX**2/2.0D0) - 1.0D0)
        DSUM1=DSUM1 + DX*DX*DWI
  100 CONTINUE
C
      SLAFU3=(SIGMA**2/DBLE(N))*DSUM1 - SIGMA**2
C
      RETURN
      END
      SUBROUTINE SLALI1(Y,TEMP1,N,ALOC,SCALE,
     1                  ALIK,AIC,AICC,BIC,
     1                  ISUBRO,IBUGA3,IERROR)
C
C     PURPOSE--THIS ROUTINE COMPUTES THE LIKELIHOOD FUNCTION FOR
C              THE SLASH DISTRIBUTION.  THIS IS FOR THE RAW DATA
C              CASE (I.E., NO GROUPING AND NO CENSORING).
C
C              IT IS ASSUMED THAT BASIC ERROR CHECKING HAS ALREADY BEEN
C              PERFORMED.
C
C     WRITTEN BY--ALAN HECKERT
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2899
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2009/10
C     ORIGINAL VERSION--OCTOBER   2009.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 ISUBRO
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 IWRITE
      CHARACTER*4 ICASPL
      CHARACTER*4 IADEDF
      CHARACTER*4 IGEPDF
      CHARACTER*4 IMAKDF
      CHARACTER*4 IBEIDF
      CHARACTER*4 ILGADF
      CHARACTER*4 ISKNDF
      CHARACTER*4 IGLDDF
      CHARACTER*4 IBGEDF
      CHARACTER*4 IGETDF
      CHARACTER*4 ICONDF
      CHARACTER*4 IGOMDF
      CHARACTER*4 IKATDF
      CHARACTER*4 IGIGDF
      CHARACTER*4 IGEODF
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 ISTEPN
      CHARACTER*4 ICAPTY
      CHARACTER*4 ICAPSW
C
      DOUBLE PRECISION DN
      DOUBLE PRECISION DNP
      DOUBLE PRECISION DLIK
      DOUBLE PRECISION DTERM3
C
C---------------------------------------------------------------------
C
      DIMENSION Y(*)
      DIMENSION TEMP1(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='SLAL'
      ISUBN2='I1  '
      IERROR='NO'
C
      ALIK=-99.0
      AIC=-99.0
      AICC=-99.0
      BIC=-99.0
C
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'ALI1')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,51)
   51   FORMAT('**** AT THE BEGINNING OF SLALI1--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,52)IBUGA3,ISUBRO
   52   FORMAT('IBUGA3,ISUBRO = ',A4,2X,A4)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,55)N,ALOC,SCALE
   55   FORMAT('N,ALOC,SCALE = ',I8,2G15.7)
        CALL DPWRST('XXX','WRIT')
        DO56I=1,MIN(N,100)
          WRITE(ICOUT,57)I,Y(I)
   57     FORMAT('I,Y(I) = ',I8,G15.7)
          CALL DPWRST('XXX','WRIT')
   56   CONTINUE
      ENDIF
C
C               ******************************************
C               **  STEP 1--                            **
C               **  COMPUTE LIKELIHOOD FUNCTION         **
C               ******************************************
C
      ISTEPN='1'
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'ALI1')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IERFLG=0
      IERROR='NO'
      IWRITE='OFF'
      ICASPL='SLAS'
      MINMAX=0
C
C     COMPUTE THE LOG-LIKELIHOOD FUNCTION FROM:
C
C         LOG-LIKE = SUM[i=1 to n][LOG(f(x(i);theta))]
C
C     WITH theta DENOTING THE PARAMETERS OF THE
C     DISTRIBUTION.  CALL DPPDF1 AND SUM TO COMPUTE THIS SUM.
C
      SHAPE1=CPUMIN
      SHAPE2=CPUMIN
      SHAPE3=CPUMIN
      SHAPE4=CPUMIN
      SHAPE5=CPUMIN
      SHAPE6=CPUMIN
      SHAPE7=CPUMIN
      IADEDF='NULL'
      IGEPDF='NULL'
      IMAKDF='NULL'
      IBEIDF='NULL'
      ILGADF='NULL'
      ISKNDF='NULL'
      IGLDDF='NULL'
      IBGEDF='NULL'
      IGETDF='NULL'
      ICONDF='NULL'
      IGOMDF='NULL'
      IKATDF='NULL'
      IGIGDF='NULL'
      IGEODF='NULL'
      ICAPSW='NULL'
      ICAPTY='NULL'
      CALL DPPDF1(Y,TEMP1,N,ICASPL,
     1            SHAPE1,SHAPE2,SHAPE3,SHAPE4,
     1            SHAPE5,SHAPE6,SHAPE7,
     1            YLOWLM,YUPPLM,A,B,MINMAX,
     1            ICAPSW,ICAPTY,
     1            IADEDF,IGEPDF,IMAKDF,IBEIDF,
     1            ILGADF,ISKNDF,IGLDDF,IBGEDF,
     1            IGETDF,ICONDF,IGOMDF,IKATDF,
     1            IGIGDF,IGEODF,
     1            ALOC,SCALE,
     1            IBUGA3,ISUBRO,IERROR)
      DO1000I=1,N
        TEMP1(I)=LOG(TEMP1(I))
 1000 CONTINUE
      CALL SUMDP(TEMP1,N,IWRITE,ALIK,IBUGA3,IERROR)
C
      DN=DBLE(N)
      DLIK=DBLE(ALIK)
      DNP=2.0D0
      AIC=REAL(-2.0D0*DLIK + 2.0D0*DNP)
      DTERM3=(2.0D0*DNP*(DNP+1.0D0))/(DN-DNP-1.0D0)
      AICC=REAL(-2.0D0*DLIK + 2.0D0*DNP + DTERM3)
      BIC=REAL(-2.0D0*DLIK + DNP*LOG(DN))
C
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'ALI1')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9011)
 9011   FORMAT('**** AT THE END OF SLALI1--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9013)DSUM1,DTERM1,DTERM3
 9013   FORMAT('DSUM1,DTERM1,DTERM3 = ',3G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9014)ALIK,AIC,AICC,BIC
 9014   FORMAT('ALIK,AIC,AICC,BIC = ',4G15.7)
        CALL DPWRST('XXX','WRIT')
      ENDIF
C
      RETURN
      END
      SUBROUTINE SLAML1(Y,N,MAXNXT,
     1                  TEMP1,TEMP2,TEMP3,DTEMP1,
     1                  XMEAN,XSD,XMIN,XMAX,XMED,XMAD,
     1                  ALOC,ASCALE,
     1                  ISUBRO,IBUGA3,IERROR)
C
C     PURPOSE--THIS ROUTINE COMPUTES THE MAXIMUM LIKELIHOOD ESTIMATES
C              FOR THE SLASH DISTRIBUTION FOR THE RAW DATA CASE (I.E.,
C              NO CENSORING AND NO GROUPING).
C
C              IT IS ASSUMED THAT BASIC ERROR CHECKING HAS ALREADY BEEN
C              PERFORMED.
C
C              PUT THIS IN A SEPARATE ROUTINE AS IT MAY BE CALLED
C              FROM MULTIPLE PLACES (DPMGU1 WILL GENERATE THE OUTPUT
C              FOR THE SLASH MLE COMMAND).
C
C     WRITTEN BY--ALAN HECKERT
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2899
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2009/10
C     ORIGINAL VERSION--OCTOBER   2009. EXTRACTED AS A SEPARATE
C                                       SUBROUTINE (FROM DPMLSL)
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 ISUBRO
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 IWRITE
      CHARACTER*40 IDIST
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 ISTEPN
      INTEGER IFLAG
C
      DIMENSION Y(*)
      DIMENSION TEMP1(*)
      DIMENSION TEMP2(*)
      DIMENSION TEMP3(*)
      DOUBLE PRECISION DTEMP1(*)
C
      DOUBLE PRECISION DAE
      DOUBLE PRECISION DRE
      DOUBLE PRECISION DXSTRT
      DOUBLE PRECISION DXLOW
      DOUBLE PRECISION DXUP
      DOUBLE PRECISION XLOWSV
      DOUBLE PRECISION XUPSV
C
C
      DOUBLE PRECISION SLAFU3
      EXTERNAL SLAFU3
C
      INTEGER IN
      DOUBLE PRECISION DMU
      COMMON/SL3COM/DMU,IN
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='SLAM'
      ISUBN2='L1  '
      IWRITE='OFF'
      IERROR='NO'
C
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'AML1')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,51)
   51   FORMAT('**** AT THE BEGINNING OF SLAML1--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,52)IBUGA3,ISUBRO,N,MAXNXT
   52   FORMAT('IBUGA3,ISUBRO,N,MAXNXT = ',2(A4,2X),2I8)
        CALL DPWRST('XXX','WRIT')
        DO56I=1,MIN(N,100)
          WRITE(ICOUT,57)I,Y(I)
   57     FORMAT('I,Y(I) = ',I8,G15.7)
          CALL DPWRST('XXX','WRIT')
   56   CONTINUE
      ENDIF
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CARRY OUT CALCULATIONS                **
C               **  FOR SLASH MLE ESTIMATE                **
C               ********************************************
C
      ISTEPN='1'
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'AML1')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IDIST='SLASH'
      IFLAG=0
      CALL SUMRAW(Y,N,IDIST,IFLAG,
     1            XMEAN,XVAR,XSD,XMIN,XMAX,
     1            ISUBRO,IBUGA3,IERROR)
      CALL MEDIAN(Y,N,IWRITE,TEMP1,MAXNXT,XMED,IBUGA3,IERROR)
C
      CALL MAD(Y,N,IWRITE,TEMP1,TEMP2,MAXNXT,XMAD,IBUGA3,IERROR)
      CALL SORT(Y,N,Y)
C
C     IF THE DATA ARE IN Y, THE ML ESTIMATE FOR THE LOCATION
C     PARAMETER IS THE SOLUTION TO THE EQUATION
C
C        MUHAT = SUM[i=1 to n][X(I)*W(X(I))]/
C                SUM[i=1 to n][W(X(I))]
C
C     WHERE
C
C        X(I) = (Y(I) - MU)/SIGMA
C        W(X(I)) = (2/X**2) - 1/(EXP(X**2/2) - 1)
C
C     THIS IS THE BIWEIGHT ESTIMATE OF LOCATION.
C
      DO1107I=1,N
        TEMP1(I)=Y(I)
 1107 CONTINUE
      CALL BIWLOC(TEMP1,N,IWRITE,TEMP2,TEMP3,MAXNXT,XBW,
     1            IBUGA3,IERROR)
      ALOC=XBW
C
C     THE ESTIMATE FOR THE SCALE PARAMETER IS THE SOLUTION
C     OF THE FOLLOWING EQUATION:
C
C        (1/N)*SUM[i=1 to n][X(I)**2*W(X(I))] - 1 = 0
C
      DO4101I=1,N
        DTEMP1(I)=DBLE(Y(I))
 4101 CONTINUE
C
      DMU=DBLE(ALOC)
      IN=N
C
      DXSTRT=DBLE(XMAD)
      DAE=2.0*0.000001D0*DXSTRT
      DRE=DAE
      IFLAG=0
      DXLOW=DXSTRT/2.0D0
      DXUP=2.0D0*DXSTRT
      ITBRAC=0
 4105 CONTINUE
      XLOWSV=DXLOW
      XUPSV=DXUP
      CALL DFZER2(SLAFU3,DXLOW,DXUP,DXSTRT,DRE,DAE,IFLAG,DTEMP1)
C
      IF(IFLAG.EQ.4 .AND. ITBRAC.LE.100)THEN
        DXLOW=XLOWSV/2.0D0
        DXUP=2.0D0*XUPSV
        ITBRAC=ITBRAC+1
        GOTO4105
      ENDIF
C
      IF(IFLAG.EQ.2)THEN
C
C  NOTE: SUPPRESS THIS MESSAGE FOR NOW.
CCCCC   WRITE(ICOUT,999)
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   WRITE(ICOUT,111)
CC111   FORMAT('***** WARNING FROM SLASH MAXIMUM ',
CCCCC1         'LIKELIHOOD--')
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   WRITE(ICOUT,113)
CC113   FORMAT('      ESTIMATE OF SIGMA MAY NOT BE COMPUTED TO ',
CCCCC1         'DESIRED TOLERANCE.')
CCCCC   CALL DPWRST('XXX','BUG ')
      ELSEIF(IFLAG.EQ.3)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,121)
  121   FORMAT('***** WARNING FROM SLASH MAXIMUM LIKELIHOOD--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,123)
  123   FORMAT('      ESTIMATE OF SIGMA MAY BE NEAR A SINGULAR POINT.')
        CALL DPWRST('XXX','BUG ')
      ELSEIF(IFLAG.EQ.4)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,131)
  131   FORMAT('***** ERROR FROM SLASH MAXIMUM LIKELIHOOD--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,133)
  133   FORMAT('      APPROPRIATE BRACKETING INTERVAL NOT FOUND.')
        CALL DPWRST('XXX','BUG ')
      ELSEIF(IFLAG.EQ.5)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,141)
  141   FORMAT('***** WARNING FROM SLASH MAXIMUM LIKELIHOOD--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,143)
  143   FORMAT('      MAXIMUM ITERATIONS EXCEEDED.')
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      ASCALE=REAL(DXLOW)
C
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'AML1')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9011)
 9011   FORMAT('**** AT THE END OF SLAML1--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9055)N,XMEAN,XSD,XMIN,XMAX
 9055   FORMAT('N,XMEAN,XSD,XMIN,XMAX = ',I8,4G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9056)ALOC,ASCALE,XMED,XMAD
 9056   FORMAT('ALOC,ASCALE,XMED,XMAD = ',4G15.7)
        CALL DPWRST('XXX','WRIT')
      ENDIF
C
      RETURN
      END
      SUBROUTINE SLAPDF(X,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION FROM THE THE SLASH DISTIBUTION WITH
C              LOCATION = 0 AND SCALE = 1.  THIS DISTRIBUTION IS
C              DEFINED FOR ALL X AND HAS THE PROBABILITY DENSITY
C              FUNCTION
C              F(X) = NORPDF(0) - NORPDF(X))/[X**2]     X <> 0
C                     0.5*NORPDF(0)                     X = 0
C              WHERE NORPDF IS THE PDF OF THE STANDARD NORMAL
C              DISTRIBUTION.
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--NODPDF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--EXP.
C     MODE OF INTERNAL OPERATIONS--DOUBLE 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     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2003.1
C     ORIGINAL VERSION--JANUARY   2003.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
      DOUBLE PRECISION DX
      DOUBLE PRECISION DPDF
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C
C     TRANSFORM THE NORMAL PDF
C
      DX=DBLE(X)
      CALL NODPDF(DX,DTERM3)
C
      IF(X.EQ.0.0)THEN
        DPDF=0.5D0*DTERM3
        PDF=REAL(DPDF)
      ELSE
        CALL NODPDF(0.0D0,DTERM2)
        DPDF=(DTERM2 - DTERM3)/(DX*DX)
        PDF=REAL(DPDF)
      ENDIF
C
      RETURN
      END
      SUBROUTINE SLAPPF(P,PPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION OF THE THE SLASH DISTIBUTION WITH
C              LOCATION = 0 AND SCALE = 1.  THIS DISTRIBUTION IS
C              DEFINED FOR ALL X AND HAS THE PROBABILITY DENSITY
C              FUNCTION
C              F(X) = NORPDF(0) - NORPDF(X))/[X**2]     X <> 0
C                     0.5*NORPDF(0)                     X = 0
C              WHERE NORPDF IS THE PDF OF THE STANDARD NORMAL
C              DISTRIBUTION.  THE PERCENT POINT FUNCTION IS
C              COMPUTED BY CALLING THE FZERO ROUTINE TO FIND THE
C              ROOT OF P - SLACDF(X) WHERE SLACDF IS THE CUMULATIVE
C              DISTRIBUTION FUNCTION OF THE SLASH DISTRIBUTION.
C     INPUT  ARGUMENTS--P      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE PERCENT POINT
C                                FUNCTION IS TO BE EVALUATED.
C     OUTPUT ARGUMENTS--PPF    = THE SINGLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PERCENT POINT
C             FUNCTION VALUE PPF.
C     PRINTING--NONE.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--FZERO.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, 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     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 PPF
C
      REAL SLAFU2
      EXTERNAL SLAFU2
C
      REAL P2
      COMMON/SLACOM/P2
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C
      IF(P.LE.0.0.OR.P.GE.1.0)THEN
         WRITE(ICOUT,61)
   61    FORMAT('***** ERROR--THE FIRST  INPUT ARGUMENT ',
     1          'TO THE SLAPPF SUBROUTINE ')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,62)
   62    FORMAT('      IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL ***')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,63)P
   63    FORMAT('      VALUE OF ARGUMENT = ',G15.7)
         CALL DPWRST('XXX','BUG ')
         PPF=0.0
         GOTO9000
      ELSE
         XTEMP=675000.
         CALL SLACDF(-XTEMP,PLOW)
         CALL SLACDF(XTEMP,PUPP)
         IF(P.LT.PLOW .OR. P.GT.PUPP)THEN
           WRITE(ICOUT,71)
   71      FORMAT('***** ERROR--THE FIRST  INPUT ARGUMENT ',
     1            'TO THE SLAPPF SUBROUTINE ')
           CALL DPWRST('XXX','BUG ')
           WRITE(ICOUT,72)
   72      FORMAT('      IS OUTSIDE THE INTERVAL (',G15.7,',',G15.7,
     1            ') INTERVAL, UNABLE TO COMPUTE PPF')
           CALL DPWRST('XXX','BUG ')
           WRITE(ICOUT,63)P
           CALL DPWRST('XXX','BUG ')
           PPF=0.0
           GOTO9000
         ENDIF
      ENDIF
C
C  STEP 1: FIND BRACKETING INTERVAL.  START WITH FACT THAT SLASH
C          DISTRIBUTION IS SYMMETRIC ABOUT X = 0.
C
      IF(P.EQ.0.5)THEN
        PPF=0.0
        GOTO9000
      ELSEIF(P.GT.0.5)THEN
        XLOW=0.0
        IF(P.LE.0.95)THEN
          XUP=9.0
        ELSEIF(P.LT.0.995)THEN
          XUP=100.
        ELSEIF(P.LT.0.9995)THEN
          XUP=1000.
        ELSEIF(P.LT.0.99995)THEN
          XUP=10000.
        ELSE
          XUP=675000.
        ENDIF
      ELSE
        XUP=0.0
        IF(P.GT.0.05)THEN
          XLOW=-9.0
        ELSEIF(P.GT.0.005)THEN
          XLOW=-100.0
        ELSEIF(P.GT.0.0005)THEN
          XLOW=-1000.
        ELSEIF(P.GT.0.00005)THEN
          XLOW=-10000.
        ELSE
          XLOW=-675000.
        ENDIF
      ENDIF
C
      P2=P
      AE=1.E-6
      RE=1.E-6
      IFLAG=0
      CALL FZERO(SLAFU2,XLOW,XUP,XUP,RE,AE,IFLAG)
C
      PPF=XLOW
C
      IF(IFLAG.EQ.2)THEN
C
C  NOTE: SUPPRESS THIS MESSAGE FOR NOW.
CCCCC   WRITE(ICOUT,999)
  999   FORMAT(1X)
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   WRITE(ICOUT,111)
CC111   FORMAT('***** WARNING FROM SLAPPF--')
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   WRITE(ICOUT,113)
CC113   FORMAT('      PPF VALUE MAY NOT BE COMPUTED TO DESIRED ',
CCCCC1         'TOLERANCE.')
CCCCC   CALL DPWRST('XXX','BUG ')
      ELSEIF(IFLAG.EQ.3)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,121)
  121   FORMAT('***** WARNING FROM SLAPPF--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,123)
  123   FORMAT('      PPF VALUE MAY BE NEAR A SINGULAR POINT.')
        CALL DPWRST('XXX','BUG ')
      ELSEIF(IFLAG.EQ.4)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,131)
  131   FORMAT('***** ERROR FROM SLAPPF--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,133)
  133   FORMAT('      APPROPRIATE BRACKETING INTERVAL NOT FOUND.')
        CALL DPWRST('XXX','BUG ')
      ELSEIF(IFLAG.EQ.5)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,141)
  141   FORMAT('***** WARNING FROM SLAPPF--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,143)
  143   FORMAT('      MAXIMUM ITERATIONS EXCEEDED.')
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE SLARAN(N,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE THE SLASH DISTIBUTION WITH LOCATION = 0
C              AND SCALE = 1.  THIS DISTRIBUTION IS DEFINED FOR ALL
C              X AND HAS THE PROBABILITY DENSITY FUNCTION
C              F(X) = NORPDF(0) - NORPDF(X))/[X**2]     X <> 0
C                     0.5*NORPDF(0)                     X = 0
C              WHERE NORPDF IS THE PDF OF THE STANDARD NORMAL
C              DISTRIBUTION.  NOTE THAT THE SLASH DISTRIBUTION IS
C              THE RATIO OF AN INDEPENDENT STANDARD NORMAL AND
C              UNIFORM DISTRIBUTIONS.
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST N)
C                                INTO WHICH THE GENERATED
C                                RANDOM SAMPLE WILL BE PLACED.
C     OUTPUT--A RANDOM SAMPLE OF SIZE N FROM THE SLASH DISTRIBUTION
C             WITH LOCATION = 0 AND SCALE = 1.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--LOG, SQRT, SIN, COS.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     METHOD--TRANSFORM NORMAL RANDOM NUMBERS
C     REFERENCES--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     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2003.1
C     ORIGINAL VERSION--JANUARY   2003.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
      DIMENSION Y(1)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
C     GENERATE N NORMAL (0,1) RANDOM NUMBERS;
C
C
C     TRANSFORM THE NORMAL RANDOM NUMBERS
C
      NTEMP=1
      DO300I=1,N
        CALL NORRAN(NTEMP,ISEED,Y)
        TERM1=Y(1)
        CALL UNIRAN(NTEMP,ISEED,Y)
        TERM2=Y(1)
        IF(TERM2.EQ.0.0)THEN
          CALL UNIRAN(NTEMP,ISEED,Y)
          TERM2=Y(1)
        ENDIF
        X(I)=TERM1/TERM2
  300 CONTINUE
C
      RETURN
      END
      SUBROUTINE SLOCDF(X,ALPHA,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE SLOPE DISTRIBUTION.
C              THE CUMULATIVE DISTRIBUTION FUNCTION IS:
C
C                  F(X;ALPHA) = ALPHA*X + (1-ALPHA)*X**2
C                              0 <= X <= 1, 0 <= ALPHA <= 2
C
C              WITH ALPHA DENOTING THE SHAPE PARAMETER.
C
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C                     --ALPHA   = THE SINGLE PRECISION SHAPE PARAMETER
C     OUTPUT ARGUMENTS--CDF    = THE SINGLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE CDF.
C     PRINTING--NONE 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--KOTZ AND VAN DORP (2004), "BEYOND ALPHA: OTHER
C                 CONTINUOUS FAMILIES OF DISTRIBUTIONS WITH BOUNDED
C                 SUPPORT AND APPLICATIONS", WORLD SCIENTFIC
C                 PUBLISHING COMPANY, CHAPTER 8.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE:  301-975-2855
C     ORIGINAL VERSION--SEPTEMBER   2007.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(X.LT.0.0 .OR. X.GT.1.0)THEN
        WRITE(ICOUT,2)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9000
      ELSEIF(ALPHA.LT.0.0 .OR. ALPHA.GT.2.0)THEN
        WRITE(ICOUT,12)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ALPHA
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9000
      ENDIF
    2 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO SLOCDF IS ',
     1       'OUTSIDE THE (0,1) INTERVAL.')
   12 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO SLOCDF IS ',
     1       'OUTSIDE THE (0,2) INTERVAL.')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
C
C-----START POINT-----------------------------------------------------
C
      CDF=ALPHA*X + (1.0-ALPHA)*X**2
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE SLOPDF(X,ALPHA,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE SLOPE DISTRIBUTION.
C              THE PROBABILITY DENSITY FUNCTION IS:
C
C                  f(X;ALPHA) = ALPHA + 2*(1-ALPHA)*X
C                              0 <= X <= 1, 0 <= ALPHA <= 2
C
C              WITH ALPHA DENOTING THE SHAPE PARAMETER.
C
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                     --ALPHA   = THE SINGLE PRECISION SHAPE PARAMETER
C     OUTPUT ARGUMENTS--PDF    = THE SINGLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE PDF.
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--DLOG, DEXP.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN.
C     REFERENCES--KOTZ AND VAN DORP (2004), "BEYOND ALPHA: OTHER
C                 CONTINUOUS FAMILIES OF DISTRIBUTIONS WITH BOUNDED
C                 SUPPORT AND APPLICATIONS", WORLD SCIENTFIC
C                 PUBLISHING COMPANY, CHAPTER 8.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE:  301-975-2855
C     ORIGINAL VERSION--SEPTEMBER   2007.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(X.LT.0.0 .OR. X.GT.1.0)THEN
        WRITE(ICOUT,2)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9000
      ELSEIF(ALPHA.LT.0.0 .OR. ALPHA.GT.2.0)THEN
        WRITE(ICOUT,12)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ALPHA
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9000
      ENDIF
    2 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO SLOPDF IS ',
     1       'OUTSIDE THE (0,1) INTERVAL.')
   12 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO SLOPDF IS ',
     1       'OUTSIDE THE (0,2) INTERVAL.')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
C
C-----START POINT-----------------------------------------------------
C
      PDF=ALPHA + 2.0*(1.0-ALPHA)*X
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE SLOPPF(P,ALPHA,PPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE SLOPE DISTRIBUTION.
C              THE PERCENT POINT FUNCTION IS:
C
C              F(P;ALPHA) = P                ALPHA = 1
C                         = {-ALPHA +
C                           SQRT(ALPHA**2 + 4*P*(1-ALPHA))}/
C                           (2*(1-ALPHA))    ALPHA <> 1
C                           0 <= P <= 1, 0 <= ALPHA <= 2
C
C              WITH ALPHA DENOTING THE SHAPE PARAMETER.
C
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE PERCENT POINT
C                                FUNCTION IS TO BE EVALUATED.
C                     --ALPHA   = THE SINGLE PRECISION SHAPE PARAMETER
C     OUTPUT ARGUMENTS--PPF    = THE SINGLE PRECISION PERCENT POINT
C                                FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PERCENT POINT
C             FUNCTION VALUE PPF.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--P 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--KOTZ AND VAN DORP (2004), "BEYOND ALPHA: OTHER
C                 CONTINUOUS FAMILIES OF DISTRIBUTIONS WITH BOUNDED
C                 SUPPORT AND APPLICATIONS", WORLD SCIENTFIC
C                 PUBLISHING COMPANY, CHAPTER 8.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE:  301-975-2855
C     ORIGINAL VERSION--SEPTEMBER   2007.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(P.LT.0.0 .OR. P.GT.1.0)THEN
        WRITE(ICOUT,2)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)P
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
        GOTO9000
      ELSEIF(ALPHA.LT.0.0 .OR. ALPHA.GT.2.0)THEN
        WRITE(ICOUT,12)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ALPHA
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
        GOTO9000
      ENDIF
    2 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO SLOPPF IS ',
     1       'OUTSIDE THE (0,1) INTERVAL.')
   12 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO SLOPPF IS ',
     1       'OUTSIDE THE (0,2) INTERVAL.')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
C
C-----START POINT-----------------------------------------------------
C
      IF(ALPHA.EQ.1.0)THEN
        PPF=P
      ELSE
        TERM1=ALPHA**2 + 4.0*P*(1.0-ALPHA)
        TERM2=2.0*(1.0 - ALPHA)
        PPF=(-ALPHA + SQRT(TERM1))/TERM2
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE SLORAN(N,ALPHA,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE SLOPE DISTRIBUTION WITH
C              SHAPE PARAMETER ALPHA.
C
C              THE PROBABILITY DENSITY FUNCTION IS:
C
C                  f(X;ALPHA) = ALPHA + 2*(1-ALPHA)*X
C                              0 <= X <= 1, 0 <= ALPHA <= 2
C
C              WITH ALPHA DENOTING THE SHAPE PARAMETER.
C
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --ALPHA  = THE SINGLE PRECISION VALUE OF THE
C                                SHAPE PARAMETER ALPHA.
C                                ALPHA SHOULD BE IN THE RANGE (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 SLOPE DISTRIBUTION
C             WITH SHAPE PARAMETER 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     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN, SLOPPF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--KOTZ AND VAN DORP (2004), "BEYOND ALPHA: OTHER
C                 CONTINUOUS FAMILIES OF DISTRIBUTIONS WITH BOUNDED
C                 SUPPORT AND APPLICATIONS", WORLD SCIENTFIC
C                 PUBLISHING COMPANY, CHAPTER 8.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHMOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2007.9
C     ORIGINAL VERSION--SEPTEMBER 2007.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)THEN
        WRITE(ICOUT, 5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
    5 FORMAT('***** ERROR--THE REQUESTED NUMBER OF ',
     1'SLOPE RANDOM NUMBERS IS NON-POSITIVE')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8)
C
      IF(ALPHA.LT.0.0 .OR. ALPHA.GT.2.0)THEN
        WRITE(ICOUT,201)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,203)ALPHA
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9000
      ENDIF
  201 FORMAT('***** ERROR--THE ALPHA SHAPE PARAMETER IS ',
     1       'OUTSIDE THE (0,2) INTERVAL.')
  203 FORMAT('      THE VALUE OF ALPHA IS ',G15.7)
C
C     GENERATE N UNIFORM (0,1) RANDOM NUMBERS;
C
      CALL UNIRAN(N,ISEED,X)
C
C     GENERATE N SLOPE DISTRIBUTION RANDOM
C     NUMBERS USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD.
C
      DO300I=1,N
        CALL SLOPPF(X(I),ALPHA,XTEMP)
        X(I)=XTEMP
  300 CONTINUE
C
 9000 CONTINUE
      RETURN
      END
      function Sn(x,n,y,a2,scrtch)
C
cc#####################################################################
cc######################  file Sn.for :  ##############################
cc#####################################################################
cc
cc   This file contains a Fortran function for a new robust estimator
cc   of scale denoted as Sn, proposed in Rousseeuw and Croux (1993).
cc   The estimator has a high breakdown point and a bounded influence
cc   function. The algorithm given here is very fast (running in
cc   O(nlogn) time) and needs only O(n) storage space.
cc
cc   Rousseeuw, P.J. and Croux, C. (1993), "Alternatives to the
cc      Median Absolute Deviation," Journal of the American
cc      Statistical Association, Vol. 88, 1273-1283.
cc
cc   A Fortran function for the estimator Qn, described in the same
cc   paper, is attached below. For both estimators, implementations
cc   in the Pascal language can be obtained from the authors.
cc
cc   This software may be used and copied freely, provided
cc   reference is made to the abovementioned paper.
cc
cc   For questions, problems or comments contact:
cc
cc              Peter Rousseeuw (rousse@wins.uia.ac.be)
cc              Christophe Croux (croux@wins.uia.ac.be)
cc              Department of Mathematics and Computing
cc              Universitaire Instelling Antwerpen
cc              Universiteitsplein 1
cc              B-2610 Wilrijk (Antwerp)
cc              Belgium
cc
cc--------------------------------------------------------------------
cc
cc   Efficient algorithm for the scale estimator:
cc
cc       Sn = cn * 1.1926 * LOMED_{i} HIMED_{i} |x_i-x_j|
cc
cc   which can equivalently be written as
cc
cc       Sn = cn * 1.1926 * LOMED_{i} LOMED_{j<>i} |x_i-x_j|
cc
cc   Parameters of the function Sn :
cc       x  : real array containing the observations
cc       n  : number of observations (n>=2)
cc
cc   The function Sn uses the procedures:
cc       sort(x,n,y) : sorts an array x of length n, and stores the
cc                     result in an array y (of size at least n)
cc       pull(a,n,k) : finds the k-th order statistic of an
cc                     array a of length n
cc
cc   The function Sn also creates an auxiliary array a2
cc       (of size at least n) in which it stores the values
cc       LOMED_{j<>i} |x_i-x_j|   for i=1,...,n
cc
ccccc dimension x(n),y(1000),a2(1000)
      dimension x(*),y(*),a2(*),scrtch(*)
      integer rightA,rightB,tryA,tryB,diff,Amin,Amax,even,half
      real medA, medB
      call sort(x,n,y)
      a2(1)=y(n/2+1)-y(1)
      do 10 i=2,(n+1)/2
          nA=i-1
          nB=n-i
          diff=nB-nA
          leftA=1
          leftB=1
          rightA=nB
          rightB=nB
          Amin=diff/2+1
          Amax=diff/2+nA
15        continue
          if (leftA.lt.rightA) then
              length=rightA-leftA+1
              even=1-mod(length,2)
              half=(length-1)/2
              tryA=leftA+half
              tryB=leftB+half
              if (tryA.lt.Amin) then
                  rightB=tryB
                  leftA=tryA+even
              else
                  if (tryA.gt.Amax) then
                      rightA=tryA
                      leftB=tryB+even
                  else
                      medA=y(i)-y(i-tryA+Amin-1)
                      medB=y(tryB+i)-y(i)
                      if (medA.ge.medB) then
                          rightA=tryA
                          leftB=tryB+even
                      else
                          rightB=tryB
                          leftA=tryA+even
                      endif
                  endif
              endif
          go to 15
          endif
          if (leftA.gt.Amax) then
              a2(i)=y(leftB+i)-y(i)
          else
              medA=y(i)-y(i-leftA+Amin-1)
              medB=y(leftB+i)-y(i)
              a2(i)=min(medA,medB)
          endif
10    continue
      do 20 i=(n+1)/2+1,n-1
          nA=n-i
          nB=i-1
          diff=nB-nA
          leftA=1
          leftB=1
          rightA=nB
          rightB=nB
          Amin=diff/2+1
          Amax=diff/2+nA
25        continue
          if (leftA.lt.rightA) then
              length=rightA-leftA+1
              even=1-mod(length,2)
              half=(length-1)/2
              tryA=leftA+half
              tryB=leftB+half
              if (tryA.lt.Amin) then
                  rightB=tryB
                  leftA=tryA+even
              else
                  if (tryA.gt.Amax) then
                      rightA=tryA
                      leftB=tryB+even
                  else
                      medA=y(i+tryA-Amin+1)-y(i)
                      medB=y(i)-y(i-tryB)
                      if (medA.ge.medB) then
                          rightA=tryA
                          leftB=tryB+even
                      else
                          rightB=tryB
                          leftA=tryA+even
                      endif
                  endif
              endif
          go to 25
          endif
          if (leftA.gt.Amax) then
              a2(i)=y(i)-y(i-leftB)
          else
              medA=y(i+leftA-Amin+1)-y(i)
              medB=y(i)-y(i-leftB)
              a2(i)=min(medA,medB)
          endif
20    continue
      a2(n)=y(n)-y((n+1)/2)
      cn=1
      if (n.le.9) then
          if (n.eq.2) cn=0.743
          if (n.eq.3) cn=1.851
          if (n.eq.4) cn=0.954
          if (n.eq.5) cn=1.351
          if (n.eq.6) cn=0.993
          if (n.eq.7) cn=1.198
          if (n.eq.8) cn=1.005
          if (n.eq.9) cn=1.131
      else
          if (mod(n,2).eq.1) cn=n/(n-0.9)
      endif
      Sn=cn*1.1926*pull(a2,n,(n+1)/2,scrtch)
      return
      end
      SUBROUTINE SNCDF(X,ALMBDA,ISKNDF,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE SKEW-NORMAL DISTRIBUTION
C              WITH SHAPE PARAMETER = LAMBDA.
C              THIS DISTRIBUTION IS DEFINED FOR ALL X AND
C              THE CUMULATIVE DISTRIBUTION IS COMPUTED BY
C              NUMERICALLY INTEGRATING THE PDF FUNCTION.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C                     --ALMBDA = THE SHAPE PARAMETER
C     OUTPUT ARGUMENTS--CDF    = THE SINGLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE CDF FOR THE SKEWED-NORMAL DISTRIBUTION
C             WITH SHAPE PARAMETER = LAMBDA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--DQAGI.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME I", SECOND EDITION,
C                 JOHN WILEY, 1994, PAGE 454.
C               --"Log-Skew-Normal and Log-Skew-t Distributions as
C                 Models for Family Income Data", Azzalini, Cappello,
C                 and Kotz, paper downloaded from Azzalini's web
C                 site.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2003.11
C     ORIGINAL VERSION--NOVEMBER  2003.
C     UPDATED         --JULY      2005. SUPPORT FOR RE-PARAMETERIZED
C                                       DEFINITION THAT IS USEFUL FOR
C                                       FITTING
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      CHARACTER*4 ISKNDF
C
      INTEGER LIMIT
      INTEGER LENW
      PARAMETER(LIMIT=100)
      PARAMETER(LENW=4*LIMIT)
      INTEGER INF
      INTEGER NEVAL
      INTEGER IER
      INTEGER LAST
      INTEGER IWORK(LIMIT)
      REAL X
      REAL CDF
      DOUBLE PRECISION EPSABS
      DOUBLE PRECISION EPSREL
      DOUBLE PRECISION DCDF
      DOUBLE PRECISION DX
      DOUBLE PRECISION ABSERR
      DOUBLE PRECISION WORK(LENW)
C
      DOUBLE PRECISION SNFUN
      EXTERNAL SNFUN
C
      DOUBLE PRECISION DLMBDA
      COMMON/SNCOM/DLMBDA
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C               ************************************
C               **  STEP 1--                      **
C               **  COMPUTE THE DENSITY FUNCTION  **
C               ************************************
C
      IF(ISKNDF.EQ.'DEFA')THEN
        INF=-1
        EPSABS=0.0D0
        EPSREL=1.0D-7
        IER=0
        CDF=0.0D0
C
        DX=DBLE(X)
        DLMBDA=DBLE(ALMBDA)
C
        CALL DQAGI(SNFUN,DX,INF,EPSABS,EPSREL,DCDF,ABSERR,NEVAL,
     1             IER,LIMIT,LENW,LAST,IWORK,WORK)
C
        CDF=REAL(DCDF)
C
        IF(IER.EQ.1)THEN
          WRITE(ICOUT,999)
  999     FORMAT(1X)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,111)
  111     FORMAT('***** ERROR FROM SNCDF--')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,113)
  113     FORMAT('      MAXIMUM NUMBER OF SUBDIVISIONS EXCEEDED.')
          CALL DPWRST('XXX','BUG ')
        ELSEIF(IER.EQ.2)THEN
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,121)
  121     FORMAT('***** ERROR FROM SNCDF--')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,123)
  123     FORMAT('      ROUNDOFF ERROR PREVENTS REQUESTED TOLERANCE ',
     1           'FROM BEING ACHIEVED.')
          CALL DPWRST('XXX','BUG ')
        ELSEIF(IER.EQ.3)THEN
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,131)
  131     FORMAT('***** ERROR FROM SNCDF--')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,133)
  133     FORMAT('      BAD INTEGRAND BEHAVIOUR DETECTED.')
          CALL DPWRST('XXX','BUG ')
        ELSEIF(IER.EQ.4)THEN
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,141)
  141     FORMAT('***** ERROR FROM SNCDF--')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,143)
  143     FORMAT('      INTEGRATION DID NOT CONVERGE.')
          CALL DPWRST('XXX','BUG ')
        ELSEIF(IER.EQ.5)THEN
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,151)
  151     FORMAT('***** ERROR FROM SNCDF--')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,153)
  153     FORMAT('      THE INTEGRATION IS PROBABLY DIVERGENT.')
          CALL DPWRST('XXX','BUG ')
        ELSEIF(IER.EQ.6)THEN
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,161)
  161     FORMAT('***** ERROR FROM SNCDF--')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,163)
  163     FORMAT('      INVALID INPUT TO THE INTEGRATION ROUTINE.')
          CALL DPWRST('XXX','BUG ')
        ENDIF
C
      ENDIF
C
      RETURN
      END
      DOUBLE PRECISION FUNCTION SNFUN(DX)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE SKEW-NORMAL DISTRIBUTION
C              WITH SHAPE PARAMETER = LAMBDA.
C              THIS DISTRIBUTION IS DEFINED FOR ALL X AND HAS
C              THE PROBABILITY DENSITY FUNCTION.  IDENTICAL TO SLAPDF,
C              BUT DEFINE AS FUNCTION TO BE USED FOR INTEGRATION
C              CODE CALLED BY SLACDF.  ALSO, THIS ROUTINE USES
C              DOUBLE PRECISION ARITHMETIC.
C                 SNPDF(X,LAMBDA) = 2*NORCDF(LAMDDA*X)*NORPDF(X)
C     INPUT  ARGUMENTS--DX     = THE DOUBLE PRECISION VALUE AT
C                                WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C     OUTPUT ARGUMENTS--SNFUN  = THE DOUBLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE PDF FOR THE SKEWED-NORMAL DISTRIBUTION
C             WITH SHAPE PARAMETER = LAMBDA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NODPDF, NODCDF..
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME I", SECOND EDITION,
C                 JOHN WILEY, 1994, PAGE 454.
C               --AZZALINI HAS AUTHORED A NUMBER OF PAPERS ON THIS
C                 DISTRIBUTION.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2003.12
C     ORIGINAL VERSION--DECEMBER  2003.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DPDF
C
      DOUBLE PRECISION DLMBDA
      COMMON/SNCOM/DLMBDA
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C               ************************************
C               **  STEP 1--                      **
C               **  COMPUTE THE DENSITY FUNCTION  **
C               ************************************
C
      CALL NODCDF(DX*DLMBDA,DTERM1)
      CALL NODPDF(DX,DTERM2)
      DPDF=2.0D0*DTERM1*DTERM2
      SNFUN=DPDF
C
      RETURN
      END
      REAL FUNCTION SNFU2(X)
C
C     PURPOSE--SNPPF CALLS FZERO TO FIND A ROOT FOR THE PERCENT
C              POINT FUNCTION.  SNFU2 IS THE FUNCTION FOR WHICH
C              THE ZERO IS FOUND.  IT IS:
C                 P - SNCDF(X,LAMBDA)
C              WHERE P IS THE DESIRED PERCENT POINT.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C     OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE SNFU2.
C     PRINTING--NONE.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--SNCDF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME I", SECOND EDITION,
C                 JOHN WILEY, 1994, PAGE 454.
C               --AZZALINI HAS AUTHORED A NUMBER OF PAPERS ON THIS
C                 DISTRIBUTION.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2003.12
C     ORIGINAL VERSION--DECEMBER  2003.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      REAL P
      CHARACTER*4 ISKNDF
      COMMON/SN2COM/P,ISKNDF
C
      DOUBLE PRECISION DLMBDA
      COMMON/SNCOM/DLMBDA
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      CALL SNCDF(X,REAL(DLMBDA),ISKNDF,CDF)
      SNFU2=P - CDF
C
      RETURN
      END
      SUBROUTINE SNPDF(X,ALMBDA,ISKNDF,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE SKEW-NORMAL DISTRIBUTION
C              WITH SHAPE PARAMETER = LAMBDA.
C              THIS DISTRIBUTION IS DEFINED FOR ALL X AND HAS
C              THE PROBABILITY DENSITY FUNCTION
C                 SNPDF(X,LAMBDA) = 2*NORCDF(LAMDDA*X)*NORPDF(X)
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE NON-NEGATIVE.
C                     --ALMBDA = THE 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 SKEWED-NORMAL DISTRIBUTION
C             WITH SHAPE PARAMETER = LAMBDA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NODPDF, NODCDF..
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME I", SECOND EDITION,
C                 JOHN WILEY, 1994, PAGE 454.
C               --"Log-Skew-Normal and Log-Skew-t Distributions as
C                 Models for Family Income Data", Azzalini, Cappello,
C                 and Kotz, paper downloaded from Azzalini's web
C                 site.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2003.11
C     ORIGINAL VERSION--NOVEMBER  2003.
C     UPDATED         --JULY      2005. SUPPORT FOR RE-PARAMETERIZED
C                                       DEFINITION THAT IS USEFUL FOR
C                                       FITTING
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      CHARACTER*4 ISKNDF
C
      DOUBLE PRECISION DX,DLMBDA
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DPDF
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C               ************************************
C               **  STEP 1--                      **
C               **  COMPUTE THE DENSITY FUNCTION  **
C               ************************************
C
      DX=DBLE(X)
      DLMBDA=DBLE(ALMBDA)
      IF(ISKNDF.EQ.'DEFA')THEN
        CALL NODCDF(DX*DLMBDA,DTERM1)
        CALL NODPDF(DX,DTERM2)
        DPDF=2.0D0*DTERM1*DTERM2
        PDF=REAL(DPDF)
        GOTO9000
      ELSE
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE SNPPF(P,ALMBDA,ISKNDF,PPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE SKEW-NORMAL DISTRIBUTION
C              WITH SHAPE PARAMETER = LAMBDA.
C              THIS DISTRIBUTION IS DEFINED FOR ALL X AND THE
C              PERCENT POINT FUNCTION IS COMPUTED BY
C              NUMERICALLY INVERTING THE CDF FUNCTION.
C     INPUT  ARGUMENTS--P      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE PERCENT POINT
C                                FUNCTION IS TO BE EVALUATED.
C                     --ALMBDA = THE SHAPE PARAMETER
C     OUTPUT ARGUMENTS--PPF    = THE SINGLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PERCENT POINT
C             FUNCTION VALUE PPF.
C     PRINTING--NONE.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--FZERO.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME I", SECOND EDITION,
C                 JOHN WILEY, 1994, PAGE 454.
C               --"Log-Skew-Normal and Log-Skew-t Distributions as
C                 Models for Family Income Data", Azzalini, Cappello,
C                 and Kotz, paper downloaded from Azzalini's web
C                 site.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2003.12
C     ORIGINAL VERSION--DECEMBER  2003.
C     UPDATED         --JULY      2005. SUPPORT FOR RE-PARAMETERIZED
C                                       DEFINITION THAT IS USEFUL FOR
C                                       FITTING
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      CHARACTER*4 ISKNDF
C
      REAL PPF
C
      REAL SNFU2
      EXTERNAL SNFU2
C
      REAL P2
      CHARACTER*4 ISNDF2
      COMMON/SN2COM/P2,ISNDF2
C
      DOUBLE PRECISION DLMBDA
      COMMON/SNCOM/DLMBDA
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C
      IF(P.LE.0.0.OR.P.GE.1.0)THEN
         WRITE(ICOUT,61)
   61    FORMAT('***** ERROR--THE FIRST  INPUT ARGUMENT ',
     1          'TO THE SNPPF SUBROUTINE ')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,62)
   62    FORMAT('      IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL ***')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,63)P
   63    FORMAT('      VALUE OF ARGUMENT = ',G15.7)
         CALL DPWRST('XXX','BUG ')
         PPF=0.0
         GOTO9000
      ENDIF
C
C  STEP 1: FIND BRACKETING INTERVAL.  START WITH FACT THAT LAMBDA = 0
C          IS THE NORMAL DISTRIBUTION AND THE HALF-NORMAL IS THE
C          LIMITING DISTRIBUTION AS LAMBDA GOES TO INFINITY.
C
      IF(ALMBDA.EQ.0.0)THEN
        CALL NORPPF(P,PPF)
        GOTO9000
      ELSE
        IFLAG2=0
        IF(ALMBDA.LT.0.0)IFLAG2=1
        P2=P
        IF(IFLAG2.EQ.1)P2=1.0 - P
        CALL NORPPF(P2,XLOW)
        CALL HFNPPF(P2,XUP)
      ENDIF
      XLOW=XLOW - 0.2
      XUP=XUP + 0.2
C
      ISNDF2=ISKNDF
      AE=1.E-6
      RE=1.E-6
      DLMBDA=DBLE(ALMBDA)
      IF(IFLAG2.EQ.1)DLMBDA=-DLMBDA
      IFLAG=0
      CALL FZERO(SNFU2,XLOW,XUP,XUP,RE,AE,IFLAG)
C
      PPF=XLOW
      IF(IFLAG2.EQ.1)PPF=-PPF
C
      IF(IFLAG.EQ.2)THEN
C
C  NOTE: SUPPRESS THIS MESSAGE FOR NOW.
CCCCC   WRITE(ICOUT,999)
  999   FORMAT(1X)
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   WRITE(ICOUT,111)
CC111   FORMAT('***** WARNING FROM SNPPF--')
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   WRITE(ICOUT,113)
CC113   FORMAT('      PPF VALUE MAY NOT BE COMPUTED TO DESIRED ',
CCCCC1         'TOLERANCE.')
CCCCC   CALL DPWRST('XXX','BUG ')
      ELSEIF(IFLAG.EQ.3)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,121)
  121   FORMAT('***** WARNING FROM SNPPF--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,123)
  123   FORMAT('      PPF VALUE MAY BE NEAR A SINGULAR POINT.')
        CALL DPWRST('XXX','BUG ')
      ELSEIF(IFLAG.EQ.4)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,131)
  131   FORMAT('***** ERROR FROM SNPPF--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,133)
  133   FORMAT('      APPROPRIATE BRACKETING INTERVAL NOT FOUND.')
        CALL DPWRST('XXX','BUG ')
      ELSEIF(IFLAG.EQ.5)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,141)
  141   FORMAT('***** WARNING FROM SNPPF--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,143)
  143   FORMAT('      MAXIMUM ITERATIONS EXCEEDED.')
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE SNRAN(N,ALMBDA,ISKNDF,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE SKEWED NORMAL DISTRIBUTION
C              WITH SHAPE PARAMETER = ALMBDA.
C              THIS DISTRIBUTION IS DEFINED FOR ALL X AND HAS
C              THE PROBABILITY DENSITY FUNCTION
C                 SNPDF(X,LAMBDA) = 2*NORCDF(LAMDDA*X)*NORPDF(X)
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --ALMBDA = THE SHAPE (PARAMETER) FOR THE
C                                SKEWED NORMAL DISTRIBUTION.
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST N)
C                                INTO WHICH THE GENERATED
C                                RANDOM SAMPLE WILL BE PLACED.
C     OUTPUT--A RANDOM SAMPLE OF SIZE N
C             FROM THE SKEWED NORMAL DISTRIBUTION
C             WITH SHAPE PARAMETER = ALMBDA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C                 --ALMBDA CAN BE ANY REAL NUMBER.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NORRAN.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME I", SECOND EDITION,
C                 JOHN WILEY, 1994, PAGE 454.
C               --"Log-Skew-Normal and Log-Skew-t Distributions as
C                 Models for Family Income Data", Azzalini, Cappello,
C                 and Kotz, paper downloaded from Azzalini's web
C                 site.
C               --ALGORITHM FOR RANDOM NUMBERS ADAPTED FROM
C                 AZZALINI'S R FUNCTIONS FOR SKEW NORMAL.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2003.11
C     ORIGINAL VERSION--NOVEMBER  2003.
C     UPDATED         --JULY      2005. SUPPORT FOR RE-PARAMETERIZED
C                                       DEFINITION THAT IS USEFUL FOR
C                                       FITTING
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
      DIMENSION Y(2)
C
      CHARACTER*4 ISKNDF
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)THEN
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,6)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
    5 FORMAT('***** FATAL ERROR--FOR THE SKEWED NORMAL DISTRIBUTION,')
    6 FORMAT('       THE REQUESTED NUMBER OF RANDOM NUMBERS WAS ',
     1      'NON-POSITIVE.')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
C
C     ALGORITHM ADAPTED FROM AZZALINI'S R FUNCTION LIBRARY.
C
      IF(ISKNDF.EQ.'DEFA')THEN
        DO100I=1,N
          CALL NORRAN(2,ISEED,Y)
          U1=Y(1)
          U2=Y(2)
          ATEMP=ALMBDA*U1
          IF(U2.GT.ATEMP)U1=-U1
          X(I)=U1
  100   CONTINUE
      ELSE
      ENDIF
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE STCDF(X,NU,ALMBDA,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE SKEW-T DISTRIBUTION
C              WITH SHAPE PARAMETERS NU AND LAMBDA.
C              THIS DISTRIBUTION IS DEFINED FOR ALL X AND HAS
C              THE PROBABILITY DENSITY FUNCTION
C                 STPDF(X,NU,LAMBDA) = 2*
C                       TCDF(LAMBDA*X*SQRT((NU+1)/(X**2+NU)),NU+1)*
C                       TPDF(X,NU)
C              THE CUMULATIVE DISTRIBUTION IS COMPUTED BY
C              NUMERICALLY INTEGRATING THE PDF FUNCTION.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C                     --NU     = THE DEGREES OF FREEDOM PARAMETER
C                     --ALMBDA = THE SKEWNESS PARAMETER
C     OUTPUT ARGUMENTS--CDF    = THE SINGLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE CDF FOR THE SKEW-T DISTRIBUTION
C             WITH SHAPE PARAMETERS NU AND LAMBDA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--DQAGI.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME I", SECOND EDITION,
C                 JOHN WILEY, 1994, PAGE 454.
C               --"Log-Skew-Normal and Log-Skew-t Distributions as
C                 Models for Family Income Data", Azzalini, Cappello,
C                 and Kotz, paper downloaded from Azzalini's web
C                 site.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2003.12
C     ORIGINAL VERSION--DECEMBER  2003.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      INTEGER LIMIT
      INTEGER LENW
      PARAMETER(LIMIT=100)
      PARAMETER(LENW=4*LIMIT)
      INTEGER INF
      INTEGER NEVAL
      INTEGER IER
      INTEGER LAST
      INTEGER IWORK(LIMIT)
      INTEGER NU
      REAL X
      REAL CDF
      DOUBLE PRECISION EPSABS
      DOUBLE PRECISION EPSREL
      DOUBLE PRECISION DCDF
      DOUBLE PRECISION DX
      DOUBLE PRECISION ABSERR
      DOUBLE PRECISION WORK(LENW)
C
      DOUBLE PRECISION STFUN
      EXTERNAL STFUN
C
      DOUBLE PRECISION DNU
      DOUBLE PRECISION DLMBDA
      COMMON/STCOM/DNU,DLMBDA
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      IF(NU.LE.0)THEN
        WRITE(ICOUT,115)
  115   FORMAT('***** ERROR--THE DEGREES OF FREEDOM SHAPE ',
     1        'PARAMETER FOR THE')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,116)
  116   FORMAT('     SKEWED-T DISTRIBUTION IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,147)NU
  147   FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,'.')
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9000
      ENDIF
C
C               ************************************
C               **  STEP 1--                      **
C               **  COMPUTE THE DENSITY FUNCTION  **
C               ************************************
C
      INF=-1
      EPSABS=0.0D0
      EPSREL=1.0D-7
      IER=0
      CDF=0.0D0
C
      DX=DBLE(X)
      DLMBDA=DBLE(ALMBDA)
      DNU=DBLE(NU)
C
      CALL DQAGI(STFUN,DX,INF,EPSABS,EPSREL,DCDF,ABSERR,NEVAL,
     1          IER,LIMIT,LENW,LAST,IWORK,WORK)
C
      CDF=REAL(DCDF)
C
      IF(IER.EQ.1)THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,111)
  111   FORMAT('***** ERROR FROM STCDF--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,113)
  113   FORMAT('      MAXIMUM NUMBER OF SUBDIVISIONS EXCEEDED.')
        CALL DPWRST('XXX','BUG ')
      ELSEIF(IER.EQ.2)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,121)
  121   FORMAT('***** ERROR FROM STCDF--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,123)
  123   FORMAT('      ROUNDOFF ERROR PREVENTS REQUESTED TOLERANCE ',
     1         'FROM BEING ACHIEVED.')
        CALL DPWRST('XXX','BUG ')
      ELSEIF(IER.EQ.3)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,131)
  131   FORMAT('***** ERROR FROM STCDF--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,133)
  133   FORMAT('      BAD INTEGRAND BEHAVIOUR DETECTED.')
        CALL DPWRST('XXX','BUG ')
      ELSEIF(IER.EQ.4)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,141)
  141   FORMAT('***** ERROR FROM STCDF--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,143)
  143   FORMAT('      INTEGRATION DID NOT CONVERGE.')
        CALL DPWRST('XXX','BUG ')
      ELSEIF(IER.EQ.5)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,151)
  151   FORMAT('***** ERROR FROM STCDF--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,153)
  153   FORMAT('      THE INTEGRATION IS PROBABLY DIVERGENT.')
        CALL DPWRST('XXX','BUG ')
      ELSEIF(IER.EQ.6)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,161)
  161   FORMAT('***** ERROR FROM STCDF--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,163)
  163   FORMAT('      INVALID INPUT TO THE INTEGRATION ROUTINE.')
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      DOUBLE PRECISION FUNCTION STFUN(DX)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE SKEW-T DISTRIBUTION
C              WITH SHAPE PARAMETERS NU AND LAMBDA.
C              THIS DISTRIBUTION IS DEFINED FOR ALL X AND HAS
C              THE PROBABILITY DENSITY FUNCTION
C                 STPDF(X,NU,LAMBDA) = 2*
C                       TCDF(LAMBDA*X*SQRT((NU+1)/(X**2+NU)),NU+1)*
C                       TPDF(X,NU)
C              IDENTICAL TO TNPDF,
C              BUT DEFINE AS FUNCTION TO BE USED FOR INTEGRATION
C              CODE CALLED BY TNCDF.  ALSO, THIS ROUTINE USES
C              DOUBLE PRECISION ARITHMETIC.
C     INPUT  ARGUMENTS--DX     = THE DOUBLE PRECISION VALUE AT
C                                WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C     OUTPUT ARGUMENTS--STFUN  = THE DOUBLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE PDF FOR THE SKEW-T DISTRIBUTION
C             WITH SHAPE PARAMETERS NU AND LAMBDA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NODPDF, NODCDF..
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME I", SECOND EDITION,
C                 JOHN WILEY, 1994, PAGE 454.
C               --AZZALINI HAS AUTHORED A NUMBER OF PAPERS ON THIS
C                 DISTRIBUTION.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2003.12
C     ORIGINAL VERSION--DECEMBER  2003.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DZ
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DNU2
C
      DOUBLE PRECISION DNU
      DOUBLE PRECISION DLMBDA
      COMMON/STCOM/DNU,DLMBDA
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C               ************************************
C               **  STEP 1--                      **
C               **  COMPUTE THE DENSITY FUNCTION  **
C               ************************************
C
      NU=INT(DNU+0.5)
      DZ=DLMBDA*DX*DSQRT((DNU+1.0D0)/(DX**2+DNU))
      DNU2=DBLE(NU+1)
      CALL TDCDF(DZ,DNU2,DTERM1)
      CALL TDPDF(DX,NU,DTERM2)
      STFUN=2.0D0*DTERM1*DTERM2
C
      RETURN
      END
      REAL FUNCTION STFU2(X)
C
C     PURPOSE--STPPF CALLS FZERO TO FIND A ROOT FOR THE PERCENT
C              POINT FUNCTION.  STFU2 IS THE FUNCTION FOR WHICH
C              THE ZERO IS FOUND.  IT IS:
C                 P - STCDF(X,LAMBDA)
C              WHERE P IS THE DESIRED PERCENT POINT.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C     OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE STFU2.
C     PRINTING--NONE.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--STCDF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME I", SECOND EDITION,
C                 JOHN WILEY, 1994, PAGE 454.
C               --AZZALINI HAS AUTHORED A NUMBER OF PAPERS ON THIS
C                 DISTRIBUTION.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2003.12
C     ORIGINAL VERSION--DECEMBER  2003.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      REAL P
      COMMON/ST2COM/P
C
      DOUBLE PRECISION DNU
      DOUBLE PRECISION DLMBDA
      COMMON/STCOM/DNU,DLMBDA
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      NU=INT(DNU+0.01D0)
      CALL STCDF(X,NU,REAL(DLMBDA),CDF)
      STFU2=P - CDF
C
      RETURN
      END
      SUBROUTINE STPDF(X,NU,ALMBDA,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE SKEW-T DISTRIBUTION
C              WITH SHAPE PARAMETERS NU AND LAMBDA.
C              THIS DISTRIBUTION IS DEFINED FOR ALL X AND HAS
C              THE PROBABILITY DENSITY FUNCTION
C                 STPDF(X,NU,LAMBDA) = 2*
C                       TCDF(LAMBDA*X*SQRT((NU+1)/(X**2+NU)),NU+1)*
C                       TPDF(X,NU)
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE NON-NEGATIVE.
C                     --NU     = THE FIRST SHAPE PARAMETER
C                     --ALMBDA = THE SECOND SHAPE PARAMETER
C     OUTPUT ARGUMENTS--PDF    = THE SINGLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE PDF FOR THE SKEWED-T DISTRIBUTION
C             WITH SHAPE PARAMETERS NU AND LAMBDA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--TPDF, TCDF
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--"Log-Skew-Normal and Log-Skew-t Distributions as
C                 Models for Family Income Data", Azzalini, Cappello,
C                 and Kotz, paper downloaded from Azzalini's web
C                 site.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2003.11
C     ORIGINAL VERSION--NOVEMBER  2003.
C     UPDATED         --OCTOBER   2006. CALL LIST TO TCDF/TPDF
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      IF(NU.LE.0)THEN
        WRITE(ICOUT,115)
  115   FORMAT('***** ERROR--THE DEGREES OF FREEDOM SHAPE ',
     1        'PARAMETER FOR THE')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,116)
  116   FORMAT('     SKEWED-T DISTRIBUTION IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,147)NU
  147   FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,'.')
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9000
      ENDIF
C
C               ************************************
C               **  STEP 1--                      **
C               **  COMPUTE THE DENSITY FUNCTION  **
C               ************************************
C
      ANU=REAL(NU)
      Z=ALMBDA*X*SQRT((ANU+1.0)/(X**2+ANU))
      CALL TCDF(Z,REAL(NU+1),TERM1)
      CALL TPDF(X,REAL(NU),TERM2)
      PDF=2.0D0*TERM1*TERM2
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE STPPF(P,NU,ALMBDA,PPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE SKEW-NORMAL DISTRIBUTION
C              WITH SHAPE PARAMETER = LAMBDA.
C              THIS DISTRIBUTION IS DEFINED FOR ALL X AND THE
C              PERCENT POINT FUNCTION IS COMPUTED BY
C              NUMERICALLY INVERTING THE CDF FUNCTION.
C     INPUT  ARGUMENTS--P      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE PERCENT POINT
C                                FUNCTION IS TO BE EVALUATED.
C                     --NU     = THE DEGREES OF FREEDOM PARAMETER
C                     --ALMBDA = THE SKEWNESS PARAMETER
C     OUTPUT ARGUMENTS--PPF    = THE SINGLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PERCENT POINT
C             FUNCTION VALUE PPF.
C     PRINTING--NONE.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--FZERO.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME I", SECOND EDITION,
C                 JOHN WILEY, 1994, PAGE 454.
C               --"Log-Skew-Normal and Log-Skew-t Distributions as
C                 Models for Family Income Data", Azzalini, Cappello,
C                 and Kotz, paper downloaded from Azzalini's web
C                 site.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2003.12
C     ORIGINAL VERSION--DECEMBER  2003.
C     UPDATED         --OCTOBER   2006. CALL LIST TO TPPF
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      REAL PPF
C
      REAL STFU2
      EXTERNAL STFU2
C
      REAL P2
      COMMON/ST2COM/P2
C
      DOUBLE PRECISION DNU
      DOUBLE PRECISION DLMBDA
      COMMON/STCOM/DNU,DLMBDA
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      PPF=0.0
      IF(NU.LE.0)THEN
        WRITE(ICOUT,115)
  115   FORMAT('***** ERROR--THE DEGREES OF FREEDOM SHAPE ',
     1        'PARAMETER FOR THE')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,116)
  116   FORMAT('     SKEWED-T DISTRIBUTION IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,147)NU
  147   FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,'.')
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(P.LE.0.0.OR.P.GE.1.0)THEN
         WRITE(ICOUT,61)
   61    FORMAT('***** ERROR--THE FIRST  ARGUMENT TO STPPF')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,62)
   62    FORMAT('      IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL.')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,63)P
   63    FORMAT('      VALUE OF ARGUMENT = ',G15.7)
         CALL DPWRST('XXX','BUG ')
         GOTO9000
      ENDIF
C
C  STEP 1: FIND BRACKETING INTERVAL.  START WITH FACT THAT LAMBDA = 0
C          IS THE T DISTRIBUTION AND THE FOLDED-T IS THE
C          LIMITING DISTRIBUTION AS LAMBDA GOES TO INFINITY.
C
      IF(ALMBDA.EQ.0.0)THEN
        CALL TPPF(P,REAL(NU),PPF)
        GOTO9000
      ELSE
        IFLAG2=0
        IF(ALMBDA.LT.0.0)IFLAG2=1
        P2=P
        IF(IFLAG2.EQ.1)P2=1.0 - P
        CALL TPPF(P2,REAL(NU),XLOW)
        CALL FTPPF(P2,NU,XUP)
      ENDIF
      XLOW=XLOW - 0.2
      XUP=XUP + 0.2
C
      AE=1.E-6
      RE=1.E-6
      DLMBDA=DBLE(ALMBDA)
      DNU=DBLE(NU)
      IF(IFLAG2.EQ.1)DLMBDA=-DLMBDA
      IFLAG=0
      CALL FZERO(STFU2,XLOW,XUP,XUP,RE,AE,IFLAG)
C
      PPF=XLOW
      IF(IFLAG2.EQ.1)PPF=-PPF
C
      IF(IFLAG.EQ.2)THEN
C
C  NOTE: SUPPRESS THIS MESSAGE FOR NOW.
CCCCC   WRITE(ICOUT,999)
  999   FORMAT(1X)
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   WRITE(ICOUT,111)
CC111   FORMAT('***** WARNING FROM STPPF--')
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   WRITE(ICOUT,113)
CC113   FORMAT('      PPF VALUE MAY NOT BE COMPUTED TO DESIRED ',
CCCCC1         'TOLERANCE.')
CCCCC   CALL DPWRST('XXX','BUG ')
      ELSEIF(IFLAG.EQ.3)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,121)
  121   FORMAT('***** WARNING FROM STPPF--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,123)
  123   FORMAT('      PPF VALUE MAY BE NEAR A SINGULAR POINT.')
        CALL DPWRST('XXX','BUG ')
      ELSEIF(IFLAG.EQ.4)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,131)
  131   FORMAT('***** ERROR FROM STPPF--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,133)
  133   FORMAT('      APPROPRIATE BRACKETING INTERVAL NOT FOUND.')
        CALL DPWRST('XXX','BUG ')
      ELSEIF(IFLAG.EQ.5)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,141)
  141   FORMAT('***** WARNING FROM STPPF--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,143)
  143   FORMAT('      MAXIMUM ITERATIONS EXCEEDED.')
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE STRAN(N,NU,ALMBDA,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE SKEWED T DISTRIBUTION
C              WITH SHAPE PARAMETERS NU AND ALMBDA.
C              THIS DISTRIBUTION IS DEFINED FOR ALL X AND HAS
C              THE PROBABILITY DENSITY FUNCTION
C                 STPDF(X,NU,LAMBDA) = 2*
C                       TCDF(LAMBDA*X*SQRT((NU+1)/(X**2+NU)),NU+1)*
C                       TPDF(X,NU)
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --NU     = THE FIRST SHAPE PARAMETER
C                     --ALMBDA = THE SECOND SHAPE PARAMETER
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST N)
C                                INTO WHICH THE GENERATED
C                                RANDOM SAMPLE WILL BE PLACED.
C     OUTPUT--A RANDOM SAMPLE OF SIZE N
C             FROM THE SKEWED T DISTRIBUTION
C             WITH SHAPE PARAMETERS NU AND ALMBDA.
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                 --NU SHOULD BE A POSITIVE INTEGER.
C                 --ALMBDA CAN BE ANY REAL NUMBER.
C     OTHER DATAPAC   SUBROUTINES NEEDED--CHSRAN, SNRAN.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C               --"Log-Skew-Normal and Log-Skew-t Distributions as
C                 Models for Family Income Data", Azzalini, Cappello,
C                 and Kotz, paper downloaded from Azzalini's web
C                 site.
C     REFERENCES--ALGORITHM FOR RANDOM NUMBERS ADAPTED FROM
C                 AZZALINI'S R FUNCTIONS FOR SKEW T.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2003.11
C     ORIGINAL VERSION--NOVEMBER  2003.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
      DIMENSION Y(1)
C
      CHARACTER*4 ISKNDF
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)THEN
        WRITE(ICOUT,5)
    5   FORMAT('***** ERROR--FOR THE SKEWED T DISTRIBUTION,')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,6)
    6   FORMAT('       THE REQUESTED NUMBER OF RANDOM NUMBERS WAS ',
     1         'NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
   47   FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,'.')
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ELSEIF(NU.LE.0)THEN
        WRITE(ICOUT,115)
  115   FORMAT('***** ERROR--THE DEGREES OF FREEDOM SHAPE ',
     1         'PARAMETER FOR THE')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,116)
  116   FORMAT('     SKEWED-T RANDOM NUMBERS IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)NU
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
C
C     ALGORITM ADAPTED FROM AZZALINI'S R FUNCTION LIBRARY.
C
      ISKNDF='DEFA'
      NTEMP=1
      ANU=REAL(NU)
      DO100I=1,N
C
        CALL SNRAN(1,ALMBDA,ISKNDF,ISEED,Y)
        Z=Y(1)
        CALL CHSRAN(1,ANU,ISEED,Y)
        V=Y(1)/ANU
        X(I)=Z/SQRT(V)
C
  100 CONTINUE
C
 9999 CONTINUE
      RETURN
      END
      REAL FUNCTION SNRM2(N,SX,INCX)
C***BEGIN PROLOGUE  SNRM2
C***DATE WRITTEN   791001   (YYMMDD)
C***REVISION DATE  820801   (YYMMDD)
C***CATEGORY NO.  D1A3B
C***KEYWORDS  BLAS,EUCLIDEAN,L2,LENGTH,LINEAR ALGEBRA,NORM,VECTOR
C***AUTHOR  LAWSON, C. L., (JPL)
C           HANSON, R. J., (SNLA)
C           KINCAID, D. R., (U. OF TEXAS)
C           KROGH, F. T., (JPL)
C***PURPOSE  Euclidean length (L2 norm) of s.p. vector
C***DESCRIPTION
C
C                B L A S  Subprogram
C    Description of Parameters
C
C     --Input--
C        N  number of elements in input vector(s)
C       SX  single precision vector with N elements
C     INCX  storage spacing between elements of SX
C
C     --Output--
C    SNRM2  single precision result (zero if N .LE. 0)
C
C     Euclidean norm of the N-vector stored in SX() with storage
C     increment INCX .
C     If N .LE. 0, return with result = 0.
C     If N .GE. 1, then INCX must be .GE. 1
C
C           C. L. Lawson, 1978 Jan 08
C
C     Four Phase Method     using two built-in constants that are
C     hopefully applicable to all machines.
C         CUTLO = maximum of  SQRT(U/EPS)  over all known machines.
C         CUTHI = minimum of  SQRT(V)      over all known machines.
C     where
C         EPS = smallest no. such that EPS + 1. .GT. 1.
C         U   = smallest positive no.   (underflow limit)
C         V   = largest  no.            (overflow  limit)
C
C     Brief Outline of Algorithm..
C
C     Phase 1 scans zero components.
C     Move to phase 2 when a component is nonzero and .LE. CUTLO
C     Move to phase 3 when a component is .GT. CUTLO
C     Move to phase 4 when a component is .GE. CUTHI/M
C     where M = N for X() real and M = 2*N for complex.
C
C     Values for CUTLO and CUTHI..
C     From the environmental parameters listed in the IMSL converter
C     document the limiting values are as follows..
C     CUTLO, S.P.   U/EPS = 2**(-102) for  Honeywell.  Close seconds are
C                   Univac and DEC at 2**(-103)
C                   Thus CUTLO = 2**(-51) = 4.44089E-16
C     CUTHI, S.P.   V = 2**127 for Univac, Honeywell, and DEC.
C                   Thus CUTHI = 2**(63.5) = 1.30438E19
C     CUTLO, D.P.   U/EPS = 2**(-67) for Honeywell and DEC.
C                   Thus CUTLO = 2**(-33.5) = 8.23181D-11
C     CUTHI, D.P.   same as S.P.  CUTHI = 1.30438D19
C     DATA CUTLO, CUTHI / 8.232D-11,  1.304D19 /
C     DATA CUTLO, CUTHI / 4.441E-16,  1.304E19 /
C***REFERENCES  LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T.,
C                 *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*,
C                 ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL
C                 SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323
C***ROUTINES CALLED  (NONE)
C***END PROLOGUE  SNRM2
      INTEGER          NEXT
      REAL   SX(*),  CUTLO, CUTHI, HITEST, SUM, XMAX, ZERO, ONE
      DATA   ZERO, ONE /0.0E0, 1.0E0/
C
      DATA CUTLO, CUTHI / 4.441E-16,  1.304E19 /
C***FIRST EXECUTABLE STATEMENT  SNRM2
      IF(N .GT. 0) GO TO 10
         SNRM2  = ZERO
         GO TO 300
C
CCC10 ASSIGN 30 TO NEXT
   10 CONTINUE
      NEXT=30
      SUM = ZERO
      NN = N * INCX
C                                                 BEGIN MAIN LOOP
      I = 1
CCC20    GO TO NEXT,(30, 50, 70, 110)
   20 CONTINUE
      IF(NEXT.EQ.30)THEN
        GOTO30
      ELSEIF(NEXT.EQ.50)THEN
        GOTO50
      ELSEIF(NEXT.EQ.70)THEN
        GOTO70
      ELSEIF(NEXT.EQ.110)THEN
        GOTO110
      ENDIF
   30 CONTINUE
      IF( ABS(SX(I)) .GT. CUTLO) GO TO 85
CCCCC ASSIGN 50 TO NEXT
      NEXT=50
      XMAX = ZERO
C
C                        PHASE 1.  SUM IS ZERO
C
   50 CONTINUE
      IF( SX(I) .EQ. ZERO) GO TO 200
      IF( ABS(SX(I)) .GT. CUTLO) GO TO 85
C
C                                PREPARE FOR PHASE 2.
CCCCC ASSIGN 70 TO NEXT
      NEXT=70
      GO TO 105
C
C                                PREPARE FOR PHASE 4.
C
  100 CONTINUE
      I = J
CCCCC ASSIGN 110 TO NEXT
      NEXT=110
      SUM = (SUM / SX(I)) / SX(I)
  105 CONTINUE
      XMAX = ABS(SX(I))
      GO TO 115
C
C                   PHASE 2.  SUM IS SMALL.
C                             SCALE TO AVOID DESTRUCTIVE UNDERFLOW.
C
   70 CONTINUE
      IF( ABS(SX(I)) .GT. CUTLO ) GO TO 75
C
C                     COMMON CODE FOR PHASES 2 AND 4.
C                     IN PHASE 4 SUM IS LARGE.  SCALE TO AVOID OVERFLOW.
C
  110 CONTINUE
      IF( ABS(SX(I)) .LE. XMAX ) GO TO 115
         SUM = ONE + SUM * (XMAX / SX(I))**2
         XMAX = ABS(SX(I))
         GO TO 200
C
  115 CONTINUE
      SUM = SUM + (SX(I)/XMAX)**2
      GO TO 200
C
C
C                  PREPARE FOR PHASE 3.
C
   75 CONTINUE
      SUM = (SUM * XMAX) * XMAX
C
C
C     FOR REAL OR D.P. SET HITEST = CUTHI/N
C     FOR COMPLEX      SET HITEST = CUTHI/(2*N)
C
   85 CONTINUE
      HITEST = CUTHI/FLOAT( N )
C
C                   PHASE 3.  SUM IS MID-RANGE.  NO SCALING.
C
      DO 95 J =I,NN,INCX
         IF(ABS(SX(J)) .GE. HITEST) GO TO 100
         SUM = SUM + SX(J)**2
   95 CONTINUE
      SNRM2 = SQRT( SUM )
      GO TO 300
C
  200 CONTINUE
      I = I + INCX
      IF ( I .LE. NN ) GO TO 20
C
C              END OF MAIN LOOP.
C
C              COMPUTE SQUARE ROOT AND ADJUST FOR SCALING.
C
      SNRM2 = XMAX * SQRT(SUM)
  300 CONTINUE
      RETURN
      END
      SUBROUTINE SNDOFD(NR,N,XPLS,FPLS,A,SX,RNOISE,STEPSZ,ANBR)
CDPLT SUBROUTINE SNDOFD(NR,N,XPLS,OPTFCN,FPLS,A,SX,RNOISE,STEPSZ,ANBR)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C PURPOSE
C -------
C FIND SECOND ORDER FORWARD FINITE DIFFERENCE APPROXIMATION "A"
C TO THE SECOND DERIVATIVE (HESSIAN) OF THE FUNCTION DEFINED BY THE SUBP
C "OPTFCN" EVALUATED AT THE NEW ITERATE "XPLS"
C
C FOR OPTIMIZATION USE THIS ROUTINE TO ESTIMATE
C 1) THE SECOND DERIVATIVE (HESSIAN) OF THE OPTIMIZATION FUNCTION
C    IF NO ANALYTICAL USER FUNCTION HAS BEEN SUPPLIED FOR EITHER
C    THE GRADIENT OR THE HESSIAN AND IF THE OPTIMIZATION FUNCTION
C    "OPTFCN" IS INEXPENSIVE TO EVALUATE.
C
C PARAMETERS
C ----------
C NR           --> ROW DIMENSION OF MATRIX
C N            --> DIMENSION OF PROBLEM
C XPLS(N)      --> NEW ITERATE:   X[K]
C OPTFCN       --> NAME OF SUBROUTINE TO EVALUATE FUNCTION
C FPLS         --> FUNCTION VALUE AT NEW ITERATE, F(XPLS)
C A(N,N)      <--  FINITE DIFFERENCE APPROXIMATION TO HESSIAN
C                  ONLY LOWER TRIANGULAR MATRIX AND DIAGONAL
C                  ARE RETURNED
C SX(N)        --> DIAGONAL SCALING MATRIX FOR X
C RNOISE       --> RELATIVE NOISE IN FNAME [F(X)]
C STEPSZ(N)    --> WORKSPACE (STEPSIZE IN I-TH COMPONENT DIRECTION)
C ANBR(N)      --> WORKSPACE (NEIGHBOR IN I-TH DIRECTION)
C
C
      DIMENSION XPLS(N)
      DIMENSION SX(N)
      DIMENSION STEPSZ(N),ANBR(N)
      DIMENSION A(NR,1)
      DIMENSION FHAT2(1)
C
C FIND I-TH STEPSIZE AND EVALUATE NEIGHBOR IN DIRECTION
C OF I-TH UNIT VECTOR.
C
      OV3 = 1.0D0/3.0D0
      DO 10 I=1,N
        STEPSZ(I)=RNOISE**OV3 * MAX(ABS(XPLS(I)),1.D0/SX(I))
        XTMPI=XPLS(I)
        XPLS(I)=XTMPI+STEPSZ(I)
        CALL OPTFCN(N,XPLS,ANBR(I))
        XPLS(I)=XTMPI
   10 CONTINUE
C
C CALCULATE COLUMN I OF A
C
      DO 30 I=1,N
        XTMPI=XPLS(I)
        XPLS(I)=XTMPI+2.0*STEPSZ(I)
        CALL OPTFCN(N,XPLS,FHAT2)
        FHAT=FHAT2(1)
        A(I,I)=((FPLS-ANBR(I))+(FHAT-ANBR(I)))/(STEPSZ(I)*STEPSZ(I))
C
C CALCULATE SUB-DIAGONAL ELEMENTS OF COLUMN
        IF(I.EQ.N) GO TO 25
        XPLS(I)=XTMPI+STEPSZ(I)
        IP1=I+1
        DO 20 J=IP1,N
          XTMPJ=XPLS(J)
          XPLS(J)=XTMPJ+STEPSZ(J)
          CALL OPTFCN(N,XPLS,FHAT2)
          FHAT=FHAT2(1)
          A(J,I)=((FPLS-ANBR(I))+(FHAT-ANBR(J)))/(STEPSZ(I)*STEPSZ(J))
          XPLS(J)=XTMPJ
   20   CONTINUE
   25   XPLS(I)=XTMPI
   30 CONTINUE
      RETURN
      END
      REAL FUNCTION SNV(AJV, ITYPE, GAMMA, DELTA, XLAM, XI, IFAULT)
C
C        ALGORITHM AS 100.2  APPL. STATIST. (1976) VOL.25, P.190
C
C        CONVERTS A JOHNSON VARIATE (AJV) TO A
C        STANDARD NORMAL VARIATE (SNV)
C
      REAL AJV, GAMMA, DELTA, XLAM, XI, V, W, C, ZERO, HALF, ONE,
     $  ZLOG, ZSQRT
C
      DATA ZERO, HALF, ONE, C /0.0, 0.5, 1.0, -63.0/
C
      ZLOG(W) = LOG(W)
      ZSQRT(W) = SQRT(W)
C
      SNV = ZERO
      IFAULT = 1
      IF (ITYPE .LT. 1 .OR. ITYPE .GT. 4) RETURN
      IFAULT = 0
      GOTO (10, 20, 30, 40), ITYPE
C
C        SL DISTRIBUTION
C
   10 W = XLAM * (AJV - XI)
      IF (W .LE. ZERO) GOTO 15
      SNV = XLAM * (ZLOG(W) * DELTA + GAMMA)
      RETURN
   15 IFAULT = 2
      RETURN
C
C        SU DISTRIBUTION
C
   20 W = (AJV - XI) / XLAM
      IF (W .GT. C) GOTO 23
      W = -HALF / W
      GOTO 27
   23 W = ZSQRT(W * W + ONE) + W
   27 SNV = ZLOG(W) * DELTA + GAMMA
      RETURN
C
C        SB DISTRIBUTION
C
   30 W = AJV - XI
      V = XLAM - W
      IF (W .LE. ZERO .OR. V .LE. ZERO) GOTO 35
      SNV = ZLOG(W / V) * DELTA + GAMMA
      RETURN
   35 IFAULT = 2
      RETURN
C
C        NORMAL DISTRIBUTION
C
   40 SNV = DELTA * AJV + GAMMA
      RETURN
      END
      SUBROUTINE SORT(X,N,Y)
C
C     PURPOSE--THIS SUBROUTINE SORTS (IN ASCENDING ORDER)
C              THE N ELEMENTS OF THE SINGLE PRECISION VECTOR X
C              AND PUTS THE RESULTING N SORTED VALUES INTO THE
C              SINGLE PRECISION VECTOR Y.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF
C                                OBSERVATIONS TO BE SORTED.
C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR X.
C     OUTPUT ARGUMENTS--Y      = THE SINGLE PRECISION VECTOR
C                                INTO WHICH THE SORTED DATA VALUES
C                                FROM X WILL BE PLACED.
C     OUTPUT--THE SINGLE PRECISION VECTOR Y
C             CONTAINING THE SORTED
C             (IN ASCENDING ORDER) VALUES
C             OF THE SINGLE PRECISION VECTOR X.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THE DIMENSIONS OF THE VECTORS IL AND IU
C                   (DEFINED AND USED INTERNALLY WITHIN
C                   THIS SUBROUTINE) DICTATE THE MAXIMUM
C                   ALLOWABLE VALUE OF N FOR THIS SUBROUTINE.
C                   IF IL AND IU EACH HAVE DIMENSION K,
C                   THEN N MAY NOT EXCEED 2**(K+1) - 1.
C                   FOR THIS SUBROUTINE AS WRITTEN, THE DIMENSIONS
C                   OF IL AND IU HAVE BEEN SET TO 36,
C                   THUS THE MAXIMUM ALLOWABLE VALUE OF N IS
C                   APPROXIMATELY 137 BILLION.
C                   SINCE THIS EXCEEDS THE MAXIMUM ALLOWABLE
C                   VALUE FOR AN INTEGER VARIABLE IN MANY COMPUTERS,
C                   AND SINCE A SORT OF 137 BILLION ELEMENTS
C                   IS PRESENTLY IMPRACTICAL AND UNLIKELY,
C                   THEN THERE IS NO PRACTICAL RESTRICTION
C                   ON THE MAXIMUM VALUE OF N FOR THIS SUBROUTINE.
C                   (IN LIGHT OF THE ABOVE, NO CHECK OF THE
C                   UPPER LIMIT OF N HAS BEEN INCORPORATED
C                   INTO 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     COMMENT--THE SMALLEST ELEMENT OF THE VECTOR X
C              WILL BE PLACED IN THE FIRST POSITION
C              OF THE VECTOR Y,
C              THE SECOND SMALLEST ELEMENT IN THE VECTOR X
C              WILL BE PLACED IN THE SECOND POSITION
C              OF THE VECTOR Y, ETC.
C     COMMENT--THE INPUT VECTOR X REMAINS UNALTERED.
C     COMMENT--IF THE ANALYST DESIRES A SORT 'IN PLACE',
C              THIS IS DONE BY HAVING THE SAME
C              OUTPUT VECTOR AS INPUT VECTOR IN THE CALLING SEQUENCE.
C              THUS, FOR EXAMPLE, THE CALLING SEQUENCE
C              CALL SORT(X,N,X)
C              IS ALLOWABLE AND WILL RESULT IN
C              THE DESIRED 'IN-PLACE' SORT.
C     COMMENT--THE SORTING ALGORTHM USED HEREIN
C              IS THE  QUICKSORT.
C              THIS ALGORTHIM IS EXTREMELY FAST AS THE
C              FOLLOWING TIME TRIALS INDICATE.
C              THESE TIME TRIALS WERE CARRIED OUT ON THE
C              UNIVAC 1108 EXEC 8 SYSTEM AT NBS
C              IN AUGUST OF 1974.
C              BY WAY OF COMPARISON, THE TIME TRIAL VALUES
C              FOR THE EASY-TO-PROGRAM BUT EXTREMELY
C              INEFFICIENT BUBBLE SORT ALGORITHM HAVE
C              ALSO BEEN INCLUDED--
C              NUMBER OF RANDOM         QUICKSORT       BUBBLE SORT
C               NUMBERS SORTED
C                N = 10                 .002 SEC          .002 SEC
C                N = 100                .011 SEC          .045 SEC
C                N = 1000               .141 SEC         4.332 SEC
C                N = 3000               .476 SEC        37.683 SEC
C                N = 10000             1.887 SEC      NOT COMPUTED
C     REFERENCES--CACM MARCH 1969, PAGE 186 ( QUICKSORT ALGORITHM
C                 BY RICHARD C. SINGLETON).
C               --CACM JANUARY 1970, PAGE 54.
C               --CACM OCTOBER 1970, PAGE 624.
C               --JACM JANUARY 1961, PAGE 41.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (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         --NOVEMBER  1975.
C     UPDATED         --JUNE      1981.
C     UPDATED         --AUGUST    1981.
C     UPDATED         --MAY       1982.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
      DIMENSION Y(*)
C
      DIMENSION IU(36)
      DIMENSION IL(36)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='SORT'
      ISUBN2='    '
      IERROR='NO'
      IBUGA3='OFF'
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 SORT--')
      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               **  SORT THE VALUES.  **
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 SORT--',
     1'THE SECOND 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
      IF(N.EQ.1)GOTO120
      GOTO129
  120 CONTINUE
CCCCC WRITE(ICOUT,999)
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC WRITE(ICOUT,121)
CC121 FORMAT('***** NON-FATAL DIAGNOSTIC IN SORT--',
CCCCC1'THE SECOND INPUT ARGUMENT (N) HAS THE VALUE 1')
CCCCC CALL DPWRST('XXX','BUG ')
      Y(1)=X(1)
      GOTO9000
  129 CONTINUE
C
      HOLD=X(1)
      DO135I=2,N
      IF(X(I).NE.HOLD)GOTO139
  135 CONTINUE
CCCCC WRITE(ICOUT,999)
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC WRITE(ICOUT,136)HOLD
CC136 FORMAT('***** NON-FATAL DIAGNOSTIC IN SORT--',
CCCCC1'THE FIRST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7)
CCCCC CALL DPWRST('XXX','BUG ')
      DO137I=1,N
        Y(I)=X(I)
  137 CONTINUE
      GOTO9000
  139 CONTINUE
C
C               *******************************************
C               **  STEP 2--                             **
C               **  COPY THE VECTOR X INTO THE VECTOR Y  **
C               *******************************************
C
      DO200I=1,N
        Y(I)=X(I)
  200 CONTINUE
C
C               **********************************************************
C               **  STEP 3--                                            **
C               **  CHECK TO SEE IF THE INPUT VECTOR IS ALREADY SORTED  **
C               **********************************************************
C
      NM1=N-1
      DO250I=1,NM1
      IP1=I+1
      IF(Y(I).LE.Y(IP1))GOTO250
      GOTO290
  250 CONTINUE
      GOTO9000
  290 CONTINUE
C
C               ***************************
C               **  STEP 4--             **
C               **  CARRY OUT THE SORT.  **
C               ***************************
C
      M=1
      I=1
      J=N
  305 IF(I.GE.J)GOTO370
  310 K=I
      MID=(I+J)/2
      AMED=Y(MID)
      IF(Y(I).LE.AMED)GOTO320
      Y(MID)=Y(I)
      Y(I)=AMED
      AMED=Y(MID)
  320 L=J
      IF(Y(J).GE.AMED)GOTO340
      Y(MID)=Y(J)
      Y(J)=AMED
      AMED=Y(MID)
      IF(Y(I).LE.AMED)GOTO340
      Y(MID)=Y(I)
      Y(I)=AMED
      AMED=Y(MID)
      GOTO340
  330 Y(L)=Y(K)
      Y(K)=TT
  340 L=L-1
      IF(Y(L).GT.AMED)GOTO340
      TT=Y(L)
  350 K=K+1
      IF(Y(K).LT.AMED)GOTO350
      IF(K.LE.L)GOTO330
      LMI=L-I
      JMK=J-K
      IF(LMI.LE.JMK)GOTO360
      IL(M)=I
      IU(M)=L
      I=K
      M=M+1
      GOTO380
  360 IL(M)=K
      IU(M)=J
      J=L
      M=M+1
      GOTO380
  370 M=M-1
      IF(M.EQ.0)GOTO9000
      I=IL(M)
      J=IU(M)
  380 JMI=J-I
      IF(JMI.GE.11)GOTO310
      IF(I.EQ.1)GOTO305
      I=I-1
  390 I=I+1
      IF(I.EQ.J)GOTO370
      AMED=Y(I+1)
      IF(Y(I).LE.AMED)GOTO390
      K=I
  395 Y(K+1)=Y(K)
      K=K-1
      IF(AMED.LT.Y(K))GOTO395
      Y(K+1)=AMED
      GOTO390
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 SORT--')
      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 ')
      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 SORT2(X1,X2,N,IWRITE,Y1,Y2,TEMP1,XIDTEM,
     1                 ISORDI,ISUBRO,IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE SORTS BASED ON TWO VARIABLES
C     INPUT  ARGUMENTS--X1     = THE SINGLE PRECISION VECTOR CONTAINING
C                                THE FIRST RESPONSE VARIABLE TO BE
C                                SORTED.
C                     --X2     = THE SINGLE PRECISION VECTOR CONTAINING
C                                THE SECOND RESPONSE VARIABLE TO BE
C                                SORTED.
C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR X.
C                     --ISORDI = CHARACTER VARIABLE THAT SPECIFIES
C                                WHETHER SORT IS ASCENDING OR
C                                DESCENDING.
C     OUTPUT ARGUMENTS--Y1     = THE SINGLE PRECISION VECTOR
C                                CONTAINING THE SORTED VALUES OF
C                                THE FIRST RESPONSE VARIABLE.
C     OUTPUT ARGUMENTS--Y2     = THE SINGLE PRECISION VECTOR
C                                CONTAINING THE SORTED VALUES OF
C                                THE SECOND RESPONSE VARIABLE.
C     OUTPUT--THE SINGLE PRECISION VECTORS Y1 AND Y2 CONTAINING
C             THE SORTED VECTORS.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     OTHER DATAPAC   SUBROUTINES NEEDED--SORT, SORTI.
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                 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2008.10
C     ORIGINAL VERSION--OCTOBER   2008.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 ISORDI
      CHARACTER*4 ISUBRO
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DIMENSION Y1(*)
      DIMENSION Y2(*)
      DIMENSION X1(*)
      DIMENSION X2(*)
      DIMENSION TEMP1(*)
      DIMENSION XIDTEM(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='SORT'
      ISUBN2='2   '
      IERROR='NO'
C
      ISTRT=0
      IFRST=0
      ILAST=0
C
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'ORT2')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,51)
   51   FORMAT('***** AT THE BEGINNING OF SORT2--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,52)IBUGA3,ISORDI
   52   FORMAT('IBUGA3,ISORDI = ',A4,2X,A4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,53)N
   53   FORMAT('N = ',2I8)
        CALL DPWRST('XXX','BUG ')
        DO55I=1,N
          WRITE(ICOUT,56)I,X1(I),X2(I)
   56     FORMAT('I,X1(I),X2(I) = ',I8,2G15.7)
          CALL DPWRST('XXX','BUG ')
   55   CONTINUE
      ENDIF
C
C    ********************************************
C    **  STEP 1--                              **
C    **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C    ********************************************
C
      AN=N
C
      IF(N.LT.1)THEN
        IERROR='YES'
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,111)
  111   FORMAT('***** ERROR IN SORT2--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,113)
  113   FORMAT('      THE NUMBER OF RESPONSE VALUES IS ',
     1         'NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,115)N
  115   FORMAT('      THE NUMBER OF RESPONSE VALUES IS ',I8)
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
      IF(N.EQ.1)THEN
        Y1(1)=X1(1)
        Y2(1)=X2(1)
        GOTO9000
      ENDIF
C
C     ***************************************************
C     **  STEP 2--                                     **
C     **  SORT FIRST VARIABLE AND CARRY THE SECOND     **
C     **  VARIABLE.                                    **
C     ***************************************************
C
      CALL SORTI(X1,N,Y1,TEMP1)
C
      IF(ISORDI.EQ.'DESC')THEN
        DO1010I=1,N
          Y2(I)=Y1(I)
 1010   CONTINUE
        DO1020I=1,N
          II=N-I+1
          Y1(I)=Y2(II)
 1020   CONTINUE
      ENDIF
C
      DO1030I=1,N
        J=INT(TEMP1(I)+0.5)
        Y2(I)=X2(J)
 1030 CONTINUE
      IF(ISORDI.EQ.'DESC')THEN
        DO1040I=1,N
          TEMP1(I)=Y2(I)
 1040   CONTINUE
        DO1050I=1,N
          II=N-I+1
          Y2(I)=TEMP1(II)
 1050   CONTINUE
      ENDIF
C
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'ORT2')THEN
        WRITE(ICOUT,1091)
 1091   FORMAT('AFTER SORT FIRST RESPONSE VARIABLE')
        CALL DPWRST('XXX','BUG ')
        DO1099I=1,N
        WRITE(ICOUT,1093)I,X1(I),X2(I),Y1(I),Y2(I)
 1093   FORMAT('I,X1(I),X2(I),Y1(I),Y2(I) = ',I8,4G15.7)
        CALL DPWRST('XXX','BUG ')
 1099   CONTINUE
      ENDIF
C
C     ****************************************************
C     **  STEP 3--                                      **
C     **  NOW SORT THE SECOND VARIABLE FOR COMMON       **
C     **  VALUES OF FIRST VARIABLE.                     **
C     ****************************************************
C
      CALL DISTIN(Y1,N,IWRITE,XIDTEM,NDIST,IBUGA3,IERROR)
      IF(N.EQ.NDIST)GOTO9000
      IF(NDIST.EQ.1)THEN
        CALL SORTI(X2,N,Y2,TEMP1)
        IF(ISORDI.EQ.'DESC')THEN
          DO2010I=1,N
            TEMP1(I)=Y2(I)
 2010     CONTINUE
          DO2020I=1,N
            II=N-I+1
            Y2(I)=TEMP1(I)
 2020     CONTINUE
        ENDIF
        GOTO9000
      ENDIF
C
      CALL SORT(XIDTEM,NDIST,XIDTEM)
      IF(ISORDI.EQ.'DESC')THEN
        DO2030I=1,NDIST
          TEMP1(I)=XIDTEM(I)
 2030   CONTINUE
        DO2040I=1,NDIST
          II=NDIST-I+1
          XIDTEM(I)=TEMP1(II)
 2040   CONTINUE
      ENDIF
C
      ISTRT=1
      DO2110ISET=1,NDIST
        HOLD=XIDTEM(ISET)
C
        IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'ORT2')THEN
          WRITE(ICOUT,2111)ISET,ISTRT,HOLD
 2111     FORMAT('AT 2110: ISET,ISTRT,HOLD = ',2I8,G15.7)
          CALL DPWRST('XXX','BUG ')
        ENDIF
C
        ICNT=0
        IFLAG1=0
        DO2120I=ISTRT,N
          IF(Y1(I).EQ.HOLD)THEN
            IF(IFLAG1.EQ.0)THEN
              IFRST=I
              IFLAG1=1
            ENDIF
            ILAST=I
            ICNT=ICNT+1
            TEMP1(ICNT)=Y2(I)
          ENDIF
 2120   CONTINUE
        ISTRT=ILAST+1
        CALL SORT(TEMP1,ICNT,TEMP1)
        IF(ISORDI.EQ.'DESC')THEN
          ICNT2=0
          DO2130J=ICNT,1,-1
            ICNT2=ICNT2+1
            Y2(IFRST+J-1)=TEMP1(ICNT2)
 2130     CONTINUE
        ELSE
          DO2160J=1,ICNT
            Y2(IFRST+J-1)=TEMP1(J)
 2160     CONTINUE
        ENDIF
 2110 CONTINUE
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
C
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'ORT2')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END       OF SORT2--')
        CALL DPWRST('XXX','BUG ')
        DO9015I=1,N
          WRITE(ICOUT,9016)I,X1(I),X2(I),Y1(I),Y2(I)
 9016     FORMAT('I,X1(I),X2(I),Y1(I),Y2(I) = ',I8,4G15.7)
          CALL DPWRST('XXX','BUG ')
 9015   CONTINUE
      ENDIF
C
      RETURN
      END
      SUBROUTINE SORT3(X1,X2,X3,N,IWRITE,Y1,Y2,Y3,
     1                 TEMP1,TEMP2,TEMP3,TEMP4,TEMP5,XIDTEM,XIDTE2,
     1                 ISORDI,ISUBRO,IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE SORTS BASED ON THREE VARIABLES
C     INPUT  ARGUMENTS--X1     = THE SINGLE PRECISION VECTOR CONTAINING
C                                THE FIRST RESPONSE VARIABLE TO BE
C                                SORTED.
C                     --X2     = THE SINGLE PRECISION VECTOR CONTAINING
C                                THE SECOND RESPONSE VARIABLE TO BE
C                                SORTED.
C                     --X3     = THE SINGLE PRECISION VECTOR CONTAINING
C                                THE THIRD RESPONSE VARIABLE TO BE
C                                SORTED.
C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR X.
C                     --ISORDI = CHARACTER VARIABLE THAT SPECIFIES
C                                WHETHER SORT IS ASCENDING OR
C                                DESCENDING.
C     OUTPUT ARGUMENTS--Y1     = THE SINGLE PRECISION VECTOR
C                                CONTAINING THE SORTED VALUES OF
C                                THE FIRST RESPONSE VARIABLE.
C                     --Y2     = THE SINGLE PRECISION VECTOR
C                                CONTAINING THE SORTED VALUES OF
C                                THE SECOND RESPONSE VARIABLE.
C                     --Y3     = THE SINGLE PRECISION VECTOR
C                                CONTAINING THE SORTED VALUES OF
C                                THE THIRD RESPONSE VARIABLE.
C     OUTPUT--THE SINGLE PRECISION VECTORS Y1, Y2 AND Y3 CONTAINING
C             THE SORTED VECTORS.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     OTHER DATAPAC   SUBROUTINES NEEDED--SORT, SORTI.
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                 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2008.10
C     ORIGINAL VERSION--OCTOBER   2008.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 ISORDI
      CHARACTER*4 ISUBRO
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DIMENSION Y1(*)
      DIMENSION Y2(*)
      DIMENSION Y3(*)
      DIMENSION X1(*)
      DIMENSION X2(*)
      DIMENSION X3(*)
      DIMENSION TEMP1(*)
      DIMENSION TEMP2(*)
      DIMENSION TEMP3(*)
      DIMENSION TEMP4(*)
      DIMENSION TEMP5(*)
      DIMENSION XIDTEM(*)
      DIMENSION XIDTE2(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='SORT'
      ISUBN2='3   '
      IERROR='NO'
C
      ISTRT=0
      IFRST=0
      ILAST=0
C
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'ORT3')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,51)
   51   FORMAT('***** AT THE BEGINNING OF SORT3--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,52)IBUGA3,ISORDI
   52   FORMAT('IBUGA3,ISORDI = ',A4,2X,A4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,53)N
   53   FORMAT('N = ',2I8)
        CALL DPWRST('XXX','BUG ')
        DO55I=1,N
          WRITE(ICOUT,56)I,X1(I),X2(I),X3(I)
   56     FORMAT('I,X1(I),X2(I),X3(I) = ',I8,3G15.7)
          CALL DPWRST('XXX','BUG ')
   55   CONTINUE
      ENDIF
C
C    ********************************************
C    **  STEP 1--                              **
C    **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C    ********************************************
C
      AN=N
C
      IF(N.LT.1)THEN
        IERROR='YES'
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,111)
  111   FORMAT('***** ERROR IN SORT3--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,113)
  113   FORMAT('      THE NUMBER OF RESPONSE VALUES IS ',
     1         'NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,115)N
  115   FORMAT('      THE NUMBER OF RESPONSE VALUES IS ',I8)
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
      IF(N.EQ.1)THEN
        Y1(1)=X1(1)
        Y2(1)=X2(1)
        Y3(1)=X3(1)
        GOTO9000
      ENDIF
C
C     ***************************************************
C     **  STEP 2--                                     **
C     **  SORT FIRST VARIABLE AND CARRY THE SECOND     **
C     **  AND THIRD VARIABLES.                         **
C     ***************************************************
C
      CALL SORTI(X1,N,Y1,TEMP1)
C
      IF(ISORDI.EQ.'DESC')THEN
        DO1010I=1,N
          Y2(I)=Y1(I)
 1010   CONTINUE
        DO1020I=1,N
          II=N-I+1
          Y1(I)=Y2(II)
 1020   CONTINUE
      ENDIF
C
      DO1030I=1,N
        J=INT(TEMP1(I)+0.5)
        Y2(I)=X2(J)
        Y3(I)=X3(J)
 1030 CONTINUE
      IF(ISORDI.EQ.'DESC')THEN
        DO1040I=1,N
          TEMP1(I)=Y2(I)
 1040   CONTINUE
        DO1050I=1,N
          II=N-I+1
          Y2(I)=TEMP1(II)
 1050   CONTINUE
        DO1060I=1,N
          TEMP1(I)=Y3(I)
 1060   CONTINUE
        DO1070I=1,N
          II=N-I+1
          Y3(I)=TEMP1(II)
 1070   CONTINUE
      ENDIF
C
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'ORT3')THEN
        WRITE(ICOUT,1091)
 1091   FORMAT('AFTER SORT FIRST RESPONSE VARIABLE')
        CALL DPWRST('XXX','BUG ')
        DO1099I=1,N
        WRITE(ICOUT,1093)I,X1(I),X2(I),X3(I),Y1(I),Y2(I),Y3(I)
 1093   FORMAT('I,X1(I),X2(I),X3(I),Y1(I),Y2(I),Y3(I) = ',
     1         I8,6G15.7)
        CALL DPWRST('XXX','BUG ')
 1099   CONTINUE
      ENDIF
C
C     **********************************************************
C     **  STEP 3--                                            **
C     **  NOW SORT THE SECOND AND THIRD VARIABLES FOR COMMON  **
C     **  VALUES OF FIRST VARIABLE.                           **
C     **********************************************************
C
      CALL DISTIN(Y1,N,IWRITE,XIDTEM,NDIST,IBUGA3,IERROR)
      IF(N.EQ.NDIST)GOTO9000
      IF(NDIST.EQ.1)THEN
        CALL SORTI(X2,N,Y2,TEMP1)
        IF(ISORDI.EQ.'DESC')THEN
          DO2010I=1,N
            TEMP1(I)=Y2(I)
 2010     CONTINUE
          DO2015I=1,N
            II=N-I+1
            Y2(I)=TEMP1(I)
 2015     CONTINUE
          DO2020I=1,N
            TEMP1(I)=Y3(I)
 2020     CONTINUE
          DO2025I=1,N
            II=N-I+1
            Y3(I)=TEMP1(I)
 2025     CONTINUE
        ENDIF
        GOTO9000
      ENDIF
C
      CALL SORT(XIDTEM,NDIST,XIDTEM)
      IF(ISORDI.EQ.'DESC')THEN
        DO2030I=1,NDIST
          TEMP1(I)=XIDTEM(I)
 2030   CONTINUE
        DO2040I=1,NDIST
          II=NDIST-I+1
          XIDTEM(I)=TEMP1(II)
 2040   CONTINUE
      ENDIF
C
      ISTRT=1
      DO2110ISET=1,NDIST
        HOLD=XIDTEM(ISET)
C
        IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'ORT3')THEN
          WRITE(ICOUT,2111)ISET,ISTRT,HOLD
 2111     FORMAT('AT 2110: ISET,ISTRT,HOLD = ',2I8,G15.7)
          CALL DPWRST('XXX','BUG ')
        ENDIF
C
        ICNT=0
        IFLAG1=0
        DO2120I=ISTRT,N
          IF(Y1(I).EQ.HOLD)THEN
            IF(IFLAG1.EQ.0)THEN
              IFRST=I
              IFLAG1=1
            ENDIF
            ILAST=I
            ICNT=ICNT+1
            TEMP1(ICNT)=Y2(I)
            TEMP2(ICNT)=Y3(I)
          ENDIF
 2120   CONTINUE
        ISTRT=ILAST+1
        CALL SORT2(TEMP1,TEMP2,ICNT,IWRITE,TEMP3,TEMP4,TEMP5,XIDTE2,
     1             ISORDI,ISUBRO,IBUGA3,IERROR)
        IF(ISORDI.EQ.'DESC')THEN
          ICNT2=0
          DO2130J=ICNT,1,-1
            ICNT2=ICNT2+1
            Y2(IFRST+J-1)=TEMP3(ICNT2)
            Y3(IFRST+J-1)=TEMP4(ICNT2)
 2130     CONTINUE
        ELSE
          DO2160J=1,ICNT
            Y2(IFRST+J-1)=TEMP3(J)
            Y3(IFRST+J-1)=TEMP4(J)
 2160     CONTINUE
        ENDIF
 2110 CONTINUE
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
C
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'ORT3')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END       OF SORT3--')
        CALL DPWRST('XXX','BUG ')
        DO9015I=1,N
          WRITE(ICOUT,9016)I,X1(I),X2(I),X3(I),Y1(I),Y2(I),Y3(I)
 9016     FORMAT('I,X1(I),X2(I),X3(I),Y1(I),Y2(I),Y3(I) = ',
     1           I8,6G15.7)
          CALL DPWRST('XXX','BUG ')
 9015   CONTINUE
      ENDIF
C
      RETURN
      END
      SUBROUTINE SORT4(X1,X2,X3,X4,N,IWRITE,Y1,Y2,Y3,Y4,
     1                 TEMP1,TEMP2,TEMP3,TEMP4,TEMP5,TEMP6,
     1                 XTEMP1,XTEMP2,XTEMP3,XTEMP4,XTEMP5,
     1                 XIDTEM,XIDTE2,XIDTE3,
     1                 ISORDI,ISUBRO,IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE SORTS BASED ON THREE VARIABLES
C     INPUT  ARGUMENTS--X1     = THE SINGLE PRECISION VECTOR CONTAINING
C                                THE FIRST RESPONSE VARIABLE TO BE
C                                SORTED.
C                     --X2     = THE SINGLE PRECISION VECTOR CONTAINING
C                                THE SECOND RESPONSE VARIABLE TO BE
C                                SORTED.
C                     --X3     = THE SINGLE PRECISION VECTOR CONTAINING
C                                THE THIRD RESPONSE VARIABLE TO BE
C                                SORTED.
C                     --X4     = THE SINGLE PRECISION VECTOR CONTAINING
C                                THE FOURTH RESPONSE VARIABLE TO BE
C                                SORTED.
C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR X.
C                     --ISORDI = CHARACTER VARIABLE THAT SPECIFIES
C                                WHETHER SORT IS ASCENDING OR
C                                DESCENDING.
C     OUTPUT ARGUMENTS--Y1     = THE SINGLE PRECISION VECTOR
C                                CONTAINING THE SORTED VALUES OF
C                                THE FIRST RESPONSE VARIABLE.
C                     --Y2     = THE SINGLE PRECISION VECTOR
C                                CONTAINING THE SORTED VALUES OF
C                                THE SECOND RESPONSE VARIABLE.
C                     --Y3     = THE SINGLE PRECISION VECTOR
C                                CONTAINING THE SORTED VALUES OF
C                                THE THIRD RESPONSE VARIABLE.
C                     --Y4     = THE SINGLE PRECISION VECTOR
C                                CONTAINING THE SORTED VALUES OF
C                                THE FOURTH RESPONSE VARIABLE.
C     OUTPUT--THE SINGLE PRECISION VECTORS Y1, Y2, Y3 AND Y4
C             CONTAINING THE SORTED VECTORS.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     OTHER DATAPAC   SUBROUTINES NEEDED--SORT, SORTI.
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                 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2008.10
C     ORIGINAL VERSION--OCTOBER   2008.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 ISORDI
      CHARACTER*4 ISUBRO
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DIMENSION Y1(*)
      DIMENSION Y2(*)
      DIMENSION Y3(*)
      DIMENSION Y4(*)
      DIMENSION X1(*)
      DIMENSION X2(*)
      DIMENSION X3(*)
      DIMENSION X4(*)
      DIMENSION TEMP1(*)
      DIMENSION TEMP2(*)
      DIMENSION TEMP3(*)
      DIMENSION TEMP4(*)
      DIMENSION TEMP5(*)
      DIMENSION TEMP6(*)
      DIMENSION XTEMP1(*)
      DIMENSION XTEMP2(*)
      DIMENSION XTEMP3(*)
      DIMENSION XTEMP4(*)
      DIMENSION XTEMP5(*)
      DIMENSION XIDTEM(*)
      DIMENSION XIDTE2(*)
      DIMENSION XIDTE3(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='SORT'
      ISUBN2='4   '
      IERROR='NO'
C
      IFRST=0
      ISTRT=0
      ILAST=0
C
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'ORT4')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,51)
   51   FORMAT('***** AT THE BEGINNING OF SORT3--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,52)IBUGA3,ISORDI,N
   52   FORMAT('IBUGA3,ISORDI,N = ',2(A4,2X),I8)
        CALL DPWRST('XXX','BUG ')
        DO55I=1,N
          WRITE(ICOUT,56)I,X1(I),X2(I),X3(I),X4(I)
   56     FORMAT('I,X1(I),X2(I),X3(I),X4(I) = ',I8,4G15.7)
          CALL DPWRST('XXX','BUG ')
   55   CONTINUE
      ENDIF
C
C    ********************************************
C    **  STEP 1--                              **
C    **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C    ********************************************
C
      AN=N
C
      IF(N.LT.1)THEN
        IERROR='YES'
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,111)
  111   FORMAT('***** ERROR IN SORT3--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,113)
  113   FORMAT('      THE NUMBER OF RESPONSE VALUES IS ',
     1         'NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,115)N
  115   FORMAT('      THE NUMBER OF RESPONSE VALUES IS ',I8)
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
      IF(N.EQ.1)THEN
        Y1(1)=X1(1)
        Y2(1)=X2(1)
        Y3(1)=X3(1)
        Y4(1)=X4(1)
        GOTO9000
      ENDIF
C
C     ***************************************************
C     **  STEP 2--                                     **
C     **  SORT FIRST VARIABLE AND CARRY THE SECOND     **
C     **  AND THIRD VARIABLES.                         **
C     ***************************************************
C
      CALL SORTI(X1,N,Y1,TEMP1)
C
      IF(ISORDI.EQ.'DESC')THEN
        DO1010I=1,N
          Y2(I)=Y1(I)
 1010   CONTINUE
        DO1020I=1,N
          II=N-I+1
          Y1(I)=Y2(II)
 1020   CONTINUE
      ENDIF
C
      DO1030I=1,N
        J=INT(TEMP1(I)+0.5)
        Y2(I)=X2(J)
        Y3(I)=X3(J)
        Y4(I)=X4(J)
 1030 CONTINUE
      IF(ISORDI.EQ.'DESC')THEN
        DO1040I=1,N
          TEMP1(I)=Y2(I)
 1040   CONTINUE
        DO1050I=1,N
          II=N-I+1
          Y2(I)=TEMP1(II)
 1050   CONTINUE
        DO1060I=1,N
          TEMP1(I)=Y3(I)
 1060   CONTINUE
        DO1070I=1,N
          II=N-I+1
          Y3(I)=TEMP1(II)
 1070   CONTINUE
        DO1080I=1,N
          TEMP1(I)=Y4(I)
 1080   CONTINUE
        DO1090I=1,N
          II=N-I+1
          Y4(I)=TEMP1(II)
 1090   CONTINUE
      ENDIF
C
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'ORT3')THEN
        WRITE(ICOUT,1091)
 1091   FORMAT('AFTER SORT FIRST RESPONSE VARIABLE')
        CALL DPWRST('XXX','BUG ')
        DO1099I=1,N
        WRITE(ICOUT,1093)I,X1(I),X2(I),X3(I),X4(I),
     1                   Y1(I),Y2(I),Y3(I)
 1093   FORMAT('I,X1(I),X2(I),X3(I),X4(I),',
     1         'Y1(I),Y2(I),Y3(I),Y4(I) = ',
     1         I8,8G15.7)
        CALL DPWRST('XXX','BUG ')
 1099   CONTINUE
      ENDIF
C
C     **********************************************************
C     **  STEP 3--                                            **
C     **  NOW SORT THE SECOND AND THIRD VARIABLES FOR COMMON  **
C     **  VALUES OF FIRST VARIABLE.                           **
C     **********************************************************
C
      CALL DISTIN(Y1,N,IWRITE,XIDTEM,NDIST,IBUGA3,IERROR)
      IF(N.EQ.NDIST)GOTO9000
      IF(NDIST.EQ.1)THEN
        CALL SORTI(X2,N,Y2,TEMP1)
        IF(ISORDI.EQ.'DESC')THEN
          DO2010I=1,N
            TEMP1(I)=Y2(I)
 2010     CONTINUE
          DO2011I=1,N
            II=N-I+1
            Y2(I)=TEMP1(I)
 2011     CONTINUE
          DO2020I=1,N
            TEMP1(I)=Y3(I)
 2020     CONTINUE
          DO2021I=1,N
            II=N-I+1
            Y3(I)=TEMP1(I)
 2021     CONTINUE
          DO2025I=1,N
            TEMP1(I)=Y4(I)
 2025     CONTINUE
          DO2026I=1,N
            II=N-I+1
            Y4(I)=TEMP1(I)
 2026     CONTINUE
        ENDIF
        GOTO9000
      ENDIF
C
      CALL SORT(XIDTEM,NDIST,XIDTEM)
      IF(ISORDI.EQ.'DESC')THEN
        DO2030I=1,NDIST
          TEMP1(I)=XIDTEM(I)
 2030   CONTINUE
        DO2040I=1,NDIST
          II=NDIST-I+1
          XIDTEM(I)=TEMP1(II)
 2040   CONTINUE
      ENDIF
C
      ISTRT=1
      DO2110ISET=1,NDIST
        HOLD=XIDTEM(ISET)
C
        IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'ORT3')THEN
          WRITE(ICOUT,2111)ISET,ISTRT,HOLD
 2111     FORMAT('AT 2110: ISET,ISTRT,HOLD = ',2I8,G15.7)
          CALL DPWRST('XXX','BUG ')
        ENDIF
C
        ICNT=0
        IFLAG1=0
        DO2120I=ISTRT,N
          IF(Y1(I).EQ.HOLD)THEN
            IF(IFLAG1.EQ.0)THEN
              IFRST=I
              IFLAG1=1
            ENDIF
            ILAST=I
            ICNT=ICNT+1
            TEMP1(ICNT)=Y2(I)
            TEMP2(ICNT)=Y3(I)
            TEMP3(ICNT)=Y4(I)
          ENDIF
 2120   CONTINUE
        ISTRT=ILAST+1
        CALL SORT3(TEMP1,TEMP2,TEMP3,ICNT,IWRITE,TEMP4,TEMP5,TEMP6,
     1             XTEMP1,XTEMP2,XTEMP3,XTEMP4,XTEMP5,
     1             XIDTE2,XIDTE3,
     1             ISORDI,ISUBRO,IBUGA3,IERROR)
        IF(ISORDI.EQ.'DESC')THEN
          ICNT2=0
          DO2130J=ICNT,1,-1
            ICNT2=ICNT2+1
            Y2(IFRST+J-1)=TEMP4(ICNT2)
            Y3(IFRST+J-1)=TEMP5(ICNT2)
            Y4(IFRST+J-1)=TEMP6(ICNT2)
 2130     CONTINUE
        ELSE
          DO2160J=1,ICNT
            Y2(IFRST+J-1)=TEMP4(J)
            Y3(IFRST+J-1)=TEMP5(J)
            Y4(IFRST+J-1)=TEMP6(J)
 2160     CONTINUE
        ENDIF
 2110 CONTINUE
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
C
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'ORT3')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END       OF SORT3--')
        CALL DPWRST('XXX','BUG ')
        DO9015I=1,N
          WRITE(ICOUT,9016)I,X1(I),X2(I),X3(I),X4(I),
     1                     Y1(I),Y2(I),Y3(I),Y4(I)
 9016     FORMAT('I,X1(I),X2(I),X3(I),X4(I),',
     1           'Y1(I),Y2(I),Y3(I),Y4(I) = ',
     1           I8,8G15.7)
          CALL DPWRST('XXX','BUG ')
 9015   CONTINUE
      ENDIF
C
      RETURN
      END
      SUBROUTINE SORTC(X,Y,N,XS,YC)
C
C     PURPOSE--THIS SUBROUTINE SORTS (IN ASCENDING ORDER)
C              THE N ELEMENTS OF THE SINGLE PRECISION VECTOR X,
C              PUTS THE RESULTING N SORTED VALUES INTO THE
C              SINGLE PRECISION VECTOR XS,
C              REARRANGES THE ELEMENTS OF THE VECTOR Y
C              (ACCORDING TO THE SORT ON X),
C              AND PUTS THE REARRANGED Y VALUES
C              INTO THE SINGLE PRECISION VECTOR YC.
C              THIS SUBROUTINE GIVES THE DATA ANALYST
C              THE ABILITY TO SORT ONE DATA VECTOR
C              WHILE 'CARRYING ALONG' THE ELEMENTS
C              OF A SECOND DATA VECTOR.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF
C                                OBSERVATIONS TO BE SORTED.
C                     --Y      = THE SINGLE PRECISION VECTOR OF
C                                OBSERVATIONS TO BE 'CARRIED ALONG',
C                                THAT IS, TO BE REARRANGED ACCORDING
C                                TO THE SORT ON X.
C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR X.
C     OUTPUT ARGUMENTS--XS     = THE SINGLE PRECISION VECTOR
C                                INTO WHICH THE SORTED DATA VALUES
C                                FROM X WILL BE PLACED.
C                     --YC     = THE SINGLE PRECISION VECTOR
C                                INTO WHICH THE REARRANGED
C                                (ACCORDING TO THE SORT OF THE
C                                VECTOR X) VALUES OF THE VECTOR Y
C                                WILL BE PLACED.
C     OUTPUT--THE SINGLE PRECISION VECTOR XS
C             CONTAINING THE SORTED
C             (IN ASCENDING ORDER) VALUES
C             OF THE SINGLE PRECISION VECTOR X, AND
C             THE SINGLE PRECISION VECTOR YC
C             CONTAINING THE REARRANGED
C             (ACCORDING TO THE SORT ON X)
C             VALUES OF THE VECTOR Y.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THE DIMENSIONS OF THE VECTORS IL AND IU
C                   (DEFINED AND USED INTERNALLY WITHIN
C                   THIS SUBROUTINE) DICTATE THE MAXIMUM
C                   ALLOWABLE VALUE OF N FOR THIS SUBROUTINE.
C                   IF IL AND IU EACH HAVE DIMENSION K,
C                   THEN N MAY NOT EXCEED 2**(K+1) - 1.
C                   FOR THIS SUBROUTINE AS WRITTEN, THE DIMENSIONS
C                   OF IL AND IU HAVE BEEN SET TO 36,
C                   THUS THE MAXIMUM ALLOWABLE VALUE OF N IS
C                   APPROXIMATELY 137 BILLION.
C                   SINCE THIS EXCEEDS THE MAXIMUM ALLOWABLE
C                   VALUE FOR AN INTEGER VARIABLE IN MANY COMPUTERS,
C                   AND SINCE A SORT OF 137 BILLION ELEMENTS
C                   IS PRESENTLY IMPRACTICAL AND UNLIKELY,
C                   THEN THERE IS NO PRACTICAL RESTRICTION
C                   ON THE MAXIMUM VALUE OF N FOR THIS SUBROUTINE.
C                   (IN LIGHT OF THE ABOVE, NO CHECK OF THE
C                   UPPER LIMIT OF N HAS BEEN INCORPORATED
C                   INTO 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     COMMENT--THE SMALLEST ELEMENT OF THE VECTOR X
C              WILL BE PLACED IN THE FIRST POSITION
C              OF THE VECTOR XS,
C              THE SECOND SMALLEST ELEMENT IN THE VECTOR X
C              WILL BE PLACED IN THE SECOND POSITION
C              OF THE VECTOR XS,
C              ETC.
C     COMMENT--THE ELEMENT IN THE VECTOR Y CORRESPONDING
C              TO THE SMALLEST ELEMENT IN X
C              WILL BE PLACED IN THE FIRST POSITION
C              OF THE VECTOR YC,
C              THE ELEMENT IN THE VECTOR Y CORRESPONDING
C              TO THE SECOND SMALLEST ELEMENT IN X
C              WILL BE PLACED IN THE SECOND POSITION
C              OF THE VECTOR YC,
C              ETC.
C     COMMENT--THE INPUT VECTOR X REMAINS UNALTERED.
C     COMMENT--IF THE ANALYST DESIRES A SORT 'IN PLACE',
C              THIS IS DONE BY HAVING THE SAME
C              OUTPUT VECTOR AS INPUT VECTOR IN THE CALLING SEQUENCE.
C              THUS, FOR EXAMPLE, THE CALLING SEQUENCE
C              CALL SORTC(X,Y,N,X,YC)
C              IS ALLOWABLE AND WILL RESULT IN
C              THE DESIRED 'IN-PLACE' SORT.
C     COMMENT--THE SORTING ALGORTHM USED HEREIN
C              IS THE BINARY SORT.
C              THIS ALGORTHIM IS EXTREMELY FAST AS THE
C              FOLLOWING TIME TRIALS INDICATE.
C              THESE TIME TRIALS WERE CARRIED OUT ON THE
C              UNIVAC 1108 EXEC 8 SYSTEM AT NBS
C              IN AUGUST OF 1974.
C              BY WAY OF COMPARISON, THE TIME TRIAL VALUES
C              FOR THE EASY-TO-PROGRAM BUT EXTREMELY
C              INEFFICIENT BUBBLE SORT ALGORITHM HAVE
C              ALSO BEEN INCLUDED--
C              NUMBER OF RANDOM        BINARY SORT       BUBBLE SORT
C               NUMBERS SORTED
C                N = 10                 .002 SEC          .002 SEC
C                N = 100                .011 SEC          .045 SEC
C                N = 1000               .141 SEC         4.332 SEC
C                N = 3000               .476 SEC        37.683 SEC
C                N = 10000             1.887 SEC      NOT COMPUTED
C     REFERENCES--CACM MARCH 1969, PAGE 186 (BINARY SORT ALGORITHM
C                 BY RICHARD C. SINGLETON).
C               --CACM JANUARY 1970, PAGE 54.
C               --CACM OCTOBER 1970, PAGE 624.
C               --JACM JANUARY 1961, PAGE 41.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (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         --NOVEMBER  1975.
C     UPDATED         --JUNE      1981.
C     UPDATED         --MAY       1982.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*),Y(*),XS(*),YC(*)
      DIMENSION IU(36),IL(36)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)THEN
        WRITE(ICOUT,15)
   15   FORMAT('***** ERROR--THE SECOND ARGUMENT TO SORTC ',
     1         'IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
   47   FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8)
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(N.EQ.1)THEN
        XS(1)=X(1)
        YC(1)=Y(1)
        GOTO9000
      ENDIF
C
C     COPY THE VECTOR X INTO THE VECTOR XS AND THE VECTOR Y INTO YC
C
      DO100I=1,N
        XS(I)=X(I)
        YC(I)=Y(I)
  100 CONTINUE
C
C     CHECK TO SEE IF THE INPUT VECTOR IS ALREADY SORTED
C
      NM1=N-1
      DO200I=1,NM1
      IP1=I+1
      IF(XS(I).LE.XS(IP1))GOTO200
      GOTO250
  200 CONTINUE
      GOTO9000
  250 M=1
      I=1
      J=N
  305 IF(I.GE.J)GOTO370
  310 K=I
      MID=(I+J)/2
      AMED=XS(MID)
      BMED=YC(MID)
      IF(XS(I).LE.AMED)GOTO320
      XS(MID)=XS(I)
      YC(MID)=YC(I)
      XS(I)=AMED
      YC(I)=BMED
      AMED=XS(MID)
      BMED=YC(MID)
  320 L=J
      IF(XS(J).GE.AMED)GOTO340
      XS(MID)=XS(J)
      YC(MID)=YC(J)
      XS(J)=AMED
      YC(J)=BMED
      AMED=XS(MID)
      BMED=YC(MID)
      IF(XS(I).LE.AMED)GOTO340
      XS(MID)=XS(I)
      YC(MID)=YC(I)
      XS(I)=AMED
      YC(I)=BMED
      AMED=XS(MID)
      BMED=YC(MID)
      GOTO340
  330 XS(L)=XS(K)
      YC(L)=YC(K)
      XS(K)=TX
      YC(K)=TY
  340 L=L-1
      IF(XS(L).GT.AMED)GOTO340
      TX=XS(L)
      TY=YC(L)
  350 K=K+1
      IF(XS(K).LT.AMED)GOTO350
      IF(K.LE.L)GOTO330
      LMI=L-I
      JMK=J-K
      IF(LMI.LE.JMK)GOTO360
      IL(M)=I
      IU(M)=L
      I=K
      M=M+1
      GOTO380
  360 IL(M)=K
      IU(M)=J
      J=L
      M=M+1
      GOTO380
  370 M=M-1
      IF(M.EQ.0)GOTO9000
      I=IL(M)
      J=IU(M)
  380 JMI=J-I
      IF(JMI.GE.11)GOTO310
      IF(I.EQ.1)GOTO305
      I=I-1
  390 I=I+1
      IF(I.EQ.J)GOTO370
      AMED=XS(I+1)
      BMED=YC(I+1)
      IF(XS(I).LE.AMED)GOTO390
      K=I
  395 XS(K+1)=XS(K)
      YC(K+1)=YC(K)
      K=K-1
      IF(AMED.LT.XS(K))GOTO395
      XS(K+1)=AMED
      YC(K+1)=BMED
      GOTO390
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE SORTC3(X,Y,N,XS,YC)
C
C     PURPOSE--THIS SUBROUTINE SORTS (IN ASCENDING ORDER)
C              THE N ELEMENTS OF THE SINGLE PRECISION VECTOR X,
C              PUTS THE RESULTING N SORTED VALUES INTO THE
C              SINGLE PRECISION VECTOR XS,
C              REARRANGES THE ELEMENTS OF THE VECTOR Y
C              (ACCORDING TO THE SORT ON X),
C              AND PUTS THE REARRANGED Y VALUES
C              INTO THE SINGLE PRECISION VECTOR YC.
C              THIS SUBROUTINE GIVES THE DATA ANALYST
C              THE ABILITY TO SORT ONE DATA VECTOR
C              WHILE 'CARRYING ALONG' THE ELEMENTS
C              OF A SECOND DATA VECTOR.
C
C              NOTE: THIS IS A COPY OF SORTC WHERE THE Y AND
C                    YC ARRAYS ARE INTEGER RATHER THAN REAL.
C                    USE THIS TO AVOID WARNING MESSAGES ON THE
C                    COMPILE.
C
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF
C                                OBSERVATIONS TO BE SORTED.
C                     --Y      = THE SINGLE PRECISION VECTOR OF
C                                OBSERVATIONS TO BE 'CARRIED ALONG',
C                                THAT IS, TO BE REARRANGED ACCORDING
C                                TO THE SORT ON X.
C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR X.
C     OUTPUT ARGUMENTS--XS     = THE SINGLE PRECISION VECTOR
C                                INTO WHICH THE SORTED DATA VALUES
C                                FROM X WILL BE PLACED.
C                     --YC     = THE SINGLE PRECISION VECTOR
C                                INTO WHICH THE REARRANGED
C                                (ACCORDING TO THE SORT OF THE
C                                VECTOR X) VALUES OF THE VECTOR Y
C                                WILL BE PLACED.
C     OUTPUT--THE SINGLE PRECISION VECTOR XS
C             CONTAINING THE SORTED
C             (IN ASCENDING ORDER) VALUES
C             OF THE SINGLE PRECISION VECTOR X, AND
C             THE SINGLE PRECISION VECTOR YC
C             CONTAINING THE REARRANGED
C             (ACCORDING TO THE SORT ON X)
C             VALUES OF THE VECTOR Y.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THE DIMENSIONS OF THE VECTORS IL AND IU
C                   (DEFINED AND USED INTERNALLY WITHIN
C                   THIS SUBROUTINE) DICTATE THE MAXIMUM
C                   ALLOWABLE VALUE OF N FOR THIS SUBROUTINE.
C                   IF IL AND IU EACH HAVE DIMENSION K,
C                   THEN N MAY NOT EXCEED 2**(K+1) - 1.
C                   FOR THIS SUBROUTINE AS WRITTEN, THE DIMENSIONS
C                   OF IL AND IU HAVE BEEN SET TO 36,
C                   THUS THE MAXIMUM ALLOWABLE VALUE OF N IS
C                   APPROXIMATELY 137 BILLION.
C                   SINCE THIS EXCEEDS THE MAXIMUM ALLOWABLE
C                   VALUE FOR AN INTEGER VARIABLE IN MANY COMPUTERS,
C                   AND SINCE A SORT OF 137 BILLION ELEMENTS
C                   IS PRESENTLY IMPRACTICAL AND UNLIKELY,
C                   THEN THERE IS NO PRACTICAL RESTRICTION
C                   ON THE MAXIMUM VALUE OF N FOR THIS SUBROUTINE.
C                   (IN LIGHT OF THE ABOVE, NO CHECK OF THE
C                   UPPER LIMIT OF N HAS BEEN INCORPORATED
C                   INTO 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     COMMENT--THE SMALLEST ELEMENT OF THE VECTOR X
C              WILL BE PLACED IN THE FIRST POSITION
C              OF THE VECTOR XS,
C              THE SECOND SMALLEST ELEMENT IN THE VECTOR X
C              WILL BE PLACED IN THE SECOND POSITION
C              OF THE VECTOR XS,
C              ETC.
C     COMMENT--THE ELEMENT IN THE VECTOR Y CORRESPONDING
C              TO THE SMALLEST ELEMENT IN X
C              WILL BE PLACED IN THE FIRST POSITION
C              OF THE VECTOR YC,
C              THE ELEMENT IN THE VECTOR Y CORRESPONDING
C              TO THE SECOND SMALLEST ELEMENT IN X
C              WILL BE PLACED IN THE SECOND POSITION
C              OF THE VECTOR YC,
C              ETC.
C     COMMENT--THE INPUT VECTOR X REMAINS UNALTERED.
C     COMMENT--IF THE ANALYST DESIRES A SORT 'IN PLACE',
C              THIS IS DONE BY HAVING THE SAME
C              OUTPUT VECTOR AS INPUT VECTOR IN THE CALLING SEQUENCE.
C              THUS, FOR EXAMPLE, THE CALLING SEQUENCE
C              CALL SORTC(X,Y,N,X,YC)
C              IS ALLOWABLE AND WILL RESULT IN
C              THE DESIRED 'IN-PLACE' SORT.
C     COMMENT--THE SORTING ALGORTHM USED HEREIN
C              IS THE BINARY SORT.
C              THIS ALGORTHIM IS EXTREMELY FAST AS THE
C              FOLLOWING TIME TRIALS INDICATE.
C              THESE TIME TRIALS WERE CARRIED OUT ON THE
C              UNIVAC 1108 EXEC 8 SYSTEM AT NBS
C              IN AUGUST OF 1974.
C              BY WAY OF COMPARISON, THE TIME TRIAL VALUES
C              FOR THE EASY-TO-PROGRAM BUT EXTREMELY
C              INEFFICIENT BUBBLE SORT ALGORITHM HAVE
C              ALSO BEEN INCLUDED--
C              NUMBER OF RANDOM        BINARY SORT       BUBBLE SORT
C               NUMBERS SORTED
C                N = 10                 .002 SEC          .002 SEC
C                N = 100                .011 SEC          .045 SEC
C                N = 1000               .141 SEC         4.332 SEC
C                N = 3000               .476 SEC        37.683 SEC
C                N = 10000             1.887 SEC      NOT COMPUTED
C     REFERENCES--CACM MARCH 1969, PAGE 186 (BINARY SORT ALGORITHM
C                 BY RICHARD C. SINGLETON).
C               --CACM JANUARY 1970, PAGE 54.
C               --CACM OCTOBER 1970, PAGE 624.
C               --JACM JANUARY 1961, PAGE 41.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (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         --NOVEMBER  1975.
C     UPDATED         --JUNE      1981.
C     UPDATED         --MAY       1982.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      REAL X(*),XS(*)
      INTEGER Y(*),YC(*)
      INTEGER BMED
      INTEGER TY
      DIMENSION IU(36),IL(36)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)THEN
        WRITE(ICOUT,15)
   15   FORMAT('***** ERROR--THE SECOND ARGUMENT TO SORTC ',
     1         'IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
   47   FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8)
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(N.EQ.1)THEN
        XS(1)=X(1)
        YC(1)=Y(1)
        GOTO9000
      ENDIF
C
      HOLD=X(1)
      DO60I=2,N
        IF(X(I).NE.HOLD)GOTO90
   60 CONTINUE
      DO61I=1,N
        XS(I)=X(I)
        YC(I)=Y(I)
   61 CONTINUE
      GOTO9000
C
   90 CONTINUE
C
C     COPY THE VECTOR X INTO THE VECTOR XS AND THE VECTOR Y INTO YS
C
      DO100I=1,N
        XS(I)=X(I)
        YC(I)=Y(I)
  100 CONTINUE
C
C     CHECK TO SEE IF THE INPUT VECTOR IS ALREADY SORTED
C
      NM1=N-1
      DO200I=1,NM1
      IP1=I+1
      IF(XS(I).LE.XS(IP1))GOTO200
      GOTO250
  200 CONTINUE
      GOTO9000
  250 M=1
      I=1
      J=N
  305 IF(I.GE.J)GOTO370
  310 K=I
      MID=(I+J)/2
      AMED=XS(MID)
      BMED=YC(MID)
      IF(XS(I).LE.AMED)GOTO320
      XS(MID)=XS(I)
      YC(MID)=YC(I)
      XS(I)=AMED
      YC(I)=BMED
      AMED=XS(MID)
      BMED=YC(MID)
  320 L=J
      IF(XS(J).GE.AMED)GOTO340
      XS(MID)=XS(J)
      YC(MID)=YC(J)
      XS(J)=AMED
      YC(J)=BMED
      AMED=XS(MID)
      BMED=YC(MID)
      IF(XS(I).LE.AMED)GOTO340
      XS(MID)=XS(I)
      YC(MID)=YC(I)
      XS(I)=AMED
      YC(I)=BMED
      AMED=XS(MID)
      BMED=YC(MID)
      GOTO340
  330 XS(L)=XS(K)
      YC(L)=YC(K)
      XS(K)=TX
      YC(K)=TY
  340 L=L-1
      IF(XS(L).GT.AMED)GOTO340
      TX=XS(L)
      TY=YC(L)
  350 K=K+1
      IF(XS(K).LT.AMED)GOTO350
      IF(K.LE.L)GOTO330
      LMI=L-I
      JMK=J-K
      IF(LMI.LE.JMK)GOTO360
      IL(M)=I
      IU(M)=L
      I=K
      M=M+1
      GOTO380
  360 IL(M)=K
      IU(M)=J
      J=L
      M=M+1
      GOTO380
  370 M=M-1
      IF(M.EQ.0)GOTO9000
      I=IL(M)
      J=IU(M)
  380 JMI=J-I
      IF(JMI.GE.11)GOTO310
      IF(I.EQ.1)GOTO305
      I=I-1
  390 I=I+1
      IF(I.EQ.J)GOTO370
      AMED=XS(I+1)
      BMED=YC(I+1)
      IF(XS(I).LE.AMED)GOTO390
      K=I
  395 XS(K+1)=XS(K)
      YC(K+1)=YC(K)
      K=K-1
      IF(AMED.LT.XS(K))GOTO395
      XS(K+1)=AMED
      YC(K+1)=BMED
      GOTO390
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE SORTC4(X,Y,N,XS,YC)
C
C     PURPOSE--THIS SUBROUTINE SORTS (IN ASCENDING ORDER)
C              THE N ELEMENTS OF THE SINGLE PRECISION VECTOR X,
C              PUTS THE RESULTING N SORTED VALUES INTO THE
C              SINGLE PRECISION VECTOR XS,
C              REARRANGES THE ELEMENTS OF THE VECTOR Y
C              (ACCORDING TO THE SORT ON X),
C              AND PUTS THE REARRANGED Y VALUES
C              INTO THE SINGLE PRECISION VECTOR YC.
C              THIS SUBROUTINE GIVES THE DATA ANALYST
C              THE ABILITY TO SORT ONE DATA VECTOR
C              WHILE 'CARRYING ALONG' THE ELEMENTS
C              OF A SECOND DATA VECTOR.
C
C              NOTE: THIS IS A COPY OF SORTC WHERE THE X, Y, XS, AND
C                    YC ARRAYS ARE INTEGER RATHER THAN REAL.
C                    USE THIS TO AVOID WARNING MESSAGES ON THE
C                    COMPILE.
C
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF
C                                OBSERVATIONS TO BE SORTED.
C                     --Y      = THE SINGLE PRECISION VECTOR OF
C                                OBSERVATIONS TO BE 'CARRIED ALONG',
C                                THAT IS, TO BE REARRANGED ACCORDING
C                                TO THE SORT ON X.
C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR X.
C     OUTPUT ARGUMENTS--XS     = THE SINGLE PRECISION VECTOR
C                                INTO WHICH THE SORTED DATA VALUES
C                                FROM X WILL BE PLACED.
C                     --YC     = THE SINGLE PRECISION VECTOR
C                                INTO WHICH THE REARRANGED
C                                (ACCORDING TO THE SORT OF THE
C                                VECTOR X) VALUES OF THE VECTOR Y
C                                WILL BE PLACED.
C     OUTPUT--THE SINGLE PRECISION VECTOR XS
C             CONTAINING THE SORTED
C             (IN ASCENDING ORDER) VALUES
C             OF THE SINGLE PRECISION VECTOR X, AND
C             THE SINGLE PRECISION VECTOR YC
C             CONTAINING THE REARRANGED
C             (ACCORDING TO THE SORT ON X)
C             VALUES OF THE VECTOR Y.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THE DIMENSIONS OF THE VECTORS IL AND IU
C                   (DEFINED AND USED INTERNALLY WITHIN
C                   THIS SUBROUTINE) DICTATE THE MAXIMUM
C                   ALLOWABLE VALUE OF N FOR THIS SUBROUTINE.
C                   IF IL AND IU EACH HAVE DIMENSION K,
C                   THEN N MAY NOT EXCEED 2**(K+1) - 1.
C                   FOR THIS SUBROUTINE AS WRITTEN, THE DIMENSIONS
C                   OF IL AND IU HAVE BEEN SET TO 36,
C                   THUS THE MAXIMUM ALLOWABLE VALUE OF N IS
C                   APPROXIMATELY 137 BILLION.
C                   SINCE THIS EXCEEDS THE MAXIMUM ALLOWABLE
C                   VALUE FOR AN INTEGER VARIABLE IN MANY COMPUTERS,
C                   AND SINCE A SORT OF 137 BILLION ELEMENTS
C                   IS PRESENTLY IMPRACTICAL AND UNLIKELY,
C                   THEN THERE IS NO PRACTICAL RESTRICTION
C                   ON THE MAXIMUM VALUE OF N FOR THIS SUBROUTINE.
C                   (IN LIGHT OF THE ABOVE, NO CHECK OF THE
C                   UPPER LIMIT OF N HAS BEEN INCORPORATED
C                   INTO 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     COMMENT--THE SMALLEST ELEMENT OF THE VECTOR X
C              WILL BE PLACED IN THE FIRST POSITION
C              OF THE VECTOR XS,
C              THE SECOND SMALLEST ELEMENT IN THE VECTOR X
C              WILL BE PLACED IN THE SECOND POSITION
C              OF THE VECTOR XS,
C              ETC.
C     COMMENT--THE ELEMENT IN THE VECTOR Y CORRESPONDING
C              TO THE SMALLEST ELEMENT IN X
C              WILL BE PLACED IN THE FIRST POSITION
C              OF THE VECTOR YC,
C              THE ELEMENT IN THE VECTOR Y CORRESPONDING
C              TO THE SECOND SMALLEST ELEMENT IN X
C              WILL BE PLACED IN THE SECOND POSITION
C              OF THE VECTOR YC,
C              ETC.
C     COMMENT--THE INPUT VECTOR X REMAINS UNALTERED.
C     COMMENT--IF THE ANALYST DESIRES A SORT 'IN PLACE',
C              THIS IS DONE BY HAVING THE SAME
C              OUTPUT VECTOR AS INPUT VECTOR IN THE CALLING SEQUENCE.
C              THUS, FOR EXAMPLE, THE CALLING SEQUENCE
C              CALL SORTC(X,Y,N,X,YC)
C              IS ALLOWABLE AND WILL RESULT IN
C              THE DESIRED 'IN-PLACE' SORT.
C     COMMENT--THE SORTING ALGORTHM USED HEREIN
C              IS THE BINARY SORT.
C              THIS ALGORTHIM IS EXTREMELY FAST AS THE
C              FOLLOWING TIME TRIALS INDICATE.
C              THESE TIME TRIALS WERE CARRIED OUT ON THE
C              UNIVAC 1108 EXEC 8 SYSTEM AT NBS
C              IN AUGUST OF 1974.
C              BY WAY OF COMPARISON, THE TIME TRIAL VALUES
C              FOR THE EASY-TO-PROGRAM BUT EXTREMELY
C              INEFFICIENT BUBBLE SORT ALGORITHM HAVE
C              ALSO BEEN INCLUDED--
C              NUMBER OF RANDOM        BINARY SORT       BUBBLE SORT
C               NUMBERS SORTED
C                N = 10                 .002 SEC          .002 SEC
C                N = 100                .011 SEC          .045 SEC
C                N = 1000               .141 SEC         4.332 SEC
C                N = 3000               .476 SEC        37.683 SEC
C                N = 10000             1.887 SEC      NOT COMPUTED
C     REFERENCES--CACM MARCH 1969, PAGE 186 (BINARY SORT ALGORITHM
C                 BY RICHARD C. SINGLETON).
C               --CACM JANUARY 1970, PAGE 54.
C               --CACM OCTOBER 1970, PAGE 624.
C               --JACM JANUARY 1961, PAGE 41.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (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         --NOVEMBER  1975.
C     UPDATED         --JUNE      1981.
C     UPDATED         --MAY       1982.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      INTEGER X(*),XS(*)
      INTEGER Y(*),YC(*)
      INTEGER BMED
      INTEGER AMED
      INTEGER HOLD
      INTEGER TX
      INTEGER TY
      DIMENSION IU(36),IL(36)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)THEN
        WRITE(ICOUT,15)
   15   FORMAT('***** ERROR--THE SECOND ARGUMENT TO ',
     1         'SORTC IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
   47   FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,'.')
        CALL DPWRST('XXX','BUG ')
        RETURN
      ELSEIF(N.EQ.1)THEN
CCCCC   WRITE(ICOUT,18)
CCC18   FORMAT('***** WARNING--THE THIRD ARGUMENT ',
CCCCC1         'TO SORTC HAS THE VALUE 1')
CCCCC   CALL DPWRST('XXX','BUG ')
        XS(1)=X(1)
        YC(1)=Y(1)
        RETURN
      ENDIF
C
      HOLD=X(1)
      DO60I=2,N
        IF(X(I).NE.HOLD)GOTO90
   60 CONTINUE
CCCCC WRITE(ICOUT, 9)HOLD
CCCC9 FORMAT('***** WARNING--THE FIRST ARGUMENT ',
CCCCC1       '(A VECTOR) TO SORTC HAS ALL ELEMENTS = ',G15.7)
CCCCC CALL DPWRST('XXX','BUG ')
      DO61I=1,N
        XS(I)=X(I)
        YC(I)=Y(I)
   61 CONTINUE
      RETURN
C
   90 CONTINUE
C     COPY THE VECTOR X INTO THE VECTOR XS
      DO100I=1,N
      XS(I)=X(I)
  100 CONTINUE
C
C     COPY THE VECTOR Y INTO THE VECTOR YS
C
      DO150I=1,N
      YC(I)=Y(I)
  150 CONTINUE
C
C     CHECK TO SEE IF THE INPUT VECTOR IS ALREADY SORTED
C
      NM1=N-1
      DO200I=1,NM1
      IP1=I+1
      IF(XS(I).LE.XS(IP1))GOTO200
      GOTO250
  200 CONTINUE
      RETURN
  250 M=1
      I=1
      J=N
  305 IF(I.GE.J)GOTO370
  310 K=I
      MID=(I+J)/2
      AMED=XS(MID)
      BMED=YC(MID)
      IF(XS(I).LE.AMED)GOTO320
      XS(MID)=XS(I)
      YC(MID)=YC(I)
      XS(I)=AMED
      YC(I)=BMED
      AMED=XS(MID)
      BMED=YC(MID)
  320 L=J
      IF(XS(J).GE.AMED)GOTO340
      XS(MID)=XS(J)
      YC(MID)=YC(J)
      XS(J)=AMED
      YC(J)=BMED
      AMED=XS(MID)
      BMED=YC(MID)
      IF(XS(I).LE.AMED)GOTO340
      XS(MID)=XS(I)
      YC(MID)=YC(I)
      XS(I)=AMED
      YC(I)=BMED
      AMED=XS(MID)
      BMED=YC(MID)
      GOTO340
  330 XS(L)=XS(K)
      YC(L)=YC(K)
      XS(K)=TX
      YC(K)=TY
  340 L=L-1
      IF(XS(L).GT.AMED)GOTO340
      TX=XS(L)
      TY=YC(L)
  350 K=K+1
      IF(XS(K).LT.AMED)GOTO350
      IF(K.LE.L)GOTO330
      LMI=L-I
      JMK=J-K
      IF(LMI.LE.JMK)GOTO360
      IL(M)=I
      IU(M)=L
      I=K
      M=M+1
      GOTO380
  360 IL(M)=K
      IU(M)=J
      J=L
      M=M+1
      GOTO380
  370 M=M-1
      IF(M.EQ.0)RETURN
      I=IL(M)
      J=IU(M)
  380 JMI=J-I
      IF(JMI.GE.11)GOTO310
      IF(I.EQ.1)GOTO305
      I=I-1
  390 I=I+1
      IF(I.EQ.J)GOTO370
      AMED=XS(I+1)
      BMED=YC(I+1)
      IF(XS(I).LE.AMED)GOTO390
      K=I
  395 XS(K+1)=XS(K)
      YC(K+1)=YC(K)
      K=K-1
      IF(AMED.LT.XS(K))GOTO395
      XS(K+1)=AMED
      YC(K+1)=BMED
      GOTO390
      END
      SUBROUTINE SORTC5(X,Y,N,XS,YC)
C
C     PURPOSE--THIS SUBROUTINE SORTS (IN ASCENDING ORDER)
C              THE N ELEMENTS OF THE SINGLE PRECISION VECTOR X,
C              PUTS THE RESULTING N SORTED VALUES INTO THE
C              SINGLE PRECISION VECTOR XS,
C              REARRANGES THE ELEMENTS OF THE VECTOR Y
C              (ACCORDING TO THE SORT ON X),
C              AND PUTS THE REARRANGED Y VALUES
C              INTO THE SINGLE PRECISION VECTOR YC.
C              THIS SUBROUTINE GIVES THE DATA ANALYST
C              THE ABILITY TO SORT ONE DATA VECTOR
C              WHILE 'CARRYING ALONG' THE ELEMENTS
C              OF A SECOND DATA VECTOR.
C
C              NOTE: THIS IS A COPY OF SORTC WHERE THE X AND
C                    XS ARRAYS ARE INTEGER RATHER THAN REAL.
C                    USE THIS TO AVOID WARNING MESSAGES ON THE
C                    COMPILE.
C
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF
C                                OBSERVATIONS TO BE SORTED.
C                     --Y      = THE SINGLE PRECISION VECTOR OF
C                                OBSERVATIONS TO BE 'CARRIED ALONG',
C                                THAT IS, TO BE REARRANGED ACCORDING
C                                TO THE SORT ON X.
C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR X.
C     OUTPUT ARGUMENTS--XS     = THE SINGLE PRECISION VECTOR
C                                INTO WHICH THE SORTED DATA VALUES
C                                FROM X WILL BE PLACED.
C                     --YC     = THE SINGLE PRECISION VECTOR
C                                INTO WHICH THE REARRANGED
C                                (ACCORDING TO THE SORT OF THE
C                                VECTOR X) VALUES OF THE VECTOR Y
C                                WILL BE PLACED.
C     OUTPUT--THE SINGLE PRECISION VECTOR XS
C             CONTAINING THE SORTED
C             (IN ASCENDING ORDER) VALUES
C             OF THE SINGLE PRECISION VECTOR X, AND
C             THE SINGLE PRECISION VECTOR YC
C             CONTAINING THE REARRANGED
C             (ACCORDING TO THE SORT ON X)
C             VALUES OF THE VECTOR Y.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THE DIMENSIONS OF THE VECTORS IL AND IU
C                   (DEFINED AND USED INTERNALLY WITHIN
C                   THIS SUBROUTINE) DICTATE THE MAXIMUM
C                   ALLOWABLE VALUE OF N FOR THIS SUBROUTINE.
C                   IF IL AND IU EACH HAVE DIMENSION K,
C                   THEN N MAY NOT EXCEED 2**(K+1) - 1.
C                   FOR THIS SUBROUTINE AS WRITTEN, THE DIMENSIONS
C                   OF IL AND IU HAVE BEEN SET TO 36,
C                   THUS THE MAXIMUM ALLOWABLE VALUE OF N IS
C                   APPROXIMATELY 137 BILLION.
C                   SINCE THIS EXCEEDS THE MAXIMUM ALLOWABLE
C                   VALUE FOR AN INTEGER VARIABLE IN MANY COMPUTERS,
C                   AND SINCE A SORT OF 137 BILLION ELEMENTS
C                   IS PRESENTLY IMPRACTICAL AND UNLIKELY,
C                   THEN THERE IS NO PRACTICAL RESTRICTION
C                   ON THE MAXIMUM VALUE OF N FOR THIS SUBROUTINE.
C                   (IN LIGHT OF THE ABOVE, NO CHECK OF THE
C                   UPPER LIMIT OF N HAS BEEN INCORPORATED
C                   INTO 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     COMMENT--THE SMALLEST ELEMENT OF THE VECTOR X
C              WILL BE PLACED IN THE FIRST POSITION
C              OF THE VECTOR XS,
C              THE SECOND SMALLEST ELEMENT IN THE VECTOR X
C              WILL BE PLACED IN THE SECOND POSITION
C              OF THE VECTOR XS,
C              ETC.
C     COMMENT--THE ELEMENT IN THE VECTOR Y CORRESPONDING
C              TO THE SMALLEST ELEMENT IN X
C              WILL BE PLACED IN THE FIRST POSITION
C              OF THE VECTOR YC,
C              THE ELEMENT IN THE VECTOR Y CORRESPONDING
C              TO THE SECOND SMALLEST ELEMENT IN X
C              WILL BE PLACED IN THE SECOND POSITION
C              OF THE VECTOR YC,
C              ETC.
C     COMMENT--THE INPUT VECTOR X REMAINS UNALTERED.
C     COMMENT--IF THE ANALYST DESIRES A SORT 'IN PLACE',
C              THIS IS DONE BY HAVING THE SAME
C              OUTPUT VECTOR AS INPUT VECTOR IN THE CALLING SEQUENCE.
C              THUS, FOR EXAMPLE, THE CALLING SEQUENCE
C              CALL SORTC(X,Y,N,X,YC)
C              IS ALLOWABLE AND WILL RESULT IN
C              THE DESIRED 'IN-PLACE' SORT.
C     COMMENT--THE SORTING ALGORTHM USED HEREIN
C              IS THE BINARY SORT.
C              THIS ALGORTHIM IS EXTREMELY FAST AS THE
C              FOLLOWING TIME TRIALS INDICATE.
C              THESE TIME TRIALS WERE CARRIED OUT ON THE
C              UNIVAC 1108 EXEC 8 SYSTEM AT NBS
C              IN AUGUST OF 1974.
C              BY WAY OF COMPARISON, THE TIME TRIAL VALUES
C              FOR THE EASY-TO-PROGRAM BUT EXTREMELY
C              INEFFICIENT BUBBLE SORT ALGORITHM HAVE
C              ALSO BEEN INCLUDED--
C              NUMBER OF RANDOM        BINARY SORT       BUBBLE SORT
C               NUMBERS SORTED
C                N = 10                 .002 SEC          .002 SEC
C                N = 100                .011 SEC          .045 SEC
C                N = 1000               .141 SEC         4.332 SEC
C                N = 3000               .476 SEC        37.683 SEC
C                N = 10000             1.887 SEC      NOT COMPUTED
C     REFERENCES--CACM MARCH 1969, PAGE 186 (BINARY SORT ALGORITHM
C                 BY RICHARD C. SINGLETON).
C               --CACM JANUARY 1970, PAGE 54.
C               --CACM OCTOBER 1970, PAGE 624.
C               --JACM JANUARY 1961, PAGE 41.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (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         --NOVEMBER  1975.
C     UPDATED         --JUNE      1981.
C     UPDATED         --MAY       1982.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      INTEGER X(*),XS(*)
      REAL Y(*),YC(*)
CCCCC INTEGER BMED
      DIMENSION IU(36),IL(36)
C
      INTEGER HOLD
      INTEGER AMED
      INTEGER TX
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)THEN
        WRITE(ICOUT,15)
   15   FORMAT('***** ERROR--THE SECOND ARGUMENT TO SORTC5 ',
     1         'IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
   47   FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,'.')
        CALL DPWRST('XXX','BUG ')
        RETURN
      ELSEIF(N.EQ.1)THEN
CCCCC   WRITE(ICOUT,18)
CCC18 FORMAT('***** WARNING--THE SECOND ARGUMENT ',
CCCCC1       'TO SORTC5 HAS THE VALUE 1.')
CCCCC   CALL DPWRST('XXX','BUG ')
        XS(1)=X(1)
        YC(1)=Y(1)
        RETURN
      ENDIF
C
      HOLD=X(1)
      DO60I=2,N
        IF(X(I).NE.HOLD)GOTO90
   60 CONTINUE
CCCCC WRITE(ICOUT, 9)HOLD
CCCC9 FORMAT('***** NON-FATAL DIAGNOSTIC--THE 1ST INPUT ARGUMENT ',
CCCCC1'(A VECTOR) TO THE SORTC  SUBROUTINE HAS ALL ELEMENTS = ',E15.8)
CCCCC CALL DPWRST('XXX','BUG ')
      DO61I=1,N
        XS(I)=X(I)
        YC(I)=Y(I)
   61 CONTINUE
      RETURN
C
   90 CONTINUE
C     COPY THE VECTOR X INTO THE VECTOR XS
      DO100I=1,N
      XS(I)=X(I)
  100 CONTINUE
C
C     COPY THE VECTOR Y INTO THE VECTOR YS
C
      DO150I=1,N
      YC(I)=Y(I)
  150 CONTINUE
C
C     CHECK TO SEE IF THE INPUT VECTOR IS ALREADY SORTED
C
      NM1=N-1
      DO200I=1,NM1
      IP1=I+1
      IF(XS(I).LE.XS(IP1))GOTO200
      GOTO250
  200 CONTINUE
      RETURN
  250 M=1
      I=1
      J=N
  305 IF(I.GE.J)GOTO370
  310 K=I
      MID=(I+J)/2
      AMED=XS(MID)
      BMED=YC(MID)
      IF(XS(I).LE.AMED)GOTO320
      XS(MID)=XS(I)
      YC(MID)=YC(I)
      XS(I)=AMED
      YC(I)=BMED
      AMED=XS(MID)
      BMED=YC(MID)
  320 L=J
      IF(XS(J).GE.AMED)GOTO340
      XS(MID)=XS(J)
      YC(MID)=YC(J)
      XS(J)=AMED
      YC(J)=BMED
      AMED=XS(MID)
      BMED=YC(MID)
      IF(XS(I).LE.AMED)GOTO340
      XS(MID)=XS(I)
      YC(MID)=YC(I)
      XS(I)=AMED
      YC(I)=BMED
      AMED=XS(MID)
      BMED=YC(MID)
      GOTO340
  330 XS(L)=XS(K)
      YC(L)=YC(K)
      XS(K)=TX
      YC(K)=TY
  340 L=L-1
      IF(XS(L).GT.AMED)GOTO340
      TX=XS(L)
      TY=YC(L)
  350 K=K+1
      IF(XS(K).LT.AMED)GOTO350
      IF(K.LE.L)GOTO330
      LMI=L-I
      JMK=J-K
      IF(LMI.LE.JMK)GOTO360
      IL(M)=I
      IU(M)=L
      I=K
      M=M+1
      GOTO380
  360 IL(M)=K
      IU(M)=J
      J=L
      M=M+1
      GOTO380
  370 M=M-1
      IF(M.EQ.0)RETURN
      I=IL(M)
      J=IU(M)
  380 JMI=J-I
      IF(JMI.GE.11)GOTO310
      IF(I.EQ.1)GOTO305
      I=I-1
  390 I=I+1
      IF(I.EQ.J)GOTO370
      AMED=XS(I+1)
      BMED=YC(I+1)
      IF(XS(I).LE.AMED)GOTO390
      K=I
  395 XS(K+1)=XS(K)
      YC(K+1)=YC(K)
      K=K-1
      IF(AMED.LT.XS(K))GOTO395
      XS(K+1)=AMED
      YC(K+1)=BMED
      GOTO390
      END
      SUBROUTINE SORTDE(X,N,Y)
C
C     PURPOSE--THIS SUBROUTINE SORTS (IN DESCENDING ORDER)
C              THE N ELEMENTS OF THE SINGLE PRECISION VECTOR X
C              AND PUTS THE RESULTING N SORTED VALUES INTO THE
C              SINGLE PRECISION VECTOR Y.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF
C                                OBSERVATIONS TO BE SORTED.
C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR X.
C     OUTPUT ARGUMENTS--Y      = THE SINGLE PRECISION VECTOR
C                                INTO WHICH THE SORTED DATA VALUES
C                                FROM X WILL BE PLACED.
C     OUTPUT--THE SINGLE PRECISION VECTOR Y
C             CONTAINING THE SORTED
C             (IN ASCENDING ORDER) VALUES
C             OF THE SINGLE PRECISION VECTOR X.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THE DIMENSIONS OF THE VECTORS IL AND IU
C                   (DEFINED AND USED INTERNALLY WITHIN
C                   THIS SUBROUTINE) DICTATE THE MAXIMUM
C                   ALLOWABLE VALUE OF N FOR THIS SUBROUTINE.
C                   IF IL AND IU EACH HAVE DIMENSION K,
C                   THEN N MAY NOT EXCEED 2**(K+1) - 1.
C                   FOR THIS SUBROUTINE AS WRITTEN, THE DIMENSIONS
C                   OF IL AND IU HAVE BEEN SET TO 36,
C                   THUS THE MAXIMUM ALLOWABLE VALUE OF N IS
C                   APPROXIMATELY 137 BILLION.
C                   SINCE THIS EXCEEDS THE MAXIMUM ALLOWABLE
C                   VALUE FOR AN INTEGER VARIABLE IN MANY COMPUTERS,
C                   AND SINCE A SORT OF 137 BILLION ELEMENTS
C                   IS PRESENTLY IMPRACTICAL AND UNLIKELY,
C                   THEN THERE IS NO PRACTICAL RESTRICTION
C                   ON THE MAXIMUM VALUE OF N FOR THIS SUBROUTINE.
C                   (IN LIGHT OF THE ABOVE, NO CHECK OF THE
C                   UPPER LIMIT OF N HAS BEEN INCORPORATED
C                   INTO 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     COMMENT--THE SMALLEST ELEMENT OF THE VECTOR X
C              WILL BE PLACED IN THE FIRST POSITION
C              OF THE VECTOR Y,
C              THE SECOND SMALLEST ELEMENT IN THE VECTOR X
C              WILL BE PLACED IN THE SECOND POSITION
C              OF THE VECTOR Y, ETC.
C     COMMENT--THE INPUT VECTOR X REMAINS UNALTERED.
C     COMMENT--IF THE ANALYST DESIRES A SORT 'IN PLACE',
C              THIS IS DONE BY HAVING THE SAME
C              OUTPUT VECTOR AS INPUT VECTOR IN THE CALLING SEQUENCE.
C              THUS, FOR EXAMPLE, THE CALLING SEQUENCE
C              CALL SORT(X,N,X)
C              IS ALLOWABLE AND WILL RESULT IN
C              THE DESIRED 'IN-PLACE' SORT.
C     COMMENT--THE SORTING ALGORTHM USED HEREIN
C              IS THE  QUICKSORT.
C              THIS ALGORTHIM IS EXTREMELY FAST AS THE
C              FOLLOWING TIME TRIALS INDICATE.
C              THESE TIME TRIALS WERE CARRIED OUT ON THE
C              UNIVAC 1108 EXEC 8 SYSTEM AT NBS
C              IN AUGUST OF 1974.
C              BY WAY OF COMPARISON, THE TIME TRIAL VALUES
C              FOR THE EASY-TO-PROGRAM BUT EXTREMELY
C              INEFFICIENT BUBBLE SORT ALGORITHM HAVE
C              ALSO BEEN INCLUDED--
C              NUMBER OF RANDOM         QUICKSORT       BUBBLE SORT
C               NUMBERS SORTED
C                N = 10                 .002 SEC          .002 SEC
C                N = 100                .011 SEC          .045 SEC
C                N = 1000               .141 SEC         4.332 SEC
C                N = 3000               .476 SEC        37.683 SEC
C                N = 10000             1.887 SEC      NOT COMPUTED
C     REFERENCES--CACM MARCH 1969, PAGE 186 ( QUICKSORT ALGORITHM
C                 BY RICHARD C. SINGLETON).
C               --CACM JANUARY 1970, PAGE 54.
C               --CACM OCTOBER 1970, PAGE 624.
C               --JACM JANUARY 1961, PAGE 41.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (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 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
      DIMENSION Y(*)
C
      DIMENSION IU(36)
      DIMENSION IL(36)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='SORT'
      ISUBN2='DE  '
      IERROR='NO'
      IBUGA3='OFF'
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 SORT--')
      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               **  SORT THE VALUES.  **
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 SORT--',
     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
      IF(N.EQ.1)GOTO120
      GOTO129
  120 CONTINUE
CCCCC WRITE(ICOUT,999)
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC WRITE(ICOUT,121)
CC121 FORMAT('***** WARNING IN SORT--THE SECOND ',
CCCCC1       'ARGUMENT (N) HAS THE VALUE 1.')
CCCCC CALL DPWRST('XXX','BUG ')
      Y(1)=X(1)
      GOTO9000
  129 CONTINUE
C
      HOLD=X(1)
      DO135I=2,N
      IF(X(I).NE.HOLD)GOTO139
  135 CONTINUE
CCCCC WRITE(ICOUT,999)
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC WRITE(ICOUT,136)HOLD
CC136 FORMAT('***** WARNING IN SORT--THE FIRST ARGUMENT ',
CCCCC1       '(A VECTOR) HAS ALL ELEMENTS = ',G15.7)
CCCCC CALL DPWRST('XXX','BUG ')
      DO137I=1,N
      Y(I)=X(I)
  137 CONTINUE
      GOTO9000
  139 CONTINUE
C
C               *******************************************
C               **  STEP 2--                             **
C               **  COPY THE VECTOR X INTO THE VECTOR Y  **
C               *******************************************
C
      DO200I=1,N
      Y(I)=X(I)
  200 CONTINUE
C
      DO210I=1,N
      Y(I)=(-Y(I))
  210 CONTINUE
C
C               **********************************************************
C               **  STEP 3--                                            **
C               **  CHECK TO SEE IF THE INPUT VECTOR IS ALREADY SORTED  **
C               **********************************************************
C
      NM1=N-1
      DO250I=1,NM1
      IP1=I+1
      IF(Y(I).LE.Y(IP1))GOTO250
      GOTO290
  250 CONTINUE
      GOTO8000
  290 CONTINUE
C
C               ***************************
C               **  STEP 4--             **
C               **  CARRY OUT THE SORT.  **
C               ***************************
C
      M=1
      I=1
      J=N
  305 IF(I.GE.J)GOTO370
  310 K=I
      MID=(I+J)/2
      AMED=Y(MID)
      IF(Y(I).LE.AMED)GOTO320
      Y(MID)=Y(I)
      Y(I)=AMED
      AMED=Y(MID)
  320 L=J
      IF(Y(J).GE.AMED)GOTO340
      Y(MID)=Y(J)
      Y(J)=AMED
      AMED=Y(MID)
      IF(Y(I).LE.AMED)GOTO340
      Y(MID)=Y(I)
      Y(I)=AMED
      AMED=Y(MID)
      GOTO340
  330 Y(L)=Y(K)
      Y(K)=TT
  340 L=L-1
      IF(Y(L).GT.AMED)GOTO340
      TT=Y(L)
  350 K=K+1
      IF(Y(K).LT.AMED)GOTO350
      IF(K.LE.L)GOTO330
      LMI=L-I
      JMK=J-K
      IF(LMI.LE.JMK)GOTO360
      IL(M)=I
      IU(M)=L
      I=K
      M=M+1
      GOTO380
  360 IL(M)=K
      IU(M)=J
      J=L
      M=M+1
      GOTO380
  370 M=M-1
      IF(M.EQ.0)GOTO8000
      I=IL(M)
      J=IU(M)
  380 JMI=J-I
      IF(JMI.GE.11)GOTO310
      IF(I.EQ.1)GOTO305
      I=I-1
  390 I=I+1
      IF(I.EQ.J)GOTO370
      AMED=Y(I+1)
      IF(Y(I).LE.AMED)GOTO390
      K=I
  395 Y(K+1)=Y(K)
      K=K-1
      IF(AMED.LT.Y(K))GOTO395
      Y(K+1)=AMED
      GOTO390
C
 8000 CONTINUE
      DO8100I=1,N
      Y(I)=(-Y(I))
 8100 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 SORT--')
      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 ')
      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 SORTI(X,N,XS,AINDEX)
C
C     PURPOSE--THIS SUBROUTINE SORTS (IN ASCENDING ORDER)
C              THE N ELEMENTS OF THE SINGLE PRECISION VECTOR X,
C              PUTS THE RESULTING N SORTED VALUES INTO THE
C              SINGLE PRECISION VECTOR XS, AND
C              REARRANGES THE ELEMENTS 1, 2, ..., N OF VECTOR AINDEX
C              (ACCORDING TO THE SORT ON X).
C              THIS SUBROUTINE GIVES THE DATA ANALYST
C              THE ABILITY TO SORT ONE DATA VECTOR
C              WHILE DETERMINING THE POSITION INDEX
C              AFTER-THE-FACT, SO AS TO SUBSEQUENTLY
C              'CARRY ALONG' THE ELEMENTS
C              OF MANY OTHER DATA VECTORS (DONE ELSEWHERE).
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF
C                                OBSERVATIONS TO BE SORTED.
C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR X.
C     OUTPUT ARGUMENTS--XS     = THE SINGLE PRECISION VECTOR
C                                INTO WHICH THE SORTED DATA VALUES
C                                FROM X WILL BE PLACED.
C                     --AINDEX = THE SINGLE PRECISION VECTOR
C                                INTO WHICH THE REARRANGED
C                                (ACCORDING TO THE SORT OF THE
C                                VECTOR X) VALUES OF 1, 2, ..., N
C                                WILL BE PLACED.
C     OUTPUT--THE SINGLE PRECISION VECTOR XS
C             CONTAINING THE SORTED
C             (IN ASCENDING ORDER) VALUES
C             OF THE SINGLE PRECISION VECTOR X, AND
C             THE SINGLE PRECISION VECTOR AINDEX
C             CONTAINING THE REARRANGED
C             (ACCORDING TO THE SORT ON X)
C             VALUES OF 1, 2, ..., N.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THE DIMENSIONS OF THE VECTORS IL AND IU
C                   (DEFINED AND USED INTERNALLY WITHIN
C                   THIS SUBROUTINE) DICTATE THE MAXIMUM
C                   ALLOWABLE VALUE OF N FOR THIS SUBROUTINE.
C                   IF IL AND IU EACH HAVE DIMENSION K,
C                   THEN N MAY NOT EXCEED 2**(K+1) - 1.
C                   FOR THIS SUBROUTINE AS WRITTEN, THE DIMENSIONS
C                   OF IL AND IU HAVE BEEN SET TO 36,
C                   THUS THE MAXIMUM ALLOWABLE VALUE OF N IS
C                   APPROXIMATELY 137 BILLION.
C                   SINCE THIS EXCEEDS THE MAXIMUM ALLOWABLE
C                   VALUE FOR AN INTEGER VARIABLE IN MANY COMPUTERS,
C                   AND SINCE A SORT OF 137 BILLION ELEMENTS
C                   IS PRESENTLY IMPRACTICAL AND UNLIKELY,
C                   THEN THERE IS NO PRACTICAL RESTRICTION
C                   ON THE MAXIMUM VALUE OF N FOR THIS SUBROUTINE.
C                   (IN LIGHT OF THE ABOVE, NO CHECK OF THE
C                   UPPER LIMIT OF N HAS BEEN INCORPORATED
C                   INTO 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     COMMENT--THE SMALLEST ELEMENT OF THE VECTOR X
C              WILL BE PLACED IN THE FIRST POSITION
C              OF THE VECTOR XS,
C              THE SECOND SMALLEST ELEMENT IN THE VECTOR X
C              WILL BE PLACED IN THE SECOND POSITION
C              OF THE VECTOR XS,
C              ETC.
C     COMMENT--AT THE END, AINDEX(1) WILL CONTAIN TBE ORIGINAL
C              POSITION NUMBER WHERE THE SMALLEST VALUE OF X DID RESIDE.
C          AINDEX(2) WILL CONTAIN THE ORIGINAL
C          POSITION NUMBER WHERE THE SECOND SMALLEST VALUE OF X DID RESIDE.
C          AINDEX(N) WILL CONTAIN THE ORIGINAL
C          POSITION NUMBER WHERE THE LARGEST VALUE OF X DID RESIDE.
C     COMMENT--THE INPUT VECTOR X REMAINS UNALTERED.
C     COMMENT--IF THE ANALYST DESIRES A SORT 'IN PLACE',
C              THIS IS DONE BY HAVING THE SAME
C              OUTPUT VECTOR AS INPUT VECTOR IN THE CALLING SEQUENCE.
C              THUS, FOR EXAMPLE, THE CALLING SEQUENCE
C              CALL SORTI(X,N,X,AINDEX)
C              IS ALLOWABLE AND WILL RESULT IN
C              THE DESIRED 'IN-PLACE' SORT.
C     COMMENT--THE SORTING ALGORTHM USED HEREIN
C              IS THE BINARY SORT.
C              THIS ALGORTHIM IS EXTREMELY FAST AS THE
C              FOLLOWING TIME TRIALS INDICATE.
C              THESE TIME TRIALS WERE CARRIED OUT ON THE
C              UNIVAC 1108 EXEC 8 SYSTEM AT NBS
C              IN AUGUST OF 1974.
C              BY WAY OF COMPARISON, THE TIME TRIAL VALUES
C              FOR THE EASY-TO-PROGRAM BUT EXTREMELY
C              INEFFICIENT BUBBLE SORT ALGORITHM HAVE
C              ALSO BEEN INCLUDED--
C              NUMBER OF RANDOM        BINARY SORT       BUBBLE SORT
C               NUMBERS SORTED
C                N = 10                 .002 SEC          .002 SEC
C                N = 100                .011 SEC          .045 SEC
C                N = 1000               .141 SEC         4.332 SEC
C                N = 3000               .476 SEC        37.683 SEC
C                N = 10000             1.887 SEC      NOT COMPUTED
C     REFERENCES--CACM MARCH 1969, PAGE 186 (BINARY SORT ALGORITHM
C                 BY RICHARD C. SINGLETON).
C               --CACM JANUARY 1970, PAGE 54.
C               --CACM OCTOBER 1970, PAGE 624.
C               --JACM JANUARY 1961, PAGE 41.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (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         --NOVEMBER  1975.
C     UPDATED         --JUNE      1981.
C     UPDATED         --MAY       1982.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*),XS(*),AINDEX(*)
      DIMENSION IU(36),IL(36)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)THEN
        WRITE(ICOUT,15)
   15   FORMAT('***** ERROR--THE SECOND ARGUMENT TO SORTI ',
     1         'IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
   47   FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,'.')
        CALL DPWRST('XXX','BUG ')
        RETURN
      ELSEIF(N.EQ.1)THEN
        XS(1)=X(1)
        AINDEX(1)=1
        RETURN
      ENDIF
C
      HOLD=X(1)
      DO60I=2,N
        IF(X(I).NE.HOLD)GOTO90
   60 CONTINUE
      DO61I=1,N
        XS(I)=X(I)
        AINDEX(I)=I
   61 CONTINUE
      RETURN
C
   90 CONTINUE
CCCC9 FORMAT('***** WARNING--THE FIRST ARGUMENT (A VECTOR) TO ',
CCCCC1       'THE SORTI  SUBROUTINE HAS ALL ELEMENTS = ',G15.7)
C
      NTEMP=0
C
C     COPY THE VECTOR X INTO THE VECTOR XS
C
      DO100I=1,N
        XS(I)=X(I)
  100 CONTINUE
C
C     COPY THE VECTOR INDEX INTO THE VECTOR INDEXS
C
      DO150I=1,N
        AINDEX(I)=I
  150 CONTINUE
C
C     CHECK TO SEE IF THE INPUT VECTOR IS ALREADY SORTED
C
      NM1=N-1
      DO200I=1,NM1
      IP1=I+1
      IF(XS(I).LE.XS(IP1))GOTO200
      GOTO250
  200 CONTINUE
      RETURN
  250 M=1
      I=1
      J=N
  305 IF(I.GE.J)GOTO370
  310 K=I
      MID=(I+J)/2
      AMED=XS(MID)
      BMED=AINDEX(MID)
      IF(XS(I).LE.AMED)GOTO320
      XS(MID)=XS(I)
      AINDEX(MID)=AINDEX(I)
      XS(I)=AMED
      AINDEX(I)=BMED
      AMED=XS(MID)
      BMED=AINDEX(MID)
  320 L=J
      IF(XS(J).GE.AMED)GOTO340
      XS(MID)=XS(J)
      AINDEX(MID)=AINDEX(J)
      XS(J)=AMED
      AINDEX(J)=BMED
      AMED=XS(MID)
      BMED=AINDEX(MID)
      IF(XS(I).LE.AMED)GOTO340
      XS(MID)=XS(I)
      AINDEX(MID)=AINDEX(I)
      XS(I)=AMED
      AINDEX(I)=BMED
      AMED=XS(MID)
      BMED=AINDEX(MID)
      GOTO340
  330 XS(L)=XS(K)
      AINDEX(L)=AINDEX(K)
      XS(K)=TX
      AINDEX(K)=TY
  340 L=L-1
      IF(XS(L).GT.AMED)GOTO340
      TX=XS(L)
      TY=AINDEX(L)
  350 K=K+1
      IF(XS(K).LT.AMED)GOTO350
      IF(K.LE.L)GOTO330
      LMI=L-I
      JMK=J-K
      IF(LMI.LE.JMK)GOTO360
      IL(M)=I
      IU(M)=L
      I=K
      M=M+1
      GOTO380
  360 IL(M)=K
      IU(M)=J
      J=L
      M=M+1
      GOTO380
  370 M=M-1
      IF(M.EQ.0)RETURN
      I=IL(M)
      J=IU(M)
  380 JMI=J-I
      IF(JMI.GE.11)GOTO310
      IF(I.EQ.1)GOTO305
      I=I-1
  390 I=I+1
      IF(I.EQ.J)GOTO370
      AMED=XS(I+1)
      BMED=AINDEX(I+1)
      IF(XS(I).LE.AMED)GOTO390
      K=I
  395 XS(K+1)=XS(K)
      AINDEX(K+1)=AINDEX(K)
      K=K-1
      IF(AMED.LT.XS(K))GOTO395
      XS(K+1)=AMED
      AINDEX(K+1)=BMED
      GOTO390
      END
      SUBROUTINE SORTII(X,N,XS,AINDEX)
C
C     PURPOSE--THIS SUBROUTINE SORTS (IN ASCENDING ORDER)
C              THE N ELEMENTS OF THE SINGLE PRECISION VECTOR X,
C              PUTS THE RESULTING N SORTED VALUES INTO THE
C              SINGLE PRECISION VECTOR XS, AND
C              REARRANGES THE ELEMENTS 1, 2, ..., N OF VECTOR AINDEX
C              (ACCORDING TO THE SORT ON X).
C              THIS SUBROUTINE GIVES THE DATA ANALYST
C              THE ABILITY TO SORT ONE DATA VECTOR
C              WHILE DETERMINING THE POSITION INDEX
C              AFTER-THE-FACT, SO AS TO SUBSEQUENTLY
C              'CARRY ALONG' THE ELEMENTS
C              OF MANY OTHER DATA VECTORS (DONE ELSEWHERE).
C
C              THIS ROUTINE IS IDENTICAL TO SORTII WITH THE
C              DIFFERENCE THAT THIS ROUTINE ASSUMES X, XS, AND
C              AINDEX ARE INTEGER RATHER THAN REAL.
C
C     INPUT  ARGUMENTS--X      = THE INTEGER VECTOR OF
C                                OBSERVATIONS TO BE SORTED.
C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR X.
C     OUTPUT ARGUMENTS--XS     = THE INTEGER VECTOR
C                                INTO WHICH THE SORTED DATA VALUES
C                                FROM X WILL BE PLACED.
C                     --AINDEX = THE INTEGER VECTOR
C                                INTO WHICH THE REARRANGED
C                                (ACCORDING TO THE SORT OF THE
C                                VECTOR X) VALUES OF 1, 2, ..., N
C                                WILL BE PLACED.
C     OUTPUT--THE SINGLE PRECISION VECTOR XS
C             CONTAINING THE SORTED
C             (IN ASCENDING ORDER) VALUES
C             OF THE SINGLE PRECISION VECTOR X, AND
C             THE SINGLE PRECISION VECTOR AINDEX
C             CONTAINING THE REARRANGED
C             (ACCORDING TO THE SORT ON X)
C             VALUES OF 1, 2, ..., N.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THE DIMENSIONS OF THE VECTORS IL AND IU
C                   (DEFINED AND USED INTERNALLY WITHIN
C                   THIS SUBROUTINE) DICTATE THE MAXIMUM
C                   ALLOWABLE VALUE OF N FOR THIS SUBROUTINE.
C                   IF IL AND IU EACH HAVE DIMENSION K,
C                   THEN N MAY NOT EXCEED 2**(K+1) - 1.
C                   FOR THIS SUBROUTINE AS WRITTEN, THE DIMENSIONS
C                   OF IL AND IU HAVE BEEN SET TO 36,
C                   THUS THE MAXIMUM ALLOWABLE VALUE OF N IS
C                   APPROXIMATELY 137 BILLION.
C                   SINCE THIS EXCEEDS THE MAXIMUM ALLOWABLE
C                   VALUE FOR AN INTEGER VARIABLE IN MANY COMPUTERS,
C                   AND SINCE A SORT OF 137 BILLION ELEMENTS
C                   IS PRESENTLY IMPRACTICAL AND UNLIKELY,
C                   THEN THERE IS NO PRACTICAL RESTRICTION
C                   ON THE MAXIMUM VALUE OF N FOR THIS SUBROUTINE.
C                   (IN LIGHT OF THE ABOVE, NO CHECK OF THE
C                   UPPER LIMIT OF N HAS BEEN INCORPORATED
C                   INTO 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     COMMENT--THE SMALLEST ELEMENT OF THE VECTOR X
C              WILL BE PLACED IN THE FIRST POSITION
C              OF THE VECTOR XS,
C              THE SECOND SMALLEST ELEMENT IN THE VECTOR X
C              WILL BE PLACED IN THE SECOND POSITION
C              OF THE VECTOR XS,
C              ETC.
C     COMMENT--AT THE END, AINDEX(1) WILL CONTAIN TBE ORIGINAL
C              POSITION NUMBER WHERE THE SMALLEST VALUE OF X DID RESIDE.
C          AINDEX(2) WILL CONTAIN THE ORIGINAL
C          POSITION NUMBER WHERE THE SECOND SMALLEST VALUE OF X DID RESIDE.
C          AINDEX(N) WILL CONTAIN THE ORIGINAL
C          POSITION NUMBER WHERE THE LARGEST VALUE OF X DID RESIDE.
C     COMMENT--THE INPUT VECTOR X REMAINS UNALTERED.
C     COMMENT--IF THE ANALYST DESIRES A SORT 'IN PLACE',
C              THIS IS DONE BY HAVING THE SAME
C              OUTPUT VECTOR AS INPUT VECTOR IN THE CALLING SEQUENCE.
C              THUS, FOR EXAMPLE, THE CALLING SEQUENCE
C              CALL SORTI(X,N,X,AINDEX)
C              IS ALLOWABLE AND WILL RESULT IN
C              THE DESIRED 'IN-PLACE' SORT.
C     COMMENT--THE SORTING ALGORTHM USED HEREIN
C              IS THE BINARY SORT.
C              THIS ALGORTHIM IS EXTREMELY FAST AS THE
C              FOLLOWING TIME TRIALS INDICATE.
C              THESE TIME TRIALS WERE CARRIED OUT ON THE
C              UNIVAC 1108 EXEC 8 SYSTEM AT NBS
C              IN AUGUST OF 1974.
C              BY WAY OF COMPARISON, THE TIME TRIAL VALUES
C              FOR THE EASY-TO-PROGRAM BUT EXTREMELY
C              INEFFICIENT BUBBLE SORT ALGORITHM HAVE
C              ALSO BEEN INCLUDED--
C              NUMBER OF RANDOM        BINARY SORT       BUBBLE SORT
C               NUMBERS SORTED
C                N = 10                 .002 SEC          .002 SEC
C                N = 100                .011 SEC          .045 SEC
C                N = 1000               .141 SEC         4.332 SEC
C                N = 3000               .476 SEC        37.683 SEC
C                N = 10000             1.887 SEC      NOT COMPUTED
C     REFERENCES--CACM MARCH 1969, PAGE 186 (BINARY SORT ALGORITHM
C                 BY RICHARD C. SINGLETON).
C               --CACM JANUARY 1970, PAGE 54.
C               --CACM OCTOBER 1970, PAGE 624.
C               --JACM JANUARY 1961, PAGE 41.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (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         --NOVEMBER  1975.
C     UPDATED         --JUNE      1981.
C     UPDATED         --MAY       1982.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      INTEGER X(*),XS(*),AINDEX(*)
      DIMENSION IU(36),IL(36)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)THEN
        WRITE(ICOUT,15)
   15   FORMAT('***** ERROR--THE SECOND ARGUMENT TO SORTII ',
     1         'IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
   47   FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,'.')
        CALL DPWRST('XXX','BUG ')
        RETURN
      ELSEIF(N.EQ.1)THEN
CCCCC   WRITE(ICOUT,18)
CCC18   FORMAT('***** WARNING--THE SECOND ARGUMENT TO SORTII ',
CCCCC1         'HAS THE VALUE 1.')
CCCCC   CALL DPWRST('XXX','BUG ')
        XS(1)=X(1)
        AINDEX(1)=1
        RETURN
      ENDIF
C
      IHOLD=X(1)
      DO60I=2,N
        IF(X(I).NE.IHOLD)GOTO90
   60 CONTINUE
      DO61I=1,N
        XS(I)=X(I)
        AINDEX(I)=I
   61 CONTINUE
      RETURN
   90 CONTINUE
C
C     COPY THE VECTOR X INTO THE VECTOR XS
      DO100I=1,N
        XS(I)=X(I)
  100 CONTINUE
C
C     COPY THE VECTOR INDEX INTO THE VECTOR INDEXS
C
      DO150I=1,N
        AINDEX(I)=I
  150 CONTINUE
C
C     CHECK TO SEE IF THE INPUT VECTOR IS ALREADY SORTED
C
      NM1=N-1
      DO200I=1,NM1
        IP1=I+1
        IF(XS(I).LE.XS(IP1))GOTO200
        GOTO250
  200 CONTINUE
      RETURN
  250 CONTINUE
      M=1
      I=1
      J=N
  305 CONTINUE
      IF(I.GE.J)GOTO370
  310 CONTINUE
      K=I
      MID=(I+J)/2
      AMED=REAL(XS(MID))
      BMED=REAL(AINDEX(MID))
      IF(XS(I).LE.INT(AMED+0.1))GOTO320
      XS(MID)=XS(I)
      AINDEX(MID)=AINDEX(I)
      XS(I)=INT(AMED+0.1)
      AINDEX(I)=INT(BMED+0.1)
      AMED=REAL(XS(MID))
      BMED=REAL(AINDEX(MID))
  320 L=J
      IF(XS(J).GE.INT(AMED+0.1))GOTO340
      XS(MID)=XS(J)
      AINDEX(MID)=AINDEX(J)
      XS(J)=INT(AMED+0.1)
      AINDEX(J)=INT(BMED+0.1)
      AMED=REAL(XS(MID))
      BMED=REAL(AINDEX(MID))
      IF(XS(I).LE.INT(AMED+0.1))GOTO340
      XS(MID)=XS(I)
      AINDEX(MID)=AINDEX(I)
      XS(I)=INT(AMED+0.1)
      AINDEX(I)=INT(BMED+0.1)
      AMED=REAL(XS(MID))
      BMED=REAL(AINDEX(MID))
      GOTO340
  330 CONTINUE
      XS(L)=XS(K)
      AINDEX(L)=AINDEX(K)
      XS(K)=INT(TX+0.1)
      AINDEX(K)=INT(TY+0.1)
  340 CONTINUE
      L=L-1
      IF(XS(L).GT.INT(AMED+0.1))GOTO340
      TX=REAL(XS(L))
      TY=REAL(AINDEX(L))
  350 CONTINUE
      K=K+1
      IF(XS(K).LT.INT(AMED+0.1))GOTO350
      IF(K.LE.L)GOTO330
      LMI=L-I
      JMK=J-K
      IF(LMI.LE.JMK)GOTO360
      IL(M)=I
      IU(M)=L
      I=K
      M=M+1
      GOTO380
  360 CONTINUE
      IL(M)=K
      IU(M)=J
      J=L
      M=M+1
      GOTO380
  370 CONTINUE
      M=M-1
      IF(M.EQ.0)RETURN
      I=IL(M)
      J=IU(M)
  380 CONTINUE
      JMI=J-I
      IF(JMI.GE.11)GOTO310
      IF(I.EQ.1)GOTO305
      I=I-1
  390 CONTINUE
      I=I+1
      IF(I.EQ.J)GOTO370
      AMED=REAL(XS(I+1))
      BMED=REAL(AINDEX(I+1))
      IF(XS(I).LE.INT(AMED+0.1))GOTO390
      K=I
  395 CONTINUE
      XS(K+1)=XS(K)
      AINDEX(K+1)=AINDEX(K)
      K=K-1
      IF(INT(AMED+0.1).LT.XS(K))GOTO395
      XS(K+1)=INT(AMED+0.1)
      AINDEX(K+1)=INT(BMED+0.1)
      GOTO390
      END
      SUBROUTINE SORTSH(X, N)
C
C        ALGORITHM AS 304.8 APPL.STATIST. (1996), VOL.45, NO.3
C
C        Sorts the N values stored in array X in ascending order
C
C        DATAPLOT NOTE: THIS IS A UTILITY ROUTINE USED BY
C                       FISHER TWO SAMPLE RANDOMIZATION TEST
C
      INTEGER N
      REAL X(N)
C
      INTEGER I, J, INCR
      REAL TEMP
C
      INCR = 1
C
C        Loop : calculate the increment
C
   10 INCR = 3 * INCR + 1
      IF (INCR .LE. N) GOTO 10

C
C        Loop : Shell-Metzner sort
C
   20 INCR = INCR / 3
      I = INCR + 1
   30 IF (I .GT. N) GOTO 60
      TEMP = X(I)
      J = I
   40 IF (X(J - INCR) .LT. TEMP) GOTO 50
      X(J) = X(J - INCR)
      J = J - INCR
      IF (J .GT. INCR) GOTO 40
   50 X(J) = TEMP
      I = I + 1
      GOTO 30
   60 IF (INCR .GT. 1) GOTO 20
C
      RETURN
      END
      SUBROUTINE SPANF1(EDGE1,EDGE2,NEDGE,Y,X,NVERT,IWRITE,
     1Y2,X2,TAG,NOUT,
     1IEDGE,IX,NV,IWORK1,
     1IBUGA3,IERROR)
C
C     PURPOSE--IMPLEMENTS THE COMMAND
C
C                 LET Y1 Y2 TAG = SPANNING FOREST EDGE1 EDGE2 Y X
C
C              WHERE EDGE1 AND EDGE2 DEFINE A LIST OF EDGES
C              AND Y AND X ARE THE COORDINATES FOR THE VERTICES.
C
C              NOTE THAT THIS FORM OF THE COMMAND IS MOST USEFUL
C              WHEN THE PRIMARY GOAL IS TO GENERATE A PLOT OF
C              THE SPANNING FOREST (I.E., THE CONNECTED COMPONENTS
C              OF THE GRAPH).
C
C     EXAMPLES--LET Y2 X2 TAG = SPANNING FOREST E1 E2 Y X
C     INPUT  ARGUMENTS--EDGE1  VECTOR IDENTIFYING FIRST VERTEX IN EDGE
C                       EDGE2  VECTOR IDENTIFYING SECOND VERTEX IN EDGE
C                       NEDGE  NUMBER OF EDGES
C                       Y      VECTOR CONTAINING Y-COORDINATE OF
C                              VERTICES
C                       X      VECTOR CONTAINING X-COORDINATE OF
C                              VERTICES
C                       X      X-AXIS VECTOR
C                       NVERT  NUMBER OF VERTICES
C     REFERENCE--NIJENHUIS, ALBERT AND WILF, HERBERT S., 'COMBINATORIAL
C                ALGORITHMS', ACADEMIC PRESS, 1975, PP. 106-108.
C     OUTPUT ARGUMENTS--Y2     Y-AXIS VECTOR OF THE NEW VERTICES
C                       X2     X-AXIS VECTOR OF THE NEW VERTICES
C                       TAG    VECTOR IDENTIFYING PAIRS OF VERTICES
C                       NOUT   NUMBER OF VERTICES IN OUTPUT MATRIX
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2008/8
C     ORIGINAL VERSION--JUNE     2008.
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
      DIMENSION EDGE1(*)
      DIMENSION EDGE2(*)
      DIMENSION Y(*)
      DIMENSION X(*)
      DIMENSION Y2(*)
      DIMENSION X2(*)
      DIMENSION TAG(*)
C
      INTEGER IEDGE(*)
      INTEGER IX(*)
      INTEGER NV(*)
      INTEGER IWORK1(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='SPAN'
      ISUBN2='F1  '
      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 SPANF1--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,52)IBUGA3,IWRITE,NEDGE,NVERT
   52   FORMAT('IBUGA3,IWRITE,NEDGE,NVERT = ',A4,2X,A4,2X,2I10)
        CALL DPWRST('XXX','BUG ')
        DO55I=1,NEDGE
          WRITE(ICOUT,56)I,EDGE1(I),EDGE2(I)
   56     FORMAT('I,EDGE1(I),EDGE2(I) = ',I8,2G15.7)
          CALL DPWRST('XXX','BUG ')
   55   CONTINUE
        DO65I=1,NVERT
          WRITE(ICOUT,66)I,Y(I),X(I)
   66     FORMAT('I,Y(I),X(I) = ',I8,2G15.7)
          CALL DPWRST('XXX','BUG ')
   65   CONTINUE
      ENDIF
C
C               ******************************************
C               **  STEP 1: CHECK THAT VERTICES ARE IN  **
C               **          THE RANGE (1,NVERT)         **
C               ******************************************
C
      DO100I=1,NEDGE
        ITEMP1=INT(EDGE1(I)+0.01)
        IF(ITEMP1.LT.1 .OR. ITEMP1.GT.NVERT)THEN
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,101)
  101     FORMAT('***** ERROR FROM SPANNING FOREST--')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,103)I
  103     FORMAT('      THE FIRST VERTEX FOR EDGE ',I8,' IS LESS ',
     1           'THAN ONE')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,105)NVERT
  105     FORMAT('      OR GREATER THAN THE NUMBER OF VERTICES (',I8,
     1           ').')
          CALL DPWRST('XXX','BUG ')
          IERROR='YES'
          GOTO9000
        ENDIF
C
        ITEMP2=INT(EDGE2(I)+0.01)
        IF(ITEMP2.LT.1 .OR. ITEMP2.GT.NVERT)THEN
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,101)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,113)I
  113     FORMAT('      THE SECOND VERTEX FOR EDGE ',I8,' IS LESS THAN')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,105)NVERT
          CALL DPWRST('XXX','BUG ')
          IERROR='YES'
          GOTO9000
        ENDIF
C
  100 CONTINUE
C
C               ******************************************
C               **  STEP 2: PREPARE INPUT FOR SPANFO    **
C               **          ROUTINE                     **
C               ******************************************
C
      DO200I=1,NEDGE
        IT1=(I-1)*2 + 1
        IT2=I*2
        IEDGE(IT1)=INT(EDGE1(I)+0.1)
        IEDGE(IT2)=INT(EDGE2(I)+0.1)
  200 CONTINUE
C
      CALL SPANFO(NVERT,NEDGE,IEDGE,K,IX,NV,IWORK1)
C
      IF(IBUGA3.EQ.'ON')THEN
        WRITE(ICOUT,223)K
  223   FORMAT('AFTER CALL TO SPANFO: K = ',I8)
        CALL DPWRST('XXX','BUG ')
        DO230I=1,NEDGE
          IT1=(I-1)*2 + 1
          IT2=I*2
          WRITE(ICOUT,231)I,IEDGE(IT1),IEDGE(IT2)
  231     FORMAT('I,IEDGE(1,I),IEDGE(2,I) = ',3I8)
          CALL DPWRST('XXX','BUG ')
  230   CONTINUE
        DO240I=1,NVERT
          WRITE(ICOUT,241)I,IX(I)
  241     FORMAT('I,IX(I) = ',2I8)
          CALL DPWRST('XXX','BUG ')
  240   CONTINUE
        DO250I=1,K
          WRITE(ICOUT,251)I,NV(I)
  251     FORMAT('I,NV(I) = ',2I8)
          CALL DPWRST('XXX','BUG ')
  250   CONTINUE
      ENDIF
C
C               ******************************************
C               **  STEP 3: CONVERT SPANFO OUTPOUT TO   **
C               **          FORM WE WANT                **
C               ******************************************
C
      ICNT1=0
      ICNT2=0
C
      DO300IK=1,K
        ATAG=REAL(IK)
        IPTS=NV(IK)-1
C
        IF(IBUGA3.EQ.'ON')THEN
          WRITE(ICOUT,301)IK,IPTS,ATAG
  301     FORMAT('IK,IPTS,ATAG = ',2I8,G15.7)
          CALL DPWRST('XXX','BUG ')
        ENDIF
C
        IF(IPTS.GE.1)THEN
          DO310I=1,IPTS
            ICNT2=ICNT2+1
            IT1=(ICNT2-1)*2 + 1
            IT2=ICNT2*2
            ITEMP1=IEDGE(IT1)
            ITEMP2=IEDGE(IT2)
C
            IF(IBUGA3.EQ.'ON')THEN
              WRITE(ICOUT,311)I,IT1,IT2,ITEMP1,ITEMP2
  311         FORMAT('I,IT1,IT2,ITEMP1,ITEMP2 = ',5I8)
              CALL DPWRST('XXX','BUG ')
              WRITE(ICOUT,313)Y(ITEMP1),X(ITEMP1)
  313         FORMAT('Y(ITEMP1),X(ITEMP1) = ',2G15.7)
              CALL DPWRST('XXX','BUG ')
              WRITE(ICOUT,314)Y(ITEMP2),X(ITEMP2)
  314         FORMAT('Y(ITEMP2),X(ITEMP2) = ',2G15.7)
              CALL DPWRST('XXX','BUG ')
            ENDIF
C
            ICNT1=ICNT1+1
            Y2(ICNT1)=Y(ITEMP1)
            X2(ICNT1)=X(ITEMP1)
            TAG(ICNT1)=ATAG
C
            IF(IBUGA3.EQ.'ON')THEN
              WRITE(ICOUT,315)ICNT1,Y2(ICNT1),X2(ICNT1)
  315         FORMAT('ICNT1,Y2(ICNT1),X2(ICNT1) = ',I8,2G15.7)
              CALL DPWRST('XXX','BUG ')
            ENDIF
C
            ICNT1=ICNT1+1
            Y2(ICNT1)=Y(ITEMP2)
            X2(ICNT1)=X(ITEMP2)
            TAG(ICNT1)=ATAG
C
            IF(IBUGA3.EQ.'ON')THEN
              WRITE(ICOUT,315)ICNT1,Y2(ICNT1),X2(ICNT1)
              CALL DPWRST('XXX','BUG ')
            ENDIF
C
  310     CONTINUE
        ELSE
          DO320I=1,NVERT
            IF(IK.EQ.IX(I))THEN
              ICNT1=ICNT1+1
              Y2(ICNT1)=Y(IX(I))
              X2(ICNT1)=X(IX(I))
              TAG(ICNT1)=ATAG
              GOTO329
            ENDIF
  320     CONTINUE
  329     CONTINUE
        ENDIF
  300 CONTINUE
C
      NOUT=ICNT1
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
C
      IF(IBUGA3.EQ.'ON')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END OF SPANF1--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9014)NOUT
 9014   FORMAT('NOUT = ',I8)
        CALL DPWRST('XXX','BUG ')
        DO9015I=1,NOUT
          WRITE(ICOUT,9016)I,Y2(I),X2(I),TAG(I)
 9016     FORMAT('I,Y2(I),X2(I),TAG(I) = ',I8,3G15.7)
          CALL DPWRST('XXX','BUG ')
 9015   CONTINUE
      ENDIF
C
      RETURN
      END
      SUBROUTINE SPANF2(EDGE1,EDGE2,NEDGE,NVERT,IWRITE,
     1IEDGE,IX,NV,K,IWORK1,
     1IBUGA3,IERROR)
C
C     PURPOSE--IMPLEMENTS THE COMMAND
C
C              LET EDGE1 EDGE2 TAG NV = SPANNING FOREST EDGE1 EDGE2 NVERT
C
C              WHERE EDGE1 AND EDGE2 DEFINE A LIST OF EDGES
C              AND NVERT IS THE NUMBER OF VERTICES.
C
C              NOTE THAT THIS FORM OF THE COMMAND RETURNS THE
C              OUTPUT AS GIVEN BY THE SPANFO ROUTINE.
C              THE SPANNING FOREST (I.E., THE CONNECTED COMPONENTS
C              OF THE GRAPH).
C
C     EXAMPLES--LET Y2 X2 TAG = SPANNING FOREST E1 E2 Y X
C     INPUT  ARGUMENTS--EDGE1  VECTOR IDENTIFYING FIRST VERTEX IN EDGE
C                       EDGE2  VECTOR IDENTIFYING SECOND VERTEX IN EDGE
C                       NEDGE  NUMBER OF EDGES
C                       NVERT  NUMBER OF VERTICES
C     OUTPUT ARGUMENTS--EDGE1  RE-ARRANGED FIRST VERTEX IN EDGE
C                       EDGE2  RE-ARRANGED SECOND VERTEX IN EDGE
C                       IX     INTEGER VECTOR THAT IDENTIFIES WHICH
C                              COMPONENT THE I-TH VERTEX BELONGS TO
C                       NV     INTEGER VECTOR THAT IDENTIFIES THEES
C                              NUMBER OF EDGES IN EACH COMPONENT
C                       K      AN INTEGER SCALAR THAT IDENTIFIES THE
C                              THE NUMBER OF COMPONENTS
C     REFERENCE--NIJENHUIS, ALBERT AND WILF, HERBERT S., 'COMBINATORIAL
C                ALGORITHMS', ACADEMIC PRESS, 1975, PP. 106-108.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2008/8
C     ORIGINAL VERSION--JUNE     2008.
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
      DIMENSION EDGE1(*)
      DIMENSION EDGE2(*)
C
      INTEGER IEDGE(*)
      INTEGER IX(*)
      INTEGER NV(*)
      INTEGER IWORK1(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='SPAN'
      ISUBN2='F2  '
      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 SPANF2--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,52)IBUGA3,IWRITE,NEDGE,NVERT
   52   FORMAT('IBUGA3,IWRITE,NEDGE,NVERT = ',A4,2X,A4,2X,2I10)
        CALL DPWRST('XXX','BUG ')
        DO55I=1,NEDGE
          WRITE(ICOUT,56)I,EDGE1(I),EDGE2(I)
   56     FORMAT('I,EDGE1(I),EDGE2(I) = ',I8,2G15.7)
          CALL DPWRST('XXX','BUG ')
   55   CONTINUE
      ENDIF
C
C               ******************************************
C               **  STEP 1: CHECK THAT VERTICES ARE IN  **
C               **          THE RANGE (1,NVERT)         **
C               ******************************************
C
      DO100I=1,NEDGE
        ITEMP1=INT(EDGE1(I)+0.01)
        IF(ITEMP1.LT.1 .OR. ITEMP1.GT.NVERT)THEN
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,101)
  101     FORMAT('***** ERROR FROM SPANNING FOREST--')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,103)I
  103     FORMAT('      THE FIRST VERTEX FOR EDGE ',I8,' IS LESS ',
     1           'THAN ONE')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,105)NVERT
  105     FORMAT('      OR GREATER THAN THE NUMBER OF VERTICES (',I8,
     1           ').')
          CALL DPWRST('XXX','BUG ')
          IERROR='YES'
          GOTO9000
        ENDIF
C
        ITEMP2=INT(EDGE2(I)+0.01)
        IF(ITEMP2.LT.1 .OR. ITEMP2.GT.NVERT)THEN
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,101)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,113)I
  113     FORMAT('      THE SECOND VERTEX FOR EDGE ',I8,' IS LESS THAN')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,105)NVERT
          CALL DPWRST('XXX','BUG ')
          IERROR='YES'
          GOTO9000
        ENDIF
C
  100 CONTINUE
C
C               ******************************************
C               **  STEP 2: PREPARE INPUT FOR SPANFO    **
C               **          ROUTINE                     **
C               ******************************************
C
      DO200I=1,NEDGE
        IT1=(I-1)*2 + 1
        IT2=I*2
        IEDGE(IT1)=INT(EDGE1(I)+0.1)
        IEDGE(IT2)=INT(EDGE2(I)+0.1)
  200 CONTINUE
C
      CALL SPANFO(NVERT,NEDGE,IEDGE,K,IX,NV,IWORK1)
C
      IF(IBUGA3.EQ.'ON')THEN
        WRITE(ICOUT,223)K
  223   FORMAT('AFTER CALL TO SPANFO: K = ',I8)
        CALL DPWRST('XXX','BUG ')
        DO230I=1,NEDGE
          IT1=(I-1)*2 + 1
          IT2=I*2
          WRITE(ICOUT,231)I,IEDGE(IT1),IEDGE(IT2)
  231     FORMAT('I,IEDGE(1,I),IEDGE(2,I) = ',3I8)
          CALL DPWRST('XXX','BUG ')
  230   CONTINUE
        DO240I=1,NVERT
          WRITE(ICOUT,241)I,IX(I)
  241     FORMAT('I,IX(I) = ',2I8)
          CALL DPWRST('XXX','BUG ')
  240   CONTINUE
        DO250I=1,K
          WRITE(ICOUT,251)I,NV(I)
  251     FORMAT('I,NV(I) = ',2I8)
          CALL DPWRST('XXX','BUG ')
  250   CONTINUE
      ENDIF
C
C               ******************************************
C               **  STEP 3: CONVERT SPANFO OUTPOUT TO   **
C               **          FORM WE WANT.  FOR THIS     **
C               **          ROUTINE, THAT JUST MEANS    **
C               **          COPY THE EDGE ARRAYS.       **
C               ******************************************
C
      DO330I=1,NEDGE
          IT1=(I-1)*2 + 1
          IT2=I*2
          EDGE1(I)=REAL(IEDGE(IT1))
          EDGE2(I)=REAL(IEDGE(IT2))
  330 CONTINUE
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
C
      IF(IBUGA3.EQ.'ON')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END OF SPANF2--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9014)NEDGE,NVERT,K
 9014   FORMAT('NEDGE,NVERT,K = ',3I8)
        CALL DPWRST('XXX','BUG ')
        DO9015I=1,NEDGE
          WRITE(ICOUT,9016)I,EDGE1(I),EDGE2(I)
 9016     FORMAT('I,EDGE1(I),EDGE2(I) = ',I8,2G15.7)
          CALL DPWRST('XXX','BUG ')
 9015   CONTINUE
        DO9025I=1,NVERT
          WRITE(ICOUT,9026)I,IX(I)
 9026     FORMAT('I,IX(I) = ',2I8)
          CALL DPWRST('XXX','BUG ')
 9025   CONTINUE
        DO9035I=1,K
          WRITE(ICOUT,9036)I,NV(I)
 9036     FORMAT('I,NV(I) = ',2I8)
          CALL DPWRST('XXX','BUG ')
 9035   CONTINUE
      ENDIF
C
      RETURN
      END
      SUBROUTINE SPECIF(X,Y,N,IWRITE,XIDTEM,STAT,IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE TEST SPECIFICITY
C              BETWEEN TWO VARIABLES.
C
C              THIS IS SPECIFICALLY FOR THE 2X2 CASE.  THAT IS,
C              EACH VARIABLE HAS TWO MUTUALLY EXCLUSIVE
C              CHOICES CODED AS 1 (FOR SUCCESS) OR 0 (FOR
C              FAILURE).  TEST SPECIFICITY IS DEFINED AS THE
C              CONDITIONAL PROBABILITY OF A POSITIVE TEST GiVEN
C              THAT THE DISEASE IS NOT PRESENT.
C
C              A TYPICAL EXAMPLE WOULD BE WHERE VARIABLE ONE
C              DENOTES THE GROUND TRUTH AND A VALUE OF 1
C              INDICATES "PRESENT" AND A VALUE OF 0 INDICATES
C              "NOT PRESENT".  VARIABLE TWO REPRESENTS SOME TYPE
C              OF DETECTION DEVICE WHERE A VALUE OF 1 INDICATES
C              THE DEVICE DETECTED THE SPECIFIED OBJECT WHILE A
C              VALUE OF 0 INDICATES THAT THE OBJECT WAS NOT
C              DETECTED.  TEST SPECIFICITY IS THEN DEFINED AS
C              THE PROBABILITY OF NOT DETECTING THE OBJECT GIVEN
C              THAT THE OBJECT IS NOT ACTUALLY THERE.
C
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF
C                                (UNSORTED) OBSERVATIONS
C                                WHICH CONSTITUTE THE FIRST SET
C                                OF DATA.
C                     --Y      = THE SINGLE PRECISION VECTOR OF
C                                (UNSORTED) OBSERVATIONS
C                                WHICH CONSTITUTE THE SECOND SET
C                                OF DATA.
C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR X, OR EQUIVALENTLY,
C                                THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR Y.
C     OUTPUT ARGUMENTS--STAT   = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED TEST SPECIFICITY
C                                BETWEEN THE 2 SETS OF DATA
C                                IN THE INPUT VECTORS X AND Y.
C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
C             SAMPLE TEST SPECIFICITY 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--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTIUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2899
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2007/3
C     ORIGINAL VERSION--MARCH     2007.
C     UPDATED         --AUGUST    2007. IF 2X2 CASE, CHECK IF SUM
C                                       OF ENTRIES IS <= 4.  IN THIS
C                                       CASE, ASSUME WE HAVE RAW DATA
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISTEPN
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
      DIMENSION Y(*)
      DIMENSION XIDTEM(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='SPEC'
      ISUBN2='IF  '
      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 SPECIF--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,52)IBUGA3,N
   52   FORMAT('IBUGA3,N = ',A4,2X,I8)
        CALL DPWRST('XXX','BUG ')
        DO55I=1,N
          WRITE(ICOUT,56)I,X(I),Y(I)
   56     FORMAT('I,X(I),Y(I) = ',I8,2G15.7)
          CALL DPWRST('XXX','BUG ')
   55   CONTINUE
      ENDIF
C
C               ********************************************
C               **  STEP 21--                             **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      ISTEPN='21'
      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(N.LT.2)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,1201)
 1201   FORMAT('***** ERROR IN THE TEST SPECIFICITY')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,1203)
 1203   FORMAT('      THE NUMBER OF OBSERVATIONS FOR THE RESPONSE ',
     1         'VARIABLES IS LESS THAN TWO')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,1205)N
 1205   FORMAT('SAMPLE SIZE = ',I8)
        CALL DPWRST('XXX','WRIT')
        IERROR='YES'
        GOTO9000
      ENDIF
C
C               ********************************************
C               **  STEP 22--                             **
C               **  CHECK THAT THE VARIABLES HAVE AT MOST **
C               **  TWO DISTINCT VALUES (1 INDICATES A    **
C               **  SUCCESS, 0 INDICATES A FAILURE).      **
C               ********************************************
C
      ISTEPN='22'
      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
C     NOTE: CHECK FOR SPECIAL CASE N = 2.  IN THIS CASE,
C           ASSUME WE HAVE A 2X2 TABLE OF COUNTS INSTEAD
C           OF RAW DATA.
C
      IF(N.EQ.2)THEN
        N11=INT(X(1)+0.5)
        N21=INT(X(2)+0.5)
        N12=INT(Y(1)+0.5)
        N22=INT(Y(2)+0.5)
C
C       CHECK IF ALL ENTRIES 0 OR 1. IF SO, ASSUME
C       RAW DATA CASE.
C
        IF((N11.EQ.0 .OR. N11.EQ.1) .AND.
     1     (N12.EQ.0 .OR. N12.EQ.1) .AND.
     1     (N21.EQ.0 .OR. N21.EQ.1) .AND.
     1     (N22.EQ.0 .OR. N22.EQ.1)) GOTO1349
C
        IF(N11.LT.0)THEN
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,1201)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,1311)
 1311     FORMAT('      ROW 1 COLUMN 1 OF THE COUNTS TABLE IS ',
     1           'NEGATIVE.')
          CALL DPWRST('XXX','BUG ')
        ELSEIF(N21.LT.0)THEN
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,1201)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,1321)
 1321     FORMAT('      ROW 2 COLUMN 1 OF THE COUNTS TABLE IS ',
     1           'NEGATIVE.')
          CALL DPWRST('XXX','BUG ')
        ELSEIF(N12.LT.0)THEN
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,1201)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,1331)
 1331     FORMAT('      ROW 1 COLUMN 2 OF THE COUNTS TABLE IS ',
     1           'NEGATIVE.')
          CALL DPWRST('XXX','BUG ')
        ELSEIF(N22.LT.0)THEN
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,1201)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,1341)
 1341     FORMAT('      ROW 2 COLUMN 2 OF THE COUNTS TABLE IS ',
     1           'NEGATIVE.')
          CALL DPWRST('XXX','BUG ')
        ENDIF
C
        AN11=REAL(N11)
        AN21=REAL(N21)
        AN12=REAL(N12)
        AN22=REAL(N22)
        STAT=AN22/(AN21+AN22)
        GOTO3000
      ENDIF
C
      CALL DISTIN(X,N,IWRITE,XIDTEM,NDIST,IBUGA3,IERROR)
      IF(NDIST.EQ.1)THEN
        AVAL=XIDTEM(1)
        IF(ABS(AVAL).LE.0.5)THEN
          AVAL=0.0
        ELSE
          AVAL=1.0
        ENDIF
        DO2202I=1,N
          X(I)=1.0
 2202   CONTINUE
      ELSEIF(NDIST.EQ.2)THEN
        IF(XIDTEM(1).EQ.1.0 .OR. XIDTEM(2).EQ.1.0)THEN
          DO2203I=1,N
            IF(X(I).NE.1.0)X(I)=0.0
 2203     CONTINUE
        ELSE
          ATEMP1=MIN(XIDTEM(1),XIDTEM(2))
          ATEMP2=MAX(XIDTEM(1),XIDTEM(2))
          DO2208I=1,N
            IF(X(I).EQ.ATEMP1)X(I)=0.0
            IF(X(I).EQ.ATEMP2)X(I)=1.0
 2208     CONTINUE
        ENDIF
      ELSE
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,1201)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,2211)
 2211   FORMAT('      RESPONSE VARIABLE ONE SHOULD CONTAIN AT MOST')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,2213)
 2213   FORMAT('      TWO DISTINCT VALUES.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,2215)NDIST
 2215   FORMAT('      ',I8,' DISTINCT VALUES FOUND.')
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        GOTO9000
      ENDIF
C
 1349 CONTINUE
C
      CALL DISTIN(Y,N,IWRITE,XIDTEM,NDIST,IBUGA3,IERROR)
      IF(NDIST.EQ.1)THEN
        AVAL=XIDTEM(1)
        IF(ABS(AVAL).LE.0.5)THEN
          AVAL=0.0
        ELSE
          AVAL=1.0
        ENDIF
        DO2302I=1,N
          Y(I)=1.0
 2302   CONTINUE
      ELSEIF(NDIST.EQ.2)THEN
        IF(XIDTEM(1).EQ.1.0 .OR. XIDTEM(2).EQ.1.0)THEN
          DO2303I=1,N
            IF(Y(I).NE.1.0)Y(I)=0.0
 2303     CONTINUE
        ELSE
          ATEMP1=MIN(XIDTEM(1),XIDTEM(2))
          ATEMP2=MAX(XIDTEM(1),XIDTEM(2))
          DO2308I=1,N
            IF(Y(I).EQ.ATEMP1)Y(I)=0.0
            IF(Y(I).EQ.ATEMP2)Y(I)=1.0
 2308     CONTINUE
        ENDIF
      ELSE
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,1201)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,2311)
 2311   FORMAT('      RESPONSE VARIABLE TWO SHOULD CONTAIN AT MOST')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,2313)
 2313   FORMAT('      TWO DISTINCT VALUES.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,2315)NDIST
 2315   FORMAT('      ',I8,' DISTINCT VALUES FOUND.')
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        GOTO9000
      ENDIF
C
      N11=0
      N12=0
      N21=0
      N22=0
      DO2410I=1,N
        IF(X(I).EQ.1.0 .AND. Y(I).EQ.1.0)THEN
          N11=N11+1
        ELSEIF(X(I).EQ.0.0 .AND. Y(I).EQ.0.0)THEN
          N22=N22+1
        ELSEIF(X(I).EQ.1.0 .AND. Y(I).EQ.0.0)THEN
          N12=N12+1
        ELSEIF(X(I).EQ.0.0 .AND. Y(I).EQ.1.0)THEN
          N21=N21+1
        ENDIF
 2410 CONTINUE
C
      STAT=REAL(N22)/REAL(N21+N22)
C
 3000 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' .OR. IWRITE.EQ.'NO')GOTO890
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,811)STAT
  811 FORMAT('THE TEST SPECIFICITY PROPORTION = ',G15.7)
      CALL DPWRST('XXX','BUG ')
  890 CONTINUE
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'ON')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END OF SPECIF--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9012)IBUGA3,IERROR
 9012   FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9013)N,N11,N12,N21,N22
 9013   FORMAT('N,N11,N12,N21,N22 = ',5I10)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9015)STAT
 9015   FORMAT('STAT = ',G15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      RETURN
      END
      DOUBLE PRECISION FUNCTION SPHINC( N, R )
*
*                   R
*     SPHINC =  K  I  exp(-t*t/2) t**(N-1) dt, for N > 1.
*                N  0
*
      INTEGER I, N
      DOUBLE PRECISION R, RR, RP, PF, ET, PHI
      PARAMETER ( RP = 2.5066 28274 63100 04D0 )
      IF ( R .GT. 0 ) THEN
         RR = R*R
         PF = 1.0D0
         DO 100 I = N-2, 2, -2
            PF = 1.0D0 + RR*PF/DBLE(I)
  100    CONTINUE
         IF ( MOD( N, 2 ) .EQ. 0 ) THEN
            ET = LOG(PF) - RR/2.0D0
            IF ( ET .GT. -40.0D0 ) THEN
               SPHINC = 1.0D0 - EXP( ET )
            ELSE
               SPHINC = 1.0D0
            END IF
         ELSE
            SPHINC = 1  - 2*PHI(-R)
            ET = LOG(R*PF) - RR/2
            IF ( ET .GT. -40 ) SPHINC = SPHINC - 2.0D0*EXP( ET )/RP
         ENDIF
      ELSE
         SPHINC = 0.0D0
      ENDIF
C
      RETURN
      END
      DOUBLE PRECISION FUNCTION SPHLIM( N, A, B, INFI, Y )
      DOUBLE PRECISION A(*), B(*), Y(*), CMN, CMX, SPHINC
      INTEGER INFI(*), I, N
      CMN = -10*N
      CMX =  10*N
      DO 100 I = 1,N
         IF ( Y(I) .GT. 0.0D0 ) THEN
            IF ( INFI(I) .NE. 1 ) CMX = MIN( CMX, B(I)/Y(I) )
            IF ( INFI(I) .NE. 0 ) CMN = MAX( CMN, A(I)/Y(I) )
         ELSE
            IF ( INFI(I) .NE. 1 ) CMN = MAX( CMN, B(I)/Y(I) )
            IF ( INFI(I) .NE. 0 ) CMX = MIN( CMX, A(I)/Y(I) )
         ENDIF
  100 CONTINUE
      IF ( CMN .LT. CMX ) THEN
         IF ( CMN .GE. 0.0D0 .AND. CMX .GE. 0.0D0 ) THEN
            SPHLIM = SPHINC( N,  CMX ) - SPHINC( N,  CMN )
         ELSEIF ( CMN .LT. 0.0D0 .AND. CMX .GE. 0.0D0 ) THEN
            SPHLIM = SPHINC( N, -CMN ) + SPHINC( N,  CMX )
         ELSE
            SPHLIM = SPHINC( N, -CMN ) - SPHINC( N, -CMX )
         ENDIF
      ELSE
         SPHLIM = 0.0D0
      ENDIF
C
      RETURN
      END
      SUBROUTINE SPHMVN(N, LOWER, UPPER, INFIN, CORREL, MAXPTS,
     &     ABSEPS, RELEPS, ERROR, VALUE, INFORM)
*
*     A subroutine for computing multivariate normal probabilities.
*     This subroutine uses a Mont-Carlo algorithm given in the paper
*       "Three Digit Accurate Multiple Normal Probabilities",
*          pp. 369-380, Numer. Math. 35(1980), by I. Deak
*
*
*  Parameters
*
*     N      INTEGER, the number of variables.
*     LOWER  REAL, array of lower integration limits.
*     UPPER  REAL, array of upper integration limits.
*     INFIN  INTEGER, array of integration limits flags:
*            if INFIN(I) < 0, Ith limits are (-infinity, infinity);
*            if INFIN(I) = 0, Ith limits are (-infinity, UPPER(I)];
*            if INFIN(I) = 1, Ith limits are [LOWER(I), infinity);
*            if INFIN(I) = 2, Ith limits are [LOWER(I), UPPER(I)].
*     CORREL REAL, array of correlation coefficients; the correlation
*            coefficient in row I column J of the correlation matrix
*            should be stored in CORREL( J + ((I-2)*(I-1))/2 ), for J < I.
*     MAXPTS INTEGER, maximum number of function values allowed. This
*            parameter can be used to limit the time. A sensible
*            strategy is to start with MAXPTS = 1000*N, and then
*            increase MAXPTS if ERROR is too large.
*     ABSEPS REAL absolute error tolerance.
*     RELEPS REAL relative error tolerance.
*     ERROR  REAL, estimated absolute error, with 99% confidence level.
*     VALUE  REAL, estimated value for the integral
*     INFORM INTEGER, termination status parameter:
*            if INFORM = 0, normal completion with ERROR < EPS;
*            if INFORM = 1, completion with ERROR > EPS and MAXPTS
*                           function vaules used; increase MAXPTS to
*                           decrease ERROR;
*            if INFORM = 2, N > 100.
*
      EXTERNAL SPNRML
      INTEGER N, INFIS, INFIN(*), MAXPTS, MPT, INFORM, NS, IVLS
      DOUBLE PRECISION CORREL(*), LOWER(*), UPPER(*),
     &     ABSEPS, RELEPS, ERROR, VALUE, D, E, EPS, SPNRNT
      IF ( N .GT. 100 ) THEN
         INFORM = 2
         VALUE = 0.0D0
         ERROR = 1.0D0
         RETURN
      ENDIF
      INFORM = INT(SPNRNT(N,CORREL,LOWER,UPPER,INFIN,INFIS,D,E,NS))
      IF ( N-INFIS .EQ. 0 ) THEN
         VALUE = 1.0D0
         ERROR = 0.0D0
      ELSE IF ( N-INFIS .EQ. 1 ) THEN
         VALUE = E - D
         ERROR = 2E-16
      ELSE
*
*        Call then Monte-Carlo integration subroutine
*
         MPT = 25 + NS/N**3
         CALL SCRUDE( N-INFIS, MPT, ERROR, VALUE, 0 )
         IVLS = MPT*NS
 10      EPS = MAX( ABSEPS, RELEPS*ABS(VALUE) )
         IF ( ERROR .GT. EPS .AND. IVLS .LT. MAXPTS ) THEN
            MPT = MAX( MIN( INT(MPT*(ERROR/(EPS))**2),
     &                      ( MAXPTS - IVLS )/NS ), 10 )
            CALL SCRUDE( N-INFIS, MPT, ERROR, VALUE, 1 )
            IVLS = IVLS + MPT*NS
            GO TO 10
         ENDIF
         IF ( ERROR. GT. EPS .AND. IVLS .GE. MAXPTS ) INFORM = 1
      ENDIF
C
      RETURN
      END
      SUBROUTINE SPHMVT( N, NU, LOWER, UPPER, INFIN, CORREL, MAXPTS,
     *                   ABSEPS, RELEPS, ERROR, VALUE, INFORM )
*
*     A subroutine for computing multivariate t probabilities.
*     This subroutine uses a modified version of the Mont-Carlo
*     algorithm for multivariatie Normal probabilities in the paper
*       "Three Digit Accurate Multiple Normal Probabilities",
*          pp. 369-380, Numer. Math. 35(1980), by I. Deak
*
*
*  Parameters
*
*     N      INTEGER, the number of variables.
*     NU     INTEGER, the number of degrees of freedom.
*     LOWER  REAL, array of lower integration limits.
*     UPPER  REAL, array of upper integration limits.
*     INFIN  INTEGER, array of integration limits flags:
*            if INFIN(I) < 0, Ith limits are (-infinity, infinity);
*            if INFIN(I) = 0, Ith limits are (-infinity, UPPER(I)];
*            if INFIN(I) = 1, Ith limits are [LOWER(I), infinity);
*            if INFIN(I) = 2, Ith limits are [LOWER(I), UPPER(I)].
*     CORREL REAL, array of correlation coefficients; the correlation
*            coefficient in row I column J of the correlation matrix
*            should be stored in CORREL( J + ((I-2)*(I-1))/2 ), for J < I.
*     MAXPTS INTEGER, maximum number of function values allowed. This
*            parameter can be used to limit the time. A sensible
*            strategy is to start with MAXPTS = 1000*N, and then
*            increase MAXPTS if ERROR is too large.
*     ABSEPS REAL absolute error tolerance.
*     RELEPS REAL relative error tolerance.
*     ERROR  REAL, estimated absolute error, with 99% confidence level.
*     VALUE  REAL, estimated value for the integral
*     INFORM INTEGER, termination status parameter:
*            if INFORM = 0, normal completion with ERROR < EPS;
*            if INFORM = 1, completion with ERROR > EPS and MAXPTS
*                           function vaules used; increase MAXPTS to
*                           decrease ERROR;
*            if INFORM = 2, N > 50.
*
      EXTERNAL SPMVTI
      INTEGER N, NU, INFIS, INFIN(*), MAXPTS, MPT, INFORM, NS, IVLS
      DOUBLE PRECISION CORREL(*), LOWER(*), UPPER(*),
     *     ABSEPS, RELEPS, ERROR, VALUE, D, E, EPS, SPMVTI
      IF ( N .GT. 50 ) THEN
         INFORM = 2
         VALUE = 0.0D0
         ERROR = 1.0D0
         RETURN
      ENDIF
      INFORM = INT(SPMVTI(N,NU,CORREL,LOWER,UPPER,INFIN,INFIS,D,E,NS))
      IF ( N-INFIS .EQ. 0 ) THEN
         VALUE = 1.0D0
         ERROR = 0.0D0
      ELSE IF ( N-INFIS .EQ. 1 ) THEN
         VALUE = E - D
         ERROR = 2E-16
      ELSE
*
*        Call the Monte-Carlo integration subroutine
*
         MPT = 25 + NS/N**3
         CALL TCRUDE( N-INFIS, MPT, ERROR, VALUE, 0 )
         IVLS = MPT*NS
 10      EPS = MAX( ABSEPS, RELEPS*ABS(VALUE) )
         IF ( ERROR .GT. EPS .AND. IVLS .LT. MAXPTS ) THEN
            MPT = MAX( MIN( INT( MPT*( ERROR/EPS )**2 ),
     *                      ( MAXPTS - IVLS )/NS ), 10 )
            CALL TCRUDE( N-INFIS, MPT, ERROR, VALUE, 1 )
            IVLS = IVLS + MPT*NS
            GO TO 10
         ENDIF
         IF ( ERROR. GT. EPS .AND. IVLS .GE. MAXPTS ) INFORM = 1
      ENDIF
C
      RETURN
      END
      DOUBLE PRECISION FUNCTION SPHLMT( N, NU, A, B, INFI, Y )
      DOUBLE PRECISION A(*), B(*), Y(*), CMN, CMX, SPHNCT
      INTEGER INFI(*), I, N, NU
      CMN = -10.0D0*N
      CMX =  10.0D0*N
      DO 100 I = 1,N
         IF ( Y(I) .GT. 0.0D0 ) THEN
            IF ( INFI(I) .NE. 1 ) CMX = MIN( CMX, B(I)/Y(I) )
            IF ( INFI(I) .NE. 0 ) CMN = MAX( CMN, A(I)/Y(I) )
         ELSE
            IF ( INFI(I) .NE. 1 ) CMN = MAX( CMN, B(I)/Y(I) )
            IF ( INFI(I) .NE. 0 ) CMX = MIN( CMX, A(I)/Y(I) )
         ENDIF
  100 CONTINUE
      IF ( CMN .LT. CMX ) THEN
         IF ( CMN .GE. 0.0D0 .AND. CMX .GE. 0.0D0 ) THEN
            SPHLMT = SPHNCT( N, NU,  CMX ) - SPHNCT( N, NU,  CMN )
         ELSEIF ( CMN .LT. 0.0D0 .AND. CMX .GE. 00D0 ) THEN
            SPHLMT = SPHNCT( N, NU, -CMN ) + SPHNCT( N, NU,  CMX )
         ELSE
            SPHLMT = SPHNCT( N, NU, -CMN ) - SPHNCT( N, NU, -CMX )
         ENDIF
      ELSE
         SPHLMT = 0.0D0
      ENDIF
C
      RETURN
      END
      DOUBLE PRECISION FUNCTION SPHNCT( M, NU, R )
*
*                   R
*     SPHNCT =  K  I  ( 1 + t**2/NU )**(-(NU+M)/2 ) t**(M-1) dt, for M > 0.
*                M  0
*
      INTEGER I, M, NU, NUOLD
      DOUBLE PRECISION R, RR, RT, PI, PF, STUDNT, TCON
      PARAMETER ( PI = 3.14159 26535 89793D0 )
      SAVE NUOLD, TCON
      DATA NUOLD / 0 /
      IF ( R .GT. 0.0D0 ) THEN
         IF ( M .LE. 1 ) THEN
            SPHNCT = 2.0D0*STUDNT( NU, R ) - 1.0D0
         ELSE IF ( M .EQ. 2 ) THEN
            SPHNCT = 1.0D0 - 1.0D0/SQRT( 1.0D0 + R*R/NU )**NU
         ELSE
            RR = R*R/NU
            RT = RR/( 1.0D0 + RR )
            PF = 1.0D0
            DO 100 I = M - 2, 2, -2
               PF = 1 + PF*RT*DBLE( NU + I - 2 )/DBLE(I)
  100       CONTINUE
            PF = PF*SQRT( RT/RR )**NU
            IF ( MOD( M, 2 ) .EQ. 0 ) THEN
               SPHNCT = 1.0D0 - PF
            ELSE
               IF ( NU .NE. NUOLD ) THEN
                  NUOLD = NU
                  TCON = 1.0D0
                  IF ( MOD( NU, 2 ) .EQ. 0 ) THEN
                     TCON = TCON/2.0D0
                  ELSE
                     TCON = TCON/PI
                  END IF
                  DO 200 I = NU-2, 1, -2
                     TCON = ( I + 1 )*TCON/I
  200             CONTINUE
               END IF
               SPHNCT = 2.0D0*
     &                  ( STUDNT( NU, R ) - TCON*SQRT(RT)*PF ) - 1.0D0
            ENDIF
         ENDIF
      ELSE
         SPHNCT = 0.0D0
      ENDIF
C
      RETURN
      END
      DOUBLE PRECISION FUNCTION spmpar(i)
C-----------------------------------------------------------------------
C
C     SPMPAR PROVIDES THE SINGLE PRECISION MACHINE CONSTANTS FOR
C     THE COMPUTER BEING USED. IT IS ASSUMED THAT THE ARGUMENT
C     I IS AN INTEGER HAVING ONE OF THE VALUES 1, 2, OR 3. IF THE
C     SINGLE PRECISION ARITHMETIC BEING USED HAS M BASE B DIGITS AND
C     ITS SMALLEST AND LARGEST EXPONENTS ARE EMIN AND EMAX, THEN
C
C        SPMPAR(1) = B**(1 - M), THE MACHINE PRECISION,
C
C        SPMPAR(2) = B**(EMIN - 1), THE SMALLEST MAGNITUDE,
C
C        SPMPAR(3) = B**EMAX*(1 - B**(-M)), THE LARGEST MAGNITUDE.
C
C-----------------------------------------------------------------------
C     WRITTEN BY
C        ALFRED H. MORRIS, JR.
C        NAVAL SURFACE WARFARE CENTER
C        DAHLGREN VIRGINIA
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
C     MODIFIED BY BARRY W. BROWN TO RETURN DOUBLE PRECISION MACHINE
C     CONSTANTS FOR THE COMPUTER BEING USED.  THIS MODIFICATION WAS
C     MADE AS PART OF CONVERTING BRATIO TO DOUBLE PRECISION
C-----------------------------------------------------------------------
C     .. Scalar Arguments ..
      INTEGER i
C     ..
C     .. Local Scalars ..
      DOUBLE PRECISION b,binv,bm1,one,w,z
      INTEGER emax,emin,ibeta,m
C     ..
C     .. External Functions ..
      INTEGER ipmpar
      EXTERNAL ipmpar
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC dble
C
      INCLUDE 'DPCOMC.INC'
C     ..
C     .. Executable Statements ..
C
      IF (i.GT.1) GO TO 10
      b = i1mach(10)
      m = i1mach(11)
CCCCC b = ipmpar(4)
CCCCC m = ipmpar(8)
      spmpar = b** (1-m)
      RETURN
C
   10 IF (i.GT.2) GO TO 20
      b = i1mach(10)
CCCCC b = ipmpar(4)
      emin = i1mach(12)
CCCCC emin = ipmpar(9)
      one = dble(1)
      binv = one/b
      w = b** (emin+2)
      spmpar = ((w*binv)*binv)*binv
      RETURN
C
   20 continue
      ibeta = i1mach(10)
CCCCC ibeta = ipmpar(4)
      m = i1mach(11)
CCCCC m = ipmpar(8)
      emax = i1mach(13)
CCCCC emax = ipmpar(10)
C
      b = ibeta
      bm1 = ibeta - 1
      one = dble(1)
      z = b** (m-1)
      w = ((z-one)*b+bm1)/ (b*z)
C
      z = b** (emax-2)
      spmpar = ((w*z)*b)*b
      RETURN

      END
      DOUBLE PRECISION FUNCTION SPMVT(N)
*
*     Integrand subroutine
*
      DOUBLE PRECISION LOWER(*), UPPER(*), CORREL(*), D, E, ZERO
      INTEGER N, INFIN(*), INFIS
      INTEGER NL, IJ, I, II, J, K, NS, NSO, ND, NU, NUIN
      PARAMETER ( NL = 50, ND = 2, ZERO = 0 )
      DOUBLE PRECISION A(NL), B(NL), U(NL,NL), Y(NL), COV(NL*(NL+1)/2)
      INTEGER INFI(NL), IS(NL), IC(NL)
      DOUBLE PRECISION RS, TMP, BT, RNOR, SPHLMT, SPMVTI
      SAVE NU, A, B, INFI, U
*
*    First generate U = COV*(random orthogonal matrix)
*
      DO 100 K = N-1, 1, -1
         TMP = 0
         DO 200 J = K, N
            Y(J) = RNOR()
            TMP = TMP + Y(J)**2
  200    CONTINUE
         TMP = -SQRT(TMP)
         BT = 1/( TMP*( Y(K) + TMP ) )
         Y(K) = Y(K) + TMP
         DO 300 I = 1, N
            TMP = 0
            DO 350 J = K, N
               TMP = TMP + U(I,J)*Y(J)
  350       CONTINUE
            TMP = BT*TMP
            DO 380 J = K, N
               U(I,J) = U(I,J) - TMP*Y(J)
  380       CONTINUE
  300    CONTINUE
  100 CONTINUE
*
*     Compute integrand average
*
      RS = SQRT( DBLE(ND) )
      DO 400 I = 1,ND
         IC(I) = I
  400 CONTINUE
      IC(ND+1) = N+1
      SPMVT = 0.0D0
      NS = 0
 10   CONTINUE
      DO 410 I = 1,ND
         IS(I) = -1
  410 CONTINUE
 20   CONTINUE
      DO 420 I = 1, N
         TMP = 0
         DO 430 J = 1,ND
            TMP = TMP + IS(J)*U( I, IC(J) )
  430    CONTINUE
         Y(I) = TMP/RS
  420 CONTINUE
      NS = NS + 1
      SPMVT = SPMVT + ( SPHLMT( N, NU, A, B, INFI, Y ) - SPMVT )/NS
      DO 440 I = 1, ND
         IS(I) = IS(I) + 2
         IF ( IS(I) .LT. 2 ) GO TO 20
         IS(I) = -1
  440 CONTINUE
      DO 450 I = 1, ND
         IC(I) = IC(I) + 1
         IF ( IC(I) .LT. IC(I+1)  ) GO TO 10
         IC(I) = I
  450 CONTINUE
      SPMVT = SPMVT/2.0D0
      RETURN
*
      ENTRY SPMVTI( N,NUIN, CORREL, LOWER,UPPER,INFIN, INFIS, D,E, NSO )
      SPMVTI = 0.0D0
      NU = NUIN
*
*     Initialisation
*
      II = 0
      IJ = 0
      INFIS = 0
      DO 500 I = 1, N
         INFI(I) = INFIN(I)
         IF ( INFI(I) .LT. 0 ) THEN
            INFIS = INFIS + 1
         ELSE
            A(I) = 0.0D0
            B(I) = 0.0D0
            IF ( INFI(I) .NE. 0 ) A(I) = LOWER(I)
            IF ( INFI(I) .NE. 1 ) B(I) = UPPER(I)
         ENDIF
         DO 550 J = 1, I-1
            II = II + 1
            IJ = IJ + 1
            COV(IJ) = CORREL(II)
  550    CONTINUE
         IJ = IJ + 1
         COV(IJ) = 1
  500 CONTINUE
      NSO = 1
      DO 600 I = 1,ND
         NSO = 2*NSO*( N - INFIS - I + 1 )/I
  600 CONTINUE
*
*     First move any doubly infinite limits to innermost positions
*
      IF ( INFIS .LT. N ) THEN
         DO 700 I = N, N-INFIS+1, -1
            IF ( INFI(I) .GE. 0 ) THEN
               DO 750 J = 1,I-1
                  IF ( INFI(J) .LT. 0 ) THEN
                     CALL RCSWAP( J, I, A, B, INFI, N, COV )
                     GO TO 700
                  ENDIF
  750          CONTINUE
            ENDIF
  700    CONTINUE
      ENDIF
      II = 0
      DO 800 I = 1, N-INFIS
         DO 810 J = 1, I
            U(J,I) = 0
            II = II + 1
            U(I,J) = COV(II)
  810    CONTINUE
  800 CONTINUE
*
*     Determine Cholesky decomposition
*
      DO 900 J = 1, N-INFIS
         DO 910 I = J, N-INFIS
            TMP = U(I,J)
            DO 920 K = 1, J-1
               TMP = TMP - U(I,K)*U(J,K)
  920       CONTINUE
            IF ( I .EQ. J ) THEN
               U(J,J) = SQRT( MAX( TMP, ZERO ) )
            ELSE IF ( U(I,I) .GT. 0 ) THEN
               U(I,J) = TMP/U(J,J)
            ELSE
               U(I,J) = 0.0D0
            END IF
  910    CONTINUE
  900 CONTINUE
      DO 950 I = 1, N-INFIS
         IF ( U(I,I) .GT. 0 ) THEN
            IF ( INFI(I) .NE. 0 ) A(I) = A(I)/U(I,I)
            IF ( INFI(I) .NE. 1 ) B(I) = B(I)/U(I,I)
            DO 960 J = 1,I
               U(I,J) = U(I,J)/U(I,I)
  960       CONTINUE
         ENDIF
  950 CONTINUE
      CALL MVTLMS( NU, A(1), B(1), INFI(1), D, E )
C
      RETURN
      END
      DOUBLE PRECISION FUNCTION SPNRML(N)
*
*     Integrand subroutine
*
      DOUBLE PRECISION LOWER(*), UPPER(*), CORREL(*), D, E, ZERO
      INTEGER N, INFIN(*), INFIS
      INTEGER NL, IJ, I, J, K, NS, NSO, ND
      PARAMETER ( NL = 100, ND = 3, ZERO = 0 )
      DOUBLE PRECISION A(NL), B(NL), U(NL,NL), Y(NL)
      INTEGER INFI(NL), IS(NL), IC(NL)
      DOUBLE PRECISION RS, TMP, BT, RNOR, SPHLIM, SPNRNT
C
CCCCC INCLUDE 'DPCOPA.INC'
CCCCC INCLUDE 'DPCOZD.INC'
CCCCC EQUIVALENCE (DGARBG(IDGA10),U(1,1))
C
      SAVE A, B, INFI, U
*
*    First generate U = COV*(random orthogonal matrix)
*
      DO 100 K = N-1, 1, -1
         TMP = 0
         DO 200 J = K, N
            Y(J) = RNOR()
            TMP = TMP + Y(J)**2
  200    CONTINUE
         TMP = -SQRT(TMP)
         BT = 1/( TMP*( Y(K) + TMP ) )
         Y(K) = Y(K) + TMP
         DO 300 I = 1, N
            TMP = 0
            DO 400 J = K, N
               TMP = TMP + U(I,J)*Y(J)
  400       CONTINUE
            TMP = BT*TMP
            DO 500 J = K, N
               U(I,J) = U(I,J) - TMP*Y(J)
  500       CONTINUE
  300    CONTINUE
  100 CONTINUE
*
*     Compute integrand average
*
      RS = SQRT( DBLE(ND) )
      DO 600 I = 1,ND
         IC(I) = I
 600  CONTINUE
      IC(ND+1) = N+1
      SPNRML = 0.0D0
      NS = 0
 10   DO 650 I = 1,ND
         IS(I) = -1
 650  CONTINUE
 20   DO 700 I = 1, N
         TMP = 0
         DO 750 J = 1,ND
            TMP = TMP + IS(J)*U(I,IC(J))
 750     CONTINUE
         Y(I) = TMP/RS
 700  CONTINUE
      NS = NS + 1
      SPNRML = SPNRML + ( SPHLIM( N, A, B, INFI, Y ) - SPNRML )/NS
      DO 800 I = 1, ND
         IS(I) = IS(I) + 2
         IF ( IS(I) .LT. 2 ) GO TO 20
         IS(I) = -1
 800  CONTINUE
      DO 850 I = 1, ND
         IC(I) = IC(I) + 1
         IF ( IC(I) .LT. IC(I+1)  ) GO TO 10
         IC(I) = I
 850  CONTINUE
      SPNRML = SPNRML/2.0D0
      RETURN
      ENTRY SPNRNT( N, CORREL, LOWER, UPPER, INFIN, INFIS, D, E, NSO )
      SPNRNT = 0
*
*     Initialisation
*
      IJ = 0
      INFIS = 0
      DO 900 I = 1, N
         INFI(I) = INFIN(I)
         IF ( INFI(I) .LT. 0 ) THEN
            INFIS = INFIS + 1
         ELSE
            A(I) = 0.0D0
            B(I) = 0.0D0
            IF ( INFI(I) .NE. 0 ) A(I) = LOWER(I)
            IF ( INFI(I) .NE. 1 ) B(I) = UPPER(I)
         ENDIF
         DO 910 J = 1, I-1
            IJ = IJ + 1
            U(I,J) = CORREL(IJ)
            U(J,I) = 0.0D0
  910    CONTINUE
         U(I,I) = 1.D0
  900 CONTINUE
      NSO = 1
      DO 920 I = 1,ND
         NSO = 2*NSO*( N - INFIS - I + 1 )/I
  920 CONTINUE
*
*     First move any doubly infinite limits to innermost positions
*
      IF ( INFIS .LT. N ) THEN
         DO 930 I = N, N-INFIS+1, -1
            IF ( INFI(I) .GE. 0 ) THEN
               DO 940 J = 1,I-1
                  IF ( INFI(J) .LT. 0 ) THEN
                     DO 950 K = 1, J-1
                        TMP = U(J,K)
                        U(J,K) = U(I,K)
                        U(I,K) = TMP
  950                CONTINUE
                     DO 960 K = J+1, I-1
                        TMP = U(I,K)
                        U(I,K) = U(K,J)
                        U(K,J) = TMP
 960                 CONTINUE
                     DO 970 K = I+1, N
                        TMP = U(K,J)
                        U(K,J) = U(K,I)
                        U(K,I) = TMP
 970                 CONTINUE
                     TMP = A(J)
                     A(J) = A(I)
                     A(I) = TMP
                     TMP = B(J)
                     B(J) = B(I)
                     B(I) = TMP
                     TMP = INFI(J)
                     INFI(J) = INFI(I)
                     INFI(I) = INT(TMP)
                     GO TO 930
                  ENDIF
 940           CONTINUE
            ENDIF
 930     CONTINUE
      ENDIF
*
*     Determine Cholesky decomposition
*
      DO 980 J = 1, N-INFIS
         DO 982 I = J, N-INFIS
            TMP = U(I,J)
            DO 984 K = 1, J-1
               TMP = TMP - U(I,K)*U(J,K)
  984       CONTINUE
            IF ( I .EQ. J ) THEN
               U(J,J) = SQRT( MAX( TMP, ZERO ) )
            ELSE IF ( U(I,I) .GT. 0 ) THEN
               U(I,J) = TMP/U(J,J)
            ELSE
               U(I,J) = 0.0D0
            END IF
 982     CONTINUE
 980  CONTINUE
      DO 990 I = 1, N-INFIS
         IF ( U(I,I) .GT. 0 ) THEN
            IF ( INFI(I) .NE. 0 ) A(I) = A(I)/U(I,I)
            IF ( INFI(I) .NE. 1 ) B(I) = B(I)/U(I,I)
            DO 995 J = 1,I
               U(I,J) = U(I,J)/U(I,I)
 995        CONTINUE
         ENDIF
 990  CONTINUE
      CALL LIMITS( A(1), B(1), INFI(1), D, E )
C
      RETURN
      END
      SUBROUTINE SPOCO(A,LDA,N,RCOND,Z,INFO)
C***BEGIN PROLOGUE  SPOCO
C***DATE WRITTEN   780814   (YYMMDD)
C***REVISION DATE  820801   (YYMMDD)
C***CATEGORY NO.  D2B1B
C***KEYWORDS  CONDITION,FACTOR,LINEAR ALGEBRA,LINPACK,MATRIX,
C             POSITIVE DEFINITE
C***AUTHOR  MOLER, C. B., (U. OF NEW MEXICO)
C***PURPOSE  Factors a real SYMMETRIC POSITIVE DEFINITE MATRIX
C            and estimates the condition number of the matrix.
C***DESCRIPTION
C
C     SPOCO factors a real symmetric positive definite matrix
C     and estimates the condition of the matrix.
C
C     If  RCOND  is not needed, SPOFA is slightly faster.
C     To solve  A*X = B , follow SPOCO by SPOSL.
C     To compute  INVERSE(A)*C , follow SPOCO by SPOSL.
C     To compute  DETERMINANT(A) , follow SPOCO by SPODI.
C     To compute  INVERSE(A) , follow SPOCO by SPODI.
C
C     On Entry
C
C        A       REAL(LDA, N)
C                the symmetric matrix to be factored.  Only the
C                diagonal and upper triangle are used.
C
C        LDA     INTEGER
C                the leading dimension of the array  A .
C
C        N       INTEGER
C                the order of the matrix  A .
C
C     On Return
C
C        A       an upper triangular matrix  R  so that  A = TRANS(R)*R
C                where  TRANS(R)  is the transpose.
C                The strict lower triangle is unaltered.
C                If  INFO .NE. 0 , the factorization is not complete.
C
C        RCOND   REAL
C                an estimate of the reciprocal condition of  A .
C                For the system  A*X = B , relative perturbations
C                in  A  and  B  of size  EPSILON  may cause
C                relative perturbations in  X  of size  EPSILON/RCOND .
C                If  RCOND  is so small that the logical expression
C                           1.0 + RCOND .EQ. 1.0
C                is true, then  A  may be singular to working
C                precision.  In particular,  RCOND  is zero  if
C                exact singularity is detected or the estimate
C                underflows.  If INFO .NE. 0 , RCOND is unchanged.
C
C        Z       REAL(N)
C                a work vector whose contents are usually unimportant.
C                If  A  is close to a singular matrix, then  Z  is
C                an approximate null vector in the sense that
C                NORM(A*Z) = RCOND*NORM(A)*NORM(Z) .
C                If  INFO .NE. 0 , Z  is unchanged.
C
C        INFO    INTEGER
C                = 0  for normal return.
C                = K  signals an error condition.  The leading minor
C                     of order  K  is not positive definite.
C
C     LINPACK.  This version dated 08/14/78 .
C     Cleve Moler, University of New Mexico, Argonne National Lab.
C
C     Subroutines and Functions
C
C     LINPACK SPOFA
C     BLAS SAXPY,SDOT,SSCAL,SASUM
C     Fortran ABS,AMAX1,REAL,SIGN
C***REFERENCES  DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W.,
C                 *LINPACK USERS  GUIDE*, SIAM, 1979.
C***ROUTINES CALLED  SASUM,SAXPY,SDOT,SPOFA,SSCAL
C***END PROLOGUE  SPOCO
      INTEGER LDA,N,INFO
      REAL A(LDA,1),Z(1)
      REAL RCOND
C
      REAL SDOT,EK,T,WK,WKM
      REAL ANORM,S,SASUM,SM,YNORM
      INTEGER I,J,JM1,K,KB,KP1
C
C     FIND NORM OF A USING ONLY UPPER HALF
C
C***FIRST EXECUTABLE STATEMENT  SPOCO
      DO 30 J = 1, N
         Z(J) = SASUM(J,A(1,J),1)
         JM1 = J - 1
         IF (JM1 .LT. 1) GO TO 20
         DO 10 I = 1, JM1
            Z(I) = Z(I) + ABS(A(I,J))
   10    CONTINUE
   20    CONTINUE
   30 CONTINUE
      ANORM = 0.0E0
      DO 40 J = 1, N
         ANORM = AMAX1(ANORM,Z(J))
   40 CONTINUE
C
C     FACTOR
C
      CALL SPOFA(A,LDA,N,INFO)
      IF (INFO .NE. 0) GO TO 180
C
C        RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) .
C        ESTIMATE = NORM(Z)/NORM(Y) WHERE  A*Z = Y  AND  A*Y = E .
C        THE COMPONENTS OF  E  ARE CHOSEN TO CAUSE MAXIMUM LOCAL
C        GROWTH IN THE ELEMENTS OF W  WHERE  TRANS(R)*W = E .
C        THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW.
C
C        SOLVE TRANS(R)*W = E
C
         EK = 1.0E0
         DO 50 J = 1, N
            Z(J) = 0.0E0
   50    CONTINUE
         DO 110 K = 1, N
            IF (Z(K) .NE. 0.0E0) EK = SIGN(EK,-Z(K))
            IF (ABS(EK-Z(K)) .LE. A(K,K)) GO TO 60
               S = A(K,K)/ABS(EK-Z(K))
               CALL SSCAL(N,S,Z,1)
               EK = S*EK
   60       CONTINUE
            WK = EK - Z(K)
            WKM = -EK - Z(K)
            S = ABS(WK)
            SM = ABS(WKM)
            WK = WK/A(K,K)
            WKM = WKM/A(K,K)
            KP1 = K + 1
            IF (KP1 .GT. N) GO TO 100
               DO 70 J = KP1, N
                  SM = SM + ABS(Z(J)+WKM*A(K,J))
                  Z(J) = Z(J) + WK*A(K,J)
                  S = S + ABS(Z(J))
   70          CONTINUE
               IF (S .GE. SM) GO TO 90
                  T = WKM - WK
                  WK = WKM
                  DO 80 J = KP1, N
                     Z(J) = Z(J) + T*A(K,J)
   80             CONTINUE
   90          CONTINUE
  100       CONTINUE
            Z(K) = WK
  110    CONTINUE
         S = 1.0E0/SASUM(N,Z,1)
         CALL SSCAL(N,S,Z,1)
C
C        SOLVE R*Y = W
C
         DO 130 KB = 1, N
            K = N + 1 - KB
            IF (ABS(Z(K)) .LE. A(K,K)) GO TO 120
               S = A(K,K)/ABS(Z(K))
               CALL SSCAL(N,S,Z,1)
  120       CONTINUE
            Z(K) = Z(K)/A(K,K)
            T = -Z(K)
            CALL SAXPY(K-1,T,A(1,K),1,Z(1),1)
  130    CONTINUE
         S = 1.0E0/SASUM(N,Z,1)
         CALL SSCAL(N,S,Z,1)
C
         YNORM = 1.0E0
C
C        SOLVE TRANS(R)*V = Y
C
         DO 150 K = 1, N
            Z(K) = Z(K) - SDOT(K-1,A(1,K),1,Z(1),1)
            IF (ABS(Z(K)) .LE. A(K,K)) GO TO 140
               S = A(K,K)/ABS(Z(K))
               CALL SSCAL(N,S,Z,1)
               YNORM = S*YNORM
  140       CONTINUE
            Z(K) = Z(K)/A(K,K)
  150    CONTINUE
         S = 1.0E0/SASUM(N,Z,1)
         CALL SSCAL(N,S,Z,1)
         YNORM = S*YNORM
C
C        SOLVE R*Z = V
C
         DO 170 KB = 1, N
            K = N + 1 - KB
            IF (ABS(Z(K)) .LE. A(K,K)) GO TO 160
               S = A(K,K)/ABS(Z(K))
               CALL SSCAL(N,S,Z,1)
               YNORM = S*YNORM
  160       CONTINUE
            Z(K) = Z(K)/A(K,K)
            T = -Z(K)
            CALL SAXPY(K-1,T,A(1,K),1,Z(1),1)
  170    CONTINUE
C        MAKE ZNORM = 1.0
         S = 1.0E0/SASUM(N,Z,1)
         CALL SSCAL(N,S,Z,1)
         YNORM = S*YNORM
C
         IF (ANORM .NE. 0.0E0) RCOND = YNORM/ANORM
         IF (ANORM .EQ. 0.0E0) RCOND = 0.0E0
  180 CONTINUE
      RETURN
      END
      SUBROUTINE SPOFA(A,LDA,N,INFO)
C***BEGIN PROLOGUE  SPOFA
C***DATE WRITTEN   780814   (YYMMDD)
C***REVISION DATE  820801   (YYMMDD)
C***CATEGORY NO.  D2B1B
C***KEYWORDS  FACTOR,LINEAR ALGEBRA,LINPACK,MATRIX,POSITIVE DEFINITE
C***AUTHOR  MOLER, C. B., (U. OF NEW MEXICO)
C***PURPOSE  Factors a real SYMMETRIC POSITIVE DEFINITE matrix.
C***DESCRIPTION
C
C     SPOFA factors a real symmetric positive definite matrix.
C
C     SPOFA is usually called by SPOCO, but it can be called
C     directly with a saving in time if  RCOND  is not needed.
C     (Time for SPOCO) = (1 + 18/N)*(Time for SPOFA) .
C
C     On Entry
C
C        A       REAL(LDA, N)
C                the symmetric matrix to be factored.  Only the
C                diagonal and upper triangle are used.
C
C        LDA     INTEGER
C                the leading dimension of the array  A .
C
C        N       INTEGER
C                the order of the matrix  A .
C
C     On Return
C
C        A       an upper triangular matrix  R  so that  A = TRANS(R)*R
C                where  TRANS(R)  is the transpose.
C                The strict lower triangle is unaltered.
C                If  INFO .NE. 0 , the factorization is not complete.
C
C        INFO    INTEGER
C                = 0  for normal return.
C                = K  signals an error condition.  The leading minor
C                     of order  K  is not positive definite.
C
C     LINPACK.  This version dated 08/14/78 .
C     Cleve Moler, University of New Mexico, Argonne National Lab.
C
C     Subroutines and Functions
C
C     BLAS SDOT
C     Fortran SQRT
C***REFERENCES  DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W.,
C                 *LINPACK USERS  GUIDE*, SIAM, 1979.
C***ROUTINES CALLED  SDOT
C***END PROLOGUE  SPOFA
      INTEGER LDA,N,INFO
      REAL A(LDA,1)
C
      REAL SDOT,T
      REAL S
      INTEGER J,JM1,K
C     BEGIN BLOCK WITH ...EXITS TO 40
C
C
C***FIRST EXECUTABLE STATEMENT  SPOFA
         DO 30 J = 1, N
            INFO = J
            S = 0.0E0
            JM1 = J - 1
            IF (JM1 .LT. 1) GO TO 20
            DO 10 K = 1, JM1
               T = A(K,J) - SDOT(K-1,A(1,K),1,A(1,J),1)
               T = T/A(K,K)
               A(K,J) = T
               S = S + T*T
   10       CONTINUE
   20       CONTINUE
            S = A(J,J) - S
C     ......EXIT
            IF (S .LE. 0.0E0) GO TO 40
            A(J,J) = SQRT(S)
   30    CONTINUE
         INFO = 0
   40 CONTINUE
      RETURN
      END
      SUBROUTINE SQRDC(X,LDX,N,P,QRAUX,JPVT,WORK,JOB)
C***BEGIN PROLOGUE  SQRDC
C***DATE WRITTEN   780814   (YYMMDD)
C***REVISION DATE  820801   (YYMMDD)
C***CATEGORY NO.  D5
C***KEYWORDS  DECOMPOSITION,LINEAR ALGEBRA,LINPACK,MATRIX,
C             ORTHOGONAL TRIANGULAR
C***AUTHOR  STEWART, G. W., (U. OF MARYLAND)
C***PURPOSE  Uses Householder transformations to compute the QR
C            factorization of an N by P matrix X.  Column pivoting is
C            a users option.
C***DESCRIPTION
C
C     SQRDC uses Householder transformations to compute the QR
C     factorization of an N by P matrix X.  Column pivoting
C     based on the 2-norms of the reduced columns may be
C     performed at the user's option.
C
C     On Entry
C
C        X       REAL(LDX,P), where LDX .GE. N.
C                X contains the matrix whose decomposition is to be
C                computed.
C
C        LDX     INTEGER.
C                LDX is the leading dimension of the array X.
C
C        N       INTEGER.
C                N is the number of rows of the matrix X.
C
C        P       INTEGER.
C                P is the number of columns of the matrix X.
C
C        JPVT    INTEGER(P).
C                JPVT contains integers that control the selection
C                of the pivot columns.  The K-th column X(K) of X
C                is placed in one of three classes according to the
C                value of JPVT(K).
C
C                   If JPVT(K) .GT. 0, then X(K) is an initial
C                                      column.
C
C                   If JPVT(K) .EQ. 0, then X(K) is a free column.
C
C                   If JPVT(K) .LT. 0, then X(K) is a final column.
C
C                Before the decomposition is computed, initial columns
C                are moved to the beginning of the array X and final
C                columns to the end.  Both initial and final columns
C                are frozen in place during the computation and only
C                free columns are moved.  At the K-th stage of the
C                reduction, if X(K) is occupied by a free column,
C                it is interchanged with the free column of largest
C                reduced norm.  JPVT is not referenced if
C                JOB .EQ. 0.
C
C        WORK    REAL(P).
C                WORK is a work array.  WORK is not referenced if
C                JOB .EQ. 0.
C
C        JOB     INTEGER.
C                JOB is an integer that initiates column pivoting.
C                If JOB .EQ. 0, no pivoting is done.
C                If JOB .NE. 0, pivoting is done.
C
C     On Return
C
C        X       X contains in its upper triangle the upper
C                triangular matrix R of the QR factorization.
C                Below its diagonal X contains information from
C                which the orthogonal part of the decomposition
C                can be recovered.  Note that if pivoting has
C                been requested, the decomposition is not that
C                of the original matrix X but that of X
C                with its columns permuted as described by JPVT.
C
C        QRAUX   REAL(P).
C                QRAUX contains further information required to recover
C                the orthogonal part of the decomposition.
C
C        JPVT    JPVT(K) contains the index of the column of the
C                original matrix that has been interchanged into
C                the K-th column, if pivoting was requested.
C
C     LINPACK.  This version dated 08/14/78 .
C     G. W. Stewart, University of Maryland, Argonne National Lab.
C
C     SQRDC uses the following functions and subprograms.
C
C     BLAS SAXPY,SDOT,SSCAL,SSWAP,SNRM2
C     Fortran ABS,AMAX1,MIN0,SQRT
C***REFERENCES  DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W.,
C                 *LINPACK USERS  GUIDE*, SIAM, 1979.
C***ROUTINES CALLED  SAXPY,SDOT,SNRM2,SSCAL,SSWAP
C***END PROLOGUE  SQRDC
      INTEGER LDX,N,P,JOB
      INTEGER JPVT(1)
      REAL X(LDX,1),QRAUX(1),WORK(1)
C
      INTEGER J,JP,L,LP1,LUP,MAXJ,PL,PU
      REAL MAXNRM,SNRM2,TT
      REAL SDOT,NRMXL,T
      LOGICAL NEGJ,SWAPJ
C
C***FIRST EXECUTABLE STATEMENT  SQRDC
      PL = 1
      PU = 0
      IF (JOB .EQ. 0) GO TO 60
C
C        PIVOTING HAS BEEN REQUESTED.  REARRANGE THE COLUMNS
C        ACCORDING TO JPVT.
C
         DO 20 J = 1, P
            SWAPJ = JPVT(J) .GT. 0
            NEGJ = JPVT(J) .LT. 0
            JPVT(J) = J
            IF (NEGJ) JPVT(J) = -J
            IF (.NOT.SWAPJ) GO TO 10
               IF (J .NE. PL) CALL SSWAP(N,X(1,PL),1,X(1,J),1)
               JPVT(J) = JPVT(PL)
               JPVT(PL) = J
               PL = PL + 1
   10       CONTINUE
   20    CONTINUE
         PU = P
         DO 50 JJ = 1, P
            J = P - JJ + 1
            IF (JPVT(J) .GE. 0) GO TO 40
               JPVT(J) = -JPVT(J)
               IF (J .EQ. PU) GO TO 30
                  CALL SSWAP(N,X(1,PU),1,X(1,J),1)
                  JP = JPVT(PU)
                  JPVT(PU) = JPVT(J)
                  JPVT(J) = JP
   30          CONTINUE
               PU = PU - 1
   40       CONTINUE
   50    CONTINUE
   60 CONTINUE
C
C     COMPUTE THE NORMS OF THE FREE COLUMNS.
C
      IF (PU .LT. PL) GO TO 80
      DO 70 J = PL, PU
         QRAUX(J) = SNRM2(N,X(1,J),1)
         WORK(J) = QRAUX(J)
   70 CONTINUE
   80 CONTINUE
C
C     PERFORM THE HOUSEHOLDER REDUCTION OF X.
C
      LUP = MIN0(N,P)
      DO 200 L = 1, LUP
         IF (L .LT. PL .OR. L .GE. PU) GO TO 120
C
C           LOCATE THE COLUMN OF LARGEST NORM AND BRING IT
C           INTO THE PIVOT POSITION.
C
            MAXNRM = 0.0E0
            MAXJ = L
            DO 100 J = L, PU
               IF (QRAUX(J) .LE. MAXNRM) GO TO 90
                  MAXNRM = QRAUX(J)
                  MAXJ = J
   90          CONTINUE
  100       CONTINUE
            IF (MAXJ .EQ. L) GO TO 110
               CALL SSWAP(N,X(1,L),1,X(1,MAXJ),1)
               QRAUX(MAXJ) = QRAUX(L)
               WORK(MAXJ) = WORK(L)
               JP = JPVT(MAXJ)
               JPVT(MAXJ) = JPVT(L)
               JPVT(L) = JP
  110       CONTINUE
  120    CONTINUE
         QRAUX(L) = 0.0E0
         IF (L .EQ. N) GO TO 190
C
C           COMPUTE THE HOUSEHOLDER TRANSFORMATION FOR COLUMN L.
C
            NRMXL = SNRM2(N-L+1,X(L,L),1)
            IF (NRMXL .EQ. 0.0E0) GO TO 180
               IF (X(L,L) .NE. 0.0E0) NRMXL = SIGN(NRMXL,X(L,L))
               CALL SSCAL(N-L+1,1.0E0/NRMXL,X(L,L),1)
               X(L,L) = 1.0E0 + X(L,L)
C
C              APPLY THE TRANSFORMATION TO THE REMAINING COLUMNS,
C              UPDATING THE NORMS.
C
               LP1 = L + 1
               IF (P .LT. LP1) GO TO 170
               DO 160 J = LP1, P
                  T = -SDOT(N-L+1,X(L,L),1,X(L,J),1)/X(L,L)
                  CALL SAXPY(N-L+1,T,X(L,L),1,X(L,J),1)
                  IF (J .LT. PL .OR. J .GT. PU) GO TO 150
                  IF (QRAUX(J) .EQ. 0.0E0) GO TO 150
                     TT = 1.0E0 - (ABS(X(L,J))/QRAUX(J))**2
                     TT = AMAX1(TT,0.0E0)
                     T = TT
                     TT = 1.0E0 + 0.05E0*TT*(QRAUX(J)/WORK(J))**2
                     IF (TT .EQ. 1.0E0) GO TO 130
                        QRAUX(J) = QRAUX(J)*SQRT(T)
                     GO TO 140
  130                CONTINUE
                        QRAUX(J) = SNRM2(N-L,X(L+1,J),1)
                        WORK(J) = QRAUX(J)
  140                CONTINUE
  150             CONTINUE
  160          CONTINUE
  170          CONTINUE
C
C              SAVE THE TRANSFORMATION.
C
               QRAUX(L) = X(L,L)
               X(L,L) = -NRMXL
  180       CONTINUE
  190    CONTINUE
  200 CONTINUE
      RETURN
      END
      SUBROUTINE SQRSL(X,LDX,N,K,QRAUX,Y,QY,QTY,B,RSD,XB,JOB,INFO)
C***BEGIN PROLOGUE  SQRSL
C***DATE WRITTEN   780814   (YYMMDD)
C***REVISION DATE  820801   (YYMMDD)
C***CATEGORY NO.  D9,D2A1
C***KEYWORDS  LINEAR ALGEBRA,LINPACK,MATRIX,ORTHOGONAL TRIANGULAR,SOLVE
C***AUTHOR  STEWART, G. W., (U. OF MARYLAND)
C***PURPOSE  Applies the output of SQRDC to compute coordinate trans-
C            formations projections, and least squares solutions.
C***DESCRIPTION
C
C     SQRSL applies the output of SQRDC to compute coordinate
C     transformations, projections, and least squares solutions.
C     For K .LE. MIN(N,P), let XK be the matrix
C
C            XK = (X(JPVT(1)),X(JPVT(2)), ... ,X(JPVT(K)))
C
C     formed from columnns JPVT(1), ... ,JPVT(K) of the original
C     N x P matrix X that was input to SQRDC (if no pivoting was
C     done, XK consists of the first K columns of X in their
C     original order).  SQRDC produces a factored orthogonal matrix Q
C     and an upper triangular matrix R such that
C
C              XK = Q * (R)
C                       (0)
C
C     This information is contained in coded form in the arrays
C     X and QRAUX.
C
C     On Entry
C
C        X      REAL(LDX,P)
C               X contains the output of SQRDC.
C
C        LDX    INTEGER
C               LDX is the leading dimension of the array X.
C
C        N      INTEGER
C               N is the number of rows of the matrix XK.  It must
C               have the same value as N in SQRDC.
C
C        K      INTEGER
C               K is the number of columns of the matrix XK.  K
C               must not be greater than MIN(N,P), where P is the
C               same as in the calling sequence to SQRDC.
C
C        QRAUX  REAL(P)
C               QRAUX contains the auxiliary output from SQRDC.
C
C        Y      REAL(N)
C               Y contains an N-vector that is to be manipulated
C               by SQRSL.
C
C        JOB    INTEGER
C               JOB specifies what is to be computed.  JOB has
C               the decimal expansion ABCDE, with the following
C               meaning.
C
C                    If A .NE. 0, compute QY.
C                    If B,C,D, or E .NE. 0, compute QTY.
C                    If C .NE. 0, compute B.
C                    If D .NE. 0, compute RSD.
C                    If E .NE. 0, compute XB.
C
C               Note that a request to compute B, RSD, or XB
C               automatically triggers the computation of QTY, for
C               which an array must be provided in the calling
C               sequence.
C
C     On Return
C
C        QY     REAL(N).
C               QY contains Q*Y, if its computation has been
C               requested.
C
C        QTY    REAL(N).
C               QTY contains TRANS(Q)*Y, if its computation has
C               been requested.  Here TRANS(Q) is the
C               transpose of the matrix Q.
C
C        B      REAL(K)
C               B contains the solution of the least squares problem
C
C                    minimize norm2(Y - XK*B),
C
C               if its computation has been requested.  (Note that
C               if pivoting was requested in SQRDC, the J-th
C               component of B will be associated with column JPVT(J)
C               of the original matrix X that was input into SQRDC.)
C
C        RSD    REAL(N).
C               RSD contains the least squares residual Y - XK*B,
C               if its computation has been requested.  RSD is
C               also the orthogonal projection of Y onto the
C               orthogonal complement of the column space of XK.
C
C        XB     REAL(N).
C               XB contains the least squares approximation XK*B,
C               if its computation has been requested.  XB is also
C               the orthogonal projection of Y onto the column space
C               of X.
C
C        INFO   INTEGER.
C               INFO is zero unless the computation of B has
C               been requested and R is exactly singular.  In
C               this case, INFO is the index of the first zero
C               diagonal element of R and B is left unaltered.
C
C     The parameters QY, QTY, B, RSD, and XB are not referenced
C     if their computation is not requested and in this case
C     can be replaced by dummy variables in the calling program.
C     To save storage, the user may in some cases use the same
C     array for different parameters in the calling sequence.  A
C     frequently occuring example is when one wishes to compute
C     any of B, RSD, or XB and does not need Y or QTY.  In this
C     case one may identify Y, QTY, and one of B, RSD, or XB, while
C     providing separate arrays for anything else that is to be
C     computed.  Thus the calling sequence
C
C          CALL SQRSL(X,LDX,N,K,QRAUX,Y,DUM,Y,B,Y,DUM,110,INFO)
C
C     will result in the computation of B and RSD, with RSD
C     overwriting Y.  More generally, each item in the following
C     list contains groups of permissible identifications for
C     a single callinng sequence.
C
C          1. (Y,QTY,B) (RSD) (XB) (QY)
C
C          2. (Y,QTY,RSD) (B) (XB) (QY)
C
C          3. (Y,QTY,XB) (B) (RSD) (QY)
C
C          4. (Y,QY) (QTY,B) (RSD) (XB)
C
C          5. (Y,QY) (QTY,RSD) (B) (XB)
C
C          6. (Y,QY) (QTY,XB) (B) (RSD)
C
C     In any group the value returned in the array allocated to
C     the group corresponds to the last member of the group.
C
C     LINPACK.  This version dated 08/14/78 .
C     G. W. Stewart, University of Maryland, Argonne National Lab.
C
C     SQRSL uses the following functions and subprograms.
C
C     BLAS SAXPY,SCOPY,SDOT
C     Fortran ABS,MIN0,MOD
C***REFERENCES  DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W.,
C                 *LINPACK USERS  GUIDE*, SIAM, 1979.
C***ROUTINES CALLED  SAXPY,SCOPY,SDOT
C***END PROLOGUE  SQRSL
      INTEGER LDX,N,K,JOB,INFO
      REAL X(LDX,1),QRAUX(1),Y(1),QY(1),QTY(1),B(1),RSD(1),XB(1)
C
      INTEGER I,J,JJ,JU,KP1
      REAL SDOT,T,TEMP
      LOGICAL CB,CQY,CQTY,CR,CXB
C
C     SET INFO FLAG.
C
C***FIRST EXECUTABLE STATEMENT  SQRSL
      INFO = 0
C
C     DETERMINE WHAT IS TO BE COMPUTED.
C
      CQY = JOB/10000 .NE. 0
      CQTY = MOD(JOB,10000) .NE. 0
      CB = MOD(JOB,1000)/100 .NE. 0
      CR = MOD(JOB,100)/10 .NE. 0
      CXB = MOD(JOB,10) .NE. 0
      JU = MIN0(K,N-1)
C
C     SPECIAL ACTION WHEN N=1.
C
      IF (JU .NE. 0) GO TO 40
         IF (CQY) QY(1) = Y(1)
         IF (CQTY) QTY(1) = Y(1)
         IF (CXB) XB(1) = Y(1)
         IF (.NOT.CB) GO TO 30
            IF (X(1,1) .NE. 0.0E0) GO TO 10
               INFO = 1
            GO TO 20
   10       CONTINUE
               B(1) = Y(1)/X(1,1)
   20       CONTINUE
   30    CONTINUE
         IF (CR) RSD(1) = 0.0E0
      GO TO 250
   40 CONTINUE
C
C        SET UP TO COMPUTE QY OR QTY.
C
         IF (CQY) CALL SCOPY(N,Y,1,QY,1)
         IF (CQTY) CALL SCOPY(N,Y,1,QTY,1)
         IF (.NOT.CQY) GO TO 70
C
C           COMPUTE QY.
C
            DO 60 JJ = 1, JU
               J = JU - JJ + 1
               IF (QRAUX(J) .EQ. 0.0E0) GO TO 50
                  TEMP = X(J,J)
                  X(J,J) = QRAUX(J)
                  T = -SDOT(N-J+1,X(J,J),1,QY(J),1)/X(J,J)
                  CALL SAXPY(N-J+1,T,X(J,J),1,QY(J),1)
                  X(J,J) = TEMP
   50          CONTINUE
   60       CONTINUE
   70    CONTINUE
         IF (.NOT.CQTY) GO TO 100
C
C           COMPUTE TRANS(Q)*Y.
C
            DO 90 J = 1, JU
               IF (QRAUX(J) .EQ. 0.0E0) GO TO 80
                  TEMP = X(J,J)
                  X(J,J) = QRAUX(J)
                  T = -SDOT(N-J+1,X(J,J),1,QTY(J),1)/X(J,J)
                  CALL SAXPY(N-J+1,T,X(J,J),1,QTY(J),1)
                  X(J,J) = TEMP
   80          CONTINUE
   90       CONTINUE
  100    CONTINUE
C
C        SET UP TO COMPUTE B, RSD, OR XB.
C
         IF (CB) CALL SCOPY(K,QTY,1,B,1)
         KP1 = K + 1
         IF (CXB) CALL SCOPY(K,QTY,1,XB,1)
         IF (CR .AND. K .LT. N) CALL SCOPY(N-K,QTY(KP1),1,RSD(KP1),1)
         IF (.NOT.CXB .OR. KP1 .GT. N) GO TO 120
            DO 110 I = KP1, N
               XB(I) = 0.0E0
  110       CONTINUE
  120    CONTINUE
         IF (.NOT.CR) GO TO 140
            DO 130 I = 1, K
               RSD(I) = 0.0E0
  130       CONTINUE
  140    CONTINUE
         IF (.NOT.CB) GO TO 190
C
C           COMPUTE B.
C
            DO 170 JJ = 1, K
               J = K - JJ + 1
               IF (X(J,J) .NE. 0.0E0) GO TO 150
                  INFO = J
C           ......EXIT
                  GO TO 180
  150          CONTINUE
               B(J) = B(J)/X(J,J)
               IF (J .EQ. 1) GO TO 160
                  T = -B(J)
                  CALL SAXPY(J-1,T,X(1,J),1,B,1)
  160          CONTINUE
  170       CONTINUE
  180       CONTINUE
  190    CONTINUE
         IF (.NOT.CR .AND. .NOT.CXB) GO TO 240
C
C           COMPUTE RSD OR XB AS REQUIRED.
C
            DO 230 JJ = 1, JU
               J = JU - JJ + 1
               IF (QRAUX(J) .EQ. 0.0E0) GO TO 220
                  TEMP = X(J,J)
                  X(J,J) = QRAUX(J)
                  IF (.NOT.CR) GO TO 200
                     T = -SDOT(N-J+1,X(J,J),1,RSD(J),1)/X(J,J)
                     CALL SAXPY(N-J+1,T,X(J,J),1,RSD(J),1)
  200             CONTINUE
                  IF (.NOT.CXB) GO TO 210
                     T = -SDOT(N-J+1,X(J,J),1,XB(J),1)/X(J,J)
                     CALL SAXPY(N-J+1,T,X(J,J),1,XB(J),1)
  210             CONTINUE
                  X(J,J) = TEMP
  220          CONTINUE
  230       CONTINUE
  240    CONTINUE
  250 CONTINUE
      RETURN
      END
      SUBROUTINE SROT(N,SX,INCX,SY,INCY,SC,SS)
C***BEGIN PROLOGUE  SROT
C***DATE WRITTEN   791001   (YYMMDD)
C***REVISION DATE  820801   (YYMMDD)
C***CATEGORY NO.  D1A8
C***KEYWORDS  BLAS,GIVENS ROTATION,LINEAR ALGEBRA,VECTOR
C***AUTHOR  LAWSON, C. L., (JPL)
C           HANSON, R. J., (SNLA)
C           KINCAID, D. R., (U. OF TEXAS)
C           KROGH, F. T., (JPL)
C***PURPOSE  Apply s.p. Givens rotation
C***DESCRIPTION
C
C                B L A S  Subprogram
C    Description of Parameters
C
C     --Input--
C        N  number of elements in input vector(s)
C       SX  single precision vector with N elements
C     INCX  storage spacing between elements of SX
C       SY  single precision vector with N elements
C     INCY  storage spacing between elements of SY
C       SC  element of rotation matrix
C       SS  element of rotation matrix
C
C     --Output--
C       SX  rotated vector SX (unchanged if N .LE. 0)
C       SY  rotated vector SY (unchanged if N .LE. 0)
C
C     Multiply the 2 x 2 matrix  ( SC SS) times the 2 x N matrix (SX**T)
C                                (-SS SC)                        (SY**T)
C     where **T indicates transpose.  The elements of SX are in
C     SX(LX+I*INCX), I = 0 to N-1, where LX = 1 if INCX .GE. 0, else
C     LX = (-INCX)*N, and similarly for SY using LY and INCY.
C***REFERENCES  LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T.,
C                 *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*,
C                 ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL
C                 SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323
C***ROUTINES CALLED  (NONE)
C***END PROLOGUE  SROT
C
      REAL             SX,SY,SC,SS,ZERO,ONE,W,Z
      DIMENSION SX(*),SY(*)
      DATA ZERO,ONE/0.E0,1.E0/
C***FIRST EXECUTABLE STATEMENT  SROT
      IF(N .LE. 0 .OR. (SS .EQ. ZERO .AND. SC .EQ. ONE)) GO TO 40
      IF(.NOT. (INCX .EQ. INCY .AND. INCX .GT. 0)) GO TO 20
C
           NSTEPS=INCX*N
           DO 10 I=1,NSTEPS,INCX
                W=SX(I)
                Z=SY(I)
                SX(I)=SC*W+SS*Z
                SY(I)=-SS*W+SC*Z
   10           CONTINUE
           GO TO 40
C
   20 CONTINUE
           KX=1
           KY=1
C
           IF(INCX .LT. 0) KX=1-(N-1)*INCX
           IF(INCY .LT. 0) KY=1-(N-1)*INCY
C
           DO 30 I=1,N
                W=SX(KX)
                Z=SY(KY)
                SX(KX)=SC*W+SS*Z
                SY(KY)=-SS*W+SC*Z
                KX=KX+INCX
                KY=KY+INCY
   30           CONTINUE
   40 CONTINUE
C
      RETURN
      END
      SUBROUTINE SROTG(SA,SB,SC,SS)
C***BEGIN PROLOGUE  SROTG
C***DATE WRITTEN   791001   (YYMMDD)
C***REVISION DATE  820801   (YYMMDD)
C***CATEGORY NO.  D1B10
C***KEYWORDS  BLAS,GIVENS ROTATION,LINEAR ALGEBRA,VECTOR
C***AUTHOR  LAWSON, C. L., (JPL)
C           HANSON, R. J., (SNLA)
C           KINCAID, D. R., (U. OF TEXAS)
C           KROGH, F. T., (JPL)
C***PURPOSE  Construct s.p. plane Givens rotation
C***DESCRIPTION
C
C                B L A S  Subprogram
C    Description of Parameters
C
C     --Input--
C       SA  single precision scalar
C       SB  single precision scalar
C
C     --Output--
C       SA  single precision result R
C       SB  single precision result Z
C       SC  single precision result
C       SS  single precision result
C
C     Designed by C. L. Lawson, JPL, 1977 Sept 08
C
C
C     Construct the Givens transformation
C
C         ( SC  SS )
C     G = (        ) ,    SC**2 + SS**2 = 1 ,
C         (-SS  SC )
C
C     which zeros the second entry of the 2-vector  (SA,SB)**T.
C
C     The quantity R = (+/-)SQRT(SA**2 + SB**2) overwrites SA in
C     storage.  The value of SB is overwritten by a value Z which
C     allows SC and SS to be recovered by the following algorithm:
C
C           If Z=1  set  SC=0.  and  SS=1.
C           If ABS(Z) .LT. 1  set  SC=SQRT(1-Z**2)  and  SS=Z
C           If ABS(Z) .GT. 1  set  SC=1/Z  and  SS=SQRT(1-SC**2)
C
C     Normally, the subprogram SROT(N,SX,INCX,SY,INCY,SC,SS) will
C     next be called to apply the transformation to a 2 by N matrix.
C***REFERENCES  LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T.,
C                 *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*,
C                 ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL
C                 SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323
C***ROUTINES CALLED  (NONE)
C***END PROLOGUE  SROTG
C
C***FIRST EXECUTABLE STATEMENT  SROTG
      IF (ABS(SA) .LE. ABS(SB)) GO TO 10
C
C *** HERE ABS(SA) .GT. ABS(SB) ***
C
      U = SA + SA
      V = SB / U
C
C     NOTE THAT U AND R HAVE THE SIGN OF SA
C
      R = SQRT(.25 + V**2) * U
C
C     NOTE THAT SC IS POSITIVE
C
      SC = SA / R
      SS = V * (SC + SC)
      SB = SS
      SA = R
      RETURN
C
C *** HERE ABS(SA) .LE. ABS(SB) ***
C
   10 IF (SB .EQ. 0.) GO TO 20
      U = SB + SB
      V = SA / U
C
C     NOTE THAT U AND R HAVE THE SIGN OF SB
C     (R IS IMMEDIATELY STORED IN SA)
C
      SA = SQRT(.25 + V**2) * U
C
C     NOTE THAT SS IS POSITIVE
C
      SS = SB / SA
      SC = V * (SS + SS)
      IF (SC .EQ. 0.) GO TO 15
      SB = 1. / SC
      RETURN
   15 SB = 1.
      RETURN
C
C *** HERE SA = SB = 0. ***
C
   20 SC = 1.
      SS = 0.
      RETURN
C
      END
      SUBROUTINE SRTMEA(Y,XH1,N,ICASE,
     1                  MAXNXT,
     1                  XH1DIS,STTEMP,TEMP,TEMP2,TEMP3,TEMP4,TEMP5,
     1                  X2,AINDX,NUMSE1,
     1                  ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
     1                  DTEMP1,DTEMP2,DTEMP3,
     1                  ISUBRO,IBUGA3,IERROR)
C
C     PURPOSE--SORT BY MEAN (OR SOME OTHER LOCATION STATISTIC).
C              THAT IS,
C
C                 LET X2 INDEX = SORT BY MEAN Y X
C
C               WILL SORT X (HERE X IS A GROUP-ID VARIABLE AND
C               Y IS A RESPONSE VARIABLE) BASED ON THE MEAN
C               (OR SOME OTHER APPROPRIATE STATISTIC).
C     WRITTEN BY--ALAN HECKERT
C                 STATISTICAL ENGINEERING DIVISION
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2899
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2005/12
C     ORIGINAL VERSION--DECEMBER  2005.
C     UPDATED         --JANUARY   2007.  CALL LIST TO CODE
C     UPDATED         --JUNE      2010.  CALL LIST TO CMPSTA
C     UPDATED         --JULY      2016.  FIX ISSUE WHEN X IS NOT
C                                        PRE-SORTED
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 ICASE
      CHARACTER*4 ISUBRO
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 IWRITE
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 ISTEPN
C
C---------------------------------------------------------------------
C
      DIMENSION Y(*)
      DIMENSION XH1(*)
      DIMENSION X2(*)
      DIMENSION AINDX(*)
C
      DIMENSION XH1DIS(*)
      DIMENSION STTEMP(*)
      DIMENSION TEMP(*)
      DIMENSION TEMP2(*)
      DIMENSION TEMP3(*)
      DIMENSION TEMP4(*)
      DIMENSION TEMP5(*)
      INTEGER ITEMP1(*)
      INTEGER ITEMP2(*)
      INTEGER ITEMP3(*)
      INTEGER ITEMP4(*)
      INTEGER ITEMP5(*)
      INTEGER ITEMP6(*)
      DOUBLE PRECISION DTEMP1(*)
      DOUBLE PRECISION DTEMP2(*)
      DOUBLE PRECISION DTEMP3(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOPA.INC'
      INCLUDE 'DPCOST.INC'
      INCLUDE 'DPCOHK.INC'
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='SRTM'
      ISUBN2='EA  '
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LE.1)THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,31)
   31   FORMAT('***** ERROR IN SORT BY <STATISTIC>--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,32)
   32   FORMAT('      THE NUMBER OF OBSERVATIONS MUST BE AT LEAST 2.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,34)N
   34   FORMAT('      THE ENTERED NUMBER OF OBSERVATIONS HERE = ',I6)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        GOTO9000
      ENDIF
C
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'TMEA')THEN
        WRITE(ICOUT,70)
   70   FORMAT('AT THE BEGINNING OF SRTMEA--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,71)N,ICASE
   71   FORMAT('N,ICASE = ',I8,2X,A4)
        CALL DPWRST('XXX','BUG ')
        DO72I=1,N
          WRITE(ICOUT,73)I,Y(I),XH1(I)
   73     FORMAT('I, Y(I), XH1(I) = ',I8,2G15.7)
          CALL DPWRST('XXX','BUG ')
   72   CONTINUE
      ENDIF
C
C               ******************************************************
C               **  STEP 2--                                        **
C               **  DETERMINE THE NUMBER OF DISTINCT VALUES         **
C               **  FOR VARIABLE 2 (ONE OF THE GROUP VARIABLES).    **
C               ******************************************************
C
      ISTEPN='2'
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'TMEA')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
C  THE DISTINCT VALUES WILL BE CODED INTO 1, 2, ... , NDIST.
C  NOTE THAT TRYING TO MAINTAIN ORIGINAL SCALE IS PROBLEMATIC
C  IF THE DATA HAS GAPS (E.G., 101, 102, 105) SINCE WE HAVE
C  NO EASY WAY TO AUTOMATICALLY PLACE THE TIC MARK LABELS.
C
      IWRITE='OFF'
      CALL CODE(XH1,N,IWRITE,TEMP3,TEMP5,MAXNXT,IBUGA3,IERROR)
      DO110I=1,N
        XH1(I)=TEMP3(I)
  110 CONTINUE
      CALL DISTIN(XH1,N,IWRITE,XH1DIS,NUMSE1,IBUGA3,IERROR)
C
C     JULY 2016: FOLLOWING LINE NEEDED FOR CASE WHERE X VARIABLE
C                NOT PRE-SORTED.
C
      CALL SORT(XH1DIS,NUMSE1,XH1DIS)
C
      AN=N
      ANUMS1=NUMSE1
C
      DO310I=1,NUMSE1
        NTEMP=0
        DO320J=1,N
          IF(XH1(J).EQ.XH1DIS(I))THEN
            NTEMP=NTEMP+1
            TEMP2(NTEMP)=Y(J)
          ENDIF
  320   CONTINUE
        IWRITE='OFF'
        IF(NTEMP.GT.0)THEN
          NUMV=1
          CALL CMPSTA(TEMP2,TEMP,TEMP,TEMP3,TEMP4,TEMP5,
     1                MAXNXT,NTEMP,NTEMP,NTEMP,NUMV,ICASE,
     1                ISEED,ITEMP1,ITEMP2,ITEMP3,
     1                ITEMP4,ITEMP5,ITEMP6,
     1                DTEMP1,DTEMP2,DTEMP3,
CCCCC1                IQUAME,IQUASE,PSTAMV,
     1                STAT1,
     1                ISUBRO,IBUGA3,IERROR)
          IF(IERROR.EQ.'YES')GOTO9000
          STTEMP(I)=STAT1
CCCCC     AINDX(I)=REAL(I)
          AINDX(I)=XH1DIS(I)
        ELSE
          IERROR='YES'
          GOTO9000
        ENDIF
  310 CONTINUE
C
      CALL SORTC(STTEMP,AINDX,NUMSE1,STTEMP,TEMP3)
C
      DO390I=1,NUMSE1
        AINDX(I)=TEMP3(I)
  390 CONTINUE
C
      DO410I=1,NUMSE1
        AVALUE=0.0
        DO415J=1,NUMSE1
          IF(XH1DIS(I).EQ.AINDX(J))THEN
CCCCC       AVALUE=REAL(J)
            AVALUE=XH1DIS(J)
            GOTO419
          ENDIF
  415   CONTINUE
  419   CONTINUE
        DO420J=1,N
          IF(XH1(J).EQ.XH1DIS(I))THEN
            X2(J)=AVALUE
          ENDIF
  420   CONTINUE
  410 CONTINUE
C
C               ******************
C               **   STEP 90--  **
C               **   EXIT       **
C               ******************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'TMEA')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END       OF SRTMEA--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9015)NUMSE1
 9015   FORMAT('NUMSE1 = ',I8)
        CALL DPWRST('XXX','BUG ')
        DO9020I=1,NUMSE1
          WRITE(ICOUT,9021)I,XH1DIS(I),AINDX(I)
 9021     FORMAT('I,XH1DIS(I),AINDX(I) = ',I8,2G15.7)
          CALL DPWRST('XXX','BUG ')
 9020   CONTINUE
        DO9030I=1,N
          WRITE(ICOUT,9031)I,Y(I),XH1(I),X2(I)
 9031     FORMAT('I,Y(I),XH1(I),X2(I) = ',I8,G15.7)
          CALL DPWRST('XXX','BUG ')
 9030   CONTINUE
      ENDIF
C
      RETURN
      END
      subroutine ss(y,n,np,ns,isdeg,nsjump,userw,rw,season,work1,work2,
     &work3,work4)
c
c  This routine is part of the Bill Cleveland seasonal loess
c  program.
c
      integer n, np, ns, isdeg, nsjump, nright, nleft, i, j, k
      real y(n), rw(n), season(n+2*np), work1(n), work2(n), work3(n),
     &work4(n), xs
      logical userw,ok
      j=1
23105 if(.not.(j .le. np))goto 23107
      k = (n-j)/np+1
      do 23108 i = 1,k
      work1(i) = y((i-1)*np+j)
23108 continue
      if(.not.(userw))goto 23110
      do 23112 i = 1,k
      work3(i) = rw((i-1)*np+j)
23112 continue
23110 continue
      call ess(work1,k,ns,isdeg,nsjump,userw,work3,work2(2),work4)
      xs = 0
      nright = min0(ns,k)
      call est(work1,k,ns,isdeg,xs,work2(1),1,nright,work4,userw,work3,
     &ok)
      if(.not.( .not. ok))goto 23114
      work2(1) = work2(2)
23114 continue
      xs = k+1
      nleft = max0(1,k-ns+1)
      call est(work1,k,ns,isdeg,xs,work2(k+2),nleft,k,work4,userw,work3,
     &ok)
      if(.not.( .not. ok))goto 23116
      work2(k+2) = work2(k+1)
23116 continue
      do 23118 m = 1,k+2
      season((m-1)*np+j) = work2(m)
23118 continue
       j=j+1
      goto 23105
23107 continue
      return
      end
      SUBROUTINE SSCAL(N,SA,SX,INCX)
C***BEGIN PROLOGUE  SSCAL
C***DATE WRITTEN   791001   (YYMMDD)
C***REVISION DATE  820801   (YYMMDD)
C***CATEGORY NO.  D1A6
C***KEYWORDS  BLAS,LINEAR ALGEBRA,SCALE,VECTOR
C***AUTHOR  LAWSON, C. L., (JPL)
C           HANSON, R. J., (SNLA)
C           KINCAID, D. R., (U. OF TEXAS)
C           KROGH, F. T., (JPL)
C***PURPOSE  S.P. vector scale x = a*x
C***DESCRIPTION
C
C                B L A S  Subprogram
C    Description of Parameters
C
C     --Input--
C        N  number of elements in input vector(s)
C       SA  single precision scale factor
C       SX  single precision vector with N elements
C     INCX  storage spacing between elements of SX
C
C     --Output--
C       SX  single precision result (unchanged if N .LE. 0)
C
C     Replace single precision SX by single precision SA*SX.
C     For I = 0 to N-1, replace SX(1+I*INCX) with  SA * SX(1+I*INCX)
C***REFERENCES  LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T.,
C                 *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*,
C                 ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL
C                 SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323
C***ROUTINES CALLED  (NONE)
C***END PROLOGUE  SSCAL
C
      REAL SA,SX(*)
C***FIRST EXECUTABLE STATEMENT  SSCAL
      IF(N.LE.0)RETURN
      IF(INCX.EQ.1)GOTO 20
C
C        CODE FOR INCREMENTS NOT EQUAL TO 1.
C
      NS = N*INCX
          DO 10 I = 1,NS,INCX
          SX(I) = SA*SX(I)
   10     CONTINUE
      RETURN
C
C        CODE FOR INCREMENTS EQUAL TO 1.
C
C
C        CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 5.
C
   20 M = MOD(N,5)
      IF( M .EQ. 0 ) GO TO 40
      DO 30 I = 1,M
        SX(I) = SA*SX(I)
   30 CONTINUE
      IF( N .LT. 5 ) RETURN
   40 MP1 = M + 1
      DO 50 I = MP1,N,5
        SX(I) = SA*SX(I)
        SX(I + 1) = SA*SX(I + 1)
        SX(I + 2) = SA*SX(I + 2)
        SX(I + 3) = SA*SX(I + 3)
        SX(I + 4) = SA*SX(I + 4)
   50 CONTINUE
      RETURN
      END
      SUBROUTINE SSIEV(A,LDA,N,E,WORK,JOB,INFO)
C***BEGIN PROLOGUE  SSIEV
C***DATE WRITTEN   800808   (YYMMDD)
C***REVISION DATE  820801   (YYMMDD)
C***CATEGORY NO.  D4A1
C***KEYWORDS  EIGENVALUE,EIGENVECTOR,MATRIX,REAL,SYMMETRIC
C***AUTHOR  KAHANER, D. K., (NBS)
C           MOLER, C. B., (U. OF NEW MEXICO)
C           STEWART, G. W., (U. OF MARYLAND)
C***PURPOSE  To compute the eigenvalues and, optionally, the eigen-
C            vectors of a real SYMMETRIC matrix.
C***DESCRIPTION
C
C     LICEPACK.  This version dated 08/08/80.
C     David Kahaner, Cleve Moler, Pete Stewart
C          N.B.S.       U.N.M.     N.B.S./U.MD.
C
C     Abstract
C      SSIEV computes the eigenvalues and, optionally, the eigenvectors
C      of a real symmetric matrix.
C
C     Call Sequence Parameters-
C       (The values of parameters marked with * (star) will be  changed
C         by SSIEV.)
C
C       A*      REAL (LDA,N)
C               real symmetric input matrix.
C               Only the diagonal and upper triangle of A must be input,
C               as SSIEV copies the upper triangle to the lower.
C               That is, the user must define A(I,J), I=1,..N, and J=I,.
C               ..,N.
C               On return from SSIEV, if the user has set JOB
C               = 0        the lower triangle of A has been altered.
C               = nonzero  the N eigenvectors of A are stored in its
C               first N columns.  See also INFO below.
C
C       LDA     INTEGER
C               set by the user to
C               the leading dimension of the array A.
C
C       N       INTEGER
C               set by the user to
C               the order of the matrix A and
C               the number of elements in E.
C
C       E*      REAL (N)
C               on return from SSIEV, E contains the N
C               eigenvalues of A.  See also INFO below.
C
C       WORK*   REAL (2*N)
C               temporary storage vector.  Contents changed by SSIEV.
C
C       JOB     INTEGER
C               set by user on input
C               = 0         only calculate eigenvalues of A.
C               = nonzero   calculate eigenvalues and eigenvectors of A.
C
C       INFO*   INTEGER
C               on return from SSIEV, the value of INFO is
C               = 0 for normal return.
C               = K if the eigenvalue iteration fails to converge.
C                   eigenvalues and vectors 1 through K-1 are correct.
C
C
C     Error Messages-
C          No. 1   recoverable  N is greater than LDA
C          No. 2   recoverable  N is less than one
C
C     Subroutines Used
C
C     EISPACK- TRED1, TRED2, TQLRAT, IMTQL2
C     SLATEC-  XERROR
C***REFERENCES  (NONE)
C***ROUTINES CALLED  IMTQL2,TQLRAT,TRED1,TRED2,XERROR
C***END PROLOGUE  SSIEV
      INTEGER INFO,JOB,LDA,N
      REAL A(LDA,N),E(N),WORK(1)
C***FIRST EXECUTABLE STATEMENT  SSIEV
       IF(N .GT. LDA)THEN
CCCCC    WRITE(*,*) 'FROM SSIEV: N .GT. LDA.'
         INFO = -1
         RETURN
       ENDIF
       IF(N .LT. 1) THEN
CCCCC    WRITE(*,*) 'FROM SSIEV: N .LT. 1'
         INFO = -2
         RETURN
       ENDIF
C
C       CHECK N=1 CASE
C
      E(1) = A(1,1)
      INFO = 0
      IF(N .EQ. 1) RETURN
C
C     COPY UPPER TRIANGLE TO LOWER
C
      DO 10 J=1,N
         DO 11 I=1,J
            A(J,I)=A(I,J)
   11    CONTINUE
   10 CONTINUE
C
      IF(JOB.NE.0) GO TO 20
C
C     EIGENVALUES ONLY
C
      CALL TRED1(LDA,N,A,E,WORK(1),WORK(N+1))
      CALL TQLRAT(N,E,WORK(N+1),INFO)
      RETURN
C
C     EIGENVALUES AND EIGENVECTORS
C
   20 CALL TRED2(LDA,N,A,E,WORK,A)
      CALL IMTQL2(LDA,N,E,WORK,A,INFO)
      RETURN
      END
      SUBROUTINE SSNC(P1,P2,ALPHA,BETA,N,IC,IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE
C              BINOMIAL BASED SINGLE SAMPLE PLAN (N,C).
C     INPUT  ARGUMENTS--P1     = THE SINGLE PRECISION VALUE FOR
C                                THE ACCEPTABLE QUALITY LEVEL.
C                     --P2     = THE SINGLE PRECISION VALUE FOR
C                                THE LOT TOLERANCE PERCENT DEFECTIVE
C                     --ALPHA  = PROBABILITY FOR AQL.
C                     --BETA   = PROBABILITY FOR LTPD.
C     OUTPUT ARGUMENTS--N      = THE COMPUTED SAMPLE SIZE.
C                     --IC     = ACCEPTABLE NUMBER OF DEFECTIVES.
C     OTHER DATAPAC   SUBROUTINES NEEDED--BINCDF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--MONTGOMERY, STATISTICAL QUALITY CONTROL,
C                 ALGORITHM IS FORTRAN TRANSLATION OF A BASIC CODE
C                 PROVIDED BY JACK PRINS.
C     WRITTEN BY--ALAN HECKERT
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-075-2899
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--99/3
C     ORIGINAL VERSION--MARCH     1999.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DCDF
C
      REAL L
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      IF(IBUGA3.EQ.'ON')THEN
        WRITE(ICOUT,11)
   11   FORMAT('AT THE BEGINNING OF SSNC')
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      IERROR='NO'
      MAXIT=10000
      I=0
  100 CONTINUE
      IF(I.GT.MAXIT)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,101)
  101   FORMAT('***** MAXIMUM NUMBER OF ITERATIONS EXCEEDED FOR THE ',
     1         'BINOMIAL SINGLE SAMPLE PLAN')
        CALL DPWRST('XXX','BUG ')
        N=0
        IC=0
        GOTO9000
      ENDIF
      IDF=2 + 2*I
      P=1.0 - BETA
      CALL CHSPPF(P,IDF,PPF)
      L=0.5*(REAL(I) + (-0.5 + 1.0/P2)*PPF)
C
      IDF=2 + 2*I
      P=ALPHA
      CALL CHSPPF(P,IDF,PPF)
      U=0.5*(REAL(I) + (-0.5 + 1.0/P1)*PPF)
C
      IF(INT(U)-INT(L).LT.1)THEN
        I=I+1
        GOTO100
      ENDIF
C
      IF(U.GT.L)THEN
        N=INT(U)
      ELSE
        N=INT(L)
      ENDIF
      IC=I
C
  300 CONTINUE
      N=N-1
      CALL BINCDF(DBLE(IC),DBLE(P2),N,DCDF)
      S=REAL(DCDF)
      IF(S.GT.BETA)GOTO400
      BCDF=S
      GOTO300
C
  400 CONTINUE
      N=N+1
      CALL BINCDF(DBLE(IC),DBLE(P1),N,DCDF)
      S=REAL(DCDF)
      ACDF=S
C
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1001)
 1001 FORMAT('BINOMIAL SINGLE SAMPLE PLAN')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1011)P1
 1011 FORMAT('     P1 (= Acceptable Quality Level)          = ',F7.4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1021)P2
 1021 FORMAT('     P2 (= Lot Tolerance Percent Defective)   = ',F7.4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1031)ALPHA
 1031 FORMAT('     ALPHA                                    = ',F7.4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1041)BETA
 1041 FORMAT('     BETA                                     = ',F7.4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1051)N
 1051 FORMAT('     Computed Sample Size                     = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1061)IC
 1061 FORMAT('     Computed Acceptance Number              = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
C
      WRITE(ICOUT,1071)
 1071 FORMAT('The sample size and acceptance number are saved in')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1081)
 1081 FORMAT('the internal parameters SSN and SSC respectively.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE SSORT(X,Y,N,KFLAG)
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***BEGIN PROLOGUE  SSORT
C***DATE WRITTEN   761101   (YYMMDD)
C***REVISION DATE  820801   (YYMMDD)
C***CATEGORY NO.  N6A2B1
C***KEYWORDS  QUICKSORT,SINGLETON QUICKSORT,SORT,SORTING
C***AUTHOR  JONES, R. E., (SNLA)
C           WISNIEWSKI, J. A., (SNLA)
C***PURPOSE  SSORT sorts array X and optionally makes the same
C            interchanges in array Y.  The array X may be sorted in
C            increasing order or decreasing order.  A slightly modified
C            QUICKSORT algorithm is used.
C***DESCRIPTION
C
C     Written by Rondall E. Jones
C     Modified by John A. Wisniewski to use the Singleton quicksort
C     algorithm.  Date 18 November 1976.
C
C     Abstract
C         SSORT sorts array X and optionally makes the same
C         interchanges in array Y.  The array X may be sorted in
C         increasing order or decreasing order.  A slightly modified
C         quicksort algorithm is used.
C
C     Reference
C         Singleton, R. C., Algorithm 347, An Efficient Algorithm for
C         Sorting with Minimal Storage, CACM,12(3),1969,185-7.
C
C     Description of Parameters
C         X - array of values to be sorted   (usually abscissas)
C         Y - array to be (optionally) carried along
C         N - number of values in array X to be sorted
C         KFLAG - control parameter
C             =2  means sort X in increasing order and carry Y along.
C             =1  means sort X in increasing order (ignoring Y)
C             =-1 means sort X in decreasing order (ignoring Y)
C             =-2 means sort X in decreasing order and carry Y along.
C***REFERENCES  SINGLETON,R.C., ALGORITHM 347, AN EFFICIENT ALGORITHM
C                 FOR SORTING WITH MINIMAL STORAGE, CACM,12(3),1969,
C                 185-7.
C***END PROLOGUE  SSORT
      integer n, kflag
      double precision X(N),Y(N)
      integer IL(21),IU(21)
c
      double precision t, tt, r, ty, tty
c
      INCLUDE 'DPCOP2.INC'
C
C***FIRST EXECUTABLE STATEMENT  SSORT
      NN = N
      IF (NN.LT.1) THEN
         WRITE(ICOUT,1)
    1    FORMAT('*****ERROR FROM SSORT--')
         CALL DPWRST('XXX','WRIT')
         WRITE(ICOUT,2)
    2    FORMAT('     THE NUMBER OF VALUES TO BE SORTED WAS NOT ',
     1          'POSITIVE.')
         CALL DPWRST('XXX','WRIT')
         RETURN
      ENDIF
      KK = IABS(KFLAG)
      IF ((KK.EQ.1).OR.(KK.EQ.2)) GO TO 15
         WRITE(ICOUT,1)
         CALL DPWRST('XXX','WRIT')
         WRITE(ICOUT,3)
    3    FORMAT('     THE SORT CONTROL PARAMETER, K, WAS NOT ',
     1          '2, 1, -1, OR -2.')
         CALL DPWRST('XXX','WRIT')
         RETURN
C
C ALTER ARRAY X TO GET DECREASING ORDER IF NEEDED
C
   15 IF (KFLAG.GE.1) GO TO 30
      DO 20 I=1,NN
         X(I) = -X(I)
   20 CONTINUE
   30 CONTINUE
      GO TO (100,200),KK
C
C SORT X ONLY
C
  100 CONTINUE
      M=1
      I=1
      J=NN
      R=.375d0
  110 IF (I .EQ. J) GO TO 155
      IF (R .GT. .5898437d0) GO TO 120
      R=R+3.90625d-2
      GO TO 125
  120 R=R-.21875d0
  125 K=I
C                                  SELECT A CENTRAL ELEMENT OF THE
C                                  ARRAY AND SAVE IT IN LOCATION T
      IJ = I + INT(FLOAT (J-I) * R)
      T=X(IJ)
C                                  IF FIRST ELEMENT OF ARRAY IS GREATER
C                                  THAN T, INTERCHANGE WITH T
      IF (X(I) .LE. T) GO TO 130
      X(IJ)=X(I)
      X(I)=T
      T=X(IJ)
  130 L=J
C                                  IF LAST ELEMENT OF ARRAY IS LESS THAN
C                                  T, INTERCHANGE WITH T
      IF (X(J) .GE. T) GO TO 140
      X(IJ)=X(J)
      X(J)=T
      T=X(IJ)
C                                  IF FIRST ELEMENT OF ARRAY IS GREATER
C                                  THAN T, INTERCHANGE WITH T
      IF (X(I) .LE. T) GO TO 140
      X(IJ)=X(I)
      X(I)=T
      T=X(IJ)
      GO TO 140
  135 TT=X(L)
      X(L)=X(K)
      X(K)=TT
C                                  FIND AN ELEMENT IN THE SECOND HALF OF
C                                  THE ARRAY WHICH IS SMALLER THAN T
  140 L=L-1
      IF (X(L) .GT. T) GO TO 140
C                                  FIND AN ELEMENT IN THE FIRST HALF OF
C                                  THE ARRAY WHICH IS GREATER THAN T
  145 K=K+1
      IF (X(K) .LT. T) GO TO 145
C                                  INTERCHANGE THESE ELEMENTS
      IF (K .LE. L) GO TO 135
C                                  SAVE UPPER AND LOWER SUBSCRIPTS OF
C                                  THE ARRAY YET TO BE SORTED
      IF (L-I .LE. J-K) GO TO 150
      IL(M)=I
      IU(M)=L
      I=K
      M=M+1
      GO TO 160
  150 IL(M)=K
      IU(M)=J
      J=L
      M=M+1
      GO TO 160
C                                  BEGIN AGAIN ON ANOTHER PORTION OF
C                                  THE UNSORTED ARRAY
  155 M=M-1
      IF (M .EQ. 0) GO TO 300
      I=IL(M)
      J=IU(M)
  160 IF (J-I .GE. 1) GO TO 125
      IF (I .EQ. 1) GO TO 110
      I=I-1
  165 I=I+1
      IF (I .EQ. J) GO TO 155
      T=X(I+1)
      IF (X(I) .LE. T) GO TO 165
      K=I
  170 X(K+1)=X(K)
      K=K-1
      IF (T .LT. X(K)) GO TO 170
      X(K+1)=T
      GO TO 165
C
C SORT X AND CARRY Y ALONG
C
  200 CONTINUE
      M=1
      I=1
      J=NN
      R=.375d0
  210 IF (I .EQ. J) GO TO 255
      IF (R .GT. .5898437d0) GO TO 220
      R=R+3.90625d-2
      GO TO 225
  220 R=R-.21875d0
  225 K=I
C                                  SELECT A CENTRAL ELEMENT OF THE
C                                  ARRAY AND SAVE IT IN LOCATION T
      IJ = I + INT(FLOAT (J-I) *R)
      T=X(IJ)
      TY= Y(IJ)
C                                  IF FIRST ELEMENT OF ARRAY IS GREATER
C                                  THAN T, INTERCHANGE WITH T
      IF (X(I) .LE. T) GO TO 230
      X(IJ)=X(I)
      X(I)=T
      T=X(IJ)
       Y(IJ)= Y(I)
       Y(I)=TY
      TY= Y(IJ)
  230 L=J
C                                  IF LAST ELEMENT OF ARRAY IS LESS THAN
C                                  T, INTERCHANGE WITH T
      IF (X(J) .GE. T) GO TO 240
      X(IJ)=X(J)
      X(J)=T
      T=X(IJ)
       Y(IJ)= Y(J)
       Y(J)=TY
      TY= Y(IJ)
C                                  IF FIRST ELEMENT OF ARRAY IS GREATER
C                                  THAN T, INTERCHANGE WITH T
      IF (X(I) .LE. T) GO TO 240
      X(IJ)=X(I)
      X(I)=T
      T=X(IJ)
       Y(IJ)= Y(I)
       Y(I)=TY
      TY= Y(IJ)
      GO TO 240
  235 TT=X(L)
      X(L)=X(K)
      X(K)=TT
      TTY= Y(L)
       Y(L)= Y(K)
       Y(K)=TTY
C                                  FIND AN ELEMENT IN THE SECOND HALF OF
C                                  THE ARRAY WHICH IS SMALLER THAN T
  240 L=L-1
      IF (X(L) .GT. T) GO TO 240
C                                  FIND AN ELEMENT IN THE FIRST HALF OF
C                                  THE ARRAY WHICH IS GREATER THAN T
  245 K=K+1
      IF (X(K) .LT. T) GO TO 245
C                                  INTERCHANGE THESE ELEMENTS
      IF (K .LE. L) GO TO 235
C                                  SAVE UPPER AND LOWER SUBSCRIPTS OF
C                                  THE ARRAY YET TO BE SORTED
      IF (L-I .LE. J-K) GO TO 250
      IL(M)=I
      IU(M)=L
      I=K
      M=M+1
      GO TO 260
  250 IL(M)=K
      IU(M)=J
      J=L
      M=M+1
      GO TO 260
C                                  BEGIN AGAIN ON ANOTHER PORTION OF
C                                  THE UNSORTED ARRAY
  255 M=M-1
      IF (M .EQ. 0) GO TO 300
      I=IL(M)
      J=IU(M)
  260 IF (J-I .GE. 1) GO TO 225
      IF (I .EQ. 1) GO TO 210
      I=I-1
  265 I=I+1
      IF (I .EQ. J) GO TO 255
      T=X(I+1)
      TY= Y(I+1)
      IF (X(I) .LE. T) GO TO 265
      K=I
  270 X(K+1)=X(K)
       Y(K+1)= Y(K)
      K=K-1
      IF (T .LT. X(K)) GO TO 270
      X(K+1)=T
       Y(K+1)=TY
      GO TO 265
C
C CLEAN UP
C
  300 CONTINUE
      IF (KFLAG.GE.1) RETURN
      DO 310 I=1,NN
         X(I) = -X(I)
  310 CONTINUE
      RETURN
      END
      SUBROUTINE SSQ(X,N,XCAP,IWRITE,XSSQ,IBUGA3,ISUBRO,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE SUM OF SQUARES
C
C                  SSQ = SUM[i=1 to n][X(i)**2]
C
C              OF THE DATA IN THE INPUT VECTOR X.
C
C              SOME AUTHORS RECOMMEND CAPPING THE VALUE OF
C              OUTLIERS TO LESSEN THE EFFECT OF SEVERE OUTLIERS
C              (THIS CAP IS TYPICALLY SET TO EITHER +/-3 OR
C              +/- 4).  SET XOUT TO CPUMIN IF CAPPING IS NOT
C              DESIRED.
C
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF
C                                (UNSORTED OR SORTED) OBSERVATIONS.
C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR X.
C                     --XCAP   = OPTIONAL CAP VALUE
C     OUTPUT ARGUMENTS--XSSQ   = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED SUM OF SQUARES.
C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE SUM OF SQUARES.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     WRITTEN BY--ALAN HECKERT
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2012.2
C     ORIGINAL VERSION--FEBRUARY  2012.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGA3
      CHARACTER*4 ISUBRO
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DSUM
C
      DIMENSION X(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='SSQ '
      ISUBN2='    '
      IERROR='NO'
C
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'SSQ ')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,51)
   51   FORMAT('***** AT THE BEGINNING OF SSQ--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,52)IBUGA3,N,XCAP
   52   FORMAT('IBUGA3,N,XCAP = ',A4,2X,I8,2X,G15.7)
        CALL DPWRST('XXX','BUG ')
        DO55I=1,N
          WRITE(ICOUT,56)I,X(I)
   56     FORMAT('I,X(I) = ',I8,G15.7)
          CALL DPWRST('XXX','BUG ')
   55   CONTINUE
      ENDIF
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      IF(N.LT.1)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,111)
  111   FORMAT('***** ERROR IN SUM OF SQUARES--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,112)
  112   FORMAT('      THE NUMBER OF OBSERVATIONS FOR THE RESPONSE ',
     1         'VARIABLE IS LESS THAN 1.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,117)N
  117   FORMAT('      THE INPUT NUMBER OF OBSERVATIONS = ',I8)
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        GOTO9000
      ENDIF
C
C               *************************************
C               **  STEP 2--                       **
C               **  COMPUTE THE SUM OF SQUARES.    **
C               *************************************
C
      DSUM=0.0D0
      IF(XCAP.EQ.CPUMIN)THEN
        DO200I=1,N
          DX=X(I)
          DSUM=DSUM + DX*DX
  200   CONTINUE
      ELSE
        DO300I=1,N
          DX=X(I)
          IF(DABS(DX).GT.XCAP)THEN
            IF(DX.GT.0.0D0)THEN
              DX=ABS(XCAP)
            ELSE
              DX=-ABS(XCAP)
            ENDIF
          ENDIF
          DSUM=DSUM + DX*DX
  300   CONTINUE
      ENDIF
      XSSQ=REAL(DSUM)
C
C               *******************************
C               **  STEP 3--                 **
C               **  WRITE OUT A LINE         **
C               **  OF SUMMARY INFORMATION.  **
C               *******************************
C
      IF(IFEEDB.EQ.'ON' .AND. IWRITE.EQ.'ON')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,811)N,XSSQ
  811   FORMAT('THE SUM OF SQUARES OF THE ',I8,
     1         ' OBSERVATIONS = ',G15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'SSQ')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END OF SSQ--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9013)IERROR,N,DSUM,XSSQ
 9013   FORMAT('IERROR,N,DSUM,XSSQ = ',A4,2X,I8,2G15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      RETURN
      END
      SUBROUTINE SSQMEA(X,N,IWRITE,XSSQ,IBUGA3,ISUBRO,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE SUM OF SQUARES FROM THE
C              MEAN
C
C                  SSQ = SUM[i=1 to n][(X(i) - XBAR)**2]
C
C              OF THE DATA IN THE INPUT VECTOR X.
C
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF
C                                (UNSORTED OR SORTED) OBSERVATIONS.
C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR X.
C     OUTPUT ARGUMENTS--XSSQ   = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED SUM OF SQUARES FROM THE MEAN.
C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE SUM OF SQUARES
C             FROM THE MEAN
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     WRITTEN BY--ALAN HECKERT
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2013.2
C     ORIGINAL VERSION--FEBRUARY  2013.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGA3
      CHARACTER*4 ISUBRO
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DN
      DOUBLE PRECISION DX
      DOUBLE PRECISION DSUM
      DOUBLE PRECISION DXBAR
C
      DIMENSION X(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='SSQM'
      ISUBN2='EA  '
      IERROR='NO'
C
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'QMEA')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,51)
   51   FORMAT('***** AT THE BEGINNING OF SSQMEA--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,52)IBUGA3,N
   52   FORMAT('IBUGA3,N = ',A4,2X,I8)
        CALL DPWRST('XXX','BUG ')
        DO55I=1,N
          WRITE(ICOUT,56)I,X(I)
   56     FORMAT('I,X(I) = ',I8,G15.7)
          CALL DPWRST('XXX','BUG ')
   55   CONTINUE
      ENDIF
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      IF(N.LT.1)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,111)
  111   FORMAT('***** ERROR IN SUM OF SQUARES FROM THE MEAN--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,112)
  112   FORMAT('      THE NUMBER OF OBSERVATIONS FOR THE RESPONSE ',
     1         'VARIABLE IS LESS THAN 1.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,117)N
  117   FORMAT('      THE INPUT NUMBER OF OBSERVATIONS = ',I8)
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        GOTO9000
      ENDIF
C
C               *************************************
C               **  STEP 2--                       **
C               **  COMPUTE THE SUM OF SQUARES.    **
C               *************************************
C
      DN=DBLE(N)
      DSUM=0.0D0
      DO100I=1,N
        DX=X(I)
        DSUM=DSUM + DX
  100 CONTINUE
      DXBAR=DSUM/DN
C
      DSUM=0.0D0
      DO200I=1,N
        DX=X(I) - DXBAR
        DSUM=DSUM + DX*DX
  200 CONTINUE
C
      XSSQ=REAL(DSUM)
C
C               *******************************
C               **  STEP 3--                 **
C               **  WRITE OUT A LINE         **
C               **  OF SUMMARY INFORMATION.  **
C               *******************************
C
      IF(IFEEDB.EQ.'ON' .AND. IWRITE.EQ.'ON')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,811)N,XSSQ
  811   FORMAT('THE SUM OF SQUARES FROM THE MEAN OF THE ',I8,
     1         ' OBSERVATIONS = ',G15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'QMEA')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END OF SSQMEA--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9013)IERROR,N,DXBAR,DSUM,XSSQ
 9013   FORMAT('IERROR,N,DXBAR,DSUM,XSSQ = ',A4,2X,I8,3G15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      RETURN
      END
      SUBROUTINE SSVDC(X,LDX,N,P,S,E,U,LDU,V,LDV,WORK,JOB,INFO)
C***BEGIN PROLOGUE  SSVDC
C***DATE WRITTEN   790319   (YYMMDD)
C***REVISION DATE  820801   (YYMMDD)
C***CATEGORY NO.  D6
C***KEYWORDS  LINEAR ALGEBRA,LINPACK,MATRIX,
C             SINGULAR VALUE DECOMPOSITION
C***AUTHOR  STEWART, G. W., (U. OF MARYLAND)
C***PURPOSE  Perform the singular value decomposition of a real NXP
C            matrix
C***DESCRIPTION
C
C     SSVDC is a subroutine to reduce a real NxP matrix X by
C     orthogonal transformations U and V to diagonal form.  The
C     diagonal elements S(I) are the singular values of X.  The
C     columns of U are the corresponding left singular vectors,
C     and the columns of V the right singular vectors.
C
C     On Entry
C
C         X         REAL(LDX,P), where LDX .GE. N.
C                   X contains the matrix whose singular value
C                   decomposition is to be computed.  X is
C                   destroyed by SSVDC.
C
C         LDX       INTEGER
C                   LDX is the leading dimension of the array X.
C
C         N         INTEGER
C                   N is the number of rows of the matrix X.
C
C         P         INTEGER
C                   P is the number of columns of the matrix X.
C
C         LDU       INTEGER
C                   LDU is the leading dimension of the array U.
C                   (See below).
C
C         LDV       INTEGER
C                   LDV is the leading dimension of the array V.
C                   (See below).
C
C         WORK      REAL(N)
C                   work is a scratch array.
C
C         JOB       INTEGER
C                   JOB controls the computation of the singular
C                   vectors.  It has the decimal expansion AB
C                   with the following meaning
C
C                        A .EQ. 0  Do not compute the left singular
C                                  vectors.
C                        A .EQ. 1  Return the N left singular vectors
C                                  in U.
C                        A .GE. 2  Return the first MIN(N,P) singular
C                                  vectors in U.
C                        B .EQ. 0  Do not compute the right singular
C                                  vectors.
C                        B .EQ. 1  Return the right singular vectors
C                                  in V.
C
C     On Return
C
C         S         REAL(MM), where MM=MIN(N+1,P).
C                   The first MIN(N,P) entries of S contain the
C                   singular values of X arranged in descending
C                   order of magnitude.
C
C         E         REAL(P).
C                   E ordinarily contains zeros.  However, see the
C                   discussion of INFO for exceptions.
C
C         U         REAL(LDU,K), where LDU .GE. N.  If JOBA .EQ. 1, then
C                                   K .EQ. N.  If JOBA .GE. 2 , then
C                                   K .EQ. MIN(N,P).
C                   U contains the matrix of right singular vectors.
C                   U is not referenced if JOBA .EQ. 0.  If N .LE. P
C                   or if JOBA .EQ. 2, then U may be identified with X
C                   in the subroutine call.
C
C         V         REAL(LDV,P), where LDV .GE. P.
C                   V contains the matrix of right singular vectors.
C                   V is not referenced if JOB .EQ. 0.  If P .LE. N,
C                   then V may be identified with X in the
C                   subroutine call.
C
C         INFO      INTEGER.
C                   the singular values (and their corresponding
C                   singular vectors) S(INFO+1),S(INFO+2),...,S(M)
C                   are correct (here M=MIN(N,P)).  Thus if
C                   INFO .EQ. 0, all the singular values and their
C                   vectors are correct.  In any event, the matrix
C                   B = TRANS(U)*X*V is the bidiagonal matrix
C                   with the elements of S on its diagonal and the
C                   elements of E on its super-diagonal (TRANS(U)
C                   is the transpose of U).  Thus the singular
C                   values of X and B are the same.
C
C     LINPACK.  This version dated 03/19/79 .
C     G. W. Stewart, University of Maryland, Argonne National Lab.
C
C     ***** Uses the following functions and subprograms.
C
C     External SROT
C     BLAS SAXPY,SDOT,SSCAL,SSWAP,SNRM2,SROTG
C     Fortran ABS,AMAX1,MAX0,MIN0,MOD,SQRT
C***REFERENCES  DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W.,
C                 *LINPACK USERS  GUIDE*, SIAM, 1979.
C***ROUTINES CALLED  SAXPY,SDOT,SNRM2,SROT,SROTG,SSCAL,SSWAP
C***END PROLOGUE  SSVDC
      INTEGER LDX,N,P,LDU,LDV,JOB,INFO
      REAL X(LDX,*),S(*),E(*),U(LDU,*),V(LDV,*),WORK(*)
C
C
      INTEGER I,ITER,J,JOBU,K,KASE,KK,L,LL,LLS,LM1,LP1,LS,LU,M,MAXIT,
     1        MM,MM1,MP1,NCT,NCTP1,NCU,NRT,NRTP1
CCCCC REAL SDOT,T,R
      REAL SDOT,T
      REAL B,C,CS,EL,EMM1,F,G,SNRM2,SCALE,SHIFT,SL,SM,SN,SMM1,T1,TEST,
     1     ZTEST
      LOGICAL WANTU,WANTV
C
C     SET THE MAXIMUM NUMBER OF ITERATIONS.
C
C***FIRST EXECUTABLE STATEMENT  SSVDC
      MAXIT = 30
      LS = 0
      L=0
C
C     DETERMINE WHAT IS TO BE COMPUTED.
C
      WANTU = .FALSE.
      WANTV = .FALSE.
      JOBU = MOD(JOB,100)/10
      NCU = N
      IF (JOBU .GT. 1) NCU = MIN0(N,P)
      IF (JOBU .NE. 0) WANTU = .TRUE.
      IF (MOD(JOB,10) .NE. 0) WANTV = .TRUE.
C
C     REDUCE X TO BIDIAGONAL FORM, STORING THE DIAGONAL ELEMENTS
C     IN S AND THE SUPER-DIAGONAL ELEMENTS IN E.
C
      INFO = 0
      NCT = MIN0(N-1,P)
      NRT = MAX0(0,MIN0(P-2,N))
      LU = MAX0(NCT,NRT)
      IF (LU .LT. 1) GO TO 170
      DO 160 L = 1, LU
         LP1 = L + 1
         IF (L .GT. NCT) GO TO 20
C
C           COMPUTE THE TRANSFORMATION FOR THE L-TH COLUMN AND
C           PLACE THE L-TH DIAGONAL IN S(L).
C
            S(L) = SNRM2(N-L+1,X(L,L),1)
            IF (S(L) .EQ. 0.0E0) GO TO 10
               IF (X(L,L) .NE. 0.0E0) S(L) = SIGN(S(L),X(L,L))
               CALL SSCAL(N-L+1,1.0E0/S(L),X(L,L),1)
               X(L,L) = 1.0E0 + X(L,L)
   10       CONTINUE
            S(L) = -S(L)
   20    CONTINUE
         IF (P .LT. LP1) GO TO 50
         DO 40 J = LP1, P
            IF (L .GT. NCT) GO TO 30
            IF (S(L) .EQ. 0.0E0) GO TO 30
C
C              APPLY THE TRANSFORMATION.
C
               T = -SDOT(N-L+1,X(L,L),1,X(L,J),1)/X(L,L)
               CALL SAXPY(N-L+1,T,X(L,L),1,X(L,J),1)
   30       CONTINUE
C
C           PLACE THE L-TH ROW OF X INTO  E FOR THE
C           SUBSEQUENT CALCULATION OF THE ROW TRANSFORMATION.
C
            E(J) = X(L,J)
   40    CONTINUE
   50    CONTINUE
         IF (.NOT.WANTU .OR. L .GT. NCT) GO TO 70
C
C           PLACE THE TRANSFORMATION IN U FOR SUBSEQUENT BACK
C           MULTIPLICATION.
C
            DO 60 I = L, N
               U(I,L) = X(I,L)
   60       CONTINUE
   70    CONTINUE
         IF (L .GT. NRT) GO TO 150
C
C           COMPUTE THE L-TH ROW TRANSFORMATION AND PLACE THE
C           L-TH SUPER-DIAGONAL IN E(L).
C
            E(L) = SNRM2(P-L,E(LP1),1)
            IF (E(L) .EQ. 0.0E0) GO TO 80
               IF (E(LP1) .NE. 0.0E0) E(L) = SIGN(E(L),E(LP1))
               CALL SSCAL(P-L,1.0E0/E(L),E(LP1),1)
               E(LP1) = 1.0E0 + E(LP1)
   80       CONTINUE
            E(L) = -E(L)
            IF (LP1 .GT. N .OR. E(L) .EQ. 0.0E0) GO TO 120
C
C              APPLY THE TRANSFORMATION.
C
               DO 90 I = LP1, N
                  WORK(I) = 0.0E0
   90          CONTINUE
               DO 100 J = LP1, P
                  CALL SAXPY(N-L,E(J),X(LP1,J),1,WORK(LP1),1)
  100          CONTINUE
               DO 110 J = LP1, P
                  CALL SAXPY(N-L,-E(J)/E(LP1),WORK(LP1),1,X(LP1,J),1)
  110          CONTINUE
  120       CONTINUE
            IF (.NOT.WANTV) GO TO 140
C
C              PLACE THE TRANSFORMATION IN V FOR SUBSEQUENT
C              BACK MULTIPLICATION.
C
               DO 130 I = LP1, P
                  V(I,L) = E(I)
  130          CONTINUE
  140       CONTINUE
  150    CONTINUE
  160 CONTINUE
  170 CONTINUE
C
C     SET UP THE FINAL BIDIAGONAL MATRIX OR ORDER M.
C
      M = MIN0(P,N+1)
      NCTP1 = NCT + 1
      NRTP1 = NRT + 1
      IF (NCT .LT. P) S(NCTP1) = X(NCTP1,NCTP1)
      IF (N .LT. M) S(M) = 0.0E0
      IF (NRTP1 .LT. M) E(NRTP1) = X(NRTP1,M)
      E(M) = 0.0E0
C
C     IF REQUIRED, GENERATE U.
C
      IF (.NOT.WANTU) GO TO 300
         IF (NCU .LT. NCTP1) GO TO 200
         DO 190 J = NCTP1, NCU
            DO 180 I = 1, N
               U(I,J) = 0.0E0
  180       CONTINUE
            U(J,J) = 1.0E0
  190    CONTINUE
  200    CONTINUE
         IF (NCT .LT. 1) GO TO 290
         DO 280 LL = 1, NCT
            L = NCT - LL + 1
            IF (S(L) .EQ. 0.0E0) GO TO 250
               LP1 = L + 1
               IF (NCU .LT. LP1) GO TO 220
               DO 210 J = LP1, NCU
                  T = -SDOT(N-L+1,U(L,L),1,U(L,J),1)/U(L,L)
                  CALL SAXPY(N-L+1,T,U(L,L),1,U(L,J),1)
  210          CONTINUE
  220          CONTINUE
               CALL SSCAL(N-L+1,-1.0E0,U(L,L),1)
               U(L,L) = 1.0E0 + U(L,L)
               LM1 = L - 1
               IF (LM1 .LT. 1) GO TO 240
               DO 230 I = 1, LM1
                  U(I,L) = 0.0E0
  230          CONTINUE
  240          CONTINUE
            GO TO 270
  250       CONTINUE
               DO 260 I = 1, N
                  U(I,L) = 0.0E0
  260          CONTINUE
               U(L,L) = 1.0E0
  270       CONTINUE
  280    CONTINUE
  290    CONTINUE
  300 CONTINUE
C
C     IF IT IS REQUIRED, GENERATE V.
C
      IF (.NOT.WANTV) GO TO 350
         DO 340 LL = 1, P
            L = P - LL + 1
            LP1 = L + 1
            IF (L .GT. NRT) GO TO 320
            IF (E(L) .EQ. 0.0E0) GO TO 320
               DO 310 J = LP1, P
                  T = -SDOT(P-L,V(LP1,L),1,V(LP1,J),1)/V(LP1,L)
                  CALL SAXPY(P-L,T,V(LP1,L),1,V(LP1,J),1)
  310          CONTINUE
  320       CONTINUE
            DO 330 I = 1, P
               V(I,L) = 0.0E0
  330       CONTINUE
            V(L,L) = 1.0E0
  340    CONTINUE
  350 CONTINUE
C
C     MAIN ITERATION LOOP FOR THE SINGULAR VALUES.
C
      MM = M
      ITER = 0
  360 CONTINUE
C
C        QUIT IF ALL THE SINGULAR VALUES HAVE BEEN FOUND.
C
C     ...EXIT
         IF (M .EQ. 0) GO TO 620
C
C        IF TOO MANY ITERATIONS HAVE BEEN PERFORMED, SET
C        FLAG AND RETURN.
C
         IF (ITER .LT. MAXIT) GO TO 370
            INFO = M
C     ......EXIT
            GO TO 620
  370    CONTINUE
C
C        THIS SECTION OF THE PROGRAM INSPECTS FOR
C        NEGLIGIBLE ELEMENTS IN THE S AND E ARRAYS.  ON
C        COMPLETION THE VARIABLES KASE AND L ARE SET AS FOLLOWS.
C
C           KASE = 1     IF S(M) AND E(L-1) ARE NEGLIGIBLE AND L.LT.M
C           KASE = 2     IF S(L) IS NEGLIGIBLE AND L.LT.M
C           KASE = 3     IF E(L-1) IS NEGLIGIBLE, L.LT.M, AND
C                        S(L), ..., S(M) ARE NOT NEGLIGIBLE (QR STEP).
C           KASE = 4     IF E(M-1) IS NEGLIGIBLE (CONVERGENCE).
C
         DO 390 LL = 1, M
            L = M - LL
C        ...EXIT
            IF (L .EQ. 0) GO TO 400
            TEST = ABS(S(L)) + ABS(S(L+1))
            ZTEST = TEST + ABS(E(L))
            IF (ZTEST .NE. TEST) GO TO 380
               E(L) = 0.0E0
C        ......EXIT
               GO TO 400
  380       CONTINUE
  390    CONTINUE
  400    CONTINUE
         IF (L .NE. M - 1) GO TO 410
            KASE = 4
         GO TO 480
  410    CONTINUE
            LP1 = L + 1
            MP1 = M + 1
            DO 430 LLS = LP1, MP1
               LS = M - LLS + LP1
C           ...EXIT
               IF (LS .EQ. L) GO TO 440
               TEST = 0.0E0
               IF (LS .NE. M) TEST = TEST + ABS(E(LS))
               IF (LS .NE. L + 1) TEST = TEST + ABS(E(LS-1))
               ZTEST = TEST + ABS(S(LS))
               IF (ZTEST .NE. TEST) GO TO 420
                  S(LS) = 0.0E0
C           ......EXIT
                  GO TO 440
  420          CONTINUE
  430       CONTINUE
  440       CONTINUE
            IF (LS .NE. L) GO TO 450
               KASE = 3
            GO TO 470
  450       CONTINUE
            IF (LS .NE. M) GO TO 460
               KASE = 1
            GO TO 470
  460       CONTINUE
               KASE = 2
               L = LS
  470       CONTINUE
  480    CONTINUE
         L = L + 1
C
C        PERFORM THE TASK INDICATED BY KASE.
C
         GO TO (490,520,540,570), KASE
C
C        DEFLATE NEGLIGIBLE S(M).
C
  490    CONTINUE
            MM1 = M - 1
            F = E(M-1)
            E(M-1) = 0.0E0
            DO 510 KK = L, MM1
               K = MM1 - KK + L
               T1 = S(K)
               CALL SROTG(T1,F,CS,SN)
               S(K) = T1
               IF (K .EQ. L) GO TO 500
                  F = -SN*E(K-1)
                  E(K-1) = CS*E(K-1)
  500          CONTINUE
               IF (WANTV) CALL SROT(P,V(1,K),1,V(1,M),1,CS,SN)
  510       CONTINUE
         GO TO 610
C
C        SPLIT AT NEGLIGIBLE S(L).
C
  520    CONTINUE
            F = E(L-1)
            E(L-1) = 0.0E0
            DO 530 K = L, M
               T1 = S(K)
               CALL SROTG(T1,F,CS,SN)
               S(K) = T1
               F = -SN*E(K)
               E(K) = CS*E(K)
               IF (WANTU) CALL SROT(N,U(1,K),1,U(1,L-1),1,CS,SN)
  530       CONTINUE
         GO TO 610
C
C        PERFORM ONE QR STEP.
C
  540    CONTINUE
C
C           CALCULATE THE SHIFT.
C
            SCALE = AMAX1(ABS(S(M)),ABS(S(M-1)),ABS(E(M-1)),ABS(S(L)),
     1                    ABS(E(L)))
            SM = S(M)/SCALE
            SMM1 = S(M-1)/SCALE
            EMM1 = E(M-1)/SCALE
            SL = S(L)/SCALE
            EL = E(L)/SCALE
            B = ((SMM1 + SM)*(SMM1 - SM) + EMM1**2)/2.0E0
            C = (SM*EMM1)**2
            SHIFT = 0.0E0
            IF (B .EQ. 0.0E0 .AND. C .EQ. 0.0E0) GO TO 550
               SHIFT = SQRT(B**2+C)
               IF (B .LT. 0.0E0) SHIFT = -SHIFT
               SHIFT = C/(B + SHIFT)
  550       CONTINUE
            F = (SL + SM)*(SL - SM) - SHIFT
            G = SL*EL
C
C           CHASE ZEROS.
C
            MM1 = M - 1
            DO 560 K = L, MM1
               CALL SROTG(F,G,CS,SN)
               IF (K .NE. L) E(K-1) = F
               F = CS*S(K) + SN*E(K)
               E(K) = CS*E(K) - SN*S(K)
               G = SN*S(K+1)
               S(K+1) = CS*S(K+1)
               IF (WANTV) CALL SROT(P,V(1,K),1,V(1,K+1),1,CS,SN)
               CALL SROTG(F,G,CS,SN)
               S(K) = F
               F = CS*E(K) + SN*S(K+1)
               S(K+1) = -SN*E(K) + CS*S(K+1)
               G = SN*E(K+1)
               E(K+1) = CS*E(K+1)
               IF (WANTU .AND. K .LT. N)
     1            CALL SROT(N,U(1,K),1,U(1,K+1),1,CS,SN)
  560       CONTINUE
            E(M-1) = F
            ITER = ITER + 1
         GO TO 610
C
C        CONVERGENCE.
C
  570    CONTINUE
C
C           MAKE THE SINGULAR VALUE  POSITIVE.
C
            IF (S(L) .GE. 0.0E0) GO TO 580
               S(L) = -S(L)
               IF (WANTV) CALL SSCAL(P,-1.0E0,V(1,L),1)
  580       CONTINUE
C
C           ORDER THE SINGULAR VALUE.
C
  590       IF (L .EQ. MM) GO TO 600
C           ...EXIT
               IF (S(L) .GE. S(L+1)) GO TO 600
               T = S(L)
               S(L) = S(L+1)
               S(L+1) = T
               IF (WANTV .AND. L .LT. P)
     1            CALL SSWAP(P,V(1,L),1,V(1,L+1),1)
               IF (WANTU .AND. L .LT. N)
     1            CALL SSWAP(N,U(1,L),1,U(1,L+1),1)
               L = L + 1
            GO TO 590
  600       CONTINUE
            ITER = 0
            M = M - 1
  610    CONTINUE
      GO TO 360
  620 CONTINUE
      RETURN
      END
      SUBROUTINE SSWAP(N,SX,INCX,SY,INCY)
C***BEGIN PROLOGUE  SSWAP
C***DATE WRITTEN   791001   (YYMMDD)
C***REVISION DATE  820801   (YYMMDD)
C***CATEGORY NO.  D1A5
C***KEYWORDS  BLAS,INTERCHANGE,LINEAR ALGEBRA,VECTOR
C***AUTHOR  LAWSON, C. L., (JPL)
C           HANSON, R. J., (SNLA)
C           KINCAID, D. R., (U. OF TEXAS)
C           KROGH, F. T., (JPL)
C***PURPOSE  Interchange s.p vectors
C***DESCRIPTION
C
C                B L A S  Subprogram
C    Description of Parameters
C
C     --Input--
C        N  number of elements in input vector(s)
C       SX  single precision vector with N elements
C     INCX  storage spacing between elements of SX
C       SY  single precision vector with N elements
C     INCY  storage spacing between elements of SY
C
C     --Output--
C       SX  input vector SY (unchanged if N .LE. 0)
C       SY  input vector SX (unchanged if N .LE. 0)
C
C     Interchange single precision SX and single precision SY.
C     For I = 0 to N-1, interchange  SX(LX+I*INCX) and SY(LY+I*INCY),
C     where LX = 1 if INCX .GE. 0, else LX = (-INCX)*N, and LY is
C     defined in a similar way using INCY.
C***REFERENCES  LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T.,
C                 *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*,
C                 ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL
C                 SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323
C***ROUTINES CALLED  (NONE)
C***END PROLOGUE  SSWAP
C
      REAL SX(*),SY(*),STEMP1,STEMP2,STEMP3
C***FIRST EXECUTABLE STATEMENT  SSWAP
      IF(N.LE.0)RETURN
CCCCC JUNE 2008: MODIFY FOLLOWING LINE SO THAT IT DOES NOT
CCCCC            GENERATE WARNING MESSAGE ON FORTRAN 95 COMPILERS.
C
CCCCC IF(INCX.EQ.INCY) IF(INCX-1) 5,20,60
      IF(INCX.EQ.INCY) THEN
        IF(INCX-1.LT.0)THEN
          GOTO5
        ELSEIF(INCX-1.EQ.0)THEN
          GOTO20
        ELSE
          GOTO60
        ENDIF
      ENDIF
    5 CONTINUE
C
C       CODE FOR UNEQUAL OR NONPOSITIVE INCREMENTS.
C
      IX = 1
      IY = 1
      IF(INCX.LT.0)IX = (-N+1)*INCX + 1
      IF(INCY.LT.0)IY = (-N+1)*INCY + 1
      DO 10 I = 1,N
        STEMP1 = SX(IX)
        SX(IX) = SY(IY)
        SY(IY) = STEMP1
        IX = IX + INCX
        IY = IY + INCY
   10 CONTINUE
      RETURN
C
C       CODE FOR BOTH INCREMENTS EQUAL TO 1
C
C
C       CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 3.
C
   20 M = MOD(N,3)
      IF( M .EQ. 0 ) GO TO 40
      DO 30 I = 1,M
        STEMP1 = SX(I)
        SX(I) = SY(I)
        SY(I) = STEMP1
   30 CONTINUE
      IF( N .LT. 3 ) RETURN
   40 MP1 = M + 1
      DO 50 I = MP1,N,3
        STEMP1 = SX(I)
        STEMP2 = SX(I+1)
        STEMP3 = SX(I+2)
        SX(I) = SY(I)
        SX(I+1) = SY(I+1)
        SX(I+2) = SY(I+2)
        SY(I) = STEMP1
        SY(I+1) = STEMP2
        SY(I+2) = STEMP3
   50 CONTINUE
      RETURN
   60 CONTINUE
C
C     CODE FOR EQUAL, POSITIVE, NONUNIT INCREMENTS.
C
      NS = N*INCX
        DO 70 I=1,NS,INCX
        STEMP1 = SX(I)
        SX(I) = SY(I)
        SY(I) = STEMP1
   70   CONTINUE
      RETURN
      END
      SUBROUTINE START1(A,X,Y,NS,CN,XC,YC)
C
C     PURPOSE--XX
C
C     WRITTEN BY--DAVID W. BEHRINGER NOAA/AOML (MIAMI).
C                 AS PART OF NOAA'S CONCX V.3   MARCH 1988.
C     ORIGINAL VERSION (IN DATAPLOT)--AUGUST    1988.
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOCP.INC'
C
C---------------------------------------------------------------------
C
CCCCC DIMENSION A(IMX,2),X(2),Y(2)   AUGUST 1988
C
      DIMENSION A(MAXIMX,2)
      DIMENSION X(2)
      DIMENSION Y(2)
C
C-----START POINT-----------------------------------------------------
C
        DNM=A(1,1)-A(1,2)
        IF (DNM.NE.0.) THEN
          R=(CN-A(1,2))/DNM
        ELSE
          R=-1.
        END IF
        IF ((R.GT.0..AND.R.LT.1.).OR.
     1     (R.EQ.0..AND.DNM.LT.0.).OR.
     2     (R.EQ.1..AND.DNM.GT.0.)) THEN
          XC=X(1)
          YC=Y(2)+R*(Y(1)-Y(2))
        ELSE
          NS=-1
        END IF
      RETURN
      END
      SUBROUTINE START2(A,X,Y,NS,CN,XC,YC)
C
C     PURPOSE--XX
C
C     WRITTEN BY--DAVID W. BEHRINGER NOAA/AOML (MIAMI).
C                 AS PART OF NOAA'S CONCX V.3   MARCH 1988.
C     ORIGINAL VERSION (IN DATAPLOT)--AUGUST    1988.
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOCP.INC'
C
C---------------------------------------------------------------------
C
CCCCC DIMENSION A(IMX,2),X(2),Y(2)   AUGUST 1988
C
      DIMENSION A(MAXIMX,2)
      DIMENSION X(2)
      DIMENSION Y(2)
C
C-----START POINT-----------------------------------------------------
C
        DNM=A(1,1)-A(2,1)
        IF (DNM.NE.0.) THEN
          R=(CN-A(2,1))/DNM
        ELSE
          R=-1.
        END IF
        IF ((R.GT.0..AND.R.LT.1.).OR.
     1     (R.EQ.0..AND.DNM.LT.0.).OR.
     2     (R.EQ.1..AND.DNM.GT.0.)) THEN
          XC=X(2)+R*(X(1)-X(2))
          YC=Y(1)
        ELSE
          NS=-1
        ENDIF
      RETURN
      END
      SUBROUTINE START3(A,X,Y,NS,CN,XC,YC)
C
C     PURPOSE--XX
C
C     WRITTEN BY--DAVID W. BEHRINGER NOAA/AOML (MIAMI).
C                 AS PART OF NOAA'S CONCX V.3   MARCH 1988.
C     ORIGINAL VERSION (IN DATAPLOT)--AUGUST    1988.
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOCP.INC'
C
C---------------------------------------------------------------------
C
CCCCC DIMENSION A(IMX,2),X(2),Y(2)   AUGUST 1988
C
      DIMENSION A(MAXIMX,2)
      DIMENSION X(2)
      DIMENSION Y(2)
C
C-----START POINT-----------------------------------------------------
C
        DNM=A(1,2)-A(1,1)
        IF (DNM.NE.0.) THEN
          R=(CN-A(1,1))/DNM
        ELSE
          R=-1.
        END IF
        IF ((R.GT.0..AND.R.LT.1.).OR.
     1     (R.EQ.0..AND.DNM.LT.0.).OR.
     2     (R.EQ.1..AND.DNM.GT.0.)) THEN
          XC=X(1)
          YC=Y(1)+R*(Y(2)-Y(1))
        ELSE
          NS=-1
        ENDIF
      RETURN
      END
      SUBROUTINE START4(A,X,Y,NS,CN,XC,YC)
C
C     PURPOSE--XX
C
C     WRITTEN BY--DAVID W. BEHRINGER NOAA/AOML (MIAMI).
C                 AS PART OF NOAA'S CONCX V.3   MARCH 1988.
C     ORIGINAL VERSION (IN DATAPLOT)--AUGUST    1988.
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOCP.INC'
C
C---------------------------------------------------------------------
C
CCCCC DIMENSION A(IMX,2),X(2),Y(2)   AUGUST 1988
C
      DIMENSION A(MAXIMX,2)
      DIMENSION X(2)
      DIMENSION Y(2)
C
C-----START POINT-----------------------------------------------------
C
        DNM=A(2,1)-A(1,1)
        IF (DNM.NE.0.) THEN
          R=(CN-A(1,1))/DNM
        ELSE
          R=-1.
        END IF
        IF ((R.GT.0..AND.R.LT.1.).OR.
     1     (R.EQ.0..AND.DNM.LT.0.).OR.
     2     (R.EQ.1..AND.DNM.GT.0.)) THEN
          XC=X(1)+R*(X(2)-X(1))
          YC=Y(1)
        ELSE
          NS=-1
        ENDIF
      RETURN
      END
      DOUBLE PRECISION FUNCTION STDINV( N, Z )
*
*     Inverse Student t Distribution Function
*
*                    STDINV
*           Z = C   I      (1 + y*y/N)**(-(N+1)/2) dy
*                N  -INF
*
*      Reference: G.W. Hill, Comm. ACM Algorithm 395
*                 Comm. ACM 13 (1970), pp. 619-620.
*
*      Conversions to double precision and other modifications by
*                 Alan Genz, 1993-4.
*
      INTEGER N
      DOUBLE PRECISION Z, P, PHINV, A, B, C, D, X, Y, PI, TWO
      DOUBLE PRECISION STUDNT, STDJAC
      PARAMETER ( PI = 3.14159 26535 89793D0, TWO = 2  )
      IF ( 0.0D0 .LT. Z .AND. Z .LT. 1.0D0 ) THEN
         IF ( N .EQ. 1 ) THEN
            STDINV = TAN( PI*( 2*Z - 1 )/2 )
         ELSE IF ( N .EQ. 2) THEN
            STDINV = ( 2.0D0*Z - 1.0D0 )/SQRT( 2.0D0*Z*( 1.0D0 - Z ) )
         ELSE
            IF ( 2.0D0*Z .GE. 1.0D0 ) THEN
               P = 2.0D0*( 1.0D0 - Z )
            ELSE
               P = 2.0D0*Z
            END IF
            A = 1.0D0/( DBLE(N) - 0.5D0 )
            B = 48.0D0/( A*A )
            C = ( ( 20700.0D0*A/B - 98.0D0 )*A - 16.0D0 )*A + 96.36D0
            D = ( ( 94.5D0/( B + C ) - 3.0D0 )/B + 1.0D0 )*
     &          SQRT( A*PI/2.0D0 )*DBLE(N)
            X = D*P
            Y = X**( TWO/DBLE(N) )
            IF ( Y .GT. A + 0.05D0 ) THEN
               X = PHINV( P/2.0D0 )
               Y = X*X
               IF ( N .LT. 5 ) C = C + 3.0D0*
     &            ( DBLE(N) - 4.5D0 )*( 10.0D0*X + 6.0D0 )/100.0D0
               C = ( ( (D*X - 100.0D0)*X/20.0D0 - 7.0D0 )*X - 2.0D0 )
     &             *X + B + C
               Y = (((((4.0D0*Y+63.0D0)*Y/10.0D0+36.0D0)*Y+94.5D0)/
     &             C-Y-3.0D0)/B + 1.0D0)*X
               Y = A*Y*Y
               IF ( Y .GT. 0.002D0) THEN
                  Y = EXP(Y) - 1.0D0
               ELSE
                  Y = Y*( 1.0D0 + Y/2.0D0 )
               ENDIF
            ELSE
               Y = ((1.0D0/((DBLE(N+6)/(DBLE(N)*Y) -
     &              0.089D0*D - 0.822D0 )*(3.0D0*DBLE(N+6)))
     &              + 0.5D0/DBLE(N+4))*Y - 1.0D0)*DBLE(N+1)/DBLE(N+2)
     &              + 1.0D0/Y
            END IF
            STDINV = SQRT(DBLE(N)*Y)
            IF ( 2.0D0*Z .LT. 1.0D0 ) STDINV = -STDINV
            IF ( ABS( STDINV ) .GT. 0.0D0 ) THEN
*
*     Use one third order correction to the single precision result
*
               X = STDINV
               D = Z - STUDNT(N,X)
               STDINV = X + 2.0D0*D/( 2.0D0/STDJAC(N,X) -
     &                  D*DBLE(N+1)/(DBLE(N)/X+X) )
            END IF
         END IF
      ELSE
*
*     Use cutoff values for Z near 0 or 1.
*
         STDINV = SQRT( DBLE(N)/( 2D-16*
     &      SQRT( 2.0D0*PI*DBLE(N)))**( TWO/N ) )
         IF ( 2.0D0*Z .LT. 1.0D0 ) STDINV = -STDINV
      END IF
C
      RETURN
      END
      DOUBLE PRECISION FUNCTION STDJAC( NU, T )
*
*     Student t Distribution Transformation Jacobean
*
*          T            STDINV(NU,T)
*         I  f(y) dy = I   f(STDINV(NU,Z) STDJAC(NU,STDINV(NU,Z)) dZ
*         -INF          0
*
      INTEGER NU, J
      DOUBLE PRECISION CONST, NUOLD, PI, T, TT
      PARAMETER ( PI = 3.14159 26535 89793D0 )
      SAVE NUOLD, CONST
      DATA NUOLD/ 0D0 /
      IF ( NU .EQ. 1 ) THEN
         STDJAC = PI*( 1.0D0 + T*T )
      ELSE IF ( NU .EQ. 2 ) THEN
         STDJAC = SQRT( 2.0D0 + T*T )**3
      ELSE
         IF ( NU .NE. NUOLD ) THEN
            NUOLD = NU
            IF ( MOD( NU, 2 ) .EQ. 0 ) THEN
               CONST = SQRT(NUOLD)*2.0D0
            ELSE
               CONST = SQRT(NUOLD)*PI
            END IF
            DO 100 J = NU-2, 1, -2
               CONST = J*CONST/(J+1)
  100       CONTINUE
         END IF
         TT = 1 + T*T/NU
         STDJAC = CONST*TT**( DBLE(NU+1)/2.0D0 )
         IF ( MOD( NU, 2 ) .EQ. 0 ) STDJAC = STDJAC*SQRT( TT )
      END IF
C
      RETURN
      END
      subroutine stl(y,n,np,ns,nt,nl,isdeg,itdeg,ildeg,nsjump,ntjump,
     &nljump,ni,no,rw,season,trend,work)
c
c  This routine is part of the Bill Cleveland seasonal loess
c  program.
c
      integer n, np, ns, nt, nl, isdeg, itdeg, ildeg, nsjump, ntjump,
     &nljump, ni, no, k
      integer newns, newnt, newnl, newnp
      real y(n), rw(n), season(n), trend(n), work(n+2*np,5)
      logical userw
c
      userw = .false.
      k = 0
      do 23000 i = 1,n
      trend(i) = 0.0
23000 continue
      newns = max0(3,ns)
      newnt = max0(3,nt)
      newnl = max0(3,nl)
      newnp = max0(2,np)
      if(.not.(mod(newns,2) .eq. 0))goto 23002
      newns = newns + 1
23002 continue
      if(.not.(mod(newnt,2) .eq. 0))goto 23004
      newnt = newnt + 1
23004 continue
      if(.not.(mod(newnl,2) .eq. 0))goto 23006
      newnl = newnl + 1
23006 continue
23008 continue
      call onestp(y,n,newnp,newns,newnt,newnl,isdeg,itdeg,ildeg,nsjump,
     &ntjump,nljump,ni,userw,rw,season, trend, work)
      k = k+1
      if(.not.(k .gt. no))goto 23011
      goto 23010
23011 continue
      do 23013 i = 1,n
      work(i,1) = trend(i)+season(i)
23013 continue
      call rwts(y,n,work(1,1),rw)
      userw = .true.
      goto 23008
23010 continue
      if(.not.(no .le. 0))goto 23015
      do 23017 i = 1,n
      rw(i) = 1.0
23017 continue
23015 continue
      return
      end
      subroutine stlez(y, n, np, ns, isdeg, itdeg, robust, no, rw,
     &season, trend, work)
c
c  This routine is part of the Bill Cleveland seasonal loess
c  program.
c
      logical robust
      integer n, i, j, np, ns, no, nt, nl, ni, nsjump, ntjump, nljump,
     &newns, newnp
      integer isdeg, itdeg, ildeg
      real y(n), rw(n), season(n), trend(n), work(n+2*np,7)
      real maxs, mins, maxt, mint, maxds, maxdt, difs, dift
      ildeg = itdeg
      newns = max0(3,ns)
      if(.not.(mod(newns,2) .eq. 0))goto 23120
      newns = newns+1
23120 continue
      newnp = max0(2,np)
      nt = int((1.5*real(newnp))/(1 - 1.5/real(newns)) + 0.5)
      nt = max0(3,nt)
      if(.not.(mod(nt,2) .eq. 0))goto 23122
      nt = nt+1
23122 continue
      nl = newnp
      if(.not.(mod(nl,2) .eq. 0))goto 23124
      nl = nl+1
23124 continue
      if(.not.(robust))goto 23126
      ni = 1
      goto 23127
23126 continue
      ni = 2
23127 continue
      nsjump = max0(1,int(float(newns)/10 + 0.9))
      ntjump = max0(1,int(float(nt)/10 + 0.9))
      nljump = max0(1,int(float(nl)/10 + 0.9))
      do 23128 i = 1,n
      trend(i) = 0.0
23128 continue
      call onestp(y,n,newnp,newns,nt,nl,isdeg,itdeg,ildeg,nsjump,ntjump,
     &nljump,ni,.false.,rw,season,trend,work)
      no = 0
      if(.not.(robust))goto 23130
      j=1
23132 if(.not.(j .le. 15))goto 23134
      do 23135 i = 1,n
      work(i,6) = season(i)
      work(i,7) = trend(i)
      work(i,1) = trend(i)+season(i)
23135 continue
      call rwts(y,n,work(1,1),rw)
      call onestp(y, n, newnp, newns, nt, nl, isdeg, itdeg, ildeg,
     &nsjump,ntjump, nljump, ni, .true., rw, season, trend, work)
      no = no+1
      maxs = work(1,6)
      mins = work(1,6)
      maxt = work(1,7)
      mint = work(1,7)
      maxds = abs(work(1,6) - season(1))
      maxdt = abs(work(1,7) - trend(1))
      do 23137 i = 2,n
      if(.not.(maxs .lt. work(i,6)))goto 23139
      maxs = work(i,6)
23139 continue
      if(.not.(maxt .lt. work(i,7)))goto 23141
      maxt = work(i,7)
23141 continue
      if(.not.(mins .gt. work(i,6)))goto 23143
      mins = work(i,6)
23143 continue
      if(.not.(mint .gt. work(i,7)))goto 23145
      mint = work(i,7)
23145 continue
      difs = abs(work(i,6) - season(i))
      dift = abs(work(i,7) - trend(i))
      if(.not.(maxds .lt. difs))goto 23147
      maxds = difs
23147 continue
      if(.not.(maxdt .lt. dift))goto 23149
      maxdt = dift
23149 continue
23137 continue
      if(.not.((maxds/(maxs-mins) .lt. .01)  .and.  (maxdt/(maxt-mint)
     & .lt. .01)))goto 23151
      goto 23134
23151 continue
       j=j+1
      goto 23132
23134 continue
23130 continue
      if(.not.( .not. robust))goto 23153
      do 23155 i = 1,n
      rw(i) = 1.0
23155 continue
23153 continue
      return
      end
      SUBROUTINE STMOM3(X,N,IWRITE,XSMOM3,IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE
C              SAMPLE STANDARDIZED THIRD CENTRAL MOMENT
C              OF THE DATA IN THE INPUT VECTOR X.
C              THE SAMPLE STANDARDIZED THIRD CENTRAL MOMENT =
C              (THE SAMPLE THIRD CENTRAL MOMENT)/((THE SAMPLE
C              STANDARD DEVIATION)**3).
C              N (RATHER THAN N-1) HAS BEEN USED IN THE DENOMINATOR
C              IN THE CALCULATION OF BOTH THE SAMPLE THIRD CENTRAL
C              MOMENT AND THE SAMPLE STANDARD DEVIATION.
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--XSMOM3 = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED SAMPLE STANDARDIZED THIRD
C                                CENTRAL MOMENT.
C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
C             SAMPLE STANDARDIZED THIRD CENTRAL MOMENT.
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--KENDALL AND STUART, THE ADVANCED THEORY OF
C                 STATISTICS, VOLUME 1, EDITION 2, 1963, PAGES 85,
C                 234, 243, 297-298, 305.
C               --SNEDECOR AND COCHRAN, STATISTICAL METHODS,
C                 EDITION 6, 1967, PAGES 86-90.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--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     UPDATED         --APRIL     2013. RESTORE DIVIDE BY N RATHER
C                                       THAN (N-1)
C     UPDATED         --APRIL     2013. ALTERNATIVE DEFINITION
C                                       USED BY EXCEL AND OTHER
C                                       POPULAR SOFTWARE
C     UPDATED         --JULY      2016. DON'T PRINT ERROR MESSAGE
C                                       WHEN ALL VALUES ARE EQUAL
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DN
      DOUBLE PRECISION DX
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DSUM2
      DOUBLE PRECISION DMEAN
      DOUBLE PRECISION DVAR
      DOUBLE PRECISION DSD
      DOUBLE PRECISION DMOM3
C
      DIMENSION X(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOST.INC'
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='STMO'
      ISUBN2='M3  '
      IERROR='NO'
C
      DSUM=0.0D0
      DMEAN=0.0D0
      DSD=0.0D0
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 STMOM3--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,52)IBUGA3,N
   52   FORMAT('IBUGA3,N = ',A4,2X,I8)
        CALL DPWRST('XXX','BUG ')
        DO55I=1,N
          WRITE(ICOUT,56)I,X(I)
   56     FORMAT('I,X(I) = ',I8,G15.7)
          CALL DPWRST('XXX','BUG ')
   55   CONTINUE
      ENDIF
C
C               *************************************************
C               **  COMPUTE STANDARDIZED THIRD CENTRAL MOMENT  **
C               *************************************************
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      AN=N
C
      IF(N.LT.1)THEN
        IERROR='YES'
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,111)
  111   FORMAT('***** ERROR IN STMOM3--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,112)
  112   FORMAT('      THE NUMBER OF OBSERVATIONS FOR THE RESPONSE')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,113)
  113   FORMAT('      VARIABLE IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,117)N
  117   FORMAT('      THE INPUT NUMBER OF OBSERVATIONS = ',I8,'.')
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
      IF(N.EQ.1)THEN
CCCCC   WRITE(ICOUT,999)
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   WRITE(ICOUT,121)
CC121   FORMAT('***** WARNING IN STMOM3--')
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   WRITE(ICOUT,123)
CC123   FORMAT('      THE NUMBER OF OBSERVATIONS FOR THE RESPONSE')
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   WRITE(ICOUT,125)
CC125   FORMAT('      VARIABLE IS EXACTLY ONE.')
CCCCC   CALL DPWRST('XXX','BUG ')
        XSMOM3=0.0
        GOTO9000
      ENDIF
C
      HOLD=X(1)
      DO135I=2,N
      IF(X(I).NE.HOLD)GOTO139
  135 CONTINUE
CCCCC WRITE(ICOUT,999)
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC WRITE(ICOUT,121)
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC WRITE(ICOUT,136)HOLD
CC136 FORMAT('      THE RESPONSE VARIABLE HAS ALL ELEMENTS = ',G15.7)
CCCCC CALL DPWRST('XXX','BUG ')
      XSMOM3=0.0
      GOTO9000
  139 CONTINUE
C
C               ******************************************************
C               **  STEP 2--                                        **
C               **  COMPUTE THE STANDARDIZED THIRD CENTRAL MOMENT.  **
C               ******************************************************
C
C     2013/04: THE STANDARD DEFINITION OF SKEWNESS USES "N" RATHER
C              "N-1" IN COMPUTING THE SECOND AND THIRD MOMENTS.
C              THIS IS THE "FISHER-PEARSON" DEFINITION.  WE WERE
C              USING "N-1".  REFER TO THIS AS THE "OLD" DEFINITION.
C              MANY PROGRAMS (INCLUDING EXCEL, SAS, MINITAB) USE THE
C              ADJUSTED FISHER PEARSON WHICH IS THE FISHER-PEARSON
C              MULTIPLIED BY THE ADJUSTMENT FACTOR:
C
C                  SQRT(N*(N-1))/(N-2)
C
C              THIS IS A SAMPLE SIZE ADJUSTMENT THAT APPROACHES 1
C              AS THE SAMPLE SIZE INCREASES.
C
      DN=N
      DSUM=0.0D0
      DO200I=1,N
        DX=X(I)
        DSUM=DSUM+DX
  200 CONTINUE
      DMEAN=DSUM/DN
C
      DSUM1=0.0D0
      DSUM2=0.0D0
      DO300I=1,N
        DX=X(I)
        DSUM1=DSUM1+(DX-DMEAN)**2
        DSUM2=DSUM2+(DX-DMEAN)**3
  300 CONTINUE
      IF(ISKWDF.EQ.'OLD')THEN
        DVAR=DSUM1/(DN-1.0D0)
        DMOM3=DSUM2/(DN-1.0D0)
      ELSE
        DVAR=DSUM1/DN
        DMOM3=DSUM2/DN
      ENDIF
      DSD=0.0D0
      IF(DVAR.GT.0.0D0)DSD=DSQRT(DVAR)
C
      IF(ISKWDF.EQ.'ADFP')THEN
        AN=REAL(N)
        ADJ=SQRT(AN*(AN-1.0))/(AN-2.0)
        XSMOM3=ADJ*REAL(DMOM3/(DSD**3))
      ELSE
        XSMOM3=REAL(DMOM3/(DSD**3))
      ENDIF
C
C               *******************************
C               **  STEP 3--                 **
C               **  WRITE OUT A LINE         **
C               **  OF SUMMARY INFORMATION.  **
C               *******************************
C
      IF(IFEEDB.EQ.'ON' .AND. IWRITE.EQ.'ON')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,811)N,XSMOM3
  811   FORMAT('THE STANDARDIZED THIRD CENTRAL MOMENT OF THE ',I8,
     1         ' OBSERVATIONS = ',G15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'ON')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END       OF STMOM3--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9012)IERROR,XSMOM3
 9012   FORMAT('IERROR,XSMOM3 = ',A4,2X,G15.7)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9014)DMEAN,DSD,DSUM1,DSUM2
 9014   FORMAT('DMEAN,DSD,DSUM1,DSUM2 = ',4G15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      RETURN
      END
      SUBROUTINE STMOM4(X,N,IWRITE,XSMOM4,IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE
C              SAMPLE STANDARDIZED FOURTH CENTRAL MOMENT
C              OF THE DATA IN THE INPUT VECTOR X.
C              THE SAMPLE STANDARDIZED FOURTH CENTRAL MOMENT =
C              (THE SAMPLE FOURTH CENTRAL MOMENT)/((THE SAMPLE
C              STANDARD DEVIATION)**4).
C              N (RATHER THAN N-1) HAS BEEN USED IN THE DENOMINATOR
C              IN THE CALCULATION OF BOTH THE SAMPLE FOURTH CENTRAL
C              MOMENT AND THE SAMPLE STANDARD DEVIATION.
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--XSMOM4 = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED SAMPLE STANDARDIZED FOURTH
C                                CENTRAL MOMENT.
C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
C             SAMPLE STANDARDIZED FOURTH CENTRAL MOMENT.
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--KENDALL AND STUART, THE ADVANCED THEORY OF
C                 STATISTICS, VOLUME 1, EDITION 2, 1963, PAGES 85, 243.
C               --SNEDECOR AND COCHRAN, STATISTICAL METHODS,
C                 EDITION 6, 1967, PAGES 86-90.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (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     UPDATED         --DECEMBER  2014. USE N INSTEAD OF N-1 IN
C                                       THE FORMULAS
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
      DOUBLE PRECISION DSD
      DOUBLE PRECISION DMOM4
C
      DIMENSION X(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='STMO'
      ISUBN2='M4  '
      IERROR='NO'
C
      DSUM=0.0D0
      DMEAN=0.0D0
      DSD=0.0D0
      XSMOM4=0.0
C
      IF(IBUGA3.EQ.'ON')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,51)
   51   FORMAT('***** AT THE BEGINNING OF STMOM4--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,52)IBUGA3,N
   52   FORMAT('IBUGA3,N = ',A4,2X,G15.7)
        CALL DPWRST('XXX','BUG ')
        DO55I=1,N
          WRITE(ICOUT,56)I,X(I)
   56     FORMAT('I,X(I) = ',I8,G15.7)
          CALL DPWRST('XXX','BUG ')
   55   CONTINUE
      ENDIF
C
C               **************************************************
C               **  COMPUTE STANDARDIZED FOURTH CENTRAL MOMENT  **
C               **************************************************
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      AN=N
C
      IF(N.LT.1)THEN
        IERROR='YES'
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,111)
  111   FORMAT('***** ERROR IN KURTOSIS (STMOM4)--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,112)
  112   FORMAT('      THE NUMBER OF OBSERVATIONS IN THE RESPONSE ',
     1         'VARIABLE IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,117)N
  117   FORMAT('      THE INPUT NUMBER OF OBSERVATIONS = ',I8,'.')
        CALL DPWRST('XXX','BUG ')
        GOTO9000
C
      ELSEIF(N.EQ.1)THEN
CCCCC   WRITE(ICOUT,999)
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   WRITE(ICOUT,121)
CC121   FORMAT('***** WARNING IN KURTOSIS (STMOM4)--')
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   WRITE(ICOUT,123)
CC123   FORMAT('      THE NUMBER OF OBSERVATIONS IN THE RESPONSE ',
CCCCC1         'VARIABLE IS EXACTLY ONE.')
CCCCC   CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
      HOLD=X(1)
      DO135I=2,N
        IF(X(I).NE.HOLD)GOTO139
  135 CONTINUE
CCCCC WRITE(ICOUT,999)
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC WRITE(ICOUT,121)
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC WRITE(ICOUT,136)HOLD
CC136 FORMAT('      THE RESPONSE VARIABLE HAS ALL ELEMENTS EQUAL ',
CCCCC1       'TO ',G15.7)
CCCCC CALL DPWRST('XXX','BUG ')
      GOTO9000
  139 CONTINUE
C
C               *******************************************************
C               **  STEP 2--                                         **
C               **  COMPUTE THE STANDARDIZED FOURTH CENTRAL MOMENT.  **
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
CCCCC DVAR=DSUM/(DN-1.0D0)
      DVAR=DSUM/DN
      DSD=0.0D0
      IF(DVAR.GT.0.0D0)DSD=DSQRT(DVAR)
      XSD=DSD
C
      DSUM=0.0D0
      DO400I=1,N
        DX=X(I)
        DSUM=DSUM+(DX-DMEAN)**4
  400 CONTINUE
CCCCC DMOM4=DSUM/(DN-1.0)
      DMOM4=DSUM/DN
      XSMOM4=DMOM4/(DSD**4)
C
C               *******************************
C               **  STEP 3--                 **
C               **  WRITE OUT A LINE         **
C               **  OF SUMMARY INFORMATION.  **
C               *******************************
C
      IF(IFEEDB.EQ.'ON' .AND. IWRITE.EQ.'ON')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,811)N,XSMOM4
  811   FORMAT('THE STANDARDIZED FOURTH CENTRAL MOMENT OF THE ',I8,
     1         ' OBSERVATIONS = ',G15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'ON')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END       OF STMOM4--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9012)IBUGA3,IERROR
 9012   FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9014)DMEAN,DSD,DSUM,XSMOM4
 9014   FORMAT('DMEAN,DSD,DSUM,XSMOM4 = ',4G15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      RETURN
      END
      SUBROUTINE STRDI(T,LDT,N,DET,JOB,INFO)
C***BEGIN PROLOGUE  STRDI
C***DATE WRITTEN   780814   (YYMMDD)
C***REVISION DATE  820801   (YYMMDD)
C***CATEGORY NO.  D2A3,D3A3
C***KEYWORDS  DETERMINANT,INVERSE,LINEAR ALGEBRA,LINPACK,MATRIX,
C             TRIANGULAR
C***AUTHOR  MOLER, C. B., (U. OF NEW MEXICO)
C***PURPOSE  Computes the determinant and inverse of a real TRIANGULAR
C            matrix
C***DESCRIPTION
C
C     STRDI computes the determinant and inverse of a real
C     triangular matrix.
C
C     On Entry
C
C        T       REAL(LDT,N)
C                T contains the triangular matrix.  The zero
C                elements of the matrix are not referenced, and
C                the corresponding elements of the array can be
C                used to store other information.
C
C        LDT     INTEGER
C                LDT is the leading dimension of the array T.
C
C        N       INTEGER
C                N is the order of the system.
C
C        JOB     INTEGER
C                = 010       no det, inverse of lower triangular.
C                = 011       no det, inverse of upper triangular.
C                = 100       det, no inverse.
C                = 110       det, inverse of lower triangular.
C                = 111       det, inverse of upper triangular.
C
C     On Return
C
C        T       inverse of original matrix if requested.
C                Otherwise unchanged.
C
C        DET     REAL(2)
C                determinant of original matrix if requested.
C                Otherwise not referenced.
C                Determinant = DET(1) * 10.0**DET(2)
C                with  1.0 .LE. ABS(DET(1)) .LT. 10.0
C                or  DET(1) .EQ. 0.0 .
C
C        INFO    INTEGER
C                INFO contains zero if the system is nonsingular
C                and the inverse is requested.
C                Otherwise INFO contains the index of
C                a zero diagonal element of T.
C
C
C     LINPACK.  This version dated 08/14/78 .
C     Cleve Moler, University of New Mexico, Argonne National Lab.
C
C     Subroutines and Functions
C
C     BLAS SAXPY,SSCAL
C     Fortran ABS,MOD
C***REFERENCES  DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W.,
C                 *LINPACK USERS  GUIDE*, SIAM, 1979.
C***ROUTINES CALLED  SAXPY,SSCAL
C***END PROLOGUE  STRDI
      INTEGER LDT,N,JOB,INFO
      REAL T(LDT,1),DET(2)
C
      REAL TEMP
      REAL TEN
      INTEGER I,J,K,KB,KM1,KP1
C
C     BEGIN BLOCK PERMITTING ...EXITS TO 180
C
C        COMPUTE DETERMINANT
C
C***FIRST EXECUTABLE STATEMENT  STRDI
         IF (JOB/100 .EQ. 0) GO TO 70
            DET(1) = 1.0E0
            DET(2) = 0.0E0
            TEN = 10.0E0
            DO 50 I = 1, N
               DET(1) = T(I,I)*DET(1)
C           ...EXIT
               IF (DET(1) .EQ. 0.0E0) GO TO 60
   10          IF (ABS(DET(1)) .GE. 1.0E0) GO TO 20
                  DET(1) = TEN*DET(1)
                  DET(2) = DET(2) - 1.0E0
               GO TO 10
   20          CONTINUE
   30          IF (ABS(DET(1)) .LT. TEN) GO TO 40
                  DET(1) = DET(1)/TEN
                  DET(2) = DET(2) + 1.0E0
               GO TO 30
   40          CONTINUE
   50       CONTINUE
   60       CONTINUE
   70    CONTINUE
C
C        COMPUTE INVERSE OF UPPER TRIANGULAR
C
         IF (MOD(JOB/10,10) .EQ. 0) GO TO 170
            IF (MOD(JOB,10) .EQ. 0) GO TO 120
C              BEGIN BLOCK PERMITTING ...EXITS TO 110
                  DO 100 K = 1, N
                     INFO = K
C              ......EXIT
                     IF (T(K,K) .EQ. 0.0E0) GO TO 110
                     T(K,K) = 1.0E0/T(K,K)
                     TEMP = -T(K,K)
                     CALL SSCAL(K-1,TEMP,T(1,K),1)
                     KP1 = K + 1
                     IF (N .LT. KP1) GO TO 90
                     DO 80 J = KP1, N
                        TEMP = T(K,J)
                        T(K,J) = 0.0E0
                        CALL SAXPY(K,TEMP,T(1,K),1,T(1,J),1)
   80                CONTINUE
   90                CONTINUE
  100             CONTINUE
                  INFO = 0
  110          CONTINUE
            GO TO 160
  120       CONTINUE
C
C              COMPUTE INVERSE OF LOWER TRIANGULAR
C
               DO 150 KB = 1, N
                  K = N + 1 - KB
                  INFO = K
C     ............EXIT
                  IF (T(K,K) .EQ. 0.0E0) GO TO 180
                  T(K,K) = 1.0E0/T(K,K)
                  TEMP = -T(K,K)
                  IF (K .NE. N) CALL SSCAL(N-K,TEMP,T(K+1,K),1)
                  KM1 = K - 1
                  IF (KM1 .LT. 1) GO TO 140
                  DO 130 J = 1, KM1
                     TEMP = T(K,J)
                     T(K,J) = 0.0E0
                     CALL SAXPY(N-K+1,TEMP,T(K,K),1,T(K,J),1)
  130             CONTINUE
  140             CONTINUE
  150          CONTINUE
               INFO = 0
  160       CONTINUE
  170    CONTINUE
  180 CONTINUE
      RETURN
      END
      SUBROUTINE STREQU(ISTR,NC,NPOSL1,NPOSL2,NPOSR1)
C
C     PURPOSE--SCAN A STRING AND SEARCH FOR AN "=" CHARACTER.
C              RETURN THE START (NPOSL1) AND STOP (NPOSL2) POSITIONS
C              OF THE STRING TO THE LEFT OF THE EQUAL SIGN AND THE
C              START POSITION OF THE STRING TO THE RIGHT OF THE
C              EQUAL SIGN.
C
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2019/02
C     ORIGINAL VERSION--FEBRUARY  2019.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*(*) ISTR
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      NPOSL1=0
      NPOSL2=0
      NPOSR1=0
C
      DO1100I=1,NC
        IF(ISTR(I:I).EQ.'=')THEN
          DO1110J=1,I-1
C
C           FIND FIRST NON-BLANK CHARACTER TO LEFT OF EQUAL SIGN
C
            IF(ISTR(J:J).NE.' ')THEN
              NPOSL1=J
C
C             FIND LAST NON-BLANK CHARACTER TO LEFT OF EQUAL SIGN
C
              DO1120K=I-1,NPOSL1,-1
                IF(ISTR(K:K).NE.' ')THEN
                  NPOSL2=K
                  GOTO1129
                ENDIF
 1120         CONTINUE
 1129         CONTINUE
C
C             FIND FIRST NON-BLANK CHARACTER TO RIGHT OF EQUAL SIGN
C
              DO1130K=I+1,NC
                IF(ISTR(K:K).NE.' ')THEN
                  NPOSR1=K
                  GOTO1139
                ENDIF
 1130         CONTINUE
              NPOSR1=I+1
 1139         CONTINUE
C
              GOTO1119
            ENDIF
 1110     CONTINUE
 1119     CONTINUE
        ENDIF
 1100 CONTINUE
C
      RETURN
      END
      DOUBLE PRECISION FUNCTION STRERR(DN)
C
C     PURPOSE--THIS FUNCTION IS A UTILITY FUNCTION FOR THE
C              BINRAW SUBROUTINE.  ADAPTED FROM ORIGINAL C
C              CODE OF CATHERINE LOADER.
C
C              THIS IS USED TO COMPUTE THE LOG OF THE ERROR TERM
C              IN STIRLING'S FORMULA.  FOR N > 15, USE THE SERIES
C              1/(12*N) - 1/(360*N**3) + ...
C              FOR N <= 15, INTEGERS, OR HALF-INTEGERS, USE STORED
C              VALUES.  FOR OTHER N < 15, CALL THE LOG-GAMMA FUNCTION.
C
C     PRINTING--NONE
C     OTHER DATAPAC   SUBROUTINES NEEDED--DLNGAM.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--ABS.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--CATHERINE LOADER (2000), "FAST AND ACCURATE COMPUTATION
C                 OF BINOMIAL PROBABILITIES", BELL LABS?
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2009/3
C     ORIGINAL VERSION--MARCH     2009.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      DIMENSION SHALVE(31)
      DOUBLE PRECISION NN
      DOUBLE PRECISION NN2
      INTEGER NTEMP
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----DATA STATEMENTS-------------------------------------------------
C
      DATA S0/0.083333333333333333333/
      DATA S1/0.00277777777777777777778/
      DATA S2/0.00079365079365079365079365/
      DATA S3/0.000595238095238095238095238/
      DATA S4/0.0008417508417508417508417508/
      DATA DPI2/6.283185307179586476925286766559/
C
      DATA SHALVE(1)/0.0/
      DATA SHALVE(2)/0.1534264097200273452913848/
      DATA SHALVE(3)/0.0810614667953272582196702/
      DATA SHALVE(4)/0.0548141210519176538961390/
      DATA SHALVE(5)/0.0413406959554092940938221/
      DATA SHALVE(6)/0.03316287351993628748511048/
      DATA SHALVE(7)/0.02767792568499833914878929/
      DATA SHALVE(8)/0.02374616365629749597132920/
      DATA SHALVE(9)/0.02079067210376509311152277/
      DATA SHALVE(10)/0.01848845053267318523077934/
      DATA SHALVE(11)/0.01664469118982119216319487/
      DATA SHALVE(12)/0.01513497322191737887351255/
      DATA SHALVE(13)/0.01387612882307074799874573/
      DATA SHALVE(14)/0.01281046524292022692424986/
      DATA SHALVE(15)/0.01189670994589177009505572/
      DATA SHALVE(16)/0.01110455975820691732662991/
      DATA SHALVE(17)/0.010411265261972096497478567/
      DATA SHALVE(18)/0.009799416126158803298389475/
      DATA SHALVE(19)/0.009255462182712732917728637/
      DATA SHALVE(20)/0.008768700134139385462952823/
      DATA SHALVE(21)/0.008330563433362871256469318/
      DATA SHALVE(22)/0.007934114564314020547248100/
      DATA SHALVE(23)/0.007573675487951840794972024/
      DATA SHALVE(24)/0.007244554301320383179543912/
      DATA SHALVE(25)/0.006942840107209529865664152/
      DATA SHALVE(26)/0.006665247032707682442354394/
      DATA SHALVE(27)/0.006408994188004207068439631/
      DATA SHALVE(28)/0.006171712263039457647532867/
      DATA SHALVE(29)/0.005951370112758847735624416/
      DATA SHALVE(30)/0.005746216513010115682023589/
      DATA SHALVE(31)/0.005554733551962801371038690/
C
C-----START POINT-----------------------------------------------------
C
      IF(DN.LE.15.0D0)THEN
        NN=DN+DN
        NTEMP=INT(NN)
        NN2=DBLE(NTEMP)
        IF (NN.EQ.NN2) THEN
           STRERR=SHALVE(NTEMP+1)
        ELSE
          DTERM1=DLNGAM(DN + 1.0D0)
          DTERM2=(DN + 0.5D0)*LOG(DN)
          DTERM3=DN - LOG(DPI2)
          STRERR=DLNGAM(DN + 1.0D0) - (DN + 0.5D0)*LOG(DN) +
     1           DN - LOG(DPI2)
        ENDIF
      ELSE
        NN=DN*DN
        IF(DN.GT.500.D0)THEN
          STRERR=(S0-S1/NN)/DN
        ELSEIF(DN.GT.80.D0)THEN
          STRERR=(S0-(S1-S2/NN)/NN)/DN
        ELSEIF(DN.GT.35.D0)THEN
          STRERR=(S0-(S1-(S2-S3/NN)/NN)/NN)/DN
        ELSE
          STRERR=(S0-(S1-(S2-(S3-S4/NN)/NN)/NN)/NN)/DN
        ENDIF
      ENDIF
C
      RETURN
      END
      SUBROUTINE STRLEZ(ISTR80,MAXCHR,LENGTH)
C
C     PURPOSE--DETERMINE THE LENGTH (OUT TO THE LAST NON-BLANK
C              CHARACTER) OF THE 80-CHARACTER STRING    ISTR80.
C
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--92/4
C     ORIGINAL VERSION--MARCH     1992.
C     UPDATED         --MARCH     2005. RENAME TO STRLEZ TO AVOID NAME CONFLICT
C                                       ON MAC OSX.
C     UPDATED         --APRIL     2020. MAKE LENGTH OF STRING SETTABLE
C                                       BY CALLING ROUTINE
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
CCCCC CHARACTER*80 ISTR80
      CHARACTER (LEN=*) :: ISTR80
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
CCCCC IWIDTH=80
      IWIDTH=MAXCHR
      DO1100I=1,IWIDTH
        IREV=IWIDTH-I+1
        IF(ISTR80(IREV:IREV).NE.' ')THEN
          LENGTH=IREV
          GOTO9000
        ENDIF
 1100 CONTINUE
      LENGTH=0
C
 9000 CONTINUE
      RETURN
      END
      DOUBLE PRECISION FUNCTION STROM(XVALUE)
C
C  DESCRIPTION:
C
C    This program calculates Stromgren's integral, defined as
C
C      STROM(X) = integral 0 to X { t**7 exp(2t)/[exp(t)-1]**3 } dt
C
C    The code uses a Chebyshev series, the coefficients of which are
C    given to an accuracy of 20 decimal places.
C
C
C  ERROR RETURNS:
C
C    If XVALUE < 0.0, an error message is printed, and the program
C    returns the value 0.0.
C
C
C  MACHINE-DEPENDENT CONSTANTS:
C
C    NTERMS - INTEGER - The number of terms of the array ASTROM to be used.
C                       The recommended value is such that
C                             ASTROM(NTERMS) < EPS/100
C
C    XLOW0 - DOUBLE PRECISION - The value below which STROM = 0.0 to machine
C                    precision. The recommended value is
C                          5th root of (130*XMIN)
C
C    XLOW1 - DOUBLE PRECISION - The value below which STROM = 3*(X**5)/(4*(pi**4))
C                   to machine precision. The recommended value is
C                             2*EPSNEG
C
C    EPSLN - DOUBLE PRECISION - The value of ln(EPS). Used to determine the no.
C                   of exponential terms for large X.
C
C    EPNGLN - DOUBLE PRECISION - The value of ln(EPSNEG). Used to prevent
C                    overflow for large X.
C
C    XHIGH - DOUBLE PRECISION - The value above which
C                           STROM = 196.52 - 15*(x**7)*exp(-x)/(4pi**4)
C                   to machine precision. The recommended value is
C                             7 / EPS
C
C     For values of EPS, EPSNEG, and XMIN refer to the file MACHCON.TXT
C
C     The machine-dependent constants are computed internally by
C     using the D1MACH subroutine.
C
C
C  INTRINSIC FUNCTIONS USED:
C
C    EXP, INT, LOG
C
C
C   OTHER MISCFUN SUBROUTINES USED:
C
C          CHEVAL , ERRPRN, D1MACH
C
C
C  AUTHOR:
C
C     DR. ALLAN J. MACLEOD,
C     DEPT. OF MATHEMATICS AND STATISTICS,
C     UNIVERSITY OF PAISLEY,
C     HIGH ST.,
C     PAISLEY,
C     SCOTLAND.
C     PA1 2BE.
C
C     (e-mail: macl_ms0@paisley.ac.uk )
C
C
C  LATEST REVISION:
C                  23 January, 1996
C
C
      INTEGER K1,K2,NTERMS,NUMEXP
      DOUBLE PRECISION ASTROM(0:26),CHEVAL,EPNGLN,EPSLN,FOUR,
     1     F15BP4,HALF,ONE,ONEHUN,ONE30,ONE5LN,PI4B3,RK,
     2     SEVEN,SUMEXP,SUM2,T,TWO,VALINF,X,XHIGH,
     3     XK,XK1,XLOW0,XLOW1,XVALUE,ZERO
CCCCC CHARACTER FNNAME*6,ERRMSG*14
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOMC.INC'
      INCLUDE 'DPCOP2.INC'
C
CCCCC DATA FNNAME/'STROM '/
CCCCC DATA ERRMSG/'ARGUMENT < 0.0'/
      DATA ZERO,HALF,ONE/ 0.0 D 0 , 0.5 D 0 , 1.0 D 0/
      DATA TWO,FOUR,SEVEN/ 2.0 D 0 , 4.0 D 0 , 7.0 D 0 /
      DATA ONEHUN,ONE30,ONE5LN/ 100.0 D 0 , 130.0 D 0 , 0.4055 D 0 /
      DATA F15BP4/0.38497 43345 50662 56959 D -1 /
      DATA PI4B3/1.29878 78804 53365 82982 D 2 /
      DATA VALINF/196.51956 92086 89882 61257 D 0/
      DATA ASTROM(0)/  0.56556 12087 25391 55290  D    0/
      DATA ASTROM(1)/  0.45557 31969 10178 5525   D   -1/
      DATA ASTROM(2)/ -0.40395 35875 93686 9170   D   -1/
      DATA ASTROM(3)/ -0.13339 05720 21486 815    D   -2/
      DATA ASTROM(4)/  0.18586 25062 50538 030    D   -2/
      DATA ASTROM(5)/ -0.46855 55868 05365 9      D   -4/
      DATA ASTROM(6)/ -0.63434 75643 42294 9      D   -4/
      DATA ASTROM(7)/  0.57254 87081 43200        D   -5/
      DATA ASTROM(8)/  0.15935 28122 16822        D   -5/
      DATA ASTROM(9)/ -0.28884 32843 1036         D   -6/
      DATA ASTROM(10)/-0.24466 33604 801          D   -7/
      DATA ASTROM(11)/ 0.10072 50382 374          D   -7/
      DATA ASTROM(12)/-0.12482 98610 4            D   -9/
      DATA ASTROM(13)/-0.26300 62528 3            D   -9/
      DATA ASTROM(14)/ 0.24904 07578              D  -10/
      DATA ASTROM(15)/ 0.48545 4902               D  -11/
      DATA ASTROM(16)/-0.10537 8913               D  -11/
      DATA ASTROM(17)/-0.36044 17                 D  -13/
      DATA ASTROM(18)/ 0.29920 78                 D  -13/
      DATA ASTROM(19)/-0.16397 1                  D  -14/
      DATA ASTROM(20)/-0.61061                    D  -15/
      DATA ASTROM(21)/ 0.9335                     D  -16/
      DATA ASTROM(22)/ 0.709                      D  -17/
      DATA ASTROM(23)/-0.291                      D  -17/
      DATA ASTROM(24)/ 0.8                        D  -19/
      DATA ASTROM(25)/ 0.6                        D  -19/
      DATA ASTROM(26)/-0.1                        D  -19/
C
      XLOW0=0.0
      XLOW1=0.0
C  Start execution
C
      X = XVALUE
C
C  Error test
C
      IF ( X .LT. ZERO ) THEN
CCCCC    CALL ERRPRN(FNNAME,ERRMSG)
         WRITE(ICOUT,999)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,101)X
         CALL DPWRST('XXX','BUG ')
         STROM = ZERO
         RETURN
      ENDIF
  999 FORMAT(1X)
  101 FORMAT('***** ERROR FROM STROM--ARGUMENT MUST BE ',
     1       'NON-NEGATIVE, ARGUMENT = ',G15.7)
C
C   Compute the machine-dependent constants.
C
      XK = D1MACH(3)
      T = XK / ONEHUN
      IF ( X .LE. FOUR ) THEN
         DO 10 NTERMS = 26 , 0 , -1
            IF ( ABS(ASTROM(NTERMS)) .GT. T ) GOTO 19
 10      CONTINUE
 19      XLOW0 = ( ONE30 * D1MACH(1) ) ** (ONE/(SEVEN-TWO))
         XLOW1 = TWO * XK
      ELSE
         EPSLN = LOG ( D1MACH(4) )
         EPNGLN = LOG ( XK )
         XHIGH = SEVEN / XK
      ENDIF
C
C   Code for x < =  4.0
C
      IF ( X .LE. FOUR ) THEN
         IF ( X .LT. XLOW0 ) THEN
            STROM = ZERO
         ELSE
            IF ( X .LT. XLOW1 ) THEN
               STROM = (X**5) / PI4B3
            ELSE
               T = ( ( X / TWO ) - HALF ) - HALF
               STROM = (X**5) * CHEVAL(NTERMS,ASTROM,T) * F15BP4
            ENDIF
         ENDIF
      ELSE
C
C  Code for x > 4.0
C
         IF ( X .GT. XHIGH ) THEN
            SUMEXP = ONE
         ELSE
            NUMEXP = INT( EPSLN / (ONE5LN - X ) ) + 1
            IF ( NUMEXP .GT. 1 ) THEN
               T = EXP( -X )
            ELSE
               T = ONE
            ENDIF
            RK = ZERO
            DO 100 K1 = 1 , NUMEXP
               RK = RK + ONE
  100       CONTINUE
            SUMEXP = ZERO
            DO 300 K1 = 1 , NUMEXP
               SUM2 = ONE
               XK = ONE / ( RK * X )
               XK1 = ONE
               DO 200 K2 = 1 , 7
                  SUM2 = SUM2 * XK1 * XK + ONE
                  XK1 = XK1 + ONE
  200          CONTINUE
               SUM2 = SUM2 * ( RK + ONE ) / TWO
               SUMEXP = SUMEXP * T + SUM2
               RK = RK - ONE
  300       CONTINUE
         ENDIF
         T = SEVEN * LOG(X) - X + LOG(SUMEXP)
         IF ( T .LT. EPNGLN ) THEN
            STROM = VALINF
         ELSE
            STROM = VALINF - EXP(T) * F15BP4
         ENDIF
      ENDIF
      RETURN
      END
      SUBROUTINE STRSL(T,LDT,N,B,JOB,INFO)
C***BEGIN PROLOGUE  STRSL
C***DATE WRITTEN   780814   (YYMMDD)
C***REVISION DATE  820801   (YYMMDD)
C***CATEGORY NO.  D2A3
C***KEYWORDS  LINEAR ALGEBRA,LINPACK,MATRIX,SOLVE,TRIANGULAR
C***AUTHOR  STEWART, G. W., (U. OF MARYLAND)
C***PURPOSE  Solves systems of the form  T*X=B or TRANS(T)*X=B
C            where T is a TRIANGULAR matrix of order N.
C***DESCRIPTION
C
C     STRSL solves systems of the form
C
C                   T * X = B
C     or
C                   TRANS(T) * X = B
C
C     where T is a triangular matrix of order N.  Here TRANS(T)
C     denotes the transpose of the matrix T.
C
C     On Entry
C
C         T         REAL(LDT,N)
C                   T contains the matrix of the system.  The zero
C                   elements of the matrix are not referenced, and
C                   the corresponding elements of the array can be
C                   used to store other information.
C
C         LDT       INTEGER
C                   LDT is the leading dimension of the array T.
C
C         N         INTEGER
C                   N is the order of the system.
C
C         B         REAL(N).
C                   B contains the right hand side of the system.
C
C         JOB       INTEGER
C                   JOB specifies what kind of system is to be solved.
C                   If JOB is
C
C                        00   solve T*X=B, T lower triangular,
C                        01   solve T*X=B, T upper triangular,
C                        10   solve TRANS(T)*X=B, T lower triangular,
C                        11   solve TRANS(T)*X=B, T upper triangular.
C
C     On Return
C
C         B         B contains the solution, if INFO .EQ. 0.
C                   Otherwise B is unaltered.
C
C         INFO      INTEGER
C                   INFO contains zero if the system is nonsingular.
C                   Otherwise INFO contains the index of
C                   the first zero diagonal element of T.
C
C     LINPACK.  This version dated 08/14/78 .
C     G. W. Stewart, University of Maryland, Argonne National Lab.
C
C     Subroutines and Functions
C
C     BLAS SAXPY,SDOT
C     Fortran MOD
C***REFERENCES  DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W.,
C                 *LINPACK USERS  GUIDE*, SIAM, 1979.
C***ROUTINES CALLED  SAXPY,SDOT
C***END PROLOGUE  STRSL
      INTEGER LDT,N,JOB,INFO
      REAL T(LDT,*),B(*)
C
C
      REAL SDOT,TEMP
      INTEGER CASE,J,JJ
C
C     BEGIN BLOCK PERMITTING ...EXITS TO 150
C
C        CHECK FOR ZERO DIAGONAL ELEMENTS.
C
C***FIRST EXECUTABLE STATEMENT  STRSL
         DO 10 INFO = 1, N
C     ......EXIT
            IF (T(INFO,INFO) .EQ. 0.0E0) GO TO 150
   10    CONTINUE
         INFO = 0
C
C        DETERMINE THE TASK AND GO TO IT.
C
         CASE = 1
         IF (MOD(JOB,10) .NE. 0) CASE = 2
         IF (MOD(JOB,100)/10 .NE. 0) CASE = CASE + 2
         GO TO (20,50,80,110), CASE
C
C        SOLVE T*X=B FOR T LOWER TRIANGULAR
C
   20    CONTINUE
            B(1) = B(1)/T(1,1)
            IF (N .LT. 2) GO TO 40
            DO 30 J = 2, N
               TEMP = -B(J-1)
               CALL SAXPY(N-J+1,TEMP,T(J,J-1),1,B(J),1)
               B(J) = B(J)/T(J,J)
   30       CONTINUE
   40       CONTINUE
         GO TO 140
C
C        SOLVE T*X=B FOR T UPPER TRIANGULAR.
C
   50    CONTINUE
            B(N) = B(N)/T(N,N)
            IF (N .LT. 2) GO TO 70
            DO 60 JJ = 2, N
               J = N - JJ + 1
               TEMP = -B(J+1)
               CALL SAXPY(J,TEMP,T(1,J+1),1,B(1),1)
               B(J) = B(J)/T(J,J)
   60       CONTINUE
   70       CONTINUE
         GO TO 140
C
C        SOLVE TRANS(T)*X=B FOR T LOWER TRIANGULAR.
C
   80    CONTINUE
            B(N) = B(N)/T(N,N)
            IF (N .LT. 2) GO TO 100
            DO 90 JJ = 2, N
               J = N - JJ + 1
               B(J) = B(J) - SDOT(JJ-1,T(J+1,J),1,B(J+1),1)
               B(J) = B(J)/T(J,J)
   90       CONTINUE
  100       CONTINUE
         GO TO 140
C
C        SOLVE TRANS(T)*X=B FOR T UPPER TRIANGULAR.
C
  110    CONTINUE
            B(1) = B(1)/T(1,1)
            IF (N .LT. 2) GO TO 130
            DO 120 J = 2, N
               B(J) = B(J) - SDOT(J-1,T(1,J),1,B(1),1)
               B(J) = B(J)/T(J,J)
  120       CONTINUE
  130       CONTINUE
  140    CONTINUE
  150 CONTINUE
      RETURN
      END
      SUBROUTINE STRSWP(A,N1,N2,N3)
C
C     PURPOSE--XX
C
C     NOTE--RECOMMENDED DIMENSIONS--
C           A(N3-1)
C
C     WRITTEN BY--DAVID W. BEHRINGER NOAA/AOML (MIAMI).
C                 AS PART OF NOAA'S CONCX V.3   MARCH 1988.
C     ORIGINAL VERSION (IN DATAPLOT)--AUGUST    1988.
C
C---------------------------------------------------------------------
C
      DIMENSION A(*)
C
C-----START POINT-----------------------------------------------------
C
      DO 10 N=N1,N2-1
        H=A(N1)
        DO 20 I=N1,N3-2
          A(I)=A(I+1)
 20     CONTINUE
        A(N3-1)=H
 10   CONTINUE
      RETURN
      END
      DOUBLE PRECISION FUNCTION STUDNT( NU, T )
*
*     Student t Distribution Function
*
*                       T
*         STUDNT = C   I  ( 1 + y*y/NU )**( -(NU+1)/2 ) dy
*                   NU -INF
*
      INTEGER NU, J
      DOUBLE PRECISION T, CSSTHE, SNTHE, POLYN, TT, TS, RN, PI, ZERO
      PARAMETER ( PI = 3.14159 26535 89793D0, ZERO = 0 )
      IF ( NU .EQ. 1 ) THEN
         STUDNT = ( 1.0D0 + 2.0D0*ATAN(T)/PI )/2.0D0
      ELSE IF ( NU .EQ. 2) THEN
         STUDNT = ( 1.0D0 + T/SQRT( 2.0D0 + T*T ))/2.0D0
      ELSE
         TT = T*T
         CSSTHE = 1.0D0/( 1.0D0 + TT/DBLE(NU) )
         POLYN = 1.0D0
         DO 100 J = NU-2, 2, -2
            POLYN = 1.0D0 + DBLE( J - 1 )*CSSTHE*POLYN/DBLE(J)
  100    CONTINUE
         IF ( MOD( NU, 2 ) .EQ. 1 ) THEN
            RN = NU
            TS = T/SQRT(RN)
            STUDNT = ( 1.0D0 + 2.0D0*
     &             ( ATAN(TS) + TS*CSSTHE*POLYN )/PI )/2.0D0
         ELSE
            SNTHE = T/SQRT( NU + TT )
            STUDNT = ( 1.0D0 + SNTHE*POLYN )/2.0D0
         END IF
         STUDNT = MAX( ZERO, STUDNT )
      ENDIF
C
      RETURN
      END
        SUBROUTINE STVH0(X,SH0)
C
C       =============================================
C       Purpose: Compute Struve function H0(x)
C       Input :  x   --- Argument of H0(x) ( x � 0 )
C       Output:  SH0 --- H0(x)
C       =============================================
C
        IMPLICIT DOUBLE PRECISION (A-H,O-Z)
        PI=3.141592653589793D0
        S=1.0D0
        R=1.0D0
        IF (X.LE.20.0D0) THEN
           A0=2.0*X/PI
           DO 10 K=1,60
              R=-R*X/(2.0D0*K+1.0D0)*X/(2.0D0*K+1.0D0)
              S=S+R
              IF (DABS(R).LT.DABS(S)*1.0D-12) GO TO 15
10         CONTINUE
15         SH0=A0*S
        ELSE
           KM=INT(.5*(X+1.0))
           IF (X.GE.50.0) KM=25
           DO 20 K=1,KM
              R=-R*((2.0D0*K-1.0D0)/X)**2
              S=S+R
              IF (DABS(R).LT.DABS(S)*1.0D-12) GO TO 25
20         CONTINUE
25         T=4.0D0/X
           T2=T*T
           P0=((((-.37043D-5*T2+.173565D-4)*T2-.487613D-4)
     &        *T2+.17343D-3)*T2-.1753062D-2)*T2+.3989422793D0
           Q0=T*(((((.32312D-5*T2-.142078D-4)*T2+.342468D-4)*
     &        T2-.869791D-4)*T2+.4564324D-3)*T2-.0124669441D0)
           TA0=X-.25D0*PI
           BY0=2.0D0/DSQRT(X)*(P0*DSIN(TA0)+Q0*DCOS(TA0))
           SH0=2.0D0/(PI*X)*S+BY0
        ENDIF
        RETURN
        END
        SUBROUTINE STVH1(X,SH1)
C
C       =============================================
C       Purpose: Compute Struve function H1(x)
C       Input :  x   --- Argument of H1(x) ( x � 0 )
C       Output:  SH1 --- H1(x)
C       =============================================
C
        IMPLICIT DOUBLE PRECISION (A-H,O-Z)
        PI=3.141592653589793D0
        R=1.0D0
        IF (X.LE.20.0D0) THEN
           S=0.0D0
           A0=-2.0D0/PI
           DO 10 K=1,60
              R=-R*X*X/(4.0D0*K*K-1.0D0)
              S=S+R
              IF (DABS(R).LT.DABS(S)*1.0D-12) GO TO 15
10         CONTINUE
15         SH1=A0*S
        ELSE
           S=1.0D0
           KM=INT(.5*X)
           IF (X.GT.50.D0) KM=25
           DO 20 K=1,KM
              R=-R*(4.0D0*K*K-1.0D0)/(X*X)
              S=S+R
              IF (DABS(R).LT.DABS(S)*1.0D-12) GO TO 25
20         CONTINUE
25         T=4.0D0/X
           T2=T*T
           P1=((((.42414D-5*T2-.20092D-4)*T2+.580759D-4)*T2
     &        -.223203D-3)*T2+.29218256D-2)*T2+.3989422819D0
           Q1=T*(((((-.36594D-5*T2+.1622D-4)*T2-.398708D-4)*
     &        T2+.1064741D-3)*T2-.63904D-3)*T2+.0374008364D0)
           TA1=X-.75D0*PI
           BY1=2.0D0/DSQRT(X)*(P1*DSIN(TA1)+Q1*DCOS(TA1))
           SH1=2.0/PI*(1.0D0+S/(X*X))+BY1
        ENDIF
        RETURN
        END
        SUBROUTINE STVHV(V,X,HV)
C
C       =====================================================
C       Purpose: Compute Struve function Hv(x) with an
C                arbitrary order v
C       Input :  v  --- Order of Hv(x)  ( -8.0  v  12.5 )
C                x  --- Argument of Hv(x) ( x � 0 )
C       Output:  HV --- Hv(x)
C       Routine called: GAMMA to compute the gamma function
C       =====================================================
C
        IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
        PU0=0.0D0
        QU0=0.0D0
        BYV=0.0D0
C
        PI=3.141592653589793D0
        IF (X.EQ.0.0D0) THEN
           IF (V.GT.-1.0.OR.INT(V)-V.EQ.0.5D0) THEN
              HV=0.0D0
           ELSE IF (V.LT.-1.0D0) THEN
              HV=(-1)**(INT(0.5D0-V)-1)*1.0D+300
           ELSE IF (V.EQ.-1.0D0) THEN
              HV=2.0D0/PI
           ENDIF
           RETURN
        ENDIF
        IF (X.LE.20.0D0) THEN
           V0=V+1.5D0
CCCCC      CALL GAMMA(V0,GA)
           GA=DGAMMA(V0)
           S=2.0D0/(DSQRT(PI)*GA)
           R1=1.0D0
           DO 10 K=1,100
              VA=K+1.5D0
CCCCC         CALL GAMMA(VA,GA)
              GA=DGAMMA(VA)
              VB=V+K+1.5D0
CCCCC         CALL GAMMA(VB,GB)
              GB=DGAMMA(VB)
              R1=-R1*(0.5D0*X)**2
              R2=R1/(GA*GB)
              S=S+R2
              IF (DABS(R2).LT.DABS(S)*1.0D-12) GO TO 15
10         CONTINUE
15         HV=(0.5D0*X)**(V+1.0D0)*S
        ELSE
           SA=(0.5D0*X)**(V-1.0)/PI
           V0=V+0.5D0
CCCCC      CALL GAMMA(V0,GA)
           GA=DGAMMA(V0)
           S=DSQRT(PI)/GA
           R1=1.0D0
           DO 20 K=1,12
              VA=K+0.5D0
CCCCC         CALL GAMMA(VA,GA)
              GA=DGAMMA(VA)
              VB=-K+V+0.5D0
CCCCC         CALL GAMMA(VB,GB)
              GB=DGAMMA(VB)
              R1=R1/(0.5D0*X)**2
              S=S+R1*GA/GB
20         CONTINUE
           S0=SA*S
           U=DABS(V)
           N=INT(U)
           U0=U-N
           DO 35 L=0,1
              VT=4.0D0*(U0+L)**2
              R1=1.0D0
              PU1=1.0D0
              DO 25 K=1,12
                 R1=-0.0078125D0*R1*(VT-(4.0*K-3.0D0)**2)*
     &             (VT-(4.0D0*K-1.0)**2)/((2.0D0*K-1.0)*K*X*X)
                 PU1=PU1+R1
25            CONTINUE
              QU1=1.0D0
              R2=1.0D0
              DO 30 K=1,12
                 R2=-0.0078125D0*R2*(VT-(4.0D0*K-1.0)**2)*
     &             (VT-(4.0D0*K+1.0)**2)/((2.0D0*K+1.0)*K*X*X)
                 QU1=QU1+R2
30            CONTINUE
              QU1=0.125D0*(VT-1.0D0)/X*QU1
              IF (L.EQ.0) THEN
                 PU0=PU1
                 QU0=QU1
              ENDIF
35         CONTINUE
           T0=X-(0.5*U0+0.25D0)*PI
           T1=X-(0.5*U0+0.75D0)*PI
           SR=DSQRT(2.0D0/(PI*X))
           BY0=SR*(PU0*DSIN(T0)+QU0*DCOS(T0))
           BY1=SR*(PU1*DSIN(T1)+QU1*DCOS(T1))
           BF0=BY0
           BF1=BY1
           DO 40 K=2,N
              BF=2.0D0*(K-1.0+U0)/X*BF1-BF0
              BF0=BF1
              BF1=BF
40         CONTINUE
           IF (N.EQ.0) BYV=BY0
           IF (N.EQ.1) BYV=BY1
           IF (N.GT.1) BYV=BF
           HV=BYV+S0
        ENDIF
        RETURN
        END
        SUBROUTINE STVL0(X,SL0)
C
C       ================================================
C       Purpose: Compute modified Struve function L0(x)
C       Input :  x   --- Argument of L0(x) ( x � 0 )
C       Output:  SL0 --- L0(x)
C       ================================================
C
        IMPLICIT DOUBLE PRECISION (A-H,O-Z)
        PI=3.141592653589793D0
        S=1.0D0
        R=1.0D0
        IF (X.LE.20.0D0) THEN
           A0=2.0D0*X/PI
           DO 10 K=1,60
              R=R*(X/(2.0D0*K+1.0D0))**2
              S=S+R
              IF (DABS(R/S).LT.1.0D-12) GO TO 15
10         CONTINUE
15         SL0=A0*S
        ELSE
           KM=INT(.5*(X+1.0))
           IF (X.GE.50.0) KM=25
           DO 20 K=1,KM
              R=R*((2.0D0*K-1.0D0)/X)**2
              S=S+R
              IF (DABS(R/S).LT.1.0D-12) GO TO 25
20         CONTINUE
25         A1=DEXP(X)/DSQRT(2.0D0*PI*X)
           R=1.0D0
           BI0=1.0D0
           DO 30 K=1,16
              R=0.125D0*R*(2.0D0*K-1.0D0)**2/(K*X)
              BI0=BI0+R
              IF (DABS(R/BI0).LT.1.0D-12) GO TO 35
30         CONTINUE
35         BI0=A1*BI0
           SL0=-2.0D0/(PI*X)*S+BI0
        ENDIF
        RETURN
        END
        SUBROUTINE STVL1(X,SL1)
C
C       ================================================
C       Purpose: Compute modified Struve function L1(x)
C       Input :  x   --- Argument of L1(x) ( x � 0 )
C       Output:  SL1 --- L1(x)
C       ================================================
C
        IMPLICIT DOUBLE PRECISION (A-H,O-Z)
        PI=3.141592653589793D0
        R=1.0D0
        IF (X.LE.20.0D0) THEN
           S=0.0D0
           DO 10 K=1,60
              R=R*X*X/(4.0D0*K*K-1.0D0)
              S=S+R
              IF (DABS(R/S).LT.1.0D-12) GO TO 15
10         CONTINUE
15         SL1=2.0D0/PI*S
        ELSE
           S=1.0D0
           KM=INT(.50*X)
           IF (X.GT.50) KM=25
           DO 20 K=1,KM
              R=R*(2.0D0*K+3.0D0)*(2.0D0*K+1.0D0)/(X*X)
              S=S+R
              IF (DABS(R/S).LT.1.0D-12) GO TO 25
20            CONTINUE
25         SL1=2.0D0/PI*(-1.0D0+1.0D0/(X*X)+3.0D0*S/X**4)
           A1=DEXP(X)/DSQRT(2.0D0*PI*X)
           R=1.0D0
           BI1=1.0D0
           DO 30 K=1,16
              R=-0.125D0*R*(4.0D0-(2.0D0*K-1.0D0)**2)/(K*X)
              BI1=BI1+R
              IF (DABS(R/BI1).LT.1.0D-12) GO TO 35
30         CONTINUE
35         SL1=SL1+A1*BI1
        ENDIF
        RETURN
        END
        SUBROUTINE STVLV(V,X,SLV)
C
C       ======================================================
C       Purpose:  Compute modified Struve function Lv(x) with
C                 an arbitrary order v
C       Input :   v   --- Order of Lv(x)  ( |v|  20 )
C                 x   --- Argument of Lv(x) ( x � 0 )
C       Output:   SLV --- Lv(x)
C       Routine called: GAMMA to compute the gamma function
C       ======================================================
C
        IMPLICIT DOUBLE PRECISION (A-H,O-Z)
        PI=3.141592653589793D0
        IF (X.EQ.0.0D0) THEN
           IF (V.GT.-1.0.OR.INT(V)-V.EQ.0.5D0) THEN
              SLV=0.0D0
           ELSE IF (V.LT.-1.0D0) THEN
              SLV=(-1)**(INT(0.5D0-V)-1)*1.0D+300
           ELSE IF (V.EQ.-1.0D0) THEN
              SLV=2.0D0/PI
           ENDIF
           RETURN
        ENDIF
        IF (X.LE.40.0D0) THEN
           V0=V+1.5D0
CCCCC      CALL GAMMA(V0,GA)
           GA=DGAMMA(V0)
           S=2.0D0/(DSQRT(PI)*GA)
           R1=1.0D0
           DO 10 K=1,100
              VA=K+1.5D0
CCCCC         CALL GAMMA(VA,GA)
              GA=DGAMMA(VA)
              VB=V+K+1.5D0
CCCCC         CALL GAMMA(VB,GB)
              GB=DGAMMA(VB)
              R1=R1*(0.5D0*X)**2
              R2=R1/(GA*GB)
              S=S+R2
              IF (DABS(R2/S).LT.1.0D-12) GO TO 15
10         CONTINUE
15         SLV=(0.5D0*X)**(V+1.0D0)*S
        ELSE
           SA=-1.0D0/PI*(0.5D0*X)**(V-1.0)
           V0=V+0.5D0
CCCCC      CALL GAMMA(V0,GA)
           GA=DGAMMA(V0)
           S=-DSQRT(PI)/GA
           R1=-1.0D0
           DO 20 K=1,12
              VA=K+0.5D0
CCCCC         CALL GAMMA(VA,GA)
              GA=DGAMMA(VA)
              VB=-K+V+0.5D0
CCCCC         CALL GAMMA(VB,GB)
              GB=DGAMMA(VB)
              R1=-R1/(0.5D0*X)**2
              S=S+R1*GA/GB
20         CONTINUE
           S0=SA*S
           U=DABS(V)
           N=INT(U)
           U0=U-N
           DO 35 L=0,1
              VT=U0+L
              R=1.0D0
              BIV=1.0D0
              DO 25 K=1,16
                 R=-0.125*R*(4.0*VT*VT-(2.0*K-1.0D0)**2)/(K*X)
                 BIV=BIV+R
                 IF (DABS(R/BIV).LT.1.0D-12) GO TO 30
25            CONTINUE
30            IF (L.EQ.0) BIV0=BIV
35         CONTINUE
           BF0=BIV0
           BF1=BIV
           DO 40 K=2,N
              BF=-2.0D0*(K-1.0+U0)/X*BF1+BF0
              BF0=BF1
              BF1=BF
40         CONTINUE
           IF (N.EQ.0) BIV=BIV0
           IF (N.GT.1) BIV=BF
           SLV=DEXP(X)/DSQRT(2.0D0*PI*X)*BIV+S0
        ENDIF
        RETURN
        END
      SUBROUTINE STWS(X,N,Y,IWRITE,YSTWS,IUPPER,IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE
C              STANDARDIZED WILK-SHAPIRO STATISTIC
C              THE PROTOTYPE NORMAL DISTRIBUTION USED HEREIN
C              HAS MEAN = 0 AND STANDARD DEVIATION = 1.
C              THIS DISTRIBUTION IS DEFINED FOR ALL X AND HAS
C              THE PROBABILITY DENSITY FUNCTION
C              F(X) = (1/SQRT(2*PI)) * EXP(-X*X/2).
C              THE STANDARDIZED WILK-SHAPIRO STATISTIC IS USEFUL IN
C              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 NORMAL DISTRIBUTION.
C              IF THE HYPOTHESIS IS TRUE, THE STANDARDIZED
C              WILK-SHAPIRO STATISTIC SHOULD BE NEAR-ZERO OR POSITIVE.
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--YSTWS  = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED STANDARDIZED WILK-SHAPIRO STATISTIC.
C     OUTPUT--NONE.
C     PRINTING--YES.
C     RESTRICTIONS--THE MAXIMUM ALLOWABLE VALUE OF N
C                   FOR THIS SUBROUTINE IS 1000.
C     OTHER DATAPAC   SUBROUTINES NEEDED--SORT, UNIMED, NORPPF.
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     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1966)
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     UPDATED         --JUNE      1990. TEMPORARY ARRAYS TO GARBAGE COMMON
C     UPDATED         --JULY      2019. TWEAK SCRATCH SPACE
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
      DIMENSION Y(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='STWS'
      ISUBN2='    '
      IERROR='NO'
C
      EWILKS=0.0
      SDWILK=0.0
C
      IF(IBUGA3.EQ.'ON')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,51)
   51   FORMAT('***** AT THE BEGINNING OF STWS--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,52)IBUGA3,N,IUPPER
   52   FORMAT('IBUGA3,N,IUPPER = ',A4,2X,2I8)
        CALL DPWRST('XXX','BUG ')
        DO55I=1,N
         WRITE(ICOUT,56)I,X(I)
   56    FORMAT('I,X(I) = ',I8,G15.7)
         CALL DPWRST('XXX','BUG ')
   55   CONTINUE
      ENDIF
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      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 STWS--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,112)
  112   FORMAT('      THE NUMBER OF OBSERVATIONS IN THE RESPONSE ',
     1         'VARIABLE')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,114)
  114   FORMAT('      FOR WHICH THE STANDARDIZED WILK-SHAPIRO')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,115)
  115   FORMAT('      STATISTIC 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 NUMBER OF OBSERVATIONS = ',I8,'.')
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
      IF(N.EQ.1)THEN
        YSTWS=0.0
        IF(IFEEDB.EQ.'ON')THEN
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,121)
  121     FORMAT('***** WARNING IN STWS--')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,123)
  123     FORMAT('      THE NUMBER OF OBSERVATIONS IS ONE.')
          CALL DPWRST('XXX','BUG ')
          GOTO9000
        ENDIF
      ENDIF
C
      HOLD=X(1)
      DO135I=2,N
        IF(X(I).NE.HOLD)GOTO139
  135 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,121)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,136)HOLD
  136 FORMAT('      THE RESPONSE VARIABLE HAS ALL ELEMENTS = ',G15.7)
      CALL DPWRST('XXX','BUG ')
      YSTWS=0.0
      GOTO9000
  139 CONTINUE
C
C               ********************************
C               **  STEP 2--                  **
C               **  COMPUTE THE               **
C               **  WILK-SHAPIRO STATISTIC    **
C               ********************************
C
      CALL SORT(X,N,Y)
C
      AL=LOG10(AN)
      GAMMA=.327511+.058212*AL-.009776*AL*AL
C
      SUM=0.0
      DO100I=1,N
        SUM=SUM+Y(I)
  100 CONTINUE
      YBAR=SUM/AN
C
      SUM=0.0
      DO200I=1,N
        SUM=SUM+(Y(I)-YBAR)**2
  200 CONTINUE
      BVAR=SUM/AN
      BS=0.0
      IF(BVAR.GT.0.0)BS=SQRT(BVAR)
C
      SUM=0.0
      IF(N.LE.20)ARG=N
      IF(N.GT.20)ARG=N+1
      ASUBN=SQRT((1.0+(1.0/(4.0*ARG)))/SQRT(ARG))
      ASUB1=-ASUBN
      SUM=SUM+ASUB1*Y(1)+ASUBN*Y(N)
      IF(N.GT.2)THEN
        NM1=N-1
        DO500I=2,NM1
          AI=I
          PI=(AI-GAMMA)/(AN-2.0*GAMMA+1.0)
          CALL NORPPF(PI,EI)
          COEFI =2.0*EI  /SQRT(-2.722+4.083*AN)
          SUM=SUM+COEFI*Y(I)
  500   CONTINUE
      ENDIF
      WILKSH=SUM*SUM/(AN*BS*BS)
C
C               ********************************************************
C               **  STEP 3--                                          **
C               **  COMPUTE THE EXPECTED VALUE AND STANDARD DEVIATION **
C               **  OF THE WILK-SHAPIRO STATISTIC UNDER THE NORMALITY **
C               **  ASSUMPTION                                        **
C               **  REFERENCE--JJF APPROXIMATION TO MOMENTS           **
C               **             ON PAGE 601 OF BIOMETRIKA (1965)       **
C               ********************************************************
C
      IF(N.LE.2)EWILKS=1.0
      IF(N.EQ.3)EWILKS=.9135
      IF(N.EQ.4)EWILKS=.9012
      IF(N.GE.5)EWILKS=.9026+(AN-5.0)/(44.608+13.593*SQRT(AN)+10.267*AN)
C
      IF(N.LE.2)SDWILK=1.0
      IF(N.EQ.3)SDWILK=.0755
      IF(N.EQ.4)SDWILK=.0719
      IF(N.GE.5)SDWILK=.0670+(AN-5.0)/(-42.368-5.026*SQRT(AN)-14.925*AN)
      YSTWS=(WILKSH-EWILKS)/SDWILK
C
C               *******************************
C               **  STEP 4--                 **
C               **  WRITE OUT A LINE         **
C               **  OF SUMMARY INFORMATION.  **
C               *******************************
C
      IF(IFEEDB.EQ.'ON' .AND. IWRITE.EQ.'ON')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,811)
  811   FORMAT('THE STANDARDIZED WILK-SHAPIRO STATISTIC')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,812)N,YSTWS
  812   FORMAT('OF THE ',I8,' OBSERVATIONS = ',E15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'ON')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END       OF STWS--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9015)YSTWS,IERROR
 9015   FORMAT('YSTWS,IERROR = ',G15.7,2X,A4)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      RETURN
      END
      SUBROUTINE SUBSAM(Y1,Y2,N1,N2,IWRITE,
     1                  Y3,N3,IBUGA3,ISUBRO,IERROR)
C
C     PURPOSE--EXTRACT A RANDOM SUBSAMPLE OF THE DATA IN Y1(.) BASED
C              ON THE INDICES IN Y2(.).
C              NOTE--CONTRARY TO BOOTSS, N2 NEED NOT BE THE SAME AS N1.
C
C     INPUT  ARGUMENTS--Y1     =  ORIGINAL SAMPLE
C                     --Y2     =  INDEX FOR RANDOM SUBSAMPLE
C     OUTPUT ARGUMENTS--Y3     =  RANDOM SUBSAMPLE
C
C     NOTE--IT IS PERMISSIBLE TO HAVE THE OUTPUT VECTOR Y3(.)
C           BEING IDENTICAL TO EITHER OF THE INPUT VECTORS Y1(.) OR Y2(.)
C     NOTE--IF AN ELEMENT OF THE INPUT INDEX (Y2) IS SMALLER THAN 1
C           OR LARGER THAN N1, THEN THIS WILL BE INTERPRETED AS
C           A NON-OPERATION.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--90/2
C     ORIGINAL VERSION--JANUARY  1990.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGA3
      CHARACTER*4 ISUBRO
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOPA.INC'
C
      DIMENSION Y1(*)
      DIMENSION Y2(*)
      DIMENSION Y3(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='SUBS'
      ISUBN2='AM  '
      IERROR='NO'
C
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'BSAM')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,51)
   51   FORMAT('***** AT THE BEGINNING OF SUBSAM--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,52)IBUGA3,ISUBRO,IWRITE,N1,N2
   52   FORMAT('IBUGA3,ISUBRO,IWRITE,N1,N2 = ',3(A4,2X),2I8)
        CALL DPWRST('XXX','BUG ')
        DO55I=1,N1
          WRITE(ICOUT,56)I,Y1(I)
   56     FORMAT('I,Y1(I) = ',I8,G15.7)
          CALL DPWRST('XXX','BUG ')
   55   CONTINUE
        DO65I=1,N2
          WRITE(ICOUT,66)I,Y2(I)
   66     FORMAT('I,Y2(I) = ',I8,G15.7)
          CALL DPWRST('XXX','BUG ')
   65   CONTINUE
      ENDIF
C
C               *************************************
C               **  CONSTRUCT A   RANDOM SUBSAMPLE **
C               *************************************
C
C               ********************************************
C               **  STEP 11--                             **
C               **  CHECK NUMBER OF INPUT OBSERVATIONS.   **
C               ********************************************
C
      IF(N1.LT.1)THEN
        IERROR='YES'
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,1111)
 1111   FORMAT('***** ERROR IN SUBSAMPLE--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,1112)
 1112   FORMAT('      THE NUMBER OF OBSERVATIONS FOR THE RESPONSE ',
     1         'VARIABLE')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,1115)
 1115   FORMAT('      MUST BE 1 OR LARGER.  SUCH WAS NOT THE CASE ',
     1         'HERE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,1117)N1
 1117   FORMAT('      THE INPUT NUMBER OF OBSERVATIONS = ',I8)
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
      IF(N2.LT.1)THEN
        IERROR='YES'
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,1111)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,1122)
 1122   FORMAT('      THE NUMBER OF OBSERVATIONS FOR THE INDEX ',
     1         'VARIABLE')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,1115)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,1127)N2
 1127   FORMAT('      THE NUMBER OF OBSERVATIONS = ',I8)
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
      J=0
      DO1300I=1,N2
        INDEX=INT(Y2(I)+0.1)
        IF(INDEX.LT.1.OR.INDEX.GT.N1)GOTO1300
        J=J+1
        Y3(J)=Y1(INDEX)
 1300 CONTINUE
      N3=J
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
C
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'BSAM')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END       OF SUBSAM--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9013)IERROR,N3
 9013   FORMAT('IERROR,N3 = ',A4,2X,I8)
        CALL DPWRST('XXX','BUG ')
        IF(N3.GE.1)THEN
          DO9041I=1,N3
            WRITE(ICOUT,9042)I,Y3(I)
 9042       FORMAT('I,Y3(I) = ',I8,G15.7)
            CALL DPWRST('XXX','BUG ')
 9041     CONTINUE
        ENDIF
      ENDIF
C
      RETURN
      END
      SUBROUTINE SUFIT (XBAR, SD, RB1, B2, GAMMA, DELTA, XLAM, XI)
C
C        ALGORITHM AS 99.1  APPL. STATIST. (1976) VOL.25, P.180
C
C        FINDS PARAMETERS OF JOHNSON SU CURVE WITH
C        GIVEN FIRST FOUR MOMENTS
C
      REAL XBAR, SD, RB1, B2, GAMMA, DELTA, XLAM, XI, TOL, B1,
     $  B3, W, Y, W1, WM1, Z, V, A, B, X, ZERO, ONE, TWO, THREE,
     $  FOUR, SIX, SEVEN, EIGHT, NINE, TEN, HALF, ONE5, TWO8,
CCCCC$  SIXTEN, ZABS, ZEXP, ZLOG, ZSIGN, ZSQRT
     $  SIXTEN, ZABS, ZEXP, ZLOG, ZSQRT
C
      DATA TOL /0.01/
      DATA ZERO,  ONE,  TWO,  THREE, FOUR,  SIX, SEVEN,
     $    EIGHT, NINE,  TEN, SIXTEN, HALF, ONE5,  TWO8
     $     /0.0,  1.0,  2.0,    3.0,  4.0,  6.0,   7.0,
     $      8.0,  9.0, 10.0,   16.0,  0.5,  1.5,   2.8/
C
      ZABS(X) = ABS(X)
      ZEXP(X) = EXP(X)
      ZLOG(X) = LOG(X)
CCCCC ZSIGN(X, Y) = SIGN(X, Y)
      ZSQRT(X) = SQRT(X)
C
      B1 = RB1 * RB1
      B3 = B2 - THREE
C
C        W IS FIRST ESTIMATE OF EXP(DELTA ** (-2))
C
      W = ZSQRT(TWO * B2 - TWO8 * B1 - TWO)
      W = ZSQRT(W-ONE)
      IF (ZABS(RB1) .GT. TOL) GOTO 10
C
C        SYMMETRICAL CASE - RESULTS ARE KNOWN
C
      Y = ZERO
      GOTO 20
C
C        JOHNSON ITERATION (USING Y FOR HIS M)
C
   10 W1 = W + ONE
      WM1 = W - ONE
      Z = W1 * B3
      V = W * (SIX + W * (THREE + W))
      A = EIGHT * (WM1 * (THREE + W * (SEVEN + V)) - Z)
      B = SIXTEN * (WM1 * (SIX + V) - B3)
      Y = (ZSQRT(A * A - TWO * B * (WM1 * (THREE + W *
     $  (NINE + W * (TEN + V))) - TWO * W1 * Z)) - A) / B
      Z = Y * WM1 * (FOUR * (W + TWO) * Y + THREE * W1 * W1) ** 2 /
     $  (TWO * (TWO * Y + W1) ** 3)
      V = W * W
      W = ZSQRT(ONE - TWO * (ONE5 - B2 + (B1 *
     $  (B2 - ONE5 - V * (ONE + HALF * V))) / Z))
      W = ZSQRT(W-ONE)
      IF (ZABS(B1 - Z) .GT. TOL) GOTO 10
C
C        END OF ITERATION
C
      Y = Y / W
      Y = ZLOG(ZSQRT(Y) + ZSQRT(Y + ONE))
      IF (RB1 .GT. ZERO) Y = -Y
   20 X = ZSQRT(ONE / ZLOG(W))
      DELTA = X
      GAMMA = Y * X
      Y = ZEXP(Y)
      Z = Y * Y
      X = SD / ZSQRT(HALF * (W - ONE) * (HALF * W *
     $  (Z + ONE / Z) + ONE))
      XLAM = X
      XI = (HALF * ZSQRT(W) * (Y - ONE / Y)) * X + XBAR
      RETURN
      END
      SUBROUTINE SUMDP(X,N,IWRITE,XSUM,IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE SAMPLE SUM
C              OF THE DATA IN THE INPUT VECTOR X.
C              THE SAMPLE SUM = SUM OF ALL OBSERVATIONS IN 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--XSUM   = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED SAMPLE SUM.
C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
C             SAMPLE SUM.
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--KENDALL AND STUART, THE ADVANCED THEORY OF
C                 STATISTICS, VOLUME 2, EDITION 1, 1961, PAGE 4.
C               --MOOD AND GRABLE, INTRODUCTION TO THE THEORY
C                 OF STATISTICS, EDITION 2, 1963, PAGE 146.
C               --DIXON AND MASSEY, INTRODUCTION TO STATISTICAL
C                 ANALYSIS, EDITION 2, 1957, PAGE 14.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (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   1978.
C     UPDATED         --JUNE      1979.
C     UPDATED         --JULY      1979.
C     UPDATED         --AUGUST    1981.
C     UPDATED         --MAY       1982.
C     UPDATED         --MAY       2008. ALL RESPONSE ELEMENTS NOT
C                                       EQUAL SHOULD NOT BE CONSIDERED
C                                       AN ERROR (OR EVEN A WARNING)
C     UPDATED         --NOVEMBER  2009. RENAME "SUM" TO "SUMDP".  THIS
C                                       IS SIMPLY TO AVOID COMPILATION
C                                       ISSUES WITH VERSION 11 OF THE
C                                       INTEL COMPILER ON WINDOWS
C                                       (CONFLICTS WITH INTRINSIC
C                                       SUM FUNCTION EVEN IF AN EXTERNAL
C                                       STATEMENT IS USED)
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 DX
      DOUBLE PRECISION DSUM
C
      DIMENSION X(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='SUMD'
      ISUBN2='P   '
      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 SUMDP--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,52)IBUGA3,N
   52   FORMAT('IBUGA3,N = ',A4,2X,I8)
        CALL DPWRST('XXX','BUG ')
        DO55I=1,N
          WRITE(ICOUT,56)I,X(I)
   56     FORMAT('I,X(I) = ',I8,G15.7)
          CALL DPWRST('XXX','BUG ')
   55   CONTINUE
      ENDIF
C
C               *******************
C               **  COMPUTE SUM  **
C               *******************
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      AN=N
C
      IF(N.LT.1)THEN
        IERROR='YES'
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,111)
  111   FORMAT('***** ERROR IN SUM--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,112)
  112   FORMAT('      THE NUMBER OF OBSERVATIONS FOR THE RESPONSE')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,115)
  115   FORMAT('      VARIABLE IS LESS THAN ONE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,117)N
  117   FORMAT('      THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8,'.')
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
CCCCC IF(N.EQ.1)GOTO120
CCCCC GOTO129
CC120 CONTINUE
CCCCC WRITE(ICOUT,999)
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC WRITE(ICOUT,121)
CC121 FORMAT('***** NON-FATAL DIAGNOSTIC IN SUM--',
CCCCC1'THE 2ND INPUT ARGUMENT (N) HAS THE VALUE 1')
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC XSUM=X(1)
CCCCC GOTO9000
CC129 CONTINUE
C
CCCCC HOLD=X(1)
CCCCC DO135I=2,N
CCCCC IF(X(I).NE.HOLD)GOTO139
CC135 CONTINUE
CCCCC WRITE(ICOUT,999)
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC WRITE(ICOUT,136)HOLD
CC136 FORMAT('***** NON-FATAL DIAGNOSTIC IN SUM--',
CCCCC1'THE FIRST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7)
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC XSUM=AN*HOLD
CCCCC GOTO9000
CC139 CONTINUE
C
C               ************************
C               **  STEP 2--          **
C               **  COMPUTE THE SUM.  **
C               ************************
C
      DSUM=0.0D0
      DO200I=1,N
      DX=X(I)
      DSUM=DSUM+DX
  200 CONTINUE
      XSUM=DSUM
C
C               *******************************
C               **  STEP 3--                 **
C               **  WRITE OUT A LINE         **
C               **  OF SUMMARY INFORMATION.  **
C               *******************************
C
      IF(IFEEDB.EQ.'ON' .AND. IWRITE.EQ.'ON')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,811)N,XSUM
  811   FORMAT('THE SUM OF THE ',I8,' OBSERVATIONS = ',E15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'ON')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END       OF SUMDP--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9012)IERROR,XSUM
 9012   FORMAT('IERROR,XSUM = ',A4,2X,G15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      RETURN
      END
      SUBROUTINE SUMRAW(Y,N,IDIST,IFLAG,
     1XMEAN,XVAR,XSD,XMIN,XMAX,
     1ISUBRO,IBUGA3,IERROR)
C
C     PURPOSE--THIS ROUTINE COMPUTES SEVERAL SUMMARY STATISTICS
C              FOR RAW DATA.  IN PARTICULAR, THIS IS CALLED BY
C              MOST OF THE DISTRIBUTIONAL FITTING ROUTINES.
C              CURRENTLY, IT COMPUTES:
C
C                  MEAN
C                  VARIANCE
C                  STANDARD DEVIATION
C                  MINIMUM
C                  MAXIMUM
C
C               IN ADDITION, IF IFLAG = 1, IT WILL CHECK FOR
C               NEGATIVE NUMBERS OR IF IFLAG = 2 IT WILL CHECK FOR
C               NON-POSITIVE NUMBERS.
C
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2009/3
C     ORIGINAL VERSION--MARCH     2009.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*40 IDIST
C
      CHARACTER*4 ISUBRO
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 IWRITE
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 ISTEPN
C
      DIMENSION Y(*)
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='SUMR'
      ISUBN2='AW  '
      IERROR='NO'
      IWRITE='OFF'
C
      XMEAN=CPUMIN
      XSD=CPUMIN
      XVAR=CPUMIN
      XMIN=CPUMIN
      XMAX=CPUMIN
C
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'MRAW')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,51)
   51   FORMAT('**** AT THE BEGINNING OF SUMRAW--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,55)N
   55   FORMAT('N = ',I8)
        CALL DPWRST('XXX','WRIT')
        DO56I=1,MIN(N,100)
          WRITE(ICOUT,57)I,Y(I)
   57     FORMAT('I,Y(I) = ',I8,G15.7)
          CALL DPWRST('XXX','WRIT')
   56   CONTINUE
      ENDIF
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      ISTEPN='1'
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'MLNB')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(N.LE.2)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,1111)IDIST
 1111   FORMAT('***** ERROR IN ',A60)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,1113)
 1113   FORMAT('      THE NUMBER OF OBSERVATIONS FOR THE RESPONSE ',
     1         'VARIABLE IS LESS THAN 3.')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,1115)N
 1115   FORMAT('SAMPLE SIZE = ',I8)
        CALL DPWRST('XXX','WRIT')
        IERROR='YES'
        GOTO9000
      ENDIF
C
C               ******************************************
C               **  STEP 2--                            **
C               **  COMPUTE THE SUMMARY STATISTICS      **
C               ******************************************
C
      ISTEPN='2'
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'MRAW')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IERROR='NO'
      IWRITE='OFF'
C
      CALL MEAN(Y,N,IWRITE,XMEAN,IBUGA3,IERROR)
      CALL SD(Y,N,IWRITE,XSD,IBUGA3,IERROR)
      CALL MINIM(Y,N,IWRITE,XMIN,IBUGA3,IERROR)
      CALL MAXIM(Y,N,IWRITE,XMAX,IBUGA3,IERROR)
      XVAR=XSD**2
C
C               ******************************************
C               **  STEP 3--                            **
C               **  CHECK FOR NEGATIVE VALUES           **
C               ******************************************
C
      IF(IFLAG.EQ.1 .AND. XMIN.LT.0.0)THEN
        DO3100I=1,N
          IF(Y(I).LT.0.0)THEN
            WRITE(ICOUT,1111)IDIST
            CALL DPWRST('XXX','WRIT')
            WRITE(ICOUT,3113)I,Y(I)
 3113       FORMAT('      ROW ',I8,' IS NEGATIVE.  THE VALUE IS ',
     1             G15.7)
            CALL DPWRST('XXX','WRIT')
            IERROR='YES'
            GOTO9000
          ENDIF
 3100   CONTINUE
      ENDIF
C
      IF(IFLAG.EQ.2 .AND. XMIN.LE.0.0)THEN
        DO3200I=1,N
          IF(Y(I).LE.0.0)THEN
            WRITE(ICOUT,1111)IDIST
            CALL DPWRST('XXX','WRIT')
            WRITE(ICOUT,3213)I,Y(I)
 3213       FORMAT('      ROW ',I8,' IS NON-POSITIVE.  THE VALUE IS ',
     1             G15.7)
            CALL DPWRST('XXX','WRIT')
            IERROR='YES'
            GOTO9000
          ENDIF
 3200   CONTINUE
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE SUMGRP(Y,X,N,IDIST,IFLAG1,IFLAG2,
     1                  TEMP1,TEMP2,TEMP3,MAXNXT,
     1                  XMEAN,XVAR,XSD,XMIN,XMAX,NTOT,
     1                  ISUBRO,IBUGA3,IERROR)
C
C     PURPOSE--THIS ROUTINE COMPUTES SEVERAL SUMMARY STATISTICS
C              FOR GROUPED DATA.  IN PARTICULAR, THIS IS CALLED BY
C              MOST OF THE DISTRIBUTIONAL FITTING ROUTINES.
C              CURRENTLY, IT COMPUTES:
C
C                  MEAN
C                  VARIANCE
C                  STANDARD DEVIATION
C                  MINIMUM
C                  MAXIMUM
C
C               ALSO DO THE FOLLOWING:
C
C               1) SORT BY THE FREQUENCY VARIABLE
C               2) CHECK FOR NEGATIVE FREQUENCIES
C               3) CHECK FOR NEGATIVE CLASS VALUES
C                  (ONLY IF IFLAG1 = 1)
C               4) COPY X AND Y TO TEMP3 ARRAY (FOR
C                  OPTIMIZATION ROUTINE)
C                  (ONLY IF IFLAG2 = 1)
C
C     WRITTEN BY--ALAN HECKERT
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2899
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2009/3
C     ORIGINAL VERSION--MARCH     2009.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*40 IDIST
C
      CHARACTER*4 ISUBRO
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 IWRITE
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 ISTEPN
C
      DIMENSION Y(*)
      DIMENSION X(*)
      DIMENSION TEMP1(*)
      DIMENSION TEMP2(*)
      DIMENSION TEMP3(*)
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='SUMG'
      ISUBN2='RP  '
C
      IERROR='NO'
      IWRITE='OFF'
      XMEAN=CPUMIN
      XSD=CPUMIN
      XVAR=CPUMIN
      XMIN=CPUMIN
      XMAX=CPUMIN
C
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'MGRP')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,51)
   51   FORMAT('**** AT THE BEGINNING OF SUMGRP--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,55)N,MAXNXT
   55   FORMAT('N,MAXNXT = ',2I8)
        CALL DPWRST('XXX','WRIT')
        DO56I=1,N
          WRITE(ICOUT,57)I,X(I),Y(I)
   57     FORMAT('I,X(I),Y(I) = ',I8,2G15.7)
          CALL DPWRST('XXX','WRIT')
   56   CONTINUE
      ENDIF
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      ISTEPN='1'
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'MLNB')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(N.LE.0)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,1111)IDIST
 1111   FORMAT('***** ERROR IN ',A40)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,1113)
 1113   FORMAT('      THE NUMBER OF FREQUENCY CLASSES IS LESS ',
     1         'THAN 1.')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,1115)N
 1115   FORMAT('NUMBER OF FREQUENCY CLASSES = ',I8)
        CALL DPWRST('XXX','WRIT')
        IERROR='YES'
        GOTO9000
      ENDIF
C
      CALL SORTC(X,Y,N,TEMP1,TEMP2)
      ATOT=0.0
      DO1210I=1,N
        X(I)=TEMP1(I)
        Y(I)=TEMP2(I)
        ATOT=ATOT + Y(I)
 1210 CONTINUE
      NTOT=INT(ATOT+0.1)
C
      DO1220I=1,N
        IF(Y(I).LT.0.0)THEN
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,1111)IDIST
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,1223)
 1223     FORMAT('      A NEGATIVE FREQUENCY WAS SPECIFIED.')
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,1225)I,Y(I)
 1225     FORMAT('      ROW ',I8,' (AFTER SORTING) HAS FREQUENCY ',
     1           G15.7)
          CALL DPWRST('XXX','WRIT')
          IERROR='YES'
          GOTO9000
        ENDIF
 1220 CONTINUE
C
      IF(IFLAG1.EQ.1 .AND. X(1).LT.0.0)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,1111)IDIST
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,1233)
 1233   FORMAT('      THE VALUE FOR THE FIRST CLASS IS NEGATIVE.')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,1235)I,X(I)
 1235   FORMAT('      ROW ',I8,' (AFTER SORTING) HAS CLASS VALUE ',
     1         G15.7)
        CALL DPWRST('XXX','WRIT')
        IERROR='YES'
        GOTO9000
      ENDIF
C
C               ******************************************
C               **  STEP 2--                            **
C               **  COMPUTE THE SUMMARY STATISTICS      **
C               ******************************************
C
      ISTEPN='2'
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'MGRP')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IERROR='NO'
      IWRITE='OFF'
C
      XMIN=X(1)
      XMAX=X(N)
      CALL WEMEAN(X,Y,N,IWRITE,XMEAN,IBUGA3,IERROR)
      CALL WESD(X,Y,N,IWRITE,XSD,IBUGA3,IERROR)
      XVAR=XSD**2
C
      IF(IFLAG2.EQ.1)THEN
        IINDX=MAXNXT/2
        IF(N.LE.IINDX)THEN
          DO2210I=1,N
            TEMP3(I)=Y(I)
            TEMP3(IINDX+I)=X(I)
 2210     CONTINUE
        ENDIF
      ENDIF
C
 9000 CONTINUE
C
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'MGRP')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9051)
 9051   FORMAT('**** AT THE END OF SUMGRP--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9055)NTOT,XMEAN,XSD,XMIN,XMAX
 9055   FORMAT('NTOT,XMEAN,XSD,XMIN,XMAX = ',I8,4G15.7)
        CALL DPWRST('XXX','WRIT')
      ENDIF
C
      RETURN
      END
      SUBROUTINE SUMGR2(Y,XLOW,XHIGH,N,IDIST,IFLAG1,IFLAG2,
     1                  TEMP1,TEMP2,TEMP3,MAXNXT,
     1                  XMEAN,XVAR,XSD,XMIN,XMAX,NTOT,
     1                  ISUBRO,IBUGA3,IERROR)
C
C     PURPOSE--THIS ROUTINE COMPUTES SEVERAL SUMMARY STATISTICS
C              FOR GROUPED DATA WHERE THE BINS ARE NOT NECESSARILY
C              EQUI-SPACED.  IN PARTICULAR, THIS IS CALLED BY
C              MOST OF THE DISTRIBUTIONAL FITTING ROUTINES.
C              CURRENTLY, IT COMPUTES:
C
C                  MEAN
C                  VARIANCE
C                  STANDARD DEVIATION
C                  MINIMUM
C                  MAXIMUM
C
C               ALSO DO THE FOLLOWING:
C
C               1) SORT BY THE FREQUENCY VARIABLE
C               2) CHECK FOR NEGATIVE FREQUENCIES
C               3) CHECK FOR NEGATIVE CLASS VALUES
C                  (ONLY IF IFLAG1 = 1)
C
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2009/11
C     ORIGINAL VERSION--NOVEMBER  2009.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*40 IDIST
C
      CHARACTER*4 ISUBRO
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 IWRITE
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 ISTEPN
C
      DIMENSION Y(*)
      DIMENSION XLOW(*)
      DIMENSION XHIGH(*)
      DIMENSION TEMP1(*)
      DIMENSION TEMP2(*)
      DIMENSION TEMP3(*)
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='SUMG'
      ISUBN2='R2  '
      IERROR='NO'
      IWRITE='OFF'
C
      XMEAN=CPUMIN
      XSD=CPUMIN
      XVAR=CPUMIN
      XMIN=CPUMIN
      XMAX=CPUMIN
C
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'MGRP')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,51)
   51   FORMAT('**** AT THE BEGINNING OF SUMGR2--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,55)N,MAXNXT,IFLAG1,IFLAG2
   55   FORMAT('N,MAXNXT,IFLAG1,IFLAG2 = ',2I8,2I5)
        CALL DPWRST('XXX','WRIT')
        DO56I=1,N
          WRITE(ICOUT,57)I,XLOW(I),XHIGH(I),Y(I)
   57     FORMAT('I,XLOW(I),XHIGH(I),Y(I) = ',I8,3G15.7)
          CALL DPWRST('XXX','WRIT')
   56   CONTINUE
      ENDIF
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      ISTEPN='1A'
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'MLNB')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
C     1A: CHECK THAT NUMBER OF FREQUENCY CLASSES IS POSITIVE
C
      IF(N.LE.0)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,1111)IDIST
 1111   FORMAT('***** ERROR IN ',A40)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,1113)
 1113   FORMAT('      THE NUMBER OF FREQUENCY CLASSES IS LESS ',
     1         'THAN 1.')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,1115)N
 1115   FORMAT('NUMBER OF FREQUENCY CLASSES = ',I8)
        CALL DPWRST('XXX','WRIT')
        IERROR='YES'
        GOTO9000
      ENDIF
C
      ISTEPN='1B'
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'MLNB')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
C     1B: SORT THE DATA BY XLOW
C
      CALL SORTC(XLOW,Y,N,TEMP1,TEMP2)
      CALL SORTC(XLOW,XHIGH,N,TEMP1,TEMP3)
      NTOT=0
      DO1210I=1,N
        XLOW(I)=TEMP1(I)
        XHIGH(I)=TEMP3(I)
        Y(I)=TEMP2(I)
        ITEMP1=INT(Y(I)+0.5)
        Y(I)=REAL(ITEMP1)
        NTOT=NTOT + ITEMP1
 1210 CONTINUE
C
      ISTEPN='1C'
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'MLNB')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
C     1C: CHECK FOR NEGATIVE FREQUENCIES, UPPER CLASS VALUE
C         GREATER THAN LOWER CLASS VALUE
C
      DO1220I=1,N
        IF(Y(I).LT.0.0)THEN
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,1111)IDIST
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,1221)
 1221     FORMAT('      A NEGATIVE FREQUENCY WAS SPECIFIED.')
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,1223)I,Y(I)
 1223     FORMAT('      ROW ',I8,' (AFTER SORTING) HAS FREQUENCY ',
     1           G15.7)
          CALL DPWRST('XXX','WRIT')
          IERROR='YES'
          GOTO9000
        ELSEIF(XLOW(I).GE.XHIGH(I))THEN
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,1111)IDIST
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,1226)
 1226     FORMAT('      A LOWER CLASS LIMIT IS GREATER THAN OR EQUAL')
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,1227)
 1227     FORMAT('      TO THE CORRESPONDING UPPER CLASS LIMIT.')
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,1228)I,XLOW(I),XHIGH(I)
 1228     FORMAT('      ROW ',I8,' (AFTER SORTING) HAS LOWER CLASS ',
     1           ',LIMIT ',G15.7)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,1229)XHIGH(I)
 1229     FORMAT('      UPPER CLASS LIMIT ',G15.7)
          CALL DPWRST('XXX','WRIT')
          IERROR='YES'
          GOTO9000
        ENDIF
 1220 CONTINUE
C
      ISTEPN='1D'
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'MLNB')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
C     1D: CHECK FOR NEGATIVE FREQUENCY CLASS LIMITS
C
C         IFLAG1 = 1  => FREQUENCY CLASSES MUST BE POSITIVE
C
      IF(IFLAG1.EQ.1 .AND. XLOW(1).LT.0.0)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,1111)IDIST
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,1233)
 1233   FORMAT('      THE LOWEST CLASS VALUE IS NEGATIVE.')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,1235)I,XLOW(I)
 1235   FORMAT('      ROW ',I8,' (AFTER SORTING) HAS CLASS VALUE ',
     1         G15.7)
        CALL DPWRST('XXX','WRIT')
        IERROR='YES'
        GOTO9000
      ENDIF
C
C               ******************************************
C               **  STEP 2--                            **
C               **  COMPUTE THE SUMMARY STATISTICS      **
C               ******************************************
C
      ISTEPN='2'
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'MGRP')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IERROR='NO'
      IWRITE='OFF'
C
      XMIN=XLOW(1)
      XMAX=XHIGH(N)
C
      DSUM1=0.0D0
      DO2330I=1,N
        TAU=(XLOW(I) + XHIGH(I))/2.0
        DSUM1=DSUM1 + DBLE(Y(I)*TAU)
 2330 CONTINUE
      XMEAN=REAL(DSUM1/DBLE(NTOT))
C
      DSUM1=0.0D0
      DO2350I=1,N
        TAU=(XHIGH(I) + XLOW(I))/2.0
        DTERM1=DBLE(TAU - XMEAN)
        DSUM1= DSUM1 + DBLE(Y(I))*(DTERM1**2)
2350  CONTINUE
      XVAR=REAL(DSUM1/DBLE(NTOT))
      XSD=SQRT(XVAR)
C
 9000 CONTINUE
C
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'MGR2')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9051)
 9051   FORMAT('**** AT THE END OF SUMGR2--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9055)NTOT,XMEAN,XSD,XMIN,XMAX
 9055   FORMAT('NTOT,XMEAN,XSD,XMIN,XMAX = ',I8,4G15.7)
        CALL DPWRST('XXX','WRIT')
      ENDIF
C
      RETURN
      END
      REAL FUNCTION SUNIF(IR)
CCCCC DATAPLOT NOTE (5/2002): CURRENTLY, ONLY USE THE UNIFORM
CCCCC RANDOM NUMBER GENERATOR FROM THIS PACKAGE (ACTIVATE BY:
CCCCC SET RANDOM NUMBER GENERATOR MULTIPLICATIVE CONGRUENTIAL
C
C     ALGORITHM 599, COLLECTED ALGORITHMS FROM ACM.
C     ALGORITHM APPEARED IN ACM-TRANS. MATH. SOFTWARE, VOL.9, NO. 2,
C     JUN., 1983, P. 255-257.
C**********************************************************************CSUN   10
C**********************************************************************CSUN   20
C**********************************************************************CSUN   30
C                                                                      CSUN   40
C                                                                      CSUN   50
C                                                                      CSUN   60
C     F O R T R A N  SOFTWARE PACKAGE FOR RANDOM NUMBER GENERATION     CSUN   70
C                                                                      CSUN   80
C                                                                      CSUN   90
C                                                                      CSUN  100
C**********************************************************************CSUN  110
C**********************************************************************CSUN  120
C**********************************************************************CSUN  130
C                                                                       SUN  140
C                                                                       SUN  150
C                                                                       SUN  160
C     CONTENTS:                                                         SUN  170
C                                                                       SUN  180
C     1) SUNIF  -  0,1 -UNIFORM DISTRIBUTION                            SUN  190
C                                                                       SUN  200
C     2) SEXPO  - (STANDARD-) EXPONENTIAL DISTRIBUTION                  SUN  210
C                                                                       SUN  220
C     3) SNORM  - (STANDARD-) NORMAL DISTRIBUTION                       SUN  230
C                                                                       SUN  240
C     4) SGAMMA - (STANDARD-) GAMMA DISTRIBUTION                        SUN  250
C                                                                       SUN  260
C     5) KPOISS - POISSON DISTRIBUTION                                  SUN  270
C                                                                       SUN  280
C                                                                       SUN  290
C     THIS PACKAGE CONSTITUTES A FORTRAN-77 DOCUMENTATION OF A SET OF   SUN  300
C     ASSEMBLER FUNCTIONS FOR SAMPLING FROM THE ABOVE DISTRIBUTIONS.    SUN  310
C     ALL ROUTINES MAKE AMPLE USE OF BINARY REPRESENTATIONS OF NUMBERS, SUN  320
C     THEY ARE AMONG THE MOST ACCURATE AND FAST SAMPLING FUNCTIONS      SUN  330
C     KNOWN. THE FORTRAN PROGRAMS BELOW YIELD THE SAME RANDOM NUMBER    SUN  340
C     SEQUENCES AS THE ONES FROM OUR ASSEMBLER PACKAGE, BUT THEY ARE    SUN  350
C     OF COURSE MUCH SLOWER (BY FACTORS 5-8 ON OUR SIEMENS 7760         SUN  360
C     COMPUTER.)                                                        SUN  370
C     THE SET OF ROUTINES WILL ALSO BE ACCEPTABLE TO FORTRAN IV         SUN  380
C     COMPILERS WHICH ALLOW DATA STATEMENTS FOR ARRAYS WITHOUT          SUN  390
C     IMPLICIT DO-LOOPS.                                                SUN  400
C                                                                       SUN  410
C                                                                       SUN  420
C     REMARKS:                                                          SUN  430
C                                                                       SUN  440
C     -  NO CARE IS TAKEN TO ENSURE THAT THE PARAMETER VALUES LIE       SUN  450
C        IN THE ALLOWED RANGE (E.G. A/MU > 0.0 FOR SGAMMA/KPOISS).      SUN  460
C                                                                       SUN  470
C     -  THE PARAMETER 'IR' MUST BE SET TO SOME  4*K+1 > 0  BEFORE      SUN  480
C        THE FIRST CALL OF ANY OF THE GENERATORS. THEREAFTER IR         SUN  490
C        MUST NOT BE ALTERED UNTIL A NEW INITIALIZATION IS DESIRED.     SUN  500
C                                                                       SUN  510
C     -  THE PACKAGE PROVIDES RANDOM DEVIATES OF 6-7 DIGITS ACCURACY.   SUN  520
C        ON MORE ACCURATE COMPUTERS THE CONSTANTS IN SEXPO, SNORM,      SUN  530
C        SGAMMA AND KPOISS OUGHT TO BE ADJUSTED ACCORDING TO LOCAL      SUN  540
C        COMMENTS OR WITH THE AID OF THE TABLES IN THE LITERATURE       SUN  550
C        QUOTED AT THE BEGINNING OF EACH FUNCTION.                      SUN  560
C                                                                       SUN  570
C                                                                       SUN  580
C**********************************************************************CSUN  590
C**********************************************************************CSUN  600
C                                                                      CSUN  610
C                                                                      CSUN  620
C       0 , 1   - U N I F O R M  DISTRIBUTION                          CSUN  630
C                                                                      CSUN  640
C                                                                      CSUN  650
C**********************************************************************CSUN  660
C**********************************************************************CSUN  670
C                                                                      CSUN  680
C     FOR DETAILS SEE:                                                 CSUN  690
C                                                                      CSUN  700
C               AHRENS, J.H., DIETER, U. AND GRUBE, A.                 CSUN  710
C               PSEUDO-RANDOM NUMBERS:  A NEW PROPOSAL                 CSUN  720
C                     FOR THE CHOICE OF MULTIPLICATORS                 CSUN  730
C               COMPUTING, 6 (1970), 121 - 138                         CSUN  740
C                                                                      CSUN  750
C**********************************************************************CSUN  760
C                                                                       SUN  770
      DOUBLE PRECISION R,FACTOR,TWO28
      SAVE R
C
C     FACTOR - INTEGER OF THE FORM 8*K+5 AS CLOSE AS POSSIBLE
C              TO  2**26 * (SQRT(5)-1)/2     (GOLDEN SECTION)
C     TWO28  = 2**28  (I.E. 28 SIGNIFICANT BITS FOR DEVIATES)
C
      DATA FACTOR /41475557.0D0/, TWO28 /268435456.0D0/
C
C     RETURNS SAMPLE U FROM THE  0,1 -UNIFORM DISTRIBUTION
C     BY A MULTIPLICATIVE CONGRUENTIAL GENERATOR OF THE FORM
C        R := R * FACTOR (MOD 1) .
C     IN THE FIRST CALL R IS INITIALIZED TO
C        R := IR / 2**28 ,
C     WHERE IR MUST BE OF THE FORM  IR = 4*K+1.
C     THEN R ASSUMES ALL VALUES  0 < (4*K+1)/2**28 < 1 DURING
C     A FULL PERIOD 2**26 OF SUNIF.
C     THE PARAMETER IR IS USED ONLY IN THE FIRST CALL FOR
C     INITIALIZATION OF SUNIF. THEREAFTER (WHEN NEGATIVE)
C     IR BECOMES A DUMMY VARIABLE.
C
      IF (IR .GE. 0) GO TO 1
C
C     STANDARD CASE:  SAMPLING
C
      R=DMOD(R*FACTOR,1.0D0)
      SUNIF=SNGL(R)
      RETURN
C
C     FIRST CALL: INITIALIZATION
C
1     R=DBLE(FLOAT(IR))/TWO28
      R=DMOD(R*FACTOR,1.0D0)
      SUNIF=SNGL(R)
      IR=-1
      RETURN
      END
      SUBROUTINE SWILK (INIT, X, N, N1, N2, A, W, PW, IFAULT)
C
C        ALGORITHM AS R94 APPL. STATIST. (1995) VOL.44, NO.4
C
C        Calculates the Shapiro-Wilk W test and its significance level
C
      INTEGER N, N1, N2, IFAULT
      REAL X(*), A(*), PW, W
      REAL C1(6), C2(6), C3(4), C4(4), C5(4), C6(3), C7(2)
      REAL C8(2), C9(2), G(2)
      REAL Z90, Z95, Z99, ZM, ZSS, BF1, XX90, XX95, ZERO, ONE, TWO
      REAL THREE, SQRTH, QTR, TH, SMALL, PI6, STQR
      REAL SUMM2, SSUMM2, FAC, RSN, AN, AN25, A1, A2, DELTA, RANGE
      REAL SA, SX, SSX, SSA, SAX, ASA, XSX, SSASSX, W1, Y, XX, XI
      REAL GAMMA, M, S, LD, BF, Z90F, Z95F, Z99F, ZFM, ZSD, ZBAR
C
C        Auxiliary routines
C
      REAL PPND, POLY
      DOUBLE PRECISION ALNORM
C
      INTEGER NCENS, NN2, I, I1, J
      LOGICAL INIT, UPPER
C
      DATA C1 /0.0E0, 0.221157E0, -0.147981E0, -0.207119E1,
     *     0.4434685E1, -0.2706056E1/
      DATA C2 /0.0E0, 0.42981E-1, -0.293762E0, -0.1752461E1,
     *     0.5682633E1, -0.3582633E1/
      DATA C3 /0.5440E0, -0.39978E0, 0.25054E-1, -0.6714E-3/
      DATA C4 /0.13822E1, -0.77857E0, 0.62767E-1, -0.20322E-2/
      DATA C5 /-0.15861E1, -0.31082E0, -0.83751E-1, 0.38915E-2/
      DATA C6 /-0.4803E0, -0.82676E-1, 0.30302E-2/
      DATA C7 /0.164E0, 0.533E0/
      DATA C8 /0.1736E0, 0.315E0/
      DATA C9 /0.256E0, -0.635E-2/
      DATA G  /-0.2273E1, 0.459E0/
      DATA Z90, Z95, Z99 /0.12816E1, 0.16449E1, 0.23263E1/
      DATA ZM, ZSS /0.17509E1, 0.56268E0/
      DATA BF1 /0.8378E0/, XX90, XX95 /0.556E0, 0.622E0/
      DATA ZERO /0.0E0/, ONE/1.0E0/, TWO/2.0E0/, THREE/3.0E0/
      DATA SQRTH /0.70711E0/, QTR/0.25E0/, TH/0.375E0/, SMALL/1E-19/
      DATA PI6 /0.1909859E1/, STQR/0.1047198E1/, UPPER/.TRUE./
C
      PW  =  ONE
      IF (W .GE. ZERO) W = ONE
      AN = N
      IFAULT = 3
      NN2 = N/2
      IF (N2 .LT. NN2) RETURN
      IFAULT = 1
      IF (N .LT. 3) RETURN
C
C        If INIT is false, calculates coefficients for the test
C
      IF (.NOT. INIT) THEN
        IF (N .EQ. 3) THEN
           A(1) = SQRTH
        ELSE
           AN25 = AN + QTR
           SUMM2 = ZERO
           DO 30 I = 1, N2
              A(I) = PPND((REAL(I) - TH)/AN25,IFAULT)
              SUMM2 = SUMM2 + A(I) ** 2
30          CONTINUE
           SUMM2 = SUMM2 * TWO
           SSUMM2 = SQRT(SUMM2)
           RSN = ONE / SQRT(AN)
           A1 = POLY(C1, 6, RSN) - A(1) / SSUMM2
C
C        Normalize coefficients
C
           IF (N .GT. 5) THEN
              I1 = 3
              A2 = -A(2)/SSUMM2 + POLY(C2,6,RSN)
              FAC = SQRT((SUMM2 - TWO * A(1) ** 2 - TWO *
     *               A(2) ** 2)/(ONE - TWO * A1 ** 2 - TWO * A2 ** 2))
              A(1) = A1
              A(2) = A2
           ELSE
              I1 = 2
              FAC = SQRT((SUMM2 - TWO * A(1) ** 2)/
     *                   (ONE - TWO * A1 ** 2))
              A(1) = A1
           END IF
           DO 40 I = I1, NN2
              A(I) = -A(I)/FAC
   40       CONTINUE
        END IF
        INIT = .TRUE.
      END IF
      IF (N1 .LT. 3) RETURN
      NCENS = N - N1
      IFAULT = 4
      IF (NCENS .LT. 0 .OR. (NCENS .GT. 0 .AND. N .LT. 20)) RETURN
      IFAULT = 5
      DELTA = FLOAT(NCENS)/AN
      IF (DELTA .GT. 0.8) RETURN
C
C        If W input as negative, calculate significance level of -W
C
      IF (W .LT. ZERO) THEN
        W1 = ONE + W
        IFAULT = 0
        GOTO 70
      END IF
C
C        Check for zero range
C
      IFAULT = 6
      RANGE = X(N1) - X(1)
      IF (RANGE .LT. SMALL) RETURN
C
C        Check for correct sort order on range - scaled X
C
      IFAULT = 7
      XX = X(1)/RANGE
      SX = XX
      SA = -A(1)
      J = N - 1
      DO 50 I = 2, N1
        XI = X(I)/RANGE
CCCCC   IF (XX-XI .GT. SMALL) PRINT *,' ANYTHING'
        SX = SX + XI
        IF (I .NE. J) SA = SA + SIGN(1, I - J) * A(MIN(I, J))
        XX = XI
        J = J - 1
50    CONTINUE
      IFAULT = 0
      IF (N .GT. 5000) IFAULT = 2
C
C        Calculate W statistic as squared correlation
C        between data and coefficients
C
      SA = SA/N1
      SX = SX/N1
      SSA = ZERO
      SSX = ZERO
      SAX = ZERO
      J = N
      DO 60 I = 1, N1
        IF (I .NE. J) THEN
           ASA = SIGN(1, I - J) * A(MIN(I, J)) - SA
        ELSE
           ASA = -SA
        END IF
        XSX = X(I)/RANGE - SX
        SSA = SSA + ASA * ASA
        SSX = SSX + XSX * XSX
        SAX = SAX + ASA * XSX
        J = J - 1
   60 CONTINUE
C
C        W1 equals (1-W) claculated to avoid excessive rounding error
C        for W very near 1 (a potential problem in very large samples)
C
      SSASSX = SQRT(SSA * SSX)
      W1 = (SSASSX - SAX) * (SSASSX + SAX)/(SSA * SSX)
   70 W = ONE - W1
C
C        Calculate significance level for W (exact for N=3)
C
      IF (N .EQ. 3) THEN
         PW = PI6 * (ASIN(SQRT(W)) - STQR)
         RETURN
      END IF
      Y = LOG(W1)
      XX = LOG(AN)
      M = ZERO
      S = ONE
      IF (N .LE. 11) THEN
        GAMMA = POLY(G, 2, AN)
        IF (Y .GE. GAMMA) THEN
           PW = SMALL
           RETURN
        END IF
        Y = -LOG(GAMMA - Y)
        M = POLY(C3, 4, AN)
        S = EXP(POLY(C4, 4, AN))
      ELSE
        M = POLY(C5, 4, XX)
        S = EXP(POLY(C6, 3, XX))
      END IF
      IF (NCENS .GT. 0) THEN
C
C        Censoring by proportion NCENS/N.  Calculate mean and sd
C        of normal equivalent deviate of W.
C
        LD = -LOG(DELTA)
        BF = ONE + XX * BF1
        Z90F = Z90 + BF * POLY(C7, 2, XX90 ** XX) ** LD
        Z95F = Z95 + BF * POLY(C8, 2, XX95 ** XX) ** LD
        Z99F = Z99 + BF * POLY(C9, 2, XX) ** LD
C
C        Regress Z90F,...,Z99F on normal deviates Z90,...,Z99 to get
C        pseudo-mean and pseudo-sd of z as the slope and intercept
C
        ZFM = (Z90F + Z95F + Z99F)/THREE
        ZSD = (Z90*(Z90F-ZFM)+Z95*(Z95F-ZFM)+Z99*(Z99F-ZFM))/ZSS
        ZBAR = ZFM - ZSD * ZM
        M = M + ZBAR * S
        S = S * ZSD
      END IF
      PW = REAL(ALNORM(DBLE((Y - M)/S), UPPER))
C
      RETURN
      END
      SUBROUTINE SYMINV(N, LOWINV, DET)
*
*     Computes lower symmetric inverse and determinant in situ
*
      INTEGER I, II, N
      DOUBLE PRECISION LOWINV(*), DET
      CALL CHOLSK(N, LOWINV)
      DET = 1
      II = 0
      DO 100 I = 1,N
         II = II + I
         DET = DET*LOWINV(II)
  100 CONTINUE
      DET = DET*DET
      CALL CHOLNV(N, LOWINV)
      CALL CHOLPI(N, LOWINV)
C
      RETURN
      END
      DOUBLE PRECISION FUNCTION SYNCH1(XVALUE)
C
C   DESCRIPTION:
C
C      This function calculates the synchrotron radiation function
C      defined as
C
C         SYNCH1(x) = x * Integral{x to inf} K(5/3)(t) dt,
C
C      where K(5/3) is a modified Bessel function of order 5/3.
C
C      The code uses Chebyshev expansions, the coefficients of which
C      are given to 20 decimal places.
C
C
C   ERROR RETURNS:
C
C      The function is undefined if x < 0.0. If XVALUE < 0.0,
C      an error message is printed and the function returns
C      the value 0.0.
C
C
C   MACHINE-DEPENDENT CONSTANTS:
C
C      NTERM1 - INTEGER - The no. of terms needed from the array
C                         ASYNC1. The recommended value is such that
C                            ABS(ASYNC1(NTERM1)) < EPS/100.
C
C      NTERM2 - INTEGER - The no. of terms needed from the array
C                         ASYNC2. The recommended value is such that
C                            ABS(ASYNC2(NTERM2)) < EPS/100.
C
C      NTERM3 - INTEGER - The no. of terms needed from the array
C                         ASYNCA. The recommended value is such that
C                            ABS(ASYNCA(NTERM3)) < EPS/100.
C
C      XLOW - DOUBLE PRECISION - The value below which
C                        SYNCH1(x) = 2.14952.. * (x**(1/3))
C                    to machine precision. The recommended value
C                    is     sqrt (8*EPSNEG)
C
C      XHIGH1 - DOUBLE PRECISION - The value above which
C                          SYNCH1(x) = 0.0
C                      to machine precision. The recommended value
C                      is     -8*LN(XMIN)/7
C
C      XHIGH2 - DOUBLE PRECISION - The value of LN(XMIN). This is used
C                      to prevent underflow in calculations
C                      for large x.
C
C     For values of EPS, EPSNEG, and XMIN refer to the file MACHCON.TXT
C
C     The machine-dependent constants are computed internally by
C     using the D1MACH subroutine.
C
C
C   INTRINSIC FUNCTIONS USED:
C
C      EXP , LOG , SQRT
C
C
C   OTHER MISCFUN SUBROUTINES USED:
C
C          CHEVAL , ERRPRN, D1MACH
C
C
C   AUTHOR:
C          Dr. Allan J. MacLeod,
C          Dept. of Mathematics and Statistics,
C          University of Paisley,
C          Paisley,
C          SCOTLAND
C          PA1 2BE
C
C          ( e-mail:  macl_ms0@paisley.ac.uk )
C
C
C   LATEST UPDATE:
C                  23 January, 1996
C
C
      INTEGER NTERM1,NTERM2,NTERM3
      DOUBLE PRECISION ASYNC1(0:13),ASYNC2(0:11),ASYNCA(0:24),
     1     CHEB1,CHEB2,CHEVAL,CONLOW,EIGHT,FOUR,HALF,
     2     LNRTP2,ONE,ONEHUN,PIBRT3,T,THREE,TWELVE,X,XHIGH1,
     3     XHIGH2,XLOW,XPOWTH,XVALUE,ZERO
CCCCC CHARACTER FNNAME*6,ERRMSG*14
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOMC.INC'
      INCLUDE 'DPCOP2.INC'
C
CCCCC DATA FNNAME/'SYNCH1'/
CCCCC DATA ERRMSG/'ARGUMENT < 0.0'/
      DATA ZERO,HALF,ONE/ 0.0 D 0 , 0.5 D 0 , 1.0 D 0 /
      DATA THREE,FOUR/ 3.0 D 0 , 4.0 D 0 /
      DATA EIGHT,TWELVE/ 8.0 D 0 , 12.0 D 0 /
      DATA ONEHUN/ 100.0 D 0 /
      DATA CONLOW/2.14952 82415 34478 63671 D 0/
      DATA PIBRT3/1.81379 93642 34217 85059 D 0/
      DATA LNRTP2/0.22579 13526 44727 43236 D 0/
      DATA ASYNC1/30.36468 29825 01076 27340  D    0,
     1            17.07939 52774 08394 57449  D    0,
     2             4.56013 21335 45072 88887  D    0,
     3             0.54928 12467 30419 97963  D    0,
     4             0.37297 60750 69301 1724   D   -1,
     5             0.16136 24302 01041 242    D   -2,
     6             0.48191 67721 20370 7      D   -4,
     7             0.10512 42528 89384        D   -5,
     8             0.17463 85046 697          D   -7,
     9             0.22815 48654 4            D   -9,
     X             0.24044 3082               D  -11,
     1             0.20865 88                 D  -13,
     2             0.15167                    D  -15,
     3             0.94                       D  -18/
      DATA ASYNC2/0.44907 21623 53266 08443  D    0,
     1            0.89835 36779 94187 2179   D   -1,
     2            0.81044 57377 21512 894    D   -2,
     3            0.42617 16991 08916 19     D   -3,
     4            0.14760 96312 70746 0      D   -4,
     5            0.36286 33615 3998         D   -6,
     6            0.66634 80749 84           D   -8,
     7            0.94907 71655              D  -10,
     8            0.10791 2491               D  -11,
     9            0.10022 01                 D  -13,
     X            0.7745                     D  -16,
     1            0.51                       D  -18/
      DATA ASYNCA(0)/ 2.13293 05161 35500 09848  D    0/
      DATA ASYNCA(1)/ 0.74135 28649 54200 2401   D   -1/
      DATA ASYNCA(2)/ 0.86968 09990 99641 978    D   -2/
      DATA ASYNCA(3)/ 0.11703 82624 87756 921    D   -2/
      DATA ASYNCA(4)/ 0.16451 05798 61919 15     D   -3/
      DATA ASYNCA(5)/ 0.24020 10214 20640 3      D   -4/
      DATA ASYNCA(6)/ 0.35827 75638 93885        D   -5/
      DATA ASYNCA(7)/ 0.54477 47626 9837         D   -6/
      DATA ASYNCA(8)/ 0.83880 28561 957          D   -7/
      DATA ASYNCA(9)/ 0.13069 88268 416          D   -7/
      DATA ASYNCA(10)/0.20530 99071 44           D   -8/
      DATA ASYNCA(11)/0.32518 75368 8            D   -9/
      DATA ASYNCA(12)/0.51791 40412              D  -10/
      DATA ASYNCA(13)/0.83002 9881               D  -11/
      DATA ASYNCA(14)/0.13352 7277               D  -11/
      DATA ASYNCA(15)/0.21591 498                D  -12/
      DATA ASYNCA(16)/0.34996 73                 D  -13/
      DATA ASYNCA(17)/0.56994 2                  D  -14/
      DATA ASYNCA(18)/0.92906                    D  -15/
      DATA ASYNCA(19)/0.15222                    D  -15/
      DATA ASYNCA(20)/0.2491                     D  -16/
      DATA ASYNCA(21)/0.411                      D  -17/
      DATA ASYNCA(22)/0.67                       D  -18/
      DATA ASYNCA(23)/0.11                       D  -18/
      DATA ASYNCA(24)/0.2                        D  -19/
C
      XLOW=0.0
C
C   Start calculation
C
      X = XVALUE
      IF ( X .LT. ZERO ) THEN
CCCCC    CALL ERRPRN(FNNAME,ERRMSG)
         WRITE(ICOUT,999)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,101)X
         CALL DPWRST('XXX','BUG ')
         SYNCH1 = ZERO
         RETURN
      ENDIF
  999 FORMAT(1X)
  101 FORMAT('***** ERROR FROM SYNCH1--ARGUMENT MUST BE ',
     1       'NON-NEGATIVE, ARGUMENT = ',G15.7)
C
C   Compute the machine-dependent constants.
C
      CHEB1 = D1MACH(3)
      T = CHEB1 / ONEHUN
      IF ( X .LE. FOUR ) THEN
         DO 10 NTERM1 = 13 , 0 , -1
            IF ( ABS(ASYNC1(NTERM1)) .GT. T ) GOTO 19
 10      CONTINUE
 19      DO 20 NTERM2 = 11 , 0 , -1
            IF ( ABS(ASYNC2(NTERM2)) .GT. T ) GOTO 29
 20      CONTINUE
 29      XLOW = SQRT ( EIGHT * CHEB1 )
      ELSE
         DO 40 NTERM3 = 24 , 0 , -1
            IF ( ABS(ASYNCA(NTERM3)) .GT. T ) GOTO 49
 40      CONTINUE
 49      XHIGH2 = LOG(D1MACH(1))
         XHIGH1 = -EIGHT * XHIGH2 / ( EIGHT - ONE )
      ENDIF
C
C   Code for 0 <= x <= 4
C
      IF ( X .LE. FOUR ) THEN
         XPOWTH = X ** ( ONE / THREE )
         IF ( X .LT. XLOW ) THEN
            SYNCH1 = CONLOW * XPOWTH
         ELSE
            T = ( X * X / EIGHT - HALF ) - HALF
            CHEB1 = CHEVAL(NTERM1,ASYNC1,T)
            CHEB2 = CHEVAL(NTERM2,ASYNC2,T)
            T = XPOWTH * CHEB1 - ( XPOWTH**11 ) * CHEB2
            SYNCH1 = T - PIBRT3 * X
         ENDIF
      ELSE
         IF ( X .GT. XHIGH1 ) THEN
            SYNCH1 = ZERO
         ELSE
            T = ( TWELVE - X ) / ( X + FOUR )
            CHEB1 = CHEVAL(NTERM3,ASYNCA,T)
            T = LNRTP2 - X + LOG( SQRT(X) * CHEB1 )
            IF ( T .LT. XHIGH2 ) THEN
               SYNCH1 = ZERO
            ELSE
               SYNCH1 = EXP(T)
            ENDIF
         ENDIF
      ENDIF
      RETURN
      END
      DOUBLE PRECISION FUNCTION SYNCH2(XVALUE)
C
C   DESCRIPTION:
C
C      This function calculates the synchrotron radiation function
C      defined as
C
C         SYNCH2(x) = x * K(2/3)(x)
C
C      where K(2/3) is a modified Bessel function of order 2/3.
C
C      The code uses Chebyshev expansions, the coefficients of which
C      are given to 20 decimal places.
C
C
C   ERROR RETURNS:
C
C      The function is undefined if x < 0.0. If XVALUE < 0.0,
C      an error message is printed and the function returns
C      the value 0.0.
C
C
C   MACHINE-DEPENDENT CONSTANTS:
C
C      NTERM1 - INTEGER - The no. of terms needed from the array
C                         ASYNC1. The recommended value is such that
C                            ABS(ASYN21(NTERM1)) < EPS/100.
C
C      NTERM2 - INTEGER - The no. of terms needed from the array
C                         ASYNC2. The recommended value is such that
C                            ABS(ASYN22(NTERM2)) < EPS/100.
C
C      NTERM3 - INTEGER - The no. of terms needed from the array
C                         ASYNCA. The recommended value is such that
C                            ABS(ASYN2A(NTERM3)) < EPS/100.
C
C      XLOW - DOUBLE PRECISION - The value below which
C                        SYNCH2(x) = 1.074764... * (x**(1/3))
C                    to machine precision. The recommended value
C                    is     sqrt (8*EPSNEG)
C
C      XHIGH1 - DOUBLE PRECISION - The value above which
C                          SYNCH2(x) = 0.0
C                      to machine precision. The recommended value
C                      is     -8*LN(XMIN)/7
C
C      XHIGH2 - DOUBLE PRECISION - The value of LN(XMIN). This is used
C                      to prevent underflow in calculations
C                      for large x.
C
C     For values of EPS, EPSNEG, and XMIN refer to the file MACHCON.TXT
C
C     The machine-dependent constants are computed internally by
C     using the D1MACH subroutine.
C
C
C   INTRINSIC FUNCTIONS USED:
C
C      EXP , LOG , SQRT
C
C
C   OTHER MISCFUN SUBROUTINES USED:
C
C          CHEVAL , ERRPRN, D1MACH
C
C
C   AUTHOR:
C          Dr. Allan J. MacLeod,
C          Dept. of Mathematics and Statistics,
C          University of Paisley,
C          Paisley,
C          SCOTLAND
C          PA1 2BE
C
C          (e-mail:  macl_ms0@paisley.ac.uk)
C
C
C   LATEST UPDATE:
C                  23 January, 1996
C
      INTEGER NTERM1,NTERM2,NTERM3
      DOUBLE PRECISION ASYN21(0:14),ASYN22(0:13),ASYN2A(0:18),
     1     CHEB1,CHEB2,CHEVAL,CONLOW,EIGHT,FOUR,HALF,
     2     LNRTP2,ONE,ONEHUN,T,TEN,THREE,TWO,X,XHIGH1,
     3     XHIGH2,XLOW,XPOWTH,XVALUE,ZERO
CCCCC CHARACTER FNNAME*6,ERRMSG*14
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOMC.INC'
      INCLUDE 'DPCOP2.INC'
C
CCCCC DATA FNNAME/'SYNCH2'/
CCCCC DATA ERRMSG/'ARGUMENT < 0.0'/
      DATA ZERO,HALF,ONE/ 0.0 D 0 , 0.5 D 0 , 1.0 D 0 /
      DATA TWO,THREE,FOUR/ 2.0 D 0 , 3.0 D 0 , 4.0 D 0 /
      DATA EIGHT,TEN,ONEHUN/ 8.0 D 0 , 10.0 D 0 , 100.0 D 0/
      DATA CONLOW/1.07476 41207 67239 31836 D 0/
      DATA LNRTP2/0.22579 13526 44727 43236 D 0/
      DATA ASYN21/38.61783 99238 43085 48014  D    0,
     1            23.03771 55949 63734 59697  D    0,
     2             5.38024 99868 33570 59676  D    0,
     3             0.61567 93806 99571 07760  D    0,
     4             0.40668 80046 68895 5843   D   -1,
     5             0.17296 27455 26484 141    D   -2,
     6             0.51061 25883 65769 9      D   -4,
     7             0.11045 95950 22012        D   -5,
     8             0.18235 53020 649          D   -7,
     9             0.23707 69803 4            D   -9,
     X             0.24887 2963               D  -11,
     1             0.21528 68                 D  -13,
     2             0.15607                    D  -15,
     3             0.96                       D  -18,
     4             0.1                        D  -19/
      DATA ASYN22/7.90631 48270 66080 42875  D    0,
     1            3.13534 63612 85342 56841  D    0,
     2            0.48548 79477 45371 45380  D    0,
     3            0.39481 66758 27237 2337   D   -1,
     4            0.19661 62233 48088 022    D   -2,
     5            0.65907 89322 93042 0      D   -4,
     6            0.15857 56134 98559        D   -5,
     7            0.28686 53011 233          D   -7,
     8            0.40412 02359 5            D   -9,
     9            0.45568 4443               D  -11,
     X            0.42045 90                 D  -13,
     1            0.32326                    D  -15,
     2            0.210                      D  -17,
     3            0.1                        D  -19/
      DATA ASYN2A/2.02033 70941 70713 60032  D    0,
     1            0.10956 23712 18074 0443   D   -1,
     2            0.85423 84730 11467 55     D   -3,
     3            0.72343 02421 32822 2      D   -4,
     4            0.63124 42796 26992        D   -5,
     5            0.56481 93141 1744         D   -6,
     6            0.51283 24801 375          D   -7,
     7            0.47196 53291 45           D   -8,
     8            0.43807 44214 3            D   -9,
     9            0.41026 81493              D  -10,
     X            0.38623 0721               D  -11,
     1            0.36613 228                D  -12,
     2            0.34802 32                 D  -13,
     3            0.33301 0                  D  -14,
     4            0.31856                    D  -15,
     5            0.3074                     D  -16,
     6            0.295                      D  -17,
     7            0.29                       D  -18,
     8            0.3                        D  -19/
C
      XLOW=0.0
C
C   Start calculation
C
      X = XVALUE
      IF ( X .LT. ZERO ) THEN
CCCCC    CALL ERRPRN(FNNAME,ERRMSG)
         WRITE(ICOUT,999)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,101)X
         CALL DPWRST('XXX','BUG ')
         SYNCH2 = ZERO
         RETURN
      ENDIF
  999 FORMAT(1X)
  101 FORMAT('***** ERROR FROM SYNCH2--ARGUMENT MUST BE ',
     1       'NON-NEGATIVE, ARGUMENT = ',G15.7)
C
C   Compute the machine-dependent constants.
C
      CHEB1 = D1MACH(3)
      T = CHEB1 / ONEHUN
      IF ( X .LE. FOUR ) THEN
         DO 10 NTERM1 = 14 , 0 , -1
            IF ( ABS(ASYN21(NTERM1)) .GT. T ) GOTO 19
 10      CONTINUE
 19      DO 20 NTERM2 = 13 , 0 , -1
            IF ( ABS(ASYN22(NTERM2)) .GT. T ) GOTO 29
 20      CONTINUE
 29      XLOW = SQRT ( EIGHT * CHEB1 )
      ELSE
         DO 40 NTERM3 = 18 , 0 , -1
            IF ( ABS(ASYN2A(NTERM3)) .GT. T ) GOTO 49
 40      CONTINUE
 49      XHIGH2 = LOG(D1MACH(1))
         XHIGH1 = -EIGHT * XHIGH2 / ( EIGHT - ONE )
      ENDIF
C
C   Code for 0 <= x <= 4
C
      IF ( X .LE. FOUR ) THEN
         XPOWTH = X ** ( ONE / THREE )
         IF ( X .LT. XLOW ) THEN
            SYNCH2 = CONLOW * XPOWTH
         ELSE
            T = ( X * X / EIGHT - HALF ) - HALF
            CHEB1 = CHEVAL(NTERM1,ASYN21,T)
            CHEB2 = CHEVAL(NTERM2,ASYN22,T)
            SYNCH2 = XPOWTH * CHEB1 - ( XPOWTH**5 ) * CHEB2
         ENDIF
      ELSE
         IF ( X .GT. XHIGH1 ) THEN
            SYNCH2 = ZERO
         ELSE
            T = ( TEN - X ) / ( X + TWO )
            CHEB1 = CHEVAL(NTERM3,ASYN2A,T)
            T = LNRTP2 - X + LOG( SQRT(X) * CHEB1 )
            IF ( T .LT. XHIGH2 ) THEN
               SYNCH2 = ZERO
            ELSE
               SYNCH2 = EXP(T)
            ENDIF
         ENDIF
      ENDIF
      RETURN
      END