      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 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   RAND = IX1*2048 + IX0
      RAND = RAND / 4194304.
      RETURN
C
 20   IX1 = AMOD(R,1.)*4194304. + 0.5
      IX0 = MOD (IX1, 2048)
      IX1 = (IX1-IX0)/2048
      GO TO 10
C
      END
      SUBROUTINE RANGE(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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--82.6
C     ORIGINAL VERSION--JUNE      1972.
C     UPDATED         --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
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
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='RANG'
      ISUBN2='E   '
C
      IERROR='NO'
C
      XMIN=0.0
      XMAX=0.0
C
      IF(IBUGA3.EQ.'OFF')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF RANGE--')
      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 RANGE  **
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 RANGE--')
      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 RANGE IS TO BE COMPUTED')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,115)
  115 FORMAT('      MUST BE 1 OR LARGER.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,116)
  116 FORMAT('      SUCH WAS NOT THE CASE HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,117)N
  117 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8,
     1'.')
      CALL DPWRST('XXX','BUG ')
      GOTO9000
  119 CONTINUE
C
      IF(N.EQ.1)GOTO120
      GOTO129
  120 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,121)
  121 FORMAT('***** NON-FATAL DIAGNOSTIC IN RANGE--',
     1'THE 2ND INPUT ARGUMENT (N) HAS THE VALUE 1')
      CALL DPWRST('XXX','BUG ')
      XRANGE=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 RANGE--',
     1'THE FIRST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      XRANGE=0.0
      GOTO9000
  139 CONTINUE
C
  190 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
      IF(IFEEDB.EQ.'OFF')GOTO890
      IF(IWRITE.EQ.'OFF')GOTO890
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,811)N,XRANGE
  811 FORMAT('THE RANGE OF THE ',I8,' OBSERVATIONS = ',E15.7)
      CALL DPWRST('XXX','BUG ')
  890 CONTINUE
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'OFF')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF RANGE--')
      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)XMIN,XMAX
 9014 FORMAT('XMIN,XMAX = ',2E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9015)XRANGE
 9015 FORMAT('XRANGE = ',E15.7)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE RANK(X,N,IWRITE,XR,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                 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (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
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
      INCLUDE 'DPCOPA.INC'
C
      DIMENSION X(*)
      DIMENSION XR(*)
      DIMENSION XS(MAXOBV)
CCCCC FOLLOWING LINES ADDED JUNE, 1990
      INCLUDE 'DPCOZ2.INC'
      EQUIVALENCE (G2RBAG(IGAR45),XS(1))
CCCCC END CHANGE
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='RANK'
      ISUBN2='    '
C
      IERROR='NO'
      IUPPER=MAXOBV
C
      K=0
C
      RPREV=0.0
C
      IF(IBUGA3.EQ.'OFF')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF RANK--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)IBUGA3
   52 FORMAT('IBUGA3 = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)N,IUPPER
   53 FORMAT('N,IUPPER = ',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
   90 CONTINUE
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(1.LE.N.AND.N.LE.IUPPER)GOTO119
      IERROR='YES'
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,111)IUPPER
  111 FORMAT('***** ERROR IN RANK--',
     1'THE 2ND INPUT ARGUMENT (N) IS SMALLER THAN 1',
     1'OR LARGER THAN ',I8)
      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
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,121)
  121 FORMAT('***** NON-FATAL DIAGNOSTIC IN RANK--',
     1'THE 2ND INPUT ARGUMENT (N) HAS THE VALUE 1')
      CALL DPWRST('XXX','BUG ')
      XR(1)=1.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 RANK--',
     1'THE FIRST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      AVRANK=(AN+1.0)/2.0
      DO137I=1,N
      XR(I)=AVRANK
  137 CONTINUE
      GOTO9000
  139 CONTINUE
C
  190 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)GOTO770
      IF(I.EQ.1)GOTO790
      IF(X(I).EQ.XPREV)GOTO750
      GOTO790
  750 CONTINUE
      XPREV=X(I)
      XR(I)=RPREV
      GOTO880
  770 CONTINUE
      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,781)IBRAN
  781 FORMAT('***** INTERNAL ERROR IN RANK--',
     1'IMPOSSIBLE BRANCH CONDITION AT BRANCH POINT = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,782)JMIN
  782 FORMAT('JMIN = ',I8)
      CALL DPWRST('XXX','BUG ')
      GOTO9000
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,881)IBRAN
  881 FORMAT('***** INTERNAL ERROR IN RANK--',
     1'IMPOSSIBLE BRANCH CONDITION AT BRANCH POINT = ',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)
CCCCC RKXMIN=XR(1)
CCCCC RKXMAX=XR(1)
CCCCC DO910I=1,N
CCCCC IF(XR(I).LT.RKXMIN)RKXMIN=XR(I)
CCCCC IF(XR(I).GT.RKXMAX)RKXMAX=XR(I)
CC910 CONTINUE
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.'OFF')GOTO9090
      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
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE RANK2(X,N,IWRITE,XR,IBUGA3,IERROR)
C
C     NOTE--THIS SUBROUTINE IS IDENTICAL TO SUBROUTINE RANK(.)
C           AND HAS BEEN DUPLICATED ONLY FOR MAPPING/STORAGE ECONOMY.
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                 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (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
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
      INCLUDE 'DPCOPA.INC'
C
      DIMENSION X(*)
      DIMENSION XR(*)
      DIMENSION XS(MAXOBV)
CCCCC FOLLOWING LINES ADDED JUNE, 1990
      INCLUDE 'DPCOZ2.INC'
      EQUIVALENCE (G2RBAG(IGAR45),XS(1))
CCCCC END CHANGE
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='RANK'
      ISUBN2='2   '
C
      IERROR='NO'
      IUPPER=MAXOBV
C
      K=0
C
      RPREV=0.0
C
      IF(IBUGA3.EQ.'OFF')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF RANK2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)IBUGA3
   52 FORMAT('IBUGA3 = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)N,IUPPER
   53 FORMAT('N,IUPPER = ',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
   90 CONTINUE
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(1.LE.N.AND.N.LE.IUPPER)GOTO119
      IERROR='YES'
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,111)IUPPER
  111 FORMAT('***** ERROR IN RANK2--',
     1'THE 2ND INPUT ARGUMENT (N) IS SMALLER THAN 1',
     1'OR LARGER THAN ',I8)
      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
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,121)
  121 FORMAT('***** NON-FATAL DIAGNOSTIC IN RANK2--',
     1'THE 2ND INPUT ARGUMENT (N) HAS THE VALUE 1')
      CALL DPWRST('XXX','BUG ')
      XR(1)=1.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 RANK2--',
     1'THE FIRST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      AVRANK=(AN+1.0)/2.0
      DO137I=1,N
      XR(I)=AVRANK
  137 CONTINUE
      GOTO9000
  139 CONTINUE
C
  190 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)GOTO770
      IF(I.EQ.1)GOTO790
      IF(X(I).EQ.XPREV)GOTO750
      GOTO790
  750 CONTINUE
      XPREV=X(I)
      XR(I)=RPREV
      GOTO880
  770 CONTINUE
      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,781)IBRAN
  781 FORMAT('***** INTERNAL ERROR IN RANK2--',
     1'IMPOSSIBLE BRANCH CONDITION AT BRANCH POINT = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,782)JMIN
  782 FORMAT('JMIN = ',I8)
      CALL DPWRST('XXX','BUG ')
      GOTO9000
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,881)IBRAN
  881 FORMAT('***** INTERNAL ERROR IN RANK2--',
     1'IMPOSSIBLE BRANCH CONDITION AT BRANCH POINT = ',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)
CCCCC RKXMIN=XR(1)
CCCCC RKXMAX=XR(1)
CCCCC DO910I=1,N
CCCCC IF(XR(I).LT.RKXMIN)RKXMIN=XR(I)
CCCCC IF(XR(I).GT.RKXMAX)RKXMAX=XR(I)
CC910 CONTINUE
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
      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.'OFF')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF RANK2--')
      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
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE RANKCM(X,Y,N,IWRITE,XTEMP,YTEMP,MAXNXT,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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--91.8
C     ORIGINAL VERSION--AUGUST    1991.
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(*)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='RANK'
      ISUBN2='CM  '
C
      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
  190 CONTINUE
C
C               *************************************************
C               **  STEP 2--                                   **
C               **  COMPUTE THE RANK COMOVEMENT  COEFFICIENT.  **
C               *************************************************
C
      IWRIT2=IBUGA3
      CALL RANK(X,N,IWRIT2,XTEMP,IBUGA3,IERROR)
      CALL RANK(Y,N,IWRIT2,YTEMP,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 RANKCR(X,Y,N,IWRITE,XTEMP,YTEMP,MAXNXT,XYRACR,
     1IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE
C              SPEARMAN RANK CORRELATION 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--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     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (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
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(*)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='RANK'
      ISUBN2='CR  '
C
      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 RANKCR--')
      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 CORRELATION COEFFICIENT  **
C               ********************************************
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      AN=N
C
      IF(1.LE.N.AND.N.LE.MAXNXT)GOTO119
      IERROR='YES'
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,111)
  111 FORMAT('***** ERROR IN RANKCR--')
      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 CORRELATION 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 RANKCR--',
     1'THE THIRD INPUT ARGUMENT (N) HAS THE VALUE 1')
      CALL DPWRST('XXX','BUG ')
      XYRACR=1.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 RANKCR--',
     1'THE 1ST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.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,146)HOLD
  146 FORMAT('***** NON-FATAL DIAGNOSTIC IN RANKCR--',
     1'THE 2ND INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      XYRACR=1.0
      GOTO9000
  149 CONTINUE
C
  190 CONTINUE
C
C               *************************************************
C               **  STEP 2--                                   **
C               **  COMPUTE THE RANK CORRELATION COEFFICIENT.  **
C               *************************************************
C
      IWRIT2=IBUGA3
      CALL RANK(X,N,IWRIT2,XTEMP,IBUGA3,IERROR)
      CALL RANK(Y,N,IWRIT2,YTEMP,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 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,XYRACR
  811 FORMAT('THE RANK CORRELATION 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 RANKCR--')
      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)XYRACR
 9015 FORMAT('XYRACR = ',E15.7)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE RANKCV(X,Y,N,IWRITE,XTEMP,YTEMP,MAXNXT,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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--82.6
C     ORIGINAL VERSION--JUNE      1972.
C     UPDATED         --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
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(*)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='RANK'
      ISUBN2='CV  '
C
      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
  190 CONTINUE
C
C               *************************************************
C               **  STEP 2--                                   **
C               **  COMPUTE THE RANK COVARIANCE  COEFFICIENT.  **
C               *************************************************
C
      IWRIT2=IBUGA3
      CALL RANK(X,N,IWRIT2,XTEMP,IBUGA3,IERROR)
      CALL RANK(Y,N,IWRIT2,YTEMP,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 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
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DATA 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
  195    TWOM24 = TWOM24 * 0.5
         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 = 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.
*
      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 = 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 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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--89/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---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      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('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ',
     1'RANPER SUBROUTINE 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=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)=IP
      IF(IP.GT.N)X(I)=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=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=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
 8000 CONTINUE
      CALL UNIRAN(5,ISEED,U)
      IFUDGE=AN*U(5)
      IFUDGE=IFUDGE+1
      IF(IFUDGE.LE.1)IFUDGE=1
      IF(IFUDGE.GE.N)IFUDGE=N
      DO1400I=1,N
      IXI=X(I)+0.5
      IXIP=IXI+IFUDGE
      IF(IXIP.LE.N)X(I)=IXIP
      IF(IXIP.GT.N)X(I)=IXIP-N
 1400 CONTINUE
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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004.6
C     ORIGINAL VERSION--JUNE      2004.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DCDF
C
      INCLUDE 'DPCOMC.INC'
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
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
      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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004.6
C     ORIGINAL VERSION--JUNE      2004.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DPDF
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
C
      INCLUDE 'DPCOMC.INC'
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004.6
C     ORIGINAL VERSION--JUNE      2004.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DP
      DOUBLE PRECISION DPPF
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C               ************************************
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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004.6
C     ORIGINAL VERSION--JUNE      2004.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
C
      DOUBLE PRECISION DP
      DOUBLE PRECISION DPPF
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----DATA STATEMENTS-------------------------------------------------
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)THEN
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,6)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
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,'.')
   48 FORMAT('      VALUE OF ARGUMENT IS: ',G15.7)
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'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
CCCCC CHARACTER*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
      DO 100 M = 1,NPTS
         DO 200 K = 1,NDIM
            X(K) = UNI()
  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'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
CCCCC CHARACTER*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
      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'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
CCCCC CHARACTER*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'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
CCCCC CHARACTER*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)
      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
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DB
      DOUBLE PRECISION DCDF
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C---------------------------------------------------------------------
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
    1 ALFA = - X2 * BETA - ALFA + B(ITEMP)
      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
    2 ALFA = - X2 * BETA - ALFA + B(ITEMP)
      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
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DB
      DOUBLE PRECISION DPDF
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C---------------------------------------------------------------------
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
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DP
      DOUBLE PRECISION DB
      DOUBLE PRECISION DPPF
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C---------------------------------------------------------------------
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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2001.10
C     ORIGINAL VERSION--OCTOBER   2001.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)THEN
        WRITE(ICOUT, 5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
      IF(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)
      LOGICAL CONFND
      CHARACTER*4 ICASRE
C
      CHARACTER*4 ISUBRO
      CHARACTER*4 IERROR
      CHARACTER*4 IBUGA2
      CHARACTER*4 IBUGA3
      CHARACTER*4 IOP
      CHARACTER*4 IFLAG
      CHARACTER*80 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
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      REAL CPUMIN
      REAL CPUMAX
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C
      DATA ZERO /0.D0/
      DATA ONE/1.D0/
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)
      REAL AJUNK
      REAL XTMP(1)
      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
      CHARACTER*80 IFILE
C
      CHARACTER*4 ICASRE
C
      CHARACTER*4 IERROR
      CHARACTER*4 IBUGA2
      CHARACTER*4 IBUGA3
      CHARACTER*4 ISUBRO
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      REAL CPUMIN
      REAL CPUMAX
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DATA ONE /1.D0/
      DATA ZERO/0.D0/
      DATA EPS /1.D-7/
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
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
  126 FORMAT('I,J,KK=',3I8,2D15.7)
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
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
  136 FORMAT('I,J,KK=',3I8,2D15.7)
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 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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--82.6
C     ORIGINAL VERSION--JUNE      1972.
C     UPDATED         --SEPTEMBER 1975.
C     UPDATED         --NOVEMBER  1975.
C     UPDATED         --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---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='RELS'
      ISUBN2='D   '
C
      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 2ND 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
  190 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 REPEAT(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
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---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='REPE'
      ISUBN2='AT  '
C
      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)NUMSET,XSD
 1131     FORMAT('***** GROUP ',I8,' SD = ',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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2006/2
C     ORIGINAL VERSION--FEBRUARY  2006.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES----------------
C
      CHARACTER*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---------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT--------------------------------------------------
C
      ISUBN1='MATC'
      ISUBN2='H   '
C
      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
   52   FORMAT('IBUGA3 = ',A4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,53)NX,NVAL
   53   FORMAT('NX,NVAL = ',I8)
        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
 9000 CONTINUE
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
 9012   FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9013)NX
 9013   FORMAT('NX = ',2I8)
        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---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='REPE'
      ISUBN2='AT  '
C
      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,IPRTMP)
      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
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      REAL CPUMIN, CPUMAX
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
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,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,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,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
C
  140 RETURN
  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)')
      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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--98/5
C     ORIGINAL VERSION--MAY       1998.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
      DIMENSION Y(*)
      DIMENSION YTEMP(*)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='REVE'
      ISUBN2='RS  '
C
      IERROR='NO'
C
      IF(IBUGA3.EQ.'OFF')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF REVERS--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)IBUGA3
   52 FORMAT('IBUGA3 = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)NX
   53 FORMAT('NX = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO55I=1,NX
      WRITE(ICOUT,56)I,X(I)
   56 FORMAT('I,X(I) = ',I8,E15.7)
      CALL DPWRST('XXX','BUG ')
   55 CONTINUE
   90 CONTINUE
C
C               **************************************
C               **  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
 9000 CONTINUE
C
      IF(IBUGA3.EQ.'OFF')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF REVERS--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IBUGA3,IERROR
 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)NX
 9013 FORMAT('NX = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO9015I=1,NX
      WRITE(ICOUT,9016)I,X(I),Y(I)
 9016 FORMAT('I,X(I),Y(I) = ',I8,2E15.7)
      CALL DPWRST('XXX','BUG ')
 9015 CONTINUE
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE 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(X,GAMMA,AMU,CDF)
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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--90.6
C     ORIGINAL VERSION--MAY       1990.
C     UPDATED         --DECEMBER  2003. SUPPORT FOR GENERAL MU
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(GAMMA.LE.0)THEN
         WRITE(ICOUT,51)
   51    FORMAT('***** ERROR--THE FIRST SHAPE PARAMETER FOR THE ',
     1          'RIGCDF SUBROUTINE IS NON-POSITIVE *****')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,52)GAMMA
   52    FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
         CALL DPWRST('XXX','BUG ')
         CDF=0.0
         GOTO9000
      ENDIF
C
      IF(AMU.LE.0)THEN
         WRITE(ICOUT,71)
   71    FORMAT('***** ERROR--THE SECOND SHAPE PARAMETER FOR THE ',
     1          'RIGPDF SUBROUTINE IS NON-POSITIVE *****')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,52)AMU
         CALL DPWRST('XXX','BUG ')
         CDF=0.0
         GOTO9000
      ENDIF
C
      IF(X.LT.0.0)THEN
         WRITE(ICOUT,61)
   61    FORMAT('***** ERROR--THE FIRST  INPUT ARGUMENT TO THE ',
     1          'RIGPDF SUBROUTINE IS NON-POSITIVE *****')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,52)X
         CALL DPWRST('XXX','BUG ')
         CDF=0.0
         GOTO9000
      ENDIF
C
      IF(X.EQ.0.0)THEN
         PDF=0.0
         GOTO9000
      ENDIF
C
      X2=1.0/X
      CALL IGCDF(X2,GAMMA,AMU,CDF)
      CDF=1.0-CDF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE RIGCHA(X,GAMMA,AMU,HAZ)
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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--98.6
C     ORIGINAL VERSION--APRIL     1998.
C     UPDATED         --DECEMBER  2003. SUPPORT FOR GENERAL MU
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(GAMMA.LE.0)THEN
         WRITE(ICOUT,51)
   51    FORMAT('***** ERROR--THE FIRST SHAPE PARAMETER FOR THE ',
     1          'RIGCHA SUBROUTINE IS NON-POSITIVE *****')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,52)GAMMA
   52    FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
         CALL DPWRST('XXX','BUG ')
         HAZ=0.0
         GOTO9000
      ENDIF
C
      IF(AMU.LE.0)THEN
         WRITE(ICOUT,71)
   71    FORMAT('***** ERROR--THE SECOND SHAPE PARAMETER FOR THE ',
     1          'RIGPDF SUBROUTINE IS NON-POSITIVE *****')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,52)AMU
         CALL DPWRST('XXX','BUG ')
         HAZ=0.0
         GOTO9000
      ENDIF
C
      IF(X.LT.0.0)THEN
         WRITE(ICOUT,61)
   61    FORMAT('***** ERROR--THE FIRST  INPUT ARGUMENT TO THE ',
     1          'RIGPDF SUBROUTINE IS NON-POSITIVE *****')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,52)X
         CALL DPWRST('XXX','BUG ')
         HAZ=0.0
         GOTO9000
      ENDIF
C
      IF(X.EQ.0.0)THEN
        HAZ=0.0
      ELSEIF(X.GT.0.0)THEN
         CALL RIGCDF(X,GAMMA,AMU,CDF)
         CDF=1.0-CDF
         IF(CDF.GT.0.0)THEN
           HAZ=-LOG(CDF)
         ELSE
           WRITE(ICOUT,162)X
  162    FORMAT('***** FOR THE VALUE OF THE ARGUMENT ',E15.8,
     1     ' THE CDF IS ESSENTIALLY 1, CUMULATIVE HAZARD SET TO 0.')
         CALL DPWRST('XXX','BUG ')
         HAZ=0.0
         ENDIF
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE RIGHAZ(X,GAMMA,AMU,HAZ)
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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--98.6
C     ORIGINAL VERSION--APRIL     1998.
C     UPDATED         --DECEMBER  2003. USE GENERAL VALUE OF MU
C                                       INSTEAD OF ASSUMING MU=1
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(GAMMA.LE.0)THEN
         WRITE(ICOUT,51)
   51    FORMAT('***** ERROR--THE FIRST SHAPE PARAMETER FOR THE ',
     1          'RIGPDF SUBROUTINE IS NON-POSITIVE *****')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,52)GAMMA
   52    FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
         CALL DPWRST('XXX','BUG ')
         HAZ=0.0
         GOTO9000
      ENDIF
C
      IF(AMU.LE.0)THEN
         WRITE(ICOUT,71)
   71    FORMAT('***** ERROR--THE SECOND SHAPE PARAMETER FOR THE ',
     1          'RIGPDF SUBROUTINE IS NON-POSITIVE *****')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,52)AMU
         CALL DPWRST('XXX','BUG ')
         HAZ=0.0
         GOTO9000
      ENDIF
C
      IF(X.LT.0.0)THEN
         WRITE(ICOUT,61)
   61    FORMAT('***** ERROR--THE FIRST  INPUT ARGUMENT TO THE ',
     1          'RIGPDF SUBROUTINE IS NON-POSITIVE *****')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,52)X
         CALL DPWRST('XXX','BUG ')
         HAZ=0.0
         GOTO9000
      ENDIF
C
      IF(X.EQ.0.0)THEN
        HAZ=0.0
      ELSEIF(X.GT.0.0)THEN
         CALL RIGCDF(X,GAMMA,AMU,CDF)
         CDF=1.0-CDF
         IF(CDF.GT.0.0)THEN
           CALL RIGPDF(X,GAMMA,AMU,PDF)
           HAZ=PDF/CDF
         ELSE
           WRITE(ICOUT,162)X
  162      FORMAT('***** FOR THE VALUE OF THE ARGUMENT ',
     1            E15.8,' THE CDF IS ESSENTIALLY 1, HAZARD SET TO 0.')
           CALL DPWRST('XXX','BUG ')
           HAZ=0.0
         ENDIF
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE RIGPDF(X,GAMMA,AMU,PDF)
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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--90.6
C     ORIGINAL VERSION--MAY       1990.
C     UPDATED         --DECEMBER  2003. USE GENERAL VALUE OF MU
C                                       INSTEAD OF ASSUMING MU=1
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(GAMMA.LE.0)THEN
         WRITE(ICOUT,51)
   51    FORMAT('***** ERROR--THE FIRST SHAPE PARAMETER FOR THE ',
     1          'RIGPDF SUBROUTINE IS NON-POSITIVE *****')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,52)GAMMA
   52    FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
         CALL DPWRST('XXX','BUG ')
         PDF=0.0
         GOTO9000
      ENDIF
C
      IF(AMU.LE.0)THEN
         WRITE(ICOUT,71)
   71    FORMAT('***** ERROR--THE SECOND SHAPE PARAMETER FOR THE ',
     1          'RIGPDF SUBROUTINE IS NON-POSITIVE *****')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,52)AMU
         CALL DPWRST('XXX','BUG ')
         PDF=0.0
         GOTO9000
      ENDIF
C
      IF(X.LT.0.0)THEN
         WRITE(ICOUT,61)
   61    FORMAT('***** ERROR--THE FIRST  INPUT ARGUMENT TO THE ',
     1          'RIGPDF SUBROUTINE IS NON-POSITIVE *****')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,52)X
         CALL DPWRST('XXX','BUG ')
         PDF=0.0
         GOTO9000
      ENDIF
C
      IF(X.EQ.0.0)THEN
         PDF=0.0
         GOTO9000
      ENDIF
C
      X2=1.0/X
      CALL IGPDF(X2,GAMMA,AMU,PDF)
      PDF=PDF/(X**2)
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE RIGPPF(P,GAMMA,AMU,PPF)
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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--90.6
C     ORIGINAL VERSION--MAY       1990.
C     UPDATED         --DECEMBER  2003. USE GENERAL VALUE OF MU
C                                       INSTEAD OF ASSUMING MU=1
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(GAMMA.LE.0)THEN
         WRITE(ICOUT,51)
   51    FORMAT('***** ERROR--THE FIRST SHAPE PARAMETER FOR THE ',
     1          'RIGPPF SUBROUTINE IS NON-POSITIVE *****')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,52)GAMMA
   52    FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
         CALL DPWRST('XXX','BUG ')
         PPF=0.0
         GOTO9000
      ENDIF
C
      IF(AMU.LE.0)THEN
         WRITE(ICOUT,71)
   71    FORMAT('***** ERROR--THE SECOND SHAPE PARAMETER FOR THE ',
     1          'RIGPPF SUBROUTINE IS NON-POSITIVE *****')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,52)AMU
         CALL DPWRST('XXX','BUG ')
         PPF=0.0
         GOTO9000
      ENDIF
C
      IF(P.LT.0.0.OR.P.GE.1.0)THEN
        WRITE(ICOUT,61)
   61   FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT FOR THE ',
     1         'RIGPPF SUBROUTINE ')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,62)
   62   FORMAT('      IS OUTSIDE THE ALLOWABLE [0,1) INTERVAL *****')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,52)P
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
        GOTO9000
      ENDIF
C
      P2=1.0-P
      CALL IGPPF(P2,GAMMA,AMU,PPF)
      PPF=1.0/PPF
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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--90.6
C     ORIGINAL VERSION--MAY       1990.
C     UPDATED         --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
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)THEN
         WRITE(ICOUT,51)
   51    FORMAT('***** FATAL ERROR--THE REQUESTED NUMBER OF ',
     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
      ENDIF
C
      IF(GAMMA.LE.0.0)THEN
         WRITE(ICOUT,61)
   61    FORMAT('***** FATAL 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 ',E15.8,' *****')
         CALL DPWRST('XXX','BUG ')
         GOTO9000
      ENDIF
C
      IF(AMU.LE.0.0)THEN
         WRITE(ICOUT,71)
   71    FORMAT('***** FATAL ERROR--THE MU SHAPE PARAMETER FOR THE',
     1          ' 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(XTEMP,GAMMA,AMU,X(I))
  100 CONTINUE
C
 9000 CONTINUE
      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 /
      Y = UNI()
      J = MOD( INT( TN*UNI() ), 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()
         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() )
               IF ( -2*LOG( UNI() ) .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 RSURF(X,Y,NP,KOLR,FRM,
     1XTEMP,YTEMP,TATEMP,NTEMP,NTRACE,
     1IBUGG3,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---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'SURF')GOTO1010
      GOTO1019
 1010 CONTINUE
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1011)NP,KOLR,FRM
 1011 FORMAT('FROM RSURF--NP,KOLR,FRM = ',2I8,F10.5)
      CALL DPWRST('XXX','BUG ')
      DO1015I=1,NP
      WRITE(ICOUT,1016)I,X(I),Y(I)
 1016 FORMAT('            I,X(I),Y(I) = ',I8,2F10.5)
      CALL DPWRST('XXX','BUG ')
 1015 CONTINUE
 1019 CONTINUE
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 RAND
      DATA NOLD /-1/
C***FIRST EXECUTABLE STATEMENT  RUNIF
      IF (N.EQ.NOLD) GO TO 20
C
      NOLD = IABS(N)
      FLOATN = NOLD
      IF (N.LT.0) DUMMY = RAND (T(NOLD+1))
      IF (N.LT.0) GO TO 20
C
      DO 10 I=1,NOLD
        T(I) = RAND (0.)
 10   CONTINUE
      T(NOLD+1) = RAND (0.)
C
 20   J = T(NOLD+1)*FLOATN + 1.
      T(NOLD+1) = T(J)
      RUNIF = T(J)
      T(J) = RAND (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'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DIMENSION 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
      REAL CPUMIN
      REAL CPUMAX
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DATA ZERO/0D0/,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
      REAL CPUMIN
      REAL CPUMAX
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DATA ZERO/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
      REAL CPUMIN
      REAL CPUMAX
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DATA ZERO/0D0/,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 = 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
      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 = 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.0D0
         CALL ADAPT( M, RULCLS, 0, FNCMVT, ABSEPS, RELEPS,
     *               LENWRK, WORK, ERROR, VALUE, INFORM )
         MAXCLS = MIN( 10*RULCLS, MAXPTS )
         TOTCLS = 0.0D0
         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(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 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
      IF(INCX.EQ.INCY) IF(INCX-1) 5,20,60
    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) = ALOG(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 SCAN(IPT, M, LER, N, LE, LS, LV, LLIM, LP, L, IA,      SCA  170
     * IBATCH)
C  PART OF ACM 591 FOR ANOVA
C  ****************************** SCAN ******************************   SCA   10
C                                                                       SCA   20
C  PROCESSES THE MODEL/HYPOTHESIS STATEMENT TO CONSTRUCT/MODIFY THE     SCA   30
C  E/R LIST (ARRAY LER); TURNS SWITCH ISST ON FOR AN INVALID STATE-     SCA   40
C  MENT.  DETERMINES THE EFFECTIVE NUMBER OF FACTORS (NSUBS); TURNS     SCA   50
C  SWITCH IXST ON WHEN THE EFFECTIVE X MATRIX IS SQUARE; COMPUTES THE   SCA   60
C  PARAMETERS NEEDED IN RESTRUCTURING DATA (LPOUT AND NO1).  COMPUTES   SCA   70
C  THE DEGREES OF FREEDOM APPLICABLE TO DATA WITH NO MISSING CELLS      SCA   80
C  (IDFM AND IDFR).                                                     SCA   90
C                                                                       SCA  100
C  IPT = POINTER TO BEGINNING OF MODEL/HYPOTHESIS STATEMENT IN INPUT    SCA  110
C  BUFFER; IBATCH = 1 (BATCH PROCESSING) OR IBATCH = 0 (INTERACTIVE)    SCA  120
C                                                                       SCA  130
C  (SEE MAIN PROGRAM COMMENTS FOR DESCRIPTION OF OTHER ARGUMENTS)       SCA  140
C                                                                       SCA  150
C  ******************************************************************   SCA  160
      COMMON /C1/ YPY, SSRM, SSEM, IIN, IOUT, IROPT, IVOPT, IGOPT,
     * IPOPT, IOFLAG, IBST, IHST, IRST, ISST, IXST, ICD, NSUBS, LPOUT,
     * NO1, IDF, IDFM, IDFR
      DIMENSION LER(M), LE(N), LS(N), LV(N), LLIM(N), LP(10), IA(L)
      DOUBLE PRECISION YPY, SSRM, SSEM
C
      CHARACTER*1 ILP, IRP, IM, IH, ISTAR, ISLASH, IBLANK, IC
      CHARACTER*4 ICD
C
CNIST CHARACTER*1 FUNCTION IGET
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DATA ILP /1H(/, IRP /1H)/, IM /1HM/, IH /1HH/, ISTAR /1H*/,
     * ISLASH /1H//
      DATA IBLANK /1H /
C
      ISST = 0
      IXST = 0
      M1 = M - 1
      II = IPT
      IF (II.GT.L) GO TO 350
CNIST IC = IGET(II,IA,L)
      IF (ICD(1:1).EQ.IH) GO TO 20
      IF (IC.EQ.ISTAR) GO TO 270
C INITIALIZE E/R LIST TO ZEROES FOR M AND ABSOLUTE VALUES FOR H
      DO 10 I=1,M1
        LER(I) = 0
   10 CONTINUE
      LER(M) = 1
   20 IF (LER(M).EQ.0) GO TO 350
      DO 30 I=1,M1
        LER(I) = IABS(LER(I))
   30 CONTINUE
      M2 = 2*M
C SCAN TERM TO CONSTRUCT E/R LIST; ENTER NEGATIVES FOR H TERM
   40 DO 50 I=1,N
        LP(I) = M2
   50 CONTINUE
C SUM VALUES OF FACTOR SYMBOLS FOR E/R ENTRY; ZERO LP POSITIONS
      NE = 0
      NVS = 0
   60 IFLAG = 0
      DO 70 I=1,N
CNIST   IF (IC.NE.LE(I)) GO TO 70
        LP(I) = 0
        IFLAG = 1
        NE = NE + 1
        NVS = NVS + LV(I)
   70 CONTINUE
      IF (IFLAG.NE.1) GO TO 80
      IF (II.GT.L) GO TO 350
CNIST IC = IGET(II,IA,L)
      GO TO 60
   80 IF (NE.EQ.0) GO TO 350
CNIST IF (IC.NE.ILP) GO TO 350
C SCAN SUBSCRIPTS; SET NONZERO LP ENTRIES TO NUMERICAL VALUES
      NS = 0
      NAS = 0
   90 IF (II.GT.L) GO TO 350
CNIST IC = IGET(II,IA,L)
CNIST SET FOLLOWING LINE JUST TO AVOID COMPILATION WARNING.
CNIST REMOVE IF WE ACTIVATE THIS CODE
      IC=' '
      IFLAG = 0
      DO 120 I=1,N
CNIST   IF (IC.NE.LS(I)) GO TO 120
        IF (LP(I).NE.0) LP(I) = LV(I)
        IF (LP(I).EQ.0) NAS = NAS + 1
C CHECK FOR INVALID NESTED TERM
        DO 100 J=I,N
          IF (LP(J).EQ.0) GO TO 110
  100   CONTINUE
        GO TO 350
  110   IFLAG = 1
        NS = NS + 1
  120 CONTINUE
      IF (IFLAG.NE.1) GO TO 130
      GO TO 90
  130 IF (NAS.NE.NE) GO TO 350
      IF (IC.NE.IRP) GO TO 350
      IF (NS.NE.NE) GO TO 150
C CHECK FOR INVALID CROSSED TERM
      DO 140 I=1,N
        IF (LP(I).EQ.M2) GO TO 140
        IF (LP(I).NE.0) GO TO 350
  140 CONTINUE
      I = M - NVS
      ITEMP = 0
      IF (ICD(1:1).EQ.IH) ITEMP = NVS + 1
      IF (LER(I).NE.ITEMP) GO TO 350
      LER(I) = NVS + 1
      IF (ICD(1:1).EQ.IH) LER(I) = -LER(I)
      GO TO 190
C ENTER SUM FOR NESTED TERM INTO E/R POSITIONS TO POOL
  150 DO 180 I=1,M1
        NUM = I - NVS
        DO 160 J=1,N
          NUM = NUM - LP(J)
          IF (NUM.GT.0) GO TO 160
          IF (NUM.EQ.0) GO TO 170
          NUM = NUM + LP(J)
  160   CONTINUE
        GO TO 180
  170   K = M - I
        ITEMP = 0
        IF (ICD(1:1).EQ.IH) ITEMP = NVS + 1
        IF (LER(K).NE.ITEMP) GO TO 350
        LER(K) = NVS + 1
        IF (ICD(1:1).EQ.IH) LER(K) = -LER(K)
  180 CONTINUE
  190 IF (II.GT.L) GO TO 200
CNIST IC = IGET(II,IA,L)
      IF (IC.EQ.IBLANK .AND. II.GT.L) GO TO 200
      IF (IC.NE.ISLASH) GO TO 40
C READ MODEL OR HYPOTHESIS CONTINUATION CARD (SLASH FOLLOWS TERM)
      READ (IIN,99999) (IA(I),I=1,L)
99999 FORMAT (80A1)
      IF (IBATCH.EQ.1) THEN
         WRITE (ICOUT,99998) (IA(I),I=1,L)
         CALL DPWRST('XXX','BUG ')
      ENDIF
99998 FORMAT (1H , 80A1)
      II = 1
CNIST IC = IGET(II,IA,L)
      GO TO 40
C CHECK FOR INVALID HYPOTHESIS TERM
  200 DO 220 I=1,M1
        DO 210 J=I,M1
          IF (LER(I).EQ.0) GO TO 210
          IF (LER(I).EQ.(-LER(J))) GO TO 350
  210   CONTINUE
  220 CONTINUE
C CONSTRUCT LP FROM E/R; DETERMINE EFFECTIVE FACTORS
      NSUBS = N
      DO 250 I=1,N
        LP(I) = 0
        INC1 = LV(I)
        INC2 = LV(1)/INC1
        LOC = 1
        DO 240 J=1,INC2
          DO 230 K=1,INC1
            IF (LER(LOC).GT.0) LP(I) = LP(I) + 1
            LOC = LOC + 1
  230     CONTINUE
          LOC = LOC + INC1
  240   CONTINUE
        IF (LP(I).EQ.0) NSUBS = NSUBS - 1
  250 CONTINUE
C DETERMINE IF THE EFFECTIVE X MATRIX IS SQUARE
      IV = N - NSUBS + 1
      DO 260 I=1,N
        IF (LP(I).EQ.0) GO TO 260
        IF (LP(I).NE.LV(IV)) GO TO 310
  260 CONTINUE
      GO TO 300
C CONSTRUCT E/R LIST FOR COMPLETELY CROSSED MODEL
  270 DO 280 I=1,M1
        LER(I) = M - I + 1
  280 CONTINUE
      NSUBS = N
      DO 290 I=1,N
        LP(I) = LV(1)
  290 CONTINUE
  300 IXST = 1
  310 IF (IOFLAG.EQ.1) THEN
        WRITE (ICOUT,99997) (LER(I),I=1,M)
        CALL DPWRST('XXX','BUG ')
      ENDIF
99997 FORMAT (10H E/R LIST-/(1H , 16I5))
C COMPUTE PARAMETERS REQUIRED TO RESTRUCTURE CELL FREQUENCY ARRAY
      LPOUT = 1
      NO1 = 1
      DO 320 I=1,N
        IF (LP(I).EQ.0) LPOUT = LPOUT*LLIM(I)
        IF (LP(I).NE.0) NO1 = NO1 + LV(I)
  320 CONTINUE
C COMPUTE DEGREES OF FREEDOM FOR FULL OR REDUCED MODEL
      IDF = 0
      DO 340 I=1,M
        IF (LER(I).LE.0) GO TO 340
        NO2 = M - I + 1
        CALL LABEL(NO2, 0, LLIM, IOUT, N, LV, LP)
        K = 1
        DO 330 J=1,N
          IF (LP(J).NE.0) K = K*(LLIM(J)-1)
  330   CONTINUE
        IDF = IDF + K
  340 CONTINUE
      IDFR = 0
      IF (ICD(1:1).EQ.IH) IDFR = IDF
      IF (ICD(1:1).EQ.IM) IDFM = IDF
      RETURN
  350 ISST = 1
      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
      IF(INCX.EQ.INCY) IF(INCX-1) 5,20,60
    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
       IF(INCX.EQ.INCY)  IF(INCX-1) 5,20,60
    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
    5   l(k) = ii
      l0 = ii
      i = i + 1
      do 6 k = i, 19
        ii = ii * 2
        l(k) = ii
    6   continue
c
      ii = 0
      do 9 j1 = 1, l1, l0
        do 9 j2 = j1, l2, l1
          do 9 j3 = j2, l3, l2
            do 9 j4 = j3, l4, l3
            do 9 j5 = j4, l5, l4
              do 9 j6 = j5, l6, l5
                do 9 j7 = j6, l7, l6
                  do 9 j8 = j7, l8, l7
                  do 9 j9 = j8, l9, l8
                    do 9 j10 = j9, l10, l9
                      do 9 j11 = j10, l11, l10
                        do 9 j12 = j11, l12, l11
                        do 9 j13 = j12, l13, l12
                          do 9 j14 = j13, l14, l13
                            do 9 j15 = j14, l15, l14
                              do 9 j16 = j15, l16, l15
                              do 9 j17 = j16, l17, l16
                                do 9 j18 = j17, l18, l17
                                  do 9 j19 = j18, l19, l18
                                    j20 = j19
                                    do 9 i = 1, 2
                                    ii = ii + 1
                                    if (ii .lt. j20) then
c
c       J20 is the bit-reverse of II pairwise interchange.
c
                                      tempr = xreal(ii)
                                      xreal(ii) = xreal(j20)
                                      xreal(j20) = tempr
                                    end if
                                    j20 = j20 + itop
    9   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
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     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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--82.6
C     ORIGINAL VERSION--JUNE      1972.
C     UPDATED         --SEPTEMBER 1975.
C     UPDATED         --NOVEMBER  1975.
C     UPDATED         --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---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='SD  '
      ISUBN2='    '
C
      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,E15.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
      AN=N
C
      IF(N.GE.1)GOTO119
      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 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 IS TO BE COMPUTED')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,115)
  115 FORMAT('      MUST BE 1 OR LARGER.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,116)
  116 FORMAT('      SUCH WAS NOT THE CASE HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,117)N
  117 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8,
     1'.')
      CALL DPWRST('XXX','BUG ')
      GOTO9000
  119 CONTINUE
C
      IF(N.EQ.1)GOTO120
      GOTO129
  120 CONTINUE
CCCCC WRITE(ICOUT,999)
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC WRITE(ICOUT,121)
CC121 FORMAT('***** NON-FATAL DIAGNOSTIC IN SD--',
CCCCC1'THE 2ND INPUT ARGUMENT (N) HAS THE VALUE 1')
CCCCC CALL DPWRST('XXX','BUG ')
      XSD=0.0
      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 SD--',
CCCCC1'THE FIRST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7)
CCCCC CALL DPWRST('XXX','BUG ')
      XSD=0.0
      GOTO9000
  139 CONTINUE
C
  190 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 SD--')
      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 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---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='SDDP'
      ISUBN2='    '
C
      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
  190 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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004.6
C     ORIGINAL VERSION--JUNE      2004.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DLMBDA
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DCDF
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----DATA STATEMENTS-------------------------------------------------
C
C-----START POINT-----------------------------------------------------
C
C               ************************************
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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004.6
C     ORIGINAL VERSION--JUNE      2004.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      REAL P
      COMMON/SDECOM/P,ALAMB
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      CALL SDECDF(X,ALAMB,CDF)
      SDEFUN=P - CDF
C
 9999 CONTINUE
      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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004.6
C     ORIGINAL VERSION--JUNE      2004.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DLMBDA
      DOUBLE PRECISION DPDF
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----DATA STATEMENTS-------------------------------------------------
C
C-----START POINT-----------------------------------------------------
C
C               ************************************
C               **  STEP 1--                      **
C               **  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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004.6
C     ORIGINAL VERSION--JUNE      2004.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      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
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C
      IF(P.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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004.6
C     ORIGINAL VERSION--JUNE      2004.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----DATA STATEMENTS-------------------------------------------------
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)THEN
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,6)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
      IF(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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--82.6
C     ORIGINAL VERSION--JANUARY   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---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='SDME'
      ISUBN2='AN  '
C
      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
  190 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
      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
      IF(INCX.EQ.INCY) IF(INCX-1)5,20,60
    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(N),XPLS(N),G(N),GPLS(N)
      DIMENSION A(NR,1)
      DIMENSION S(N),Y(N),U(N),W(N)
      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,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE SEMI-CIRCULAR
C              DISTRIBUTION ON THE INTERVAL (-1,1).
C              THIS DISTRIBUTION HAS MEAN = 0.0
C              AND STANDARD DEVIATION = SQRT(2/3) = 0.816497
C              THIS DISTRIBUTION HAS THE PROBABILITY
C              DENSITY FUNCTION F(X) = SQRT(1-X*X)
C              (A SEMI-CIRCLE).
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 CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C     OUTPUT ARGUMENTS--CDF    = THE SINGLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE CDF.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE BETWEEN -1 AND 1, 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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--82.6
C     ORIGINAL VERSION--NOVEMBER  1977.
C     UPDATED         --DECEMBER  1981.
C     UPDATED         --MAY       1982.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----DATA STATEMENTS-------------------------------------------------
C
      DATA PI/3.14159265359/
C
C-----START POINT-----------------------------------------------------
C
      XHOLD=X
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(XHOLD.LT.-1.0.OR.XHOLD.GT.1.0)GOTO50
      GOTO90
   50 CONTINUE
      WRITE(ICOUT,2)
    2 FORMAT('***** NON-FATAL DIAGNOSTIC--THE 1ST INPUT ARGUMENT ',
     1'TO THE SEMCDF SUBROUTINE IS OUTSIDE THE USUAL (-1,1) INT.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)X
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
      CALL DPWRST('XXX','BUG ')
      IF(XHOLD.LT.-1.0)CDF=0.0
      IF(XHOLD.GT.1.0)CDF=1.0
      RETURN
   90 CONTINUE
C
      IF(XHOLD.EQ.-1.0)GOTO110
      IF(XHOLD.EQ.1.0)GOTO120
      GOTO150
  110 CONTINUE
      CDF=0.0
      RETURN
  120 CONTINUE
      CDF=1.0
      RETURN
  150 CONTINUE
      ARG=X/SQRT(1.0-XHOLD*XHOLD)
      CDF=(1.0/PI)*(ATAN(ARG)+X*SQRT(1.0-XHOLD*XHOLD))+0.5
C
      RETURN
      END
      SUBROUTINE SEMPDF(X,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE SEMI-CIRCULAR
C              DISTRIBUTION ON THE INTERVAL (-1,1).
C              THIS DISTRIBUTION HAS MEAN = 0.0
C              AND STANDARD DEVIATION = SQRT(2/3) = 0.816497
C              THIS DISTRIBUTION HAS THE PROBABILITY
C              DENSITY FUNCTION F(X) = SQRT(1-X*X)
C              (A SEMI-CIRCLE).
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     OUTPUT ARGUMENTS--PDF    = THE SINGLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE CDF.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE BETWEEN -1 AND 1, 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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--94.4
C     ORIGINAL VERSION--APRIL     1994
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----DATA STATEMENTS-------------------------------------------------
C
      DATA PI/3.14159265359/
C
C-----START POINT-----------------------------------------------------
C
      XHOLD=X
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(XHOLD.LT.-1.0.OR.XHOLD.GT.1.0)GOTO50
      GOTO90
   50 CONTINUE
      WRITE(ICOUT,2)
    2 FORMAT('***** NON-FATAL DIAGNOSTIC--THE 1ST INPUT ARGUMENT ',
     1'TO THE SEMPDF SUBROUTINE IS OUTSIDE THE USUAL (-1,1) INT.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)X
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
      CALL DPWRST('XXX','BUG ')
      IF(XHOLD.LT.-1.0)PDF=0.0
      IF(XHOLD.GT.1.0)PDF=1.0
      RETURN
   90 CONTINUE
C
      IF(XHOLD.EQ.-1.0)GOTO110
      IF(XHOLD.EQ.1.0)GOTO120
      GOTO150
  110 CONTINUE
      PDF=0.0
      RETURN
  120 CONTINUE
      PDF=0.0
      RETURN
  150 CONTINUE
      PDF=SQRT(1.0-XHOLD*XHOLD)
C
      RETURN
      END
      SUBROUTINE SEMPPF(P,PPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE SEMI-CIRCULAR
C              DISTRIBUTION ON THE INTERVAL (-1,1).
C              THIS DISTRIBUTION HAS MEAN = 0.0
C              AND STANDARD DEVIATION = SQRT(2/3) = 0.816497
C              THIS DISTRIBUTION HAS THE PROBABILITY
C              DENSITY FUNCTION F(X) = SQRT(1-X*X)
C              (A SEMI-CIRCLE).
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--P      = THE SINGLE PRECISION VALUE
C                                (BETWEEN 0.0 AND 1.0)
C                                AT WHICH THE PERCENT POINT
C                                FUNCTION IS TO BE EVALUATED.
C     OUTPUT ARGUMENTS--PPF    = THE SINGLE PRECISION PERCENT
C                                POINT FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PERCENT POINT
C             FUNCTION VALUE PPF.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--P SHOULD BE BETWEEN 0.0 AND 1.0, INCLUSIVELY.
C     OTHER DATAPAC   SUBROUTINES NEEDED--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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--82.6
C     ORIGINAL VERSION--DECEMBER  1977.
C     UPDATED         --DECEMBER  1981.
C     UPDATED         --MAY       1982.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(P.LT.0.0.OR.P.GT.1.0)GOTO50
      GOTO90
   50 WRITE(ICOUT,1)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)P
      CALL DPWRST('XXX','BUG ')
      RETURN
   90 CONTINUE
    1 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ',
     1'SEMPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
      PHOLD=P
      IF(PHOLD.EQ.0.0)GOTO110
      IF(PHOLD.EQ.1.0)GOTO120
      GOTO130
C
  110 CONTINUE
      PPF=-1.0
      RETURN
C
  120 CONTINUE
      PPF=1.0
      RETURN
C
  130 CONTINUE
      TOL=0.000001
      MAXIT=30
C
      XMIN=-1.0
      XMAX=1.0
C
      XMID=(XMIN+XMAX)/2.0
      XLOW=XMIN
      XUP=XMAX
      ICOUNT=0
C
  210 CONTINUE
      X=XMID
      CALL SEMCDF(X,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
C
      RETURN
      END
      SUBROUTINE SEMRAN(N,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE SEMI-CIRCULAR DISTRIBUTION
C              WITH MEAN = 0 AND STANDARD DEVIATION = ZZ.
C              THIS DISTRIBUTION IS DEFINED FOR ALL X AND HAS
C              THE PROBABILITY DENSITY FUNCTION
C              F(X) = ZZZ
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 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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--82.6
C     ORIGINAL VERSION--JUNE      1978.
C     UPDATED         --DECEMBER  1981.
C     UPDATED         --MAY       1982.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)GOTO50
      GOTO90
   50 WRITE(ICOUT, 5)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,47)N
      CALL DPWRST('XXX','BUG ')
      RETURN
   90 CONTINUE
    5 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ',
     1'SEMRAN SUBROUTINE IS NON-POSITIVE *****')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
C
C     GENERATE N UNIFORM (0,1) RANDOM NUMBERS;
C
      CALL UNIRAN(N,ISEED,X)
C
C     GENERATE N SEMI-CIRCULAR RANDOM NUMBERS
C     USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD.
C
      DO100I=1,N
      CALL SEMPPF(X(I),X(I))
  100 CONTINUE
C
      RETURN
      END
      SUBROUTINE SEQDIF(X,NX,IWRITE,Y,NY,IBUGA3,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--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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--82.6
C     ORIGINAL VERSION--FEBRUARY  1979.
C     UPDATED         --APRIL     1979.
C     UPDATED         --JULY      1979.
C     UPDATED         --AUGUST    1981.
C     UPDATED         --MAY       1982.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
      DIMENSION Y(*)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='SEQD'
      ISUBN2='DI  '
C
      IERROR='NO'
C
      IF(IBUGA3.EQ.'OFF')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF SEQDIF--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)IBUGA3
   52 FORMAT('IBUGA3 = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)NX
   53 FORMAT('NX = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO55I=1,NX
      WRITE(ICOUT,56)I,X(I)
   56 FORMAT('I,X(I) = ',I8,E15.7)
      CALL DPWRST('XXX','BUG ')
   55 CONTINUE
   90 CONTINUE
C
C               **************************************
C               **  COMPUTE SEQUENTIAL DIFFERENCE.  **
C               **************************************
C
      NXM1=NX-1
      IF(NXM1.LT.1)GOTO150
      DO100I=1,NXM1
      IP1=I+1
      Y(I)=X(IP1)-X(I)
  100 CONTINUE
      NY=NXM1
      GOTO190
C
  150 CONTINUE
      IERROR='YES'
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,151)
  151 FORMAT('***** ERROR IN SEQDIF--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,152)
  152 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,153)
  153 FORMAT('      IN THE VARIABLE FOR WHICH')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,154)
  154 FORMAT('      THE SEQUENTIAL DIFFERENCE IS TO BE COMPUTED')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,155)
  155 FORMAT('      MUST BE 2 OR LARGER.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,156)
  156 FORMAT('      SUCH WAS NOT THE CASE HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,157)NX
  157 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8,
     1'.')
      CALL DPWRST('XXX','BUG ')
C
  190 CONTINUE
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
C
      IF(IBUGA3.EQ.'OFF')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF SEQDIF--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IBUGA3,IERROR
 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)NX,NY
 9013 FORMAT('NX,NY = ',2I8)
      CALL DPWRST('XXX','BUG ')
      DO9015I=1,NX
      WRITE(ICOUT,9016)I,X(I),Y(I)
 9016 FORMAT('I,X(I),Y(I) = ',I8,2E15.7)
      CALL DPWRST('XXX','BUG ')
 9015 CONTINUE
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE SETARI(Y1,Y2,N1,N2,IACASE,IWRITE,
     1Y3,Y4,N3,SCAL3,ITYP3,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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--87/9
C     ORIGINAL VERSION--AUGUST   1987.
C     UPDATED         --JUNE      1990. TEMPORARY ARRAYS TO GARBAGE COMMON
C     UPDATED         --SEPTEMBER 1993. FIX CARTESIAN PRODUCT (ALAN)
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IACASE
      CHARACTER*4 IWRITE
      CHARACTER*4 ITYP3
      CHARACTER*4 IBUGA3
      CHARACTER*4 ISUBRO
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOPA.INC'
C
      DIMENSION Y1(*)
      DIMENSION Y2(*)
      DIMENSION Y3(*)
      DIMENSION Y4(*)
C
      DIMENSION Y1HOLD(MAXOBV)
      DIMENSION Y2HOLD(MAXOBV)
CCCCC FOLLOWING LINES ADDED JUNE, 1990
      INCLUDE 'DPCOZ2.INC'
      EQUIVALENCE (G2RBAG(IGAR11),Y1HOLD(1))
      EQUIVALENCE (G2RBAG(IGAR12),Y2HOLD(1))
CCCCC END CHANGE
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='SETA'
      ISUBN2='RI  '
C
      IERROR='NO'
C
      SCAL3=(-999.0)
      ITYP3='VECT'
C
      TOL=0.00001
C
      IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'TARI')GOTO90
      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
   52 FORMAT('IBUGA3,ISUBRO,IACASE,IWRITE = ',A4,2X,A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)N1
   53 FORMAT('N1 = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO55I=1,N1
      WRITE(ICOUT,56)I,Y1(I),Y2(I)
   56 FORMAT('I,Y1(I),Y2(I) = ',I8,2E13.5)
      CALL DPWRST('XXX','BUG ')
   55 CONTINUE
   90 CONTINUE
C
C               **************************************************
C               **  CARRY OUT SET        ARITHMETIC OPERATIONS  **
C               **************************************************
C
C               ********************************************
C               **  STEP 11--                             **
C               **  CHECK NUMBER OF INPUT OBSERVATIONS.   **
C               ********************************************
C
      IF(N1.LT.1)GOTO1100
      IF(IACASE.EQ.'SECA')GOTO1190
      IF(IACASE.EQ.'SEEL')GOTO1190
      IF(N2.LT.1)GOTO1100
      GOTO1190
C
 1100 CONTINUE
      IERROR='YES'
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1151)
 1151 FORMAT('***** ERROR IN SETARI--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1152)
 1152 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1153)
 1153 FORMAT('      IN THE VARIABLE FOR WHICH')
      CALL DPWRST('XXX','BUG ')
      IF(IACASE.EQ.'SEUN')WRITE(ICOUT,1161)
 1161 FORMAT('      THE SET        UNION IS TO BE ',
     1'COMPUTED')
      IF(IACASE.EQ.'SEUN')CALL DPWRST('XXX','BUG ')
      IF(IACASE.EQ.'SEIN')WRITE(ICOUT,1162)
 1162 FORMAT('      THE SET        INTERSECTION IS TO BE ',
     1'COMPUTED')
      IF(IACASE.EQ.'SEIN')CALL DPWRST('XXX','BUG ')
      IF(IACASE.EQ.'SECO')WRITE(ICOUT,1163)
 1163 FORMAT('      THE SET        COMPLEMENT IS TO BE ',
     1'COMPUTED')
      IF(IACASE.EQ.'SECO')CALL DPWRST('XXX','BUG ')
      IF(IACASE.EQ.'SECA')WRITE(ICOUT,1164)
 1164 FORMAT('      THE SET        CARDINALITY IS TO BE ',
     1'COMPUTED')
      IF(IACASE.EQ.'SECA')CALL DPWRST('XXX','BUG ')
      IF(IACASE.EQ.'SECP')WRITE(ICOUT,1165)
 1165 FORMAT('      THE SET        CARTESIAN PRODUCT IS TO BE ',
     1'COMPUTED')
      IF(IACASE.EQ.'SECP')CALL DPWRST('XXX','BUG ')
      IF(IACASE.EQ.'SECA')WRITE(ICOUT,1166)
 1166 FORMAT('      THE SET        ELEMENTS IS TO BE ',
     1'COMPUTED')
      IF(IACASE.EQ.'SECA')CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1181)
 1181 FORMAT('      MUST BE 1 OR LARGER.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1182)
 1182 FORMAT('      SUCH WAS NOT THE CASE HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1183)N1
 1183 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8,
     1'.')
      CALL DPWRST('XXX','BUG ')
      GOTO9000
C
 1190 CONTINUE
C
C               *********************************
C               **  STEP 12--                  **
C               **  BRANCH TO THE PROPER CASE  **
C               *********************************
C
      IF(IACASE.EQ.'SEUN')GOTO2100
      IF(IACASE.EQ.'SEIN')GOTO2200
      IF(IACASE.EQ.'SECO')GOTO2300
      IF(IACASE.EQ.'SECA')GOTO2400
      IF(IACASE.EQ.'SECP')GOTO2500
      IF(IACASE.EQ.'SEEL')GOTO2600
C
      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, ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1214)
 1214 FORMAT('      SECP, OR SEEL')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1215)
 1215 FORMAT('      IACASE = ',A4)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
C
C               *********************************************
C               **  STEP 21--                              **
C               **  TREAT THE SET        UNION       CASE  **
C               *********************************************
C
 2100 CONTINUE
      K=1
      Y3(K)=Y1(K)
C
      IF(N1.LE.1)GOTO2119
      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
 2119 CONTINUE
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
      GOTO9000
C
C               *********************************************
C               **  STEP 22--                              **
C               **  TREAT THE SET        INTERSECTION CASE **
C               *********************************************
C
 2200 CONTINUE
      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
      GOTO9000
C
C               ************************************************
C               **  STEP 23--                                 **
C               **  TREAT THE SET        COMPLEMENT     CASE  **
C               ************************************************
C
 2300 CONTINUE
      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
      GOTO9000
C
C               ************************************************
C               **  STEP 24--                                 **
C               **  TREAT THE SET        CARDINALITY    CASE  **
C               ************************************************
C
 2400 CONTINUE
      K=1
      Y3(K)=Y1(K)
C
      IF(N1.LE.1)GOTO2419
      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
 2419 CONTINUE
      SCAL3=K
C
      ITYP3='SCAL'
      N3=1
      GOTO9000
C
C               ***************************************************
C               **  STEP 25--                                    **
C               **  TREAT THE SET        CARTESIAN PRODUCT CASE  **
C               ***************************************************
C
 2500 CONTINUE
      K1=1
      Y1HOLD(K1)=Y1(K1)
      IF(N1.LE.1)GOTO2519
      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
 2519 CONTINUE
C
CCCCC THE FOLLOWING SECTION WAS CORRECTED   (ALAN) SEPTEMBER 1993
      K2=1
      Y2HOLD(K2)=Y2(K2)
      IF(N2.LE.1)GOTO2539
      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
 2539 CONTINUE
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
      GOTO9000
C
C               *******************************************************
C               **  STEP 26--                                        **
C               **  TREAT THE SET        ELEMENTS (DISTINCT)   CASE  **
C               *******************************************************
C
 2600 CONTINUE
      K=1
      Y3(K)=Y1(K)
C
      IF(N1.LE.1)GOTO2619
      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
 2619 CONTINUE
C
      ITYP3='VECT'
      N3=K
      GOTO9000
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
C
      IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'TARI')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF SETARI--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IBUGA3,ISUBRO,IACASE,IWRITE
 9012 FORMAT('IBUGA3,ISUBRO,IACASE,IWRITE = ',A4,2X,A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)IERROR
 9013 FORMAT('IERROR = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9017)N1,N2,N3
 9017 FORMAT('N1,N2,N3 = ',3I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9018)SCAL3,ITYP3
 9018 FORMAT('SCAL3,ITYP3 = ',E15.7,2X,A4)
      CALL DPWRST('XXX','BUG ')
      IF(ITYP3.EQ.'SCAL')GOTO9090
      DO9021I=1,N1
      WRITE(ICOUT,9022)I,Y1(I)
 9022 FORMAT('I,Y1(I) = ',I8,E13.5)
      CALL DPWRST('XXX','BUG ')
 9021 CONTINUE
      DO9031I=1,N2
      WRITE(ICOUT,9032)I,Y2(I)
 9032 FORMAT('I,Y2(I) = ',I8,E13.5)
      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,2E13.5)
      CALL DPWRST('XXX','BUG ')
 9041 CONTINUE
 9090 CONTINUE
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
      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)*ALOG(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 (ALOG(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)*ALOG(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(ALOG(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=-ALOG((B-P)/A)
CCCCC IF (SEXPO(IR) .LT. (1.0-A)*ALOG(SGAMMA)) GO TO 13
      NTEMP=1
      CALL EXPRAN(NTEMP,ISEED,XTEMP)
      IF (XTEMP(1) .LT. (1.0-A)*ALOG(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)
   20 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
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C***FIRST EXECUTABLE STATEMENT  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 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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--82/7
C     ORIGINAL VERSION--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---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      IERROR='NO'
C
      IF(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
      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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--82/7
C     ORIGINAL VERSION--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---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      IERROR='NO'
C
      IF(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 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  IF (T) 40,50,90
  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  IF (IND-2) 80,70,60
  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
      IF (IND-2) 130,110,100
 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    IF (ASUMSC) 280,300,290
 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      IF (TEMP) 540,560,550
 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,
     1ISUBRO,IFOUND,IERROR)
C
C     PURPOSE--CARRY OUT MARK VANGEL'S SIMCOV PROGRAM
C              FOR LINEAR MODELS.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--97/9
C     ORIGINAL VERSION--SEPTEMBER1997.
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
CCCCC CHARACTER*4 IH
CCCCC CHARACTER*4 IH2
      CHARACTER*4 ICASEQ
      CHARACTER*4 IKEY
      CHARACTER*4 IHRIGH
      CHARACTER*4 IHRIG2
CCCCC CHARACTER*4 ICH
CCCCC CHARACTER*4 IOP
      CHARACTER*4 IFLAG
C
CCCCC CHARACTER*4 NEWNAM
      CHARACTER*4 IHWUSE
      CHARACTER*4 MESSAG
      CHARACTER*4 IHLEFT
      CHARACTER*4 IHLEF2
CCCCC CHARACTER*4 IREP
C
      CHARACTER*4 IVARN1
      CHARACTER*4 IVARN2
C
      CHARACTER*4 IWRITE
C
      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'
C
      DIMENSION ILIS(100)
      DIMENSION ICOLR(100)
C
      REAL XTMP(1)
      DOUBLE PRECISION COV(MAXOBV/2)
      DOUBLE PRECISION XDESGN(MAXOBV/2)
      DOUBLE PRECISION XPTS(MAXOBV/2)
      DOUBLE PRECISION V2(MAXOBV/2)
      DOUBLE PRECISION TLM0(MAXOBV/2)
      DOUBLE PRECISION TLM1(MAXOBV/2)
      DOUBLE PRECISION ETA0(MAXOBV/2)
      DOUBLE PRECISION ETA1(MAXOBV/2)
      DOUBLE PRECISION XM(MAXOBV/2)
      DOUBLE PRECISION WK2(MAXOBV/2)
      DOUBLE PRECISION WK3(MAXOBV/2)
      DOUBLE PRECISION XN(MAXOBV)
      DOUBLE PRECISION T(MAXOBV/2)
      DOUBLE PRECISION CRT(MAXOBV/2)
C
      DIMENSION IP(MAXOBV)
      DIMENSION IQ(MAXOBV)
C
      DOUBLE PRECISION Y2(MAXOBV/2)
      DIMENSION PRED2(MAXOBV/2)
      DIMENSION RES2(MAXOBV/2)
C
      DOUBLE PRECISION XMAT(MAXOBV*10)
      DOUBLE PRECISION SCRTCH(MAXOBV*20)
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 (Y2(1),X3D(1))
      EQUIVALENCE (PRED2(1),X(1))
      EQUIVALENCE (RES2(1),D(1))
      EQUIVALENCE (CRT(1),DSIZE(1))
      EQUIVALENCE (COV(1),DSYMB(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
      INCLUDE 'DPCOZZ.INC'
      INCLUDE 'DPCOZ2.INC'
      INCLUDE 'DPCOZI.INC'
      INCLUDE 'DPCOZD.INC'
      EQUIVALENCE (IGARBG(IIGAR1),IQ(1))
      EQUIVALENCE (IGARBG(IIGAR2),IP(1))
      EQUIVALENCE (G2RBAG(1),SCRTCH(1))
      EQUIVALENCE (G2RBAG(1+40*MAXOBV),XM(1))
      EQUIVALENCE (G2RBAG(1+41*MAXOBV),WK2(1))
      EQUIVALENCE (G2RBAG(1+42*MAXOBV),WK3(1))
      EQUIVALENCE (G2RBAG(1+43*MAXOBV),T(1))
      EQUIVALENCE (G2RBAG(1+44*MAXOBV),XN(1))
      EQUIVALENCE (GARBAG(1),XMAT(1))
      EQUIVALENCE (DGARBG(1),XDESGN(1))
      EQUIVALENCE (DGARBG(1+MAXOBV),XPTS(1))
      EQUIVALENCE (DGARBG(1+2*MAXOBV),V2(1))
      EQUIVALENCE (DGARBG(1+3*MAXOBV),TLM0(1))
      EQUIVALENCE (DGARBG(1+4*MAXOBV),TLM1(1))
      EQUIVALENCE (DGARBG(1+5*MAXOBV),ETA0(1))
      EQUIVALENCE (DGARBG(1+6*MAXOBV),ETA1(1))
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='SIMC'
      ISUBN2='OV  '
C
      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
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
 2290 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)
 2390 CONTINUE
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
  511   FORMAT('***** ERROR IN SIMCOV (RECIPE ANOVA)--')
  512   FORMAT('      THE REQUESTED NUMBER OF FACTORS ',I8,
     1        ' 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
        CALL DPWRST('XXX','BUG')
      ENDIF
   71 FORMAT('NUMVAR,NUMFAC=',2I8)
 1290 CONTINUE
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
      CALL DPSUB2(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
        DO4701I=1,MAXOBV
          XPTS(I)=0.D0
 4701   CONTINUE
        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
 6530 CONTINUE
      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---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      IERROR='NO'
C
      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(ALOG10(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
C-----START POINT-----------------------------------------------------
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)
      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
      CALL DSORT (VALS, DUM, NREP, 1, IERROR)
C
C     -- RETURN THE DESIRED QUANTILE
      IDX   = CONF*NREP
      QUANT = VALS(IDX)
      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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--88/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---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='SINF'
      ISUBN2='IT  '
C
      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
   52 FORMAT('ISUBRO,IBUGA3 = ',A4,2X,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  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.GE.1)GOTO119
      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')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,113)
  113 FORMAT('      IN THE VARIABLE FOR WHICH')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,114)
  114 FORMAT('      THE FREQUENCY 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 SINFIT--',
     1'THE SECOND INPUT ARGUMENT (N) HAS THE VALUE 1')
      CALL DPWRST('XXX','BUG ')
      XSINFR=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 SINFIT--',
     1'THE FIRST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      XSINFR=0.0
      GOTO9000
  139 CONTINUE
C
  190 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
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'NFIT')
     1WRITE(ICOUT,563)AANGLE,THETA,SSQ,SSQHOL,A,B,AMP
  563 FORMAT('AANGLE,THETA,SSQ,SSQHOL,A,B,AMP = ',7E12.4)
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'NFIT')
     1CALL DPWRST('XXX','BUG ')
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')
     1WRITE(ICOUT,591)XSINFR,XSINAM,XRESSD
  591 FORMAT('XSINFR,XSINAM,XRESSD = ',3E15.7)
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'NFIT')
     1CALL DPWRST('XXX','BUG ')
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 = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,812)N,XSINAM
  812 FORMAT('THE SINUSOIDAL AMPLITUDE ESTIMATE FOR THE ',I8,
     1' OBSERVATIONS = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,813)XRESSD
  813 FORMAT('THE RESIDUAL STANDARD DEVIATION = ',E15.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 = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)N
 9013 FORMAT('N = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9014)DN,DMEAN
 9014 FORMAT('DN,DMEAN = ',2E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9015)XSINFR,XSINAM,XRESSD
 9015 FORMAT('XSINFR,XSINAM,XRESSD = ',3E15.7)
      CALL DPWRST('XXX','BUG ')
 9090 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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--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---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='SINT'
      ISUBN2='RA  '
C
      IERROR='NO'
C
      N1HALF=(-999)
      IMAX=(-999)
      IEVODD=(-999)
      DDEL=(-999.0D0)
C
      DN1=N1
C
      DPI=3.14159265358979D0
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 SINTRA--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)IBUGA3
   52 FORMAT('IBUGA3 = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)N1
   53 FORMAT('N1 = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO55I=1,N1
      WRITE(ICOUT,56)I,Y1(I)
   56 FORMAT('I,Y1(I) = ',I8,E15.7)
      CALL DPWRST('XXX','BUG ')
   55 CONTINUE
   90 CONTINUE
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.'OFF')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF SINTRA--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IBUGA3,IERROR
 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,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,2E15.7)
      CALL DPWRST('XXX','BUG ')
 9015 CONTINUE
 9090 CONTINUE
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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--82.6
C     ORIGINAL VERSION--JUNE      1977.
C     UPDATED         --JUNE      1979.
C     UPDATED         --AUGUST    1981.
C     UPDATED         --MARCH     1982.
C     UPDATED         --MAY       1982.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='SIZE'
      ISUBN2='    '
C
      IERROR='NO'
C
      IF(IBUGA3.EQ.'OFF')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF SIZE--')
      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 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.'OFF')GOTO890
      IF(IWRITE.EQ.'OFF')GOTO890
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,811)N,XSIZE
  811 FORMAT('THE SAMPLE SIZE OF THE ',I8,' OBSERVATIONS = ',E15.7)
      CALL DPWRST('XXX','BUG ')
  890 CONTINUE
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'OFF')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF SIZE--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IBUGA3,IERROR
 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)N
 9013 FORMAT('N = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9015)XSIZE
 9015 FORMAT('XSIZE = ',E15.7)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2003.12
C     ORIGINAL VERSION--DECEMBER  2003.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      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 RESULT
      DOUBLE PRECISION DCDF
      DOUBLE PRECISION DX
      DOUBLE PRECISION ABSERR
      DOUBLE PRECISION WORK(LENW)
C
      DOUBLE PRECISION SLAFUN
      EXTERNAL SLAFUN
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C
      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
 9999 CONTINUE
      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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2003.12
C     ORIGINAL VERSION--DECEMBER  2003.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
      DOUBLE PRECISION DX
      DOUBLE PRECISION DPDF
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C
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
 9999 CONTINUE
      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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2003.12
C     ORIGINAL VERSION--DECEMBER  2003.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      REAL P
      COMMON/SLACOM/P
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      CALL SLACDF(X,CDF)
      SLAFU2=P - CDF
C
 9999 CONTINUE
      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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2003.1
C     ORIGINAL VERSION--JANUARY   2003.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
      DOUBLE PRECISION DX
      DOUBLE PRECISION DPDF
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C
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
C
 9999 CONTINUE
      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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2003.12
C     ORIGINAL VERSION--DECEMBER  2003.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      REAL PPF
C
      REAL SLAFU2
      EXTERNAL SLAFU2
C
      REAL P2
      COMMON/SLACOM/P2
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C
      IF(P.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--ALOG, 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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2003.1
C     ORIGINAL VERSION--JANUARY   2003.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
      DIMENSION Y(1)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
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
 9999 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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2003.11
C     ORIGINAL VERSION--NOVEMBER  2003.
C     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 RESULT
      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---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----DATA STATEMENTS-------------------------------------------------
C
C-----START POINT-----------------------------------------------------
C
C               ************************************
C               **  STEP 1--                      **
C               **  COMPUTE THE DENSITY FUNCTION  **
C               ************************************
C
      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
      ELSE
      ENDIF
C
 9000 CONTINUE
      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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2003.12
C     ORIGINAL VERSION--DECEMBER  2003.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DPDF
C
      DOUBLE PRECISION DLMBDA
      COMMON/SNCOM/DLMBDA
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----DATA STATEMENTS-------------------------------------------------
C
C-----START POINT-----------------------------------------------------
C
C               ************************************
C               **  STEP 1--                      **
C               **  COMPUTE THE DENSITY FUNCTION  **
C               ************************************
C
      CALL NODCDF(DX*DLMBDA,DTERM1)
      CALL NODPDF(DX,DTERM2)
      DPDF=2.0D0*DTERM1*DTERM2
      SNFUN=DPDF
C
 9000 CONTINUE
      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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2003.12
C     ORIGINAL VERSION--DECEMBER  2003.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      REAL P
      CHARACTER*4 ISKNDF
      COMMON/SN2COM/P,ISKNDF
C
      DOUBLE PRECISION DLMBDA
      COMMON/SNCOM/DLMBDA
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      CALL SNCDF(X,REAL(DLMBDA),ISKNDF,CDF)
      SNFU2=P - CDF
C
 9999 CONTINUE
      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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2003.11
C     ORIGINAL VERSION--NOVEMBER  2003.
C     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---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----DATA STATEMENTS-------------------------------------------------
C
C-----START POINT-----------------------------------------------------
C
C               ************************************
C               **  STEP 1--                      **
C               **  COMPUTE THE DENSITY FUNCTION  **
C               ************************************
C
      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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2003.12
C     ORIGINAL VERSION--DECEMBER  2003.
C     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
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C
      IF(P.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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2003.11
C     ORIGINAL VERSION--NOVEMBER  2003.
C     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---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----DATA STATEMENTS-------------------------------------------------
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)THEN
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,6)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
    5 FORMAT('***** 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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2003.12
C     ORIGINAL VERSION--DECEMBER  2003.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      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 RESULT
      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---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----DATA STATEMENTS-------------------------------------------------
C
C-----START POINT-----------------------------------------------------
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      IF(NU.LE.0)THEN
        WRITE(ICOUT,115)
  115   FORMAT('***** FATAL 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,
     1         ' *****')
        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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2003.12
C     ORIGINAL VERSION--DECEMBER  2003.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DZ
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
C
      DOUBLE PRECISION DNU
      DOUBLE PRECISION DLMBDA
      COMMON/STCOM/DNU,DLMBDA
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----DATA STATEMENTS-------------------------------------------------
C
C-----START POINT-----------------------------------------------------
C
C               ************************************
C               **  STEP 1--                      **
C               **  COMPUTE THE DENSITY FUNCTION  **
C               ************************************
C
      NU=INT(DNU+0.5)
      DZ=DLMBDA*DX*DSQRT((DNU+1.0D0)/(DX**2+DNU))
      CALL TDCDF(DZ,NU+1,DTERM1)
      CALL TDPDF(DX,NU,DTERM2)
      STFUN=2.0D0*DTERM1*DTERM2
C
 9000 CONTINUE
      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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2003.12
C     ORIGINAL VERSION--DECEMBER  2003.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      REAL P
      COMMON/ST2COM/P
C
      DOUBLE PRECISION DNU
      DOUBLE PRECISION DLMBDA
      COMMON/STCOM/DNU,DLMBDA
C
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      NU=INT(DNU+0.01D0)
      CALL STCDF(X,NU,REAL(DLMBDA),CDF)
      STFU2=P - CDF
C
 9999 CONTINUE
      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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2003.11
C     ORIGINAL VERSION--NOVEMBER  2003.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,ALMBDAMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
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('***** FATAL ERROR--THE DEGREES OF FREEDOM SHAPE ',
     1        'PARAMETER FOR THE')
        CALL DPWRST('XXX','BUG ')
  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,
     1         ' *****')
        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,NU+1,TERM1)
      CALL TPDF(X,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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2003.12
C     ORIGINAL VERSION--DECEMBER  2003.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      REAL PPF
C
      REAL STFU2
      EXTERNAL STFU2
C
      REAL P2
      COMMON/ST2COM/P2
C
      DOUBLE PRECISION DNU
      DOUBLE PRECISION DLMBDA
      COMMON/STCOM/DNU,DLMBDA
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      IF(NU.LE.0)THEN
        WRITE(ICOUT,115)
  115   FORMAT('***** FATAL ERROR--THE DEGREES OF FREEDOM SHAPE ',
     1        'PARAMETER FOR THE')
        CALL DPWRST('XXX','BUG ')
  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 ')
        PPF=0.0
        GOTO9000
      ENDIF
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 STPPF 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 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,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,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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2003.11
C     ORIGINAL VERSION--NOVEMBER  2003.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
      DIMENSION Y(1)
C
      CHARACTER*4 ISKNDF
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----DATA STATEMENTS-------------------------------------------------
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)THEN
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,6)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
    5 FORMAT('***** FATAL ERROR--FOR THE SKEWED T DISTRIBUTION,')
    6 FORMAT('       THE REQUESTED NUMBER OF RANDOM NUMBERS WAS ',
     1      'NON-POSITIVE.')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
C
      IF(NU.LE.0)THEN
        WRITE(ICOUT,115)
  115   FORMAT('***** FATAL ERROR--THE DEGREES OF FREEDOM SHAPE ',
     1        'PARAMETER FOR THE')
        CALL DPWRST('XXX','BUG ')
  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
   10 ASSIGN 30 TO NEXT
      SUM = ZERO
      NN = N * INCX
C                                                 BEGIN MAIN LOOP
      I = 1
   20    GO TO NEXT,(30, 50, 70, 110)
   30 IF( ABS(SX(I)) .GT. CUTLO) GO TO 85
      ASSIGN 50 TO NEXT
      XMAX = ZERO
C
C                        PHASE 1.  SUM IS ZERO
C
   50 IF( SX(I) .EQ. ZERO) GO TO 200
      IF( ABS(SX(I)) .GT. CUTLO) GO TO 85
C
C                                PREPARE FOR PHASE 2.
      ASSIGN 70 TO NEXT
      GO TO 105
C
C                                PREPARE FOR PHASE 4.
C
  100 I = J
      ASSIGN 110 TO NEXT
      SUM = (SUM / SX(I)) / SX(I)
  105 XMAX = ABS(SX(I))
      GO TO 115
C
C                   PHASE 2.  SUM IS SMALL.
C                             SCALE TO AVOID DESTRUCTIVE UNDERFLOW.
C
   70 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 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 SUM = SUM + (SX(I)/XMAX)**2
      GO TO 200
C
C
C                  PREPARE FOR PHASE 3.
C
   75 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 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
   95    SUM = SUM + SX(J)**2
      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)
C
C FIND I-TH STEPSIZE AND EVALUATE NEIGHBOR IN DIRECTION
C OF I-TH UNIT VECTOR.
C
      OV3 = 1.0/3.0
      DO 10 I=1,N
        STEPSZ(I)=RNOISE**OV3 * MAX(ABS(XPLS(I)),1./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,FHAT)
        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,FHAT)
          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) = ALOG(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---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='SORT'
      ISUBN2='    '
C
      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)
  121 FORMAT('***** NON-FATAL DIAGNOSTIC IN SORT--',
     1'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
  136 FORMAT('***** NON-FATAL DIAGNOSTIC IN SORT--',
     1'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
  190 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 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---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)GOTO50
      IF(N.EQ.1)GOTO55
      HOLD=X(1)
      DO60I=2,N
      IF(X(I).NE.HOLD)GOTO90
   60 CONTINUE
CCCCC WRITE(ICOUT, 9)HOLD
CCCCC CALL DPWRST('XXX','BUG ')
      DO61I=1,N
      XS(I)=X(I)
      YC(I)=Y(I)
   61 CONTINUE
      RETURN
   50 WRITE(ICOUT,15)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,47)N
      CALL DPWRST('XXX','BUG ')
      RETURN
   55 CONTINUE
CCCCC WRITE(ICOUT,18)
CCCCC CALL DPWRST('XXX','BUG ')
      XS(1)=X(1)
      YC(1)=Y(1)
      RETURN
   90 CONTINUE
    9 FORMAT('***** NON-FATAL DIAGNOSTIC--THE 1ST INPUT ARGUMENT ',
     1'(A VECTOR) TO THE SORTC  SUBROUTINE HAS ALL ELEMENTS = ',E15.8)
   15 FORMAT('***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE ',
     1'SORTC  SUBROUTINE IS NON-POSITIVE *****')
   18 FORMAT('***** NON-FATAL DIAGNOSTIC--THE 2ND INPUT ARGUMENT ',
     1'TO THE SORTC  SUBROUTINE HAS THE VALUE 1')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
C
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 SORTC2(X,Y,N,XS,YC)
C
C     NOTE--THIS SUBROUTINE IS IDENTICAL TO SORTC.
C           IT HAS BEEN DUPLICATED AND PLACED
C           ON THIS BRANCH OF THE OVERLAY/SEGMENTATION
C           TREE STRUCTURE IN ORDER TO ACHIEVE
C           FASTER EXECUTION TIME.
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 SORTC2(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---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)GOTO50
      IF(N.EQ.1)GOTO55
      HOLD=X(1)
      DO60I=2,N
      IF(X(I).NE.HOLD)GOTO90
   60 CONTINUE
CCCCC WRITE(ICOUT, 9)HOLD
CCCCC CALL DPWRST('XXX','BUG ')
      DO61I=1,N
      XS(I)=X(I)
      YC(I)=Y(I)
   61 CONTINUE
      RETURN
   50 WRITE(ICOUT,15)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,47)N
      CALL DPWRST('XXX','BUG ')
      RETURN
   55 CONTINUE
CCCCC WRITE(ICOUT,18)
CCCCC CALL DPWRST('XXX','BUG ')
      XS(1)=X(1)
      YC(1)=Y(1)
      RETURN
   90 CONTINUE
    9 FORMAT('***** NON-FATAL DIAGNOSTIC--THE 1ST INPUT ARGUMENT ',
     1'(A VECTOR) TO THE SORTC2 SUBROUTINE HAS ALL ELEMENTS = ',E15.7)
   15 FORMAT(   '***** FATAL ERROR--THE 2ND INPUT ARGUMENT TO THE
     1 SORTC2  SUBROUTINE IS NON-POSITIVE *****')
   18 FORMAT('***** NON-FATAL DIAGNOSTIC--THE 2ND INPUT ARGUMENT ',
     1'TO THE SORTC2  SUBROUTINE HAS THE VALUE 1')
   47 FORMAT(  '***** THE VALUE OF THE ARGUMENT IS ',I8   ,'*****')
C
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---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='SORT'
      ISUBN2='DE  '
C
      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)
  121 FORMAT('***** NON-FATAL DIAGNOSTIC IN SORT--',
     1'THE 2ND 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
  136 FORMAT('***** NON-FATAL DIAGNOSTIC IN SORT--',
     1'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
  190 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---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)GOTO50
      IF(N.EQ.1)GOTO55
      HOLD=X(1)
      DO60I=2,N
      IF(X(I).NE.HOLD)GOTO90
   60 CONTINUE
CCCCC WRITE(ICOUT, 9)HOLD
CCCCC CALL DPWRST('XXX','BUG ')
      DO61I=1,N
      XS(I)=X(I)
      AINDEX(I)=I
   61 CONTINUE
      RETURN
   50 WRITE(ICOUT,15)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,47)N
      CALL DPWRST('XXX','BUG ')
      RETURN
   55 CONTINUE
CCCCC WRITE(ICOUT,18)
CCCCC CALL DPWRST('XXX','BUG ')
      XS(1)=X(1)
      AINDEX(1)=1
      RETURN
   90 CONTINUE
    9 FORMAT('***** NON-FATAL DIAGNOSTIC--THE 1ST INPUT ARGUMENT ',
     1'(A VECTOR) TO THE SORTI  SUBROUTINE HAS ALL ELEMENTS = ',E15.8)
   15 FORMAT('***** FATAL ERROR--THE 2ND INPUT ARGUMENT TO THE ',
     1'SORTI  SUBROUTINE IS NON-POSITIVE *****')
   18 FORMAT('***** NON-FATAL DIAGNOSTIC--THE 2ND INPUT ARGUMENT ',
     1'TO THE SORTI  SUBROUTINE HAS THE VALUE 1')
   47 FORMAT( 35H***** THE VALUE OF THE ARGUMENT IS ,I8   ,6H *****)
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 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---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)GOTO50
      IF(N.EQ.1)GOTO55
      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
   50 WRITE(ICOUT,15)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,47)N
      CALL DPWRST('XXX','BUG ')
      RETURN
   55 CONTINUE
CCCCC WRITE(ICOUT,18)
CCCCC CALL DPWRST('XXX','BUG ')
      XS(1)=X(1)
      AINDEX(1)=1
      RETURN
   90 CONTINUE
    9 FORMAT('***** NON-FATAL DIAGNOSTIC--THE 1ST INPUT ARGUMENT ',
     1'(A VECTOR) TO THE SORTI  SUBROUTINE HAS ALL ELEMENTS = ',E15.8)
   15 FORMAT('***** FATAL ERROR--THE 2ND INPUT ARGUMENT TO THE ',
     1'SORTI  SUBROUTINE IS NON-POSITIVE *****')
   18 FORMAT('***** NON-FATAL DIAGNOSTIC--THE 2ND INPUT ARGUMENT ',
     1'TO THE SORTI  SUBROUTINE HAS THE VALUE 1')
   47 FORMAT( 35H***** THE VALUE OF THE ARGUMENT IS ,I8   ,6H *****)
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 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
      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 = 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 = 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 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
      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
      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
      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
            B(I) = 0
            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
  910    CONTINUE
         U(I,I) = 1
  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) = 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
            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,
     1MAXNXT,
     1XH1DIS,STTEMP,TEMP,TEMP2,TEMP3,TEMP4,TEMP5,
     1X2,AINDX,NUMSE1,
     1ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
     1ISUBRO,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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2005/12
C     ORIGINAL VERSION--DECEMBER  2005.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      EXTERNAL SUM
      EXTERNAL RANGE
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(*)
C
      INCLUDE 'DPCOPA.INC'
      INCLUDE 'DPCOST.INC'
      INCLUDE 'DPCOHK.INC'
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='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,IBUGA3,IERROR)
      DO110I=1,N
        XH1(I)=TEMP3(I)
  110 CONTINUE
      CALL DISTIN(XH1,N,IWRITE,XH1DIS,NUMSE1,IBUGA3,IERROR)
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,TEMP3,TEMP4,TEMP5,
     1                MAXNXT,NTEMP,NTEMP,NUMV,ICASE,
     1                ISEED,ITEMP1,ITEMP2,ITEMP3,
     1                ITEMP4,ITEMP5,ITEMP6,
     1                IQUAME,IQUASE,
     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 10 I=1,J
         A(J,I)=A(I,J)
   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--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-075-2899
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--99/3
C     ORIGINAL VERSION--MARCH     1999.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
C---------------------------------------------------------------------
C
      REAL L
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      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
  200 CONTINUE
      IF(U.GT.L)THEN
        N=INT(U)
      ELSE
        N=INT(L)
      ENDIF
      IC=I
C
  300 CONTINUE
      N=N-1
      CALL BINCDF(REAL(IC),P2,N,S)
      IF(S.GT.BETA)GOTO400
      BCDF=S
      GOTO300
C
  400 CONTINUE
      N=N+1
      CALL BINCDF(REAL(IC),P1,N,S)
      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
      CHARACTER*4 IERROR
C
      REAL CPUMIN
      REAL CPUMAX
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
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
   10 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
   20 X(I) = -X(I)
   30 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
  115 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
  215 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 IF (KFLAG.GE.1) RETURN
      DO 310 I=1,NN
  310 X(I) = -X(I)
      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
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
      IF(INCX.EQ.INCY) IF(INCX-1) 5,20,60
    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,IMX,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,IMX,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,IMX,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,IMX,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 STEP(IND, C, S, NW, W, M, LSTFI, LER, N, LV, LLIM, LT, STE  330
     * LP)
C  PART OF ACM 591 FOR ANOVA
C  ****************************** STEP ******************************   STE   10
C                                                                       STE   20
C  PERFORMS THE FOLLOWING SUB-STEPS OPERATING UPON THE VECTORS IN THE   STE   30
C  W ARRAY                                                              STE   40
C                                                                       STE   50
C                           1) T = (Y-D*V)/C                            STE   60
C                           2) V = V+T                                  STE   70
C                           3) B = B+T                                  STE   80
C                           4) T = R(T)                                 STE   90
C                           5) V = V-T                                  STE  100
C                           6) S = 2*Y*V-V*D*V                          STE  110
C                                                                       STE  120
C  VECTOR T CONSISTS OF THE FIRST NCELLS LOCATIONS IN VECTOR A OF W;    STE  130
C  HOWEVER, ALL LOCATIONS IN VECTOR A ARE NEEDED IN SUB-STEP 4.  R(T)   STE  140
C  IS THE RESIDUAL OPERATOR APPLIED TO VECTOR T; IT IS IMPLEMENTED      STE  150
C  USING SUBROUTINES DECOMP, POOL, AND LABEL.                           STE  160
C                                                                       STE  170
C  SUB-STEPS 1 AND 6 ARE MODIFIED IN COMPUTING RANK WITH THE R OPTION   STE  180
C  AND SUB-STEP 1 IS ALSO MODIFIED WHEN SWITCH IBST IS ON; ARGUMENT     STE  190
C  IND CONTROLS THESE MODIFICATIONS.                                    STE  200
C                                                                       STE  210
C  IND = 1 (ITERATION FOR SSR); IND = 2 (NON-ITERATIVE, IBST IS ON);    STE  220
C  IND = 3 (ITERATION FOR RANK)                                         STE  230
C                                                                       STE  240
C  S IS EITHER SSR (IND=2), AN APPROXIMATION TO SSR, (IND=1), OR PART   STE  250
C  OF THE RANK APPROXIMATION (IND=3).  C IS A SCALAR CONSTANT SELECT-   STE  260
C  ED FOR MONOTONICITY OF THE APPROXIMATION TO SSR OR FOR FASTER, BUT   STE  270
C  NOT MONOTONE, CONVERGENCE.                                           STE  280
C                                                                       STE  290
C  (SEE MAIN PROGRAM COMMENTS FOR DESCRIPTION OF OTHER ARGUMENTS)       STE  300
C                                                                       STE  310
C  ******************************************************************   STE  320
      DIMENSION W(NW), LSTFI(M), LER(M), LV(N), LLIM(N), LT(N), LP(10)
      DOUBLE PRECISION W, C, S, T1, T2
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      S = 0
      NCELLS = LSTFI(1)
      DO 40 I=1,NCELLS
C INCREMENT BASE ADDRESSES OF ARRAYS
        ID1 = NCELLS + I
        ID2 = ID1 + NCELLS
        IV = ID2 + NCELLS
        IB = IV + NCELLS
        IA = IB + NCELLS
C GENERAL ITERATION (IND=1); NON-ITERATIVE (IND=2); RANK (IND=3)
        IF (IND.EQ.1) GO TO 20
        IF (IND.EQ.2) GO TO 10
        W(IA) = W(I) - W(IV)
        IF (W(ID1).EQ.0.0) W(IA) = W(I)
        GO TO 30
   10   W(IA) = -W(IV)
        IF (W(ID2).GT.0.0) W(IA) = W(IA) + W(I)/W(ID2)
        GO TO 30
   20   W(IA) = (W(I)-W(ID1)*W(IV))/C
C V=V+A; B=B+A
   30   W(IV) = W(IV) + W(IA)
        W(IB) = W(IB) + W(IA)
   40 CONTINUE
C RESIDUAL OPERATOR
      IA = IB
      CALL DECOMP(0, IB, IOUT, NW, W, M, LSTFI, N, LT, LV, LLIM, LP)
      IFLAG = 0
      DO 70 I=1,M
        IF (LER(I).GT.0) GO TO 60
        IF (I.EQ.1) GO TO 50
        NO = M - I + 1
        CALL LABEL(NO, 0, LLIM, IOUT, N, LV, LP)
        CALL POOL(IFLAG, IA, IB, NW, W, N, LLIM, LT, LP)
   50   IFLAG = 1
   60   IB = IB + LSTFI(I)
   70 CONTINUE
C V=V-T; S=2*Y*V-V*D*V
      DO 90 I=1,NCELLS
        ID1 = NCELLS + I
        IV = ID2 + I
        IA = IA + 1
        IF (IFLAG.EQ.1) W(IV) = W(IV) - W(IA)
        T1 = 2.0D0*W(I)
        T2 = W(ID1)
        IF (T2.EQ.0.0) GO TO 80
        IF (IND.EQ.3) T2 = 1.0D0
        T1 = T1 - W(IV)*T2
   80   S = S + T1*W(IV)
   90 CONTINUE
      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
      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.
23009 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 = (1.5*newnp)/(1 - 1.5/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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--82.6
C     ORIGINAL VERSION--JUNE      1972.
C     UPDATED         --SEPTEMBER 1975.
C     UPDATED         --NOVEMBER  1975.
C     UPDATED         --JUNE      1979.
C     UPDATED         --AUGUST    1981.
C     UPDATED         --MAY       1982.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DN
      DOUBLE PRECISION DX
      DOUBLE PRECISION DSUM
      DOUBLE PRECISION DMEAN
      DOUBLE PRECISION DVAR
      DOUBLE PRECISION DSD
      DOUBLE PRECISION DMOM3
C
      DIMENSION X(*)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='STMO'
      ISUBN2='M3  '
C
      IERROR='NO'
C
      DSUM=0.0D0
      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 STMOM3--')
      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 STANDARDIZED THIRD CENTRAL MOMENT  **
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 STMOM3--')
      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 STANDARDIZED THIRD CENTRAL MOMENT 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 STMOM3--',
     1'THE 2ND INPUT ARGUMENT (N) HAS THE VALUE 1')
      CALL DPWRST('XXX','BUG ')
      XSMOM3=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 STMOM3--',
     1'THE FIRST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      XSMOM3=0.0
      GOTO9000
  139 CONTINUE
C
  190 CONTINUE
C
C               ******************************************************
C               **  STEP 2--                                        **
C               **  COMPUTE THE STANDARDIZED THIRD 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
      DVAR=DSUM/(DN-1.0D0)
      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)**3
  400 CONTINUE
      DMOM3=DSUM/(DN-1.0D0)
      XSMOM3=DMOM3/(DSD**3)
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,XSMOM3
  811 FORMAT('THE STANDARDIZED THIRD CENTRAL MOMENT 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 STMOM3--')
      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,DSUM
 9014 FORMAT('DMEAN,DSD,DSUM = ',3D15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9015)XSMOM3
 9015 FORMAT('XSMOM3 = ',E15.7)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--82.6
C     ORIGINAL VERSION--JUNE      1972.
C     UPDATED         --SEPTEMBER 1975.
C     UPDATED         --NOVEMBER  1975.
C     UPDATED         --JUNE      1979.
C     UPDATED         --AUGUST    1981.
C     UPDATED         --MAY       1982.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DN
      DOUBLE PRECISION DX
      DOUBLE PRECISION DSUM
      DOUBLE PRECISION DMEAN
      DOUBLE PRECISION DVAR
      DOUBLE PRECISION DSD
      DOUBLE PRECISION DMOM4
C
      DIMENSION X(*)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='STMO'
      ISUBN2='M4  '
C
      IERROR='NO'
C
      DSUM=0.0D0
      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 STMOM4--')
      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 STANDARDIZED FOURTH CENTRAL MOMENT  **
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 STMOM4--')
      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 STANDARDIZED FOURTH CENTRAL MOMENT IS')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,115)
  115 FORMAT('      TO BE 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 STMOM4--',
     1'THE 2ND INPUT ARGUMENT (N) HAS THE VALUE 1')
      CALL DPWRST('XXX','BUG ')
      XSMOM4=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 STMOM4--',
     1'THE FIRST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      XSMOM4=0.0
      GOTO9000
  139 CONTINUE
C
  190 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
      DVAR=DSUM/(DN-1.0D0)
      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
      DMOM4=DSUM/(DN-1.0)
      XSMOM4=DMOM4/(DSD**4)
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,XSMOM4
  811 FORMAT('THE STANDARDIZED FOURTH CENTRAL MOMENT 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 STMOM4--')
      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,DSUM
 9014 FORMAT('DMEAN,DSD,DSUM = ',3D15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9015)XSMOM4
 9015 FORMAT('XSMOM4 = ',E15.7)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
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 STRLEZ(ISTR80,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
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*80 ISTR80
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      IWIDTH=80
      DO1100I=1,IWIDTH
      IREV=IWIDTH-I+1
      IF(ISTR80(IREV:IREV).NE.' ')GOTO1110
 1100 CONTINUE
      LENGTH=0
      GOTO9000
 1110 CONTINUE
      LENGTH=IREV
      GOTO9000
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'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
CCCCC DATA FNNAME/'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
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,1),B(1)
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)
        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
40            BF1=BF
           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
40            BF1=BF
           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,IWRITE,YSTWS,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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--82.6
C     ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--JULY      1972.
C     UPDATED         --JULY      1981.
C     UPDATED         --AUGUST    1981.
C     UPDATED         --NOVEMBER  1981.
C     UPDATED         --MAY       1982.
C     UPDATED         --JUNE      1990. TEMPORARY ARRAYS TO GARBAGE COMMON
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
      INCLUDE 'DPCOPA.INC'
C
      DIMENSION X(*)
      DIMENSION Y(MAXOBV)
CCCCC FOLLOWING LINES ADDED JUNE, 1990
      INCLUDE 'DPCOZ2.INC'
      EQUIVALENCE (G2RBAG(IGAR45),Y(1))
CCCCC END CHANGE
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='STWS'
      ISUBN2='    '
C
      IERROR='NO'
      IUPPER=MAXOBV
C
      EWILKS=0.0
      SDWILK=0.0
C
      IF(IBUGA3.EQ.'OFF')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF STWS--')
      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               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      AN=N
C
      IF(1.LE.N.AND.N.LE.IUPPER)GOTO119
      IERROR='YES'
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,111)
  111 FORMAT('***** ERROR IN STWS--')
      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 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 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 STWS--',
     1'THE 2ND INPUT ARGUMENT (N) HAS THE VALUE 1')
      CALL DPWRST('XXX','BUG ')
      YSTWS=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 STWS--',
     1'THE FIRST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      YSTWS=0.0
      GOTO9000
  139 CONTINUE
C
  190 CONTINUE
C
C               ********************************
C               **  STEP 2--                  **
C               **  COMPUTE THE               **
C               **  WILK-SHAPIRO STATISTIC    **
C               ********************************
C
      CALL SORT(X,N,Y)
C
      AL=ALOG10(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.LE.2)GOTO510
      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
  510 CONTINUE
      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 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.'OFF')GOTO890
      IF(IWRITE.EQ.'OFF')GOTO890
      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 ')
  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 STWS--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IBUGA3,IERROR
 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)N
 9013 FORMAT('N = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9015)YSTWS
 9015 FORMAT('YSTWS = ',E15.7)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE SUBSAM(Y1,Y2,N1,N2,IWRITE,
     1Y3,N3,IBUGA3,ISUBRO,IERROR)
C
C     PURPOSE--EXTRACT A RANDOM SUBSAMPLE
C              OF THE DATA IN Y1(.) BASED ON THE INDICES IN Y2(.).
C              NOTE--CONTRARY TO BOOTSS, N2 NEED NOT BE THE SAME AS N1
C                    (BUT SHOULD NOT EXCEED 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                 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--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
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='SUBS'
      ISUBN2='AM  '
C
      IERROR='NO'
C
      IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'OTSS')GOTO90
      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
   52 FORMAT('IBUGA3,ISUBRO,IWRITE = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)N1,N2
   53 FORMAT('N1,N2 = ',2I8)
      CALL DPWRST('XXX','BUG ')
      DO55I=1,N1
      WRITE(ICOUT,56)I,Y1(I)
   56 FORMAT('I,Y1(I) = ',I8,E13.5)
      CALL DPWRST('XXX','BUG ')
   55 CONTINUE
      DO65I=1,N2
      WRITE(ICOUT,66)I,Y2(I)
   66 FORMAT('I,Y2(I) = ',I8,E13.5)
      CALL DPWRST('XXX','BUG ')
   65 CONTINUE
   90 CONTINUE
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)GOTO1110
      GOTO1119
C
 1110 CONTINUE
      IERROR='YES'
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1111)
 1111 FORMAT('***** ERROR IN SUBSAM--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1112)
 1112 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1113)
 1113 FORMAT('      IN THE VARIABLE FOR WHICH')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1114)
 1114 FORMAT('      THE RANDOM SAMPLE IS TO BE ',
     1'EXTRACTED')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1115)
 1115 FORMAT('      MUST BE 1 OR LARGER.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1116)
 1116 FORMAT('      SUCH WAS NOT THE CASE HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1117)N1
 1117 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8,
     1'.')
      CALL DPWRST('XXX','BUG ')
      GOTO9000
 1119 CONTINUE
C
      IF(N2.LT.1)GOTO1120
      GOTO1129
C
 1120 CONTINUE
      IERROR='YES'
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1121)
 1121 FORMAT('***** ERROR IN SUBSAM--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1122)
 1122 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1123)
 1123 FORMAT('      IN THE VARIABLE SPECIFYING THE')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1124)
 1124 FORMAT('      INDEX OF THE RANDOM SAMPLE TO BE ',
     1'EXTRACTED')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1125)
 1125 FORMAT('      MUST BE 1 OR LARGER.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1126)
 1126 FORMAT('      SUCH WAS NOT THE CASE HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1127)N2
 1127 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8,
     1'.')
      CALL DPWRST('XXX','BUG ')
      GOTO9000
 1129 CONTINUE
C
      J=0
      DO1300I=1,N2
      INDEX=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.'OFF'.AND.ISUBRO.NE.'PARI')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF SUBSAM--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IBUGA3,ISUBRO,IWRITE
 9012 FORMAT('IBUGA3,ISUBRO,IWRITE = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)IERROR
 9013 FORMAT('IERROR = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9017)N1,N2,N3
 9017 FORMAT('N1,N2,N3 = ',3I8)
      CALL DPWRST('XXX','BUG ')
      IF(N1.LE.0)GOTO9023
      DO9021I=1,N1
      WRITE(ICOUT,9022)I,Y1(I)
 9022 FORMAT('I,Y1(I) = ',I8,E13.5)
      CALL DPWRST('XXX','BUG ')
 9021 CONTINUE
 9023 CONTINUE
      IF(N2.LE.0)GOTO9033
      DO9031I=1,N2
      WRITE(ICOUT,9032)I,Y2(I)
 9032 FORMAT('I,Y2(I) = ',I8,E13.5)
      CALL DPWRST('XXX','BUG ')
 9031 CONTINUE
 9033 CONTINUE
      IF(N3.LE.0)GOTO9043
      DO9041I=1,N3
      WRITE(ICOUT,9042)I,Y3(I)
 9042 FORMAT('I,Y3(I) = ',I8,E13.5)
      CALL DPWRST('XXX','BUG ')
 9041 CONTINUE
 9043 CONTINUE
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE 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) = ALOG(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 SUM(X,N,IWRITE,XSUM,IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE
C              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           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--82.6
C     ORIGINAL VERSION--JUNE      1972.
C     UPDATED         --SEPTEMBER 1975.
C     UPDATED         --NOVEMBER  1975.
C     UPDATED         --OCTOBER   1978.
C     UPDATED         --JUNE      1979.
C     UPDATED         --JULY      1979.
C     UPDATED         --AUGUST    1981.
C     UPDATED         --MAY       1982.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DSUM
C
      DIMENSION X(*)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='SUM '
      ISUBN2='    '
C
      IERROR='NO'
C
      IF(IBUGA3.EQ.'OFF')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF SUM--')
      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 SUM  **
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 SUM--')
      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 SUM IS TO BE COMPUTED')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,115)
  115 FORMAT('      MUST BE 1 OR LARGER.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,116)
  116 FORMAT('      SUCH WAS NOT THE CASE HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,117)N
  117 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8,
     1'.')
      CALL DPWRST('XXX','BUG ')
      GOTO9000
  119 CONTINUE
C
      IF(N.EQ.1)GOTO120
      GOTO129
  120 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,121)
  121 FORMAT('***** NON-FATAL DIAGNOSTIC IN SUM--',
     1'THE 2ND INPUT ARGUMENT (N) HAS THE VALUE 1')
      CALL DPWRST('XXX','BUG ')
      XSUM=X(1)
      GOTO9000
  129 CONTINUE
C
      HOLD=X(1)
      DO135I=2,N
      IF(X(I).NE.HOLD)GOTO139
  135 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,136)HOLD
  136 FORMAT('***** NON-FATAL DIAGNOSTIC IN SUM--',
     1'THE FIRST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      XSUM=AN*HOLD
      GOTO9000
  139 CONTINUE
C
  190 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.'OFF')GOTO890
      IF(IWRITE.EQ.'OFF')GOTO890
      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 ')
  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 SUM--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IBUGA3,IERROR
 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)N
 9013 FORMAT('N = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9015)XSUM
 9015 FORMAT('XSUM = ',E15.7)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
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'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
CCCCC DATA FNNAME/'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
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'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
CCCCC DATA FNNAME/'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
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
