      SUBROUTINE MATI50(X,N,Y)
C
C     THIS PROGRAM COMPUTES THE INVERSE OF A SINGLE PRECISION SYMMETRIC
C     MATRIX WHOSE ORDER DOES NOT EXCEED 50
C     THE MODIFIED NO-SQUARE-ROOT CHOLESKI DECOMPOSITION IS USED
C     N IS THE ORDER OF THE SYMMETRIC MATRIX--N DOES NOT EXCEED 50
C     THE INPUT MATRIX IS THE LOWER LEFT TRIANGLE OF ARRAY X
C     OR, IF AVAILABLE, ALL OF THE ARRAY X
C     OUTPUT MATRIX--Y.
C     NOTE--THE DIMENSIONS OF X AND Y MUST BE THE SAME
C           IN THE CALLING ROUTINE AS IN THIS SUBROUTINE.
C           THEY HAVE BEEN SET HEREIN TO 50 BY 50,
C           AND HENCE THE 50 IN THE NAME OF THIS SUBROUTINE (MATI50).
C     NOTE--MATI50 IS IDENTICAL TO MATI25 AND MATINV
C           EXCEPT FOR THE DIMENSIONS.
C
C     REFERENCE--
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--82.6
C     ORIGINAL VERSION--THESIS
C     UPDATED         --AUGUST    1976.
C     UPDATED         --MARCH     1981.
C     UPDATED         --MAY       1982.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
CCCCC DOUBLE PRECISION SUM
C
      DIMENSION X(50,50)
      DIMENSION Y(50,50)
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='MATI'
      ISUBN2='50  '
C
      IF(N-1)115,106,115
  106 Y(1,1)=1.0D0/X(1,1)
      GOTO111
C
C     WE KNOW THAT A = L TIMES D TIMES L TRANSPOSE     WHERE L IS A
C     LOWER TRIANGULAR MATRIX AND D IS A DIAGONAL MATRIX
C     THE DIAGONAL ELEMENTS OF L ARE ALL ONES, THEREFORE WE SAVE SPACE
C     AND OVERWRITE THIS DIAGONAL WITH THE DIAGONAL ELEMENTS OF D
C     FIND L AND D
C
  115 Y(1,1)=X(1,1)
      DO20I=2,N
      Y(I,1)=X(I,1)/X(1,1)
      DO30J=2,I
      SUM=0.
      JM1=J-1
      DO40K=1,JM1
      SUM=SUM+Y(K,K)*Y(I,K)*Y(J,K)
   40 CONTINUE
      Y(I,J)=X(I,J)-SUM
      IF(J-I)41,30,41
   41 Y(I,J)=Y(I,J)/Y(J,J)
   30 CONTINUE
   20 CONTINUE
C
C     FIND L INVERSE AND STORE IT IN THE UPPER RIGHT TRIANGLE OF L
C
      DO60I=2,N
      IM1=I-1
      DO70J=1,IM1
      JJ=I-J
      SUM=0.
      JJP1=JJ+1
      DO80K=JJP1,I
      IF(K-I)64,65,64
   65 SUM=SUM+Y(K,JJ)
      GOTO80
   64 SUM=SUM+Y(K,I)*Y(K,JJ)
   80 CONTINUE
      Y(JJ,I)=-SUM
   70 CONTINUE
   60 CONTINUE
C
C     FIND A INVERSE=L INVERSE TRANSPOSE TIMES D INVERSE TIMES L INVERSE
C     STORE THIS IN THE LOWER LEFT TRIANGLE OF L
C
      DO100I=1,N
      DO110J=1,I
      SUM=0.
      DO120K=I,N
      IF(K-I)91,92,91
   91 IF(K-J)93,94,93
   93 SUM=SUM+Y(I,K)*Y(J,K)/Y(K,K)
      GOTO120
   94 SUM=SUM+Y(I,K)/Y(K,K)
      GOTO120
   92 IF(K-J)95,96,95
   95 SUM=SUM+Y(J,K)/Y(K,K)
      GOTO120
   96 SUM=SUM+1.0D0/Y(K,K)
  120 CONTINUE
      Y(I,J)=SUM
  110 CONTINUE
  100 CONTINUE
C
C     FILL IN THE UPPER RIGHT TRIANGLE OF THE INVERSE MATRIX
C     THIS IS NEEDED ONLY BECAUSE OF THE BLUE SUBROUTINE WHICH FOLLOWS
C
      NM1=N-1
      DO10I=1,NM1
      JMIN=I+1
      DO21J=JMIN,N
      Y(I,J)=Y(J,I)
   21 CONTINUE
   10 CONTINUE
  111 RETURN
      END
      SUBROUTINE MATSCA(AMAT,AMAT2,MAXROM,MAXCOM,NR1,NC1,Y1,Y2,Y3,
     1IMATSC,ICASE,IWRITE,
     1IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE SCALES A MATRIX BY
C              EITHER A SD, RANGE, MEAN, OR Z-SCORE.
C     INPUT  ARGUMENTS--AMAT   = THE SINGLE PRECISION MATRIX
C                     --MAXROM = THE INTEGER ROW DIMENSION OF AMAT
C                     --MAXCOM = THE INTEGER COUMN DIMENSION OF AMAT
C                     --NR1    = THE INTEGER NUMBER OF ROWS OF AMAT
C                     --NC1    = THE INTEGER NUMBER OF COLUMNS OF AMAT
C     OUTPUT ARGUMENTS--AMAT2    = THE SINGLE PRECISION VALUE OF THE
C                                SCALED MATRIX.
C     OUTPUT--SCALED MATRIX.
C     NOTE--THIS ROUTINE ASSUMES THE ERROR CHECKING (FOR EQUAL
C           ROWS AND COLUMNS, MATCHING DIMENSIONS FOR X AND AMAT)
C           IS DONE BT THE CALLING SUBROUTINE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     LANGUAGE--ANSI FORTRAN (1977)
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--98.6
C     ORIGINAL VERSION--JUNE      1998.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      EXTERNAL RANGE
C
      CHARACTER*4 IMATSC
      CHARACTER*4 ICASE
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DIMENSION Y1(*)
      DIMENSION Y2(*)
      DIMENSION Y3(*)
      DIMENSION AMAT(MAXROM,MAXCOM)
      DIMENSION AMAT2(MAXROM,MAXCOM)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='MATS'
      ISUBN2='CA  '
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 MATSCA--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)IBUGA3
   52 FORMAT('IBUGA3 = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)NR1,NC1
   53 FORMAT('NR1, NC1 = ',2I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,54)ICASE
   54 FORMAT('ICASE = ',A4)
      CALL DPWRST('XXX','BUG ')
   90 CONTINUE
C
C               ********************************
C               **  SCALE THE MATRIX           *
C               ********************************
C
      IWRITE='OFF'
C
      IF(IMATSC.EQ.'NONE')THEN
        DO110J=1,NC1
          DO120I=1,NR1
            AMAT2(I,J)=AMAT(I,J)
 120      CONTINUE
 110    CONTINUE 
        GOTO9000
      ENDIF
C
      IF(IMATSC.EQ.'MEAN')THEN
        IF(ICASE.EQ.'ROW ')THEN
          DO210I=1,NR1
            DO215J=1,NC1
              Y1(J)=AMAT(I,J)
 215        CONTINUE
            CALL MEAN(Y1,NC1,IWRITE,ASTAT,IBUGA3,IERROR)
            Y2(I)=ASTAT
 210      CONTINUE
          DO220I=1,NR1
            DO225J=1,NC1
              AMAT2(I,J)=AMAT(I,J)/Y2(I)
 225        CONTINUE
 220      CONTINUE
        ELSE
          DO230J=1,NC1
            DO235I=1,NR1
              Y1(I)=AMAT(I,J)
 235        CONTINUE
            CALL MEAN(Y1,NR1,IWRITE,ASTAT,IBUGA3,IERROR)
            Y2(J)=ASTAT
 230      CONTINUE
          DO240J=1,NC1
            DO245I=1,NR1
              AMAT2(I,J)=AMAT(I,J)/Y2(J)
 245        CONTINUE
 240      CONTINUE
        ENDIF
      ENDIF
C
      IF(IMATSC.EQ.'RANG')THEN
        IF(ICASE.EQ.'ROW ')THEN
          DO310I=1,NR1
            DO315J=1,NC1
              Y1(J)=AMAT(I,J)
 315        CONTINUE
            CALL RANGE(Y1,NC1,IWRITE,ASTAT,IBUGA3,IERROR)
            Y2(I)=ASTAT
 310      CONTINUE
          DO320I=1,NR1
            DO325J=1,NC1
              AMAT2(I,J)=AMAT(I,J)/Y2(I)
 325        CONTINUE
 320      CONTINUE
        ELSE
          DO330J=1,NC1
            DO335I=1,NR1
              Y1(I)=AMAT(I,J)
 335        CONTINUE
            CALL RANGE(Y1,NR1,IWRITE,ASTAT,IBUGA3,IERROR)
            Y2(J)=ASTAT
 330      CONTINUE
          DO340J=1,NC1
            DO345I=1,NR1
              AMAT2(I,J)=AMAT(I,J)/Y2(J)
 345        CONTINUE
 340      CONTINUE
        ENDIF
      ENDIF
C
      IF(IMATSC.EQ.'Z-SC')THEN
        IF(ICASE.EQ.'ROW ')THEN
          DO410I=1,NR1
            DO415J=1,NC1
              Y1(J)=AMAT(I,J)
 415        CONTINUE
            CALL SD(Y1,NC1,IWRITE,ASTAT,IBUGA3,IERROR)
            Y2(I)=ASTAT
            CALL MEAN(Y1,NC1,IWRITE,ASTAT,IBUGA3,IERROR)
            Y3(I)=ASTAT
 410      CONTINUE
          DO420I=1,NR1
            DO425J=1,NC1
              AMAT2(I,J)=(AMAT(I,J)-Y3(I))/Y2(I)
 425        CONTINUE
 420      CONTINUE
        ELSE
          DO430J=1,NC1
            DO435I=1,NR1
              Y1(I)=AMAT(I,J)
 435        CONTINUE
            CALL SD(Y1,NR1,IWRITE,ASTAT,IBUGA3,IERROR)
            Y2(J)=ASTAT
            CALL MEAN(Y1,NR1,IWRITE,ASTAT,IBUGA3,IERROR)
            Y3(J)=ASTAT
 430      CONTINUE
          DO440J=1,NC1
            DO445I=1,NR1
              AMAT2(I,J)=(AMAT(I,J)-Y3(J))/Y2(J)
 445        CONTINUE
 440      CONTINUE
        ENDIF
      ENDIF
C
      IF(IMATSC.EQ.'SD  ')THEN
        IF(ICASE.EQ.'ROW ')THEN
          DO510I=1,NR1
            DO515J=1,NC1
              Y1(J)=AMAT(I,J)
 515        CONTINUE
            CALL SD(Y1,NC1,IWRITE,ASTAT,IBUGA3,IERROR)
            Y3(I)=ASTAT
 510      CONTINUE
          DO520I=1,NR1
            DO525J=1,NC1
              AMAT2(I,J)=AMAT(I,J)/Y2(I)
 525        CONTINUE
 520      CONTINUE
        ELSE
          DO530J=1,NC1
            DO535I=1,NR1
              Y1(I)=AMAT(I,J)
 535        CONTINUE
            CALL SD(Y1,NR1,IWRITE,ASTAT,IBUGA3,IERROR)
            Y3(J)=ASTAT
 530      CONTINUE
          DO540J=1,NC1
            DO545I=1,NR1
              AMAT2(I,J)=AMAT(I,J)/Y2(J)
 545        CONTINUE
 540      CONTINUE
        ENDIF
      ENDIF
C
C
C               *******************************
C               **  STEP 3--                 **
C               **  WRITE OUT A LINE         **
C               **  OF SUMMARY INFORMATION.  **
C               *******************************
C
      IF(IFEEDB.EQ.'OFF')GOTO890
      IF(IWRITE.EQ.'OFF')GOTO890
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,811)
  811 FORMAT('THE EUCLIDEN DISTANCE MATRIX HAS BEEN CALCULATED.')
      CALL DPWRST('XXX','BUG ')
  890 CONTINUE
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'OFF')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF MATSCA--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IBUGA3,IERROR
 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9015)IMATSC
 9015 FORMAT('IMATSC = ',A4)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE MAXIM(X,N,IWRITE,XMAX,IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE
C              SAMPLE MAXIMUM
C              OF THE DATA IN THE INPUT VECTOR X.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF
C                                (UNSORTED OR SORTED) OBSERVATIONS.
C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR X.
C     OUTPUT ARGUMENTS--XMAX   = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED SAMPLE MAXIMUM.
C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
C             SAMPLE MAXIMUM.
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--DAVID, ORDER STATISTICS, 1970, PAGE 7.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--82.6
C     ORIGINAL VERSION--JUNE      1972.
C     UPDATED         --SEPTEMBER 1975.
C     UPDATED         --NOVEMBER  1975.
C     UPDATED         --JUNE      1979.
C     UPDATED         --AUGUST    1981.
C     UPDATED         --MAY       1982.
C     UPDATED         --FEBRUARY  1988.  (SUPPRESS SOME DIAGNOSTIC MESSAGES)
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='MAXI'
      ISUBN2='M   '
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 MAXIM--')
      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 MAXIMUM  **
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 MAXIM--')
      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 MAXIMUM 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 MAXIM--',
CCCCC1'THE 2ND INPUT ARGUMENT (N) HAS THE VALUE 1')
CCCCC CALL DPWRST('XXX','BUG ')
      XMAX=X(1)
      GOTO9000
  129 CONTINUE
C
      HOLD=X(1)
      DO135I=2,N
      IF(X(I).NE.HOLD)GOTO139
  135 CONTINUE
CCCCC WRITE(ICOUT,999)
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC WRITE(ICOUT,136)HOLD
CC136 FORMAT('***** NON-FATAL DIAGNOSTIC IN MAXIM--',
CCCCC1'THE FIRST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7)
CCCCC CALL DPWRST('XXX','BUG ')
      XMAX=HOLD
      GOTO9000
  139 CONTINUE
C
  190 CONTINUE
C
C               ****************************
C               **  STEP 2--              **
C               **  COMPUTE THE MAXIMUM.  **
C               ****************************
C
      XMAX=X(1)
      DO200I=2,N
      IF(X(I).GT.XMAX)XMAX=X(I)
  200 CONTINUE
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,XMAX
  811 FORMAT('THE MAXIMUM 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 MAXIM--')
      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)XMAX
 9015 FORMAT('XMAX = ',E15.7)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE MAXCDF(X,SIGMA,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE MAXWELL DISTRIBUTION
C              THIS DISTRIBUTION IS DEFINED FOR NON-NEGATIVE X AND
C              HAS THE CUMULATIVE DISTRIBUTION FUNCTION
C                 F(X) = 2*IG(3/2,0.5*(1/SIGMA**2)*X**2)/SQRT(PI)
C              WITH IG DENOTING THE IMCOMPLETE GAMMA FUNCTION.
C     INPUT  ARGUMENTS--X     = THE SINGLE PRECISION VALUE AT
C                               WHICH THE CUMULATIVE DISTRIBUTION
C                               FUNCTION IS TO BE EVALUATED.
C                               X SHOULD BE NON-NEGATIVE.
C                     --SIGMA = THE SINGLE PRECISION VALUE THAT IS
C                               THE SHAPE PARAMETER
C     OUTPUT ARGUMENTS--CDF   = THE SINGLE PRECISION CUMULATIVE
C                               DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION FUNCTION
C             VALUE CDF FOR THE MAXWELL 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--DGAMI, DSQRT.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 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     REFERENCE--JOHNSON, KOTZ, AND BALAKRISHNAN (1994).
C                "CONTINUOUS UNIVARIATE DISTRIBUTIONS--VOLUME 1",
C                SECOND EDITION, WILEY, P. 453.
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 DS
      DOUBLE PRECISION DCDF
      DOUBLE PRECISION DPI
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
      DOUBLE PRECISION DGAMI
C
      EXTERNAL DGAMI
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
      DATA DPI / 3.1415926535 8979323846 2643383279 503 D0 /
C
C-----DATA STATEMENTS-------------------------------------------------
C
C-----START POINT-----------------------------------------------------
C
C               ************************************
C               **  STEP 1--                      **
C               **  COMPUTE THE DENSITY FUNCTION  **
C               ************************************
C
CCCCC IF(X.LT.0.0)THEN
CCCCC   WRITE(ICOUT,8)
CCCCC   CALL DPWRST('XXX','WRIT')
CCCCC   WRITE(ICOUT,48)X
CCCCC   CALL DPWRST('XXX','WRIT')
CCCCC   CDF=0.0
CCCCC   GOTO9000
CCCCC ENDIF
      IF(SIGMA.LE.0.0)THEN
        WRITE(ICOUT,18)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,48)SIGMA
        CALL DPWRST('XXX','WRIT')
        PDF=0.0
        GOTO9000
      ENDIF
CCCC8 FORMAT('***** ERROR: VALUE OF THE FIRST ARGUMENT TO MAXCDF ',
CCCCC1       'IS NEGATIVE.')
   18 FORMAT('***** ERROR: VALUE OF THE SECOND ARGUMENT TO MAXCDF ',
     1       'IS NON-POSITIVE.')
   48 FORMAT('      VALUE OF ARGUMENT IS: ',G15.7)
C
      IF(X.LE.0.0)THEN
        CDF=0.0
      ELSE
        DX=DBLE(X)
        DS=DBLE(SIGMA)**2
        IF(DX.GE.DSQRT(D1MACH(2)))THEN
          CDF=1.0
          GOTO9000
        ENDIF
C
        DTERM3=2.0D0/DSQRT(DPI)
        DTERM1=1.5D0
        DTERM2=0.5D0*DX*DX/DS
        DCDF=DTERM3*DGAMI(DTERM1,DTERM2)
        CDF=REAL(DCDF)
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      subroutine maxofq
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
      implicit none
c
      integer kk
      double precision aa, ybar, cc, bb(100), yy(100)
      common /cmn1/ kk
      common /cmn2/ aa, ybar, cc, bb, yy
c
      integer i
      double precision sx2, sx1, s1b
c
      sx2 = 0.0d0
      sx1 = 0.0d0
      s1b = 0.0d0
c
      do 10 i = 1, kk
         sx2 = sx2 + yy(i)**2/bb(i)
         sx1 = sx1 + yy(i)/bb(i)
         s1b = s1b + 1.0d0/bb(i)
   10 continue
c
      aa = sx2 - 2.0d0*ybar*sx1 + ybar**2 * s1b -
     1    (sx1 - ybar*s1b)**2/s1b
c
      return
      end
      SUBROUTINE MAXPDF(X,SIGMA,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE MAXWELL DISTRIBUTION.
C              THIS DISTRIBUTION IS DEFINED FOR NON-NEGATIVE X AND
C              HAS THE PROBABILITY DENSITY FUNCTION
C                 F(X) = SQRT(2/PI)*(1/SIGMA**2)**(3/2)*X**2*
C                        EXP(-(X**2)/(2*SIGMA**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                     --SIGMA = THE SINGLE PRECISION VALUE WHICH
C                               DEFINES THE SHAPE PARAMETER
C     OUTPUT ARGUMENTS--PDF   = THE SINGLE PRECISION PROBABILITY
C                               DENSITY FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY FUNCTION
C             VALUE PDF FOR THE MAXWELL 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, P. 453.
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 DS
      DOUBLE PRECISION DPDF
      DOUBLE PRECISION DPI
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
      DOUBLE PRECISION DTERM4
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
      DATA DPI / 3.1415926535 8979323846 2643383279 503 D0 /
C
C-----DATA STATEMENTS-------------------------------------------------
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
      IF(SIGMA.LE.0.0)THEN
        WRITE(ICOUT,18)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,48)SIGMA
        CALL DPWRST('XXX','WRIT')
        PDF=0.0
        GOTO9000
      ENDIF
    8 FORMAT('***** ERROR: VALUE OF THE FIRST ARGUMENT TO MAXPDF ',
     1       'IS NEGATIVE.')
   18 FORMAT('***** ERROR: VALUE OF THE SECOND ARGUMENT TO MAXPDF ',
     1       'IS NON-POSITIVE.')
   48 FORMAT('      VALUE OF ARGUMENT IS: ',G15.7)
C
      IF(X.EQ.0.0)THEN
        PDF=0.0
      ELSE
        DX=DBLE(X)
        DS=DBLE(SIGMA)
        IF(DX.GE.DSQRT(D1MACH(2)))THEN
          PDF=0.0
          GOTO9000
        ENDIF
C
        DTERM1=DLOG(DSQRT(2.0D0/DPI))
        DTERM2=1.5D0*DLOG(1.0D0/DS**2)
        DTERM3=2.0D0*DLOG(DX)
        DTERM4=-(DX*DX)/(2.0D0*DS**2)
        DPDF=DTERM1 + DTERM2 + DTERM3 + DTERM4
        DPDF=DEXP(DPDF)
        PDF=REAL(DPDF)
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE MAXPPF(P,SIGMA,PPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE MAXWELL DISTRIBUTION
C              THIS DISTRIBUTION IS DEFINED FOR NON-NEGATIVE X AND
C              HAS THE CUMULATIVE DISTRIBUTION FUNCTION
C                 F(X) = 2*IG(3/2,0.5*(1/SIGMA)*X**2)/SQRT(PI)
C              WITH IG DENOTING THE IMCOMPLETE GAMMA FUNCTION.
C              DATAPLOT COMPUTES THE PERCENT POINT FUNCTION BY
C              NUMERICALLY INVERTING THE CUMULATIVE DISTRIBUTION
C              FUNCTION.
C     INPUT  ARGUMENTS--P     = THE SINGLE PRECISION VALUE AT
C                               WHICH THE PERCENT POINT
C                               FUNCTION IS TO BE EVALUATED.
C                               P SHOULD BE IN THE INTERVAL (0,1].
C                     --SIGMA = THE SINGLE PRECISION VALUE THAT IS
C                               THE SHAPE PARAMETER
C     OUTPUT ARGUMENTS--PPF   = THE SINGLE PRECISION PERCENT POINT
C                               FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PERCENT POINT FUNCTION
C             VALUE PPF FOR THE MAXWELL DISTRIBUTION
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--MAXCDF.
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                 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
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DATA PI / 3.1415926535 /
      DATA EPS /0.00001/
      DATA SIG /1.0E-6/
      DATA ZERO /0.0/
      DATA MAXIT /3000/
C
C-----DATA STATEMENTS-------------------------------------------------
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
      IF(SIGMA.LE.0.0)THEN
        WRITE(ICOUT,18)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,48)SIGMA
        CALL DPWRST('XXX','WRIT')
        PDF=0.0
        GOTO9000
      ENDIF
    8 FORMAT('***** ERROR: VALUE OF THE FIRST ARGUMENT TO MAXPPF ',
     1       'IS OUTSIDE THE [0,1) INTERVAL.')
   18 FORMAT('***** ERROR: VALUE OF THE SECOND ARGUMENT TO MAXPDF ',
     1       'IS NON-POSITIVE.')
   48 FORMAT('      VALUE OF ARGUMENT IS: ',G15.7)
C
      IF(P.EQ.0.0)THEN
        PPF=0.0
        GOTO9000
      ENDIF
C
C  FIND BRACKETING INTERVAL.
C
C  1) LOWER LIMIT = 0
C  2) MEAN = 2*SQRT(2*SIGMA/PI)
C     SD = SQRT(3*SIGMA)
C  3) START RIGHT LIMIT AT MEAN, INCREMENT IN UNITS OF
C     ONE STANDARD DEVIATION
C
      DP=P
      XL=0.0
      XR=2*SQRT(2.0*SIGMA/PI)
      XINC=SQRT(3.0*SIGMA)
      ICOUNT=0
      MAXCNT=10000
C
   91 CONTINUE
      IF(XL.LE.0.0)XL=0.0
      IF(XR.LE.0.0)XR=XL+XINC
      CALL MAXCDF(XL,SIGMA,CDFL)
      CALL MAXCDF(XR,SIGMA,CDFR)
      IF(CDFL.LT.DP .AND. CDFR.LT.DP)THEN
        XL=XR
        XR=XL+XINC
      ELSEIF(CDFL.GT.DP .AND. CDFR.GT.DP)THEN
        XL=XL-XINC
        IF(XL.LT.0.0D0)XL=0.0D0
      ELSE
        GOTO99
      ENDIF
      ICOUNT=ICOUNT+1
      IF(ICOUNT.GT.MAXCNT)THEN
        WRITE(ICOUT,96)
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
        GOTO9000
      ENDIF
   96 FORMAT('***** ERROR--MAXPPF UNABLE TO FIND BRACKETING ',
     *       'INTERVAL.')
      GOTO91
C
C  BISECTION METHOD
C
   99 CONTINUE
      IC = 0
      FXL = -DP
      FXR = 1.0 - DP
  105 CONTINUE
      X = (XL+XR)*0.5
      CALL MAXCDF(X,SIGMA,DCDF)
      P1=DCDF
      PPF=REAL(X)
      FCS = P1 - DP
      IF(FCS*FXL.GT.ZERO)GOTO110
      XR = X
      FXR = FCS 
      GOTO115
  110 CONTINUE
      XL = X
      FXL = FCS
  115 CONTINUE
      XRML = XR - XL
      IF(XRML.LE.SIG .AND. ABS(FCS).LE.EPS)GOTO9000
      IC = IC + 1
      IF(IC.LE.MAXIT)GOTO105
      WRITE(ICOUT,130)
      CALL DPWRST('XXX','BUG ')
  130 FORMAT('***** ERROR--MAXPPF ROUTINE DID NOT CONVERGE.')
      GOTO9000
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE MAXRAN(N,SIGMA,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE MAXWELL DISTRIBUTION.
C              THIS DISTRIBUTION IS DEFINED FOR NON-NEGATIVE X AND HAS
C              THE PROBABILITY DENSITY FUNCTION
C                 F(X) = SQRT(2/PI)*(1/SIGMA)**(3/2)X**2*
C                        EXP(-X**2/(2*SIGMA))
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --SIGMA = THE SINGLE PRECISION VALUE THAT IS
C                               THE SHAPE PARAMETER
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST N)
C                                INTO WHICH THE GENERATED
C                                RANDOM SAMPLE WILL BE PLACED.
C     OUTPUT--A RANDOM SAMPLE OF SIZE N
C             FROM THE MAXWELL 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, MAXPPF.
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
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      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 MAXWELL 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
        ATEMP=X(I)
        CALL MAXPPF(ATEMP,SIGMA,PPF)
        X(I)=PPF
  100 CONTINUE
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE MCLCDF(X,ALPHA,DCDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE MCLEISH
C              DISTRIBUTION WITH SHAPE PARAMETER ALPHA.
C              THE CUMULATIVE DISTRIBUTION IS COMPUTED BY
C              NUMERICALLY INTEGRATING THE PDF FUNCTION.
C     INPUT  ARGUMENTS--X       = THE DOUBLE PRECISION VALUE AT
C                                 WHICH THE CUMULATIVE DISTRIBUTION
C                                 FUNCTION IS TO BE EVALUATED.
C                     --ALPHA   = THE FIRST SHAPE PARAMETER
C     OUTPUT ARGUMENTS--CDF     = THE DOUBLE PRECISION CUMULATIVE
C                                 DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE FOR THE MCLEISH
C             DISTRIBUTION WITH SHAPE PARAMETERS ALPHA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--DQAG.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, (1994), "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME 1", SECOND EDITION,
C                 WILEY, PP. 50-53.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004.8
C     ORIGINAL VERSION--AUGUST    2004.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      INTEGER LIMIT
      INTEGER LENW
      PARAMETER(LIMIT=100)
      PARAMETER(LENW=4*LIMIT)
      INTEGER INF
      INTEGER NEVAL
      INTEGER IER
      INTEGER LAST
      INTEGER IWORK(LIMIT)
      DOUBLE PRECISION ALPHA
      DOUBLE PRECISION EPSABS
      DOUBLE PRECISION EPSREL
      DOUBLE PRECISION RESULT
      DOUBLE PRECISION DCDF
      DOUBLE PRECISION X
      DOUBLE PRECISION DX
      DOUBLE PRECISION DB
      DOUBLE PRECISION DC
      DOUBLE PRECISION DM
      DOUBLE PRECISION ABSERR
      DOUBLE PRECISION WORK(LENW)
C
      DOUBLE PRECISION MCLFUN
      EXTERNAL MCLFUN
C
      DOUBLE PRECISION DALPHA
      COMMON/MCLCOM/DALPHA
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,AKMBPC,AKMCPW,AKMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----DATA STATEMENTS-------------------------------------------------
C
C-----START POINT-----------------------------------------------------
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      IF(ALPHA.LE.0.0D0)THEN
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,48)ALPHA
        CALL DPWRST('XXX','WRIT')
        CDF=0.0D0
        GOTO9000
      ENDIF
    5 FORMAT('***** ERROR: VALUE OF SHAPE PARAMETER (ALPHA)',
     1       ' IN MCLCDF ROUTINE IS NON-POSITIVE.')
   48 FORMAT('      VALUE OF ARGUMENT IS: ',G15.7)
C
C               ************************************
C               **  STEP 1--                      **
C               **  COMPUTE THE DENSITY FUNCTION  **
C               ************************************
C
      IF(X.EQ.0.0D0)THEN
        DCDF=0.5D0
        GOTO9000
      ELSEIF(X.LT.0.0D0)THEN
        ICASE=0
        DX=-X
      ELSE
        ICASE=1
        DX=X
      ENDIF
C
      INF=+1
      IKEY=3
      EPSABS=0.0D0
      EPSREL=1.0D-7
      DA=0.0D0
      IER=0
      DCDF=0.0D0
      DALPHA=ALPHA
C
      CALL DQAG(MCLFUN,DA,DX,EPSABS,EPSREL,IKEY,DCDF,ABSERR,NEVAL,
     1          IER,LIMIT,LENW,LAST,IWORK,WORK)
C
      IF(ICASE.EQ.1)THEN
        DCDF=0.5D0 + DCDF
      ELSE
        DCDF=0.50D0 - 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 MCLCDF--')
        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 MCLCDF--')
        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 MCLCDF--')
        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 MCLCDF--')
        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 MCLCDF--')
        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 MCLCDF--')
        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 MCLFUN(DX)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE MCLEISH
C              DISTRIBUTION WITH SHAPE PARAMETER ALPHA.
C              THIS DISTRIBUTION IS DEFINED FOR ALL REAL X
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C
C                 MCLPDF(X,ALPHA) = [1/(SQRT(PI)*GAMMA(ALPHA))]*
C                                   (ABS(X)/2)**(ALPHA-1/2)*
C                                   K(X,ALPHA-1/2)
C              WHERE
C                 K(X,N) IS THE MODIFIED BESSEL FUNCTION OF THE
C                        SECOND KIND
C                 GAMMA IS THE GAMMA FUNCTION
C
C              THE MCLPDF ROUTINE IS CALLED TO COMPUTE THE
C              PROBABILITY DENSITY.  DEFINE AS FUNCTION TO BE USED FOR
C              INTEGRATION CODE CALLED BY MCLCDF.  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--MCLFUN  = THE DOUBLE PRECISION PROBABILITY
C                                 DENSITY FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE PDF FOR THE MCLEISH
C             DISTRIBUTION WITH SHAPE PARAMETER ALPHA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--MCLPDF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, (1994), "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME 1", SECOND EDITION,
C                 WILEY, PP. 50-53.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004.8
C     ORIGINAL VERSION--AUGUST    2004.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DTERM
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DALPHA
      COMMON/MCLCOM/DALPHA
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----DATA STATEMENTS-------------------------------------------------
C
C-----START POINT-----------------------------------------------------
C
C               ************************************
C               **  STEP 1--                      **
C               **  COMPUTE THE DENSITY FUNCTION  **
C               ************************************
C
      CALL MCLPDF(DX,DALPHA,DTERM)
      MCLFUN=DTERM
C
 9000 CONTINUE
      RETURN
      END
      DOUBLE PRECISION FUNCTION MCLFU2(DX)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE MCLEISH
C              DISTRIBUTION WITH SHAPE PARAMETER ALPHA.
C              THIS DISTRIBUTION IS DEFINED FOR ALL REAL X
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C
C                 MCLPDF(X,ALPHA) = [1/(SQRT(PI)*GAMMA(ALPHA))]*
C                                   (ABS(X)/2)**(ALPHA-1/2)*
C                                   K(X,ALPHA-1/2)
C              WHERE
C                 K(X,N) IS THE MODIFIED BESSEL FUNCTION OF THE
C                        SECOND KIND
C                 GAMMA IS THE GAMMA FUNCTION
C
C              THE MCLCDF ROUTINE IS CALLED TO COMPUTE THE
C              CUMULATIVE DISTRIBUTION.  DEFINE AS FUNCTION TO BE USED
C              FOR INTEGRATION CODE CALLED BY MCLCDF.  THIS ROUTINE
C              USES DOUBLE PRECISION ARITHMETIC.
C     INPUT  ARGUMENTS--DX      = THE DOUBLE PRECISION VALUE AT
C                                 WHICH THE CUMULATIVE DISTRIBUTION
C                                 FUNCTION IS TO BE EVALUATED.
C     OUTPUT ARGUMENTS--MCLFU2  = THE DOUBLE PRECISION CUMULATIVE
C                                 DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE CDF FOR THE MCLEISH
C             DISTRIBUTION WITH SHAPE PARAMETER ALPHA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--MCLCDF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, (1994), "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME 1", SECOND EDITION,
C                 WILEY, PP. 50-53.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004.8
C     ORIGINAL VERSION--AUGUST    2004.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DCDF
      DOUBLE PRECISION DX
C
      DOUBLE PRECISION DP
      COMMON/MC2COM/DP
C
      DOUBLE PRECISION DALPHA
      COMMON/MCLCOM/DALPHA
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----DATA STATEMENTS-------------------------------------------------
C
C-----START POINT-----------------------------------------------------
C
C               ************************************
C               **  STEP 1--                      **
C               **  COMPUTE THE DENSITY FUNCTION  **
C               ************************************
C
      CALL MCLCDF(DX,DALPHA,DCDF)
      MCLFU2=DP - DCDF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE MCLPDF(X,ALPHA,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE MCLEISH BESSEL K-FUNCTION
C              DISTRIBUTION.  IT HAS SHAPE PARAMETER ALPHA.
C              THIS DISTRIBUTION IS SYMMETRIC AND IS DEFINED
C              FOR ALL REAL X AND HAS THE PROBABILITY DENSITY FUNCTION
C
C                 MCLPDF(X,ALPHA) = [1/(SQRT(PI)*GAMMA(ALPHA))]*
C                                   (ABS(X)/2)**(ALPHA-1/2)*
C                                   K(X,ALPHA-1/2)
C              WHERE
C                 K(X,N) IS THE MODIFIED BESSEL FUNCTION OF THE
C                        SECOND KIND
C                 GAMMA IS THE GAMMA FUNCTION
C
C     NOTE--ARGUMENTS TO THIS ROUTINE ARE IN DOUBLE PRECISION.
C     INPUT  ARGUMENTS--X       = THE DOUBLE PRECISION VALUE AT
C                                 WHICH THE PROBABILITY DENSITY
C                                 FUNCTION IS TO BE EVALUATED.
C                                 X SHOULD BE POSITIVE
C                     --ALPHA    = THE FIRST SHAPE PARAMETER
C     OUTPUT ARGUMENTS--PDF     = THE DOUBLE PRECISION PROBABILITY
C                                 DENSITY FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION PROBABILITY DENSITY FUNCTION
C             VALUE PDF FOR THE MCLEISH DISTRIBUTION
C             WITH SHAPE PARAMETER ALPHA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--DBESK.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--DEXP, DLOG.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISNAN, "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME I", SECOND EDITION,
C                 WILEY, 1994, PP. 50-53.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004.8
C     ORIGINAL VERSION--AUGUST    2004.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION X
      DOUBLE PRECISION DX
      DOUBLE PRECISION ALPHA
      DOUBLE PRECISION PDF
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
      DOUBLE PRECISION DTERM4
      DOUBLE PRECISION DORD
      DOUBLE PRECISION DPI
      DOUBLE PRECISION DEPS
      DOUBLE PRECISION DLNGAM
      EXTERNAL DLNGAM
C
      DOUBLE PRECISION DTEMP1(1000)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----DATA STATEMENTS-------------------------------------------------
C
      DATA DPI / 3.14159265358979D+00/
C
C-----START POINT-----------------------------------------------------
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      IF(ALPHA.LE.0.0D0)THEN
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,48)ALPHA
        CALL DPWRST('XXX','WRIT')
        PDF=0.0D0
        GOTO9000
      ENDIF
    5 FORMAT('***** ERROR: VALUE OF SHAPE PARAMETER (ALPHA)',
     1       ' IN MCLPDF ROUTINE IS NON-POSITIVE.')
   48 FORMAT('      VALUE OF ARGUMENT IS: ',G15.7)
C
C               *****************************************
C               **  STEP 2--                           **
C               **  COMPUTE THE DENSITY FUNCTION.  FOR **
C               **  BETTER NUMERICAL STABILITY,        **
C               **  COMPUTE LOGARIGHMS.                **
C               *****************************************
C
C
C  COMPUTE BESSEL FUNCTION FIRST.  IF THIS IS 0, SET PDF TO
C  0 AND RETURN.
C
      DEPS=1.0D-12
      IF(ALPHA.GT.25.0)DEPS=1.0D-10
      DX=X
      DX=DABS(DX)
      IF(DX.EQ.0.0D0)DX=DEPS
      DORD=DABS(ALPHA-0.5D0)
      IARG1=1
      ISCALE=1
      CALL DBESK(DX,DORD,ISCALE,IARG1,DTEMP1,NZERO)
      DTERM3=DTEMP1(IARG1)
      IF(DTERM3.LE.0.0D0)THEN
        PDF=0.0D0
        GOTO9000
      ENDIF
      DTERM3=DLOG(DTERM3)
C
      DTERM1=0.5D0*DLOG(DPI) + DLNGAM(ALPHA)
      DTERM2=(ALPHA-0.5D0)*DLOG(DX/2.0D0)
      DTERM4 = -DTERM1+DTERM2+DTERM3
      PDF=DEXP(DTERM4)
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE MCLPPF(P,ALPHA,PPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE MCLEISH DISTRIBUTION.  IT HAS
C              SHAPE PARAMETERS ALPHA.  THIS DISTRIBUTION IS DEFINED
C              FOR ALL REAL X AND HAS THE PROBABILITY DENSITY FUNCTION
C
C                 MCLPDF(X,ALPHA) = [1/(SQRT(PI)*GAMMA(ALPHA))]*
C                                   (ABS(X)/2)**(ALPHA-1/2)*
C                                   K(X,ALPHA-1/2)
C              WHERE
C                 K(X,N) IS THE MODIFIED BESSEL FUNCTION OF THE
C                        SECOND KIND
C                 GAMMA IS THE GAMMA FUNCTION
C
C              THE PERCENT POINT FUNCTION IS COMPUTED BY NUMERICALLY
C              INVERTING THE MCLEISH CUMULATIVE
C              DISTRIBUTION FUNCTION (WHICH IN TURN IS COMPUTED BY
C              NUMERICAL INTEGRATION OF THE PROBABILITYT DENSITY.
C
C     INPUT  ARGUMENTS--P       = THE DOUBLE PRECISION VALUE AT
C                                 WHICH THE PERCENT POINT
C                                 FUNCTION IS TO BE EVALUATED.
C                                 0 < P < 1
C                     --ALPHA   = THE FIRST SHAPE PARAMETER
C     OUTPUT ARGUMENTS--PPF     = THE SINGLE PRECISION PERCENT POINT
C                                 FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PERCENT POINT FUNCTION
C             VALUE PPF FOR THE MCLEISH
C             DISTRIBUTION WITH SHAPE PARAMETER = ALPHA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--DFZERO.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, (1994), "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME 1", SECOND EDITION,
C                 WILEY, PP. 50-53.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004.8
C     ORIGINAL VERSION--AUGUST    2004.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION P
      DOUBLE PRECISION PTEMPL
      DOUBLE PRECISION PTEMPU
      DOUBLE PRECISION ALPHA
      DOUBLE PRECISION PPF
      DOUBLE PRECISION DINC
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
C
      DOUBLE PRECISION DTEMP1(1000)
C
      DOUBLE PRECISION XUP
      DOUBLE PRECISION XUP2
      DOUBLE PRECISION XLOW
      DOUBLE PRECISION RE
      DOUBLE PRECISION AE
C
      DOUBLE PRECISION MCLFU2
      EXTERNAL MCLFU2
C
      DOUBLE PRECISION DP
      COMMON/MC2COM/DP
C
      DOUBLE PRECISION DALPHA
      COMMON/MCLCOM/DALPHA
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C               *****************************************
C               **  STEP 1--                           **
C               **  CHECK FOR VALID PARAMETERS         **
C               *****************************************
C
      IF(P.LE.0.0D0 .OR. P.GE.1.0D0)THEN
        WRITE(ICOUT,4)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,14)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,48)P
        CALL DPWRST('XXX','WRIT')
        PPF=0.0D0
        GOTO9000
      ENDIF
    4 FORMAT('***** ERROR: VALUE OF INPUT ARGUMENT (P) IN ',
     1       'MCLPPF ROUTINE')
   14 FORMAT('      IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL.')
      IF(ALPHA.LE.0.0D0)THEN
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,48)ALPHA
        CALL DPWRST('XXX','WRIT')
        PPF=0.0D0
        GOTO9000
      ENDIF
    5 FORMAT('***** ERROR: VALUE OF SHAPE PARAMETER (ALPHA)',
     1       ' IN MCLPPF ROUTINE IS NON-POSITIVE.')
C
   48 FORMAT('      VALUE OF ARGUMENT IS: ',G15.7)
C
      IF(P.EQ.0.5D0)THEN
        PPF=0.0D0
        GOTO9000
      ENDIF
C
C               *****************************************
C               **  STEP 2--                           **
C               **  COMPUTE THE PERCENT POINT FUNCTION.**
C               *****************************************
C
C  STEP 1: FIND BRACKETING INTERVAL.  START WITH -10 AND +10,
C          INCREMENT BY 10.
C
      XLOW=-10.0D0
      XUP2=10.0D0
      CALL MCLCDF(XLOW,ALPHA,PTEMPL)
      CALL MCLCDF(XUP2,ALPHA,PTEMPU)
      DINC=10.0D0
C
      MAXIT=1000
      NIT=0
C
  200 CONTINUE
      IF(NIT.GT.MAXIT)THEN
        PPF=0.0D0
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,131)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,133)
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
      CALL MCLCDF(XLOW,ALPHA,PTEMPL)
      CALL MCLCDF(XUP2,ALPHA,PTEMPU)
      IF(PTEMPL.LE.P .AND. P.LE.PTEMPU)THEN
        XUP=XUP2
        GOTO300
      ELSEIF(P.GT.PTEMPU)THEN
        XLOW=XUP2
        XUP2=XUP2 + DINC
        NIT=NIT+1
        GOTO200
      ELSEIF(P.LT.PTEMPL)THEN
        XUP2=XLOW
        XLOW=XLOW - DINC
        NIT=NIT+1
        GOTO200
      ENDIF
C
  300 CONTINUE
      AE=1.D-7
      RE=1.D-7
      DALPHA=ALPHA
      DP=P
      CALL DFZERO(MCLFU2,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 MCLPPF--')
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 MCLPPF--')
        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 MCLPPF--')
        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 MCLPPF--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,143)
  143   FORMAT('      MAXIMUM ITERATIONS EXCEEDED.')
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE MCLRAN(N,ALPHA,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE MCLEISH DISTRIBUTION WITH SHAPE
C              PARAMETER = ALPHA.  THIS DISTRIBUTION IS DEFINED
C              FOR ALL X AND HAS THE PROBABILITY DENSITY FUNCTION
C
C                 MCLPDF(X,ALPHA) = [1/(SQRT(PI)*GAMMA(ALPHA))]*
C                                   (ABS(X)/2)**(ALPHA-1/2)*
C                                   K(X,ALPHA-1/2)
C              WHERE
C                 K(X,N) IS THE MODIFIED BESSEL FUNCTION OF THE
C                        SECOND KIND
C                 GAMMA IS THE GAMMA FUNCTION
C
C              TO GENERATE RANDOM NUMBERS, USE THE RELATIONSHIP
C
C                    Y = SQRT(G)*Z
C
C              WITH G DENOTING A GAMMA RANDOM VARIABLE WITH SHAPE
C              ALPHA AND SCALE PARAMETER 2 AND Z A STANDARD NORMAL
C              RANDOM VARIABLE.
C
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --ALPHA  = THE SHAPE PARAMETER FOR THE
C                                MCLEISH DISTRIBUTION
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST N)
C                                INTO WHICH THE GENERATED
C                                RANDOM SAMPLE WILL BE PLACED.
C     OUTPUT--A RANDOM SAMPLE OF SIZE N FROM THE MCLEISH DISTRIBUTION
C             WITH SHAPE PARAMETER ALPHA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN, NORRAN, GAMRAN.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISNAN, "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME I", SECOND EDITION,
C                 WILEY, 1994, PP. 50-51.
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.8
C     ORIGINAL VERSION--AUGUST    2004.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
      DIMENSION Y(2)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----DATA STATEMENTS-------------------------------------------------
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)THEN
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,6)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
C
    5 FORMAT('***** ERROR--FOR THE MCLEISH DISTRIBUTION, THE REQUESTED')
    6 FORMAT('      NUMBER OF RANDOM NUMBERS WAS NON-POSITIVE.')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,'.')
CCC48 FORMAT('      VALUE OF ARGUMENT IS: ',G15.7)
C
C     MCLEISH IS DISTRIBUTION OF SQRT(G)*Z WHERE G IS A GAMMA
C     DISTRIBUTION WITH SHAPE PARAMETER ALPHA AND SCALE PARAMETER 2
C     T IS A STANDARD NORMAL DISTRIBUTION.
C
      CALL GAMRAN(N,ALPHA,ISEED,X)
      NTEMP=1
      DO100I=1,N
        G1=SQRT(2.0*X(I))
        CALL NORRAN(NTEMP,ISEED,Y)
        G2=Y(1)
        X(I)=G1*G2
  100 CONTINUE
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE MEAN(X,N,IWRITE,XMEAN,IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE
C              SAMPLE MEAN
C              OF THE DATA IN THE INPUT VECTOR X.
C              THE SAMPLE MEAN = (SUM OF THE OBSERVATIONS)/N.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF
C                                (UNSORTED OR SORTED) OBSERVATIONS.
C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR X.
C     OUTPUT ARGUMENTS--XMEAN  = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED SAMPLE MEAN.
C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
C             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--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                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (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         --JULY      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
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='MEAN'
      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 MEAN--')
      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 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 MEAN--')
      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 MEAN 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 MEAN--',
CCCCC1'THE 2ND INPUT ARGUMENT (N) HAS THE VALUE 1')
CCCCC CALL DPWRST('XXX','BUG ')
      XMEAN=X(1)
      GOTO9000
  129 CONTINUE
C
      HOLD=X(1)
      DO135I=2,N
      IF(X(I).NE.HOLD)GOTO139
  135 CONTINUE
CCCCC WRITE(ICOUT,999)
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC WRITE(ICOUT,136)HOLD
CC136 FORMAT('***** NON-FATAL DIAGNOSTIC IN MEAN--',
CCCCC1'THE FIRST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7)
CCCCC CALL DPWRST('XXX','BUG ')
      XMEAN=HOLD
      GOTO9000
  139 CONTINUE
C
  190 CONTINUE
C
C               *************************
C               **  STEP 2--           **
C               **  COMPUTE THE MEAN.  **
C               *************************
C
      DN=N
      DSUM=0.0D0
      DO200I=1,N
      DX=X(I)
      DSUM=DSUM+DX
  200 CONTINUE
      XMEAN=DSUM/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,XMEAN
  811 FORMAT('THE MEAN OF THE ',I8,' OBSERVATIONS = ',E15.7)
      CALL DPWRST('XXX','BUG ')
  890 CONTINUE
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'OFF')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF MEAN--')
      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)XMEAN
 9015 FORMAT('XMEAN = ',E15.7)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE MEBLOC(ISUBN1,ISUBN2,IBRANCH,MINN2,IANS,IWIDTH,
     1NUMARG,NUMV2,IHLEFT,NLEFT,IHHOR,NHOR)
C
C     PURPOSE--MESSAGE SUBROUTINE FOR DPBLOC--BLOCK PLOT ROUTINE
C
C     WRITTEN BY--JAMES J. FILLIBEN
C                 NATIONAL INSTITUTE OF STANDARDS & TECHNOLOGY
C                 GAITHERSBURG, MARYLAND 20899
C                 PHONE--301-975-2855
C     ORIGINAL VERSION--MAY     1992.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 IANS
      CHARACTER*4 IHLEFT
      CHARACTER*4 IHHOR
C
      DIMENSION IANS(*)
 
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
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,110)IBRANCH,ISUBN1,ISUBN2
  110 FORMAT('***** ERROR ',I6,'IN ',A4,A4,'--')
      CALL DPWRST('XXX','BUG ')
C
      IF(IBRANCH.EQ.310)GOTO310
      IF(IBRANCH.EQ.480)GOTO480
      IF(IBRANCH.EQ.510)GOTO510
      IF(IBRANCH.EQ.540)GOTO540
      GOTO9000
C
  310 CONTINUE
      WRITE(ICOUT,312)
  312 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,321)
  321 FORMAT('      (FOR WHICH A BLOCK PLOT ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,314)
  314 FORMAT('      WAS TO HAVE BEEN FORMED)')
      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 ')
      GOTO8000
C
  480 CONTINUE
      WRITE(ICOUT,482)
  482 FORMAT('      AT BRANCH POINT 481--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,483)
  483 FORMAT('      NUMARG LESS THAN 1 EVEN THOUGH')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,484)
  484 FORMAT('      NUMARG HAD PREVIOUSLY PASSED THIS TEST')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,485)NUMARG
  485 FORMAT('      ONCE ALREADY.  VALUE OF NUMARG = ',I8)
      CALL DPWRST('XXX','BUG ')
      GOTO8000
C
  510 CONTINUE
      WRITE(ICOUT,512)
  512 FORMAT('      FOR A BLOCK PLOT, ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,518)
  518 FORMAT('      THE NUMBER OF VARIABLES ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,519)
  519 FORMAT('      MUST BE 3 OR MORE;')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,520)
  520 FORMAT('      SUCH WAS NOT THE CASE HERE;')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,521)
  521 FORMAT('      THE SPECIFIED NUMBER')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,522)NUMV2
  522 FORMAT('      OF VARIABLES WAS ',I8)
      CALL DPWRST('XXX','BUG ')
      GOTO8000
C
  540 CONTINUE
      WRITE(ICOUT,542)
  542 FORMAT('      FOR A BLOCK PLOT, ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,543)
  543 FORMAT('      THE NUMBER OF ELEMENTS')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,544)
  544 FORMAT('      IN ALL THE VARIABLES ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,545)
  545 FORMAT('      MUST BE THE SAME; ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,546)
  546 FORMAT('      SUCH WAS NOT THE CASE HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,547)
  547 FORMAT('      THE FIRST  VARIABLE  (RESPONSE VALUES)--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,548)IHLEFT,NLEFT
  548 FORMAT('                  ',A4,'  HAS ',I8,' ELEMENTS')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,549)I
  549 FORMAT('      VARIABLE ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,550)IHHOR,NHOR
  550 FORMAT('                  ',A4,'  HAS ',I8,' ELEMENTS')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      GOTO8000
C
 8000 CONTINUE
      WRITE(ICOUT,8011)
 8011 FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
      CALL DPWRST('XXX','BUG ')
      IF(IWIDTH.GE.1)WRITE(ICOUT,8012)(IANS(I),I=1,IWIDTH)
 8012 FORMAT('      ',80A1)
      IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
      GOTO9000
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE MEDIA2(X,N,IWRITE,XMED,IBUGA3,IERROR)
C
C     NOTE--THIS SUBROUTINE IS IDENTICAL TO THE MEDIAN SUBROUTINE
C           AND WAS CREATED ONLY TO ACHIEVE ECONOMY OF MAPPING.
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE
C              SAMPLE MEDIAN
C              OF THE DATA IN THE INPUT VECTOR X.
C              THE SAMPLE MEDIAN = THAT VALUE SUCH THAT HALF THE
C              DATA SET IS BELOW IT AND HALF ABOVE IT.
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--XMED   = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED SAMPLE MEDIAN.
C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
C             SAMPLE MEDIAN.
C     RESTRICTIONS--THE MAXIMUM ALLOWABLE VALUE OF N
C                   FOR THIS SUBROUTINE IS 15000.
C     OTHER DATAPAC   SUBROUTINES NEEDED--SORT.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--KENDALL AND STUART, THE ADVANCED THEORY OF
C                 STATISTICS, VOLUME 1, EDITION 2, 1963, PAGE 326.
C               --KENDALL AND STUART, THE ADVANCED THEORY OF
C                 STATISTICS, VOLUME 2, EDITION 1, 1961, PAGE 49.
C               --DAVID, ORDER STATISTICS, 1970, PAGE 139.
C               --SNEDECOR AND COCHRAN, STATISTICAL METHODS,
C                 EDITION 6, 1967, PAGE 123.
C               --DIXON AND MASSEY, INTRODUCTION TO STATISTICAL
C                 ANALYSIS, EDITION 2, 1957, PAGE 70.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (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         --FEBRUARY  1976.
C     UPDATED         --JUNE      1979.
C     UPDATED         --AUGUST    1981.
C     UPDATED         --DECEMBER  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='MEDI'
      ISUBN2='AN  '
C
      IERROR='NO'
      IUPPER=MAXOBV
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 MEDIA2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)IBUGA3
   52 FORMAT('IBUGA3 = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)N
   53 FORMAT('N = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO55I=1,N
      WRITE(ICOUT,56)I,X(I)
   56 FORMAT('I,X(I) = ',I8,E15.7)
      CALL DPWRST('XXX','BUG ')
   55 CONTINUE
   90 CONTINUE
C
C               **********************
C               **  COMPUTE MEDIAN  **
C               **********************
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      AN=N
C
      IF(1.LE.N.AND.N.LE.IUPPER)GOTO119
      IERROR='YES'
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,111)
  111 FORMAT('***** ERROR IN MEDIA2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,112)
  112 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,113)
  113 FORMAT('      IN THE VARIABLE FOR WHICH')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,114)
  114 FORMAT('      THE MEDIAN IS TO BE COMPUTED')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,115)IUPPER
  115 FORMAT('      MUST BE BETWEEN 1 AND ',I8,' (INCLUSIVELY).')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,116)
  116 FORMAT('      SUCH WAS NOT THE CASE HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,117)N
  117 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8,
     1'.')
      CALL DPWRST('XXX','BUG ')
      GOTO9000
  119 CONTINUE
C
      IF(N.EQ.1)GOTO120
      GOTO129
  120 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,121)
  121 FORMAT('***** NON-FATAL DIAGNOSTIC IN MEDIA2--',
     1'THE 2ND INPUT ARGUMENT (N) HAS THE VALUE 1')
      CALL DPWRST('XXX','BUG ')
      XMED=X(1)
      GOTO9000
  129 CONTINUE
C
      GOTO139
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 MEDIA2--',
CCCCC1'THE FIRST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7)
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC XMED=HOLD
CCCCC GOTO9000
  139 CONTINUE
C
  190 CONTINUE
C
C               ***************************
C               **  STEP 2--             **
C               **  COMPUTE THE MEDIAN.  **
C               ***************************
C
      CALL SORT(X,N,Y)
C
      IEVODD=N-(N/2)*2
      NMID=N/2
      NMIDP1=NMID+1
      IF(IEVODD.EQ.0)XMED=(Y(NMID)+Y(NMIDP1))/2.0
      IF(IEVODD.EQ.1)XMED=Y(NMIDP1)
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,XMED
  811 FORMAT('THE MEDIAN 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 MEDIA2--')
      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)XMED
 9015 FORMAT('XMED = ',E15.7)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE MEDIAN(X,N,IWRITE,XTEMP,MAXNXT,XMED,IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE
C              SAMPLE MEDIAN
C              OF THE DATA IN THE INPUT VECTOR X.
C              THE SAMPLE MEDIAN = THAT VALUE SUCH THAT HALF THE
C              DATA SET IS BELOW IT AND HALF ABOVE IT.
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--XMED   = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED SAMPLE MEDIAN.
C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
C             SAMPLE MEDIAN.
C     OTHER DATAPAC   SUBROUTINES NEEDED--SORT.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--KENDALL AND STUART, THE ADVANCED THEORY OF
C                 STATISTICS, VOLUME 1, EDITION 2, 1963, PAGE 326.
C               --KENDALL AND STUART, THE ADVANCED THEORY OF
C                 STATISTICS, VOLUME 2, EDITION 1, 1961, PAGE 49.
C               --DAVID, ORDER STATISTICS, 1970, PAGE 139.
C               --SNEDECOR AND COCHRAN, STATISTICAL METHODS,
C                 EDITION 6, 1967, PAGE 123.
C               --DIXON AND MASSEY, INTRODUCTION TO STATISTICAL
C                 ANALYSIS, EDITION 2, 1957, PAGE 70.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (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         --FEBRUARY  1976.
C     UPDATED         --JUNE      1979.
C     UPDATED         --AUGUST    1981.
C     UPDATED         --MAY       1982.
C     UPDATED         --FEBRUARY  1988.  (COMMENTED OUT INPUT ERROR MESSAGES)
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
      DIMENSION XTEMP(*)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='MEDI'
      ISUBN2='AN  '
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 MEDIAN--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)IBUGA3
   52 FORMAT('IBUGA3 = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)N
   53 FORMAT('N = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO55I=1,N
      WRITE(ICOUT,56)I,X(I)
   56 FORMAT('I,X(I) = ',I8,E15.7)
      CALL DPWRST('XXX','BUG ')
   55 CONTINUE
   90 CONTINUE
C
C               **********************
C               **  COMPUTE MEDIAN  **
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 MEDIAN--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,112)
  112 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,113)
  113 FORMAT('      IN THE VARIABLE FOR WHICH')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,114)
  114 FORMAT('      THE MEDIAN IS TO BE COMPUTED')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,115)MAXNXT
  115 FORMAT('      MUST BE BETWEEN 1 AND ',I8,' (INCLUSIVELY).')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,116)
  116 FORMAT('      SUCH WAS NOT THE CASE HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,117)N
  117 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8,
     1'.')
      CALL DPWRST('XXX','BUG ')
      GOTO9000
  119 CONTINUE
C
      IF(N.EQ.1)GOTO120
      GOTO129
  120 CONTINUE
CCCCC WRITE(ICOUT,999)
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC WRITE(ICOUT,121)
CC121 FORMAT('***** NON-FATAL DIAGNOSTIC IN MEDIAN--',
CCCCC1'THE 2ND INPUT ARGUMENT (N) HAS THE VALUE 1')
CCCCC CALL DPWRST('XXX','BUG ')
      XMED=X(1)
      GOTO9000
  129 CONTINUE
C
      HOLD=X(1)
      DO135I=2,N
      IF(X(I).NE.HOLD)GOTO139
  135 CONTINUE
CCCCC WRITE(ICOUT,999)
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC WRITE(ICOUT,136)HOLD
CC136 FORMAT('***** NON-FATAL DIAGNOSTIC IN MEDIAN--',
CCCCC1'THE FIRST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7)
CCCCC CALL DPWRST('XXX','BUG ')
      XMED=HOLD
      GOTO9000
  139 CONTINUE
C
  190 CONTINUE
C
C               ***************************
C               **  STEP 2--             **
C               **  COMPUTE THE MEDIAN.  **
C               ***************************
C
      CALL SORT(X,N,XTEMP)
C
      IEVODD=N-(N/2)*2
      NMID=N/2
      NMIDP1=NMID+1
      IF(IEVODD.EQ.0)XMED=(XTEMP(NMID)+XTEMP(NMIDP1))/2.0
      IF(IEVODD.EQ.1)XMED=XTEMP(NMIDP1)
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,XMED
  811 FORMAT('THE MEDIAN 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 MEDIAN--')
      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)XMED
 9015 FORMAT('XMED = ',E15.7)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE MIDMEA(X,N,IWRITE,XTEMP,MAXNXT,XMIDM,IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE
C              SAMPLE MIDMEAN = THE
C              SAMPLE 25% (ON EACH SIDE) TRIMMED MEAN
C              OF THE DATA IN THE INPUT VECTOR X.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF
C                                (UNSORTED OR SORTED) OBSERVATIONS.
C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR X.
C     OUTPUT ARGUMENTS--XMIDM  = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED SAMPLE MIDMEAN.
C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
C             SAMPLE MIDMEAN.
C     OTHER DATAPAC   SUBROUTINES NEEDED--SORT.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--DAVID, ORDER STATISTICS, 1970, PAGES 129, 136.
C               --CROW AND SIDDIQUI, 'ROBUST ESTIMATION OF LOCATION',
C                 JOURNAL OF THE AMERICAN STATISTICAL ASSOCIATION,
C                 1967, PAGES 357, 387.
C               --FILLIBEN, SIMPLE AND ROBUST LINEAR ESTIMATION
C                 OF THE LOCATION PARAMETER OF A SYMMETRIC
C                 DISTRIBUTION (UNPUBLISHED PH.D. DISSERTATION,
C                 PRINCETON UNIVERSITY, 1969).
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (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         --FEBRUARY  1976.
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
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DK
      DOUBLE PRECISION DX
      DOUBLE PRECISION DSUM
C
      DIMENSION X(*)
      DIMENSION XTEMP(*)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='MIDM'
      ISUBN2='EA  '
C
      IERROR='NO'
C
      IF(IBUGA3.EQ.'OFF')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF MIDMEA--')
      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 MIDMEAN  **
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 MIDMEA--')
      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 MIDMEAN IS TO BE COMPUTED')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,115)MAXNXT
  115 FORMAT('      MUST BE BETWEEN 1 AND ',I8,' (INCLUSIVELY).')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,116)
  116 FORMAT('      SUCH WAS NOT THE CASE HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,117)N
  117 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8,
     1'.')
      CALL DPWRST('XXX','BUG ')
      GOTO9000
  119 CONTINUE
C
      IF(N.EQ.1)GOTO120
      GOTO129
  120 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,121)
  121 FORMAT('***** NON-FATAL DIAGNOSTIC IN MIDMEA--',
     1'THE 2ND INPUT ARGUMENT (N) HAS THE VALUE 1')
      CALL DPWRST('XXX','BUG ')
      XMIDM=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 MIDMEA--',
     1'THE FIRST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      XMIDM=HOLD
      GOTO9000
  139 CONTINUE
C
  190 CONTINUE
C
C               ****************************
C               **  STEP 2--              **
C               **  COMPUTE THE MIDMEAN.  **
C               ****************************
C
      CALL SORT(X,N,XTEMP)
C
      P1=0.25
      NP1=P1*AN+0.0001
      ISTART=NP1+1
C
      P2=0.25
      NP2=P2*AN+0.0001
      ISTOP=N-NP2
C
      DSUM=0.0
      K=0
      IF(ISTART.GT.ISTOP)GOTO250
      DO200I=ISTART,ISTOP
      K=K+1
      DX=X(I)
      DSUM=DSUM+DX
  200 CONTINUE
      DK=K
      XMIDM=DSUM/DK
      GOTO290
C
  250 CONTINUE
      IERROR='YES'
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,251)
  251 FORMAT('***** INTERNAL ERROR IN MIDMEA--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,252)
  252 FORMAT('      START INDEX IS HIGHER THAN STOP INDEX.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,253)ISTART,ISTOP
  253 FORMAT('      ISTART,ISTOP = ',2I8)
      CALL DPWRST('XXX','BUG ')
      GOTO9000
  290 CONTINUE
C
C               *******************************
C               **  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 ')
      PERP1=100.0*P1
      PERP2=100.0*P2
      PERP3=100.0*(1.0-P1-P2)
      WRITE(ICOUT,811)PERP1,NP1
  811 FORMAT(8X,F10.4,' PERCENT (= ',I8,' OBSERVATIONS) ',
     1'OF THE DATA WERE TRIMMED         FROM BELOW')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,812)PERP2,NP2
  812 FORMAT(8X,F10.4,' PERCENT (= ',I8,' OBSERVATIONS) ',
     1'OF THE DATA WERE TRIMMED         FROM ABOVE')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,813)PERP3,K
  813 FORMAT(8X,F10.4,' PERCENT (= ',I8,' OBSERVATIONS) ',
     1'OF THE DATA REMAIN IN MIDDLE AFTER TRIMMING')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,821)N,XMIDM
  821 FORMAT('THE MIDMEAN 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 MIDMEA--')
      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)XMIDM
 9015 FORMAT('XMIDM = ',E15.7)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE MIDRAN(X,N,IWRITE,XMIDR,IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE
C              SAMPLE MIDRANGE
C              OF THE DATA IN THE INPUT VECTOR X.
C              THE SAMPLE MIDRANGE = (SAMPLE MIN + SAMPLE MAX)/2.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF
C                                (UNSORTED OR SORTED) OBSERVATIONS.
C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR X.
C     OUTPUT ARGUMENTS--XMIDR  = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED SAMPLE MIDRANGE.
C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
C             SAMPLE MIDRANGE.
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               --KENDALL AND STUART, THE ADVANCED THEORY OF
C                 STATISTICS, VOLUME 2, EDITION 1, 1961, PAGE 91.
C               --DAVID, ORDER STATISTICS, 1970, PAGE 97.
C               --DIXON AND MASSEY, INTRODUCTION TO STATISTICAL
C                 ANALYSIS, EDITION 2, 1957, PAGE 71.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (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
      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='MIDR'
      ISUBN2='AN  '
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 MIDRAN--')
      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 MIDRANGE  **
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 MIDRAN--')
      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 MIDRANGE 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 MIDRAN--',
     1'THE 2ND INPUT ARGUMENT (N) HAS THE VALUE 1')
      CALL DPWRST('XXX','BUG ')
      XMIDR=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 MIDRAN--',
     1'THE FIRST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      XMIDR=HOLD
      GOTO9000
  139 CONTINUE
C
  190 CONTINUE
C
C               *****************************
C               **  STEP 2--               **
C               **  COMPUTE THE MIDRANGE.  **
C               *****************************
C
      XMIN=X(1)
      XMAX=X(1)
      DO200I=1,N
      IF(X(I).LT.XMIN)XMIN=X(I)
      IF(X(I).GT.XMAX)XMAX=X(I)
  200 CONTINUE
      XMIDR=(XMIN+XMAX)/2.0
C
C               *******************************
C               **  STEP 3--                 **
C               **  WRITE OUT A LINE         **
C               **  OF SUMMARY INFORMATION.  **
C               *******************************
C
      IF(IFEEDB.EQ.'OFF')GOTO890
      IF(IWRITE.EQ.'OFF')GOTO890
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,811)N,XMIDR
  811 FORMAT('THE MIDRANGE 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 MIDRAN--')
      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)XMIDR
 9015 FORMAT('XMIDR = ',E15.7)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE MINDIS(AMAT,AMAT2,MAXROM,MAXCOM,NR1,NC1,P,ICASE,
     1IWRITE,IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE
C              MINKOWSKI DISTANCE OF A MATRIX.  THE FORMULA IS:
C                 Dij=SUM(ABS|(Xik - Xjk)|**P)**(1/P)
C              THE SUM IS FROM K = 1 TO P (WHERE THERE ARE P
C              COLUMNS IN THE MATRIX).  FOR EXAMPLE, D23 IS
C              THE DISTANCE BETWEEN THE SECOND AND THIRD ROWS.
C              (ALTERNATIVELY, THE DISTANCE CAN BE CALCULATED
C              ACROSS COLUMNS).
C     INPUT  ARGUMENTS--AMAT   = THE SINGLE PRECISION MATRIX
C                     --MAXROM = THE INTEGER ROW DIMENSION OF AMAT
C                     --MAXCOM = THE INTEGER COUMN DIMENSION OF AMAT
C                     --NR1    = THE INTEGER NUMBER OF ROWS OF AMAT
C                     --NC1    = THE INTEGER NUMBER OF COLUMNS OF AMAT
C     OUTPUT ARGUMENTS--AMAT2    = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED SAMPLE MINKOWSKI DISTANCES.
C     OUTPUT--MATRIX OF MINKOWSKI DISTANCES
C     NOTE--THIS ROUTINE ASSUMES THE ERROR CHECKING (FOR EQUAL
C           ROWS AND COLUMNS, MATCHING DIMENSIONS FOR X AND AMAT)
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     LANGUAGE--ANSI FORTRAN (1977)
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--98.7
C     ORIGINAL VERSION--JULY      1998.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 ICASE
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DSUM
      DOUBLE PRECISION DYM1
      DOUBLE PRECISION DYM2
C
      DIMENSION AMAT(MAXROM,MAXCOM)
      DIMENSION AMAT2(MAXROM,MAXCOM)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='CHED'
      ISUBN2='IS  '
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 MINDIS--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)IBUGA3
   52 FORMAT('IBUGA3 = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)NR1,NC1
   53 FORMAT('NR1, NC1 = ',2I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,54)ICASE
   54 FORMAT('ICASE = ',A4)
      CALL DPWRST('XXX','BUG ')
   90 CONTINUE
C
C               ********************************
C               **  COMPUTE MINKOWSKI DISTANCE *
C               ********************************
C
      IF(ICASE.EQ.'ROW ')THEN
        DO5861I=1,NR1
          DO5863J=1,I
            IF(I.EQ.1)THEN
              AMAT2(I,I)=0.0
            ELSE
              DSUM=0.0D0
              DO5865K=1,NC1
                DYM1=AMAT(I,K)
                DYM2=AMAT(J,K)
                DSUM=DSUM + DABS(DYM1-DYM2)**DBLE(P)
 5865         CONTINUE
              AMAT2(I,J)=REAL(DSUM**(1.0D0/DBLE(P)))
              AMAT2(J,I)=AMAT2(I,J)
            ENDIF
 5863     CONTINUE
 5861   CONTINUE
      ELSEIF(ICASE.EQ.'COLU')THEN
        DO5961I=1,NC1
          DO5963J=1,I
            IF(I.EQ.J)THEN
              AMAT2(I,I)=0.0
            ELSE
              DSUM=0.0D0
              DO5965K=1,NR1
                DYM1=AMAT(K,I)
                DYM2=AMAT(K,J)
                DSUM=DSUM + DABS(DYM1-DYM2)**DBLE(P)
 5965         CONTINUE
              AMAT2(I,J)=REAL(DSUM**(1.0D0/DBLE(P)))
              AMAT2(J,I)=AMAT2(I,J)
            ENDIF
 5963     CONTINUE
 5961   CONTINUE
      ENDIF
C
C               *******************************
C               **  STEP 3--                 **
C               **  WRITE OUT A LINE         **
C               **  OF SUMMARY INFORMATION.  **
C               *******************************
C
      IF(IFEEDB.EQ.'OFF')GOTO890
      IF(IWRITE.EQ.'OFF')GOTO890
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,811)
  811 FORMAT('THE MINKOWSKI DISTANCE MATRIX HAS BEEN CALCULATED.')
      CALL DPWRST('XXX','BUG ')
  890 CONTINUE
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'OFF')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF MINDIS--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IBUGA3,IERROR
 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE MINIM(X,N,IWRITE,XMIN,IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE
C              SAMPLE MINIMUM
C              OF THE DATA IN THE INPUT VECTOR X.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF
C                                (UNSORTED OR SORTED) OBSERVATIONS.
C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR X.
C     OUTPUT ARGUMENTS--XMIN   = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED SAMPLE MINIMUM.
C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
C             SAMPLE MINIMUM.
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--DAVID, ORDER STATISTICS, 1970, PAGE 7.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--82.6
C     ORIGINAL VERSION--JUNE      1972.
C     UPDATED         --SEPTEMBER 1975.
C     UPDATED         --NOVEMBER  1975.
C     UPDATED         --JUNE      1979.
C     UPDATED         --AUGUST    1981.
C     UPDATED         --MAY       1982.
C     UPDATED         --FEBRUARY  1988. (SUPPRESS SOME DIAGNOSTIC MESSAGES)
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='MINI'
      ISUBN2='M   '
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 MINIM--')
      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 MINIMUM  **
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 MINIM--')
      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 MINIMUM 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 MINIM--',
CCCCC1'THE 2ND INPUT ARGUMENT (N) HAS THE VALUE 1')
CCCCC CALL DPWRST('XXX','BUG ')
      XMIN=X(1)
      GOTO9000
  129 CONTINUE
C
      HOLD=X(1)
      DO135I=2,N
      IF(X(I).NE.HOLD)GOTO139
  135 CONTINUE
CCCCC WRITE(ICOUT,999)
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC WRITE(ICOUT,136)HOLD
CC136 FORMAT('***** NON-FATAL DIAGNOSTIC IN MINIM--',
CCCCC1'THE FIRST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7)
CCCCC CALL DPWRST('XXX','BUG ')
      XMIN=HOLD
      GOTO9000
  139 CONTINUE
C
  190 CONTINUE
C
C               ****************************
C               **  STEP 2--              **
C               **  COMPUTE THE MINIMUM.  **
C               ****************************
C
      XMIN=X(1)
      DO200I=2,N
      IF(X(I).LT.XMIN)XMIN=X(I)
  200 CONTINUE
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,XMIN
  811 FORMAT('THE MINIMUM 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 MINIM--')
      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)XMIN
 9015 FORMAT('XMIN = ',E15.7)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      subroutine mixtur(a, k, m, c, x, n, 
     +    alpha, mean, sd, tol, nobvs,
     +    newalp,newmea,newsd,dt,nt,vt,g,f,kmax,mmax,
     +    logl, counter, ifault)
c
c     Translation from Algol 60 by Alan Miller of AS 203.
c
c     ALGORITHM AS 203 APPL. STATIST. (1984) VOL.33, NO. 3
c
c     This algorithm calculates the maximum likelihood estimates of the
c     parameters of a mixture of normal or exponential or Poisson or
c     binomial distributions.   These parameters are the mixing
c     proportions, the means and (in the normal distribution case)
c     standard deviations.   It also calculates the log-likelihood
c     function and the number of iterations taken to satisfy the
c     tolerance value.
c
c     Users must provide their own routine `putout' which prints the
c     estimated parameter values after each iteration.   The form of
c     this routine is:
c        subroutine putout(k, alpha, mean, sd, logl)
c        integer k
c        real alpha(k), mean(k), sd(k), logl
c
c     Notes:
c     The original (Algol) variable names have been retained.   This
c     means that some variable names have more than 6 characters, such
c     as `counter', `newalp', etc.
c
c     NOTE: For Dataplot, variable names have been modified to be
c           six characters or less.
c
c     The authors treat the normal distribution as if it were a discrete
c     distribution.
c     In Fortran 77 it is necessary to give explicit dimensions to some
c     of the temporary arrays which are not passed as arguments.
c     Maximum values have been set for k and m (kmax and mmax) in the
c     parameter statement under `Local variables' below.
c
c     NOTE: For Dataplot, dimension in calling routine and pass
c           in to this routine.
c
      integer a, k, m, c, n(m), nobvs, icount, ifault
      real x(m), alpha(k), mean(k), sd(k), tol, logl
ccccc external putout
c
c     Local variables
c
      integer kmax, mmax, i, j
ccccc parameter (kmax = 20, mmax = 100)
      logical test
      real sumalp, part, oldlgl
      real zero, one, half
c
      real newalp(kmax)
      real newmea(kmax)
      real newsd(kmax)
      real dt(kmax)
      real nt(kmax)
      real vt(kmax)
c
      real g(mmax)
      real f(mmax, kmax)
c
      data zero /0.0/, one /1.0/, half /0.5/
c
      if (a .lt. 1 .or. a .gt. 4) then
        ifault = 1
        return
      else
        ifault = 0
      end if

      do 10 i = 1, m-1
        if (x(i) .gt. x(i+1)) then
          ifault = 5
          return
        end if
   10 continue

      if (nobvs .lt. 2 * m) then
        ifault = 6
        return
      end if

      do 20 i = 1, m
        if (n(i) .lt. 0) then
          ifault = 6
          return
        end if
        if (a .ne. 1) then
          if (x(i) .lt. zero) then
            ifault = 7
            return
          end if
        end if
   20 continue

      oldlgl = zero
      icount = 0 
c
c     Start of iterative cycle
c
   30 icount = icount + 1
      do 40 j = 1, k
        if (alpha(j) .gt. one .or. alpha(j) .lt. zero) then
          ifault = 2
          return
        end if
        if (mean(j) .ge. x(m) .or. mean(j) .le. x(1)) then
          ifault = 3
          return
        end if
        if (a .eq. 1) then
          if (sd(j) .le. zero) then
            ifault = 4
            return
          end if
        end if
   40 continue

      do 60 i = 1, k-1
        do 50 j = i+1, k
          if (mean(i) .eq. mean(j)) then
            if (a .eq. 1) then
              if (sd(i) .eq. sd(j)) then
                ifault = 9
                return
              end if
            else
              ifault = 8
              return
            end if
          end if
   50   continue
   60 continue

      logl = zero
      do 80 i = 1, m
        g(i) = zero
        do 70 j = 1, k
c
c     a = 1 denotes normal mixture
c     a = 2 denotes exponential mixture
c     a = 3 denotes Poisson mixture
c     a = 4 denotes binomial mixture
c
          if (a .eq. 1) then
            f(i,j) = exp(-half*((x(i) - mean(j))/sd(j))**2) / sd(j)
          else if (a .eq. 2) then
            f(i,j) = exp(-x(i)/mean(j)) / mean(j)
          else if (a .eq. 3) then
            if (x(i) .eq. x(1)) then
              f(i,j) = exp(-mean(j)) * mean(j)**x(i)
            else
              f(i,j) = f(i-1,j) * mean(j)
            end if
          else
            if (x(i) .eq. x(1)) then
              f(i,j) = (one - mean(j) / x(m))**x(m) * (mean(j) /
     +                  (x(m) - mean(j)))**x(i)
            else
              f(i,j) = f(i-1,j) * (mean(j) / (x(m) - mean(j)))
            end if
          end if
          g(i) = g(i) + alpha(j) * f(i,j)
   70   continue
        logl = logl + n(i) * log(g(i))
   80 continue
c
c     Calculation of the probability densities of the sub-populations
c     which form the mixture, and the log-likelihood function.
c
      test = .false.
      sumalp = zero
      do 100 j = 1, k
        nt(j) = zero
        dt(j) = zero
        vt(j) = zero
        do 90 i = 1, m
          part = f(i,j) * n(i) / g(i)
          dt(j) = dt(j) + part
          nt(j) = nt(j) + part * x(i)
          if (a .eq. 1) vt(j) = vt(j) + part * (x(i) - mean(j))**2
   90   continue
c
c     Calculation of denominators and numerators of new estimates.
c
        newmea(j) = nt(j) / dt(j)
        if (j .ne. k) then
          newalp(j) = alpha(j) * dt(j) / nobvs
          sumalp = sumalp + newalp(j)
        else
          newalp(k) = one - sumalp
        end if
        if (a .eq. 1) newsd(j) = sqrt(vt(j) / dt(j))
c
c     Convergence test.
c
        if (abs(oldlgl - logl) .gt. tol) test = .true.
        oldlgl = logl
        alpha(j) = newalp(j)
        mean(j) = newmea(j)
        if (a .eq. 1) sd(j) = newsd(j)
  100 continue
c
      if (c .gt. 0) then
        if ((icount/c)*c .eq. icount) then
ccccc     call putout(k, alpha, mean, sd, logl)
        end if
      end if

      if (test) go to 30
      return
      end
      SUBROUTINE MLEGEV(X, N, PARA, VCOV, MONIT, IFAULT)
         
C        ALGORITHM AS215   APPL. STATIST. (1985) VOL. 34, NO. 3
C        Modifications in AS R76 (1989) have been incorporated.
C
C        MAXIMUM-LIKELIHOOD ESTIMATION OF GENERALIZED EXTREME-VALUE
C        DISTRIBUTION
C
      DOUBLE PRECISION PARA(3), VCOV(6), X(N)
      DOUBLE PRECISION A, ACCA, ACCG, ACCU, AI, AIGI, AN, D, DA, DAA,
     *  DAG, DELA, DELG, DELU, DG, DGG, DU, DUA, DUG, DUU, E, F, FOLD,
     *  G, GAI, GG, GI, GIPQ, GNORM, H, HALF, HE, HH, ONE, P, PA, PQ,
     *  PQG, PU, Q, QA, QU, R, RA, RATIO, RG, RU, SE, SH, SHE, SHH,
     *  SHHE, SMALL, SRF, STEPA, STEPG, STEPU, SY, SYE, SYHE, SYYE,
     *  TEMP1, TEMP2, U, VLNEG, XMAX, XMIN, Y, YE, Z, ZERO
      CHARACTER*8 ACTI1, ACTI2, ACTI3, ACTI4, ACTI5, ACTI6, ACTI7,
     *  ACTI8, ACTI9
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      DATA ACTI1/'  NEWTON'/, ACTI2/'  ST.ASC'/, ACTI3/'  RESETK'/,
     *  ACTI4/'  SR.INF'/, ACTI5/'  SR.LIK'/, ACTI6/'  MAX.SR'/,
     *  ACTI7/'  MAX.EV'/, ACTI8/'  MAX.IT'/, ACTI9/'  CONVGD'/
      DATA ZERO /0.0D0/, HALF /0.5D0/, ONE/1.0D0/
C
C        ADDU,ACCA,ACCG ARE ACCURACY CRITERIA FOR TESTING CONVERGENCE
C        STEPU,STEPA,STEPG ARE MAXIMUM STEPLENGTHS FOR ITERATIONS
C        ACCU,ACCA,STEPU,STEPA ARE SCALED BY CURRENT VALUE OF A WHEN
C        USED IN PROGRAM
C
CCCCC DATA ACCU, ACCA, ACCG /3 * 1.0D-5/, STEPU, STEPA, STEPG /
      DATA ACCU /0.00001D0/
      DATA ACCA /0.00001D0/
      DATA ACCG /0.00001D0/
      DATA STEPU /0.5D0/
      DATA STEPA /0.25D0/
      DATA STEPG /0.01D0/
C        
C        MAXIT IS MAX. NO. OF ITERATIONS
C        MAXEV IS MAX. NO. OF EVALUATIONS OF LIKELIHOOD FUNCTION
C        SRF IS STEPLENGTH REDUCTION FACTOR
C        MAXSR IS MAX. NO. OF STEPLENGTH REDUCTIONS PERMITTED PER
C        ITERATION
C
CCCCC DATA MAXIT /30/, MAXEV /50/, SRF /0.25D0/, MAXSR /30/
      DATA MAXIT /300/, MAXEV /500/, SRF /0.25D0/, MAXSR /30/
C        
C        SMALL IS A SMALL NUMBER, USED TO ADJUST THE SHAPE PARAMETER TO
C        AVOID AN EXACT ZERO VALUE OR BORDERLINE INFEASIBILITY
C        ALNEG IS A LARGE NEGATIVE NUMBER, USED TO INITIALIZE
C        LOG-LIKELIHOOD
C
      DATA SMALL /1.D-3/, VLNEG /-1.D37/
C
C        FIND MIN AND MAX DATA VALUE
C
      DO 10 I = 1, 6
  10  VCOV(I) = ZERO
      IFAULT = 1
      IF (N .LE. 2) GOTO 170
      XMIN = X(1)
      XMAX = X(1)
      DO 20 I = 2, N
        IF (X(I) .LT. XMIN) XMIN = X(I)
        IF (X(I) .GT. XMAX) XMAX = X(I)
   20 CONTINUE
C
C       INITIALIZATION
C       U IS LOCATION PARAMETER
C       A IS SCALE PARAMETER
C       G IS SHAPE PARAMETER
C
      IF (MONIT .GT. 0) THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE (ICOUT, 6000)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE (ICOUT, 6003)
        CALL DPWRST('XXX','BUG ')
      ENDIF
  999 FORMAT(1X)
 6000 FORMAT(' MAXIMUM-LIKELIHOOD ESTIMATION OF GENERALIZED EXTREME',
     *  1X, 'VALUE DISTRIBUTION')
 6003 FORMAT(' ITER EVAL', 8X, 'XI', 5X, 'ALPHA',
     *  9X, 'K  ACTION', 6X, 'LOG-L', 7X, 'GNORM')
C
      IFAULT = 0
      NITER = 0
      NEVAL =0
      FOLD = VLNEG
      U = PARA(1)
      A = PARA(2)
      G = PARA(3)
      IF (G .EQ. ZERO) G = SMALL
      IF (Z .LE. ZERO) A = ONE
      AN = DBLE(FLOAT(N))
C
C        CHECK WHETHER ALL DATA POINTS LIE WITHIN THE RANGE OF THE GEV
C        DISTRIBUTION WITH THE INITIAL PARAMETERS - IF NOT, ADJUST THE
C        SHAPE PARAMETER SO AS TO BRING ALL POINTS WITHIN RANGE
C
      IF (G .GT. ZERO) GOTO 30
      IF (XMIN .GE. U) GOTO 40
      Z = A / (XMIN - U)
      IF (MONIT .GT. 0) THEN
        WRITE (ICOUT, 6010) NITER, NEVAL, U, A, G, ACTI3
        CALL DPWRST('XXX','BUG ')
      ENDIF
 6010 FORMAT(1X, I4, I5, 3F10.4, 1X, A, F11.3, 1PD12.2)
C
      G = Z + SMALL
      IF (G .GE. ZERO) G = HALF * Z
      GOTO 40
   30 IF (XMAX .LE. U) GOTO 40
      Z = A / (XMAX - U)
      IF (G .LT. Z) GOTO 40
      IF(MONIT .GT. 0) THEN
        WRITE (ICOUT, 6010) NITER, NEVAL, U, A, G, ACTI3
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      G = Z - SMALL
      IF (G .LE. ZERO) G = HALF * Z
C
C        START OF MAIN LOOP
C
   40 DO 140 NITER = 1, MAXIT
C
      NSR = 0
   50 IF (NEVAL .GE. MAXEV) GOTO 150
      NEVAL = NEVAL + 1
      AI = ONE / A
      GI = ONE /G
      GAI = G * AI
      AIGI = AI * GI
      GG = ONE - G
C        
C       ACCUMULATE SUMS OF QUANTITIES OCCURRING IN LIKELIHOOD
C       DERIVATIVES
C
C       IN PRESCOTT AND WALDEN'S NOTATION:
C       Z IS 1 - K * (X(I)-U) / A
C       Y IS THE REDUCED VARIATE - (1/K) * LOG(Z)
C       E IS EXP(-Y)
C       H IS EXP(K*Y)
C
      SY = ZERO
      SE = ZERO
      SYE = ZERO
      SYYE = ZERO
      SH = ZERO
      SHE = ZERO
      SYHE = ZERO
      SHHE = ZERO
      SHH = ZERO
      DO 60 I = 1, N
        Z = ONE -GAI * (X(I) - U)
        Y = -GI * LOG(Z)
        E = EXP(-Y)
        H = ONE / Z
        YE = Y * E
        HE = H * E
        HH = H * H
        SY = SY + Y
        SY = SY + E
        SYE = SYE + YE
        SYYE = SYYE + Y * YE
        SH = SH + H
        SHE = SHE + HE
        SYHE = SYHE + Y * HE
        SHHE = SHHE + HH * E
        SHH = SHH + HH
   60 CONTINUE
C
C       F IS CURRENT VALUE OF LIKELIHOOD FUNCTIONN
C
      F = -AN * LOG(A) - GG * SY - SE
      IF (F .GT. FOLD) GOTO 90
C
C       LIKELIHOOD HAS NOT INCREASED - REDUCE STEPLENGTH AND TRY AGAIN
C
      IF (MONIT .GT. 0) THEN
        WRITE(ICOUT, 6010) NITER, NEVAL, U, A, G, ACTI5, F
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      IF (NSR .EQ. MAXSR) GOTO 80
   70 NSR = NSR + 1
      U = U - DELU
      A = A - DELA
      G = G - DELG
      DELU = SRF * DELU
      DELA = SRF * DELA
      DELG = SRF * DELG
      U = U + DELU
      A = A + DELA
      G = G + DELG
      IF (A .GT. G * (XMIN - U) .AND. A .GT. G * (XMAX - U) .AND. G .NE.
     *  ZERO) GO TO 50
      IF (MONIT .GT. 0) THEN
        WRITE (ICOUT, 6010) NITER, NEVAL, U, A, G, ACTI4
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      IF (NSR .LT. MAXSR) GOTO 70
C
C        MAX. NO. OF STEPLENGTH REDUCTIONS REACHED
C        IF CURRENT ITERATION IS NEWTON-RAPHSON, TRY STEEPEST ASCENT
C        INSTEAD.  IF CURRENT ITERATION IS STEEPEST ASCENT, GIVE UP.
C
   80 U = U - DELU
      A = A - DELA
      G = G - DELG
      IF (MONIT .GT. 0) THEN
        WRITE(ICOUT, 6010) NITER, NEVAL, U, A, G, ACTI6
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      IF (ITYPE .EQ. 1) GOTO 100
      IFAULT = 4
      GOTO 160
C
C        P,Q,R, ARE AS DEFINED IN FLOOD STUDIES REPORT
C
   90 FOLD = F
      P = AN - SE
      Q = SHE - GG * SH
      R = AN - SY + SYE
      PQ = P + Q
      GIPQ = GI * PQ
C
C        FIRST DERIVATIVES OF LOG-LIKELIHOOD
C
      DU = -AI * Q
      DA = -AIGI * PQ
      DG = -GI * (R - GIPQ)
      IF (MONIT .GT. 0) GNORM = SQRT(DU * DU + DA * DA + DG * DG)
C
C        DERIVATIVES OF P,Q,R
C
      PU = -AI * SHE
      PA = GI * PU + AIGI * SE
      QU = GG * AI * (SHHE + G * SHH)
      RU = AI * (SH - SHE + SYHE)
      RA = GI * RU - AIGI * (AN - SE + SYE)
      RG = GI * (SY - SYE + SYYE - A * RA)
      QA = AI * Q + GI * (PU + QU)
      PQG = GIPQ + A * (RA - GI * (PA + QA))
C
C         MINUS SECOND DERIVATIVE OF LOG-LIKELIHOOD (HESSIAN MATRIX)
C
      DUU = AI * QU
      DUA = AIGI * (PU + QU)
      DAA = -AIGI * (AI * PQ - PA - QA)
      DUG = GI * (RU - GI * (PU + QU))
      DAG = -AIGI * (GIPQ - PQG)
      DGG = GI * (RG - GI * (PQG + R - GIPQ - GIPQ))
C
C         INVERT HESSIAN MATRIX
C
      DO 95 KK = 1, 3
        IF (DUU .LE. ZERO) GO TO 100
        D = ONE / DUU
        TEMP1 = -DUA * D
        IF (KK .GT. 2) TEMP1 = -TEMP1
        TEMP2 = -DUG * D
        IF (KK .GT. 1) TEMP2 = -TEMP2
        DUU = DAA + TEMP1 * DUA
        DUA = DAG + TEMP1 * DUG
        DAA = DGG + TEMP2 * DUG
        DUG = TEMP1
        DAG = TEMP2
        DGG = D
   95 CONTINUE
C
C        CALCULATE STEPLENGTHS
C
      ITYPE = 1
      IF (MONIT .GT. 0) THEN
        WRITE(ICOUT, 6010) NITER, NEVAL, U, A, G, ACTI1, F, GNORM
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      DELU = DUU * DU + DUA * DA + DUG * DG
      DELA = DUA * DU + DAA * DA + DAG * DG
      DELG = DUG * DU + DAG * DA + DGG * DG
      RATIO = DMAX1(ABS(DELU) / (STEPU * A), ABS(DELA) / (STEPA * A),
     *  ABS(DELG) / STEPG)
      IF (RATIO .LT. ONE) GOTO 110
      RATIO = ONE / RATIO
      DELU = DELU * RATIO
      DELA = DELA * RATIO
      DELG = DELG * RATIO
      GOTO 110
C
C        HESSIAN IS NOT POSITIVE DEFINITE - MAKE A LARGE STEP IN THE
C        DIRECTION OF STEEPEST ASCENT
C
  100 ITYPE = 2
      IF (MONIT .GT. 0) THEN
        WRITE(ICOUT, 6010) NITER, NEVAL, U, A, G, ACTI2, F, GNORM
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      D = ABS(VLNEG)
      TEMP1 = D
      IF (DU .NE. ZERO) TEMP1 = STEPU * A / ABS(DU)
      TEMP2 = D
      IF (DA .NE. ZERO) TEMP2 = STEPA * A / ABS(DA)
      Z = D
      IF (DG .NE. ZERO) Z = STEPG / ABS(DG)
      RATIO = MIN(TEMP1, TEMP2, Z)
      DELU = RATIO * DU
      DELA = RATIO * DA
      DELG = RATIO * DG
C
C        ADJUST PARAMETERS
C
  110 U = U + DELU
      A = A + DELA
      G = G + DELG
C
C        TEST FOR FEASIBILITY
C
      IF (A .GT. F * (XMIN - U) .AND. A .GT. G * (XMAX - U) .AND. G .NE.
     *  ZERO) GOTO 130
      DO 120 NSR = 1, MAXSR
        IF (MONIT .GT. 0) THEN
          WRITE(ICOUT, 6010) NITER, NEVAL, U, A, G, ACTI4
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
        U = U - DELU
        A = A - DELA
        G = G - DELG
        DELU = SRF * DELU
        DELA = SRF * DELA
        DELG = SRF * DELG
        U = U + DELU
        A = A + DELA
        G = G + DELG
        IF (A .GT. G * (XMIN - U) .AND. A .GT. G * (XMAX - Y) .AND. 
     *     G .NE. ZERO) GOTO 140
  120 CONTINUE
      GOTO 80
C
C        TEST FOR CONVERGENCE
C
  130 IF (ABS(DELU) .GT. ACCU * A) GOTO 140
      IF (ABS(DELA) .GT. ACCA * A) GOTO 140
      IF (ABS(DELG) .GT. ACCG) GOTO 140
      IF (MONIT .GT. 0) THEN
        WRITE(ICOUT, 6010) NITER, NEVAL, U, A, G, ACTI9
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      VCOV(1) = DUU
      VCOV(2) = DUA
      VCOV(3) = DAA
      VCOV(4) = DUG
      VCOV(5) = DAG
      VCOV(6) = DGG
      GOTO 160
C
C        END OF MAIN LOOP
C
  140 CONTINUE
C
C        ITERATIONS NOT CONVERGED - SET FAULT FLAG
C
      IFAULT = 2
      IF (MONIT .GT. 0) THEN
        WRITE(ICOUT, 6010) MAXIT, NEVAL, U, A, G, ACTI8
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      GOTO 160
  150 IFAULT = 3
      IF (MONIT .GT. 0) THEN
        WRITE(ICOUT, 6010) NITER, MAXEV, U, A, G, ACTI7
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
C
C        ITERATION FINISHED -COPY RESULTS INTO ARRAY PARA
C
  160 IF (MONIT .GT. 0) THEN
        WRITE(ICOUT, 6020)
        CALL DPWRST('XXX','BUG ')
      ENDIF
 6020 FORMAT('0')
C
      PARA(1) = U
      PARA(2) = A
      PARA(3) = G
      RETURN
C
  170 DO 180 I = 1, 3
  180 PARA(I) = ZERO
      RETURN
C
      END
      SUBROUTINE MOM(G, D, A, FAULT)
C
C        ALGORITHM AS 99.3  APPL. STATIST. (1976) VOL.25, P.180
C
C        EVALUATES FIRST SIX MOMENTS OF A JOHNSON
C        SB DISTRIBUTION, USING GOODWIN METHOD
C
      REAL A(6), B(6), C(6), G, D, ZZ, VV, RTTWO, RRTPI, W, E, R,
     $  H, T, U, Y, X, V, F, Z, S, P, Q, AA, AB, EXPA, EXPB,
     $  ZERO, QUART, HALF, P75, ONE, TWO, THREE, ZABS, ZEXP
      LOGICAL L, FAULT
C
      DATA ZZ, VV, LIMIT /1.0E-5, 1.0E-8, 500/
C
C        RTTWO IS SQRT(2.0)
C        RRTPI IS RECIPROCAL OF SQRT(PI)
C        EXPA IS A VALUE SUCH THAT EXP(EXPA) DOES NOT QUITE
C          CAUSE OVERFLOW
C        EXPB IS A VALUE SUCH THAT 1.0 + EXP(-EXPB) MAY BE
C          TAKEN TO BE 1.0
C
      DATA     RTTWO,        RRTPI, EXPA, EXPB
     $  /1.414213562, 0.5641895835, 80.0, 23.7/
      DATA ZERO, QUART, HALF,  P75, ONE, TWO, THREE
     $     /0.0,  0.25,  0.5, 0.75, 1.0, 2.0,   3.0/
C
      ZABS(X) = ABS(X)
      ZEXP(X) = EXP(X)
C
      FAULT = .FALSE.
      DO 10 I = 1, 6
   10 C(I) = ZERO
      W = G / D
C
C        TRIAL VALUE OF H
C
      IF (W .GT. EXPA) GOTO 140
      E = ZEXP(W) + ONE
      R = RTTWO / D
      H = P75
      IF (D .LT. THREE) H = QUART * D
      K = 1
      GOTO 40
C
C        START OF OUTER LOOP
C
   20 K = K + 1
      IF (K .GT. LIMIT) GOTO 140
      DO 30 I = 1, 6
   30 C(I) = A(I)
C
C        NO CONVERGENCE YET - TRY SMALLER H
C
      H = HALF * H
   40 T = W
      U = T
      Y = H * H
      X = TWO * Y
      A(1) = ONE / E
      DO 50 I = 2, 6
   50 A(I) = A(I - 1) / E
      V = Y
      F = R * H
      M = 0
C
C        START OF INNER LOOP
C        TO EVALUATE INFINITE SERIES
C
   60 M = M + 1
      IF (M .GT. LIMIT) GOTO 140
      DO 70 I = 1, 6
   70 B(I) = A(I)
      U = U - F
      Z = ONE
      IF (U .GT. -EXPB) Z = ZEXP(U) + Z
      T = T + F
      L = T .GT. EXPB
      IF (.NOT. L) S = ZEXP(T) + ONE
      P = ZEXP(-V)
      Q = P
      DO 90 I = 1, 6
      AA = A(I)
      P = P / Z
      AB = AA
      AA = AA + P
      IF (AA .EQ. AB) GOTO 100
      IF (L) GOTO 80
      Q = Q / S
      AB = AA
      AA = AA + Q
      L = AA .EQ. AB
   80 A(I) = AA
   90 CONTINUE
  100 Y = Y + X
      V = V + Y
      DO 110 I = 1, 6
      IF (A(I) .EQ. ZERO) GOTO 140
      IF (ZABS((A(I) - B(I)) / A(I)) .GT. VV) GOTO 60
  110 CONTINUE
C
C        END OF INNER LOOP
C
      V = RRTPI * H
      DO 120 I = 1, 6
  120 A(I) = V * A(I)
      DO 130 I = 1, 6
      IF (A(I) .EQ. ZERO) GOTO 140
      IF (ZABS((A(I) - C(I)) / A(I)) .GT. ZZ) GOTO 20
  130 CONTINUE
C
C        END OF OUTER LOOP
C
      RETURN
  140 FAULT =.TRUE.
      RETURN
      END
      SUBROUTINE MOMENT(X, Y, N, R, W)
C
C        ALGORITHM AS 258.3  APPL.STATIST. (1990), VOL.39, NO.3
C
C        For k=0,...,n,  computes the integral from x to
C        infinity of the quantity
C
C                 R(k+1) = ( t - y )**k z(t) dt,
C            where
C                 z(t) = 1/sqrt(2 pi) exp( -t**2 / 2 ) .
C
      INTEGER N
      DOUBLE PRECISION X, Y, R( * ), W( * )
      INTEGER I, K
      DOUBLE PRECISION ALNORM
      DOUBLE PRECISION XMY, SQR2PI, FACT(19)
      EXTERNAL ALNORM
      DATA SQR2PI / 2.506628274631000502415765D0 /
      DATA FACT / 2 * 1.D0, 2.D0, 6.D0, 24.D0, 120.D0, 720.D0, 5040.D0,
     *     40320.D0, 362880.D0, 3628800.D0, 39916800.D0, 479001600.D0,
     *     6227020800.D0, 87178291200.D0, 1307674368000.D0,
     *     20922789888000.D0, 355687428096000.D0, 6402373705728000.D0 /
C
C        Compute first term of R.
C
      W(1) = EXP(-X * X / 2.0) / SQR2PI
      W(2) = ALNORM(-X, .FALSE.)
      R(1) = W(2)
      IF (N .GT. 0) THEN
         DO 10 I = 1, N
            W(I + 2) = (W(I) - X * W(I + 1)) / I
            R(I + 1) = W(I + 2) * FACT(I + 1)
   10    CONTINUE
C
C        If X=Y, then R is already computed.
C
         IF (X .NE. Y) THEN
C
C        Compute R.
C
            DO 30 K = 0, N
               R(K + 1) = W(2) / FACT(K + 1)
               XMY = X - Y
               DO 20 I = 1, K
                  R(K + 1) = R(K + 1) * XMY + W(I + 2) / FACT(K - I + 1)
   20          CONTINUE
               R(K + 1) = R(K + 1) * FACT(K + 1)
   30       CONTINUE
         END IF
      END IF
      RETURN
      END
      double precision function mpf(x, t, nlab, y)
      implicit double precision (a-h, o-z)
      dimension x(*), t(*)
c
c     -- Calculate the mean estimate
      wsum = 0.0d0
      xhat = 0.0d0
      do 10 i=1, nlab
         wght = 1.0d0/(t(i)+y)
         wsum = wsum +wght
         xhat = xhat +x(i)*wght
 10   continue
      xhat = xhat /wsum
c
c    -- Evaluate the function
      mpf = 0.0d0
      do 20 i=1, nlab
         mpf = mpf + 1.0d0/(t(i) +y) *(x(i) -xhat)**2
 20   continue
      return
      end
      double precision function mpfder(x, t, nlab, y, wsum)
      implicit double precision (a-h, o-z)
      dimension x(*), t(*)
c
c     -- Calculate the mean estimate
      wsum = 0.0d0
      xhat = 0.0d0
      do 10 i=1, nlab
         wght = 1.0d0/(t(i)+y)
         wsum = wsum + wght
         xhat = xhat + x(i)*wght
 10   continue
      xhat = xhat /wsum
c
c    -- Evaluate the function
      mpfder = 0.0d0
      do 20 i=1, nlab
         mpfder = mpfder + 1.0d0/(t(i) +y)**2 *(x(i) -xhat)**2
 20   continue
      return
      end
      subroutine mpinit (dat, n, ieq2, nlab, x, t)
c
c  Initialization for Mandel-Paule estimation
c
c  Routine supplied by Mark Vangel: 10/2000
c
c  2/2005: Modification by Alan Heckert.  If a lab has a single
c          observation, the within lab variance is zero and
c          code below blows up.  As an alternative, check for
c          this case and set the resulting variance to the
c          maximum variance of all the labs.
c
      implicit double precision (a-h, o-z)
      real dat
      dimension dat(*), n(*), x(*), t(*)
c
c     -- Calculate batch means and variances of these means
      ntot   = 0
      timax=0.0
      do 10 i=1, nlab
        x(i) = 0.0d0
        if (ieq2 .eq. 1) then
           ntot  = ntot +n(1)
           ni    = n(1)
           n(i)  = ni
        else
           ntot  = ntot +n(i)
           ni = n(i)
        end if
        do 20 j=ntot-ni+1, ntot
          x(i) = x(i) + dat(j)
 20     continue
        x(i)   = x(i)/dble(ni)
        t(i)   = 0.0d0
        do 30 j=ntot-ni+1, ntot
           t (i) = t(i) +(dat(j)-x(i))**2
 30     continue
        if(ni .eq. 1)then
          t(i) = -1.0
        else
          t(i) = t(i) /dble(((ni-1)*ni))
          if(t(i).gt.timax)timax=t(i)
        endif
 10   continue
c
      do 40 i=1, nlab
        if (t(i) .le. 0.0) t(i)=timax
 40   continue
c
      Return
      end
      subroutine mpintl(nlab,n,x,t,xm,s2b,w,maxit,dlik,ibuga3,ierror)
c
c  --Mandel-Paule Interlab subroutine
c  --This subroutine is driver routine for generating maximum
c  --likelihood estimates
c  --Code provided by Mark Vangel (10/2000)
c  --Adapted to Dataplot by Alan Heckert
c
      implicit double precision (a-h, o-z)
      double precision mplglk, mpwmea, mps2bf
      dimension n(*), t(*), w(*), x(*)
      character*4 ibuga3
      character*4 ierror
      dimension q(3), xl(3)
C
      common /mpcom/ t0, t1
C
C--------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
      REAL CPUMIN, CPUMAX
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT------------------------------------------------
C
      do 5 i=1,3
        q(i)=0.0d0
        xl(i)=0.0d0
  5   continue
      tol    = 1.d-12
      iter   = 0
      dlik   = mplglk (nlab, n, x, t, xm, s2b, w, ibuga3)
 10   continue
c
      if(ibuga3.eq.'ON')then
         WRITE(ICOUT,999)
  999    FORMAT(1X)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,1001)ITER,S2B,XM,DLIK
 1001    FORMAT('ITER,S2B,XM,DLIK=',I8,3G15.7)
         CALL DPWRST('XXX','BUG ')
      endif
c
      dlt    = 0.0d0
      iter   = iter +1
      mltwgt = 0
      do 20 i=1, nlab
        a    = s2b  /(x(i) - xm)**2
        b    = t(i) /(x(i) - xm)**2
        ss   = dble(n(i)*(n(i)-1))*t(i)
        if (a .eq. 0.0d0) then
          w(i)  = dble(n(i))/((x(i)-xm)**2 +dble(n(i)-1)*t(i))
          q(1)  = w(i)
          nwght = 1
        else
          call mpweig(a, b, dble(n(i)-1), nwght, q, ibuga3, ierror)
          if(ierror.eq.'YES')return
        end if
        if (nwght .gt. 1) mltwgt = 1
        if (nwght .eq. 1) then
          wtmp = q(1)
          jwgt = 1
        else
          do 15 j=1,3
            xl(j) = dble(n(i))*log(q(j)) -
     $      q(j)*(1.0d0/a +dble(n(i)-1)*t(i)/(1.0d0-q(j))) -
     $      dble(n(i)-1)*log(1.0d0-q(j))
 15       continue
          if (xl(2) .gt. xl(1) .and. xl(2) .gt. xl(3)) then
            wtmp = q(2)
            jwgt = 2
          else if (xl(3) .gt. xl(1) .and. xl(3) .gt. xl(2)) then
            wtmp = q(3)
            jwgt = 3
          else 
            wtmp = q(1)
            jwgt = 1
          end if
        end if
        dtmp = abs(wtmp - w(i))
        if (dtmp .gt. dlt) dlt = dtmp
        w(i) = wtmp
        if(ibuga3.eq.'ON')then
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,1011)XM,S2B,I,NWGHT,JWGT
 1011     FORMAT('XM,S2B,I,NWGHT,JWGT=',2G15.7,3I8)
          CALL DPWRST('XXX','BUG ')
        endif
 20   continue
c
      dlik  = mplglk (nlab, n, x, t, xm, s2b, w, ibuga3)
      IF(IBUGA3.EQ.'ON')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,1021)iter,t0 +(t1-t0)*xm,(t1-t0)**2*s2b, dlik
 1021   FORMAT('ITER,T0+(T1-T0)*XM,(T1-T0**2*S2B,DLIK=',I8,3G16.8)
        CALL DPWRST('XXX','BUG ')
      ENDIF
      s2b   = mps2bf(x, w, xm, nlab)
      xm    = mpwmea(x, w, nlab, ibuga3)
      if (dlt .gt. tol .and. iter .lt. maxit) go to 10
      if (iter .gt. maxit) then
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,1041)
 1041   FORMAT('***** ERROR FROM MPINTL:: CONVERGENCE FAILED.')
        CALL DPWRST('XXX','BUG ')
      ENDIF
      return
      end
      double precision function mplglk 
     $    (nlab, n, x, t, xm, s2b, w, ibuga3)
c
c  --log-likelihood function used by CONSESUS MEANS code
c  --provided by Mark Vangel (10/2000)
c 
      implicit double precision (a-h, o-z)
      character*4 ibuga3
      dimension n(*), x(*), t(*), w(*)
C
C--------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
      REAL CPUMIN, CPUMAX
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT------------------------------------------------
C
      mplglk = 0.0d0
      if (s2b .gt. 0.0d0) then
        do 10 i=1, nlab
          prtlik = dble(n(i))*log(w(i)/s2b) - 
     $             (w(i)/s2b)*((x(i)-xm)**2 +
     $             dble(n(i)-1)*t(i)/(1.0d0-w(i))) -
     $             dble(n(i)-1)*log(1.0d0 - w(i))
          mplglk = mplglk + prtlik
          IF(IBUGA3.EQ.'ON')THEN
            WRITE(ICOUT,999)
  999       FORMAT(1X)
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,101)PRTLIK
 101   FORMAT('***** FROM MPLGLK (s2b > 0): PRTLIK = ',G15.7)
            CALL DPWRST('XXX','BUG ')
          ENDIF
 10     continue
      else
        do 20 i=1, nlab
          prtlik = -w(i) *((x(i)-xm)**2 + dble(n(i)-1)*t(i)) +
     $             dble(n(i))*log(w(i))
          mplglk = mplglk + prtlik
          IF(IBUGA3.EQ.'ON')THEN
            WRITE(ICOUT,999)
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,103)PRTLIK
 103   FORMAT('***** FROM MPLGLK (s2b <= 0): PRTLIK = ',G15.7)
          ENDIF
 20     continue
      end if
c
      return
      end
      subroutine mppoly(x, fx)
c
c --Compute cubic polynomial function for root finder in
c --Consensus Means code.
c --Code provided by Mark Vangel
c
      implicit double precision (a-h, o-z)
      double precision c(0:3)
      common /mpfnc/ c
c
      fx = c(0)+x*(c(1)+x*(c(2)+x*c(3)))
c
      return
      end
      subroutine mpprep (nlab, x, t, t0, t1)
c
c     Mark Vangel, NIST, Nov 1995
c
c     Added to Dataplot: 10/2000
c
c     Scale the sufficient statistics so that the
c     means are in [0,1].
c
      implicit double precision (a-h, o-z)
      dimension x(*), t(*)
c
      t0 = x(1)
      t1 = x(1)
      do 10 j=1, nlab
         if (x(j) .lt. t0) t0 = x(j)
         if (x(j) .gt. t1) t1 = x(j)
 10   continue
      do 20 j=1, nlab
         x(j) = (x(j)-t0)/(t1-t0)
         t(j) = t(j)/(t1-t0)**2
 20   continue
      return
      end
      double precision function mprhs (x, t, that, n, nlab)
      implicit double precision (a-h, o-z)
      dimension x(*), t(*), that(*), n(*)
      mprhs = 0.0d0
      do 10 i=1, nlab
         mprhs = mprhs + dble(n(i)-1) * (1.0d0 - t(i)/that(i)) + 1.0d0
 10   continue
      return
      end
      subroutine mproot
     $ (x, t, nlab, tol, rhs, root, maxit, niter, ier)
      implicit double precision (a-h, o-z)
      double precision mpf, mpfder
      dimension x(*), t(*)
C
C--------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
      REAL CPUMIN, CPUMAX
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     -- If root is negative or nonexistent, set it to 
c        zero.
c
      y  = 0.0d0
      f0 = mpf(x, t, nlab, y)
      if (f0 .lt. rhs) then
         root = 0.0d0
         ier  = 1
         return
      end if
c
c    -- Loop until convergence
      niter = 0
 30   continue
         niter = niter +1
         fd = mpfder(x, t, nlab, y, wsum)
         ynew = y +(mpf(x, t, nlab, y)-rhs)/fd
         if (abs (ynew-y) .le. tol .and.
     $            niter   .le. maxit) then
            root = ynew
            ier  = 0
            return
         else if (niter .gt. maxit) then
            root = ynew
            WRITE(ICOUT,999)
  999       FORMAT(1X)
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,1001)
 1001       FORMAT('***** ERROR: FAILURE IN MPROOT: YNEW = ',G15.7)
            CALL DPWRST('XXX','BUG ')
            DO1010I=1,NLAB
            WRITE(ICOUT,1011)
 1011       FORMAT('      I,T(I) = ',I8,G15.7)
 1010       CONTINUE
            ier  = 2
            return
         else
           y = ynew
           go to 30
         end if
         return
      end
      double precision function mps2bf (x, w, xbar, nlab)
c
c  --Code for consensus mean
c  --Provided by Mark Vangel
c
      implicit double precision (a-h, o-z)
      dimension x(*), w(*)
      mps2bf = 0.0d0
      wsum   = 0.0d0
      do 10 i=1, nlab
         mps2bf = mps2bf + w(i)**2 *(x(i) -xbar)**2
         wsum   = wsum + w(i)
 10   continue
      if (wsum .ne. 0.0d0) then
         mps2bf = mps2bf /wsum
      else
         mps2bf = 0.0d0
      end if
      return
      end
      subroutine mpsub (nlab, n, x, t, xmp, s2bmp, imanpa, ibuga3)
c
c  Initialization for Mandel-Paule estimation
c
c  Routine supplied by Mark Vangel: 10/2000
c
      implicit double precision (a-h, o-z)
ccccc double precision mprhs
      double precision mpxbar
      dimension x(*), n(*), t(*)
      character*4 imanpa
      character*4 ibuga3
C
C--------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
      REAL CPUMIN, CPUMAX
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 = 1000
      tol   = 1.d-7
c
c    -- Initialize with Mandel-Paule
      s2b = 0.d0
CCCCC USE NLAB FOR MANDEL-PAULE, NLAB-1 FOR MODIFIED MANDEL-PAULE
      if(imanpa.eq.'MODI')then
        xrhs=dble(nlab)
      else
        xrhs=dble(nlab-1)
      endif
CCCCC xrhs = mprhs (x, t, t, n, nlab)
      call mproot
     $ (x, t, nlab, tol, xrhs, s2b, maxit, niter, ier)
      xmp  = mpxbar   (x, t, s2b, nlab)
      s2bmp  = s2b
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      IF(IBUGA3.NE.'ON')GOTO1099
      WRITE(ICOUT,1001)
 1001 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1011)
 1011 FORMAT('FROM ROUTINE MPSUB')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1021)XRHS,XMP,S2BMP
 1021 FORMAT('RHS, XMP, S2BMP = ',3G15.7)
      CALL DPWRST('XXX','BUG ')
 1099 CONTINUE
      return
      end
      double precision function mpwmea (x, w, nlab, ibuga3)
c
c --Compute a weighted mean for the consensus means code
c --provided by Mark Vangel.
c
      implicit double precision (a-h, o-z)
      dimension w(*), x(*)
      character*4 ibuga3
C
C--------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
      REAL CPUMIN, CPUMAX
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT------------------------------------------------
C
      dtemp = 0.0d0
      wsum  = 0.0d0
      do 10 i=1, nlab
         dtemp = dtemp + x(i)*w(i)
         wsum  = wsum  + w(i)
 10   continue
      IF(IBUGA3.EQ.'ON')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        DO1010I=1,NLAB
          WRITE(ICOUT,1001)I,X(I),W(I)
 1001     FORMAT('***** MPWMEA: I,X(I),W(I)=',I8,2G15.7)
          CALL DPWRST('XXX','BUG ')
 1010   CONTINUE
      ENDIF
      mpwmea = dtemp/wsum
      return
      end
      subroutine mpweig (a, b, gnu, nwght, w, ibuga3, ierror)
      implicit double precision (a-h, o-z)
c
c     Concensus Means Code
c     Mark Vangel, NIST, Oct. 1995
c
c         Find weight by solving cubic equation.
c
      character*4 ibuga3
      character*4 ierror
      real dwarf, precis
      double precision w(*)
      double precision c(0:3)
      common /mpfnc/ c
      external mppoly
C
C--------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
      REAL CPUMIN, CPUMAX
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
      IERROR='NO'
      c(3)   = 1.0d0
      c(2)   = 1.0d0 - a
      c(1)   = gnu *(a+b)
      c(0)   = gnu *b
      precis = 1.e-14
      dwarf  = 1.e-14
      x0     = -1.0d0
      x1     =  0.0d0
      ndeg   = 11
      zero=0.0d0
c
      call mpzero(mppoly, x0, x1, ndeg, precis, dwarf, zero, ier)
      nwght  = 1
      w(1)   = zero + 1.0d0
      disc   = (1.0d0-a+zero)**2 +4.0d0*b*gnu/zero
      if (disc .gt. 0.0d0) then
            z1   = zero
            disc = sqrt(disc)
            z2   = (-(1.0d0-a+zero) +disc)/2.0d0
            z3   = (-(1.0d0-a+zero) -disc)/2.0d0
            if ((-1.0d0 .le. z2 .and. z2 .le. 0.0d0) .or.
     $         ((-1.0d0 .le. z3 .and. z3 .le. 0.0d0))) then
                nwght = 3
                w(2) = z2 +1.0d0
                w(3) = z3 +1.0d0
            end if
      end if
      IF(IBUGA3.EQ.'ON')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,1001)W(1),W(2),W(3)
 1001   FORMAT('FROM MPWEIG: W = ',3G15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
      if (ier .ne. 0) then
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,1011)IER
 1011   FORMAT('FROM MPWEIG: IER = ',I8)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,1021)A,B,GNU
 1021   FORMAT('FROM MPWEIG: A,B,GNU = ',3G15.7)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,1026)W(1),W(2),W(3)
 1026   FORMAT('FROM MPWEIG: W = ',3G15.7)
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
      end if
      if (nwght .eq. 3) then
CCCCC   write(ICOUT,1031) W(1),W(2),W(3)
C1031   FORMAT('FROM MPWEIG (NWGHT=3): W = ',3G15.7)
CCCCC   CALL DPWRST('XXX','BUG ')
      endif
      return
      end
      double precision function mpxbar (x, t, s2b, nlab)
      implicit double precision (a-h, o-z)
      dimension x(*), t(*)
c
      mpxbar = 0.0d0
      wsum = 0.0d0
      do 10 i=1, nlab
         wi   = 1.0d0/(s2b+t(i))
         wsum = wsum + wi
         mpxbar = mpxbar + x(i)*wi
 10   continue
      mpxbar = mpxbar /wsum
c
      return
      end
      SUBROUTINE MPZERO(EVF,A,B,NDEG,PRECIS,DWARF,ZERO,IER)
C-----------------------------------------------------------------------
C
C   PURPOSE              - FIND A ZERO OF A FUNCTION WHICH CHANGES
C                            SIGN IN A GIVEN INTERVAL BY LARKIN'S
C                            METHOD OF RATIONAL INTERPOLATION.
C
C   PRECISION            - DOUBLE.
C
C   ARGUMENTS    EVF     - AN EXTERNAL SUBROUTINE EVF(X,FX) WITH
C                            DOUBLE PRECISION ARBUMENTS X,FX WHICH
C                            COMPUTES F(X) FOR ANY X IN THE INTERVAL
C                            (A,B) INCLUSIVE. (INPUT)
C                            EVF MUST APPEAR IN AN EXTERNAL STATEMENT
C                            IN THE CALLING PROGRAM.
C                A,B     - DOUBLE PRECISION BOUNDARY POINTS.
C                            (INPUT/OUTPUT)
C                          ON INPUT, F(A) AND F(B) SHOULD HAVE OPPOSITE
C                            SIGNS UNLESS ONE EQUALS 0.
C                          ON OUTPUT, BOTH A AND B ARE ALTERED BUT F(A)
C                            AND F(B) REMAIN OPPOSITELY SIGNED UNLESS
C                            ONE EQUALS 0. IF NEITHER F(A) NOR F(B)
C                            EQUALS 0, THEN
C                              ABS(A-B) .LE. 4*PRECIS*ABS(A)+2*DWARF.
C                NDEG    - MAXIMUM TOTAL DEGREE OF RATIONAL INTER-
C                            POLATION. (INPUT)
C                            IF NDEG.LT.2 THEN 2 IS USED IN PLACE OF
C                            NDEG. IF NDEG.GT.11 THEN 11 IS USED IN
C                            PLACE OF NDEG.
C                PRECIS  - REAL RELATIVE CONVERGENCE PARAMETER. (INPUT)
C                            PRECIS SHOULD BE AT LEAST MACHINE PRE-
C                            CISION, I.E. 1+PRECIS.GT.1 IN DOUBLE
C                            PRECISION ARITHMETIC.
C                DWARF   - REAL ABSOLUTE CONVERGENCE PARAMETER. (INPUT)
C                            DWARF SHOULD BE AT LEAST AS LARGE AS THE
C                            SMALLEST POSITIVE NORMALIZED REAL NUMBER
C                            REPRESENTABLE IN THE COMPUTER.
C                ZERO    - DOUBLE PRECISION APPROXIMATE ZERO OF F(X).
C                            (OUTPUT)
C                            ZERO EQUALS WHICHEVER OF OUTPUT A OR B HAS
C                            SMALLER F MAGNITUDE.
C                IER     - ERROR INDICATOR. (OUTPUT)
C                            NO ERROR: IER=0 .
C                            TERMINAL ERROR:
C                              IER=129 INDICATES THAT F HAS THE SAME
C                              SIGN ON INPUT A AND B.
C
C-----------------------------------------------------------------------
C
C                                 SPECIFICATIONS FOR ARGUMENTS.
C
      INTEGER NDEG,IER
      REAL PRECIS,DWARF
      DOUBLE PRECISION A,B,ZERO
C
C                                 SPECIFICATIONS FOR LOCAL VARIABLES.
C
      INTEGER MAXDEG,NN,N,NLAST,I,J
      REAL TOL,C,D,E,D0,D1
      DOUBLE PRECISION X(11),U(11),X0,F0,F1,F2,Z,FZ,H,HLAST,R,S,T
      DATA MAXDEG/11/
C
C     REMARK:  IN THIS SUBROUTINE THE MAXIMUM ALLOWABLE DEGREE OF
C                RATIONAL INTERPOLATION HAS BEEN ARBITRARILY SET AT 11.
C                (SEE DESCRIPTION OF NDEG.) TO INCREASE THE MAXIMUM
C                ALLOWABLE DEGREE TO M:
C                  1. DIMENSION X AND U AT M (RATHER THAN 11),
C                  2. INITIALIZE MAXDEG AT M (RATHER THAN 11),
C                IN THE ABOVE LINES OF CODE.
C
C                                 FIRST EXECUTABLE STATEMENT.
C
      X0 = A
      X(1) = B
      CALL EVF(A,F0)
      CALL EVF(B,F1)
      IF (F0.EQ.0. .OR. F1.EQ.0.) GO TO 120
      IF (F0.GT.0. .AND. F1.GT.0.) GO TO 140
      IF (F0.LT.0. .AND. F1.LT.0.) GO TO 140
      NN = NDEG
      IF (NN.LT.2) NN = 2
      IF (NN.GT.MAXDEG) NN = MAXDEG
      R = X(1) - X0
      E = 0.
      F2 = F0
C
C                                 MAIN LOOP.
C
   10 CONTINUE
      TOL = 2.*PRECIS*DABS(X0) + DWARF
      IF (DABS(R).LE.2.*TOL) GO TO 120
      U(1) = R* (F0/ (F0-F1))
      IF (E.LT.TOL .OR. DABS(F0).GE.DABS(F2)) GO TO 60
C
C                                 INTERPOLATE.
C
      H = U(1)
      HLAST = H
      NLAST = 1
      S = R
      DO 30 I = 2,N
          S = S + U(I) - U(I-1)
          T = X(I) - X0 - S
          IF (T.EQ.0.) GO TO 40
          U(I) = H* (S/T)
          H = H + U(I)
          D1 = DABS(U(I))
          IF (I.EQ.2) GO TO 20
          IF (D1.GE.D0) GO TO 40
          T = H/R
          IF (T.LE.0. .OR. T.GE.1.) GO TO 40
   20     HLAST = H
          NLAST = I
          D0 = D1
   30 CONTINUE
   40 Z = X0 + HLAST
      D0 = DABS(HLAST)
      D1 = DABS(Z-X(1))
      C = E
      E = D
      D = AMIN1(D0,D1)
      IF (D.GE..5*C) GO TO 60
      IF (D.GE.TOL) GO TO 70
      IF (D0.LT.TOL) GO TO 50
      IF (R.LT.0.) TOL = -TOL
      Z = X(1) - TOL
      GO TO 70

   50 IF (R.LT.0.) TOL = -TOL
      Z = X0 + TOL
      GO TO 70
C
C                                 END INTERPOLATE.
C
   60 CONTINUE
C
C                                 BISECT.
C
      H = .5*R
      Z = X0 + H
      NLAST = 1
      D = DABS(H)
      E = D
C
C                                 END BISECT.
C
   70 CONTINUE
C
C                                 EVALUATE AND ORGANIZE.
C
      CALL EVF(Z,FZ)
      IF (FZ.NE.0.) GO TO 80
      X0 = Z
      F0 = FZ
      GO TO 120

   80 N = MIN0(NLAST+1,NN)
      J = N + 1
      DO 90 I = 2,N
          J = J - 1
          X(J) = X(J-1)
          U(J) = U(J-1)
   90 CONTINUE
      IF (FZ.GT.0. .AND. F1.GT.0.) GO TO 100
      IF (FZ.LT.0. .AND. F1.LT.0.) GO TO 100
      X(2) = X0
      F2 = F0
      U(2) = U(2) - R
      GO TO 110

  100 X(1) = X0
      F2 = F1
      F1 = F0
  110 CONTINUE
      X0 = Z
      F0 = FZ
      R = X(1) - X0
C
C                                 END EVALUATE AND ORGANIZE.
C
      GO TO 10
C
C                                 END MAIN LOOP.
C
  120 CONTINUE
C
C                                 RETURN WITHOUT ERROR.
C
      IER = 0
      A = X0
      B = X(1)
      IF (DABS(F1).LT.DABS(F0)) GO TO 130
      ZERO = A
      RETURN

  130 ZERO = B
      RETURN

  140 CONTINUE
C
C                                 RETURN WITH ERROR.
C
      IER = 129
      RETURN
      END
        INTEGER FUNCTION MSTA1(X,MP)
C
C       ===================================================
C       Purpose: Determine the starting point for backward  
C                recurrence such that the magnitude of    
C                Jn(x) at that point is about 10^(-MP)
C       Input :  x     --- Argument of Jn(x)
C                MP    --- Value of magnitude
C       Output:  MSTA1 --- Starting point   
C       ===================================================
C
        IMPLICIT DOUBLE PRECISION (A-H,O-Z)
        A0=DABS(X)
        N0=INT(1.1*A0)+1
        F0=ENVJ(N0,A0)-MP
        N1=N0+5
        F1=ENVJ(N1,A0)-MP
        DO 10 IT=1,20             
           NN=N1-(N1-N0)/(1.0D0-F0/F1)                  
           F=ENVJ(NN,A0)-MP
           IF(ABS(NN-N1).LT.1) GO TO 20
           N0=N1
           F0=F1
           N1=NN
 10        F1=F
 20     MSTA1=NN
        RETURN
        END
      INTEGER FUNCTION MSTA2(X,N,MP)
C
C       ===================================================
C       Purpose: Determine the starting point for backward
C                recurrence such that all Jn(x) has MP
C                significant digits
C       Input :  x  --- Argument of Jn(x)
C                n  --- Order of Jn(x)
C                MP --- Significant digit
C       Output:  MSTA2 --- Starting point
C       ===================================================
C
        IMPLICIT DOUBLE PRECISION (A-H,O-Z)
        A0=DABS(X)
        HMP=0.5D0*MP
        EJN=ENVJ(N,A0)
        IF (EJN.LE.HMP) THEN
           OBJ=MP
           N0=INT(1.1*A0)
        ELSE
           OBJ=HMP+EJN
           N0=N
        ENDIF
        F0=ENVJ(N0,A0)-OBJ
        N1=N0+5
        F1=ENVJ(N1,A0)-OBJ
        DO 10 IT=1,20
           NN=N1-(N1-N0)/(1.0D0-F0/F1)
           F=ENVJ(NN,A0)-OBJ
           IF (ABS(NN-N1).LT.1) GO TO 20
           N0=N1
           F0=F1
           N1=NN
10         F1=F
20      MSTA2=NN+10
        RETURN
        END
      SUBROUTINE MULRAN(n,p,ncat,ix,iseed,ierror)
C**********************************************************************
C
C            SUBROUTINE GENMUL( N, P, NCAT, IX )
C     GENerate an observation from the MULtinomial distribution
C
C
C                              Arguments
C
C
C     N --> Number of events that will be classified into one of
C           the categories 1..NCAT
C                         INTEGER N
C
C     P --> Vector of probabilities.  P(i) is the probability that
C           an event will be classified into category i.  Thus, P(i)
C           must be [0,1]. Only the first NCAT-1 P(i) must be defined
C           since P(NCAT) is 1.0 minus the sum of the first
C           NCAT-1 P(i).
C                         REAL P(NCAT-1)
C
C     NCAT --> Number of categories.  Length of P and IX.
C                         INTEGER NCAT
C
C     IX <-- Observation from multinomial distribution.  All IX(i)
C            will be nonnegative and their sum will be N.
C                         INTEGER IX(NCAT)
C
C
C                              Method
C
C
C     Algorithm from page 559 of
C
C     Devroye, Luc
C
C     Non-Uniform Random Variate Generation.  Springer-Verlag,
C     New York, 1986.
C
C     DATAPLOT NOTE: CODE FROM RANLIB LIBRARY OF BROWN AND LAVATO.
C                    Department of Biomathematics, Box 237
C                    The University of Texas, M.D. Anderson Cancer Center
C                    1515 Holcombe Boulevard
C                    Houston, TX      77030
C
C                    FOLLOWING CHANGES:
C                    1) RENAMED FROM GENMUL TO MULRAN
C                    2) REPLACE THEIR IGBNM ROUTINE WITH DATAPLOT BINRAN
C                    3) I/O CHANGED AND ERROR FLAG ADDED.
C
C**********************************************************************
C     .. Scalar Arguments ..
      INTEGER n,ncat
C     ..
C     .. Array Arguments ..
      REAL p(*)
      INTEGER ix(*)
C     ..
C     .. Local Scalars ..
      REAL prob,ptot,sum
      INTEGER i,icat,ntot
C     ..
C     .. External Functions ..
CCCCC INTEGER ignbin
CCCCC EXTERNAL ignbin
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC abs
C     ..
C     .. Executable Statements ..
C
C---------------------------------------------------------------------
C
      REAL XTEMP(1)
C
      CHARACTER*4 IERROR
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C
C     Check Arguments
C
      IF (n.LT.0) THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,1001)N
 1001   FORMAT('***** ERROR IN MULRAN: N IS NOT POSITIVE, VALUE = ',I8)
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        GOTO9999
      ENDIF
      IF (ncat.LE.1) THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,1003)NCAT
 1003   FORMAT('***** ERROR IN MULRAN: NUMBER OF CATEGORIES IS <= 1, ',
     1         'VALUE = ',I8)
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        GOTO9999
      ENDIF
      ptot = 0.0
      DO 10,i = 1,ncat - 1
          IF (p(i).LT.0.0 .or. p(i).gt.1.0) THEN
            WRITE(ICOUT,999)
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,1011)i,p(i)
 1011   FORMAT('***** ERROR IN MULRAN: FOR CATEGORY ',I8,' P(I) IS ',
     1         'NOT IN THE INTERVAL (0,1).  THE VALUE = ',G15.7)
            CALL DPWRST('XXX','BUG ')
            IERROR='YES'
            GOTO9999
          ENDIF
          ptot = ptot + p(i)
   10 CONTINUE
      IF (ptot.GT.0.999999) THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,1021)
 1021   FORMAT('***** ERROR IN MULRAN: SUM OF PROBABILITIES IS ',
     1         'GREATER THAN 1.')
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        GOTO9999
      ENDIF
C
C     Initialize variables
C
      ntot = n
      sum = 1.0
      DO 20,i = 1,ncat
          ix(i) = 0
   20 CONTINUE

C     Generate the observation
      NPAR=1
      DO 30,icat = 1,ncat - 1
          prob = p(icat)/sum
CCCCC     ix(icat) = ignbin(ntot,prob)
          CALL BINRAN(NPAR,PROB,NTOT,ISEED,XTEMP)
          IX(ICAT) = INT(XTEMP(1)+0.1)
          ntot = ntot - ix(icat)
          IF (ntot.LE.0) goto9999
          sum = sum - p(icat)
   30 CONTINUE
      ix(ncat) = ntot
C
C     Finished
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE MVMLTL(NR,N,A,X,Y)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C PURPOSE
C -------
C COMPUTE Y=LX
C WHERE L IS A LOWER TRIANGULAR MATRIX STORED IN A
C
C PARAMETERS
C ----------
C NR           --> ROW DIMENSION OF MATRIX
C N            --> DIMENSION OF PROBLEM
C A(N,N)       --> LOWER TRIANGULAR (N*N) MATRIX
C X(N)         --> OPERAND VECTOR
C Y(N)        <--  RESULT VECTOR
C
C NOTE
C ----
C X AND Y CANNOT SHARE STORAGE
C
      DIMENSION A(NR,1),X(N),Y(N)
      DO 30 I=1,N
        SUM=0.
        DO 10 J=1,I
          SUM=SUM+A(I,J)*X(J)
   10   CONTINUE
        Y(I)=SUM
   30 CONTINUE
      RETURN
      END
      SUBROUTINE MVMLTS(NR,N,A,X,Y)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C PURPOSE
C -------
C COMPUTE Y=AX
C WHERE "A" IS A SYMMETRIC (N*N) MATRIX STORED IN ITS LOWER
C TRIANGULAR PART AND X,Y ARE N-VECTORS
C
C PARAMETERS
C ----------
C NR           --> ROW DIMENSION OF MATRIX
C N            --> DIMENSION OF PROBLEM
C A(N,N)       --> SYMMETRIC (N*N) MATRIX STORED IN
C                  LOWER TRIANGULAR PART AND DIAGONAL
C X(N)         --> OPERAND VECTOR
C Y(N)        <--  RESULT VECTOR
C
C NOTE
C ----
C X AND Y CANNOT SHARE STORAGE.
C
      DIMENSION A(NR,1),X(N),Y(N)
      DO 30 I=1,N
        SUM=0.
        DO 10 J=1,I
          SUM=SUM+A(I,J)*X(J)
   10   CONTINUE
        IF(I.EQ.N) GO TO 25
        IP1=I+1
        DO 20 J=IP1,N
          SUM=SUM+A(J,I)*X(J)
   20   CONTINUE
   25   Y(I)=SUM
   30 CONTINUE
      RETURN
      END
      SUBROUTINE MVMLTU(NR,N,A,X,Y)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C PURPOSE
C -------
C COMPUTE Y=(L+)X
C WHERE L IS A LOWER TRIANGULAR MATRIX STORED IN A
C (L-TRANSPOSE (L+) IS TAKEN IMPLICITLY)
C
C PARAMETERS
C ----------
C NR           --> ROW DIMENSION OF MATRIX
C N            --> DIMENSION OF PROBLEM
C A(NR,1)       --> LOWER TRIANGULAR (N*N) MATRIX
C X(N)         --> OPERAND VECTOR
C Y(N)        <--  RESULT VECTOR
C
C NOTE
C ----
C X AND Y CANNOT SHARE STORAGE
C
      DIMENSION A(NR,1),X(N),Y(N)
      DO 30 I=1,N
        SUM=0.
        DO 10 J=I,N
          SUM=SUM+A(J,I)*X(J)
   10   CONTINUE
        Y(I)=SUM
   30 CONTINUE
      RETURN
      END
      DOUBLE PRECISION FUNCTION MVNFNC(N, W)
*     
*     Integrand subroutine
*
      INTEGER N, INFIN(*), INFIS
      DOUBLE PRECISION W(*), LOWER(*), UPPER(*), CORREL(*), ONE
      INTEGER NL, IJ, I, J
      PARAMETER ( NL = 100, ONE = 1.0D0 )
      DOUBLE PRECISION COV((NL*(NL+1))/2), A(NL), B(NL), Y(NL), BVN
      INTEGER INFI(NL)
      DOUBLE PRECISION PROD, D1, E1, DI, EI, SUM, PHINV, D, E, MVNNIT
      SAVE D1, E1, A, B, INFI, COV
      DI = D1
      EI = E1
      PROD = E1 - D1
      IJ = 1
      DO 100 I = 1,N
         Y(I) = PHINV( DI + W(I)*(EI-DI) )
         SUM = 0.0D0
         DO 200 J = 1,I
            IJ = IJ + 1
            SUM = SUM + COV(IJ)*Y(J)
  200    CONTINUE
         IJ = IJ + 1
         IF ( COV(IJ) .GT. 0.0D0 ) THEN
            CALL LIMITS( A(I+1)-SUM, B(I+1)-SUM, INFI(I+1), DI, EI )
         ELSE
            DI = ( 1.0D0 + SIGN( ONE, A(I+1)-SUM ) )/2.0D0
            EI = ( 1.0D0 + SIGN( ONE, B(I+1)-SUM ) )/2.0D0
         ENDIF
         PROD = PROD*(EI-DI)
 100  CONTINUE
      MVNFNC = PROD
      RETURN
*
*     Entry point for intialization.
*
      ENTRY MVNNIT(N, CORREL, LOWER, UPPER, INFIN, INFIS, D, E)
      MVNNIT = 0
*
*     Initialization and computation of covariance Cholesky factor.
*
      CALL NCVSRT(N, LOWER,UPPER,CORREL,INFIN,Y, INFIS,A,B,INFI,COV,D,E)
      D1 = D
      E1 = E
      IF ( N - INFIS .EQ. 2 ) THEN
         D = SQRT( 1.0D0 + COV(2)**2 )
         A(2) = A(2)/D
         B(2) = B(2)/D
         E = BVN( A, B, INFI, COV(2)/D )
         D = 0.0D0
         INFIS = INFIS + 1 
      END IF
C
      RETURN
      END
      SUBROUTINE MVTLMS( NU, A, B, INFIN, LOWER, UPPER )
      DOUBLE PRECISION A, B, LOWER, UPPER, STUDNT
      INTEGER NU, INFIN
      LOWER = 0.0D0
      UPPER = 1.0D0
      IF ( INFIN .GE. 0 ) THEN
         IF ( INFIN .NE. 0 ) LOWER = STUDNT( NU, A )
         IF ( INFIN .NE. 1 ) UPPER = STUDNT( NU, B )
      ENDIF
C
      RETURN
      END
      SUBROUTINE MVTSRT( N, NU, LOWER, UPPER, CORREL, INFIN, Y, INFIS, 
     &                   A, B, INFI, COV, D, E )
*
*     Sort limits
*
      INTEGER N, NU, INFI(*), INFIN(*), INFIS
      DOUBLE PRECISION 
     &     A(*), B(*), COV(*), LOWER(*), UPPER(*), CORREL(*), Y(*), D, E
      INTEGER I, J, K, IJ, II, JMIN
      DOUBLE PRECISION SUMSQ, ZERO, TWO, PI, CVDIAG
      DOUBLE PRECISION AI, BI, SUM, YL, YU, YD
      DOUBLE PRECISION AMIN, BMIN, DMIN, EMIN, CON, CONODD, CONEVN
      PARAMETER ( ZERO = 0, TWO = 2, PI = 3.14159 26535 89793 23844 )
      IJ = 0
      II = 0
      INFIS = 0
      DO 100 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 200 J = 1,I-1
            IJ = IJ + 1
            II = II + 1
            COV(IJ) = CORREL(II)
  200    CONTINUE
         IJ = IJ + 1
         COV(IJ) = 1
  100 CONTINUE
      CONODD = 1.0D0/PI
      CONEVN = 1.0D0/TWO
      DO 300 I = 1, NU - 1
         IF ( MOD(I,2) .EQ. 0 ) THEN
            IF ( I .GT. 2 ) CONEVN = CONEVN*DBLE(I-1)/DBLE(I-2)
         ELSE
            IF ( I .GT. 2 ) CONODD = CONODD*DBLE(I-1)/DBLE(I-2)
         ENDIF
  300 CONTINUE
*
*     First move any doubly infinite limits to innermost positions
*
      IF ( INFIS .LT. N ) THEN
         DO 400 I = N, N-INFIS+1, -1
            IF ( INFI(I) .GE. 0 ) THEN
               DO 500 J = 1, I-1
                  IF ( INFI(J) .LT. 0 ) THEN
                     CALL RCSWAP( J, I, A, B, INFI, N, COV )
                     GOTO 400
                  ENDIF
  500          CONTINUE
            ENDIF
  400    CONTINUE
*
*     Sort remaining limits and determine Cholesky decomposition
*
         II = 0
         YD = 1.0D0
         DO 900 I = 1, N-INFIS
*
*     Determine the integration limits for variable with minimum
*      expected probability and interchange that variable with Ith.
*
            EMIN = 1
            DMIN = 0
            JMIN = I
            CVDIAG = 0
            IJ = II
            DO 600 J = I, N-INFIS
               SUM = 0
               SUMSQ = 0
               DO 650 K = 1, I-1
                  SUM = SUM + COV(IJ+K)*Y(K)
                  SUMSQ = SUMSQ + COV(IJ+K)**2
  650          CONTINUE
               IJ = IJ + J
               SUMSQ = SQRT( MAX( COV(IJ)-SUMSQ, ZERO ) )
               IF ( SUMSQ .GT. 0 ) THEN
                  AI = YD*( A(J) - SUM )/SUMSQ
                  BI = YD*( B(J) - SUM )/SUMSQ
                  CALL MVTLMS( NU+J-1, AI, BI, INFI(J), D, E )
                  IF ( EMIN - DMIN .GE. E - D ) THEN
                     JMIN = J
                     AMIN = AI
                     BMIN = BI
                     DMIN = D
                     EMIN = E
                     CVDIAG = SUMSQ
                  ENDIF
               ENDIF
  600       CONTINUE
            IF ( JMIN .NE. I ) CALL RCSWAP( I, JMIN, A,B, INFI, N,COV )
*
*     Compute Ith column of Cholesky factor.
*
            IJ = II + I
            COV(IJ) = CVDIAG
            DO 700 J = I+1, N-INFIS
               IF ( CVDIAG .GT. 0.0D0 ) THEN
                  SUM = COV(IJ+I)
                  DO 750 K = 1, I-1
                     SUM = SUM - COV(II+K)*COV(IJ+K)
  750             CONTINUE
                  COV(IJ+I) = SUM/CVDIAG
               ELSE
                  COV(IJ+I) = 0.0D0
               ENDIF
               IJ = IJ + J
 700        CONTINUE
*
*     Compute expected value for Ith integration variable and
*     scale Ith covariance matrix row and limits.
*
            IF ( MOD(NU+I-1,2) .EQ. 0 ) THEN
               IF ( NU+I-3 .GT. 0 ) CONEVN =
     &                              CONEVN*DBLE(NU+I-2)/DBLE(NU+I-3)
               CON = CONEVN
            ELSE
               IF ( NU+I-3 .GT. 0 ) CONODD =
     &                              CONODD*DBLE(NU+I-2)/DBLE(NU+I-3)
               CON = CONODD
            ENDIF
            IF ( CVDIAG .GT. 0.0D0 ) THEN
               YL = 0.0D0
               YU = 0.0D0
               IF ( INFI(I) .NE. 0 .AND. NU+I-2 .GT. 0 ) 
     &              YL = -CON*DBLE(NU+I-1)/DBLE(NU+I-2)
     &              /( 1.0D0 + AMIN**2/DBLE(NU+I-1) )**((NU+I-2)/TWO)
               IF ( INFI(I) .NE. 1 .AND. NU+I-2 .GT. 0 ) 
     &              YU = -CON*DBLE(NU+I-1)/DBLE(NU+I-2)
     &              /( 1.0D0 + BMIN**2/(NU+I-1) )**( (NU+I-2)/TWO )
               Y(I) = ( YU - YL )/( EMIN - DMIN )/YD
               DO 800 J = 1,I
                  II = II + 1
                  COV(II) = COV(II)/CVDIAG
  800          CONTINUE
               IF ( INFI(I) .NE. 0 ) A(I) = A(I)/CVDIAG
               IF ( INFI(I) .NE. 1 ) B(I) = B(I)/CVDIAG
            ELSE
               Y(I) = 0.0D0
               II = II + I
            ENDIF
            YD = YD/SQRT( 1 + ( Y(I)*YD + 1 )*( Y(I)*YD - 1 )/(NU+I) )
  900    CONTINUE
         CALL MVTLMS( NU, A(1), B(1), INFI(1), D, E)
      ENDIF
C
      RETURN
      END
      SUBROUTINE NBCDF(X,P,AN,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE AT THE SINGLE PRECISION VALUE X
C              FOR THE NEGATIVE BINOMIAL DISTRIBUTION
C              WITH SINGLE PRECISION 'BERNOULLI PROBABILITY'
C              PARAMETER = P,
C              AND INTEGER 'NUMBER OF SUCCESSES IN BERNOULLI TRIALS'
C              PARAMETER = N.
C              THE NEGATIVE BINOMIAL DISTRIBUTION USED
C              HEREIN HAS MEAN = N*(1-P)/P
C              AND STANDARD DEVIATION = SQRT(N*(1-P)/(P*P))).
C              THIS DISTRIBUTION IS DEFINED FOR
C              ALL NON-NEGATIVE INTEGER X--X = 0, 1, 2, ... .
C              THIS DISTRIBUTION HAS THE PROBABILITY FUNCTION
C              F(X) = C(N+X-1,N) * P**N * (1-P)**X.
C              WHERE C(N+X-1,N) IS THE COMBINATORIAL FUNCTION
C              EQUALING THE NUMBER OF COMBINATIONS OF N+X-1 ITEMS
C              TAKEN N AT A TIME.
C              THE NEGATIVE BINOMIAL DISTRIBUTION IS THE
C              DISTRIBUTION OF THE NUMBER OF FAILURES
C              BEFORE OBTAINING N SUCCESSES IN AN
C              INDEFINITE SEQUENCE OF BERNOULLI (0,1)
C              TRIALS WHERE THE PROBABILITY OF SUCCESS
C              IN A SINGLE TRIAL = P.
C
C              THE NEGATIVE BINOMIAL CAN BE EXTENDED TO THE
C              CASE WHERE N IS POSITIVE REAL NUMBER (I.E., NOT
C              RESTRICTED TO AN INTEGER).  IN THAT CASE, THE
C              PROBABILITY FUNCTION IS:
C
C              F(X) = P**N * (1-P)**X * GAMMA(N+X)/(GAMMA(N)*X!)
C
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE
C                                AT WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE NON-NEGATIVE AND
C                                INTEGRAL-VALUED.
C                     --P      = THE SINGLE PRECISION VALUE
C                                OF THE 'BERNOULLI PROBABILITY'
C                                PARAMETER FOR THE NEGATIVE BINOMIAL
C                                DISTRIBUTION.
C                                P SHOULD BE BETWEEN
C                                0.0 (EXCLUSIVELY) AND
C                                1.0 (EXCLUSIVELY).
C                     --N      = THE REAL VALUE
C                                OF THE 'NUMBER OF SUCCESSES
C                                IN BERNOULLI TRIALS' PARAMETER.
C                                N SHOULD BE A POSITIVE NUMBER.
C     OUTPUT ARGUMENTS--CDF    = THE SINGLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE CDF
C             FOR THE NEGATIVE BINOMIAL DISTRIBUTION
C             WITH 'BERNOULLI PROBABILITY' PARAMETER = P
C             AND 'NUMBER OF SUCCESSES IN BERNOULLI TRIALS'
C             PARAMETER = N.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE NON-NEGATIVE AND INTEGRAL-VALUED.
C                 --P SHOULD BE BETWEEN 0.0 (EXCLUSIVELY)
C                   AND 1.0 (EXCLUSIVELY).
C                 --N SHOULD BE POSITIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--DSQRT, DATAN, LNGAMM.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     COMMENT--NOTE THAT EVEN THOUGH THE INPUT
C              TO THIS CUMULATIVE
C              DISTRIBUTION FUNCTION SUBROUTINE
C              FOR THIS DISCRETE DISTRIBUTION
C              SHOULD (UNDER NORMAL CIRCUMSTANCES) BE A
C              DISCRETE INTEGER VALUE,
C              THE INPUT VARIABLE X IS SINGLE
C              PRECISION IN MODE.
C              X HAS BEEN SPECIFIED AS SINGLE
C              PRECISION SO AS TO CONFORM WITH THE DATAPAC
C              CONVENTION THAT ALL INPUT ****DATA****
C              (AS OPPOSED TO SAMPLE SIZE, FOR EXAMPLE)
C              VARIABLES TO ALL
C              DATAPAC SUBROUTINES ARE SINGLE PRECISION.
C              THIS CONVENTION IS BASED ON THE BELIEF THAT
C              1) A MIXTURE OF MODES (FLOATING POINT
C              VERSUS INTEGER) IS INCONSISTENT AND
C              AN UNNECESSARY COMPLICATION
C              IN A DATA ANALYSIS; AND
C              2) FLOATING POINT MACHINE ARITHMETIC
C              (AS OPPOSED TO INTEGER ARITHMETIC)
C              IS THE MORE NATURAL MODE FOR DOING
C              DATA ANALYSIS.
C     REFERENCES--NATIONAL BUREAU OF STANDARDS APPLIED MATHEMATICS
C                 SERIES 55, 1964, PAGE 945, FORMULAE 26.5.24 AND
C                 26.5.28, AND PAGE 929.
C               --JOHNSON, KOTZ, AND KEMP, "DISCRETE UNIVARIATE
C                 DISTRIBUTIONS", SECOND EDITION, 1992.
C               --EVANS, HASTINGS AND PEACOCK, STATISTICAL
C                 DISTRIBUTIONS--THIRD EDITION, 2001.
C               --FELLER, AN INTRODUCTION TO PROBABILITY
C                 THEORY AND ITS APPLICATIONS, VOLUME 1,
C                 EDITION 2, 1957, PAGES 155-157, 210.
C               --KENDALL AND STUART, THE ADVANCED THEORY OF
C                 STATISTICS, VOLUME 1, EDITION 2, 1963, PAGES 130-131.
C               --WILLIAMSON AND BRETHERTON, TABLES OF
C                 THE NEGATIVE BINOMIAL PROBABILITY
C                 DISTRIBUTION, 1963.
C               --OWEN, HANDBOOK OF STATISTICAL
C                 TABLES, 1962, PAGE 304.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--82.6
C     ORIGINAL VERSION--NOVEMBER  1975.
C     UPDATED         --DECEMBER  1981.
C     UPDATED         --MAY       1982.
C     UPDATED         --MARCH     2004. EXTEND TO NON-INTEGER VALUES
C                                       FOR N
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      CHARACTER*4 ICASE
C
      DOUBLE PRECISION DX2
      DOUBLE PRECISION PI
      DOUBLE PRECISION ANU1
      DOUBLE PRECISION ANU2
      DOUBLE PRECISION Z
      DOUBLE PRECISION SUM
      DOUBLE PRECISION TERM
      DOUBLE PRECISION AI
      DOUBLE PRECISION COEF1
      DOUBLE PRECISION COEF2
      DOUBLE PRECISION ARG
      DOUBLE PRECISION COEF
      DOUBLE PRECISION THETA
      DOUBLE PRECISION SINTH
      DOUBLE PRECISION COSTH
      DOUBLE PRECISION A
      DOUBLE PRECISION B
      DOUBLE PRECISION DSQRT
      DOUBLE PRECISION DATAN
      DOUBLE PRECISION DBETAI
      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
      DATA PI/3.14159265358979D0/
      DATA EPS/0.000001/
C
C-----START POINT-----------------------------------------------------
C
      B=0.0
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(P.LE.0.0.OR.P.GE.1.0)THEN
        WRITE(ICOUT,11)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)P
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9000
      ENDIF
   11 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO THE ',
     1'NBCDF  SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL')
C
      IF(X.LT.0.0)THEN
        WRITE(ICOUT,4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9000
      ENDIF
    4 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT ',
     1'TO THE NBCDF  SUBROUTINE IS NEGATIVE *****')
C
      INTN=AN+EPS
      FINTN=INTN
      DELN=ABS(AN-FINTX)
      ICASE='INTE'
      IF(DELN.GT.EPS)ICASE='REAL'
      N=INTN
      IF(ICASE.EQ.'INTE' .AND. N.LT.1)THEN
        WRITE(ICOUT,25)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9000
      ELSEIF(ICASE.EQ.'REAL' .AND. AN.LE.0.0)THEN
        WRITE(ICOUT,27)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)AN
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9000
      ENDIF
   25 FORMAT('***** ERROR--THE THIRD INPUT ARGUMENT TO THE ',
     1'NBCDF  SUBROUTINE IS A NON-POSITIVE INTEGER *****')
   27 FORMAT('***** ERROR--THE THIRD INPUT ARGUMENT TO THE ',
     1'NBCDF  SUBROUTINE IS A NON-POSITIVE REAL *****')
C
      INTX=X+0.0001
      FINTX=INTX
      DEL=ABS(X-FINTX)
      IF(DEL.GT.0.001)THEN
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
      ENDIF
    5 FORMAT('***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT ',
     1'TO THE NBCDF  SUBROUTINE IS NON-INTEGRAL *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
C
C     SUPPORT NON-INTEGER VALUES FOR N.  IN THIS CASE, THE
C     CDF FUNCTION = 1 - I(1-P)(X+1,AN)
C
      IF(ICASE.EQ.'REAL')THEN
        DCDF=1.0D0 - DBETAI(DBLE(1.0-P),DBLE(INTX+1),DBLE(AN))
        CDF=REAL(DCDF)
        GOTO9000
      ENDIF
C
C     EXPRESS THE NEGATIVE BINOMIAL CUMULATIVE DISTRIBUTION
C     FUNCTION IN TERMS OF THE EQUIVALENT BINOMIAL
C     CUMULATIVE DISTRIBUTION FUNCTION,
C     AND THEN OPERATE ON THE LATTER.
C
      INTX=X+0.0001
      K=N-1
      N2=N+INTX
C
C     EXPRESS THE BINOMIAL CUMULATIVE DISTRIBUTION
C     FUNCTION IN TERMS OF THE EQUIVALENT F
C     CUMULATIVE DISTRIBUTION FUNCTION,
C     AND THEN EVALUATE THE LATTER.
C
      AK=K
      AN2=N2
      DX2=(P/(1.0-P))*((AN2-AK)/(AK+1.0))
      NU1=2*(K+1)
      NU2=2*(N2-K)
      ANU1=NU1
      ANU2=NU2
      Z=ANU2/(ANU2+ANU1*DX2)
C
C     DETERMINE IF NU1 AND NU2 ARE EVEN OR ODD
C
      IFLAG1=NU1-2*(NU1/2)
      IFLAG2=NU2-2*(NU2/2)
      IF(IFLAG1.EQ.0)GOTO120
      IF(IFLAG2.EQ.0)GOTO150
      GOTO250
C
C     DO THE NU1 EVEN AND NU2 EVEN OR ODD CASE
C
  120 SUM=0.0D0
      TERM=1.0D0
      IMAX=(NU1-2)/2
      IF(IMAX.LE.0)GOTO110
      DO100I=1,IMAX
      AI=I
      COEF1=2.0D0*(AI-1.0D0)
      COEF2=2.0D0*AI
      TERM=TERM*((ANU2+COEF1)/COEF2)*(1.0D0-Z)
      SUM=SUM+TERM
  100 CONTINUE
C
  110 SUM=SUM+1.0D0
      SUM=(Z**(ANU2/2.0D0))*SUM
      CDF=1.0D0-SUM
      GOTO9000
C
C     DO THE NU1 ODD AND NU2 EVEN CASE
C
  150 SUM=0.0D0
      TERM=1.0D0
      IMAX=(NU2-2)/2
      IF(IMAX.LE.0)GOTO210
      DO200I=1,IMAX
      AI=I
      COEF1=2.0D0*(AI-1.0D0)
      COEF2=2.0D0*AI
      TERM=TERM*((ANU1+COEF1)/COEF2)*Z
      SUM=SUM+TERM
  200 CONTINUE
C
  210 SUM=SUM+1.0D0
      CDF=((1.0D0-Z)**(ANU1/2.0D0))*SUM
      GOTO9000
C
C     DO THE NU1 ODD AND NU2 ODD CASE
C
  250 SUM=0.0D0
      TERM=1.0D0
      ARG=DSQRT((ANU1/ANU2)*DX2)
      THETA=DATAN(ARG)
      SINTH=ARG/DSQRT(1.0D0+ARG*ARG)
      COSTH=1.0D0/DSQRT(1.0D0+ARG*ARG)
      IF(NU2.EQ.1)GOTO320
      IF(NU2.EQ.3)GOTO310
      IMAX=NU2-2
      DO300I=3,IMAX,2
      AI=I
      COEF1=AI-1.0D0
      COEF2=AI
      TERM=TERM*(COEF1/COEF2)*(COSTH*COSTH)
      SUM=SUM+TERM
  300 CONTINUE
C
  310 SUM=SUM+1.0D0
      SUM=SUM*SINTH*COSTH
C
  320 A=(2.0D0/PI)*(THETA+SUM)
  350 SUM=0.0D0
      TERM=1.0D0
      IF(NU1.EQ.1)B=0.0D0
      IF(NU1.EQ.1)GOTO450
      IF(NU1.EQ.3)GOTO410
      IMAX=NU1-3
      DO400I=1,IMAX,2
      AI=I
      COEF1=AI
      COEF2=AI+2.0D0
      TERM=TERM*((ANU2+COEF1)/COEF2)*(SINTH*SINTH)
      SUM=SUM+TERM
  400 CONTINUE
C
  410 SUM=SUM+1.0D0
      SUM=SUM*SINTH*(COSTH**N)
      COEF=1.0D0
      IEVODD=NU2-2*(NU2/2)
      IMIN=3
      IF(IEVODD.EQ.0)IMIN=2
      IF(IMIN.GT.NU2)GOTO420
      DO430I=IMIN,NU2,2
      AI=I
      COEF=((AI-1.0D0)/AI)*COEF
  430 CONTINUE
C
  420 COEF=COEF*ANU2
      IF(IEVODD.EQ.0)GOTO440
      COEF=COEF*(2.0D0/PI)
C
  440 B=COEF*SUM
C
  450 CDF=A-B
C
 9000 CONTINUE
      RETURN
C
      END
      INTEGER FUNCTION NBPK(M,J)
CCCCC INTEGER FUNCTION NBP_K(M,J)
      IF (M.LT.J) THEN
          NBPK=0
      ELSE
          IF (J.EQ.1) NBPK=M
          IF (J.EQ.2) NBPK=(M*(M-1))/2
          IF (J.EQ.3) NBPK=(M*(M-1)*(M-2))/6
      ENDIF
      RETURN
      END
      INTEGER FUNCTION NBPNCE(M,J)
CCCCC CHANGE TO 6-CHARACTER NAME
CCCCC INTEGER FUNCTION NBP_NCEIL(M,J)
      IF (MOD(M,J).EQ.0) THEN
         NBPNCE=INT(dble(M)/J)
      ELSE
         NBPNCE=NINT(dble(M)/J+0.5)
      ENDIF
      RETURN
      END
      SUBROUTINE NBPDF(X,P,AN,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY MASS
C              FUNCTION VALUE AT THE SINGLE PRECISION VALUE X
C              FOR THE NEGATIVE BINOMIAL DISTRIBUTION
C              WITH SINGLE PRECISION 'BERNOULLI PROBABILITY'
C              PARAMETER = P,
C              AND INTEGER 'NUMBER OF SUCCESSES IN BERNOULLI TRIALS'
C              PARAMETER = N.
C              THE NEGATIVE BINOMIAL DISTRIBUTION USED
C              HEREIN HAS MEAN = N*(1-P)/P
C              AND STANDARD DEVIATION = SQRT(N*(1-P)/(P*P))).
C              THIS DISTRIBUTION IS DEFINED FOR
C              ALL NON-NEGATIVE INTEGER X--X = 0, 1, 2, ... .
C              THIS DISTRIBUTION HAS THE PROBABILITY FUNCTION
C              F(X) = C(N+X-1,N) * P**N * (1-P)**X.
C              WHERE C(N+X-1,N) IS THE COMBINATORIAL FUNCTION
C              EQUALING THE NUMBER OF COMBINATIONS OF N+X-1 ITEMS
C              TAKEN N AT A TIME.
C              THE NEGATIVE BINOMIAL DISTRIBUTION IS THE
C              DISTRIBUTION OF THE NUMBER OF FAILURES
C              BEFORE OBTAINING N SUCCESSES IN AN
C              INDEFINITE SEQUENCE OF BERNOULLI (0,1)
C              TRIALS WHERE THE PROBABILITY OF SUCCESS
C              IN A SINGLE TRIAL = P.
C
C              THE NEGATIVE BINOMIAL CAN BE EXTENDED TO THE
C              CASE WHERE N IS POSITIVE REAL NUMBER (I.E., NOT
C              RESTRICTED TO AN INTEGER).  IN THAT CASE, THE
C              PROBABILITY FUNCTION IS:
C
C              F(X) = P**N * (1-P)**X * GAMMA(N+X)/(GAMMA(N)*X!)
C
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE
C                                AT WHICH THE PROBABILITY MASS
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE NON-NEGATIVE AND
C                                INTEGRAL-VALUED.
C                     --P      = THE SINGLE PRECISION VALUE
C                                OF THE 'BERNOULLI PROBABILITY'
C                                PARAMETER FOR THE NEGATIVE BINOMIAL
C                                DISTRIBUTION.
C                                P SHOULD BE BETWEEN
C                                0.0 (EXCLUSIVELY) AND
C                                1.0 (EXCLUSIVELY).
C                     --N      = THE REAL VALUE
C                                OF THE 'NUMBER OF SUCCESSES
C                                IN BERNOULLI TRIALS' PARAMETER.
C                                N SHOULD BE A POSITIVE NUMBER.
C     OUTPUT ARGUMENTS--PDF    = THE SINGLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PROBABILITY MASS
C             FUNCTION VALUE PDF
C             FOR THE NEGATIVE BINOMIAL DISTRIBUTION
C             WITH 'BERNOULLI PROBABILITY' PARAMETER = P
C             AND 'NUMBER OF SUCCESSES IN BERNOULLI TRIALS'
C             PARAMETER = N.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE NON-NEGATIVE AND INTEGRAL-VALUED.
C                 --P SHOULD BE BETWEEN 0.0 (EXCLUSIVELY)
C                   AND 1.0 (EXCLUSIVELY).
C                 --N SHOULD BE POSITIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--DSQRT, DATAN, LNGAMM.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     COMMENT--NOTE THAT EVEN THOUGH THE INPUT
C              TO THIS CUMULATIVE
C              DISTRIBUTION FUNCTION SUBROUTINE
C              FOR THIS DISCRETE DISTRIBUTION
C              SHOULD (UNDER NORMAL CIRCUMSTANCES) BE A
C              DISCRETE INTEGER VALUE,
C              THE INPUT VARIABLE X IS SINGLE
C              PRECISION IN MODE.
C              X HAS BEEN SPECIFIED AS SINGLE
C              PRECISION SO AS TO CONFORM WITH THE DATAPAC
C              CONVENTION THAT ALL INPUT ****DATA****
C              (AS OPPOSED TO SAMPLE SIZE, FOR EXAMPLE)
C              VARIABLES TO ALL
C              DATAPAC SUBROUTINES ARE SINGLE PRECISION.
C              THIS CONVENTION IS BASED ON THE BELIEF THAT
C              1) A MIXTURE OF MODES (FLOATING POINT
C              VERSUS INTEGER) IS INCONSISTENT AND
C              AN UNNECESSARY COMPLICATION
C              IN A DATA ANALYSIS; AND
C              2) FLOATING POINT MACHINE ARITHMETIC
C              (AS OPPOSED TO INTEGER ARITHMETIC)
C              IS THE MORE NATURAL MODE FOR DOING
C              DATA ANALYSIS.
C     REFERENCES--NATIONAL BUREAU OF STANDARDS APPLIED MATHEMATICS
C                 SERIES 55, 1964, PAGE 945, FORMULAE 26.5.24 AND
C                 26.5.28, AND PAGE 929.
C               --JOHNSON, KOTZ, AND KEMP, "DISCRETE UNIVARIATE
C                 DISTRIBUTIONS", SECOND EDITION, 1992.
C               --EVANS, HASTINGS AND PEACOCK, STATISTICAL
C                 DISTRIBUTIONS--THIRD EDITION, 2001.
C               --FELLER, AN INTRODUCTION TO PROBABILITY
C                 THEORY AND ITS APPLICATIONS, VOLUME 1,
C                 EDITION 2, 1957, PAGES 155-157, 210.
C               --KENDALL AND STUART, THE ADVANCED THEORY OF
C                 STATISTICS, VOLUME 1, EDITION 2, 1963, PAGES 130-131.
C               --WILLIAMSON AND BRETHERTON, TABLES OF
C                 THE NEGATIVE BINOMIAL PROBABILITY
C                 DISTRIBUTION, 1963.
C               --OWEN, HANDBOOK OF STATISTICAL
C                 TABLES, 1962, PAGE 304.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--2004/3
C     ORIGINAL VERSION--MARCH     2004.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      CHARACTER*4 ICASE
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DP
      DOUBLE PRECISION DQ
      DOUBLE PRECISION DN
      DOUBLE PRECISION DLNGAM
      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
      DATA EPS/0.000001/
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(P.LE.0.0.OR.P.GE.1.0)THEN
        WRITE(ICOUT,11)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)P
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9000
      ENDIF
   11 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO THE ',
     1'NBPDF  SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL')
C
      IF(X.LT.0.0)THEN
        WRITE(ICOUT,4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9000
      ENDIF
    4 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT ',
     1'TO THE NBPDF  SUBROUTINE IS NEGATIVE *****')
C
      INTN=AN+EPS
      FINTN=INTN
      DELN=ABS(AN-FINTX)
      ICASE='INTE'
      IF(DELN.GT.EPS)ICASE='REAL'
      N=INTN
      IF(ICASE.EQ.'INTE' .AND. N.LT.1)THEN
        WRITE(ICOUT,25)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9000
      ELSEIF(ICASE.EQ.'REAL' .AND. AN.LE.0.0)THEN
        WRITE(ICOUT,27)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)AN
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9000
      ENDIF
   25 FORMAT('***** ERROR--THE THIRD INPUT ARGUMENT TO THE ',
     1'NBPDF  SUBROUTINE IS A NON-POSITIVE INTEGER *****')
   27 FORMAT('***** ERROR--THE THIRD INPUT ARGUMENT TO THE ',
     1'NBPDF  SUBROUTINE IS A NON-POSITIVE REAL *****')
C
      INTX=X+0.0001
      FINTX=INTX
      DEL=ABS(X-FINTX)
      IF(DEL.GT.0.001)THEN
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
      ENDIF
    5 FORMAT('***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT ',
     1'TO THE NBPDF  SUBROUTINE IS NON-INTEGRAL *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
C
C     SUPPORT NON-INTEGER VALUES FOR N.  IN THIS CASE, THE
C     PDF FUNCTION = 1 - I(1-P)(X+1,AN)
C
      DN=DBLE(N)
      DP=DBLE(P)
      DQ=DBLE(1.0-P)
      DX=DBLE(FINTX)
      DPDF=DLNGAM(DN+DX) + DN*DLOG(DP) + DX*DLOG(DQ) - DLNGAM(DN) -
     1     DLNGAM(DX+1.0D0)
      DPDF=DEXP(DPDF)
      PDF=REAL(DPDF)
C
 9000 CONTINUE
      RETURN
C
      END
      SUBROUTINE NBPPF(P,PPAR,AN,PPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE AT THE SINGLE PRECISION VALUE P
C              FOR THE NEGATIVE BINOMIAL DISTRIBUTION
C              WITH SINGLE PRECISION 'BERNOULLI PROBABILITY'
C              PARAMETER = PPAR,
C              AND INTEGER 'NUMBER OF SUCCESSES IN BERNOULLI TRIALS'
C              PARAMETER = N.
C              THE NEGATIVE BINOMIAL DISTRIBUTION USED
C              HEREIN HAS MEAN = N*(1-PPAR)/PPAR
C              AND STANDARD DEVIATION = SQRT(N*(1-PPAR)/(PPAR*PPAR))).
C              THIS DISTRIBUTION IS DEFINED FOR
C              ALL NON-NEGATIVE INTEGER X--X = 0, 1, 2, ... .
C              THIS DISTRIBUTION HAS THE PROBABILITY FUNCTION
C              F(X) = C(N+X-1,N) * PPAR**N * (1-PPAR)**X.
C              WHERE C(N+X-1,N) IS THE COMBINATORIAL FUNCTION
C              EQUALING THE NUMBER OF COMBINATIONS OF N+X-1 ITEMS
C              TAKEN N AT A TIME.
C              THE NEGATIVE BINOMIAL DISTRIBUTION IS THE
C              DISTRIBUTION OF THE NUMBER OF FAILURES
C              BEFORE OBTAINING N SUCCESSES IN AN
C              INDEFINITE SEQUENCE OF BERNOULLI (0,1)
C              TRIALS WHERE THE PROBABILITY OF SUCCESS
C              IN A SINGLE TRIAL = PPAR.
C              NOTE THAT THE PERCENT POINT FUNCTION OF A DISTRIBUTION
C              IS IDENTICALLY THE SAME AS THE INVERSE CUMULATIVE
C              DISTRIBUTION FUNCTION OF THE DISTRIBUTION.
C     INPUT  ARGUMENTS--P      = THE SINGLE PRECISION VALUE
C                                (BETWEEN 0.0 (INCLUSIVELY)
C                                AND 1.0 (EXCLUSIVELY))
C                                AT WHICH THE PERCENT POINT
C                                FUNCTION IS TO BE EVALUATED.
C                     --PPAR   = THE SINGLE PRECISION VALUE
C                                OF THE 'BERNOULLI PROBABILITY'
C                                PARAMETER FOR THE NEGATIVE BINOMIAL
C                                DISTRIBUTION.
C                                PPAR SHOULD BE BETWEEN
C                                0.0 (EXCLUSIVELY) AND
C                                1.0 (EXCLUSIVELY).
C                     --N      = THE INTEGER VALUE
C                                OF THE 'NUMBER OF SUCCESSES
C                                IN BERNOULLI TRIALS' PARAMETER.
C                                N SHOULD BE A POSITIVE INTEGER.
C     OUTPUT ARGUMENTS--PPF    = THE SINGLE PRECISION PERCENT
C                                POINT FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PERCENT POINT  .
C             FUNCTION VALUE PPF
C             FOR THE NEGATIVE BINOMIAL DISTRIBUTION
C             WITH 'BERNOULLI PROBABILITY' PARAMETER = PPAR
C             AND 'NUMBER OF SUCCESSES IN BERNOULLI TRIALS'
C             PARAMETER = N.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--PPAR SHOULD BE BETWEEN 0.0 (EXCLUSIVELY)
C                   AND 1.0 (EXCLUSIVELY).
C                 --N SHOULD BE A POSITIVE INTEGER.
C                 --P SHOULD BE BETWEEN 0.0 (INCLUSIVELY)
C                   AND 1.0 (EXCLUSIVELY).
C     OTHER DATAPAC   SUBROUTINES NEEDED--NORPPF, NBCDF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--SQRT, EXP, ALOG.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION AND DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     COMMENT--NOTE THAT EVEN THOUGH THE OUTPUT
C              FROM THIS DISCRETE DISTRIBUTION
C              PERCENT POINT FUNCTION
C              SUBROUTINE MUST NECESSARILY BE A
C              DISCRETE INTEGER VALUE,
C              THE OUTPUT VARIABLE PPF IS SINGLE
C              PRECISION IN MODE.
C              PPF HAS BEEN SPECIFIED AS SINGLE
C              PRECISION SO AS TO CONFORM WITH THE DATAPAC
C              CONVENTION THAT ALL OUTPUT VARIABLES FROM ALL
C              DATAPAC SUBROUTINES ARE SINGLE PRECISION.
C              THIS CONVENTION IS BASED ON THE BELIEF THAT
C              1) A MIXTURE OF MODES (FLOATING POINT
C              VERSUS INTEGER) IS INCONSISTENT AND
C              AN UNNECESSARY COMPLICATION
C              IN A DATA ANALYSIS; AND
C              2) FLOATING POINT MACHINE ARITHMETIC
C              (AS OPPOSED TO INTEGER ARITHMETIC)
C              IS THE MORE NATURAL MODE FOR DOING
C              DATA ANALYSIS.
C     REFERENCES--JOHNSON AND KOTZ, DISCRETE
C                 DISTRIBUTIONS, 1969, PAGES 122-142,
C                 ESPECIALLY PAGE 127, FORMULA 22.
C               --HASTINGS AND PEACOCK, STATISTICAL
C                 DISTRIBUTIONS--A HANDBOOK FOR
C                 STUDENTS AND PRACTITIONERS, 1975,
C                 PAGES 92-95.
C               --NATIONAL BUREAU OF STANDARDS APPLIED MATHEMATICS
C                 SERIES 55, 1964, PAGE 929.
C               --FELLER, AN INTRODUCTION TO PROBABILITY
C                 THEORY AND ITS APPLICATIONS, VOLUME 1,
C                 EDITION 2, 1957, PAGES 155-157, 210.
C               --KENDALL AND STUART, THE ADVANCED THEORY OF
C                 STATISTICS, VOLUME 1, EDITION 2, 1963, PAGES 130-131.
C               --WILLIAMSON AND BRETHERTON, TABLES OF
C                 THE NEGATIVE BINOMIAL PROBABILITY
C                 DISTRIBUTION, 1963.
C               --OWEN, HANDBOOK OF STATISTICAL
C                 TABLES, 1962, PAGE 304.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--82.6
C     ORIGINAL VERSION--NOVEMBER  1975.
C     UPDATED         --OCTOBER   1978.
C     UPDATED         --DECEMBER  1981.
C     UPDATED         --DECEMBER  1981.
C     UPDATED         --MAY       1982.
C     UPDATED         --MARCH     2004. EXTENDED TO SUPPORT
C                                       NON-INTEGER VALUES FOR N
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DPPAR
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(P.LT.0.0.OR.P.GE.1.0)THEN
        WRITE(ICOUT,1)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)P
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
        GOTO9000
      ENDIF
      IF(PPAR.LE.0.0.OR.PPAR.GE.1.0)THEN
        WRITE(ICOUT,11)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)PPAR
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
        GOTO9000
      ENDIF
      IF(AN.LE.0.0)THEN
        WRITE(ICOUT,25)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)AN
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
        GOTO9000
      ENDIF
    1 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO THE ',
     1'NBPPF  SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL')
   11 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO THE ',
     1'NBPPF  SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL')
   25 FORMAT('***** ERROR--THE THIRD INPUT ARGUMENT TO THE ',
     1'NBPPF  SUBROUTINE IS NON-POSITIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
C
      N=INT(AN+0.000001)
      DPPAR=PPAR
      PPF=0.0
      IX0=0
      IX1=0
      IX2=0
      P0=0.0
      P1=0.0
      P2=0.0
C
C     TREAT CERTAIN SPECIAL CASES IMMEDIATELY--
C     1) P = 0.0
C     2) P = 0.5 AND PPAR = 0.5
C     3) PPF = 0
C
      IF(P.EQ.0.0)THEN
        PPF=0.0
        GOTO9000
      ENDIF
      IF(P.EQ.0.5.AND.PPAR.EQ.0.5)THEN
        PPF=N-1
        GOTO9000
      ENDIF
      PF0=DPPAR**AN
      IF(P.LE.PF0)THEN
        PPF=0.0
        GOTO9000
      ENDIF
C
C     DETERMINE AN INITIAL APPROXIMATION TO THE NEGATIVE BINOMIAL
C     PERCENT POINT BY USE OF THE HYPERBOLIC ARCSIN
C     TRANSFORMATION OF THE NEGATIVE BINOMIAL
C     TO APPROXIMATE NORMALITY.
C     (SEE JOHNSON AND KOTZ, DISCRETE DISTRIBUTIONS,
C     PAGE 127, FORMULA 22).
C
      AMEAN=AN*(1.0-PPAR)/PPAR
      SD=SQRT(AN*(1.0-PPAR)/(PPAR*PPAR))
      ARG=SQRT((AMEAN+0.375)/(AN-0.75))
      ARCSH=ALOG(ARG+SQRT(ARG*ARG+1.0))
      YMEAN=(SQRT(AN-0.5))*ARCSH
      YSD=0.5
      CALL NORPPF(P,ZPPF)
      YPPF=YMEAN+ZPPF*YSD
      ARG=YPPF/SQRT(AN-0.5)
      E=EXP(ARG)
      SINH=(E-1.0/E)/2.0
      X2=-0.375+(AN-0.75)*SINH*SINH
      X2=X2+0.5
      IX2=X2
C
C     CHECK AND MODIFY (IF NECESSARY) THIS INITIAL
C     ESTIMATE OF THE PERCENT POINT
C     TO ASSURE THAT IT BE NON-NEGATIVE.
C
      IF(IX2.LT.0)IX2=0
C
C     DETERMINE UPPER AND LOWER BOUNDS ON THE DESIRED
C     PERCENT POINT BY ITERATING OUT (BOTH BELOW AND ABOVE)
C     FROM THE ORIGINAL APPROXIMATION AT STEPS
C     OF 1 STANDARD DEVIATION.
C     THE RESULTING BOUNDS WILL BE AT MOST
C     1 STANDARD DEVIATION APART.
C
      IX0=0
      IX1=INT(10.0**7 + 0.01)
      ISD=SD+1.0
      X2=IX2
      CALL NBCDF(X2,PPAR,AN,P2)
C
      IF(P2.LT.P)GOTO210
      GOTO250
C
  210 CONTINUE
      IX0=IX2
      I=1
  215 CONTINUE
      IX2=IX0+ISD
      IF(IX2.GE.IX1)GOTO275
      X2=IX2
      CALL NBCDF(X2,PPAR,AN,P2)
      IF(P2.GE.P)GOTO230
      IX0=IX2
  220 CONTINUE
      I=I+1
      IF(I.LE.1000000)GOTO215
      WRITE(ICOUT,249)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,222)
      CALL DPWRST('XXX','BUG ')
      GOTO950
  230 IX1=IX2
      GOTO275
C
  250 CONTINUE
      IX1=IX2
      I=1
  255 CONTINUE
      IX2=IX1-ISD
      IF(IX2.LE.IX0)GOTO275
      X2=IX2
      CALL NBCDF(X2,PPAR,AN,P2)
      IF(P2.LT.P)GOTO270
      IX1=IX2
  260 CONTINUE
      I=I+1
      IF(I.LE.1000000)GOTO255
      WRITE(ICOUT,249)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,262)
      CALL DPWRST('XXX','BUG ')
      GOTO950
  270 IX0=IX2
C
  275 IF(IX0.EQ.IX1)GOTO280
      GOTO295
  280 IF(IX0.EQ.0)GOTO285
      IF(IX0.EQ.N)GOTO290
      WRITE(ICOUT,249)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,282)
      CALL DPWRST('XXX','BUG ')
      GOTO950
  285 IX1=IX1+1
      GOTO295
  290 IX0=IX0-1
  295 CONTINUE
C
C     COMPUTE NEGATIVE BINOMIAL PROBABILITIES FOR THE
C     DERIVED LOWER AND UPPER BOUNDS.
C
      X0=IX0
      X1=IX1
      CALL NBCDF(X0,PPAR,AN,P0)
      CALL NBCDF(X1,PPAR,AN,P1)
C
C     CHECK THE PROBABILITIES FOR PROPER ORDERING
C
      IF(P0.LT.P.AND.P.LE.P1)GOTO490
      IF(P0.EQ.P)GOTO410
      IF(P1.EQ.P)GOTO420
      IF(P0.GT.P1)GOTO430
      IF(P0.GT.P)GOTO440
      IF(P1.LT.P)GOTO450
      WRITE(ICOUT,249)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,401)
      CALL DPWRST('XXX','BUG ')
      GOTO950
  410 PPF=IX0
      GOTO9000
  420 PPF=IX1
      GOTO9000
  430 WRITE(ICOUT,249)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,431)
      CALL DPWRST('XXX','BUG ')
      GOTO950
  440 WRITE(ICOUT,249)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,441)
      CALL DPWRST('XXX','BUG ')
      GOTO950
  450 WRITE(ICOUT,249)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,451)
      CALL DPWRST('XXX','BUG ')
      GOTO950
  490 CONTINUE
C
C     THE STOPPING CRITERION IS THAT THE LOWER BOUND
C     AND UPPER BOUND ARE EXACTLY 1 UNIT APART.
C     CHECK TO SEE IF IX1 = IX0 + 1;
C     IF SO, THE ITERATIONS ARE COMPLETE;
C     IF NOT, THEN BISECT, COMPUTE PROBABILIIES,
C     CHECK PROBABILITIES, AND CONTINUE ITERATING
C     UNTIL IX1 = IX0 + 1.
C
  300 IX0P1=IX0+1
      IF(IX1.EQ.IX0P1)GOTO690
      IX2=(IX0+IX1)/2
      IF(IX2.EQ.IX0)GOTO610
      IF(IX2.EQ.IX1)GOTO620
      X2=IX2
      CALL NBCDF(X2,PPAR,AN,P2)
      IF(P0.LT.P2.AND.P2.LT.P1)GOTO630
      IF(P2.LE.P0)GOTO640
      IF(P2.GE.P1)GOTO650
  610 WRITE(ICOUT,249)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,611)
      CALL DPWRST('XXX','BUG ')
      GOTO950
  620 WRITE(ICOUT,249)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,611)
      CALL DPWRST('XXX','BUG ')
      GOTO950
  630 IF(P2.LE.P)GOTO635
      IX1=IX2
      P1=P2
      GOTO300
  635 IX0=IX2
      P0=P2
      GOTO300
  640 WRITE(ICOUT,249)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,641)
      CALL DPWRST('XXX','BUG ')
      GOTO950
  650 WRITE(ICOUT,249)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,651)
      CALL DPWRST('XXX','BUG ')
      GOTO950
  690 PPF=IX1
      IF(P0.EQ.P)PPF=IX0
      GOTO9000
C
  950 WRITE(ICOUT,240)IX0,P0
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,241)IX1,P1
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,242)IX2,P2
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,244)P
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,245)PPAR,N
      CALL DPWRST('XXX','BUG ')
      GOTO9000
C
  222 FORMAT('NO UPPER BOUND FOUND AFTER 10**7 ITERATIONS')
  240 FORMAT('IX0  = ',I8,10X,'P0 = ',F14.7)
  241 FORMAT('IX1  = ',I8,10X,'P1 = ',F14.7)
  242 FORMAT('IX2  = ',I8,10X,'P2 = ',F14.7)
  244 FORMAT('P    = ',F14.7)
  245 FORMAT('PPAR = ',F14.7,10X,'N  = ',I8)
  249 FORMAT('***** INTERNAL ERROR IN NBPPF  SUBROUTINE *****')
  262 FORMAT('NO LOWER BOUND FOUND AFTER 10**7 ITERATIONS')
  282 FORMAT('LOWER AND UPPER BOUND IDENTICAL')
  401 FORMAT('IMPOSSIBLE BRANCH CONDITION ENCOUNTERED')
  431 FORMAT('LOWER BOUND PROBABILITY (P0) GREATER THAN ',
     1 'UPPER BOUND PROBABILITY (P1)')
  441 FORMAT('LOWER BOUND PROBABILITY (P0) GREATER THAN ',
     1 21HINPUT PROBABILITY (P))
  451 FORMAT('UPPER BOUND PROBABILITY (P1) LESS    THAN ',
     1 'INPUT PROBABILITY (P)')
  611 FORMAT('BISECTION VALUE (X2) = LOWER BOUND (X0)')
  621 FORMAT('BISECTION VALUE (X2) = UPPER BOUND (X1)')
  641 FORMAT('BISECTION VALUE PROBABILITY (P2) ',
     1 'LESS THAN LOWER BOUND PROBABILITY (P0)')
  651 FORMAT('BISECTION VALUE PROBABILITY (P2) ',
     1 'GREATER THAN UPPER BOUND PROBABILITY (P1)')
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE NBRAN(N,P,AK,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE NEGATIVE BINOMIAL DISTRIBUTION
C              WITH SINGLE PRECISION 'BERNOULLI PROBABILITY'
C              PARAMETER = P,
C              AND INTEGER 'NUMBER OF SUCCESSES IN BERNOULLI TRIALS'
C              PARAMETER = K.
C              THE NEGATIVE BINOMIAL DISTRIBUTION USED
C              HEREIN HAS MEAN = K*(1-P)/P
C              AND STANDARD DEVIATION = SQRT(K*(1-P)/(P*P))).
C              THIS DISTRIBUTION IS DEFINED FOR
C              ALL NON-NEGATIVE INTEGER X--X = 0, 1, 2, ... .
C              THIS DISTRIBUTION HAS THE PROBABILITY FUNCTION
C              F(X) = C(K+X-1,K) * P**K * (1-P)**X.
C              WHERE C(K+X-1,K) IS THE COMBINATORIAL FUNCTION
C              EQUALING THE NUMBER OF COMBINATIONS OF K+X-1 ITEMS
C              TAKEN K AT A TIME.
C              THE NEGATIVE BINOMIAL DISTRIBUTION IS THE
C              DISTRIBUTION OF THE NUMBER OF FAILURES
C              BEFORE OBTAINING K SUCCESSES IN AN
C              INDEFINITE SEQUENCE OF BERNOULLI (0,1)
C              TRIALS WHERE THE PROBABILITY OF SUCCESS
C              IN A SINGLE TRIAL = P.
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --P      = THE SINGLE PRECISION VALUE
C                                OF THE 'BERNOULLI PROBABILITY'
C                                PARAMETER FOR THE NEGATIVE BINOMIAL
C                                DISTRIBUTION.
C                                P SHOULD BE BETWEEN
C                                0.0 (EXCLUSIVELY) AND
C                                1.0 (EXCLUSIVELY).
C                     --K      = THE INTEGER VALUE
C                                OF THE 'NUMBER OF SUCCESSES
C                                IN BERNOULLI TRIALS' PARAMETER.
C                                K SHOULD BE A POSITIVE INTEGER.
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 NEGATIVE BINOMIAL DISTRIBUTION
C             WITH 'BERNOULLI PROBABILITY' PARAMETER = P
C             AND 'NUMBER OF SUCCESSES IN BERNOULLI TRIALS'
C             PARAMETER = K.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C                 --P SHOULD BE BETWEEN 0.0 (EXCLUSIVELY)
C                   AND 1.0 (EXCLUSIVELY).
C                 --K SHOULD BE A POSITIVE INTEGER.
C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN, BINRAN, GEORAN.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     COMMENT--NOTE THAT EVEN THOUGH THE OUTPUT
C              FROM THIS DISCRETE RANDOM NUMBER
C              GENERATOR MUST NECESSARILY BE A
C              SEQUENCE OF ***INTEGER*** VALUES,
C              THE OUTPUT VECTOR X IS SINGLE
C              PRECISION IN MODE.
C              X HAS BEEN SPECIFIED AS SINGLE
C              PRECISION SO AS TO CONFORM WITH THE DATAPAC
C              CONVENTION THAT ALL OUTPUT VECTORS FROM ALL
C              DATAPAC SUBROUTINES ARE SINGLE PRECISION.
C              THIS CONVENTION IS BASED ON THE BELIEF THAT
C              1) A MIXTURE OF MODES (FLOATING POINT
C              VERSUS INTEGER) IS INCONSISTENT AND
C              AN UNNECESSARY COMPLICATION
C              IN A DATA ANALYSIS; AND
C              2) FLOATING POINT MACHINE ARITHMETIC
C              (AS OPPOSED TO INTEGER ARITHMETIC)
C              IS THE MORE NATURAL MODE FOR DOING
C              DATA ANALYSIS.
C     REFERENCES--HASTINGS AND PEACOCK, STATISTICAL
C                 DISTRIBUTIONS--A HANDBOOK FOR
C                 STUDENTS AND PRACTITIONERS, 1975,
C                 PAGE 95.
C               --JOHNSON AND KOTZ, DISCRETE
C                 DISTRIBUTIONS, 1969, PAGES 122-142.
C               --FELLER, AN INTRODUCTION TO PROBABILITY
C                 THEORY AND ITS APPLICATIONS, VOLUME 1,
C                 EDITION 2, 1957, PAGES 155-157, 210.
C               --NATIONAL BUREAU OF STANDARDS APPLIED MATHEMATICS
C                 SERIES 55, 1964, PAGE 929.
C               --KENDALL AND STUART, THE ADVANCED THEORY OF
C                 STATISTICS, VOLUME 1, EDITION 2, 1963, PAGES 130-131.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--82.6
C     ORIGINAL VERSION--NOVEMBER  1975.
C     UPDATED         --DECEMBER  1981.
C     UPDATED         --MAY       1982.
C     UPDATED         --MARCH     2004. SUPPORT FOR NON-INTEGER K
C     UPDATED         --MARCH     2004. ALGORITHM FOR MODERATE TO
C                                       LARGE K APPEARS WRONG (STARTS
C                                       AT X>=K, I.E., BASED ON
C                                       ALTERNATIVE DEFINITION OF
C                                       NEGATIVE BINOMIAL.
C                                       REPLACE CURRENT ALGORITHM
C                                       WITH CODE FROM ALAN MILLER
C                                       BASED ON J. DAGPUNAR,
C                                       "PRINCIPLES OF RANDOM VARIATE
C                                       GENERATION", CLARENDON PRESS,
C                                       OXFORD, 1988.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      REAL X(*)
C
COLD  DIMENSION B(2)
COLD  DIMENSION G(2)
C
      REAL H
      REAL Q
      REAL XTEMP
      REAL ST
      REAL AK
      REAL ULN
      REAL V
      REAL R(1)
      REAL S
      REAL Y
      REAL G
      INTEGER K
      INTEGER I
      INTEGER NTEMP
      INTEGER NUNI
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOMC.INC'
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)THEN
        WRITE(ICOUT, 5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
      IF(P.LE.0.0.OR.P.GE.1.0)THEN
        WRITE(ICOUT,11)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)P
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
      IF(AK.LE.0.0)THEN
        WRITE(ICOUT,25)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)K
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
    5 FORMAT('***** ERROR--THE NUMBER OF REQUESTED NEGATIVE ',
     1'BINOMIAL RANDOM NUMBERS IS NON-POSITIVE.')
   11 FORMAT('***** ERROR--THE FIRST SHAPE PARAMETER FOR THE ',
     1'NEGATIVE BINOMIAL IS OUTSIDE THE (0,1) INTERVAL')
   25 FORMAT('***** ERROR--THE SECOND SHAPE PARAMETER FOR THE ',
     1'NEGATIVE BINOMIAL IS NON-POSITIVE')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
C
C
C
C     REPLACE FOLLOWING ALGORITHM WITH ONE THAT CAN ACCOMODATE
C     REAL VALUES FOR K.
C
C     CHECK ON THE MAGNITUDE OF P,
C     AND BRANCH TO THE FASTER
C     GENERATION METHOD ACCORDINGLY.
C
COLD  IF(P.LT.0.1)GOTO450
C
C     IF P IS MODERATE OR LARGE,
C     GENERATE N NEGATIVE BINOMIAL NUMBERS
C     USING THE FACT THAT THE
C     WAITING TIME FOR K SUCCESSES IN
C     BERNOULLI TRIALS HAS A
C     NEGATIVE BINOMIAL DISTRIBUTION.
C
COLD  DO100I=1,N
COLD  ISUM=0
COLD  J=1
CO150 CALL BINRAN(1,P,1,ISEED,B)
COLD  IB=B(1)+0.5
COLD  ISUM=ISUM+IB
COLD  IF(ISUM.EQ.K)GOTO250
COLD  J=J+1
COLD  GOTO150
CO250 X(I)=J
CO100 CONTINUE
COLD  RETURN
C
C     IF P IS SMALL,
C     GENERATE N NEGATIVE BINOMIAL NUMBERS
C     BY USING THE FACT THAT THE SUM
C     OF GEOMETRIC VARIATES IS A
C     NEGATIVE BINOMIAL VARIATE.
C
CO450 DO500I=1,N
COLD  ISUM=0
COLD  DO600J=1,K
COLD  CALL GEORAN(1,P,ISEED,G)
COLD  IG=G(1)+0.5
COLD  ISUM=ISUM+IG
CO600 CONTINUE
COLD  X(I)=ISUM
CO500 CONTINUE
C
C     THIS ALGORITHM REVERSES THE ROLE OF P AND Q AS
C     USED IN DATAPLOT.
C
      NUNI=1
      Q=P
      P2=1.0-Q
      H=0.7
C
      DO600I=1,N
C
        XTEMP=0.0
        ST=AK
C
        IF(P2.GT.H)THEN
          V=1.0/LOG(P2)
          K=ST + 0.0000001
          DO610ITEMP=1,K
  620       CONTINUE
            CALL UNIRAN(NUNI,ISEED,R)
            IF(R(1).LE.0.0)GOTO620
            NTEMP=V*LOG(R(1))
            XTEMP=XTEMP+NTEMP
  610     CONTINUE
          ST=ST-K
        ENDIF
C
        S=0.0
        ULN=-LOG(R1MACH(1))
        IF(ST.GT.-ULN/LOG(Q))THEN
          WRITE(ICOUT,691)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,692)P2,AK
          CALL DPWRST('XXX','BUG ')
          GOTO9000
        ENDIF
        Y=Q**ST
        G=ST
        CALL UNIRAN(NUNI,ISEED,R)
  630   CONTINUE
        IF(Y.LE.R(1))THEN
          R(1)=R(1)-Y
          S=S+1.0
          Y=Y*P2*G/S
          G=G+1.0
          GOTO630
        ENDIF
        X(I)=XTEMP+S
  600 CONTINUE
C
  691 FORMAT('***** ERROR IN NEGATIVE BINOMIAL RANDOM NUMBERS--')
  692 FORMAT('      THE VALUE OF P (',F10.5,') IS TOO LARGE FOR THE ',
     1       'VALUE OF K (',F10.5,')')
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE NCBCDF(XSNGL, ASNGL, BSNGL, LAMBDS, CDF)
C
C     ALGORITHM AS226 APPL. STATIST. (1987) VOL. 36, NO. 2
C     Incorporates modification AS R84 from AS vol. 39, pp311-2, 1990
C
C     Returns the cumulative probability of X for the non-central beta
C     distribution with parameters A, B and non-centrality LAMBDA
C
C     Auxiliary routines required: DLNGAM - log-gamma function (ACM
C     291 or AS 245), and BETAIN - incomplete-beta function (AS 63)
C
      REAL  XSNGL, ASNGL, BSNGL, LAMBDS, CDF
      DOUBLE PRECISION A, AX, B, BETA, C, ERRBD, ERRMAX, GX, HALF, 
     *                 LAMBDA, ONE, Q, SUMQ, TEMP, X, XJ, ZERO
      DOUBLE PRECISION BETANC, A0, X0, UALPHA
      DOUBLE PRECISION DLNGAM
      DOUBLE PRECISION DLBETA
      DOUBLE PRECISION DBETAI
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      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     Change ERRMAX and ITRMAX if desired ...
C     MAY 2004. Increase error criterion and number of iterations
C               (to get more accuracy for PDF function)
C
CCCCC DATA ERRMAX, ITRMAX /1.0D-6, 100/, UALPHA /5.0D0/
      DATA ERRMAX, ITRMAX /1.0D-8, 300/, UALPHA /5.0D0/
      DATA ZERO, HALF, ONE /0.0D0, 0.5D0, 1.0D0/
C
      A=DBLE(ASNGL)
      B=DBLE(BSNGL)
      LAMBDA=DBLE(LAMBDS)
      X=DBLE(XSNGL)
      CDF=0.0
C
      IF(A.LE.0.0 .OR. B.LE.0.0)THEN
        WRITE(ICOUT,101)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,102)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,103)A
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,104)B
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
      IF(X.LT.0.D0)THEN
        WRITE(ICOUT,301)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,302)X
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
      IF(X.GT.1.D0)THEN
        WRITE(ICOUT,401)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,402)X
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
      IF(LAMBDA.LT.0.D0)THEN
        WRITE(ICOUT,501)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,502)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,503)LAMBDS
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
  101 FORMAT('***** FATAL DIAGNOSTIC--EITHER THE ALPHA OR BETA IS')
  102 FORMAT('      NON-POSITIVE.')
  103 FORMAT('      THE VALUE OF ALPHA IS ',E15.7)
  104 FORMAT('      THE VALUE OF BETA IS ',E15.7,'       ******')
  301 FORMAT('***** FATAL DIAGNOSTIC--THE INPUT ARGUMENT IS ')
  302 FORMAT('      NON-POSITIVE.  IT HAS THE VALUE ',E15.7)
  401 FORMAT('***** FATAL DIAGNOSTIC--THE INPUT ARGUMENT IS GRETATER')
  402 FORMAT('      THAN 1.  IT HAS THE VALUE ',E15.7)
  501 FORMAT('***** FATAL DIAGNOSTIC--THE NON-CENTRALITY PARAMETER')
  502 FORMAT('      NEGATIVE.')
  503 FORMAT('      THE VALUE OF LAMBDA IS ',E15.7)
C
      BETANC = X
      CDF=REAL(BETANC)
C
      IF (X .EQ. ZERO .OR. X .EQ. ONE) GOTO9999
C
      C = LAMBDA * HALF
C
C     Initialize the series ...
C
      X0 = INT(MAX(C - UALPHA*SQRT(C), ZERO))
      A0 = A + X0
CCCCC BETA = DLNGAM(A0) + DLNGAM(B) -  DLNGAM(A0+B)
      BETA = DLBETA(A0,B)
      TEMP = DBETAI(X, A0, B)
      GX = EXP(A0 * LOG(X) + B * LOG(ONE - X) - BETA - LOG(A0))
      IF (A0 .GT. A) THEN
        Q = EXP(-C + X0*LOG(C) - DLNGAM(X0 + ONE))
      ELSE
        Q = EXP(-C)
      END IF
      XJ = ZERO
      AX = Q * TEMP
      SUMQ = ONE - Q
      BETANC = AX
C
C     Recur over subsequent terms until convergence is achieved...
C
   10 XJ = XJ + ONE
      TEMP = TEMP - GX
      GX = X * (A + B + XJ - ONE) * GX / (A + XJ)
      Q = Q * C / XJ
      SUMQ = SUMQ - Q
      AX = TEMP * Q
      BETANC = BETANC + AX
C
C     Check for convergence and act accordingly...
C
      ERRBD = (TEMP - GX) * SUMQ
      IF ((INT(XJ) .LT. ITRMAX) .AND. (ERRBD .GT. ERRMAX)) GO TO 10
      IF (ERRBD .GT. ERRMAX) THEN
        WRITE(ICOUT,701)
        CALL DPWRST('XXX','BUG ')
        CDF=REAL(BETANC)
        GOTO9999
      ELSE
        CDF=REAL(BETANC)
        GOTO9999
      ENDIF
  701 FORMAT('***** WARNING--THE BETCDF ROUTINE DID NOT CONVERGE.  ***')
C
 9999 CONTINUE
      RETURN
      END
      REAL FUNCTION NCBFU3(X)
C
C     PURPOSE--NCBPDF CALLS DIFF TO FIND A NUMERICAL DERIVATIVE
C              FOR THE NON-CENTRAL CUMULATIVE DISTRIBUTION FUNCTION.
C              NCBFU3 IS A FUNCTION THAT CALL NCBCDF.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE DERIVATIVE
C                                IS TO BE EVALUATED.
C     OUTPUT--THE SINGLE PRECISION FUNCTION VALUE NCBFU3.
C     PRINTING--NONE.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NCBCDF.
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.3
C     ORIGINAL VERSION--APRIL     2004.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      REAL ALPHA
      REAL BETA
      REAL ALAMB
      COMMON/NCBCOM/ALPHA,BETA,ALAMB
C
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
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 NCBCDF(X,ALPHA,BETA,ALAMB,CDF)
      NCBFU3=CDF
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE NCBPDF(X, A, B, LAMBDA, PDF)
C
C     PURPOSE--PROBABILITY DENSITY FUNCTION FOR THE NON-CENTRAL
C              BETA DISTRIBUTION.  THE PROBABILITY DENSITY FUNCTION
C              IS COMPUTED BY COMPUTING THE NUMERICAL DERIVATIVE OF
C              THE CUMULATIVE DISTRIBUTION FUNCTION.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                     --ALPHA  = THE FIRST SHAPE PARAMETER
C                     --BETA   = THE SECOND SHAPE PARAMETER
C                     --LAMBDS = THE NON-CENTRALITY PARAMETER
C     OUTPUT ARGUMENTS--PDF    = THE SINGLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE PDF.
C     PRINTING--NONE.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--DIFF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--LENTH, "COMPUTING NONCENTRAL BETA PROBABILITIES",
C                 APPLIED STATISTICS, VOL. 39, NO. 2, 1987,
C                 PP. 241-244.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004/4
C     ORIGINAL VERSION--APRIL     2004.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      REAL  X
      REAL  A
      REAL  B
      REAL  LAMBDA
      REAL  PDF
C
      REAL NCBFU3
      EXTERNAL NCBFU3
      REAL ALPHA
      REAL BETA
      REAL ALAMB
      COMMON/NCBCOM/ALPHA,BETA,ALAMB
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      PDF=0.0
C
      IF(A.LE.0.0)THEN
        WRITE(ICOUT,101)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,104)A
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
      IF(B.LE.0.0)THEN
        WRITE(ICOUT,102)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,104)B
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
      IF(LAMBDA.LT.0.0)THEN
        WRITE(ICOUT,103)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,104)LAMBDA
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
      IF(X.LT.0.0 .OR. X.GT.1.0)THEN
        WRITE(ICOUT,105)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,104)X
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
  101 FORMAT('***** ERROR--THE FIRST SHAPE PARAMETER FOR THE ',
     1       'NON-CENTRAL BETA PDF IS NON-POSITIVE.')
  102 FORMAT('***** ERROR--THE SECOND SHAPE PARAMETER FOR THE ',
     1       'NON-CENTRAL BETA PDF IS NON-POSITIVE.')
  103 FORMAT('***** ERROR--THE NON-CENTRALITY PARAMETER FOR THE ',
     1       'NON-CENTRAL BETA PDF IS NEGATIVE.')
  104 FORMAT('      THE VALUE OF THE PARAMETER IS ',E15.7)
  105 FORMAT('***** ERROR--THE INPUT ARGUMENT FOR THE NON-CENTRAL ',
     1       'BETA PDF IS OUTSIDE THE (0,1) INTERVAL')
C
C  USE NON-CENTRAL F PDF FUNCTION
C
C  NOTE: THIS RELATIONSHIP APPLIES TO CDF FUNCTION, NOT CLEAR
C        THAT IT APPLIES TO PDF (DO NOT GET CONSISTENT ANSWERS).
C
CCCCC DF2=2.0*B
CCCCC DF2=2.0*B
CCCCC XTEMP=X*DF2/(DF1 - X*DF1)
CCCCC CALL NCFPDF(XTEMP,DF1,DF2,ALAMB,PDF)
CCCCC GOTO9999
C
C  FIND NUMERIC DERIVATIVE OF CDF ROUTINE
C
      IFAIL=0
      IORD=1
      EPS=0.001
      ACCUR=0.0
      IFAIL=0
      X0 = X
      XMIN=0.0
      XMAX=1.0
      ALPHA=A
      BETA=B
      ALAMB=LAMBDA
C
      CALL DIFF(IORD,X0,XMIN,XMAX,NCBFU3,EPS,ACCUR,PDF,ERROR,IFAIL)
C
      IF(IFAIL.EQ.1)THEN
  999     FORMAT(1X)
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,301)
  301   FORMAT('***** WARNING IN NUMERICAL DERIVATIVE FOR NCBPDF--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,303)
  303   FORMAT('      THE ESTIMATED ERROR IN THE RESULT EXCEEDS THE')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,305)
  305   FORMAT('      REQUESTED ERROR, BUT THE MOST ACCURATE RESULT')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,307)
  307   FORMAT('      POSSIBLE HAS BEEN RETURNED.')
        CALL DPWRST('XXX','BUG ')
      ELSEIF(IFAIL.EQ.2)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,311)
  311   FORMAT('***** ERROR IN NUMERICAL DERIVATIVE FOR NCBPDF--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,313)
  313   FORMAT('      ERROR IN THE INPUT TO THE DIFF ROUTINE.')
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ELSEIF(IFAIL.EQ.3)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,321)
  321   FORMAT('***** ERROR IN NUMERICAL DERIVATIVE FOR NCBPDF--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,323)
  323   FORMAT('      THE INTERVAL FOR DIFFERENTIATION, (',G15.7,
     1         ',',G15.7,')')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,325)
  325   FORMAT('      IS TOO SMALL.')
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ENDIF
C
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE NCBPPF(P,ALPHA,BETA,LAMBDA,PPF)
C
C     PURPOSE   --PERCENT POINT FUNCTION FOR THE NON-CENTRAL BETA
C                 DISTRIBUTION.  USES A BISECTION METHOD.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--82/7
C     ORIGINAL VERSION--JULY      1981.
C     UPDATED         --FEBRUARY  1982.
C     UPDATED         --MAY       1982.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
CCCCC DOUBLE PRECISION DCDF
CCCCC DOUBLE PRECISION DALPHA
CCCCC DOUBLE PRECISION DBETA
CCCCC DOUBLE PRECISION DX
CCCCC DOUBLE PRECISION DBETAI
      REAL LAMBDA
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DATA EPS /0.0001/
      DATA SIG /1.0E-5/
      DATA ZERO /0./
      DATA MAXIT /100/
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(P.LT.0.0.OR.P.GT.1.0)GOTO50
      IF(ALPHA.LE.0.0)GOTO55
      IF(BETA.LE.0.0)GOTO60
      IF(LAMBDA.LT.0.0)GOTO70
      GOTO90
   50 WRITE(ICOUT,1)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)P
      CALL DPWRST('XXX','BUG ')
      PPF=0.0
      RETURN
   55 WRITE(ICOUT,11)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)ALPHA
      CALL DPWRST('XXX','BUG ')
      PPF=0.0
      RETURN
   60 WRITE(ICOUT,25)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)BETA
      CALL DPWRST('XXX','BUG ')
      PPF=0.0
      GOTO9999
   70 WRITE(ICOUT,35)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)LAMBDA
      CALL DPWRST('XXX','BUG ')
      PPF=0.0
      GOTO9999
C
    1 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ',
     1' NCBPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL')
   11 FORMAT('***** FATAL ERROR--THE 2ND INPUT ARGUMENT TO THE ',
     1' NCBPPF SUBROUTINE IS NON-POSITIVE')
   25 FORMAT('***** FATAL ERROR--THE 3RD INPUT ARGUMENT TO THE ',
     1' NCBPPF SUBROUTINE IS NON-POSITIVE *****')
   35 FORMAT('***** FATAL ERROR--THE FOURTH INPUT ARGUMENT TO THE ',
     1' NCBPPF SUBROUTINE IS NEGATIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
   90 CONTINUE
C
      A = ALPHA
      B = BETA
C
      IERR=0
      IC = 0
      AB = A/B
      XL = 0.0
      XR = 1.0
      FXL = -P
      FXR = 1.0 - P
CCCCC INVALID P EXPLICITLY CHECKED FOR EARLIER.
      IF(FXL*FXR .GT. ZERO)GOTO50
C
C  BISECTION METHOD
C
  105 CONTINUE
      X = (XL+XR)*0.5
      CALL NCBCDF(X,ALPHA,BETA,LAMBDA,CDF)
      P1=CDF
      PPF=X
      FCS = P1 - P
      IF(FCS*FXL.GT.ZERO)GOTO110
      XR = X
      FXR = FCS 
      GOTO115
  110 CONTINUE
      XL = X
      FXL = FCS
  115 CONTINUE
      XRML = XR - XL
      IF(XRML.LE.SIG .AND. ABS(FCS).LE.EPS)GOTO9999
      IC = IC + 1
      IF(IC.LE.MAXIT)GOTO105
      WRITE(ICOUT,130)
      CALL DPWRST('XXX','BUG ')
  130 FORMAT('***** FATAL ERROR--NCBPPF ROUTINE DID NOT CONVERGE. ***')
      GOTO9999
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE NCBRAN(N,ALPHA,BETA,ALAMB,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE NON-CENTRAL BETA DISTRIBUTION WITH SHAPE
C              PARAMETERS ALPHA AND BETA AND NON-CENTRALITY
C              PARAMETER LAMBDA.
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --ALPHA  = THE SINGLE PRECISION VALUE OF THE
C                                FIRST  SHAPE PARAMETER.
C                     --BETA   = THE SINGLE PRECISION VALUE OF THE
C                                SECOND SHAPE PARAMETER.
C                     --ALAMB  = THE SINGLE PRECISION VALUE OF THE
C                                NON-CENTRALITY 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 NON-CENTRAL BETA DISTRIBUTION
C             WITH SHAPE PARAMETER VALUES = ALPHA, BETA, AND ALAMB.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C                 --ALPHA AND BETA  SHOULD BE POSITIVE.
C                 --ALAMB  SHOULD BE NON-NEGATIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NCCRAN, CHSRAN.
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 2", SECOND EDITION,
C                 1994, PAGES 502-503.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004.5
C     ORIGINAL VERSION--MAY       2004.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
      DIMENSION XTEMP(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-----DATA STATEMENTS-------------------------------------------------
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)THEN
        WRITE(ICOUT, 5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
    5 FORMAT('***** ERROR--THE REQUESTED NUMBER OF NON-CENTRAL BETA ',
     1' RANDOM NUMBERS IS NON-POSITIVE.')
      IF(ALPHA.LE.0.0)THEN
        WRITE(ICOUT,16)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ALPHA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
   16 FORMAT('***** ERROR--THE SHAPE PARAMETER ALPHA FOR THE ',
     1'NON-CENTRAL BETA RANDOM NUMBERS IS NON-POSITIVE.')
      IF(BETA.LE.0.0)THEN
        WRITE(ICOUT,26)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)BETA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
   26 FORMAT('***** ERROR--THE SHAPE PARAMETER BETA FOR THE ',
     1'NON-CENTRAL BETA RANDOM NUMBERS IS NON-POSITIVE.')
      IF(ALAMB.LT.0.0)THEN
        WRITE(ICOUT,36)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ALAMB
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
   36 FORMAT('***** ERROR--THE NON-CENTRALITY PARAMETER LAMBDA FOR ',
     1'THE NON-CENTRAL BETA RANDOM NUMBERS IS NEGATIVE.')
C
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8)
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8)
C
C     USE THE CENTRAL AND NON-CENTRAL CHI-SQUARE RANDOM NUMBER
C     ROUTINE TO GENERATE NON-CENTRAL BETA RANDOM NUMBERS.
C
C     NCB = NCCHISQ(NU1,LAMBDA)/(NCCHISQ(NU1,LAMBDA)+CHISQUARE(NU2))
C
      ANU1=ALPHA
      ANU2=BETA
      NTEMP=1
      DO100I=1,N
        CALL NCCRAN(NTEMP,ANU1,ALAMB,ISEED,XTEMP)
        TERM1=XTEMP(1)
        CALL CHSRAN(NTEMP,ANU2,ISEED,XTEMP)
        TERM2=XTEMP(1)
        X(I)=TERM1/(TERM1+TERM2)
  100 CONTINUE
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE NCVSRT( N, LOWER, UPPER, CORREL, INFIN, Y, INFIS, 
     &                   A, B, INFI, COV, D, E )
*
*     Subroutine to sort integration limits.
*
      INTEGER N, INFI(*), INFIN(*), INFIS
      DOUBLE PRECISION 
     &     A(*), B(*), COV(*), LOWER(*), UPPER(*), CORREL(*), Y(*), D, E
      INTEGER I, J, K, IJ, II, JMIN
      DOUBLE PRECISION SUMSQ, ZERO
      PARAMETER ( ZERO = 0 )
      DOUBLE PRECISION AJ, BJ, SUM, SQTWPI
      DOUBLE PRECISION CVDIAG, AMIN, BMIN, DMIN, EMIN, YL, YU
      PARAMETER ( SQTWPI = 2.50662 82746 31000 50240 )
      IJ = 0
      II = 0
      INFIS = 0
      DO 100 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 200 J = 1,I-1
            IJ = IJ + 1
            II = II + 1
            COV(IJ) = CORREL(II)
  200    CONTINUE
         IJ = IJ + 1
         COV(IJ) = 1
  100 CONTINUE
*
*     First move any doubly infinite limits to innermost positions
*
      IF ( INFIS .LT. N ) THEN
         DO 300 I = N,N-INFIS+1,-1
            IF ( INFI(I) .GE. 0 ) THEN 
               DO 400 J = 1,I-1
                  IF ( INFI(J) .LT. 0 ) THEN
                     CALL RCSWAP(J, I, A, B, INFI, N, COV)
                     GO TO 300
                  ENDIF
 400           CONTINUE
            ENDIF
 300     CONTINUE
*
*     Sort remaining limits and determine Cholesky decomposition
*
         II = 0
         DO 500 I = 1,N-INFIS
*
*     Determine the integration limits for variable with minimum
*      expected probability and interchange that variable with Ith.
*
            EMIN = 1
            DMIN = 0
            JMIN = I
            CVDIAG = 0
            IJ = II
            DO 600 J = I, N-INFIS
               SUM = 0
               SUMSQ = 0
               DO 700 K = 1, I-1
                  SUM = SUM + COV(IJ+K)*Y(K)
                  SUMSQ = SUMSQ + COV(IJ+K)**2
  700          CONTINUE
               IJ = IJ + J 
               SUMSQ = SQRT( MAX( COV(IJ)-SUMSQ, ZERO ) )
               IF ( SUMSQ .GT. 0 ) THEN
                  IF ( INFI(J) .NE. 0 ) AJ = ( A(J) - SUM )/SUMSQ
                  IF ( INFI(J) .NE. 1 ) BJ = ( B(J) - SUM )/SUMSQ
                  CALL LIMITS( AJ, BJ, INFI(J), D, E )
                  IF ( EMIN - DMIN .GE. E - D ) THEN
                     JMIN = J
                     IF ( INFI(J) .NE. 0 ) AMIN = AJ 
                     IF ( INFI(J) .NE. 1 ) BMIN = BJ
                     DMIN = D
                     EMIN = E
                     CVDIAG = SUMSQ
                  ENDIF
               ENDIF
  600       CONTINUE
            IF ( JMIN .NE. I) CALL RCSWAP(I, JMIN, A, B, INFI, N, COV)
*
*     Compute Ith column of Cholesky factor.
*
            IJ = II + I
            COV(IJ) = CVDIAG
            DO 800 J = I+1, N-INFIS               
               IF ( CVDIAG .GT. 0 ) THEN
                  SUM = COV(IJ+I)
                  DO 900 K = 1, I-1
                     SUM = SUM - COV(II+K)*COV(IJ+K)
  900             CONTINUE
                  COV(IJ+I) = SUM/CVDIAG
               ELSE
                  COV(IJ+I) = 0
               ENDIF
               IJ = IJ + J
  800       CONTINUE
*
*     Compute expected value for Ith integration variable and
*     scale Ith covariance matrix row and limits.
*
            IF ( CVDIAG .GT. 0 ) THEN
               IF ( EMIN .GT. DMIN + 1D-8 ) THEN
                  YL = 0
                  YU = 0
                  IF ( INFI(I) .NE. 0 ) YL = -EXP( -AMIN**2/2 )/SQTWPI
                  IF ( INFI(I) .NE. 1 ) YU = -EXP( -BMIN**2/2 )/SQTWPI
                  Y(I) = ( YU - YL )/( EMIN - DMIN )
               ELSE
                  IF ( INFI(I) .EQ. 0 ) Y(I) = BMIN
                  IF ( INFI(I) .EQ. 1 ) Y(I) = AMIN
                  IF ( INFI(I) .EQ. 2 ) Y(I) = ( AMIN + BMIN )/2
               END IF
               DO 910 J = 1,I
                  II = II + 1
                  COV(II) = COV(II)/CVDIAG
  910          CONTINUE
               IF ( INFI(I) .NE. 0 ) A(I) = A(I)/CVDIAG
               IF ( INFI(I) .NE. 1 ) B(I) = B(I)/CVDIAG
            ELSE
               Y(I) = 0
               II = II + I
            ENDIF
  500    CONTINUE
         CALL LIMITS( A(1), B(1), INFI(1), D, E)
      ENDIF
C
      RETURN
      END
      SUBROUTINE NCCCDF(X, DF, FL, CDF)
C UKC NETLIB DISTRIBUTION COPYRIGHT 1990 RSS
C
C
C<<<<<  Acquired in machine-readable form from 'Applied Statistics'
C<<<<<  algorithms editor, January 1983.
C
C
C        ALGORITHM AS 170  APPL. STATIST. (1981) VOL.30, NO.3
C
C        The non-central chi-squared distribution.
C
C     Auxiliary routines required: GAMMDS = AS147, ALOGAM = CACM 291.
C     See AS245 for an alternative to ALOGAM.
C
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DGAMIP
      DOUBLE PRECISION DARG1
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C        TEST FOR ADMISSIBILITY OF ARGUMENTS
C
      IF (DF.LE.0.0) THEN
        WRITE(ICOUT,101)
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
      IF(X.LT.0.0)THEN
        WRITE(ICOUT,301)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,302)X
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
      IF (FL.LT.0.0)THEN
        WRITE(ICOUT,401)
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
  101 FORMAT('***** ERROR--THE DEGREES OF FREEDOM PARAMETER FOR NCCCDF '
     1      ,'IS NON-POSITIVE. ****')
  301 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO NCCCDF IS ')
  302 FORMAT('      NON-POSITIVE.  IT HAS THE VALUE ',E15.7)
  401 FORMAT('***** ERROR--THE NON-CENTRALITY PARAMETER TO NCCCDF ',
     1       'IS NEGATIVE. ****')
C
C
      CDF = 0.0
      IF(X.EQ.0.0)GOTO9999
      DF2 = 0.5*DF
      X2 = 0.5*X
CCCCC FXP = GAMMDS(X2,DF2,IFAULT)
      DARG1=DGAMIP(DBLE(DF2),DBLE(X2))
      FXP=REAL(DARG1)
      CALL NCCCHI(X2,DF2,FL,FXP,CDF)
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE NCCCHI(X, DF, FL, FXC, CHI)
C
C        ALGORITHM AS 170.2  APPL. STATIST. (1981) VOL.30, NO.3
C
C        (ROUTINE USED BY NCCCDF AND NCCNCP)
      PARAMETER (ACC2 = 1.0E-8)
      DOUBLE PRECISION DGAMIP
      DOUBLE PRECISION DARG1
C
      CHI = FXC
      DF1 = DF
      FL2 = 0.5*FL
      C = 1.0
      T = 0.0
    1 CONTINUE
      T = T+1.0
      C = C*FL2/T
      DF1 = DF1+1.0
CCCCC TERM = C*GAMMDS(X, DF1, IFAULT)
      DARG1=DGAMIP(DBLE(DF1),DBLE(X))
      TERM = C*REAL(DARG1)
      CHI = CHI+TERM
      IF (TERM.GE.ACC2) GO TO 1
      CHI = CHI*EXP(-FL2)
C
      RETURN
      END
      SUBROUTINE NCCPDF(X, V, FL, PDF)
C UKC NETLIB DISTRIBUTION COPYRIGHT 1990 RSS
C
C
C        The non-central chi-squared probability density function.
C        USE THE FOLLOWING FORMULA ON PAGE 436 OF 2ND ED OF
C        VOL. 2 OF JOHNSON AND KOTZ.
C        F(X)=EXP(-(L+X)/2)*(1/2)*(X/V)**((V-2)/4)*I((V-2)/2)(SQRT(L*X))
C        WHERE I IS THE MODIFIED BESSEL FUNCTION.
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOMC.INC'
C
      DOUBLE PRECISION DX, DL, DV, DPDF
      DOUBLE PRECISION DPI
      DOUBLE PRECISION DTERM1, DTERM2, DTERM3, DTERM4, DTERM5
      DOUBLE PRECISION DLNGAM
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DATA DPI / 3.1415926535 8979323846 2643383279 503 D0 /
C
C        TEST FOR ADMISSIBILITY OF ARGUMENTS
C
      IF(X.LE.0.0)THEN
        WRITE(ICOUT,301)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
      IF (V.LE.0.0) THEN
        WRITE(ICOUT,101)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)V
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
      IF (FL.LT.0.0)THEN
        WRITE(ICOUT,401)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)FL
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
  101 FORMAT('***** ERROR IN NCCPDF--THE SECOND INPUT ARGUMENT ',
     1'IS NON-POSITIVE')
  301 FORMAT('***** ERROR IN NCCPDF--THE FIRST INPUT ARGUMENT ',
     1'IS NON-POSITIVE')
  401 FORMAT('***** ERROR IN NCCPDF--THE THIRD INPUT ARGUMENT ',
     1'IS NON-POSITIVE')
   46 FORMAT('      THE ARGUMENT HAS THE VALUE ',E15.6)
C
C
      PDF = 0.0
      DX=DBLE(X)
      DL=DBLE(FL)
      DV=DBLE(V)
C
      IF(FL.EQ.0.0)THEN
        DTERM1=((DV-2.0D0)/2.0D0)*DLOG(DX)
        DTERM2=-DX/2.0D0
        DTERM3=(DV/2.0D0)*DLOG(2.0D0)
        DTERM4=DLNGAM(DV/2.0D0)
        DPDF=DEXP(DTERM1+DTERM2-DTERM3-DTERM4)
        PDF=REAL(DPDF)
        GOTO9999
      ENDIF
C
      IF(DV.LT.2.0D0)GOTO1000
C
      DTERM1=DSQRT(DL*DX)
      IF(DTERM1.LE.DLOG(D1MACH(2)))THEN
        DTERM2=-(DL+DX)/2.0D0+DLOG(0.5D0)+
     1         ((DV-2.0D0)/4.0D0)*DLOG(DX/DL)
        IARG1=1
        ISCALE=1
        DTERM5=(DV-2.0D0)/2.0D0
        CALL DBESI(DTERM1,DTERM5,ISCALE,IARG1,DTERM3,NZERO)
        DTERM3=DLOG(DTERM3)
        DTERM4=DTERM2+DTERM3
        IF(DTERM4.LE.-80.D0)THEN
          PDF=0.0
        ELSEIF(DTERM4.GE.80.D0)THEN
          WRITE(ICOUT,601)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,47)X
          CALL DPWRST('XXX','BUG ')
          PDF=ALOG(R1MACH(2))
        ELSE
          DPDF=DEXP(DTERM4)
          PDF=SNGL(DPDF)
        ENDIF
      ELSE
        WRITE(ICOUT,501)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)X
        CALL DPWRST('XXX','BUG ')
      ENDIF
      GOTO9999
  601 FORMAT('***** ERROR IN NCCPDF--OVERFLOW IN CALCULATION OF PDF' ,
     1' VALUE, PDF SET TO LOG OF LARGEST NUMBER.')
  501 FORMAT('***** ERROR IN NCCPDF--ARGUMENT TO LARGE FOR DBESI ',
     1'ROUTINE, PDF SET TO 0')
   47 FORMAT('      THE ARGUMENT HAS THE VALUE ',E15.6)
C
C  CASE FOR V < 2 REQUIRE NEGATIVE ORDER OF MODIFIED BESSEL FUNCTION.
C  USE I(-v) = I(v) + (2/PI)*SIN(V*PI)*K(v)
C
 1000 CONTINUE
      DTERM1=DSQRT(DL*DX)
      IF(DTERM1.LE.DLOG(D1MACH(2)))THEN
        DTERM2=-(DL+DX)/2.0D0+DLOG(0.5D0)+
     1         ((DV-2.0D0)/4.0D0)*DLOG(DX/DL)
        IARG1=1
        ISCALE=1
        DTERM5=(DV-2.0D0)/2.0D0
        CALL DBESI(DTERM1,DABS(DTERM5),ISCALE,IARG1,DTERM3,NZERO)
        CALL BESK(SNGL(DTERM1),SNGL(DABS(DTERM5)),ISCALE,IARG1,TERM3,
     1            NZERO)
        DTERM3=DTERM3+(2.0D0/DPI)*DSIN(DABS(DTERM5)*DPI)*DBLE(TERM3)
        DTERM3=DLOG(DTERM3)
        DTERM4=DTERM2+DTERM3
        IF(DTERM4.LE.-80.D0)THEN
          PDF=0.0
        ELSEIF(DTERM4.GE.80.D0)THEN
          WRITE(ICOUT,601)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,47)X
          CALL DPWRST('XXX','BUG ')
          PDF=ALOG(R1MACH(2))
        ELSE
          DPDF=DEXP(DTERM4)
          PDF=SNGL(DPDF)
        ENDIF
      ELSE
        WRITE(ICOUT,501)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)X
        CALL DPWRST('XXX','BUG ')
      ENDIF
      GOTO9999
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE NCCNCP(X, DF, FX, FL)
C
C        ALGORITHM AS 170.1  APPL.STATIST. (1981) VOL.30, NO.3
C
C        DEFINE ACCURACY AND INITIALIZE
C
C        N SHOULD BE SPECIFIED SUCH THAT ACC IS GREATER THAN
C        OR EQUAL TO (AU-AL)/2**N
C
      PARAMETER (ACC = 1.0E-6, N = 30)
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DGAMIP
      DOUBLE PRECISION DARG1
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C
      AL = 0.0
      AINC = 80.0
      AU = 80.0
C
C        TEST FOR ADMISSIBILITY OF ARGUMENTS
C
      IF (DF.LE.0.0) THEN
        WRITE(ICOUT,101)
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
      IF(X.LT.0.0)THEN
        WRITE(ICOUT,301)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,302)X
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
      IF (FX.LE.0.0)THEN
        WRITE(ICOUT,401)
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
  101 FORMAT('***** FATAL DIAGNOSTIC--THE DEGREES OF FREEDOM PARAMETER',
     1       ' IS NON-POSITIVE. ****')
  301 FORMAT('***** FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT IS ')
  302 FORMAT('      NON-POSITIVE.  IT HAS THE VALUE ',E15.7)
  401 FORMAT('***** FATAL DIAGNOSTIC--THE CDF PARAMETER IS NEGATIVE.')
C
      DF2 = 0.5*DF
      X2 = 0.5*X
CCCCC FX1 = GAMMDS(X2,DF2,IFAULT)
      DARG1=DGAMIP(DBLE(DF2),DBLE(X2))
      FX1 = REAL(DARG1)
    1 CONTINUE
CCCC1 APROX = CHI(X2,DF2,AU,FX1)
      CALL NCCCHI (X2,DF2,AU,FX1,APROX)
      IF (FX.GT.APROX) GOTO 2
      IF (FX.LT.APROX) AL = AU
      AU = AU+AINC
      GO TO 1
C
    2 CONTINUE
      DO 3 J = 1,N
        FL = 0.5*(AL+AU)
CCCCC   APROX = CHI(X2, DF2, FL, FX1)
        CALL NCCCHI (X2,DF2,FL,FX1,APROX)
        IF (ABS(FX-APROX).LT.ACC) GO TO 9999
        IF (FX.LT.APROX) AL = FL
        IF (FX.GE.APROX) AU = FL
    3 CONTINUE
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE NCCPPF(P,NU,DELTA,PPF)
C
C     PURPOSE   --PERCENT POINT FUNCTION FOR THE NON-CENTRAL CHI-SQUARE
C                 DISTRIBUTION.  USES A BISECTION METHOD.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--94/9
C     ORIGINAL VERSION--SEPTEMBER 1994.
C     UPDATE          --MAY       2004. SOME UPDATES TO SPEED
C                                 CONVERGENCE
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      REAL NU
      DOUBLE PRECISION DGAMIP
      DOUBLE PRECISION DARG1
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
CCCCC DATA EPS /0.0001/
CCCCC DATA SIG /1.0E-5/
      DATA ZERO /0./
      DATA MAXIT /500/
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(P.LT.0.0.OR.P.GE.1.0)GOTO50
      IF(NU.LE.0.0)GOTO55
      IF(DELTA.LT.0.0)GOTO70
      GOTO90
   50 WRITE(ICOUT,1)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)P
      CALL DPWRST('XXX','BUG ')
      PPF=0.0
      RETURN
   55 WRITE(ICOUT,11)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)NU
      CALL DPWRST('XXX','BUG ')
      PPF=0.0
      RETURN
   70 WRITE(ICOUT,35)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)DELTA
      CALL DPWRST('XXX','BUG ')
      PPF=0.0
      GOTO9999
C
    1 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO THE ',
     1' NCCPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL.')
   11 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO THE ',
     1' NCCPPF SUBROUTINE IS NON-POSITIVE.')
   35 FORMAT('***** FATAL ERROR--THE THIRD INPUT ARGUMENT TO THE ',
     1' NCCPPF SUBROUTINE IS NEGATIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I15,' *****')
C
   90 CONTINUE
C
C  SPECIAL CASE.  FOR INTEGER NU AND DELTA = 0, USE CENTRAL CHI-SQUARE
C  ROUTINE.
C
      IF(DELTA.EQ.0.0)THEN
        NUINT=INT(NU+0.1)
        ANUINT=REAL(NUINT)
        IF(ABS(NU-ANUINT).LE.0.00001 .AND. NUINT.GE.1)THEN
          CALL CHSPPF(P,NUINT,PPF)
          GOTO9999
        ENDIF
      ENDIF
C
C  FIND BRACKETING INTERVAL.  USE CORRESPONDING CENTRAL CHI-SQUARE
C  AS INITIAL GUESS, INCREMENTS OF 1 STANDARD DEVIATION AROUND IT
C  (SD = SQRT(2*(NU+2*DELTA))
C  AFTER SUCCESSFULLY FIND BRACKETING INTERVAL, THEN SWITCH TO 
C  MORE EFFICIENT BISECTION METHOD.
C
C  5/2004. BETTER BRACKETING INTERVAL.  BASE ON MEAN, SD, AND VALUE OF P.
C          ALSO, FOR LOW VALUES OF NU AND MORE EXTREME VALUES OF P,
C          LOOSEN THE CONVERGENCE CRITIERION.  LEFT INVERVAL IS 0 (OR
C          0 + EPS)
C
      EPS=0.0001
      SIG=1.0E-5
CCCCC IF(NU.GE.20.0)THEN
CCCCC   EPS=0.0001
CCCCC   SIG=1.0E-5
CCCCC   IF(P.GT.0.95 .OR. P.LT.0.05)THEN
CCCCC     EPS=0.0001
CCCCC     SIG=1.0E-4
CCCCC   ENDIF
CCCCC ELSE
CCCCC   IF(P.GT.0.99 .OR. P.LT.0.01)THEN
CCCCC     EPS=0.0001
CCCCC     SIG=1.0E-5
CCCCC   ENDIF
CCCCC ENDIF
C
CCCCC NUINT=NU+0.5
CCCCC CALL CHSPPF(P,NUINT,XL)
      AMEAN=NU+DELTA
      SD=SQRT(2.0*(NU+2.0*DELTA))
      XINC=SD
C
      XL=0.0
      IF(P.LE.0.25)THEN
        XL=0.0
      ELSEIF(P.GT.0.25 .AND. P.LE.0.75)THEN
        XL=AMEAN
      ELSEIF(P.GT.0.75 .AND. P.LE.0.95)THEN
        XL=AMEAN+SD
      ELSE
        XL=AMEAN+2.0*SD
      ENDIF
C
      ICOUNT=0
      MAXCNT=100
C
   91 CONTINUE
      XR=XL+XINC
      IF(XL.LE.0.0)XL=0.0
      IF(XR.LE.0.0)XR=XL+XINC
C
      DF2 = 0.5*NU
      FL=DELTA
      IF(XL.LE.0.0000001)THEN
        CDFL=0.0
      ELSE
        X2 = 0.5*XL
        DARG1=DGAMIP(DBLE(DF2),DBLE(X2))
        FXP=REAL(DARG1)
        CALL NCCCHI(X2,DF2,FL,FXP,CDFL)
      ENDIF
      X2 = 0.5*XR
      DARG1=DGAMIP(DBLE(DF2),DBLE(X2))
      FXP=REAL(DARG1)
      CALL NCCCHI(X2,DF2,FL,FXP,CDFR)
C
CCCCC CALL NCCCDF(XL,NU,DELTA,CDFL)
CCCCC CALL NCCCDF(XR,NU,DELTA,CDFR)
      IF(CDFL.LT.P .AND. CDFR.LT.P)THEN
        XL=XR
      ELSEIF(CDFL.GT.P .AND. CDFR.GT.P)THEN
        XL=XL-XINC
      ELSE
        GOTO99
      ENDIF
      ICOUNT=ICOUNT+1
      IF(ICOUNT.GT.MAXCNT)THEN
        WRITE(ICOUT,96)
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
        GOTO9999
      ENDIF
   96 FORMAT('***** FATAL ERROR--NCCPPF UNABLE TO FIND BRACKETING ',
     *       'INTERVAL. *****')
      GOTO91
C
C  BISECTION METHOD
C
   99 CONTINUE
      IC = 0
      FXL = -P
      FXR = 1.0 - P
  105 CONTINUE
      X = (XL+XR)*0.5
C
      IF(X.LE.0.0000001)THEN
        CDF=0.0
      ELSE
        X2 = 0.5*X
        DARG1=DGAMIP(DBLE(DF2),DBLE(X2))
        FXP=REAL(DARG1)
        CALL NCCCHI(X2,DF2,FL,FXP,CDF)
      ENDIF
CCCCC CALL NCCCDF(X,NU,DELTA,CDF)
      P1=CDF
      PPF=X
      FCS = P1 - P
      IF(FCS*FXL.GT.ZERO)GOTO110
      XR = X
      FXR = FCS 
      GOTO115
  110 CONTINUE
      XL = X
      FXL = FCS
  115 CONTINUE
      XRML = XR - XL
      IF(XRML.LE.SIG .AND. ABS(FCS).LE.EPS)GOTO9999
      IC = IC + 1
      IF(IC.LE.MAXIT)GOTO105
      WRITE(ICOUT,130)
      CALL DPWRST('XXX','BUG ')
  130 FORMAT('***** ERROR--NCCPPF ROUTINE DID NOT CONVERGE. ***')
      GOTO9999
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE NCCRAN(N,ANU,ALAMB,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE NON-CENTRAL CHI-SQUARED DISTRIBUTION
C              WITH DEGREES OF FREEDOM PARAMETER NU AND
C              NON-CENTRALITY PARAMETER LAMBDA.
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --ANU    = THE DEGREES OF FREEDOM PARAMETER
C                     --ALAMB  = THE NON-CENTRALITY 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 NON-CENTRAL CHI-SQUARED DISTRIBUTION
C             WITH SHAPE PARAMETERS NU AND LANBDA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C                 --ANU SHOULD BE POSITIVE.
C                 --ALAMB SHOULD BE NON-NEGATIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NORRAN, GAMRAN.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--SQRT.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2899
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004/5
C     ORIGINAL VERSION--MAY       2004.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
      DIMENSION XTEMP(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(N.LT.1)THEN
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
    5 FORMAT('***** ERROR--THE REQUESTED NUMBER OF NON-CENTRAL ',
     1       'CHI-SQUARE RANDOM NUMBERS IS NON-POSITIVE.')
      IF(ANU.LE.0.0)THEN
        WRITE(ICOUT,15)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,48)ANU
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
   15 FORMAT('***** ERROR--THE DEGREES OF FREEDOM PARAMETER FOR ',
     1'NON-CENTRAL CHI-SQUARE RANDOM NUMBERS IS NON-POSITIVE.')
      IF(ALAMB.LT.0.0)THEN
        WRITE(ICOUT,25)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,48)ALAMB
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
   25 FORMAT('***** ERROR--THE NON-CENTRALITY PARAMETER FOR ',
     1'NON-CENTRAL CHI-SQUARE RANDOM NUMBERS IS NON-POSITIVE.')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8)
   48 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
C
      IF(ALAMB.EQ.0.0)THEN
        CALL CHSRAN(N,ANU,ISEED,X)
      ELSE
        IF(ANU.LE.1.0)THEN
          CALL UNIRAN(N,ISEED,X)
          DO1367II=1,N
            ATEMP=X(II)
            CALL NCCPPF(ATEMP,ANU,ALAMB,PPF)
            X(II)=PPF
 1367     CONTINUE
        ELSE
CCCCC     NOTE: 5/2004.  USING PERCENT POINT METHOD SEEMS TO
CCCCC           GENERATE BETTER RANDOM NUMBERS THAN THE SUM OF
CCCCC           NORMALS METHOD.  IT IS SLOWER, BUT IT SEEMS TO
CCCCC           BE MORE ACCURATE.  ALSO, IT CAN HANDLE NON-INTEGER
CCCCC           VALUES OF NU.
C
          CALL UNIRAN(N,ISEED,X)
          DO1369II=1,N
            ATEMP=X(II)
            CALL NCCPPF(ATEMP,ANU,ALAMB,PPF)
            X(II)=PPF
 1369     CONTINUE
CCCCC     NUINT=INT(NU+0.5)
CCCCC     IF(NUINT.LT.1)NUINT=1
CCCCC     NTEMP=1
CCCCC     DO1365II=1,N
CCCCC       ASUM=0.0
CCCCC       DO1366J=1,NUINT
CCCCC         CALL NORRAN(NTEMP,ISEED,XTEMP)
CCCCC         ASUM=ASUM + (XTEMP(1) + (ALAMB/REAL(NUINT)))**2
C1365       CONTINUE
CCCCC       X(II)=ASUM
C1365     CONTINUE
        ENDIF
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE NCFCDF(X,NU1,NU2,LAMBDA,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE NON-CENTRAL F DISTRIBUTION
C              WITH INTEGER DEGREES OF FREEDOM
C              PARAMETERS = NU1 AND NU2.
C              THIS DISTRIBUTION IS DEFINED FOR ALL NON-NEGATIVE X.
C              THE PROBABILITY DENSITY FUNCTION IS GIVEN
C              IN THE REFERENCES BELOW.
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                     --NU1    = THE INTEGER DEGREES OF FREEDOM
C                                FOR THE NUMERATOR OF THE F RATIO.
C                                NU1 SHOULD BE POSITIVE.
C                     --NU2    = THE INTEGER DEGREES OF FREEDOM
C                                FOR THE DENOMINATOR OF THE F RATIO.
C                                NU2 SHOULD BE POSITIVE.
C                     --LAMBDA   NON-NEGATIVE NON-CENTRALITY PARAMETER.
C     OUTPUT ARGUMENTS--CDF    = THE SINGLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE CDF FOR THE NON-CENTRAL F DISTRIBUTION
C             WITH DEGREES OF FREEDOM PARAMETERS = NU1 AND NU2.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE NON-NEGATIVE.
C                 --NU1 SHOULD BE A POSITIVE INTEGER VARIABLE.
C                 --NU2 SHOULD BE A POSITIVE INTEGER VARIABLE.
C                 --LAMBDA SHOULD BE GREATER THAN OR EQUAL TO 0.
C     OTHER           SUBROUTINES NEEDED--NCBCDF,CHSCDF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--DSQRT, DATAN.
C     LANGUAGE--ANSI FORTRAN (1977)
C     ALGORITHM --USES THE NON-CENTRAL BETA DISTRIBUTION.
C     REFERENCES--"COMPUTING NON-CENTRAL BETA PROBABILITIES"
C                 RUSSELL LENTH, ALGORITHM AS 226 FROM APPLIED
C                 STATISTICS JOURNAL.  
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--94/9
C     ORIGINAL VERSION--SEPTEMBER 1994.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      REAL NU1
      REAL NU2
      REAL LAMBDA
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
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(NU1.LE.0.0)GOTO50
      IF(NU2.LE.0.0)GOTO55
      IF(X.LT.0.0)GOTO60
      IF(LAMBDA.LT.0.0)GOTO70
      GOTO90
   50 WRITE(ICOUT,15)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,47)NU1
      CALL DPWRST('XXX','BUG ')
      CDF=0.0
      RETURN
   55 WRITE(ICOUT,23)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,47)NU2
      CALL DPWRST('XXX','BUG ')
      CDF=0.0
      RETURN
   60 WRITE(ICOUT,4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)X
      CALL DPWRST('XXX','BUG ')
      CDF=0.0
      RETURN
   70 WRITE(ICOUT,24)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)LAMBDA
      CALL DPWRST('XXX','BUG ')
      CDF=0.0
      RETURN
    4 FORMAT('***** NON-FATAL DIAGNOSTIC--THE 1ST INPUT ARGUMENT ',
     1'TO THE NCFCDF   SUBROUTINE IS NEGATIVE *****')
   15 FORMAT('***** FATAL ERROR--THE 2ND INPUT ARGUMENT TO THE ',
     1'NCFCDF   SUBROUTINE IS NON-POSITIVE *****')
   23 FORMAT('***** FATAL ERROR--THE 3RD INPUT ARGUMENT TO THE ',
     1'NCFCDF   SUBROUTINE IS NON-POSITIVE *****')
   24 FORMAT('***** FATAL ERROR--THE FOURTH INPUT ARGUMENT TO THE ',
     1'NCFCDF   SUBROUTINE IS NEGATIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
C
   90 CONTINUE
C
      TERM1=NU1*0.5
      TERM2=NU2*0.5
      TERM3=NU1*X/(NU1*X+NU2)
      CALL NCBCDF(TERM3,TERM1,TERM2,LAMBDA,CDF)
C
 9999 CONTINUE
      RETURN
      END
      REAL FUNCTION NCFFU3(X)
C
C     PURPOSE--NCFPDF CALLS DIFF TO FIND A NUMERICAL DERIVATIVE
C              FOR THE NON-CENTRAL CUMULATIVE DISTRIBUTION FUNCTION.
C              NCFFU3 IS A FUNCTION THAT CALL NCFCDF.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE DERIVATIVE
C                                IS TO BE EVALUATED.
C     OUTPUT--THE SINGLE PRECISION FUNCTION VALUE NCFFU3.
C     PRINTING--NONE.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NCBCDF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE 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.5
C     ORIGINAL VERSION--MAY       2004.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      REAL ANU1
      REAL ANU2
      REAL ALAMB
      COMMON/NCFCOM/ANU1,ANU2,ALAMB
C
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
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  NOTE: NCFCDF CALLS NCBCDF.  PERFORM THE NEEDED PARAMETER TRANSLATION
C        AND CALL NCBCDF (I.E., SAVE A SUBROUTINE CALL).
C
CCCCC CALL NCFCDF(X,ANU1,ANU2,,ALAMB,CDF)
      TERM1=ANU1*0.5
      TERM2=ANU2*0.5
      TERM3=ANU1*X/(ANU1*X+ANU2)
      CALL NCBCDF(TERM3,TERM1,TERM2,ALAMB,CDF)
      NCFFU3=CDF
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE NCFPDF(X,NU1,NU2,LAMBDA,PDF)
C
C     PURPOSE--PROBABILITY DENSITY FUNCTION FOR THE NON-CENTRAL
C              T DISTRIBUTION.  THE PROBABILITY DENSITY FUNCTION
C              IS COMPUTED BY COMPUTING THE NUMERICAL DERIVATIVE OF
C              THE CUMULATIVE DISTRIBUTION FUNCTION.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                     --ANU    = THE DEGREES OF FREEDOM SHAPE PARAMETER
C                     --DELTA  = THE FIRST NON-CENTRALITY SHAPE PARAMETER
C                     --LAMBDA = THE SECOND NON-CENTRALITY PARAMETER
C     OUTPUT ARGUMENTS--PDF    = THE SINGLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY FUNCTION VALUE PDF.
C     PRINTING--NONE.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--DIFF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004/5
C     ORIGINAL VERSION--MAY       2004.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      REAL  X
      REAL  NU1
      REAL  NU2
      REAL  LAMBDA
      REAL  PDF
C
      REAL NCFFU3
      EXTERNAL NCFFU3
      REAL ANU1
      REAL ANU2
      REAL ALAMB
      COMMON/NCFCOM/ANU1,ANU2,ALAMB
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      PDF=0.0
C
      IF(NU1.LE.0.0)THEN
        WRITE(ICOUT,101)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,102)NU1
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
  101 FORMAT('**** ERROR--THE FIRST DEGREES OF FREEDOM PARAMETER')
  102 FORMAT('     FOR NCFPDF IS NON-POSITIVE.  IT HAS THE VALUE ',
     1       E15.7)
C
      IF(NU2.LE.0.0)THEN
        WRITE(ICOUT,103)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,104)NU2
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
  103 FORMAT('**** ERROR--THE SECOND DEGREES OF FREEDOM PARAMETER')
  104 FORMAT('     FOR NCFPDF IS NON-POSITIVE.  IT HAS THE VALUE ',
     1       E15.7)
C
      IF(ALAMB.LT.0.0)THEN
        WRITE(ICOUT,303)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,304)ALAMB
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
  303 FORMAT('**** ERROR--THE NON-CENTRALITY PARAMETER IS NEGATIVE.')
  304 FORMAT('     IT HAS THE VALUE ',E15.7)
C
C  FIND NUMERIC DERIVATIVE OF CDF ROUTINE
C
      IORD=1
      EPS=0.0001
      ACCUR=0.0
      IFAIL=0
      X0 = X
      XMIN=MAX(X0 - 50.0,0.0)
      XMAX=X0 + 50.0
      ANU1=NU1
      ANU2=NU2
      ALAMB=LAMBDA
C
      CALL DIFF(IORD,X0,XMIN,XMAX,NCFFU3,EPS,ACCUR,PDF,ERROR,IFAIL)
C
      IF(IFAIL.EQ.1)THEN
  999     FORMAT(1X)
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,401)
  401   FORMAT('***** WARNING IN NUMERICAL DERIVATIVE FOR NCFPDF--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,403)
  403   FORMAT('      THE ESTIMATED ERROR IN THE RESULT EXCEEDS THE')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,405)
  405   FORMAT('      REQUESTED ERROR, BUT THE MOST ACCURATE RESULT')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,407)
  407   FORMAT('      POSSIBLE HAS BEEN RETURNED.')
        CALL DPWRST('XXX','BUG ')
      ELSEIF(IFAIL.EQ.2)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,411)
  411   FORMAT('***** ERROR IN NUMERICAL DERIVATIVE FOR NCFPDF--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,413)
  413   FORMAT('      ERROR IN THE INPUT TO THE DIFF ROUTINE.')
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ELSEIF(IFAIL.EQ.3)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,421)
  421   FORMAT('***** ERROR IN NUMERICAL DERIVATIVE FOR NCFPDF--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,423)
  423   FORMAT('      THE INTERVAL FOR DIFFERENTIATION, (',G15.7,
     1         ',',G15.7,')')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,425)
  425   FORMAT('      IS TOO SMALL.')
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ENDIF
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE NCFPPF(P,NU1,NU2,DELTA,PPF)
C
C     PURPOSE   --PERCENT POINT FUNCTION FOR THE NON-CENTRAL F
C                 DISTRIBUTION.  USES A BISECTION METHOD.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--94/9
C     ORIGINAL VERSION--SEPTEMBER 1994.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      REAL NU1
      REAL NU2
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DATA EPS /0.0001/
      DATA SIG /1.0E-5/
      DATA ZERO /0./
      DATA MAXIT /500/
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(P.LE.0.0.OR.P.GE.1.0)GOTO50
      IF(NU1.LT.0.0)GOTO55
      IF(NU2.LT.0.0)GOTO65
      IF(DELTA.LT.0.0)GOTO70
      GOTO90
   50 WRITE(ICOUT,1)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)P
      CALL DPWRST('XXX','BUG ')
      PPF=0.0
      RETURN
   55 WRITE(ICOUT,11)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)NU1
      CALL DPWRST('XXX','BUG ')
      PPF=0.0
      RETURN
   65 WRITE(ICOUT,12)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)NU2
      CALL DPWRST('XXX','BUG ')
      PPF=0.0
      RETURN
   70 WRITE(ICOUT,35)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)DELTA
      CALL DPWRST('XXX','BUG ')
      PPF=0.0
      GOTO9999
C
    1 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ',
     1' NCFPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL')
   11 FORMAT('***** FATAL ERROR--THE 2ND INPUT ARGUMENT TO THE ',
     1' NCFPPF SUBROUTINE IS NON-POSITIVE.')
   12 FORMAT('***** FATAL ERROR--THE THIRD INPUT ARGUMENT TO THE ',
     1' NCFPPF SUBROUTINE IS NON-POSITIVE.')
   35 FORMAT('***** FATAL ERROR--THE FOURTH INPUT ARGUMENT TO THE ',
     1' NCFPPF SUBROUTINE IS NEGATIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I15,' *****')
C
   90 CONTINUE
C
C  FIND BRACKETING INTERVAL.  USE CORRESPONDING CENTRAL F
C  AS INITIAL GUESS, INCREMENTS OF 100 AROUND IT.
C  AFTER SUCCESSFULLY FIND BRACKETING INTERVAL, THEN SWITCH TO 
C  MORE EFFICIENT BISECTION METHOD.
C
      XINC=50.0
      NU1INT=NU1+0.5
      NU2INT=NU2+0.5
      CALL FPPF(P,NU1INT,NU2INT,XL)
      ICOUNT=0
      MAXCNT=10000
C
   91 CONTINUE
      XR=XL+XINC
      IF(XL.LE.0.0)XL=0.0
      IF(XR.LE.0.0)XR=XL+1.0
      CALL NCFCDF(XL,NU1,NU2,DELTA,CDFL)
      CALL NCFCDF(XR,NU1,NU2,DELTA,CDFR)
      IF(CDFL.LT.P .AND. CDFR.LT.P)THEN
        XL=XR
      ELSEIF(CDFL.GT.P .AND. CDFR.GT.P)THEN
        XL=XL-XINC
      ELSE
        GOTO99
      ENDIF
      ICOUNT=ICOUNT+1
      IF(ICOUNT.GT.MAXCNT)THEN
        WRITE(ICOUT,96)
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
        GOTO9999
      ENDIF
   96 FORMAT('***** FATAL ERROR--NCFPPF UNABLE TO FIND BRACKETING ',
     *       'INTERVAL. *****')
      GOTO91
C
C  BISECTION METHOD
C
   99 CONTINUE
      IC = 0
      FXL = -P
      FXR = 1.0 - P
  105 CONTINUE
      X = (XL+XR)*0.5
      CALL NCFCDF(X,NU1,NU2,DELTA,CDF)
      P1=CDF
      PPF=X
      FCS = P1 - P
      IF(FCS*FXL.GT.ZERO)GOTO110
      XR = X
      FXR = FCS 
      GOTO115
  110 CONTINUE
      XL = X
      FXL = FCS
  115 CONTINUE
      XRML = XR - XL
      IF(XRML.LE.SIG .AND. ABS(FCS).LE.EPS)GOTO9999
      IC = IC + 1
      IF(IC.LE.MAXIT)GOTO105
      WRITE(ICOUT,130)
      CALL DPWRST('XXX','BUG ')
  130 FORMAT('***** FATAL ERROR--NCFPPF ROUTINE DID NOT CONVERGE. ***')
      GOTO9999
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE NCFRAN(N,ANU1,ANU2,ALAMB1,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE NON-CENTRAL F DISTRIBUTION WITH SHAPE
C              PARAMETERS ANU1 AND ANU2 AND NON-CENTRALITY
C              PARAMETER LAMBDA.
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --ANU1   = THE SINGLE PRECISION VALUE OF THE
C                                FIRST  SHAPE PARAMETER.
C                     --ANU2   = THE SINGLE PRECISION VALUE OF THE
C                                SECOND SHAPE PARAMETER.
C                     --ALAMB1  = THE SINGLE PRECISION VALUE OF THE
C                                NON-CENTRALITY 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 NON-CENTRAL F DISTRIBUTION
C             WITH SHAPE PARAMETER VALUES = ANU1, ANU2, AND ALAMB1.
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                 --ANU1 AND ANU2  SHOULD BE POSITIVE.
C                 --ALAMB1  SHOULD BE NON-NEGATIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NORRAN, CHSRAN.
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 2", SECOND EDITION,
C                 1994, PAGES 502-503.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004.5
C     ORIGINAL VERSION--MAY       2004.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
      DIMENSION XTEMP(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-----DATA STATEMENTS-------------------------------------------------
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)THEN
        WRITE(ICOUT, 5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
    5 FORMAT('***** ERROR--THE REQUESTED NUMBER OF NON-CENTRAL F ',
     1' RANDOM NUMBERS IS NON-POSITIVE.')
      IF(ANU1.LE.0.0)THEN
        WRITE(ICOUT,16)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ANU1
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
   16 FORMAT('***** ERROR--THE SHAPE PARAMETER NU1 FOR THE ',
     1'NON-CENTRAL F RANDOM NUMBERS IS NON-POSITIVE.')
      IF(ANU2.LE.0.0)THEN
        WRITE(ICOUT,26)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ANU2
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
   26 FORMAT('***** ERROR--THE SHAPE PARAMETER NU2 FOR THE ',
     1'NON-CENTRAL F RANDOM NUMBERS IS NON-POSITIVE.')
      IF(ALAMB1.LT.0.0)THEN
        WRITE(ICOUT,36)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ALAMB1
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
   36 FORMAT('***** ERROR--THE NON-CENTRALITY PARAMETER LAMBDA FOR ',
     1'THE NON-CENTRAL F RANDOM NUMBERS IS NEGATIVE.')
C
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8)
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8)
C
C  IF DEGREES OF FREEDOM ARE LESS THAN 1, THEN USE PERCENT
C  POINT METHOD (PROBABLY NOT MOST EFFICIENT METHOD, BUT LEAVE
C  UNTIL FIND A BETTER ALGORITHM).
C 
      ALAMB2=0.0
C
      IF(ANU1.LE.1.0 .OR. ANU2.LE.1.0)THEN
        CALL UNIRAN(N,ISEED,X)
        DO1378II=1,N
          ATEMP=X(II)
          CALL NCFPPF(ATEMP,ANU1,ANU2,ALAMB1,PPF)
          X(II)=PPF
 1378   CONTINUE
      ELSE
        NTEMP=1
        DO100II=1,N
          CALL NORRAN(NTEMP,ISEED,XTEMP)
          X1=(XTEMP(1) + SQRT(ALAMB1))**2
          IF(ANU1.GT.1.0)THEN
            CALL CHSRAN(NTEMP,ANU1-1.0,ISEED,XTEMP)
            X1=X1+XTEMP(1)
          ENDIF
          CALL NORRAN(NTEMP,ISEED,XTEMP)
          X2=(XTEMP(1) + SQRT(ALAMB2))**2
          IF(ANU2.GT.1.0)THEN
            CALL CHSRAN(NTEMP,ANU2-1.0,ISEED,XTEMP)
            X2=X2+XTEMP(1)
          ENDIF
          X(II)=ANU2*X1/(ANU1*X2)
  100   CONTINUE
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE NCTCDF(T2, DF2, DELTA2, CDF)
C
C     ALGORITHM AS 243  APPL. STATIST. (1989), VOL.38, NO. 1
C
C     Cumulative probability at T of the non-central t-distribution
C     with DF degrees of freedom (may be fractional) and non-centrality
C     parameter DELTA.
C
C     Note - requires the following auxiliary routines
C     ALOGAM (X)                         - ACM 291 or AS 245
C     BETAIN (X, A, B, ALBETA, IFAULT)   - AS 63 (updated in ASR 19)
C     ALNORM (X, UPPER)                  - AS 66
C
      REAL T2, DF2, DELTA2
      DOUBLE PRECISION A, DLBETA, ALNRPI, B, DEL, DELTA, DF, EN, ERRBD
      DOUBLE PRECISION ERRMAX, GEVEN, GODD, HALF, ITRMAX, LAMBDA, ONE
      DOUBLE PRECISION P, Q, R2PI, RXB, S, T, TT, TWO, X, XEVEN, XODD
      DOUBLE PRECISION ZERO, DBETAI, TNC
      LOGICAL NEGDEL
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      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     Note - ITRMAX and ERRMAX may be changed to suit one's needs.
C
      DATA ITRMAX/500.1D0/, ERRMAX/1.D-06/
C
C     Constants - R2PI = 1/ {GAMMA(1.5) * SQRT(2)} = SQRT(2 / PI)
C                 ALNRPI = LN(SQRT(PI))
C
      DATA ZERO/0.D0/
      DATA HALF/0.5D0/
      DATA ONE/1.0D0/
      DATA TWO/2.0D0/
      DATA R2PI/0.79788 45608 02865 35588D0/
      DATA ALNRPI/0.57236 49429 24700 08707D0/
C
      T=DBLE(T2)
      DF=DBLE(DF2)
      DELTA=DBLE(DELTA2)
C
      IF(DF.LE.ZERO)THEN
        WRITE(ICOUT,101)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,102)DF2
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
  101 FORMAT('***** FATAL DIAGNOSTIC--THE DEGREES OF FREEDOM PARAMETER')
  102 FORMAT('      IS NON-POSITIVE.  IT HAS THE VALUE ',E15.7)
C
      TNC = ZERO
C
      TT = T
      DEL = DELTA
      NEGDEL = .FALSE.
      IF (T .GE. ZERO) GO TO 1
      NEGDEL = .TRUE.
      TT = -TT
      DEL = -DEL
    1 CONTINUE
C
C     Initialize twin series (Guenther, J. Statist. Computn. Simuln.
C     vol.6, 199, 1978).
C
      EN = ONE
      X = T * T / (T* T + DF)
      IF (X .LE. ZERO) GO TO 20
      LAMBDA = DEL * DEL
      P = HALF * DEXP(-HALF * LAMBDA)
      Q = R2PI * P * DEL
      S = HALF - P
      A = HALF
      B = HALF * DF
      RXB = (ONE - X) ** B
CCCCC ALBETA = ALNRPI + ALOGAM(B, IFAULT) - ALOGAM(A + B, IFAULT)
CCCCC XODD = BETAIN(X, A, B, ALBETA, IFAULT)
      ALBETA=DLBETA(A,B)
      XODD = DBETAI(X,A,B)
C
      GODD = TWO * RXB * EXP(A * LOG(X) - ALBETA)
      XEVEN = ONE - RXB
      GEVEN = B * X * RXB
      TNC = P * XODD + Q * XEVEN
C
C     Repeat until convergence
C
   10 A = A + ONE
      XODD = XODD - GODD
      XEVEN = XEVEN - GEVEN
      GODD = GODD * X * (A + B - ONE) / A
      GEVEN = GEVEN * X * (A + B - HALF) / (A + HALF)
      P = P * LAMBDA / (TWO * EN)
      Q = Q * LAMBDA / (TWO * EN + ONE)
      S = S - P
      EN = EN + ONE
      TNC = TNC + P * XODD + Q * XEVEN
      ERRBD = TWO * S * (XODD - GODD)
      IF (ERRBD .GT. ERRMAX .AND. EN .LE. ITRMAX) GO TO 10
C
CCCCC APRIL 1995.  IF NO CONVERGENCE, CALL DOUBLY NON-CENTRAL T
CCCCC ROUTINE.
C
   20 CONTINUE
      IF (EN .GT. ITRMAX) THEN
CCCCC   WRITE(ICOUT,701)
CCCCC   CALL DPWRST('XXX','BUG ')
        ALAMB=0.0
        CALL DNTCDF(T2,DF2,DELTA2,ALAMB,CDF)
        RETURN
      ENDIF
  701 FORMAT('*** WARNING--THE NCTCDF ROUTINE DID NOT CONVERGE.  ***')
C
CCCCC TNC = TNC + ALNORM(DEL, .TRUE.)
      ARG1=REAL(DEL)
      CALL NORCDF(ARG1,ARG2)
      TNC = TNC + DBLE(1.0-ARG2)
      IF (NEGDEL) TNC = ONE - TNC
      GOTO9999
C
 9999 CONTINUE
      CDF=REAL(TNC)
      RETURN
      END
      SUBROUTINE NCTCD2(T2, DF2, DELTA2, CDF)
C
C     This is a copy of NCTCDF.  Distinction is that this version
C     returns a double precision result (used by the NCTPDF
C     routine) and inputs double precision arguments.
C
C     ALGORITHM AS 243  APPL. STATIST. (1989), VOL.38, NO. 1
C
C     Cumulative probability at T of the non-central t-distribution
C     with DF degrees of freedom (may be fractional) and non-centrality
C     parameter DELTA.
C
C     Note - requires the following auxiliary routines
C     ALOGAM (X)                         - ACM 291 or AS 245
C     BETAIN (X, A, B, ALBETA, IFAULT)   - AS 63 (updated in ASR 19)
C     ALNORM (X, UPPER)                  - AS 66
C
      DOUBLE PRECISION T2, DF2, DELTA2, ARG2, CDF
      DOUBLE PRECISION A, DLBETA, ALNRPI, B, DEL, DELTA, DF, EN, ERRBD
      DOUBLE PRECISION ERRMAX, GEVEN, GODD, HALF, ITRMAX, LAMBDA, ONE
      DOUBLE PRECISION P, Q, R2PI, RXB, S, T, TT, TWO, X, XEVEN, XODD
      DOUBLE PRECISION ZERO, DBETAI, TNC
      LOGICAL NEGDEL
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      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     Note - ITRMAX and ERRMAX may be changed to suit one's needs.
C
      DATA ITRMAX/1000.1D0/, ERRMAX/1.D-08/
C
C     Constants - R2PI = 1/ {GAMMA(1.5) * SQRT(2)} = SQRT(2 / PI)
C                 ALNRPI = LN(SQRT(PI))
C
      DATA ZERO/0.D0/
      DATA HALF/0.5D0/
      DATA ONE/1.0D0/
      DATA TWO/2.0D0/
      DATA R2PI/0.79788 45608 02865 35588D0/
      DATA ALNRPI/0.57236 49429 24700 08707D0/
C
      T=T2
      DF=DF2
      DELTA=DELTA2
C
      IF(DF.LE.ZERO)THEN
        WRITE(ICOUT,101)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,102)DF2
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
  101 FORMAT('***** FATAL DIAGNOSTIC--THE DEGREES OF FREEDOM PARAMETER')
  102 FORMAT('      IS NON-POSITIVE.  IT HAS THE VALUE ',D15.7)
C
      TNC = ZERO
C
      TT = T
      DEL = DELTA
      NEGDEL = .FALSE.
      IF (T .GE. ZERO) GO TO 1
      NEGDEL = .TRUE.
      TT = -TT
      DEL = -DEL
    1 CONTINUE
C
C     Initialize twin series (Guenther, J. Statist. Computn. Simuln.
C     vol.6, 199, 1978).
C
      EN = ONE
      X = T * T / (T* T + DF)
      IF (X .LE. ZERO) GO TO 20
      LAMBDA = DEL * DEL
      P = HALF * DEXP(-HALF * LAMBDA)
      Q = R2PI * P * DEL
      S = HALF - P
      A = HALF
      B = HALF * DF
      RXB = (ONE - X) ** B
CCCCC ALBETA = ALNRPI + ALOGAM(B, IFAULT) - ALOGAM(A + B, IFAULT)
CCCCC XODD = BETAIN(X, A, B, ALBETA, IFAULT)
      ALBETA=DLBETA(A,B)
      XODD = DBETAI(X,A,B)
C
      GODD = TWO * RXB * EXP(A * LOG(X) - ALBETA)
      XEVEN = ONE - RXB
      GEVEN = B * X * RXB
      TNC = P * XODD + Q * XEVEN
C
C     Repeat until convergence
C
   10 A = A + ONE
      XODD = XODD - GODD
      XEVEN = XEVEN - GEVEN
      GODD = GODD * X * (A + B - ONE) / A
      GEVEN = GEVEN * X * (A + B - HALF) / (A + HALF)
      P = P * LAMBDA / (TWO * EN)
      Q = Q * LAMBDA / (TWO * EN + ONE)
      S = S - P
      EN = EN + ONE
      TNC = TNC + P * XODD + Q * XEVEN
      ERRBD = TWO * S * (XODD - GODD)
      IF (ERRBD .GT. ERRMAX .AND. EN .LE. ITRMAX) GO TO 10
C
CCCCC APRIL 1995.  IF NO CONVERGENCE, CALL DOUBLY NON-CENTRAL T
CCCCC ROUTINE.
C
   20 CONTINUE
      IF (EN .GT. ITRMAX) THEN
CCCCC   WRITE(ICOUT,701)
CCCCC   CALL DPWRST('XXX','BUG ')
        ALAMB=0.0
        CALL DNTCDF(REAL(T2),REAL(DF2),REAL(DELTA2),ALAMB,CDF2)
        CDF=DBLE(CDF2)
        RETURN
      ENDIF
  701 FORMAT('*** WARNING--THE NCTCD2 ROUTINE DID NOT CONVERGE.  ***')
C
CCCCC TNC = TNC + ALNORM(DEL, .TRUE.)
      ARG1=REAL(DEL)
      CALL NODCDF(DEL,ARG2)
      TNC = TNC + (1.0D0-ARG2)
      IF (NEGDEL) TNC = ONE - TNC
      GOTO9999
C
 9999 CONTINUE
      CDF=TNC
      RETURN
      END
      SUBROUTINE NCTPDF(T, DF, DELTA, PDF)
C
C     COMPUTE NON-CENTRAL PDF BASED ON NON-CENTRAL CDF.
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
      DOUBLE PRECISION DCDF
      DOUBLE PRECISION DPDF
      DOUBLE PRECISION DPDF1
      DOUBLE PRECISION DPDF2
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C     T = 0 IS A SPECIAL CASE.
C
CCCCC EPS=0.000001
      EPS=1.0E-8
      IF(ABS(T).LE.EPS)THEN
C
C  THIS ALGORITHM DOES NOT RETURN A CORRECT RESULT.  AS TEMPORARY
C  FIX, COMPUTE FOR +EPS AND -EPS, THEN AVERAGE RESULT.
C
CCCCC   TX=EPS
CCCCC   TERM1=DF/TX
CCCCC   DF2=DF+2.0
CCCCC   TX2=SQRT((DF+2.0)/DF)*TX
CCCCC   CALL NCTCDF(TX2,DF2,DELTA,TERM2)
CCCCC   CALL NCTCDF(TX,DF,DELTA,TERM3)
CCCCC   PDF=TERM1*(TERM2-TERM3)
C
        TTEMP=EPS
        DTERM1=DBLE(DF/TTEMP)
        DF2=DF+2.0
        T2=SQRT((DF+2.0)/DF)*TTEMP
        CALL NCTCD2(DBLE(T2),DBLE(DF2),DBLE(DELTA),DTERM2)
        CALL NCTCD2(DBLE(TTEMP),DBLE(DF),DBLE(DELTA),DTERM3)
        DPDF1=DTERM1*(DTERM2-DTERM3)
C
        TTEMP=-EPS
        DTERM1=DBLE(DF/TTEMP)
        DF2=DF+2.0
        T2=SQRT((DF+2.0)/DF)*TTEMP
        CALL NCTCD2(DBLE(T2),DBLE(DF2),DBLE(DELTA),DTERM2)
        CALL NCTCD2(DBLE(TTEMP),DBLE(DF),DBLE(DELTA),DTERM3)
        DPDF2=DTERM1*(DTERM2-DTERM3)
C
        DPDF=(DPDF1+DPDF2)/2.0D0
        PDF=REAL(DPDF)
      ELSE
        DTERM1=DBLE(DF/T)
        DF2=DF+2.0
        T2=SQRT((DF+2.0)/DF)*T
        CALL NCTCD2(DBLE(T2),DBLE(DF2),DBLE(DELTA),DTERM2)
        CALL NCTCD2(DBLE(T),DBLE(DF),DBLE(DELTA),DTERM3)
        DPDF=DTERM1*(DTERM2-DTERM3)
        PDF=REAL(DPDF)
      ENDIF
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE NCTPPF(P,NU,DELTA,PPF)
C
C     PURPOSE   --PERCENT POINT FUNCTION FOR THE NON-CENTRAL T
C                 DISTRIBUTION.  USES A BISECTION METHOD.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--94/9
C     ORIGINAL VERSION--SEPTEMBER 1994.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      REAL NU
      DOUBLE PRECISION DLNGAM
      DOUBLE PRECISION FCT
      DOUBLE PRECISION C0
      DOUBLE PRECISION C1
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
CCCCC DATA EPS /0.0001/
CCCCC DATA SIG /1.0E-5/
      DATA ZERO /0./
      DATA MAXIT /500/
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(P.LE.0.0.OR.P.GE.1.0)GOTO50
      IF(NU.LT.0.0)GOTO55
      IF(DELTA.LT.0.0)GOTO70
      GOTO90
   50 WRITE(ICOUT,1)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)P
      CALL DPWRST('XXX','BUG ')
      PPF=0.0
      RETURN
   55 WRITE(ICOUT,11)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)NU
      CALL DPWRST('XXX','BUG ')
      PPF=0.0
      RETURN
   70 WRITE(ICOUT,35)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)DELTA
      CALL DPWRST('XXX','BUG ')
      PPF=0.0
      GOTO9999
C
    1 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ',
     1' NCTPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL.')
   11 FORMAT('***** FATAL ERROR--THE 2ND INPUT ARGUMENT TO THE ',
     1' NCTPPF SUBROUTINE IS LESS THAN 1.')
   35 FORMAT('***** FATAL ERROR--THE THIRD INPUT ARGUMENT TO THE ',
     1' NCTPPF SUBROUTINE IS NEGATIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I15,' *****')
C
   90 CONTINUE
C
C  DELTA = 0 AND NU INTEGER, USE CENTRAL T
C
      IF(DELTA.EQ.0.0)THEN
        NUINT=INT(NU+0.1)
        ANUINT=REAL(NUINT)
        IF(ABS(NU-ANUINT).LE.0.00001)THEN
          CALL TPPF(P,NUINT,PPF)
          GOTO9999
        ENDIF
      ENDIF
C
C  FIND BRACKETING INTERVAL.  USE CORRESPONDING CENTRAL T
C  AS INITIAL GUESS, INCREMENTS OF 100 AROUND IT.
C  AFTER SUCCESSFULLY FIND BRACKETING INTERVAL, THEN SWITCH TO 
C  MORE EFFICIENT BISECTION METHOD.
C
C  8/97.  BASE XINC ON NON_CENTRAL T STANDARD DEVIATION
C         (FROM MARK VANGEL'S INVNCT ALGORITHM)
C  5/2004. BETTER BRACKETING INTERVAL.  BASE ON MEAN, SD, AND VALUE OF P.
C          ALSO, FOR LOW VALUES OF NU AND MORE EXTREME VALUES OF P,
C          LOOSEN THE CONVERGENCE CRITIERION.
C
      EPS=0.0001
      SIG=1.0E-5
      IF(NU.LT.3.0)THEN
        IF(P.GT.0.90 .OR. P.LT.0.10)THEN
          EPS=0.0001
          SIG=1.0E-4
        ENDIF
      ENDIF
      IF(ABS(DELTA).GE.10.0)THEN
          EPS=0.0001
          SIG=1.0E-4
      ENDIF
C
      NUINT=NU+0.5
CCCCC CALL TPPF(P,NUINT,XL)
CCCCC XINC=50.0
      IF(NU.LE.1.5)THEN
        AMEAN=DELTA
      ELSE
        FCT=DEXP(DLNGAM(DBLE(0.5*(NU-1.0)))-DLNGAM(DBLE(0.5*NU)))
        C1=DBLE(NU)*DSQRT(DBLE(NU)/2.0D0)
        AMEAN=SNGL(C1*FCT)
      ENDIF
      IF(NU.LE.2.5)THEN
        SD=100.0
      ELSE
        FCT=DEXP(DLNGAM(DBLE(0.5*(NU-1.0)))-DLNGAM(DBLE(0.5*NU)))
        C1=DBLE(NU/(NU-2.0) - 0.5*NU*FCT**2)
        C0=DBLE(NU/(NU-2.0))
        SD=SNGL(DSQRT(C1*DELTA**2+C0))
      ENDIF
      XINC=SD
C
      IF(P.GE.0.25 .AND. P.LE.0.75)THEN
        XL=AMEAN-XINC
        XINC=2.0*SD
      ELSEIF(P.GT.0.75)THEN
        XL=AMEAN
      ELSE
        XL=AMEAN-3.0*XINC
        XINC=2.9*SD
      ENDIF
C
      ICOUNT=0
      MAXCNT=100
      IF(NU.LT.3.0)MAXCNT=200
C
   91 CONTINUE
      XR=XL+XINC
      CALL NCTCDF(XL,NU,DELTA,CDFL)
      CALL NCTCDF(XR,NU,DELTA,CDFR)
      IF(CDFL.LT.P .AND. CDFR.LT.P)THEN
        XL=XR
      ELSEIF(CDFL.GT.P .AND. CDFR.GT.P)THEN
        XL=XL-XINC
      ELSE
        GOTO99
      ENDIF
      ICOUNT=ICOUNT+1
      IF(ICOUNT.GT.MAXCNT)THEN
        WRITE(ICOUT,96)
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
        GOTO9999
      ENDIF
   96 FORMAT('***** FATAL ERROR--NCTPPF UNABLE TO FIND BRACKETING ',
     *       'INTERVAL. *****')
      GOTO91
C
C  BISECTION METHOD
C
   99 CONTINUE
      IC = 0
      FXL = -P
      FXR = 1.0 - P
  105 CONTINUE
      X = (XL+XR)*0.5
      CALL NCTCDF(X,NU,DELTA,CDF)
      P1=CDF
      PPF=X
      FCS = P1 - P
      IF(FCS*FXL.GT.ZERO)GOTO110
      XR = X
      FXR = FCS 
      GOTO115
  110 CONTINUE
      XL = X
      FXL = FCS
  115 CONTINUE
      XRML = XR - XL
      IF(XRML.LE.SIG .AND. ABS(FCS).LE.EPS)GOTO9999
      IC = IC + 1
      IF(IC.LE.MAXIT)GOTO105
      WRITE(ICOUT,130)
      CALL DPWRST('XXX','BUG ')
  130 FORMAT('***** FATAL ERROR--NCTPPF ROUTINE DID NOT CONVERGE. ***')
      GOTO9999
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE NCTRAN(N,ANU,DELTA,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE STUDENT'S NON-CENTRAL T DISTRIBUTION
C              WITH DEGREES OF FREEDOM PARAMETER NU AND
C              NON-CENTRALITY PARAMETER DELTA.
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --NU     = THE INTEGER DEGREES OF FREEDOM
C                                PARAMETER.
C                     --DELTA  = THE REAL NON-CENTRALITY PARAMETER DELTA.
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 STUDENT'S NON-CENTRAL T DISTRIBUTION
C             WITH DEGREES OF FREEDOM PARAMETER = NU AND
C             NON-CENTRALITY PARAMETER DELTA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C                 --NU SHOULD BE A POSITIVE INTEGER VARIABLE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN.
C     FORNCTRAN LIBRARY SUBROUTINES NEEDED--ALOG, SQRT, SIN, COS.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORNCTRAN (1977)
C     REFERENCES--MOOD AND GRABLE, INTRODUCTION TO THE
C                 THEORY OF STATISTICS, 1963, PAGE 233.
C               --JOHNSON, KOTZ, AND BALAKRISHNAN, CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME 2, SECOND EDITION,
C                 1994, CHAPTER 31.
C               --HASTINGS, EVANS, AND PEACOCK, STATISTICAL
C                 DISTRIBUTIONS--THIRD EDITION, WILEY, 2001,
C                 PP. 184-186.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--2004.3
C     ORIGINAL VERSION--MARCH     2004.
C     UPDATED         --MAY       2004. SUPPORT FOR REAL VALUES OF NU
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      REAL DELTA
      REAL ANU
      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-----DATA STATEMENTS-------------------------------------------------
C
      DATA PI/3.14159265359/
      DATA EPS/0.00001/
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(ANU.LE.0.0)THEN
        WRITE(ICOUT,15)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,48)ANU
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
    5 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO THE ',
     1'NCTRAN   SUBROUTINE IS NON-POSITIVE *****')
   15 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO THE ',
     1'NCTRAN   SUBROUTINE IS NON-POSITIVE *****')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8)
   48 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
C
C     GENERATE N STUDENT'S NON-CENTRAL T RANDOM NUMBERS
C     USING THE DEFINITION THAT A STUDENT'S NON-CENTRAL T VARIATE
C     WITH NU DEGREES OF FREEDOM AND NON-CENTRALITY PARAMETER
C     DELTA EQUALS A NORMAL VARIATE WITH LOCATION PARAMETER DELTA
C     DIVIDED BY A STANDARDIZED CHI VARIATE
C     (WHERE THE LATTER EQUALS SQRT(CHI-SQUARED/NU).
C     FIRST GENERATE A NORMAL RANDOM NUMBER WITH LOCATION PARAMETER
C     DELTA, THEN GENERATE A STANDARDIZED CHI RANDOM NUMBER,
C     THEN FORM THE RATIO OF THE FIRST DIVIDED BY
C     THE SECOND.
C
      CALL NORRAN(N,ISEED,X)
      NTEMP=1
C
      DO100I=1,N
C
        X(I)=X(I) + DELTA
        CALL CHSRAN(NTEMP,ANU,ISEED,Y)
        X(I)=X(I)/SQRT(Y(1)/ANU)
C
  100 CONTINUE
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE NEIGH(IT,NN,XS,N,I1,I2,ISUBRO,IBUGA3,IERROR)
C
C     PURPOSE--FOR THE IT-TH HORIZONTAL ORDERED DATA POINT XS(IT),
C              DETERMINE THE INDICES I1 AND I2 WHICH DEFINE
C              THE NN NEAREST NEIGHBORS OF XS(IT).
C     NOTE--XS(IT) IS CONSIDERED A NEIGHBOR OF ITSELF.
C     REFERENCE--CHAMBERS, ET AL.  GRAPHICAL METHODS FOR DATA ANALYSIS.
C                WADSWORTH, 1983, PAGES 94-98, 121-122.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--88/2
C     ORIGINAL VERSION--FEBRUARY   1988
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 ISUBRO
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DIMENSION XS(*)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
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='EIGH'
      ISUBN2='H   '
C
      I1=(-999)
      I2=(-999)
      IERROR='NO'
C
      IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'EIGH')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF NEIGH--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)ISUBRO,IBUGA3,IERROR
   52 FORMAT('ISUBRO,IBUGA3,IERROR = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)IT,NN,N
   53 FORMAT('IT,NN,N = ',3I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,54)I1,I2
   54 FORMAT('I1,I2 = ',2I8)
      CALL DPWRST('XXX','BUG ')
   90 CONTINUE
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      IF(N.GE.1)GOTO119
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,111)
  111 FORMAT('***** ERROR IN NEIGH--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,112)
  112 FORMAT('      THE INPUT FULL SAMPLE SIZE,')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,113)
  113 FORMAT('      FOR WHICH LOWESS NEIGHBORHOODS')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,114)
  114 FORMAT('      ARE TO BE COMPUTED, MUST BE 1 OR LARGER.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,115)
  115 FORMAT('      SUCH WAS NOT THE CASE HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,116)N
  116 FORMAT('      THE FULL SAMPLE SIZE N = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
  119 CONTINUE
C
      IF(IT.GE.1)GOTO129
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,121)
  121 FORMAT('***** ERROR IN NEIGH--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,122)
  122 FORMAT('      THE INPUT TARGET OBSERVATION INDEX')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,123)
  123 FORMAT('      FOR WHICH A LOWESS IS TO BE CARRIED OUT')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,124)N
  124 FORMAT('      MUST BE BETWEEN 1 AND ',I8,' (INCLUSIVE).')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,125)
  125 FORMAT('      SUCH WAS NOT THE CASE HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,126)IT
  126 FORMAT('      THE TARGET OBSERVATION INDEX IT = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
  129 CONTINUE
C
      IF(NN.GE.1)GOTO139
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,131)
  131 FORMAT('***** ERROR IN NEIGH--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,132)
  132 FORMAT('      THE INPUT NEIGHBORHOOD SIZE')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,133)
  133 FORMAT('      FOR WHICH A LOWESS IS TO BE CARRIED OUT')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,134)N
  134 FORMAT('      MUST BE BETWEEN 1 AND ',I8,' (INCLUSIVE).')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,135)
  135 FORMAT('      SUCH WAS NOT THE CASE HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,136)NN
  136 FORMAT('      THE NEIGHBORHOOD SIZE NN = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
  139 CONTINUE
C
C               ***********************************************
C               **  STEP 11--                                **
C               **  COMPUTE THE INDICES OF THE NEIGHBORHOOD  **
C               ***********************************************
C
      I1=IT
      I2=IT
      NNI=1
C
      IF(NN.LE.1)GOTO1190
      DO1100I=2,NN
C
      IF(I1.LE.1)GOTO1110
      IF(I2.GE.N)GOTO1120
      GOTO1130
C
 1110 CONTINUE
      I2=I2+1
      NNI=NNI+1
      GOTO1100
C
 1120 CONTINUE
      I1=I1-1
      NNI=NNI+1
      GOTO1100
C
 1130 CONTINUE
      I1M1=I1-1
      I2P1=I2+1
      DEL1=ABS(XS(IT)-XS(I1M1))
      DEL2=ABS(XS(I2P1)-XS(IT))
      IF(DEL1.LT.DEL2)I1=I1M1
      IF(DEL1.GE.DEL2)I2=I2P1
      NNI=NNI+1
      GOTO1100
C
 1100 CONTINUE
 1190 CONTINUE
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'EIGH')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF NEIGH--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)ISUBRO,IBUGA3,IERROR
 9012 FORMAT('ISUBRO,IBUGA3,IERROR = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)IT,NN,N
 9013 FORMAT('IT,NN,N = ',3I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9014)I1,I2
 9014 FORMAT('I1,I2 = ',2I8)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE NMXCDF(X,U1,SD1,U2,SD2,P,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE MIXTUURE NORMAL (GAUSSIAN)
C              DISTRIBUTION.
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 DOUBLE 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--NODCDF.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS, 2ND. ED.--1, 1994, CHAPTER 12.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--98.5
C     ORIGINAL VERSION--MAY       1998.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DOUBLE PRECISION DARG1
      DOUBLE PRECISION DCDF1
      DOUBLE PRECISION DCDF2
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
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(SD1.LE.0.0)THEN
        WRITE(ICOUT,101)
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9000
      ENDIF
  101 FORMAT('*****ERROR FROM NMXCDF--FIRST SCALE PARAMETER IS ',
     1       'NOT POSITVE.')
      IF(SD2.LE.0.0)THEN
        WRITE(ICOUT,103)
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9000
      ENDIF
  103 FORMAT('*****ERROR FROM NMXCDF--SECOND SCALE PARAMETER IS ',
     1       'NOT POSITIVE.')
C
      DARG1=DBLE((X-U1)/SD1)
      CALL NODCDF(DARG1,DCDF1)
      DARG1=DBLE((X-U2)/SD2)
      CALL NODCDF(DARG1,DCDF2)
C
      CDF=REAL(DBLE(P)*DCDF1 + DBLE(1.0-P)*DCDF2)
C
 9000 CONTINUE
C
      RETURN
      END
      SUBROUTINE NMDCDF(X,U1,SD1,U2,SD2,P,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE MIXTUURE NORMAL (GAUSSIAN)
C              DISTRIBUTION.  SAME AS NMXCDF EXCEPT THAT THE
C              CDF RETURNED IS DOUBLE PRECISION.
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 DOUBLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE CDF.
C     PRINTING--NONE.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NODCDF.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS, 2ND. ED.--1, 1994, CHAPTER 12.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--98.5
C     ORIGINAL VERSION--MAY       1998.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DOUBLE PRECISION DARG1
      DOUBLE PRECISION DCDF1
      DOUBLE PRECISION DCDF2
      DOUBLE PRECISION CDF
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
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(SD1.LE.0.0)THEN
        WRITE(ICOUT,101)
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9000
      ENDIF
  101 FORMAT('*****ERROR FROM NMXCDF--FIRST SCALE PARAMETER IS ',
     1       'NOT POSITVE.')
      IF(SD2.LE.0.0)THEN
        WRITE(ICOUT,103)
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9000
      ENDIF
  103 FORMAT('*****ERROR FROM NMXCDF--SECOND SCALE PARAMETER IS ',
     1       'NOT POSITIVE.')
C
      DARG1=DBLE((X-U1)/SD1)
      CALL NODCDF(DARG1,DCDF1)
      DARG1=DBLE((X-U2)/SD2)
      CALL NODCDF(DARG1,DCDF2)
C
      CDF=DBLE(P)*DCDF1 + DBLE(1.0-P)*DCDF2
C
 9000 CONTINUE
C
      RETURN
      END
      SUBROUTINE NMXPPF(P,U1,SD1,U2,SD2,PMIX,PPF)
C
C     PURPOSE   --PERCENT POINT FUNCTION FOR THE NORMAL MIXTURE
C                 DISTRIBUTION.  USES A BISECTION METHOD.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--98/5
C     ORIGINAL VERSION--MAY       1998.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DCDF
      DOUBLE PRECISION FXL
      DOUBLE PRECISION FXR
      DOUBLE PRECISION XLD
      DOUBLE PRECISION XRD
      DOUBLE PRECISION P1
      DOUBLE PRECISION X
      DOUBLE PRECISION PPFD
      DOUBLE PRECISION FCS
      DOUBLE PRECISION XRML
      DOUBLE PRECISION SIG
      DOUBLE PRECISION EPS
      DOUBLE PRECISION ZERO
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DATA EPS /0.00001D0/
      DATA SIG /1.0D-6/
      DATA ZERO /0.D0/
      DATA MAXIT /20000/
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(P.LE.0.0.OR.P.GE.1.0)THEN
        WRITE(ICOUT,1)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)P
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
        GOTO9999
      ENDIF
    1 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ',
     1' NMXPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL.')
      IF(SD1.LE.0.0)THEN
        WRITE(ICOUT,11)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)SD1
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
        GOTO9999
      ENDIF
   11 FORMAT('***** FATAL ERROR--THE FIRST SCALE PARAMETER TO THE ',
     1' NMXPPF SUBROUTINE IS LESS THAN OR EQUAL TO 0.')
      IF(SD2.LE.0.0)THEN
        WRITE(ICOUT,13)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)SD2
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
        GOTO9999
      ENDIF
   13 FORMAT('***** FATAL ERROR--THE SECOND SCALE PARAMETER TO THE ',
     1' NMXPPF SUBROUTINE IS LESS THAN OR EQUAL TO 0.')
C
      IF(PMIX.LT.0.0 .OR. PMIX.GT.1.0)THEN
        WRITE(ICOUT,15)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)PMIX
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
        GOTO9999
      ENDIF
   15 FORMAT('***** FATAL ERROR--THE MIXING PARAMETER TO THE ',
     1' NMXPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL.')
C
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I15,' *****')
C
   90 CONTINUE
C
C  FIND BRACKETING INTERVAL.
C
      XMEAN=PMIX*U1 + (1.0-PMIX)*U2
      XVAR=PMIX*SD1*SD1 + (1.0-PMIX)*SD2*SD2 +
     1     PMIX*(1.0-PMIX)*(U1-U2)*(U1-U2)
      XSD=SQRT(XVAR)
C
      ICOUNT=0
      MAXCNT=100
C
      XL=XMEAN
      XINC=XSD
C
   91 CONTINUE
      XR=XL+XINC
      CALL NMXCDF(XL,U1,SD1,U2,SD2,PMIX,CDFL)
      CALL NMXCDF(XR,U1,SD1,U2,SD2,PMIX,CDFR)
      IF(CDFL.LT.P .AND. CDFR.LT.P)THEN
        XL=XR
      ELSEIF(CDFL.GT.P .AND. CDFR.GT.P)THEN
        XL=XL-XINC
      ELSE
        GOTO99
      ENDIF
      ICOUNT=ICOUNT+1
      IF(ICOUNT.GT.MAXCNT)THEN
        WRITE(ICOUT,96)
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
        GOTO9999
      ENDIF
   96 FORMAT('***** FATAL ERROR--NMXPPF UNABLE TO FIND BRACKETING ',
     *       'INTERVAL. *****')
      GOTO91
C
C  BISECTION METHOD
C
   99 CONTINUE
      XLD=DBLE(XL)
      XRD=DBLE(XR)
      IC = 0
      FXL = DBLE(-P)
      FXR = DBLE(1.0 - P)
  105 CONTINUE
      X = (XLD+XRD)*0.5D0
      CALL NMDCDF(REAL(X),U1,SD1,U2,SD2,PMIX,DCDF)
      P1=DCDF
      PPFD=X
      PPF=REAL(PPFD)
      FCS = P1 - DBLE(P)
      IF(FCS*FXL.GT.ZERO)GOTO110
      XRD = X
      FXR = FCS
      GOTO115
  110 CONTINUE
      XLD = X
      FXL = FCS
  115 CONTINUE
      XRML = XRD - XLD
      IF(XRML.LE.SIG .AND. ABS(FCS).LE.EPS)GOTO9999
      IC = IC + 1
      IF(IC.LE.MAXIT)GOTO105
      WRITE(ICOUT,130)
      CALL DPWRST('XXX','BUG ')
  130 FORMAT('***** FATAL ERROR--NMXPPF ROUTINE DID NOT CONVERGE. ***')
      GOTO9999
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE NMXRAN(N,U1,SD1,U2,SD2,P,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE THE NORMAL (GAUSSIAN) MIXTURE
C              DISTRIBUTION.
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST N)
C                                INTO WHICH THE GENERATED
C                                RANDOM SAMPLE WILL BE PLACED.
C     OUTPUT--A RANDOM SAMPLE OF SIZE N
C             FROM THE NORMAL MIXTURE 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--ALOG, SQRT, SIN, COS.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     METHOD--1) CALCULATE UNIFORM RAND NUMBER.
C             2) IF LESS THAN OR EQUAL TO P, CALCULATE RAND NUMBER
C                FROM NORMAL WITH U1, SD1
C             3) IF GREATER THAN P, CALCULATE RAND NUMBER
C                FROM NORMAL WITH U2, SD2
C     REFERENCES--FOWLKES, "SOME METHODS FOR STUDYING THE MIXTURE
C                 OF TWO NORMAL (LOGNORMAL) DSITRIBUTIONS', 
C                 JOURNAL OF THE AMERICAN STATISTICAL ASSOCIATION,
C                 SEPTEMBER, 1979.  PAGES 561-575.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--98.5
C     ORIGINAL VERSION--MAY       1998.
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
      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'NMXRAN SUBROUTINE IS NON-POSITIVE *****')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
C
      CALL UNIRAN(N,ISEED,X)
C
      NTEMP=1
      DO200I=1,N
        CALL NORRAN(NTEMP,ISEED,Y)
        IF(X(I).LE.P)THEN
          X(I)=U1 + SD1*Y(1)
        ELSE
          X(I)=U2 + SD2*Y(1)
        ENDIF
  200 CONTINUE
C
      RETURN
      END
      SUBROUTINE NORCDF(X,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE NORMAL (GAUSSIAN)
C              DISTRIBUTION WITH 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     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C     OUTPUT ARGUMENTS--CDF    = THE SINGLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE CDF.
C     PRINTING--NONE.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--EXP.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--NATIONAL BUREAU OF STANDARDS APPLIED MATHEMATICS
C                 SERIES 55, 1964, PAGE 932, FORMULA 26.2.17.
C               --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1970, PAGES 40-111.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (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   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 B1,B2,B3,B4,B5,P/.319381530,-0.356563782,1.781477937,-1.82125
     15978,1.330274429,.2316419/
C
C-----START POINT-----------------------------------------------------
C
      Z=X
      IF(X.LT.0.0)Z=-Z
      T=1.0/(1.0+P*Z)
      CDF=1.0-((0.39894228040143  )*EXP(-0.5*Z*Z))*(B1*T+B2*T**2+B3*T**3
     1+B4*T**4+B5*T**5)
      IF(X.LT.0.0)CDF=1.0-CDF
C
      RETURN
      END
      SUBROUTINE NORFUN (N, X, FVEC, IFLAG, XDATA, NOBS)
C
C     PURPOSE--THIS ROUTINE COMPUTES THE FUNCTIONS FOR THE
C              CENSORED NORMAL MAXIMUM LIKELIHOOD EQUATIONS.
C
C                 SUM[i=1 to r][Z(I)] + SUM[j=1 to m][h(y(i)] = 0
C                 SUM[i=1 to r][Z(I)**2] + SUM[j=1 to m][y(i)*h(y(i)] - r = 0
C
C              WITH
C
C                 r = NUMBER OF FAILURE TIMES
C                 m = NUMBER OF CENSORED ITEMS
C
C                 Z(I) = (X(i) - muhat)/sigmahat
C                 Y(I) = (C(j) - muhat)/sigmahat
C
C                 h IS THE NORMAL HAZARD FUNCTION.
C
C              WITH C AND K DENOTING THE SHAPE PARAMETERS,
C              RESPECTIVELY.  THE muhat AND sigmahat PARAMETERS ARE
C              THE QUANTITIES BEING ESTIMATED.  USE THE MEAN AND
C              STANDARD DEVIATION OF THE FAILURE TIMES DATA AS
C              STARTING VALUES.
C
C              TO SIMPLIFY THE INTERFACE, SORT THE INPUT DATA
C              ARRAY, X, SO THAT THE r FAILURE TIMES COME FIRST
C              AND THEN THE M CENSOR TIMES.
C
C              CALLED BY DNSQE ROUTINE FOR SOLVING SIMULTANEOUS
C              NONLINEAR EQUATIONS.  NOTE THAT THE CALLING SEQUENCE
C              DID NOT ACCOMODATE A DATA ARRAY (AND ASSCIATED NUMBER OF
C              OBSERVATIONS), SO THESE WERE ADDED TO THE CALL LIST.
C     EXAMPLE--NORMAL MAXIMUM LIKELIHOOD Y CENSOR
C     REFERENCE--KARL BURY, "STATISTICAL DISTRIBUTIONS IN ENGINEERING",
C                CAMBRIDGE UNIVERSITY PRESS, 1999, CHAPTER 10.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBUG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2003/11
C     ORIGINAL VERSION--NOVEMBER  2003.
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION X(*)
      DOUBLE PRECISION FVEC(*)
      REAL XDATA(*)
C
      DOUBLE PRECISION MU
      DOUBLE PRECISION SIGMA
      DOUBLE PRECISION DN
      DOUBLE PRECISION DX
      DOUBLE PRECISION DR
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DSUM2
      DOUBLE PRECISION DSUM3
      DOUBLE PRECISION DSUM4
      DOUBLE PRECISION DHAZ
      DOUBLE PRECISION DPDF
      DOUBLE PRECISION DCDF
C
C---------------------------------------------------------------------
C
      COMMON/NORCML/IR
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C  COMPUTE SOME SUMS
C
      MU=X(1)
      SIGMA=X(2)
      DN=DBLE(NOBS)
      DR=DBLE(IR)
C
      DSUM1=0.0D0
      DSUM2=0.0D0
      DO200I=1,IR
        DX=DBLE(XDATA(I))
        DX=(DX - MU)/SIGMA
        DSUM1=DSUM1 + DX
        DSUM2=DSUM2 + DX*DX
  200 CONTINUE
C
      DSUM3=0.0D0
      DSUM4=0.0D0
      IF(IR.LT.NOBS)THEN
        DO300I=IR+1,NOBS
          DX=DBLE(XDATA(I))
          DX=(DX - MU)/SIGMA
          CALL NODPDF(DX,DPDF)
          CALL NODCDF(DX,DCDF)
          DHAZ=DPDF/(1.0D0 - DCDF)
          DSUM3=DSUM3 + DHAZ
          DSUM4=DSUM4 + DX*DHAZ
  300   CONTINUE
      ENDIF
C
      FVEC(1)=DSUM1 + DSUM3
      FVEC(2)=DSUM2 + DSUM4 - DR
C
      RETURN
      END
      SUBROUTINE NORPDF(X,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE NORMAL (GAUSSIAN)
C              DISTRIBUTION WITH 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     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C     OUTPUT ARGUMENTS--PDF    = THE SINGLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE PDF.
C     PRINTING--NONE.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--EXP.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--NATIONAL BUREAU OF STANDARDS APPLIED MATHEMATICS
C                 SERIES 55, 1964, PAGE 931, FORMULA 26.2.1.
C               --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DENSITYS--1, 1970, PAGES 40-111.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (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   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.14159265/
C
C-----START POINT-----------------------------------------------------
C
      CONST=1/SQRT(2.0*PI)
      TERM=EXP(-0.5*X**2)
      PDF=CONST*TERM
C
      RETURN
      END
      SUBROUTINE NORPPC(X,N,IWRITE,Y,W,MAXNYW,PPCC,IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE NORMAL
C              PROBABILITY PLOT CORRELATION COEFFICIENT.
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              AS USED HEREIN, A PROBABILITY PLOT FOR A DISTRIBUTION
C              IS A PLOT OF THE ORDERED OBSERVATIONS VERSUS
C              THE ORDER STATISTIC MEDIANS FOR THAT DISTRIBUTION.
C              THE NORMAL PROBABILITY PLOT IS USEFUL IN
C              GRAPHICALLY TESTING THE COMPOSITE (THAT IS,
C              LOCATION AND SCALE PARAMETERS NEED NOT BE SPECIFIED)
C              HYPOTHESIS THAT THE UNDERLYING DISTRIBUTION
C              FROM WHICH THE DATA HAVE BEEN RANDOMLY DRAWN
C              IS THE NORMAL DISTRIBUTION.
C              IF THE HYPOTHESIS IS TRUE, THE PROBABILITY PLOT
C              SHOULD BE NEAR-LINEAR.
C              A MEASURE OF SUCH LINEARITY IS GIVEN BY THE
C              CALCULATED PROBABILITY PLOT CORRELATION COEFFICIENT.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF
C                                (UNSORTED OR SORTED) OBSERVATIONS.
C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR X.
C     OUTPUT ARGUMENTS--PPCC   = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED NORMAL PPCC.
C     OUTPUT--NONE.
C     PRINTING--YES.
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               --FILLIBEN, 'THE PROBABILITY PLOT CORRELATION COEFFICIENT
C                 TEST FOR NORMALITY', TECHNOMETRICS, 1975, PAGES 111-117.
C               --RYAN AND JOINER, 'NORMAL PROBABILITY PLOTS AND TESTS
C                 FOR NORMALITY'  PENNSYLVANIA
C                 STATE UNIVERSITY REPORT.
C               --HAHN AND SHAPIRO, STATISTICAL METHODS IN ENGINEERING,
C                 1967, PAGES 260-308.
C               --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1970, PAGES 40-111.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--82.6
C     ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--JULY      1972.
C     UPDATED         --JULY      1981.
C     UPDATED         --AUGUST    1981.
C     UPDATED         --NOVEMBER  1981.
C     UPDATED         --MAY       1982.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
      DIMENSION Y(*)
      DIMENSION W(*)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      INCLUDE 'DPCOPA.INC'
C
      ISUBN1='NORP'
      ISUBN2='PC  '
C
      IERROR='NO'
      IUPPER=MAXOBV
C
      SUM1=0.0
      SUM2=0.0
      SUM3=0.0
C
      IF(IBUGA3.EQ.'OFF')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF NORPPC--')
      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 NORMAL                            **
C               **  PROBABILITY PLOT CORRELATION COEFFICIENT  **
C               ************************************************
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      AN=N
C
      IF(1.LE.N.AND.N.LE.IUPPER)GOTO119
      IERROR='YES'
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,111)
  111 FORMAT('***** ERROR IN NORPPC--')
      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 NORMAL PROBABILITY PLOT')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,115)
  115 FORMAT('      CORRELATION COEFFICIENT IS TO BE COMPUTED')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,116)IUPPER
  116 FORMAT('      MUST BE BETWEEN 1 AND ',I8,' (INCLUSIVELY).')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,117)
  117 FORMAT('      SUCH WAS NOT THE CASE HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,118)N
  118 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8,
     1'.')
      CALL DPWRST('XXX','BUG ')
      GOTO9000
  119 CONTINUE
C
      IF(N.EQ.1)GOTO120
      GOTO129
  120 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,121)
  121 FORMAT('***** NON-FATAL DIAGNOSTIC IN NORPPC--',
     1'THE 2ND INPUT ARGUMENT (N) HAS THE VALUE 1')
      CALL DPWRST('XXX','BUG ')
      PPCC=0.0
      GOTO9000
  129 CONTINUE
C
      HOLD=X(1)
      DO135I=2,N
      IF(X(I).NE.HOLD)GOTO139
  135 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,136)HOLD
  136 FORMAT('***** NON-FATAL DIAGNOSTIC IN NORPPC--',
     1'THE FIRST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      PPCC=0.0
      GOTO9000
  139 CONTINUE
C
  190 CONTINUE
C
C               *************************************************
C               **  STEP 2--                                   **
C               **  COMPUTE THE NORMAL                         **
C               **  PROBABILITY PLOT CORRELATION COEFFICIENT.  **
C               *************************************************
C
      CALL SORT(X,N,Y)
C
      CALL UNIMED(N,W)
C
      DO200I=1,N
      CALL NORPPF(W(I),WOUT)
      W(I)=WOUT
  200 CONTINUE
C
      SUM1=0.0
      DO300I=1,N
      SUM1=SUM1+Y(I)
  300 CONTINUE
      YBAR=SUM1/AN
      WBAR=0.0
C
      SUM1=0.0
      SUM2=0.0
      SUM3=0.0
      DO400I=1,N
      SUM1=SUM1+(Y(I)-YBAR)*(Y(I)-YBAR)
      SUM2=SUM2+(W(I)-WBAR)*(Y(I)-YBAR)
      SUM3=SUM3+(W(I)-WBAR)*(W(I)-WBAR)
  400 CONTINUE
      PPCC=SUM2/SQRT(SUM3*SUM1)
C
C               *******************************
C               **  STEP 3--                 **
C               **  WRITE OUT A LINE         **
C               **  OF SUMMARY INFORMATION.  **
C               *******************************
C
      IF(IFEEDB.EQ.'OFF')GOTO890
      IF(IWRITE.EQ.'OFF')GOTO890
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,811)
  811 FORMAT('THE NORMAL PROBABILITY PLOT CORRELATION COEFFICIENT')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,812)N,PPCC
  812 FORMAT('OF THE ',I8,' OBSERVATIONS = ',E15.7)
      CALL DPWRST('XXX','BUG ')
  890 CONTINUE
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'OFF')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF NORPPC--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IBUGA3,IERROR
 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)N
 9013 FORMAT('N = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9014)SUM1,SUM2,SUM3
 9014 FORMAT('SUM1,SUM2,SUM3 = ',3E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9015)PPCC
 9015 FORMAT('PPCC = ',E15.7)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE NODCDF(X,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE NORMAL (GAUSSIAN)
C              DISTRIBUTION WITH 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              THIS IS THE DOUBLE PRECISION VERSION.
C     INPUT  ARGUMENTS--X      = THE DOUBLE PRECISION VALUE AT
C                                WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C     OUTPUT ARGUMENTS--CDF    = THE DOUBLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE CDF.
C     PRINTING--NONE.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--ALNORM.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--EXP.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--NATIONAL BUREAU OF STANDARDS APPLIED MATHEMATICS
C                 SERIES 55, 1964, PAGE 932, FORMULA 26.2.17.
C               --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1970, PAGES 40-111.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--97.8
C     ORIGINAL VERSION--AUGUST    1997.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DOUBLE PRECISION X
      DOUBLE PRECISION CDF
      DOUBLE PRECISION ALNORM
      LOGICAL UPPER
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
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(X.LT.0.0D0)THEN
        UPPER=.FALSE.
        CDF=ALNORM(X,UPPER)
      ELSEIF(X.GT.0.0D0)THEN
        UPPER=.TRUE.
        CDF=1.0D0 - ALNORM(X,UPPER)
      ELSE
        CDF=0.5D0
      ENDIF
C
      RETURN
      END
      SUBROUTINE NODPDF(Z, PDF)
CCCCC SUBROUTINE NODPDF(Z, P, Q, PDF)
C
C      Normal distribution probabilities accurate to 1.e-15.
C      Z = no. of standard deviations from the mean.
C      P, Q = probabilities to the left & right of Z.   P + Q = 1.
C       PDF = the probability density.
C
C       Based upon algorithm 5666 for the error function, from:
C       Hart, J.F. et al, 'Computer Approximations', Wiley 1968
C
C       Programmer: Alan Miller
C
C      Latest revision - 30 March 1986
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      DATA P0, P1, P2, P3, P4, P5, P6/220.20 68679 12376 1D0,
     *        221.21 35961 69931 1D0, 112.07 92914 97870 9D0,
     *        33.912 86607 83830 0D0, 6.3739 62203 53165 0D0,
     *        .70038 30644 43688 1D0, .35262 49659 98910 9D-01/,
     *        Q0, Q1, Q2, Q3, Q4, Q5, Q6, Q7/440.41 37358 24752 2D0,
     *        793.82 65125 19948 4D0, 637.33 36333 78831 1D0,
     *        296.56 42487 79673 7D0, 86.780 73220 29460 8D0,
     *        16.064 17757 92069 5D0, 1.7556 67163 18264 2D0,
     *        .88388 34764 83184 4D-1/,
     *        CUTOFF/7.071D0/, ROOT2PI/2.5066 28274 63100 1D0/
C
      ZABS = ABS(Z)
C
C      |Z| > 37.
C
      IF (ZABS .GT. 37.D0) THEN
        PDF = 0.D0
        IF (Z .GT. 0.D0) THEN
          P = 1.D0
          Q = 0.D0
        ELSE
          P = 0.D0
          Q = 1.D0
        END IF
        RETURN
      END IF
C
C      |Z| <= 37.
C
      EXPNTL = EXP(-0.5D0*ZABS**2)
      PDF = EXPNTL/ROOT2PI
C
C      |Z| < CUTOFF = 10/sqrt(2).
C
      IF (ZABS .LT. CUTOFF) THEN
        P = EXPNTL*((((((P6*ZABS + P5)*ZABS + P4)*ZABS + P3)*ZABS +
     *        P2)*ZABS + P1)*ZABS + P0)/(((((((Q7*ZABS + Q6)*ZABS +
     *        Q5)*ZABS + Q4)*ZABS + Q3)*ZABS + Q2)*ZABS + Q1)*ZABS +
     *        Q0)
C
C      |Z| >= CUTOFF.
C
      ELSE
        P = PDF/(ZABS + 1.D0/(ZABS + 2.D0/(ZABS + 3.D0/(ZABS + 4.D0/
     *        (ZABS + 0.65D0)))))
      END IF
C
      IF (Z .LT. 0.D0) THEN
        Q = 1.D0 - P
      ELSE
        Q = P
        P = 1.D0 - Q
      END IF
      RETURN
      END
      SUBROUTINE NODPPF(P,PPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES
C              THE PERCENT POINT
C              FUNCTION VALUE FOR THE NORMAL (GAUSSIAN)
C              DISTRIBUTION WITH 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              NOTE THAT THE PERCENT POINT FUNCTION OF A DISTRIBUTION
C              IS IDENTICALLY THE SAME AS THE INVERSE CUMULATIVE
C              DISTRIBUTION FUNCTION OF THE DISTRIBUTION.
C     NOTE--THIS ROUTINE IS IDENTICAL IN LOGIC TO NORPPF
C           EXCEPT NORPPF HAS INTERNAL CALUCLATIONS
C           IN SINGLE PRECISION,
C           WHILE NODPPF HAS INTERNAL CALUCLATIONS
C           IN DOUBLE PRECISION.
C     INPUT  ARGUMENTS--P      = THE SINGLE PRECISION VALUE
C                                (BETWEEN 0.0 AND 1.0)
C                                AT WHICH THE PERCENT POINT
C                                FUNCTION IS TO BE EVALUATED.
C     OUTPUT ARGUMENTS--PPF    = THE SINGLE PRECISION PERCENT
C                                POINT FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PERCENT POINT
C             FUNCTION VALUE PPF.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--P SHOULD BE BETWEEN 0.0 AND 1.0, EXCLUSIVELY.
C
C      ALGORITHM AS241  APPL. STATIST. (1988) VOL. 37, NO. 3
C
C      Produces the normal deviate Z corresponding to a given lower
C      tail area of P; Z is accurate to about 1 part in 10**16.
C
C      The hash sums below are the sums of the mantissas of the
C      coefficients.   They are included for use in checking
C      transcription.
C
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C     VERSION NUMBER--95.7
C     ORIGINAL VERSION--JULY      1995.
C     UPDATED         --AUGUST    1997. REPLACE CURRENT ALGORITHM WITH
C                                       AS 243 (HAS HIGHER ACCURACY)
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION P
      DOUBLE PRECISION PPF
      DOUBLE PRECISION ZERO, ONE, HALF, SPLIT1, SPLIT2, CONST1,
     *        CONST2, A0, A1,  A2, A3, A4, A5, A6, A7, B1, B2, B3,
     *          B4, B5, B6, B7,
     *        C0, C1, C2, C3, C4, C5, C6, C7,  D1, D2, D3, D4, D5,
     *        D6, D7, E0, E1, E2, E3, E4, E5, E6, E7, F1, F2, F3,
     *        F4, F5, F6, F7, Q, R
      PARAMETER (ZERO = 0.D0, ONE = 1.D0, HALF = 0.5D0,
     *        SPLIT1 = 0.425D0, SPLIT2 = 5.D0,
     *        CONST1 = 0.180625D0, CONST2 = 1.6D0)
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C      Coefficients for P close to 0.5
C
      PARAMETER (A0 = 3.38713 28727 96366 6080D0,
     *           A1 = 1.33141 66789 17843 7745D+2,
     *           A2 = 1.97159 09503 06551 4427D+3,
     *           A3 = 1.37316 93765 50946 1125D+4,
     *           A4 = 4.59219 53931 54987 1457D+4,
     *           A5 = 6.72657 70927 00870 0853D+4,
     *           A6 = 3.34305 75583 58812 8105D+4,
     *           A7 = 2.50908 09287 30122 6727D+3,
     *           B1 = 4.23133 30701 60091 1252D+1,
     *           B2 = 6.87187 00749 20579 0830D+2,
     *           B3 = 5.39419 60214 24751 1077D+3,
     *           B4 = 2.12137 94301 58659 5867D+4,
     *           B5 = 3.93078 95800 09271 0610D+4,
     *           B6 = 2.87290 85735 72194 2674D+4,
     *           B7 = 5.22649 52788 52854 5610D+3)
C      HASH SUM AB    55.88319 28806 14901 4439
C
C      Coefficients for P not close to 0, 0.5 or 1.
C
      PARAMETER (C0 = 1.42343 71107 49683 57734D0,
     *           C1 = 4.63033 78461 56545 29590D0,
     *           C2 = 5.76949 72214 60691 40550D0,
     *           C3 = 3.64784 83247 63204 60504D0,
     *           C4 = 1.27045 82524 52368 38258D0,
     *           C5 = 2.41780 72517 74506 11770D-1,
     *             C6 = 2.27238 44989 26918 45833D-2,
     *           C7 = 7.74545 01427 83414 07640D-4,
     *           D1 = 2.05319 16266 37758 82187D0,
     *           D2 = 1.67638 48301 83803 84940D0,
     *           D3 = 6.89767 33498 51000 04550D-1,
     *           D4 = 1.48103 97642 74800 74590D-1,
     *           D5 = 1.51986 66563 61645 71966D-2,
     *           D6 = 5.47593 80849 95344 94600D-4,
     *           D7 = 1.05075 00716 44416 84324D-9)
C      HASH SUM CD    49.33206 50330 16102 89036
C
C      Coefficients for P near 0 or 1.
C
      PARAMETER (E0 = 6.65790 46435 01103 77720D0,
     *           E1 = 5.46378 49111 64114 36990D0,
     *           E2 = 1.78482 65399 17291 33580D0,
     *           E3 = 2.96560 57182 85048 91230D-1,
     *           E4 = 2.65321 89526 57612 30930D-2,
     *           E5 = 1.24266 09473 88078 43860D-3,
     *           E6 = 2.71155 55687 43487 57815D-5,
     *           E7 = 2.01033 43992 92288 13265D-7,
     *           F1 = 5.99832 20655 58879 37690D-1,
     *           F2 = 1.36929 88092 27358 05310D-1,
     *           F3 = 1.48753 61290 85061 48525D-2,
     *           F4 = 7.86869 13114 56132 59100D-4,
     *           F5 = 1.84631 83175 10054 68180D-5,
     *           F6 = 1.42151 17583 16445 88870D-7,
     *           F7 = 2.04426 31033 89939 78564D-15)
C      HASH SUM EF    47.52583 31754 92896 71629
C
C-----START POINT-----------------------------------------------------
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      PPF=0.0D0
      IF(P.LE.0.0D0.OR.P.GE.1.0D0)GOTO50
      GOTO90
   50 WRITE(ICOUT,1)
    1 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ',
     1'NODPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)P
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',D15.7,'*****')
      CALL DPWRST('XXX','BUG ')
      GOTO9000
   90 CONTINUE
C
C               ************************************************
C               **  STEP 2--                                  **
C               **  COMPUTE THE PERCENT POINT FUNCTION VALUE  **
C               ************************************************
C
      IF(P.EQ.0.5D0)THEN
        PPF=0.0D0
        GOTO9000
      ENDIF
C
      Q = P - HALF
      IF (ABS(Q) .LE. SPLIT1) THEN
        R = CONST1 - Q * Q
        PPF = Q * (((((((A7 * R + A6) * R + A5) * R + A4) * R + A3)
     *          * R + A2) * R + A1) * R + A0) /
     *              (((((((B7 * R + B6) * R + B5) * R + B4) * R + B3)
     *          * R + B2) * R + B1) * R + ONE)
        RETURN
      ELSE
        IF (Q .LT. ZERO) THEN
          R = P
        ELSE
          R = ONE - P
        END IF
        IF (R .LE. ZERO) THEN
          WRITE(ICOUT,47)
          CALL DPWRST('XXX','BUG ')
          PPF = ZERO
          RETURN
        END IF
   47 FORMAT('***** INTERNAL ERROR FROM NODPPF ******')
        R = SQRT(-LOG(R))
        IF (R .LE. SPLIT2) THEN
          R = R - CONST2
          PPF = (((((((C7 * R + C6) * R + C5) * R + C4) * R + C3)
     *          * R + C2) * R + C1) * R + C0) /
     *             (((((((D7 * R + D6) * R + D5) * R + D4) * R + D3)
     *          * R + D2) * R + D1) * R + ONE)
        ELSE
          R = R - SPLIT2
          PPF = (((((((E7 * R + E6) * R + E5) * R + E4) * R + E3)
     *          * R + E2) * R + E1) * R + E0) /
     *             (((((((F7 * R + F6) * R + F5) * R + F4) * R + F3)
     *          * R + F2) * R + F1) * R + ONE)
        END IF
        IF (Q .LT. ZERO) PPF = - PPF
        RETURN
      END IF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE NORPPF(P,PPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE NORMAL (GAUSSIAN)
C              DISTRIBUTION WITH 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              NOTE THAT THE PERCENT POINT FUNCTION OF A DISTRIBUTION
C              IS IDENTICALLY THE SAME AS THE INVERSE CUMULATIVE
C              DISTRIBUTION FUNCTION OF THE DISTRIBUTION.
C     INPUT  ARGUMENTS--P      = THE SINGLE PRECISION VALUE
C                                (BETWEEN 0.0 AND 1.0)
C                                AT WHICH THE PERCENT POINT
C                                FUNCTION IS TO BE EVALUATED.
C     OUTPUT ARGUMENTS--PPF    = THE SINGLE PRECISION PERCENT
C                                POINT FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PERCENT POINT
C             FUNCTION VALUE PPF.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--P SHOULD BE BETWEEN 0.0 AND 1.0, EXCLUSIVELY.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--SQRT, ALOG.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--ODEH AND EVANS, THE PERCENTAGE POINTS
C                 OF THE NORMAL DISTRIBUTION, ALGORTIHM 70,
C                 APPLIED STATISTICS, 1974, PAGES 96-97.
C               --EVANS, ALGORITHMS FOR MINIMAL DEGREE
C                 POLYNOMIAL AND RATIONAL APPROXIMATION,
C                 M. SC. THESIS, 1972, UNIVERSITY
C                 OF VICTORIA, B. C., CANADA.
C               --HASTINGS, APPROXIMATIONS FOR DIGITAL
C                 COMPUTERS, 1955, PAGES 113, 191, 192.
C               --NATIONAL BUREAU OF STANDARDS APPLIED MATHEMATICS
C                 SERIES 55, 1964, PAGE 933, FORMULA 26.2.23.
C               --FILLIBEN, SIMPLE AND ROBUST LINEAR ESTIMATION
C                 OF THE LOCATION PARAMETER OF A SYMMETRIC
C                 DISTRIBUTION (UNPUBLISHED PH.D. DISSERTATION,
C                 PRINCETON UNIVERSITY), 1969, PAGES 21-44, 229-231.
C               --FILLIBEN, 'THE PERCENT POINT FUNCTION',
C                 (UNPUBLISHED MANUSCRIPT), 1970, PAGES 28-31.
C               --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1970, PAGES 40-111.
C               --THE KELLEY STATISTICAL TABLES, 1948.
C               --OWEN, HANDBOOK OF STATISTICAL TABLES,
C                 1962, PAGES 3-16.
C               --PEARSON AND HARTLEY, BIOMETRIKA TABLES
C                 FOR STATISTICIANS, VOLUME 1, 1954,
C                 PAGES 104-113.
C     COMMENTS--THE CODING AS PRESENTED BELOW
C               IS ESSENTIALLY IDENTICAL TO THAT
C               PRESENTED BY ODEH AND EVANS
C               AS ALGORTIHM 70 OF APPLIED STATISTICS.
C               THE PRESENT AUTHOR HAS MODIFIED THE
C               ORIGINAL ODEH AND EVANS CODE WITH ONLY
C               MINOR STYLISTIC CHANGES.
C             --AS POINTED OUT BY ODEH AND EVANS
C               IN APPLIED STATISTICS,
C               THEIR ALGORITHM REPRESENTES A
C               SUBSTANTIAL IMPROVEMENT OVER THE
C               PREVIOUSLY EMPLOYED
C               HASTINGS APPROXIMATION FOR THE
C               NORMAL PERCENT POINT FUNCTION--
C               THE ACCURACY OF APPROXIMATION
C               BEING IMPROVED FROM 4.5*(10**-4)
C               TO 1.5*(10**-8).
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--82.6
C     ORIGINAL VERSION--JUNE      1972.
C     UPDATED         --SEPTEMBER 1975.
C     UPDATED         --NOVEMBER  1975.
C     UPDATED         --OCTOBER   1976.
C     UPDATED         --MAY       1982.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----DATA STATEMENTS-------------------------------------------------
C
      DATA P0,P1,P2,P3,P4
     1/-.322232431088,-1.0,
     1 -.342242088547,-.204231210245E-1,
     1 -.453642210148E-4/
      DATA Q0,Q1,Q2,Q3,Q4
     1/.993484626060E-1,.588581570495,
     1 .531103462366,.103537752850,
     1 .38560700634E-2/
C
C-----START POINT-----------------------------------------------------
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      IF(P.LE.0.0.OR.P.GE.1.0)GOTO50
      GOTO90
   50 WRITE(ICOUT,1)
    1 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ',
     1'NORPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)P
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,'*****')
      CALL DPWRST('XXX','BUG ')
      GOTO9000
   90 CONTINUE
C
C               ************************************************
C               **  STEP 2--                                  **
C               **  COMPUTE THE PERCENT POINT FUNCTION VALUE  **
C               ************************************************
C
      IF(P.EQ.0.5)GOTO120
      GOTO129
  120 CONTINUE
      PPF=0.0
      GOTO9000
  129 CONTINUE
C
      PHOLD=P
      R=P
      IF(PHOLD.GT.0.5)R=1.0-R
      T=SQRT(-2.0*ALOG(R))
      ANUM=((((T*P4+P3)*T+P2)*T+P1)*T+P0)
      ADEN=((((T*Q4+Q3)*T+Q2)*T+Q1)*T+Q0)
      PPF=T+(ANUM/ADEN)
      IF(PHOLD.LT.0.5)PPF=-PPF
      GOTO9000
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE NORRAN(N,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE THE NORMAL (GAUSSIAN)
C              DISTRIBUTION WITH 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     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 NORMAL DISTRIBUTION
C             WITH MEAN = 0 AND STANDARD DEVIATION = 1.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--ALOG, SQRT, SIN, COS.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     METHOD--BOX-MULLER ALGORITHM.
C     REFERENCES--BOX AND MULLER, 'A NOTE ON THE GENERATION
C                 OF RANDOM NORMAL DEVIATES', JOURNAL OF THE
C                 ASSOCIATION FOR COMPUTING MACHINERY, 1958,
C                 PAGES 610-611.
C               --TOCHER, THE ART OF SIMULATION,
C                 1963, PAGES 33-34.
C               --HAMMERSLEY AND HANDSCOMB, MONTE CARLO METHODS,
C                 1964, PAGE 39.
C               --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1970, PAGES 40-111.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (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         --JULY      1976.
C     UPDATED         --DECEMBER  1981.
C     UPDATED         --MAY       1982.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
      DIMENSION Y(2)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----DATA STATEMENTS-------------------------------------------------
C
      DATA PI/3.14159265359/
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)GOTO50
      GOTO90
   50 WRITE(ICOUT, 5)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,47)N
      CALL DPWRST('XXX','BUG ')
      RETURN
   90 CONTINUE
    5 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ',
     1'NORRAN SUBROUTINE IS NON-POSITIVE *****')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
C
C     GENERATE N UNIFORM (0,1) RANDOM NUMBERS;
C     THEN GENERATE 2 ADDITIONAL UNIFORM (0,1) RANDOM NUMBERS
C     (TO BE USED BELOW IN FORMING THE N-TH NORMAL
C     RANDOM NUMBER WHEN THE DESIRED SAMPLE SIZE N
C     HAPPENS TO BE ODD).
C
      CALL UNIRAN(N,ISEED,X)
      CALL UNIRAN(2,ISEED,Y)
C
C     GENERATE N NORMAL RANDOM NUMBERS
C     USING THE BOX-MULLER METHOD.
C
      DO200I=1,N,2
      IP1=I+1
      U1=X(I)
      IF(I.EQ.N)GOTO210
      U2=X(IP1)
      GOTO220
  210 U2=Y(2)
  220 ARG1=-2.0*ALOG(U1)
      ARG2=2.0*PI*U2
      SQRT1=SQRT(ARG1)
      Z1=SQRT1*COS(ARG2)
      Z2=SQRT1*SIN(ARG2)
      X(I)=Z1
      IF(I.EQ.N)GOTO200
      X(IP1)=Z2
  200 CONTINUE
C
      RETURN
      END
      SUBROUTINE NORSF(P,SF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE SPARSITY
C              FUNCTION VALUE FOR THE NORMAL (GAUSSIAN)
C              DISTRIBUTION WITH 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              NOTE THAT THE SPARSITY FUNCTION OF A DISTRIBUTION
C              IS THE DERIVATIVE OF THE PERCENT POINT FUNCTION,
C              AND ALSO IS THE RECIPROCAL OF THE PROBABILITY
C              DENSITY FUNCTION (BUT IN UNITS OF P RATHER THAN X).
C     INPUT  ARGUMENTS--P      = THE SINGLE PRECISION VALUE 
C                                (BETWEEN 0.0 AND 1.0)
C                                AT WHICH THE SPARSITY
C                                FUNCTION IS TO BE EVALUATED.
C     OUTPUT ARGUMENTS--SF     = THE SINGLE PRECISION
C                                SPARSITY FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION SPARSITY
C             FUNCTION VALUE SF.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 
C     RESTRICTIONS--P SHOULD BE BETWEEN 0.0 AND 1.0, EXCLUSIVELY.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NORPPF. 
C     FORTRAN LIBRARY SUBROUTINES NEEDED--EXP.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN. 
C     REFERENCES--FILLIBEN, SIMPLE AND ROBUST LINEAR ESTIMATION
C                 OF THE LOCATION PARAMETER OF A SYMMETRIC
C                 DISTRIBUTION (UNPUBLISHED PH.D. DISSERTATION,
C                 PRINCETON UNIVERSITY), 1969, PAGES 21-44, 229-231.
C               --FILLIBEN, 'THE PERCENT POINT FUNCTION',
C                 (UNPUBLISHED MANUSCRIPT), 1970, PAGES 28-31.
C               --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1970, PAGES 40-111.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE:  301-921-2315
C     ORIGINAL VERSION--APRIL     1994. 
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C---------------------------------------------------------------------
C
      DATA C/.3989422804/
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(P.LE.0.0.OR.P.GE.1.0)GOTO50
      GOTO90
   50 CONTINUE
      WRITE(ICOUT,1)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)P
      CALL DPWRST('XXX','BUG ')
      RETURN
   90 CONTINUE
    1 FORMAT(
     1'***** FATAL ERROR--THE FIRST  INPUT ARGUMENT TO THE NORSF')
    2 FORMAT(
     1'SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
C-----START POINT-----------------------------------------------------
C
      CALL NORPPF(P,PPF)
      PDF=C*EXP(-(PPF*PPF)/2.0)
      SF=1.0/PDF
C
      RETURN
      END 
      SUBROUTINE NRMLAG(X,AN,ALN)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE NORMALIZED LAGUERRE
C              POLYNOMIAL OF ORDER N.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION INPUT ARGUMENT
C                       AN     = THE SINGLE PRECISION VALUE FOR THE
C                                ORDER OF THE FUNCTION (SHOULD BE
C                                NON-NEGATIVE ORDER)
C     OUTPUT ARGUMENTS--ALN    = THE SINGLE PRECISION VALUE OF THE
C                                NORMALIZED LAGUERRE POLYNOMIAL.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 
C     RESTRICTIONS--
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE
C     MODE OF INTERNAL OPERATIONS--SOME DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN. 
C     REFERENCES--"HANDBOOK OF MATHEMATICAL FUNCTIONS, AMS 55", 
C                 ABRAMOWITZ AND STEGUM.
C                 USE FOLLOWING RECURRENCE FORMULA:
C                    L(N+1) = (1+2*N-X)*L(N)-N**2*L(N-1)
C                 FIRST FEW TERMS ARE FROM TABLE 22.10 OF ABRAMOWITZ
C                 AND STEGUM.
C                 NORMALIZED LAGUERRE IS LAGUERRE SCALED BY N!
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE:  301-975-2855
C     ORIGINAL VERSION--JULY       1995. 
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 ICOUTINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,ICOUTINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DN, DN2
      DOUBLE PRECISION DLN, DLN1, DLN2
C
C-----START POINT-----------------------------------------------------
C
      IF(X.LT.0.0)THEN
        WRITE(ICOUT,4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
    4 FORMAT('***** NON-FATAL DIAGNOSTIC--THE 1ST INPUT ARGUMENT ',
     1'TO THE NRMLAG SUBROUTINE IS NEGATIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
      N=INT(AN+0.5)
      IF(N.LT.0)THEN
        WRITE(ICOUT,6)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
    6 FORMAT('***** NON-FATAL DIAGNOSTIC--THE 2ND INPUT ARGUMENT ',
     1'TO THE NRMLAGRRE SUBROUTINE IS NEGATIVE *****')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
C
      DX=DBLE(X)
      DN=DBLE(N)
C
      IF(N.LE.0)THEN
        ALN=1.0
      ELSEIF(N.EQ.1)THEN
        ALN=-X+1.0
      ELSEIF(N.EQ.2)THEN
        ALN=X**2 - 4.0*X + 2.0
      ELSEIF(N.EQ.3)THEN
        DLN=-DX**3 + 9.0D0*DX**2 -18.0D0*DX + 6.0D0
        ALN=REAL(DLN)
      ELSE
        DLN1=-DX**3 + 9.0D0*DX**2 -18.0D0*DX + 6.0D0
        DLN2=DX**2 - 4.0D0*DX + 2.0D0
        DO1000I=4,N
          DN2=DBLE(I)-1.0D0
          DLN=(1.0D0+2.0D0*DN2-DX)*DLN1 - DN2**2*DLN2
          DLN2=DLN1
          DLN1=DLN
 1000   CONTINUE
        ALN=REAL(DLN)
      ENDIF
C
 9999 CONTINUE
      RETURN
      END 
      subroutine onestp(y,n,np,ns,nt,nl,isdeg,itdeg,ildeg,nsjump,ntjump,
     &nljump,ni,userw,rw,season,trend,work)
c
c  This routine is part of the Bill Cleveland seasonal loess
c  program.
c
      integer n,ni,np,ns,nt,nsjump,ntjump,nl,nljump,isdeg,itdeg,ildeg
      real y(n),rw(n),season(n),trend(n),work(n+2*np,5)
      logical userw
      do 23089 j = 1,ni 
      do 23091 i = 1,n
      work(i,1) = y(i)-trend(i)
23091 continue
      call ss(work(1,1),n,np,ns,isdeg,nsjump,userw,rw,work(1,2),work(1,
     &3),work(1,4),work(1,5),season)
      call fts(work(1,2),n+2*np,np,work(1,3),work(1,1))
      call ess(work(1,3),n,nl,ildeg,nljump,.false.,work(1,4),work(1,1),
     &work(1,5))
      do 23093 i = 1,n
      season(i) = work(np+i,2)-work(i,1)
23093 continue
      do 23095 i = 1,n
      work(i,1) = y(i)-season(i)
23095 continue
      call ess(work(1,1),n,nt,itdeg,ntjump,userw,rw,trend,work(1,3))
23089 continue
      return
      end
      SUBROUTINE OPTCHK(N,X,TYPSIZ,SX,FSCALE,GRADTL,ITNLIM,NDIGIT,EPSM,
     +     DLT,METHOD,IEXP,IAGFLG,IAHFLG,STEPMX,MSG,IPRTMP)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C PURPOSE
C -------
C CHECK INPUT FOR REASONABLENESS
C
C PARAMETERS
C ----------
C N            --> DIMENSION OF PROBLEM
C X(N)         --> ON ENTRY, ESTIMATE TO ROOT OF FCN
C TYPSIZ(N)   <--> TYPICAL SIZE OF EACH COMPONENT OF X
C SX(N)       <--  DIAGONAL SCALING MATRIX FOR X
C FSCALE      <--> ESTIMATE OF SCALE OF OBJECTIVE FUNCTION FCN
C GRADTL       --> TOLERANCE AT WHICH GRADIENT CONSIDERED CLOSE
C                  ENOUGH TO ZERO TO TERMINATE ALGORITHM
C ITNLIM      <--> MAXIMUM NUMBER OF ALLOWABLE ITERATIONS
C NDIGIT      <--> NUMBER OF GOOD DIGITS IN OPTIMIZATION FUNCTION FCN
C EPSM         --> MACHINE EPSILON
C DLT         <--> TRUST REGION RADIUS
C METHOD      <--> ALGORITHM INDICATOR
C IEXP        <--> EXPENSE FLAG
C IAGFLG      <--> =1 IF ANALYTIC GRADIENT SUPPLIED
C IAHFLG      <--> =1 IF ANALYTIC HESSIAN SUPPLIED
C STEPMX      <--> MAXIMUM STEP SIZE
C MSG         <--> MESSAGE AND ERROR CODE
C IPR          --> DEVICE TO WHICH TO SEND OUTPUT
C
      DIMENSION X(N),TYPSIZ(N),SX(N)
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
      REAL CPUMIN, CPUMAX
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 CHECK THAT PARAMETERS ONLY TAKE ON ACCEPTABLE VALUES.
C IF NOT, SET THEM TO DEFAULT VALUES.
      IF(METHOD.LT.1 .OR. METHOD.GT.3) METHOD=1
      IF(IAGFLG.NE.1) IAGFLG=0
      IF(IAHFLG.NE.1) IAHFLG=0
      IF(IEXP.NE.0) IEXP=1
      IF(MOD(MSG/2,2).EQ.1 .AND. IAGFLG.EQ.0) GO TO 830
      IF(MOD(MSG/4,2).EQ.1 .AND. IAHFLG.EQ.0) GO TO 835
C
C CHECK DIMENSION OF PROBLEM
C
      IF(N.LE.0) GO TO 805
      IF(N.EQ.1 .AND. MOD(MSG,2).EQ.0) GO TO 810
C
C COMPUTE SCALE MATRIX
C
      DO 10 I=1,N
        IF(TYPSIZ(I).EQ.0.) TYPSIZ(I)=1.0
        IF(TYPSIZ(I).LT.0.) TYPSIZ(I)=-TYPSIZ(I)
        SX(I)=1.0/TYPSIZ(I)
   10 CONTINUE
C
C CHECK MAXIMUM STEP SIZE
C
      IF (STEPMX .GT. 0.0) GO TO 20
      STPSIZ = 0.0
      DO 15 I = 1, N
         STPSIZ = STPSIZ + X(I)*X(I)*SX(I)*SX(I)
   15 CONTINUE
      STPSIZ = SQRT(STPSIZ)
      STEPMX = MAX(1.0E3*STPSIZ, 1.0D3)
   20 CONTINUE
C CHECK FUNCTION SCALE
      IF(FSCALE.EQ.0.) FSCALE=1.0
      IF(FSCALE.LT.0.) FSCALE=-FSCALE
C
C CHECK GRADIENT TOLERANCE
      IF(GRADTL.LT.0.) GO TO 815
C
C CHECK ITERATION LIMIT
      IF(ITNLIM.LE.0) GO TO 820
C
C CHECK NUMBER OF DIGITS OF ACCURACY IN FUNCTION FCN
      IF(NDIGIT.EQ.0) GO TO 825
      IF(NDIGIT.LT.0) NDIGIT=-LOG10(EPSM)
C
C CHECK TRUST REGION RADIUS
      IF(DLT.LE.0.) DLT=-1.0
      IF (DLT .GT. STEPMX) DLT = STEPMX
      RETURN
C
C ERROR EXITS
C
  805 WRITE(ICOUT,901) N
      CALL DPWRST('XXX','BUG ')
      MSG=-1
      GO TO 895
  810 WRITE(ICOUT,902)
      CALL DPWRST('XXX','BUG ')
      MSG=-2
      GO TO 895
  815 WRITE(ICOUT,903) GRADTL
      CALL DPWRST('XXX','BUG ')
      MSG=-3
      GO TO 895
  820 WRITE(ICOUT,904) ITNLIM
      CALL DPWRST('XXX','BUG ')
      MSG=-4
      GO TO 895
  825 WRITE(ICOUT,905) NDIGIT
      CALL DPWRST('XXX','BUG ')
      MSG=-5
      GO TO 895
  830 WRITE(ICOUT,906) MSG
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,916)IAGFLG
      CALL DPWRST('XXX','BUG ')
      MSG=-6
      GO TO 895
  835 WRITE(ICOUT,907) MSG
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,917)IAHFLG
      CALL DPWRST('XXX','BUG ')
      MSG=-7
  895 RETURN
  901 FORMAT('***** FROM OPTCHK    ILLEGAL DIMENSION, N =',I5)
  902 FORMAT(
     +'***** FROM OPTCHK    +++ WARNING +++  THIS PACKAGE IS ',
     +'INEFFICIENT FOR PROBLEMS OF SIZE N=1.')
  903 FORMAT(
     +'***** FROM OPTCHK    ILLEGAL TOLERANCE.  GRADTL = ',E20.13)
  904 FORMAT(
     +'***** FROM OPTCHK    ILLEGAL ITERATION LIMIT.  ITNLIM = ',I5)
  905 FORMAT(
     +'***** FROM OPTCHK    MINIMIZATION FUNCTION HAS NO GOOD DIGITS.'
     +,'  NDIGIT = ',I5)
  906 FORMAT(
     +'***** FROM OPTCHK    USER REQUESTS THAT ANALYTIC GRADIENT BE',
     +' ACCEPTED AS PROPERLY CODED (MSG =',I5)
  916 FORMAT(
     +'                     BUT ANALYTIC GRADIENT NOT SUPPLIED',
     +'(IAGFLG = ',I5,'.')
  907 FORMAT(
     +'***** FROM OPTCHK    USER REQUESTS THAT ANALYTIC HESSIAN BE',
     +' ACCEPTED AS PROPERLY CODED (MSG =',I5)
  917 FORMAT(
     +'                     BUT ANALYTIC HESSIAN NOT SUPPLIED',
     +'(IAHFLG = ',I5,'.')
      END
      SUBROUTINE OPTDRV(NR,N,X,TYPSIZ,FSCALE,
CDPLT SUBROUTINE OPTDRV(NR,N,X,FCN,D1FCN,D2FCN,TYPSIZ,FSCALE,
CDPLT+     METHOD,IEXP,MSG,NDIGIT,ITNLIM,IAGFLG,IAHFLG,IPR,
     +     METHOD,IEXP,MSG,NDIGIT,ITNLIM,IAGFLG,IAHFLG,IPR2,
     +     DLT,GRADTL,STEPMX,STEPTL,
     +     XPLS,FPLS,GPLS,ITRMCD,
     +     A,UDIAG,G,P,SX,WRK0,WRK1,WRK2,WRK3)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C PURPOSE
C -------
C DRIVER FOR NON-LINEAR OPTIMIZATION PROBLEM
C
C PARAMETERS
C ----------
C NR           --> ROW DIMENSION OF MATRIX
C N            --> DIMENSION OF PROBLEM
C X(N)         --> ON ENTRY: ESTIMATE TO A ROOT OF FCN
C FCN          --> NAME OF SUBROUTINE TO EVALUATE OPTIMIZATION FUNCTION
C                  MUST BE DECLARED EXTERNAL IN CALLING ROUTINE
C                            FCN: R(N) --> R(1)
C D1FCN        --> (OPTIONAL) NAME OF SUBROUTINE TO EVALUATE GRADIENT
C                  OF FCN.  MUST BE DECLARED EXTERNAL IN CALLING ROUTINE
C D2FCN        --> (OPTIONAL) NAME OF SUBROUTINE TO EVALUATE HESSIAN OF
C                  OF FCN.  MUST BE DECLARED EXTERNAL IN CALLING ROUTINE
C TYPSIZ(N)    --> TYPICAL SIZE FOR EACH COMPONENT OF X
C FSCALE       --> ESTIMATE OF SCALE OF OBJECTIVE FUNCTION
C METHOD       --> ALGORITHM TO USE TO SOLVE MINIMIZATION PROBLEM
C                    =1 LINE SEARCH
C                    =2 DOUBLE DOGLEG
C                    =3 MORE-HEBDON
C IEXP         --> =1 IF OPTIMIZATION FUNCTION FCN IS EXPENSIVE TO
C                  EVALUATE, =0 OTHERWISE.  IF SET THEN HESSIAN WILL
C                  BE EVALUATED BY SECANT UPDATE INSTEAD OF
C                  ANALYTICALLY OR BY FINITE DIFFERENCES
C MSG         <--> ON INPUT:  (.GT.0) MESSAGE TO INHIBIT CERTAIN
C                    AUTOMATIC CHECKS
C                  ON OUTPUT: (.LT.0) ERROR CODE; =0 NO ERROR
C NDIGIT       --> NUMBER OF GOOD DIGITS IN OPTIMIZATION FUNCTION FCN
C ITNLIM       --> MAXIMUM NUMBER OF ALLOWABLE ITERATIONS
C IAGFLG       --> =1 IF ANALYTIC GRADIENT SUPPLIED
C IAHFLG       --> =1 IF ANALYTIC HESSIAN SUPPLIED
C IPR          --> DEVICE TO WHICH TO SEND OUTPUT
C DLT          --> TRUST REGION RADIUS
C GRADTL       --> TOLERANCE AT WHICH GRADIENT CONSIDERED CLOSE
C                  ENOUGH TO ZERO TO TERMINATE ALGORITHM
C STEPMX       --> MAXIMUM ALLOWABLE STEP SIZE
C STEPTL       --> RELATIVE STEP SIZE AT WHICH SUCCESSIVE ITERATES
C                  CONSIDERED CLOSE ENOUGH TO TERMINATE ALGORITHM
C XPLS(N)     <--> ON EXIT:  XPLS IS LOCAL MINIMUM
C FPLS        <--> ON EXIT:  FUNCTION VALUE AT SOLUTION, XPLS
C GPLS(N)     <--> ON EXIT:  GRADIENT AT SOLUTION XPLS
C ITRMCD      <--  TERMINATION CODE
C A(N,N)       --> WORKSPACE FOR HESSIAN (OR ESTIMATE)
C                  AND ITS CHOLESKY DECOMPOSITION
C UDIAG(N)     --> WORKSPACE [FOR DIAGONAL OF HESSIAN]
C G(N)         --> WORKSPACE (FOR GRADIENT AT CURRENT ITERATE)
C P(N)         --> WORKSPACE FOR STEP
C SX(N)        --> WORKSPACE (FOR DIAGONAL SCALING MATRIX)
C WRK0(N)      --> WORKSPACE
C WRK1(N)      --> WORKSPACE
C WRK2(N)      --> WORKSPACE
C WRK3(N)      --> WORKSPACE
C
C
C INTERNAL VARIABLES
C ------------------
C ANALTL           TOLERANCE FOR COMPARISON OF ESTIMATED AND
C                  ANALYTICAL GRADIENTS AND HESSIANS
C EPSM             MACHINE EPSILON
C F                FUNCTION VALUE: FCN(X)
C ITNCNT           CURRENT ITERATION, K
C RNF              RELATIVE NOISE IN OPTIMIZATION FUNCTION FCN.
C                       NOISE=10.**(-NDIGIT)
C
      DIMENSION X(N),XPLS(N),G(N),GPLS(N),P(N)
      DIMENSION TYPSIZ(N),SX(N)
      DIMENSION A(NR,1),UDIAG(N)
      DIMENSION WRK0(N),WRK1(N),WRK2(N),WRK3(N)
      LOGICAL MXTAKE,NOUPDT
CDPLT EXTERNAL FCN,D1FCN,D2FCN
CDPLT EXTERNAL OPTFCN
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
      INCLUDE 'DPCOF2.INC'
      REAL R1MACH
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
      REAL CPUMIN, CPUMAX
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 INITIALIZATION
C --------------
      DO 10 I=1,N
        P(I)=0.
   10 CONTINUE
      ITNCNT=0
      IRETCD=-1
CCCCC EPSM=D1MACH(4)
      EPSM=R1MACH(4)
      CALL OPTCHK(N,X,TYPSIZ,SX,FSCALE,GRADTL,ITNLIM,NDIGIT,EPSM,
     +     DLT,METHOD,IEXP,IAGFLG,IAHFLG,STEPMX,MSG,IPR2)
      IF(MSG.LT.0) RETURN
      RNF=MAX(10.0D0**(-NDIGIT),EPSM)
      ANALTL=MAX(1.0D-2,SQRT(RNF))
C
      IF(MOD(MSG/8,2).EQ.1) GO TO 15
      WRITE(ICOUT,901)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,900) (TYPSIZ(I),I=1,N)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,902)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,900) (SX(I),I=1,N)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,903) FSCALE
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,904) NDIGIT
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,914) IAGFLG
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,916)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,924) IAHFLG
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,926)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,934) IEXP
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,936) 
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,944) METHOD
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,946)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,954) ITNLIM
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,964) EPSM
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,905) STEPMX
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,915) STEPTL
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,925) GRADTL
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,935) DLT
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,945) RNF
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,955) ANALTL
      CALL DPWRST('XXX','BUG ')
   15 CONTINUE
C
C EVALUATE FCN(X)
C
      CALL OPTFCN(N,X,F)
C
C EVALUATE ANALYTIC OR FINITE DIFFERENCE GRADIENT AND CHECK ANALYTIC
C GRADIENT, IF REQUESTED.
C
      IF (IAGFLG .EQ. 1) GO TO 20
C     IF (IAGFLG .EQ. 0)
C     THEN
CCCCC   CALL FSTOFD (1, 1, N, X, OPTFCN, F, G, SX, RNF, WRK, 1)
        CALL FSTOFD (1, 1, N, X, F, G, SX, RNF, WRK, 1)
        GO TO 25
C
   20 CONTINUE
CDP20 CALL D1FCN (N, X, G)
CDPLT IF (MOD(MSG/2,2) .EQ. 1) GO TO 25
C     IF (MOD(MSG/2,2).EQ.0)
C     THEN
CDPLT   CALL GRDCHK (N, X, FCN, F, G, TYPSIZ, SX, FSCALE,
CDPLT1    RNF, ANALTL, WRK1, MSG, IPR)
CDPLT   IF (MSG .LT. 0) RETURN
   25 CONTINUE
C
      CALL OPTSTP(N,X,F,G,WRK1,ITNCNT,ICSCMX,
     +            ITRMCD,GRADTL,STEPTL,SX,FSCALE,ITNLIM,IRETCD,MXTAKE,
     +            IPR,MSG)
      IF(ITRMCD.NE.0) GO TO 700
C
      IF(IEXP.NE.1) GO TO 80
C
C IF OPTIMIZATION FUNCTION EXPENSIVE TO EVALUATE (IEXP=1), THEN
C HESSIAN WILL BE OBTAINED BY SECANT UPDATES.  GET INITIAL HESSIAN.
C
      CALL HSNINT(NR,N,A,SX,METHOD)
      GO TO 90
   80 CONTINUE
C
C EVALUATE ANALYTIC OR FINITE DIFFERENCE HESSIAN AND CHECK ANALYTIC
C HESSIAN IF REQUESTED (ONLY IF USER-SUPPLIED ANALYTIC HESSIAN
C ROUTINE D2FCN FILLS ONLY LOWER TRIANGULAR PART AND DIAGONAL OF A).
C
      IF (IAHFLG .EQ. 1) GO TO 82
C     IF (IAHFLG .EQ. 0)
C     THEN
CDPLT    IF (IAGFLG .EQ. 1) CALL FSTOFD (NR, N, N, X, D1FCN, G, A, SX,
CDPLT1      RNF, WRK1, 3)
CDPLT    IF (IAGFLG .NE. 1) CALL SNDOFD (NR, N, X, OPTFCN, F, A, SX, 
         IF (IAGFLG .NE. 1) CALL SNDOFD (NR, N, X, F, A, SX, 
     1      RNF, WRK1, WRK2)
         GO TO 88
C
C     ELSE
   82    CONTINUE
CDP82    IF (MOD(MSG/4,2).EQ.0) GO TO 85
C        IF (MOD(MSG/4, 2) .EQ. 1)
C        THEN
CDPLT       CALL D2FCN (NR, N, X, A)
CDPLT       GO TO 88
C
C        ELSE
CDP85       CALL HESCHK (NR, N, X, FCN, D1FCN, D2FCN, F, G, A, TYPSIZ,
CDPLT1         SX, RNF, ANALTL, IAGFLG, UDIAG, WRK1, WRK2, MSG, IPR)
C
C           HESCHK EVALUATES D2FCN AND CHECKS IT AGAINST THE FINITE
C           DIFFERENCE HESSIAN WHICH IT CALCULATES BY CALLING FSTOFD
C           (IF IAGFLG .EQ. 1) OR SNDOFD (OTHERWISE).
C
CDPLT       IF (MSG .LT. 0) RETURN
   88 CONTINUE
C
   90 IF(MOD(MSG/8,2).EQ.0)
     +     CALL RESULT(NR,N,X,F,G,A,P,ITNCNT,1,IPR2)
C
C
C ITERATION
C ---------
  100 ITNCNT=ITNCNT+1
C
C FIND PERTURBED LOCAL MODEL HESSIAN AND ITS LL+ DECOMPOSITION
C (SKIP THIS STEP IF LINE SEARCH OR DOGSTEP TECHNIQUES BEING USED WITH
C SECANT UPDATES.  CHOLESKY DECOMPOSITION L ALREADY OBTAINED FROM
C SECFAC.)
C
      IF(IEXP.EQ.1 .AND. METHOD.NE.3) GO TO 105
  103   CALL CHLHSN(NR,N,A,EPSM,SX,UDIAG)
  105 CONTINUE
C
C SOLVE FOR NEWTON STEP:  AP=-G
C
      DO 110 I=1,N
        WRK1(I)=-G(I)
  110 CONTINUE
      CALL LLTSLV(NR,N,A,P,WRK1)
C
C DECIDE WHETHER TO ACCEPT NEWTON STEP  XPLS=X + P
C OR TO CHOOSE XPLS BY A GLOBAL STRATEGY.
C
      IF (IAGFLG .NE. 0 .OR. METHOD .EQ. 1) GO TO 111
      DLTSAV = DLT
      IF (METHOD .EQ. 2) GO TO 111
      AMUSAV = AMU
      DLPSAV = DLTP
      PHISAV = PHI
      PHPSAV = PHIP0
  111 IF(METHOD.EQ.1)
CDPLT+     CALL LNSRCH(N,X,F,G,P,XPLS,FPLS,OPTFCN,MXTAKE,IRETCD,
     +     CALL LNSRCH(N,X,F,G,P,XPLS,FPLS,MXTAKE,IRETCD,
     +     STEPMX,STEPTL,SX,IPR2)
      IF(METHOD.EQ.2)
CDPLT+     CALL DOGDRV(NR,N,X,F,G,A,P,XPLS,FPLS,OPTFCN,SX,STEPMX,
     +     CALL DOGDRV(NR,N,X,F,G,A,P,XPLS,FPLS,SX,STEPMX,
     +     STEPTL,DLT,IRETCD,MXTAKE,WRK0,WRK1,WRK2,WRK3,IPR2)
      IF(METHOD.EQ.3)
CDPLT+     CALL HOOKDR(NR,N,X,F,G,A,UDIAG,P,XPLS,FPLS,OPTFCN,SX,STEPMX,
     +     CALL HOOKDR(NR,N,X,F,G,A,UDIAG,P,XPLS,FPLS,SX,STEPMX,
     +     STEPTL,DLT,IRETCD,MXTAKE,AMU,DLTP,PHI,PHIP0,WRK0,
     +     WRK1,WRK2,EPSM,ITNCNT,IPR2)
C
C IF COULD NOT FIND SATISFACTORY STEP AND FORWARD DIFFERENCE
C GRADIENT WAS USED, RETRY USING CENTRAL DIFFERENCE GRADIENT.
C
      IF (IRETCD .NE. 1 .OR. IAGFLG .NE. 0) GO TO 112
C     IF (IRETCD .EQ. 1 .AND. IAGFLG .EQ. 0)
C     THEN
C
C        SET IAGFLG FOR CENTRAL DIFFERENCES
C
         IAGFLG = -1
         WRITE(ICOUT,906) ITNCNT
         CALL DPWRST('XXX','BUG ')
C
CDPLT    CALL FSTOCD (N, X, OPTFCN, SX, RNF, G)
         CALL FSTOCD (N, X, SX, RNF, G)
         IF (METHOD .EQ. 1) GO TO 105
         DLT = DLTSAV
         IF (METHOD .EQ. 2) GO TO 105
         AMU = AMUSAV
         DLTP = DLPSAV
         PHI = PHISAV
         PHIP0 = PHPSAV
         GO TO 103
C     ENDIF
C
C CALCULATE STEP FOR OUTPUT
C
  112 CONTINUE
      DO 114 I = 1, N
         P(I) = XPLS(I) - X(I)
  114 CONTINUE
C
C CALCULATE GRADIENT AT XPLS
C
      IF (IAGFLG .EQ. (-1)) GO TO 116
      IF (IAGFLG .EQ. 0) GO TO 118
C
C ANALYTIC GRADIENT
CDPLT CALL D1FCN (N, XPLS, GPLS)
      GO TO 120
C
C CENTRAL DIFFERENCE GRADIENT
CD116 CALL FSTOCD (N, XPLS, OPTFCN, SX, RNF, GPLS)
  116 CALL FSTOCD (N, XPLS, SX, RNF, GPLS)
      GO TO 120
C
C FORWARD DIFFERENCE GRADIENT
CD118 CALL FSTOFD (1, 1, N, XPLS, OPTFCN, FPLS, GPLS, SX, RNF, WRK, 1)
  118 CALL FSTOFD (1, 1, N, XPLS, FPLS, GPLS, SX, RNF, WRK, 1)
  120 CONTINUE
C
C CHECK WHETHER STOPPING CRITERIA SATISFIED
C
      CALL OPTSTP(N,XPLS,FPLS,GPLS,X,ITNCNT,ICSCMX,
     +            ITRMCD,GRADTL,STEPTL,SX,FSCALE,ITNLIM,IRETCD,MXTAKE,
     +            IPR2,MSG)
      IF(ITRMCD.NE.0) GO TO 690
C
C EVALUATE HESSIAN AT XPLS
C
      IF(IEXP.EQ.0) GO TO 130
      IF(METHOD.EQ.3)
     +     CALL SECUNF(NR,N,X,G,A,UDIAG,XPLS,GPLS,EPSM,ITNCNT,RNF,
     +     IAGFLG,NOUPDT,WRK1,WRK2,WRK3)
      IF(METHOD.NE.3)
     +     CALL SECFAC(NR,N,X,G,A,XPLS,GPLS,EPSM,ITNCNT,RNF,IAGFLG,
     +     NOUPDT,WRK0,WRK1,WRK2,WRK3)
      GO TO 150
  130 IF(IAHFLG.EQ.1) GO TO 140
CDPLT IF(IAGFLG.EQ.1)
CDPLT+     CALL FSTOFD(NR,N,N,XPLS,D1FCN,GPLS,A,SX,RNF,WRK1,3)
      IF(IAGFLG.NE.1) 
CDPLT+     CALL SNDOFD(NR,N,XPLS,OPTFCN,FPLS,A,SX,RNF,WRK1,WRK2)
     +     CALL SNDOFD(NR,N,XPLS,FPLS,A,SX,RNF,WRK1,WRK2)
      GO TO 150
  140 CONTINUE
CD140 CALL D2FCN(NR,N,XPLS,A)
  150 CONTINUE
      IF(MOD(MSG/16,2).EQ.1)
     +     CALL RESULT(NR,N,XPLS,FPLS,GPLS,A,P,ITNCNT,1,IPR2)
C
C X <-- XPLS  AND  G <-- GPLS  AND  F <-- FPLS
C
      F=FPLS
      DO 160 I=1,N
        X(I)=XPLS(I)
        G(I)=GPLS(I)
  160 CONTINUE
      GO TO 100
C
C TERMINATION
C -----------
C RESET XPLS,FPLS,GPLS,  IF PREVIOUS ITERATE SOLUTION
C
  690 IF(ITRMCD.NE.3) GO TO 710
  700 CONTINUE
      FPLS=F
      DO 705 I=1,N
        XPLS(I)=X(I)
        GPLS(I)=G(I)
  705 CONTINUE
C
C PRINT RESULTS
C
  710 CONTINUE
      IF(MOD(MSG/8,2).EQ.0)
     +     CALL RESULT(NR,N,XPLS,FPLS,GPLS,A,P,ITNCNT,0,IPR2)
      MSG=0
CDPLT
CCCCC WRITE HESSIAN TO FILE DPST2F.DAT.  BEFORE WRITING, MAKE
CCCCC UPPER DIAGONAL OF MATRIX EQUAL TO LOWER DIAGONAL.
C
      IOUNI2=IST2NU
      DO9005I=1,N
        DO9007J=1,N
          A(J,I)=A(I,J)
 9007   CONTINUE
 9005 CONTINUE
C
      IF(N.LE.10)THEN
      WRITE(IOUNI2,9011)ITNCNT
      DO9010I=1,N
        WRITE(IOUNI2,9013)(A(I,J),J=1,N)
 9010 CONTINUE
 9011 FORMAT(1X,'HESSIAN MATRIX AT ITERATION ',I5)
 9013 FORMAT(10(1X,E15.7))
      ELSE
      WRITE(IOUNI2,9011)ITNCNT
      DO9020I=1,N
        DO9025J=1,N
          WRITE(IOUNI2,9023)A(I,J)
 9025   CONTINUE
        WRITE(IOUNI2,9027)
 9020 CONTINUE
 9023 FORMAT(1X,E15.7)
 9027 FORMAT(1X)
      ENDIF
C
      RETURN
C
  900 FORMAT('***** FROM OPTDRV       ',5(E20.13,3X))
  901 FORMAT('***** FROM OPTDRV    TYPICAL X')
  902 FORMAT('***** FROM OPTDRV    DIAGONAL SCALING MATRIX FOR X')
  903 FORMAT('***** FROM OPTDRV    TYPICAL F = ',E20.13)
  904 FORMAT('***** FROM OPTDRV    NUMBER OF GOOD DIGITS IN OPTFCN = ',
     +I5)
  914 FORMAT('                     GRADIENT FLAG  = ',I5,
     +' (=1 IF ')
  916 FORMAT('                     ANALYTIC GRADIENT SUPPLIED)')
  924 FORMAT('                     HESSIAN FLAG   = ',I5,
     +' (=1 IF ')
  926 FORMAT('                     ANALYTIC HESSIAN SUPPLIED)')
  934 FORMAT('                     EXPENSE FLAG   = ',I5,' (=1 IF ',
     +'MINIMIZATION ')
  936 FORMAT('                     FUNCTION EXPENSIVE TO EVALUATE)')
  944 FORMAT('                     METHOD TO USE  = ',I5,' (=1,2,3 ',
     +'FOR LINE SEARCH,')
  946 FORMAT('                     DOUBLE DOGLEG, MORE-HEBDON ',
     +' RESPECTIVELY)')
  954 FORMAT('                     ITERATION LIMIT = ',I5)
  964 FORMAT('                     MACHINE EPSILON = ',E20.13)
  905 FORMAT('***** FROM OPTDRV    MAXIMUM STEP SIZE    = ',E20.13)
  915 FORMAT('                     STEP TOLERANCE       = ',E20.13)
  925 FORMAT('                     GRADIENT TOLERANCE   = ',E20.13)
  935 FORMAT('                     TRUST REGION RADIUS  = ',E20.13)
  945 FORMAT('                     REL NOISE IN OPTFCN  = ',E20.13)
  955 FORMAT('                     ANAL-FD TOLERANCE    = ',E20.13)
  906 FORMAT('***** FROM OPTDRV    SHIFT FROM FORWARD TO CENTRAL ',
     +'DIFFERENCES IN ITERATION ', I5)
      END
      SUBROUTINE OPTFCN(N, X, F)
C
C     PURPOSE--AUXILLARY FUNCTION FOR THE UNCMIN ROUTINES.
C              IT COMPUTES THE FUNCTION BEING OPTIMIZED
C              AT THE VALUES OF THE N PARAMETERS GIVEN IN
C              X AND RETURNS THE FUNCTION VALUE IN F.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--95/2
C     ORIGINAL VERSION--FEBRUARY  1995.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DOUBLE PRECISION X(*)
      DOUBLE PRECISION F
C
      CHARACTER*4 MODEL
      CHARACTER*4 IPARN
      CHARACTER*4 IPARN2
      CHARACTER*4 IANGLU
      CHARACTER*4 ITYPEH
      CHARACTER*4 IW21HO
      CHARACTER*4 IW22HO
      CHARACTER*4 IVARN
      CHARACTER*4 IVARN2
      CHARACTER*4 IBUGA3
      CHARACTER*4 IBUGCO
      CHARACTER*4 IBUGEV
      CHARACTER*4 IERROR
C
CCCCC CHARACTER*4 ILAB
CCCCC CHARACTER*4 IH
CCCCC CHARACTER*4 IH2
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 ISTEPN
C
C---------------------------------------------------------------------
C
      PARAMETER (IOPTCH=1000)
      PARAMETER (IOPTC2=100)
C
      DIMENSION PARAM(IOPTC2)
      DIMENSION IPARN(IOPTC2)
      DIMENSION IPARN2(IOPTC2)
      DIMENSION IVARN(IOPTC2)
      DIMENSION IVARN2(IOPTC2)
C
      DIMENSION MODEL(IOPTCH)
      DIMENSION ITYPEH(IOPTCH)
      DIMENSION IW21HO(IOPTCH)
      DIMENSION IW22HO(IOPTCH)
      DIMENSION W2HOLD(IOPTCH)
C
      DIMENSION ILOCV(IOPTC2)
CCCCC DIMENSION ILAB(IOPTC2)
C
      COMMON /OPTCMC/ IBUGA3, ITYPEH, IW21HO, IW22HO, IPARN, IPARN2, 
     &                IVARN, IVARN2, MODEL
      COMMON /OPTCMR/ PARAM, W2HOLD,
     &                NUMCHA, NUMVAR, NWHOLD, NUMDV, ILOCV
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
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(IBUGA3.EQ.'OFF')GOTO99
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('AT THE BEGINNING OF OPTFCN--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)IBUGA3
   52 FORMAT('IBUGA3 = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)NUMCHA,NUMDV,NUMVAR
   53 FORMAT('NUMCHA,NUMDV,NUMVAR = ',3I8)
      CALL DPWRST('XXX','BUG ')
      NMAX=NUMCHA
      IF(NMAX.GT.25)NMAX=25
      WRITE(ICOUT,54)(MODEL(J),J=1,NMAX)
   54 FORMAT('MODEL(I) = ',25A4)
      CALL DPWRST('XXX','BUG ')
      DO55I=1,NUMVAR
      WRITE(ICOUT,56)I,PARAM(I),IPARN(I),IPARN2(I)
   56 FORMAT('I,PARAM(I),IPARN(I),IPARN2(I) = ',I8,E15.7,A4,A4)
      CALL DPWRST('XXX','BUG ')
   55 CONTINUE
      DO59I=1,NUMDV
      WRITE(ICOUT,61)I,IVARN(I),IVARN2(I)
   61 FORMAT('I, IVARN(I),IVARN2(I) = ',I8,2X,A4,A4)
      CALL DPWRST('XXX','BUG ')
   59 CONTINUE
   99 CONTINUE
C
C               ***************************
C               **  STEP 3--             **
C               **  INITIALIZE PARAMETERS**
C               ***************************
C
      ISTEPN='3'
      IF(IBUGA3.EQ.'ON')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      DO9100K=1,NUMDV
      JLOC=ILOCV(K)
      PARAM(JLOC)=REAL(X(K))
 9100 CONTINUE
C
      IPASS=2
      IBUGCO=IBUGA3
      IBUGEV=IBUGA3
      FX=0.0
      CALL COMPIM(MODEL,NUMCHA,IPASS,PARAM,IPARN,IPARN2,NUMVAR,
     1IANGLU,ITYPEH,IW21HO,IW22HO,W2HOLD,NWHOLD,FX,
     1IBUGCO,IBUGEV,IERROR)
      F=DBLE(FX)
      IF(IBUGA3.EQ.'ON')THEN
        WRITE(ICOUT,9101)FX
        CALL DPWRST('XXX','BUG ')
        DO9102KK=1,NUMDV
        WRITE(ICOUT,9103)KK,REAL(X(KK))
        CALL DPWRST('XXX','BUG ')
 9102   CONTINUE
      ENDIF
 9101 FORMAT('FX  = ',E15.7)
 9103 FORMAT('I,X(I) = ',I5,1X,E15.7)
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'OFF')GOTO9090
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END      OF OPTFCN--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9021)IERROR
 9021 FORMAT('IERROR = ',A4)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE OPTIF9(NR,N,X,TYPSIZ,FSCALE,
CCCCC SUBROUTINE OPTIF9(NR,N,X,OPTFCN,D1FCN,D2FCN,TYPSIZ,FSCALE,
     +     METHOD,IEXP,MSG,NDIGIT,ITNLIM,IAGFLG,IAHFLG,IPR,
     +     DLT,GRADTL,STEPMX,STEPTL,
     +     XPLS,FPLS,GPLS,ITRMCD,A,WRK)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C PURPOSE
C -------
C PROVIDE COMPLETE INTERFACE TO MINIMIZATION PACKAGE.
C USER HAS FULL CONTROL OVER OPTIONS.
C
C PARAMETERS
C ----------
C NR           --> ROW DIMENSION OF MATRIX
C N            --> DIMENSION OF PROBLEM
C X(N)         --> ON ENTRY: ESTIMATE TO A ROOT OF FCN
C FCN          --> NAME OF SUBROUTINE TO EVALUATE OPTIMIZATION FUNCTION
C                  MUST BE DECLARED EXTERNAL IN CALLING ROUTINE
C                            FCN: R(N) --> R(1)
C D1FCN        --> (OPTIONAL) NAME OF SUBROUTINE TO EVALUATE GRADIENT
C                  OF FCN.  MUST BE DECLARED EXTERNAL IN CALLING ROUTINE
C D2FCN        --> (OPTIONAL) NAME OF SUBROUTINE TO EVALUATE HESSIAN OF
C                  OF FCN.  MUST BE DECLARED EXTERNAL IN CALLING ROUTINE
C TYPSIZ(N)    --> TYPICAL SIZE FOR EACH COMPONENT OF X
C FSCALE       --> ESTIMATE OF SCALE OF OBJECTIVE FUNCTION
C METHOD       --> ALGORITHM TO USE TO SOLVE MINIMIZATION PROBLEM
C                    =1 LINE SEARCH
C                    =2 DOUBLE DOGLEG
C                    =3 MORE-HEBDON
C IEXP         --> =1 IF OPTIMIZATION FUNCTION FCN IS EXPENSIVE TO
C                  EVALUATE, =0 OTHERWISE.  IF SET THEN HESSIAN WILL
C                  BE EVALUATED BY SECANT UPDATE INSTEAD OF
C                  ANALYTICALLY OR BY FINITE DIFFERENCES
C MSG         <--> ON INPUT:  (.GT.0) MESSAGE TO INHIBIT CERTAIN
C                    AUTOMATIC CHECKS
C                  ON OUTPUT: (.LT.0) ERROR CODE; =0 NO ERROR
C NDIGIT       --> NUMBER OF GOOD DIGITS IN OPTIMIZATION FUNCTION FCN
C ITNLIM       --> MAXIMUM NUMBER OF ALLOWABLE ITERATIONS
C IAGFLG       --> =1 IF ANALYTIC GRADIENT SUPPLIED
C IAHFLG       --> =1 IF ANALYTIC HESSIAN SUPPLIED
C IPR          --> DEVICE TO WHICH TO SEND OUTPUT
C DLT          --> TRUST REGION RADIUS
C GRADTL       --> TOLERANCE AT WHICH GRADIENT CONSIDERED CLOSE
C                  ENOUGH TO ZERO TO TERMINATE ALGORITHM
C STEPMX       --> MAXIMUM ALLOWABLE STEP SIZE
C STEPTL       --> RELATIVE STEP SIZE AT WHICH SUCCESSIVE ITERATES
C                  CONSIDERED CLOSE ENOUGH TO TERMINATE ALGORITHM
C XPLS(N)     <--> ON EXIT:  XPLS IS LOCAL MINIMUM
C FPLS        <--> ON EXIT:  FUNCTION VALUE AT SOLUTION, XPLS
C GPLS(N)     <--> ON EXIT:  GRADIENT AT SOLUTION XPLS
C ITRMCD      <--  TERMINATION CODE
C A(N,N)       --> WORKSPACE FOR HESSIAN (OR ESTIMATE)
C                  AND ITS CHOLESKY DECOMPOSITION
C WRK(N,8)     --> WORKSPACE
C
CCCCC MAY 1995.  DO DUMMY DECLARATIONS WITH "*".
CCCCC DIMENSION X(N),XPLS(N),GPLS(N),TYPSIZ(N)
CCCCC DIMENSION A(NR,1),WRK(NR,1)
      DIMENSION X(*),XPLS(*),GPLS(*),TYPSIZ(*)
      DIMENSION A(NR,*),WRK(NR,*)
CDPLT EXTERNAL FCN,D1FCN,D2FCN
CDPLT EXTERNAL OPTFCN
C
C EQUIVALENCE WRK(N,1) = UDIAG(N)
C             WRK(N,2) = G(N)
C             WRK(N,3) = P(N)
C             WRK(N,4) = SX(N)
C             WRK(N,5) = WRK0(N)
C             WRK(N,6) = WRK1(N)
C             WRK(N,7) = WRK2(N)
C             WRK(N,8) = WRK3(N)
C
CDPLT CALL OPTDRV(NR,N,X,FCN,D1FCN,D2FCN,TYPSIZ,FSCALE,
      CALL OPTDRV(NR,N,X,TYPSIZ,FSCALE,
     +     METHOD,IEXP,MSG,NDIGIT,ITNLIM,IAGFLG,IAHFLG,IPR,
     +     DLT,GRADTL,STEPMX,STEPTL,
     +     XPLS,FPLS,GPLS,ITRMCD,
     +     A,WRK(1,1),WRK(1,2),WRK(1,3),WRK(1,4),WRK(1,5),
     +     WRK(1,6),WRK(1,7),WRK(1,8))
      RETURN
      END
      SUBROUTINE OPTSTP(N,XPLS,FPLS,GPLS,X,ITNCNT,ICSCMX,
     +      ITRMCD,GRADTL,STEPTL,SX,FSCALE,ITNLIM,IRETCD,MXTAKE,
     +      IPRTMP,MSG)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C UNCONSTRAINED MINIMIZATION STOPPING CRITERIA
C --------------------------------------------
C FIND WHETHER THE ALGORITHM SHOULD TERMINATE, DUE TO ANY
C OF THE FOLLOWING:
C 1) PROBLEM SOLVED WITHIN USER TOLERANCE
C 2) CONVERGENCE WITHIN USER TOLERANCE
C 3) ITERATION LIMIT REACHED
C 4) DIVERGENCE OR TOO RESTRICTIVE MAXIMUM STEP (STEPMX) SUSPECTED
C
C
C PARAMETERS
C ----------
C N            --> DIMENSION OF PROBLEM
C XPLS(N)      --> NEW ITERATE X[K]
C FPLS         --> FUNCTION VALUE AT NEW ITERATE F(XPLS)
C GPLS(N)      --> GRADIENT AT NEW ITERATE, G(XPLS), OR APPROXIMATE
C X(N)         --> OLD ITERATE X[K-1]
C ITNCNT       --> CURRENT ITERATION K
C ICSCMX      <--> NUMBER CONSECUTIVE STEPS .GE. STEPMX
C                  [RETAIN VALUE BETWEEN SUCCESSIVE CALLS]
C ITRMCD      <--  TERMINATION CODE
C GRADTL       --> TOLERANCE AT WHICH RELATIVE GRADIENT CONSIDERED CLOSE
C                  ENOUGH TO ZERO TO TERMINATE ALGORITHM
C STEPTL       --> RELATIVE STEP SIZE AT WHICH SUCCESSIVE ITERATES
C                  CONSIDERED CLOSE ENOUGH TO TERMINATE ALGORITHM
C SX(N)        --> DIAGONAL SCALING MATRIX FOR X
C FSCALE       --> ESTIMATE OF SCALE OF OBJECTIVE FUNCTION
C ITNLIM       --> MAXIMUM NUMBER OF ALLOWABLE ITERATIONS
C IRETCD       --> RETURN CODE
C MXTAKE       --> BOOLEAN FLAG INDICATING STEP OF MAXIMUM LENGTH USED
C IPR          --> DEVICE TO WHICH TO SEND OUTPUT
C MSG          --> IF MSG INCLUDES A TERM 8, SUPPRESS OUTPUT
C
C
      INTEGER N,ITNCNT,ICSCMX,ITRMCD,ITNLIM
      DIMENSION SX(N)
      DIMENSION XPLS(N),GPLS(N),X(N)
      LOGICAL MXTAKE
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
      REAL CPUMIN, CPUMAX
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
      ITRMCD=0
C
C LAST GLOBAL STEP FAILED TO LOCATE A POINT LOWER THAN X
      IF(IRETCD.NE.1) GO TO 50
C     IF(IRETCD.EQ.1)
C     THEN
        JTRMCD=3
        GO TO 600
C     ENDIF
   50 CONTINUE
C
C FIND DIRECTION IN WHICH RELATIVE GRADIENT MAXIMUM.
C CHECK WHETHER WITHIN TOLERANCE
C
      D=MAX(ABS(FPLS),FSCALE)
      RGX=0.0
      DO 100 I=1,N
        RELGRD=ABS(GPLS(I))*MAX(ABS(XPLS(I)),1./SX(I))/D
        RGX=MAX(RGX,RELGRD)
  100 CONTINUE
      JTRMCD=1
      IF(RGX.LE.GRADTL) GO TO 600
C
      IF(ITNCNT.EQ.0) RETURN
C
C FIND DIRECTION IN WHICH RELATIVE STEPSIZE MAXIMUM
C CHECK WHETHER WITHIN TOLERANCE.
C
      RSX=0.0
      DO 120 I=1,N
        RELSTP=ABS(XPLS(I)-X(I))/MAX(ABS(XPLS(I)),1./SX(I))
        RSX=MAX(RSX,RELSTP)
  120 CONTINUE
      JTRMCD=2
      IF(RSX.LE.STEPTL) GO TO 600
C
C CHECK ITERATION LIMIT
C
      JTRMCD=4
      IF(ITNCNT.GE.ITNLIM) GO TO 600
C
C CHECK NUMBER OF CONSECUTIVE STEPS \ STEPMX
C
      IF(MXTAKE) GO TO 140
C     IF(.NOT.MXTAKE)
C     THEN
        ICSCMX=0
        RETURN
C     ELSE
  140   CONTINUE
        IF (MOD(MSG/8,2) .EQ. 0) WRITE(ICOUT,900)
        ICSCMX=ICSCMX+1
        IF(ICSCMX.LT.5) RETURN
        JTRMCD=5
C     ENDIF
C
C
C PRINT TERMINATION CODE
C
CCCCC DATAPLOT WILL PRINT THE ERROR MESSAGES FROM DPOPT3.
  600 ITRMCD=JTRMCD
      IF (MOD(MSG/8,2) .EQ. 0) GO TO(601,602,603,604,605), ITRMCD
      GO TO 700
  601 CONTINUE
CCCCC WRITE(ICOUT,901)
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC WRITE(ICOUT,911)
CCCCC CALL DPWRST('XXX','BUG ')
      GO TO 700
  602 CONTINUE
CCCCC WRITE(ICOUT,902)
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC WRITE(ICOUT,912)
CCCCC CALL DPWRST('XXX','BUG ')
      GO TO 700
  603 CONTINUE
CCCCC WRITE(ICOUT,903)
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC WRITE(ICOUT,913)
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC WRITE(ICOUT,923)
CCCCC CALL DPWRST('XXX','BUG ')
      GO TO 700
  604 CONTINUE
CCCCC WRITE(ICOUT,904)
CCCCC CALL DPWRST('XXX','BUG ')
      GO TO 700
  605 CONTINUE
CCCCC WRITE(ICOUT,905)
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC WRITE(ICOUT,915)
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC WRITE(ICOUT,915)
CCCCC CALL DPWRST('XXX','BUG ')
C
  700 RETURN
C
  900 FORMAT(
     +'***** FROM OPTSTP    STEP OF MAXIMUM LENGTH (STEPMX) TAKEN')
  901 FORMAT(
     +'***** FROM OPTSTP    RELATIVE GRADIENT CLOSE TO ZERO.')
  911 FORMAT(
     +'                     CURRENT ITERATE IS PROBABLY SOLUTION.')
  902 FORMAT(
     +'***** FROM OPTSTP    SUCCESSIVE ITERATES WITHIN TOLERANCE.')
  912 FORMAT(
     +'                     CURRENT ITERATE IS PROBABLY SOLUTION.')
  903 FORMAT(
     +'***** FROM OPTSTP    LAST GLOBAL STEP FAILED TO LOCATE A ',
     +'POINT LOWER THAN X.')
  913 FORMAT(
     +'                     EITHER X IS AN APPROXIMATE LOCAL MINIMUM',
     + ' OF THE FUNCTION,')
  923 FORMAT(
     +'                     THE FUNCTION IS TOO NON-LINEAR FOR THIS ',
     +'ALGORITHM OR STEPTL IS TOO LARGE.')
  904 FORMAT(
     +'***** FROM OPTSTP    ALGORITHM FAILED BECAUSE ITERATION LIMIT',
     +'  EXCEEDED.')
  905 FORMAT(
     +'***** FROM OPTSTP    MAXIMUM STEP SIZE EXCEEDED 5 CONSECUTIVE',
     +'  TIMES.')
  915 FORMAT(
     +'                     EITHER THE FUNCTION IS UNBOUNDED BELOW, ',
     +'BECOMES ASYMPTOTIC TO A FINITE VALUE FROM ABOVE IN SOME ')
  925 FORMAT(
     +'                     DIRECTION, OR STEPMX IS TOO SMALL.')
      END
      SUBROUTINE ORTHES(NM,N,LOW,IGH,A,ORT)
C***BEGIN PROLOGUE  ORTHES
C***DATE WRITTEN   760101   (YYMMDD)
C***REVISION DATE  830518   (YYMMDD)
C***CATEGORY NO.  D4C1B2
C***KEYWORDS  EIGENVALUES,EIGENVECTORS,EISPACK
C***AUTHOR  SMITH, B. T., ET AL.
C***PURPOSE  Reduces real general matrix to upper Hessenberg form
C            orthogonal similarity transformations.
C***DESCRIPTION
C
C     This subroutine is a translation of the ALGOL procedure ORTHES,
C     NUM. MATH. 12, 349-368(1968) by Martin and Wilkinson.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971).
C
C     Given a REAL GENERAL matrix, this subroutine
C     reduces a submatrix situated in rows and columns
C     LOW through IGH to upper Hessenberg form by
C     orthogonal similarity transformations.
C
C     On INPUT
C
C        NM must be set to the row dimension of two-dimensional
C          array parameters as declared in the calling program
C          dimension statement.
C
C        N is the order of the matrix.
C
C        LOW and IGH are integers determined by the balancing
C          subroutine  BALANC.  If  BALANC  has not been used,
C          set LOW=1, IGH=N.
C
C        A contains the input matrix.
C
C     On OUTPUT
C
C        A contains the Hessenberg matrix.  Information about
C          the orthogonal transformations used in the reduction
C          is stored in the remaining triangle under the
C          Hessenberg matrix.
C
C        ORT contains further information about the transformations.
C          only elements LOW through IGH are used.
C
C     Questions and comments should be directed to B. S. Garbow,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C     ------------------------------------------------------------------
C***REFERENCES  B. T. SMITH, J. M. BOYLE, J. J. DONGARRA, B. S. GARBOW,
C                 Y. IKEBE, V. C. KLEMA, C. B. MOLER, *MATRIX EIGEN-
C                 SYSTEM ROUTINES - EISPACK GUIDE*, SPRINGER-VERLAG,
C                 1976.
C***ROUTINES CALLED  (NONE)
C***END PROLOGUE  ORTHES
C
      INTEGER I,J,M,N,II,JJ,LA,MP,NM,IGH,KP1,LOW
      REAL A(NM,N),ORT(IGH)
      REAL F,G,H,SCALE
C
C***FIRST EXECUTABLE STATEMENT  ORTHES
      LA = IGH - 1
      KP1 = LOW + 1
      IF (LA .LT. KP1) GO TO 200
C
      DO 180 M = KP1, LA
         H = 0.0E0
         ORT(M) = 0.0E0
         SCALE = 0.0E0
C     .......... SCALE COLUMN (ALGOL TOL THEN NOT NEEDED) ..........
         DO 90 I = M, IGH
   90    SCALE = SCALE + ABS(A(I,M-1))
C
         IF (SCALE .EQ. 0.0E0) GO TO 180
         MP = M + IGH
C     .......... FOR I=IGH STEP -1 UNTIL M DO -- ..........
         DO 100 II = M, IGH
            I = MP - II
            ORT(I) = A(I,M-1) / SCALE
            H = H + ORT(I) * ORT(I)
  100    CONTINUE
C
         G = -SIGN(SQRT(H),ORT(M))
         H = H - ORT(M) * G
         ORT(M) = ORT(M) - G
C     .......... FORM (I-(U*UT)/H) * A ..........
         DO 130 J = M, N
            F = 0.0E0
C     .......... FOR I=IGH STEP -1 UNTIL M DO -- ..........
            DO 110 II = M, IGH
               I = MP - II
               F = F + ORT(I) * A(I,J)
  110       CONTINUE
C
            F = F / H
C
            DO 120 I = M, IGH
  120       A(I,J) = A(I,J) - F * ORT(I)
C
  130    CONTINUE
C     .......... FORM (I-(U*UT)/H)*A*(I-(U*UT)/H) ..........
         DO 160 I = 1, IGH
            F = 0.0E0
C     .......... FOR J=IGH STEP -1 UNTIL M DO -- ..........
            DO 140 JJ = M, IGH
               J = MP - JJ
               F = F + ORT(J) * A(I,J)
  140       CONTINUE
C
            F = F / H
C
            DO 150 J = M, IGH
  150       A(I,J) = A(I,J) - F * ORT(J)
C
  160    CONTINUE
C
         ORT(M) = SCALE * ORT(M)
         A(M,M-1) = SCALE * G
  180 CONTINUE
C
  200 RETURN
      END
      SUBROUTINE ORTRAN(NM,N,LOW,IGH,A,ORT,Z)
C***BEGIN PROLOGUE  ORTRAN
C***DATE WRITTEN   760101   (YYMMDD)
C***REVISION DATE  830518   (YYMMDD)
C***CATEGORY NO.  D4C4
C***KEYWORDS  EIGENVALUES,EIGENVECTORS,EISPACK
C***AUTHOR  SMITH, B. T., ET AL.
C***PURPOSE  Accumulates orthogonal similarity transformations in
C            reduction of real general matrix by ORTHES.
C***DESCRIPTION
C
C     This subroutine is a translation of the ALGOL procedure ORTRANS,
C     NUM. MATH. 16, 181-204(1970) by Peters and Wilkinson.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971).
C
C     This subroutine accumulates the orthogonal similarity
C     transformations used in the reduction of a REAL GENERAL
C     matrix to upper Hessenberg form by  ORTHES.
C
C     On INPUT
C
C        NM must be set to the row dimension of two-dimensional
C          array parameters as declared in the calling program
C          dimension statement.
C
C        N is the order of the matrix.
C
C        LOW and IGH are integers determined by the balancing
C          subroutine  BALANC.  If  BALANC  has not been used,
C          set LOW=1, IGH=N.
C
C        A contains information about the orthogonal trans-
C          formations used in the reduction by  ORTHES
C          in its strict lower triangle.
C
C        ORT contains further information about the trans-
C          formations used in the reduction by  ORTHES.
C          only elements LOW through IGH are USED.
C
C     On OUTPUT
C
C        Z contains the transformation matrix produced in the
C          reduction by  ORTHES.
C
C        ORT has been altered.
C
C     Questions and comments should be directed to B. S. Garbow,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C     ------------------------------------------------------------------
C***REFERENCES  B. T. SMITH, J. M. BOYLE, J. J. DONGARRA, B. S. GARBOW,
C                 Y. IKEBE, V. C. KLEMA, C. B. MOLER, *MATRIX EIGEN-
C                 SYSTEM ROUTINES - EISPACK GUIDE*, SPRINGER-VERLAG,
C                 1976.
C***ROUTINES CALLED  (NONE)
C***END PROLOGUE  ORTRAN
C
      INTEGER I,J,N,KL,MM,MP,NM,IGH,LOW,MP1
      REAL A(NM,IGH),ORT(IGH),Z(NM,N)
      REAL G
C
C     .......... INITIALIZE Z TO IDENTITY MATRIX ..........
C***FIRST EXECUTABLE STATEMENT  ORTRAN
      DO 80 I = 1, N
C
         DO 60 J = 1, N
   60    Z(I,J) = 0.0E0
C
         Z(I,I) = 1.0E0
   80 CONTINUE
C
      KL = IGH - LOW - 1
      IF (KL .LT. 1) GO TO 200
C     .......... FOR MP=IGH-1 STEP -1 UNTIL LOW+1 DO -- ..........
      DO 140 MM = 1, KL
         MP = IGH - MM
         IF (A(MP,MP-1) .EQ. 0.0E0) GO TO 140
         MP1 = MP + 1
C
         DO 100 I = MP1, IGH
  100    ORT(I) = A(I,MP-1)
C
         DO 130 J = MP, IGH
            G = 0.0E0
C
            DO 110 I = MP, IGH
  110       G = G + ORT(I) * Z(I,J)
C     .......... DIVISOR BELOW IS NEGATIVE OF H FORMED IN ORTHES.
C                DOUBLE DIVISION AVOIDS POSSIBLE UNDERFLOW ..........
            G = (G / ORT(MP)) / A(MP,MP-1)
C
            DO 120 I = MP, IGH
  120       Z(I,J) = Z(I,J) + G * ORT(I)
C
  130    CONTINUE
C
  140 CONTINUE
C
  200 RETURN
      END
      SUBROUTINE PARCHI(IHP,IHP2,IDIST,
     1IPAR,ILOWLM,IUPPLM,LOWLTY,UPPLTY,
     1ISUBN1,ISUBN2,IERROR)
C
C     PURPOSE--CHECK TO SEE IF A (INTEGER) PARAMETER IS IN 
C              A SPECIFIED RANGE.  UTILITY ROUTINE FOR
C              PROBABILITY PLOT, LAHEY COMPILER HAD TROUBLE
C              COMPILING DPPP.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--98/8
C     ORIGINAL VERSION--AUGUST    1998.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      INCLUDE 'DPCOPA.INC'
      INCLUDE 'DPCOHK.INC'
C
      CHARACTER*4 IHP
      CHARACTER*4 IHP2
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 LOWLTY
      CHARACTER*4 UPPLTY
      CHARACTER*30 IDIST
      CHARACTER*4 IERROR
C
      CHARACTER*4 IHWUSE
      CHARACTER*4 MESSAG
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
C
C               ************************************
C               **  STEP 1--                      **
C               **  CHECK FOR GAMMA DISTRIBUTION  **
C               **  PARAMETER GAMMA               **
C               ************************************
C
      IHWUSE='P'
      MESSAG='YES'
      CALL CHECKN(IHP,IHP2,IHWUSE,
     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
     1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR)
      IF(IERROR.EQ.'YES')GOTO9000
      IPAR=VALUE(ILOCP)+0.5
C
      IF(LOWLTY.EQ.'>   ')THEN
        IF(IPAR.GT.ILOWLM)GOTO1590
      ELSEIF(LOWLTY.EQ.'>=  ')THEN
        IF(IPAR.GE.ILOWLM)GOTO1590
      ENDIF
      WRITE(ICOUT,999)
  999 FORMAT(' ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1511)ISUBN1,ISUBN2
 1511 FORMAT('***** ERROR IN ',A4,A4,'--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1512)IHP,IHP2
 1512 FORMAT('      THE SPECIFIED SHAPE PARAMETER ',A4,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1513)IDIST
 1513 FORMAT('      FOR THE ',A30,' DISTRIBUTION')
      CALL DPWRST('XXX','BUG ')
      IF(LOWLTY.EQ.'>   ')THEN
        WRITE(ICOUT,1514)ILOWLM
 1514   FORMAT('      MUST BE STRICTLY LARGER THAN ',I10,';')
        CALL DPWRST('XXX','BUG ')
      ELSEIF(LOWLTY.EQ.'>=  ')THEN
        WRITE(ICOUT,1524)ILOWLM
 1524   FORMAT('      MUST BE LARGER THAN OR EQUAL TO ',I10,';')
        CALL DPWRST('XXX','BUG ')
      ENDIF
      WRITE(ICOUT,1515)
 1515 FORMAT('      SUCH WAS NOT THE CASE HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1516)IHP,IHP2,IPAR
 1516 FORMAT('      THE SPECIFIED VALUE OF ',A4,A4,' = ',I10)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
 1590 CONTINUE
C
      IF(UPPLTY.EQ.'<   ')THEN
        IF(IPAR.LT.IUPPLM)GOTO1690
      ELSEIF(UPPLTY.EQ.'<=  ')THEN
        IF(IPAR.LE.IUPPLM)GOTO1690
      ENDIF
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1611)ISUBN1,ISUBN2
 1611 FORMAT('***** ERROR IN ',A4,A4,'--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1612)IHP,IHP2
 1612 FORMAT('      THE SPECIFIED SHAPE PARAMETER ',A4,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1613)IDIST
 1613 FORMAT('      FOR THE ',A30,' DISTRIBUTION')
      CALL DPWRST('XXX','BUG ')
      IF(UPPLTY.EQ.'<   ')THEN
        WRITE(ICOUT,1614)IUPPLM
 1614   FORMAT('      MUST BE STRICTLY LESS THAN ',I10,';')
        CALL DPWRST('XXX','BUG ')
      ELSEIF(UPPLTY.EQ.'<=  ')THEN
        WRITE(ICOUT,1624)IUPPLM
 1624   FORMAT('      MUST BE LESS THAN OR EQUAL TO',I10,';')
        CALL DPWRST('XXX','BUG ')
      ENDIF
      WRITE(ICOUT,1615)
 1615 FORMAT('      SUCH WAS NOT THE CASE HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1616)IHP,IHP2,IPAR
 1616 FORMAT('      THE SPECIFIED VALUE OF ',A4,A4,' = ',I10)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
 1690 CONTINUE
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE PARCHR(IHP,IHP2,IDIST,
     1APAR,ALOWLM,AUPPLM,LOWLTY,UPPLTY,
     1ISUBN1,ISUBN2,IERROR)
C
C     PURPOSE--CHECK TO SEE IF A (REAL) PARAMETER IS IN 
C              A SPECIFIED RANGE.  UTILITY ROUTINE FOR
C              PROBABILITY PLOT, LAHEY COMPILER HAD TROUBLE
C              COMPILING DPPP.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--98/8
C     ORIGINAL VERSION--AUGUST    1998.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      INCLUDE 'DPCOPA.INC'
      INCLUDE 'DPCOHK.INC'
C
      CHARACTER*4 IHP
      CHARACTER*4 IHP2
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 LOWLTY
      CHARACTER*4 UPPLTY
      CHARACTER*30 IDIST
      CHARACTER*4 IERROR
C
      CHARACTER*4 IHWUSE
      CHARACTER*4 MESSAG
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
C
C               ************************************
C               **  STEP 1--                      **
C               **  CHECK FOR GAMMA DISTRIBUTION  **
C               **  PARAMETER GAMMA               **
C               ************************************
C
      IHWUSE='P'
      MESSAG='YES'
      CALL CHECKN(IHP,IHP2,IHWUSE,
     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
     1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR)
      IF(IERROR.EQ.'YES')GOTO9000
      APAR=VALUE(ILOCP)
C
      IF(LOWLTY.EQ.'>   ')THEN
        IF(APAR.GT.ALOWLM)GOTO1590
      ELSEIF(LOWLTY.EQ.'>=  ')THEN
        IF(APAR.GE.ALOWLM)GOTO1590
      ENDIF
      WRITE(ICOUT,999)
  999 FORMAT(' ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1511)ISUBN1,ISUBN2
 1511 FORMAT('***** ERROR IN ',A4,A4,'--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1512)IHP,IHP2
 1512 FORMAT('      THE SPECIFIED SHAPE PARAMETER ',A4,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1513)IDIST
 1513 FORMAT('      FOR THE ',A30,' DISTRIBUTION')
      CALL DPWRST('XXX','BUG ')
      IF(LOWLTY.EQ.'>   ')THEN
        WRITE(ICOUT,1514)ALOWLM
 1514   FORMAT('      MUST BE STRICTLY LARGER THAN ',F10.5,';')
        CALL DPWRST('XXX','BUG ')
      ELSEIF(LOWLTY.EQ.'>=  ')THEN
        WRITE(ICOUT,1524)ALOWLM
 1524   FORMAT('      MUST BE LARGER THAN OR EQUAL TO ',F10.5,';')
        CALL DPWRST('XXX','BUG ')
      ENDIF
      WRITE(ICOUT,1515)
 1515 FORMAT('      SUCH WAS NOT THE CASE HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1516)IHP,IHP2,APAR
 1516 FORMAT('      THE SPECIFIED VALUE OF ',A4,A4,' = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
 1590 CONTINUE
C
      IF(UPPLTY.EQ.'<   ')THEN
        IF(APAR.LT.AUPPLM)GOTO1690
      ELSEIF(UPPLTY.EQ.'<=  ')THEN
        IF(APAR.LE.AUPPLM)GOTO1690
      ENDIF
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1611)ISUBN1,ISUBN2
 1611 FORMAT('***** ERROR IN ',A4,A4,'--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1612)IHP,IHP2
 1612 FORMAT('      THE SPECIFIED SHAPE PARAMETER ',A4,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1613)IDIST
 1613 FORMAT('      FOR THE ',A30,' DISTRIBUTION')
      CALL DPWRST('XXX','BUG ')
      IF(UPPLTY.EQ.'<   ')THEN
        WRITE(ICOUT,1614)AUPPLM
 1614   FORMAT('      MUST BE STRICTLY LESS THAN ',F10.5,';')
        CALL DPWRST('XXX','BUG ')
      ELSEIF(UPPLTY.EQ.'<=  ')THEN
        WRITE(ICOUT,1624)AUPPLM
 1624   FORMAT('      MUST BE LESS THAN OR EQUAL TO',F10.5,';')
        CALL DPWRST('XXX','BUG ')
      ENDIF
      WRITE(ICOUT,1615)
 1615 FORMAT('      SUCH WAS NOT THE CASE HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1616)IHP,IHP2,APAR
 1616 FORMAT('      THE SPECIFIED VALUE OF ',A4,A4,' = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
 1690 CONTINUE
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE PARCH2(IHP,IHP2,IDIST,
     1APAR,APARDF,ALOWLM,AUPPLM,LOWLTY,UPPLTY,
     1ISUBN1,ISUBN2,IERROR)
C
C     PURPOSE--CHECK TO SEE IF A (REAL) PARAMETER IS IN 
C              A SPECIFIED RANGE.  UTILITY ROUTINE FOR
C              PPCC PLOT, KOLMOGOROV-SMIRNOV PLOT.
C              THIS IS SLIGHTLY MODIFIED VERSION OF PARCHR
C              (USED BY PROB PLOT, K-S AND CHI-SQUARE GOODNESS
C              OF FIT TESTS).  DISTINCTION IS THAT PARAMETER
C              IS OPTIONAL AND A SUITABLE DEFAULT VALUE IS
C              PROVIDED.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004/3
C     ORIGINAL VERSION--MARCH     2004.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      INCLUDE 'DPCOPA.INC'
      INCLUDE 'DPCOHK.INC'
C
      CHARACTER*4 IHP
      CHARACTER*4 IHP2
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 LOWLTY
      CHARACTER*4 UPPLTY
      CHARACTER*30 IDIST
      CHARACTER*4 IERROR
C
      CHARACTER*4 IHWUSE
      CHARACTER*4 MESSAG
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
C
C               ************************************
C               **  STEP 1--                      **
C               **  CHECK FOR PARAMETER           **
C               ************************************
C
      IHWUSE='P'
      MESSAG='NO'
      CALL CHECKN(IHP,IHP2,IHWUSE,
     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
     1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR)
      IF(IERROR.EQ.'YES')THEN
        APAR=APARDF
      ELSE
        APAR=VALUE(ILOCP)
      ENDIF
C
      IERROR='NO'
      IF(LOWLTY.EQ.'>   ')THEN
        IF(APAR.GT.ALOWLM)GOTO1590
      ELSEIF(LOWLTY.EQ.'>=  ')THEN
        IF(APAR.GE.ALOWLM)GOTO1590
      ENDIF
      WRITE(ICOUT,999)
  999 FORMAT(' ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1511)ISUBN1,ISUBN2
 1511 FORMAT('***** ERROR IN ',A4,A4,'--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1512)IHP,IHP2
 1512 FORMAT('      THE SPECIFIED SHAPE PARAMETER ',A4,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1513)IDIST
 1513 FORMAT('      FOR THE ',A30,' DISTRIBUTION')
      CALL DPWRST('XXX','BUG ')
      IF(LOWLTY.EQ.'>   ')THEN
        WRITE(ICOUT,1514)ALOWLM
 1514   FORMAT('      MUST BE STRICTLY LARGER THAN ',F10.5,';')
        CALL DPWRST('XXX','BUG ')
      ELSEIF(LOWLTY.EQ.'>=  ')THEN
        WRITE(ICOUT,1524)ALOWLM
 1524   FORMAT('      MUST BE LARGER THAN OR EQUAL TO ',F10.5,';')
        CALL DPWRST('XXX','BUG ')
      ENDIF
      WRITE(ICOUT,1515)
 1515 FORMAT('      SUCH WAS NOT THE CASE HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1516)IHP,IHP2,APAR
 1516 FORMAT('      THE SPECIFIED VALUE OF ',A4,A4,' = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
 1590 CONTINUE
C
      IF(UPPLTY.EQ.'<   ')THEN
        IF(APAR.LT.AUPPLM)GOTO1690
      ELSEIF(UPPLTY.EQ.'<=  ')THEN
        IF(APAR.LE.AUPPLM)GOTO1690
      ENDIF
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1611)ISUBN1,ISUBN2
 1611 FORMAT('***** ERROR IN ',A4,A4,'--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1612)IHP,IHP2
 1612 FORMAT('      THE SPECIFIED SHAPE PARAMETER ',A4,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1613)IDIST
 1613 FORMAT('      FOR THE ',A30,' DISTRIBUTION')
      CALL DPWRST('XXX','BUG ')
      IF(UPPLTY.EQ.'<   ')THEN
        WRITE(ICOUT,1614)AUPPLM
 1614   FORMAT('      MUST BE STRICTLY LESS THAN ',F10.5,';')
        CALL DPWRST('XXX','BUG ')
      ELSEIF(UPPLTY.EQ.'<=  ')THEN
        WRITE(ICOUT,1624)AUPPLM
 1624   FORMAT('      MUST BE LESS THAN OR EQUAL TO',F10.5,';')
        CALL DPWRST('XXX','BUG ')
      ENDIF
      WRITE(ICOUT,1615)
 1615 FORMAT('      SUCH WAS NOT THE CASE HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1616)IHP,IHP2,APAR
 1616 FORMAT('      THE SPECIFIED VALUE OF ',A4,A4,' = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
 1690 CONTINUE
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE PARCI2(IHP,IHP2,IDIST,
     1IPAR,IPARDF,ILOWLM,IUPPLM,LOWLTY,UPPLTY,
     1ISUBN1,ISUBN2,IERROR)
C
C     PURPOSE--CHECK TO SEE IF A (INTEGER) PARAMETER IS IN 
C              A SPECIFIED RANGE.  UTILITY ROUTINE FOR
C              PPCC PLOT AND KOLMOGOROV-SMIRNOV PLOT.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004/3
C     ORIGINAL VERSION--MARCH     2004.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      INCLUDE 'DPCOPA.INC'
      INCLUDE 'DPCOHK.INC'
C
      CHARACTER*4 IHP
      CHARACTER*4 IHP2
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 LOWLTY
      CHARACTER*4 UPPLTY
      CHARACTER*30 IDIST
      CHARACTER*4 IERROR
C
      CHARACTER*4 IHWUSE
      CHARACTER*4 MESSAG
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
C
C               ************************************
C               **  STEP 1--                      **
C               **  CHECK FOR GAMMA DISTRIBUTION  **
C               **  PARAMETER GAMMA               **
C               ************************************
C
      IHWUSE='P'
      MESSAG='NO'
      CALL CHECKN(IHP,IHP2,IHWUSE,
     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
     1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR)
      IF(IERROR.EQ.'YES')THEN
        IPAR=IPARDF
      ELSE
        IPAR=VALUE(ILOCP)+0.5
      ENDIF
      IERROR='NO'
C
      IF(LOWLTY.EQ.'>   ')THEN
        IF(IPAR.GT.ILOWLM)GOTO1590
      ELSEIF(LOWLTY.EQ.'>=  ')THEN
        IF(IPAR.GE.ILOWLM)GOTO1590
      ENDIF
      WRITE(ICOUT,999)
  999 FORMAT(' ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1511)ISUBN1,ISUBN2
 1511 FORMAT('***** ERROR IN ',A4,A4,'--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1512)IHP,IHP2
 1512 FORMAT('      THE SPECIFIED SHAPE PARAMETER ',A4,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1513)IDIST
 1513 FORMAT('      FOR THE ',A30,' DISTRIBUTION')
      CALL DPWRST('XXX','BUG ')
      IF(LOWLTY.EQ.'>   ')THEN
        WRITE(ICOUT,1514)ILOWLM
 1514   FORMAT('      MUST BE STRICTLY LARGER THAN ',I10,';')
        CALL DPWRST('XXX','BUG ')
      ELSEIF(LOWLTY.EQ.'>=  ')THEN
        WRITE(ICOUT,1524)ILOWLM
 1524   FORMAT('      MUST BE LARGER THAN OR EQUAL TO ',I10,';')
        CALL DPWRST('XXX','BUG ')
      ENDIF
      WRITE(ICOUT,1515)
 1515 FORMAT('      SUCH WAS NOT THE CASE HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1516)IHP,IHP2,IPAR
 1516 FORMAT('      THE SPECIFIED VALUE OF ',A4,A4,' = ',I10)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
 1590 CONTINUE
C
      IF(UPPLTY.EQ.'<   ')THEN
        IF(IPAR.LT.IUPPLM)GOTO1690
      ELSEIF(UPPLTY.EQ.'<=  ')THEN
        IF(IPAR.LE.IUPPLM)GOTO1690
      ENDIF
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1611)ISUBN1,ISUBN2
 1611 FORMAT('***** ERROR IN ',A4,A4,'--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1612)IHP,IHP2
 1612 FORMAT('      THE SPECIFIED SHAPE PARAMETER ',A4,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1613)IDIST
 1613 FORMAT('      FOR THE ',A30,' DISTRIBUTION')
      CALL DPWRST('XXX','BUG ')
      IF(UPPLTY.EQ.'<   ')THEN
        WRITE(ICOUT,1614)IUPPLM
 1614   FORMAT('      MUST BE STRICTLY LESS THAN ',I10,';')
        CALL DPWRST('XXX','BUG ')
      ELSEIF(UPPLTY.EQ.'<=  ')THEN
        WRITE(ICOUT,1624)IUPPLM
 1624   FORMAT('      MUST BE LESS THAN OR EQUAL TO',I10,';')
        CALL DPWRST('XXX','BUG ')
      ENDIF
      WRITE(ICOUT,1615)
 1615 FORMAT('      SUCH WAS NOT THE CASE HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1616)IHP,IHP2,IPAR
 1616 FORMAT('      THE SPECIFIED VALUE OF ',A4,A4,' = ',I10)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
 1690 CONTINUE
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE PARCDF(X,GAMMA,A,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE PARETO
C              DISTRIBUTION WITH SINGLE PRECISION 
C              TAIL LENGTH PARAMETER = GAMMA
C              AND LOCATION PARAMETER ALOC.
C              THE PARETO DISTRIBUTION USED
C              HEREIN IS DEFINED FOR ALL X GREATER THAN
C              OR EQUAL TO A, 
C              AND HAS THE CUMULATIVE DISTRIBUTION FUNCTION
C              F(X) = 1 - (A/X)**GAMMA
C
C              NOTE THAT ALTHOUGH A IS COMMONLY REFERRED TO AS A
C              LOCATION PARAMETER, IT IS NOT IN THE TECHNICAL
C              SENSE OF
C
C                 f(X;A) = f(X-A),0)
C
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE 
C                                AT WHICH THE CUMULATIVE DISTRIBUTION 
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE GREATER THAN
C                                OR EQUAL TO ALOC.
C                     --GAMMA  = THE SINGLE PRECISION VALUE 
C                                OF THE TAIL LENGTH PARAMETER.
C                                GAMMA SHOULD BE POSITIVE.
C                     --A      = THE SINGLE PRECISION VALUE 
C                                OF THE LOCATION PARAMETER.
C                                ALOC SHOULD BE NON-NEGATIVE.
C     OUTPUT ARGUMENTS--CDF    = THE SINGLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE CDF FOR THE PARETO
C             DISTRIBUTION WITH TAIL LENGTH PARAMETER VALUE = GAMMA
C             AND LOCATION PARAMETER A.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 
C     RESTRICTIONS--GAMMA AND A SHOULD BE POSITIVE.
C                 --X SHOULD BE GREATER THAN
C                   OR EQUAL TO A.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN. 
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1970, PAGES 233-249.
C               --HASTINGS AND PEACOCK, STATISTICAL
C                 DISTRIBUTIONS--A HANDBOOK FOR
C                 STUDENTS AND PRACTITIONERS, 1975,
C                 PAGE 102.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE:  301-975-2899
C     ORIGINAL VERSION--APRIL     1994. 
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(X.LT.A)THEN
        WRITE(ICOUT,4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,5)A
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9999
      ELSEIF(GAMMA.LE.0.0)THEN
        WRITE(ICOUT,15) 
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,16) 
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)GAMMA
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9999
      ELSEIF(A.LE.0.0)THEN
        WRITE(ICOUT,25) 
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,26) 
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)GAMMA
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9999
      ENDIF
    4 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO THE PARCDF ',
     1       'SUBROUTINE')
    5 FORMAT('      IS LESS THAN THE LOCATION PARAMETER ',G15.7,
     1       '******')
   15 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO THE PARCDF ',
     1       'SUBROUTINE')
   16 FORMAT('      (THE SHAPE PARAMETER) IS NON-POSITIVE *****')
   25 FORMAT('***** ERROR--THE THIRD INPUT ARGUMENT TO THE PARCDF ',
     1       'SUBROUTINE')
   26 FORMAT('      (THE LOCATION PARAMETER) IS NON-POSITIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
C-----START POINT-----------------------------------------------------
C
      CDF=1.0-(A/X)**GAMMA
C
 9999 CONTINUE
      RETURN
      END 
      SUBROUTINE PARCHA(X,GAMMA,A,HAZ)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE HAZARD
C              FUNCTION VALUE FOR THE PARETO
C              DISTRIBUTION WITH SINGLE PRECISION 
C              TAIL LENGTH PARAMETER = GAMMA
C              AND LOCATION PARAMETER = A.
C              THE PARETO DISTRIBUTION USED
C              HEREIN IS DEFINED FOR ALL X GREATER THAN
C              OR EQUAL TO A, 
C              AND HAS THE CUMULATIVE HAZARD FUNCTION
C              H(X) = GAMMA*LOG(X/A)
C
C              NOTE THAT ALTHOUGH A IS COMMONLY REFERRED TO AS A
C              LOCATION PARAMETER, IT IS NOT IN THE TECHNICAL
C              SENSE OF
C
C                 f(X;A) = f(X-A),0)
C
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE 
C                                AT WHICH THE PROBABILITY DENSITY 
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE GREATER THAN
C                                OR EQUAL TO ALOC.
C                     --GAMMA  = THE SINGLE PRECISION VALUE 
C                                OF THE TAIL LENGTH PARAMETER.
C                                GAMMA SHOULD BE POSITIVE.
C                     --A      = THE SINGLE PRECISION VALUE 
C                                OF THE LOCATION PARAMETER.
C                                ALOC SHOULD BE NON-NEGATIVE.
C     OUTPUT ARGUMENTS--HAZ    = THE SINGLE PRECISION
C                                CUMULATIVE HAZARD FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION CUMULATIVE HAZARD
C             FUNCTION VALUE FOR THE PARETO
C             DISTRIBUTION WITH TAIL LENGTH PARAMETER VALUE = GAMMA
C             AND LOCATION PARAMETER A.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 
C     RESTRICTIONS--GAMMA SHOULD BE POSITIVE.
C                 --X SHOULD BE GREATER THAN
C                   OR EQUAL TO A.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN. 
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1970, CHAPTER 20
C               --HASTINGS AND PEACOCK, STATISTICAL
C                 DISTRIBUTIONS--A HANDBOOK FOR
C                 STUDENTS AND PRACTITIONERS, 1975,
C                 PAGE 102.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE:  301-975-2855
C     ORIGINAL VERSION--APRIL     1998. 
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(X.LT.A)THEN
        WRITE(ICOUT,4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,5)A
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        HAZ=0.0
        GOTO9999
      ELSEIF(GAMMA.LE.0.0)THEN
        WRITE(ICOUT,15) 
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,16) 
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)GAMMA
        CALL DPWRST('XXX','BUG ')
        HAZ=0.0
        GOTO9999
      ELSEIF(A.LE.0.0)THEN
        WRITE(ICOUT,25) 
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,26) 
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)GAMMA
        CALL DPWRST('XXX','BUG ')
        HAZ=0.0
        GOTO9999
      ENDIF
    4 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO THE PARCHAZ ',
     1       'SUBROUTINE')
    5 FORMAT('      IS LESS THAN THE LOCATION PARAMETER ',G15.7,
     1       '******')
   15 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO THE PARCHAZ ',
     1       'SUBROUTINE')
   16 FORMAT('      (THE SHAPE PARAMETER) IS NON-POSITIVE *****')
   25 FORMAT('***** ERROR--THE THIRD INPUT ARGUMENT TO THE PARCHAZ ',
     1       'SUBROUTINE')
   26 FORMAT('      (THE LOCATION PARAMETER) IS NON-POSITIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
C-----START POINT-----------------------------------------------------
C
      HAZ=GAMMA*LOG(X/A)
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE PARHAZ(X,GAMMA,A,HAZ)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE HAZARD
C              FUNCTION VALUE FOR THE PARETO
C              DISTRIBUTION WITH SINGLE PRECISION 
C              TAIL LENGTH PARAMETER = GAMMA
C              AND LOCATION PARAMETER = A.
C              THE PARETO DISTRIBUTION USED
C              HEREIN IS DEFINED FOR ALL X GREATER THAN
C              OR EQUAL TO A, AND HAS THE HAZARD FUNCTION
C              H(X) = GAMMA / X
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE 
C                                AT WHICH THE PROBABILITY DENSITY 
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE GREATER THAN
C                                OR EQUAL TO ALOC.
C                     --GAMMA  = THE SINGLE PRECISION VALUE 
C                                OF THE TAIL LENGTH PARAMETER.
C                                GAMMA SHOULD BE POSITIVE.
C                     --A      = THE SINGLE PRECISION VALUE 
C                                OF THE LOCATION PARAMETER.
C                                ALOC SHOULD BE POSITIVE.
C     OUTPUT ARGUMENTS--HAZ    = THE SINGLE PRECISION
C                                HAZARD FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION HAZARD
C             FUNCTION VALUE PDF FOR THE PARETO
C             DISTRIBUTION WITH TAIL LENGTH PARAMETER VALUE = GAMMA
C             AND LOCATION PARAMETER A.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 
C     RESTRICTIONS--GAMMA AND A SHOULD BE POSITIVE.
C                 --X SHOULD BE GREATER THAN OR EQUAL TO A.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN. 
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1970, CHAPTER 20
C               --HASTINGS AND PEACOCK, STATISTICAL
C                 DISTRIBUTIONS--A HANDBOOK FOR
C                 STUDENTS AND PRACTITIONERS, 1975,
C                 PAGE 102.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE:  301-975-2855
C     ORIGINAL VERSION--APRIL     1998. 
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(X.LT.A)THEN
        WRITE(ICOUT,4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,5)A
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        HAZ=0.0
        GOTO9999
      ELSEIF(GAMMA.LE.0.0)THEN
        WRITE(ICOUT,15) 
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,16) 
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)GAMMA
        CALL DPWRST('XXX','BUG ')
        HAZ=0.0
        GOTO9999
      ELSEIF(A.LE.0.0)THEN
        WRITE(ICOUT,25) 
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,26) 
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)GAMMA
        CALL DPWRST('XXX','BUG ')
        HAZ=0.0
        GOTO9999
      ENDIF
    4 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO THE PARHAZ ',
     1       'SUBROUTINE')
    5 FORMAT('      IS LESS THAN THE LOCATION PARAMETER ',G15.7,
     1       '******')
   15 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO THE PARHAZ ',
     1       'SUBROUTINE')
   16 FORMAT('      (THE SHAPE PARAMETER) IS NON-POSITIVE *****')
   25 FORMAT('***** ERROR--THE THIRD INPUT ARGUMENT TO THE PARHAZ ',
     1       'SUBROUTINE')
   26 FORMAT('      (THE LOCATION PARAMETER) IS NON-POSITIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
C-----START POINT-----------------------------------------------------
C
      HAZ=GAMMA/X
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE PARPDF(X,GAMMA,A,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE PARETO
C              DISTRIBUTION WITH SINGLE PRECISION 
C              TAIL LENGTH PARAMETER = GAMMA.
C              THE PARETO DISTRIBUTION USED
C              HEREIN IS DEFINED FOR ALL X GREATER THAN
C              OR EQUAL TO A, 
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C              F(X) = GAMMA*A**GAMMA/(X**(GAMMA+1)).
C
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE 
C                                AT WHICH THE PROBABILITY DENSITY 
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE GREATER THAN
C                                OR EQUAL TO ALOC.
C                     --GAMMA  = THE SINGLE PRECISION VALUE 
C                                OF THE TAIL LENGTH PARAMETER.
C                                GAMMA SHOULD BE POSITIVE.
C                     --A      = THE SINGLE PRECISION VALUE 
C                                OF THE LOCATION PARAMETER.
C                                ALOC SHOULD BE NON-NEGATIVE.
C     OUTPUT ARGUMENTS--PDF    = THE SINGLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE PDF FOR THE PARETO
C             DISTRIBUTION WITH TAIL LENGTH PARAMETER VALUE = GAMMA
C             AND LOCATION PARAMETER A.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 
C     RESTRICTIONS--GAMMA SHOULD BE POSITIVE.
C                 --X SHOULD BE GREATER THAN OR EQUAL TO A.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN. 
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1970, PAGES 233-249.
C               --HASTINGS AND PEACOCK, STATISTICAL
C                 DISTRIBUTIONS--A HANDBOOK FOR
C                 STUDENTS AND PRACTITIONERS, 1975,
C                 PAGE 102.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE:  301-975-2855
C     ORIGINAL VERSION--APRIL     1994. 
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(X.LT.A)THEN
        WRITE(ICOUT,4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,5)A
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ELSEIF(GAMMA.LE.0.0)THEN
        WRITE(ICOUT,15) 
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,16) 
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)GAMMA
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ELSEIF(A.LE.0.0)THEN
        WRITE(ICOUT,25) 
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,26) 
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)GAMMA
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ENDIF
    4 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO THE PARPDF ',
     1       'SUBROUTINE')
    5 FORMAT('      IS LESS THAN THE LOCATION PARAMETER ',G15.7,
     1       '******')
   15 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO THE PARPDF ',
     1       'SUBROUTINE')
   16 FORMAT('      (THE SHAPE PARAMETER) IS NON-POSITIVE *****')
   25 FORMAT('***** ERROR--THE THIRD INPUT ARGUMENT TO THE PARPDF ',
     1       'SUBROUTINE')
   26 FORMAT('      (THE LOCATION PARAMETER) IS NON-POSITIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
C-----START POINT-----------------------------------------------------
C
      PDF=GAMMA*A**GAMMA/(X**(GAMMA+1.0))
C
 9999 CONTINUE
      RETURN
      END 
      SUBROUTINE PARPPF(P,GAMMA,A,PPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE PARETO
C              DISTRIBUTION WITH SINGLE PRECISION
C              TAIL LENGTH PARAMETER = GAMMA
C              AND LOCATION PARAMETER = A.
C              THE PARETO DISTRIBUTION USED
C              HEREIN IS DEFINED FOR ALL X GREATER THAN
C              OR EQUAL TO A,
C              AND HAS THE PERCENT POINT FUNCTION
C              G(P) = A*(1.0-P)**(-1.0/GAMMA)
C              NOTE THAT THE PERCENT POINT FUNCTION OF A DISTRIBUTION
C              IS IDENTICALLY THE SAME AS THE INVERSE CUMULATIVE
C              DISTRIBUTION FUNCTION OF THE DISTRIBUTION.
C
C              NOTE THAT ALTHOUGH A IS COMMONLY REFERRED TO AS A
C              LOCATION PARAMETER, IT IS NOT IN THE TECHNICAL
C              SENSE OF
C
C                 f(X;A) = f(X-A),0)
C
C     INPUT  ARGUMENTS--P      = THE SINGLE PRECISION VALUE
C                                (BETWEEN 0.0 (INCLUSIVELY)
C                                AND 1.0 (EXCLUSIVELY))
C                                AT WHICH THE PERCENT POINT
C                                FUNCTION IS TO BE EVALUATED.
C                     --GAMMA  = THE SINGLE PRECISION VALUE
C                                OF THE TAIL LENGTH PARAMETER.
C                                GAMMA SHOULD BE POSITIVE.
C                     --A      = THE SINGLE PRECISION VALUE 
C                                OF THE LOCATION PARAMETER.
C                                A SHOULD BE NON-NEGATIVE.
C     OUTPUT ARGUMENTS--PPF    = THE SINGLE PRECISION PERCENT
C                                POINT FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PERCENT POINT FUNCTION .
C             VALUE PPF FOR THE PARETO DISTRIBUTION
C             WITH TAIL LENGTH PARAMETER VALUE = GAMMA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--GAMMA AND A SHOULD BE POSITIVE.
C                 --P SHOULD BE BETWEEN 0.0 (INCLUSIVELY)
C                   AND 1.0 (EXCLUSIVELY).
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1970, PAGES 233-249.
C               --HASTINGS AND PEACOCK, STATISTICAL
C                 DISTRIBUTIONS--A HANDBOOK FOR
C                 STUDENTS AND PRACTITIONERS, 1975,
C                 PAGE 102.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--82.6
C     ORIGINAL VERSION--NOVEMBER  1975.
C     UPDATED         --DECEMBER  1981.
C     UPDATED         --MAY       1982.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(P.LT.0.0.OR.P.GE.1.0)THEN
        WRITE(ICOUT,1)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)P
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
        GOTO9999
      ELSEIF(GAMMA.LE.0.0)THEN
        WRITE(ICOUT,15) 
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,16) 
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)GAMMA
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
        GOTO9999
      ELSEIF(A.LE.0.0)THEN
        WRITE(ICOUT,25) 
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,26) 
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)GAMMA
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
        GOTO9999
      ENDIF
    1 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO THE ',
     1'PARPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE [0,1) INTERVAL')
   15 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO THE PARPPF ',
     1       'SUBROUTINE')
   16 FORMAT('      (THE SHAPE PARAMETER) IS NON-POSITIVE *****')
   25 FORMAT('***** ERROR--THE THIRD INPUT ARGUMENT TO THE PARPPF ',
     1       'SUBROUTINE')
   26 FORMAT('      (THE LOCATION PARAMETER) IS NON-POSITIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
      PPF=A*(1.0-P)**(-1.0/GAMMA)
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE PARRAN(N,GAMMA,A,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE PARETO DISTRIBUTION
C              WITH TAIL LENGTH PARAMETER VALUE = GAMMA.
C              THE PROTOTYPE PARETO DISTRIBUTION USED
C              HEREIN IS DEFINED FOR ALL X GREATER THAN
C              OR EQUAL TO 1,
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C              F(X) = GAMMA*A**GAMMA/(X**(GAMMA+1)).
C
C              NOTE THAT ALTHOUGH A IS COMMONLY REFERRED TO AS A
C              LOCATION PARAMETER, IT IS NOT IN THE TECHNICAL
C              SENSE OF
C
C                 f(X;A) = f(X-A),0)
C
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                     --A      = THE SINGLE PRECISION VALUE 
C                                OF THE LOCATION PARAMETER.
C                                A SHOULD BE NON-NEGATIVE.
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 PARETO DISTRIBUTION
C             WITH TAIL LENGTH PARAMETER VALUE = GAMMA
C             LOCATION PARAMETER VALUE = A
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C                 --GAMMA AND A 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--TOCHER, THE ART OF SIMULATION,
C                 1963, PAGES 14-15.
C               --HAMMERSLEY AND HANDSCOMB, MONTE CARLO METHODS,
C                 1964, PAGE 36.
C               --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1970, PAGES 233-249.
C               --HASTINGS AND PEACOCK, STATISTICAL
C                 DISTRIBUTIONS--A HANDBOOK FOR
C                 STUDENTS AND PRACTITIONERS, 1975,
C                 PAGE 104.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--82.6
C     ORIGINAL VERSION--NOVEMBER  1975.
C     UPDATED         --DECEMBER  1981.
C     UPDATED         --MAY       1982.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)THEN
        WRITE(ICOUT, 5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ELSEIF(GAMMA.LE.0.0)THEN
        WRITE(ICOUT,15) 
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,16) 
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)GAMMA
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ELSEIF(A.LE.0.0)THEN
        WRITE(ICOUT,25) 
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,26) 
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)GAMMA
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
    5 FORMAT('***** ERROR--THE REQUESTED NUMBER OF PARETO RANDOM ',
     1'NUMBERS IS NON-POSITIVE ******')
   15 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO THE PARPDF ',
     1       'SUBROUTINE')
   16 FORMAT('      (THE SHAPE PARAMETER) IS NON-POSITIVE *****')
   25 FORMAT('***** ERROR--THE THIRD INPUT ARGUMENT TO THE PARPDF ',
     1       'SUBROUTINE')
   26 FORMAT('      (THE LOCATION PARAMETER) IS NON-POSITIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
C
C     GENERATE N UNIFORM (0,1) RANDOM NUMBERS;
C
      CALL UNIRAN(N,ISEED,X)
C
C     GENERATE N PARETO DISTRIBUTION RANDOM NUMBERS
C     USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD.
C
      DO100I=1,N
      X(I)=A*(1.0-X(I))**(-1.0/GAMMA)
  100 CONTINUE
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE PA2CDF(X,GAMMA,A,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE PARETO TYPE II
C              DISTRIBUTION WITH SINGLE PRECISION TAIL LENGTH
C              PARAMETER = GAMMA AND LOCATION PARAMETER = A.
C              THE PARETO DISTRIBUTION USED HEREIN IS DEFINED FOR
C              ALL X GREATER THAN OR EQUAL TO 0, 
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C              F(X) = GAMMA*A**GAMMA/(X+A)**(GAMMA+1)
C              THE CUMULATIVE DISTRIBUTION FUNCTION IS:
C              F(X) = 1 - A**GAMMA/(X+A)**GAMMA
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE 
C                                AT WHICH THE CUMULATIVE DISTRIBUTION 
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE GREATER THAN
C                                OR EQUAL TO 1.
C                     --GAMMA  = THE SINGLE PRECISION VALUE 
C                                OF THE TAIL LENGTH PARAMETER.
C                                GAMMA SHOULD BE POSITIVE.
C                     --A      = THE SINGLE PRECISION VALUE 
C                                OF THE LOCATION PARAMETER.
C                                A 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 PARETO
C             DISTRIBUTION WITH TAIL LENGTH PARAMETER VALUE = GAMMA
C             AND LOCATION PARAMETER A.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 
C     RESTRICTIONS--GAMMA AND A SHOULD BE POSITIVE.
C                 --X SHOULD BE GREATER THAN
C                   OR EQUAL TO 0.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN. 
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--2, 1994, CHAPTER 20
C               --EVANS, HASTINGS AND PEACOCK, STATISTICAL
C                 DISTRIBUTIONS--CHAPTER 30
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE:  301-975-2899
C     ORIGINAL VERSION--OCTOBER   1995. 
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DCDF
      DOUBLE PRECISION DA
      DOUBLE PRECISION DG
      DOUBLE PRECISION DX
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(X.LT.0.0)THEN
        WRITE(ICOUT,4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9999
      ELSEIF(GAMMA.LE.0.0)THEN
        WRITE(ICOUT,15) 
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)GAMMA
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9999
      ELSEIF(A.LE.0.0)THEN
        WRITE(ICOUT,25) 
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)GAMMA
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9999
      ENDIF
    4 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO THE PA2CDF ',
     1       'SUBROUTINE IS NEGATIVE.')
   15 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO THE PA2CDF ',
     1       'SUBROUTINE IS NON-POSITIVE.')
   25 FORMAT('***** ERROR--THE THIRD INPUT ARGUMENT TO THE PA2CDF ',
     1       'SUBROUTINE IS NON-POSITIVE.')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
C-----START POINT-----------------------------------------------------
C
      DA=DBLE(A)
      DG=DBLE(GAMMA)
      DX=DBLE(X)
      DCDF=1.0D0 - DA**DG/((DX+DA)**DG)
      CDF=REAL(DCDF)
C
 9999 CONTINUE
      RETURN
      END 
      SUBROUTINE PA2PDF(X,GAMMA,A,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE PARETO DISTRIBUTION OF THE
C              SECOND KIND WITH SINGLE PRECISION TAIL LENGTH
C              PARAMETER = GAMMA AND LOCATION PARAMETER A.
C              THE PARETO DISTRIBUTION USED HEREIN IS DEFINED FOR
C              ALL X GREATER THAN OR EQUAL TO 0, 
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C              F(X) = GAMMA*A**GAMMA/(X+A)**(GAMMA+1)
C
C              NOTE THAT ALTHOUGH A IS COMMONLY REFERRED TO AS A
C              LOCATION PARAMETER, IT IS NOT IN THE TECHNICAL
C              SENSE OF
C
C                 f(X;A) = f(X-A),0)
C
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE 
C                                AT WHICH THE PROBABILITY DENSITY 
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE GREATER THAN
C                                OR EQUAL TO 1.
C                     --GAMMA  = THE SINGLE PRECISION VALUE 
C                                OF THE TAIL LENGTH PARAMETER.
C                                GAMMA SHOULD BE POSITIVE.
C                     --A      = THE SINGLE PRECISION VALUE 
C                                OF THE LOCATION PARAMETER.
C                                A SHOULD BE NON-NEGATIVE.
C     OUTPUT ARGUMENTS--PDF    = THE SINGLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE PDF FOR THE PARETO
C             DISTRIBUTION WITH TAIL LENGTH PARAMETER VALUE = GAMMA
C             AND LOCATION PARAMETER A.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 
C     RESTRICTIONS--GAMMA AND A SHOULD BE POSITIVE.
C                 --X SHOULD BE GREATER THAN OR EQUAL TO 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--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--2, 1994, CHAPTER 20
C               --EVANS, HASTINGS AND PEACOCK, STATISTICAL
C                 DISTRIBUTIONS--CHAPTER 30
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE:  301-975-2855
C     ORIGINAL VERSION--OCTOBER   1995. 
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DG
      DOUBLE PRECISION DA
      DOUBLE PRECISION DPDF
      DOUBLE PRECISION DTERM1
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(X.LT.0.0)THEN
        WRITE(ICOUT,4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ELSEIF(GAMMA.LE.0.0)THEN
        WRITE(ICOUT,15) 
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)GAMMA
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ELSEIF(A.LE.0.0)THEN
        WRITE(ICOUT,25) 
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)GAMMA
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ENDIF
    4 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO THE PA2PDF ',
     1       'SUBROUTINE IS NEGATIVE.')
   15 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO THE PA2PDF ',
     1       'SUBROUTINE IS NON-POSITIVE.')
   25 FORMAT('***** ERROR--THE THIRD INPUT ARGUMENT TO THE PA2PDF ',
     1       'SUBROUTINE IS NON-POSITIVE.')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
C-----START POINT-----------------------------------------------------
C
      DX=DBLE(X)
      DG=DBLE(GAMMA)
      DA=DBLE(A)
      DTERM1=DLOG(DG) + DG*DLOG(DA) - (DG+1.0D0)*DLOG(DX+DA)
      DPDF=DEXP(DTERM1)
      PDF=SNGL(DPDF)
C
 9999 CONTINUE
      RETURN
      END 
      SUBROUTINE PA2PPF(P,GAMMA,A,PPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT FUNCTION
C              VALUE FOR THE PARETO DISTRIBUTION OF THE SECOND KIND
C              WITH SINGLE PRECISION TAIL LENGTH PARAMETER = GAMMA
C              AND LOCATION PARAMETER A.
C              THE PARETO DISTRIBUTION USED HEREIN IS DEFINED FOR
C              ALL X GREATER THAN OR EQUAL TO 0, 
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C              F(X) = GAMMA*A**GAMMA/(X+A)**(GAMMA+1)
C
C              THE PERCENT POINT FUNCTION IS
C
C              G(P) = (A**GAMMA/(1-P))**(1/GAMMA) - A
C
C              NOTE THAT ALTHOUGH A IS COMMONLY REFERRED TO AS A
C              LOCATION PARAMETER, IT IS NOT IN THE TECHNICAL
C              SENSE OF
C
C                 f(X;A) = f(X-A),0)
C
C     INPUT  ARGUMENTS--P      = THE SINGLE PRECISION VALUE
C                                (BETWEEN 0.0 (INCLUSIVELY)
C                                AND 1.0 (EXCLUSIVELY))
C                                AT WHICH THE PERCENT POINT
C                                FUNCTION IS TO BE EVALUATED.
C                     --GAMMA  = THE SINGLE PRECISION VALUE
C                                OF THE TAIL LENGTH PARAMETER.
C                                GAMMA SHOULD BE POSITIVE.
C                     --A      = THE SINGLE PRECISION VALUE 
C                                OF THE LOCATION PARAMETER.
C                                A SHOULD BE POSITIVE.
C     OUTPUT ARGUMENTS--PPF    = THE SINGLE PRECISION PERCENT
C                                POINT FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PERCENT POINT FUNCTION .
C             VALUE PPF FOR THE PARETO DISTRIBUTION
C             WITH TAIL LENGTH PARAMETER VALUE = GAMMA AND LOCATION
C             PARAMETER = A.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--GAMMA AND A SHOULD BE POSITIVE.
C                 --P SHOULD BE BETWEEN 0.0 (EXCLUSIVELY)
C                   AND 1.0 (EXCLUSIVELY).
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--2, 1994, CHAPTER 20
C               --EVANS, HASTINGS AND PEACOCK, STATISTICAL
C                 DISTRIBUTIONS--CHAPTER 30
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--95/10
C     ORIGINAL VERSION--OCTOBER   1995.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DPPF
      DOUBLE PRECISION DP
      DOUBLE PRECISION DA
      DOUBLE PRECISION DG
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(P.LE.0.0.OR.P.GE.1.0)THEN
        WRITE(ICOUT,1)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)P
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
        GOTO9999
      ELSEIF(GAMMA.LE.0.0)THEN
        WRITE(ICOUT,15) 
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)GAMMA
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
        GOTO9999
      ELSEIF(A.LE.0.0)THEN
        WRITE(ICOUT,25) 
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)GAMMA
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
        GOTO9999
      ENDIF
    1 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO THE PA2PPF ',
     1       'SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL.')
   15 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO THE PA2PPF ',
     1       'SUBROUTINE IS NON-POSITIVE.')
   25 FORMAT('***** ERROR--THE THIRD INPUT ARGUMENT TO THE PA2PPF ',
     1       'SUBROUTINE IS NON-POSITIVE.')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
      DP=DBLE(P)
      DA=DBLE(A)
      DG=DBLE(GAMMA)
      DPPF=(DA**DG/(1.0D0-DP))**(1.0D0/DG) - DA
      PPF=REAL(DPPF)
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE PA2RAN(N,GAMMA,A,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE PARETO DISTRIBUTION OF THE SECOND KIND
C              WITH TAIL LENGTH PARAMETER VALUE = GAMMA AND
C              LOCATION PARAMETER A.
C              THE PARETO DISTRIBUTION USED HEREIN IS DEFINED FOR
C              ALL X GREATER THAN OR EQUAL TO 0, 
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C              F(X) = GAMMA*A**GAMMA/(X+A)**(GAMMA+1)
C
C              NOTE THAT ALTHOUGH A IS COMMONLY REFERRED TO AS A
C              LOCATION PARAMETER, IT IS NOT IN THE TECHNICAL
C              SENSE OF
C
C                 f(X;A) = f(X-A),0)
C
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                     --A      = THE SINGLE PRECISION VALUE 
C                                OF THE LOCATION PARAMETER.
C                                A 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 PARETO DISTRIBUTION OF THE SECOND KIND
C             WITH TAIL LENGTH PARAMETER VALUE = GAMMA AND
C             LOCATION PARAMETER A.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C                 --GAMMA SHOULD BE POSITIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--TOCHER, THE ART OF SIMULATION,
C                 1963, PAGES 14-15.
C               --HAMMERSLEY AND HANDSCOMB, MONTE CARLO METHODS,
C                 1964, PAGE 36.
C               --JOHNSON, KOTZ, AND BALAKRISHNAN, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1994.
C               --EVANS, HASTINGS AND PEACOCK, STATISTICAL
C                 DISTRIBUTIONS--THIRD EDITION, 2000.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--2003.6
C     ORIGINAL VERSION--JUNE      2003.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      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
      ELSEIF(GAMMA.LE.0.0)THEN
        WRITE(ICOUT,15)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)GAMMA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(A.LE.0.0)THEN
        WRITE(ICOUT,25)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)A
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
    5 FORMAT('***** ERROR--THE NUMBER OF REQUESTED PARETO SECOND ',
     1'KIND RANDOM NUMBERS IS NON-POSITIVE.')
   15 FORMAT('***** ERROR--THE SHAPE PARAMETER FOR THE PARETO ',
     1'SECOND KIND RANDOM NUMBERS IS NON-POSITIVE.')
   25 FORMAT('***** ERROR--THE LOCATION PARAMETER FOR THE PARETO ',
     1'SECOND KIND RANDOM NUMBERS IS NON-POSITIVE.')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
C
C     GENERATE N UNIFORM (0,1) RANDOM NUMBERS;
C
      CALL UNIRAN(N,ISEED,X)
C
C     GENERATE N PARETO SECOND KIND DISTRIBUTION RANDOM NUMBERS
C     USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD.
C
      DO100I=1,N
        CALL PA2PPF(X(I),GAMMA,A,PPF)
        X(I)=PPF
  100 CONTINUE
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE PASSB(NAC,IDO,IP,L1,IDL1,CC,C1,C2,CH,CH2,WA)    
C***BEGIN PROLOGUE  PASSB
C***REFER TO  CFFTB 
C***ROUTINES CALLED  (NONE)   
C***END PROLOGUE  PASSB  
      DIMENSION       CH(IDO,L1,IP)          ,CC(IDO,IP,L1)          ,
     1                C1(IDO,L1,IP)          ,WA(*)      ,C2(IDL1,IP),
     2                CH2(IDL1,IP) 
C***FIRST EXECUTABLE STATEMENT  PASSB   
      IDOT = IDO/2  
      IPP2 = IP+2   
      IPPH = (IP+1)/2    
      IDP = IP*IDO  
C    
      IF (IDO .LT. L1) GO TO 106   
      DO 103 J=2,IPPH    
         JC = IPP2-J
         DO 102 K=1,L1   
CDIR$ IVDEP    
            DO 101 I=1,IDO    
               CH(I,K,J) = CC(I,J,K)+CC(I,JC,K)   
               CH(I,K,JC) = CC(I,J,K)-CC(I,JC,K)  
  101       CONTINUE
  102    CONTINUE   
  103 CONTINUE 
      DO 105 K=1,L1 
CDIR$ IVDEP    
         DO 104 I=1,IDO  
            CH(I,K,1) = CC(I,1,K)  
  104    CONTINUE   
  105 CONTINUE 
      GO TO 112
  106 DO 109 J=2,IPPH    
         JC = IPP2-J
         DO 108 I=1,IDO  
CDIR$ IVDEP    
            DO 107 K=1,L1
               CH(I,K,J) = CC(I,J,K)+CC(I,JC,K)   
               CH(I,K,JC) = CC(I,J,K)-CC(I,JC,K)  
  107       CONTINUE
  108    CONTINUE   
  109 CONTINUE 
      DO 111 I=1,IDO
CDIR$ IVDEP    
         DO 110 K=1,L1   
            CH(I,K,1) = CC(I,1,K)  
  110    CONTINUE   
  111 CONTINUE 
  112 IDL = 2-IDO   
      INC = 0  
      DO 116 L=2,IPPH    
         LC = IPP2-L
         IDL = IDL+IDO   
CDIR$ IVDEP    
         DO 113 IK=1,IDL1
            C2(IK,L) = CH2(IK,1)+WA(IDL-1)*CH2(IK,2)   
            C2(IK,LC) = WA(IDL)*CH2(IK,IP)   
  113    CONTINUE   
         IDLJ = IDL 
         INC = INC+IDO   
         DO 115 J=3,IPPH 
            JC = IPP2-J  
            IDLJ = IDLJ+INC   
            IF (IDLJ .GT. IDP) IDLJ = IDLJ-IDP    
            WAR = WA(IDLJ-1)  
            WAI = WA(IDLJ)    
CDIR$ IVDEP    
            DO 114 IK=1,IDL1  
               C2(IK,L) = C2(IK,L)+WAR*CH2(IK,J)  
               C2(IK,LC) = C2(IK,LC)+WAI*CH2(IK,JC)    
  114       CONTINUE
  115    CONTINUE   
  116 CONTINUE 
      DO 118 J=2,IPPH    
CDIR$ IVDEP    
         DO 117 IK=1,IDL1
            CH2(IK,1) = CH2(IK,1)+CH2(IK,J)  
  117    CONTINUE   
  118 CONTINUE 
      DO 120 J=2,IPPH    
         JC = IPP2-J
CDIR$ IVDEP    
         DO 119 IK=2,IDL1,2   
            CH2(IK-1,J) = C2(IK-1,J)-C2(IK,JC)    
            CH2(IK-1,JC) = C2(IK-1,J)+C2(IK,JC)   
            CH2(IK,J) = C2(IK,J)+C2(IK-1,JC) 
            CH2(IK,JC) = C2(IK,J)-C2(IK-1,JC)
  119    CONTINUE   
  120 CONTINUE 
      NAC = 1  
      IF (IDO .EQ. 2) RETURN  
      NAC = 0  
      DO 121 IK=1,IDL1   
         C2(IK,1) = CH2(IK,1) 
  121 CONTINUE 
      DO 123 J=2,IP 
CDIR$ IVDEP    
         DO 122 K=1,L1   
            C1(1,K,J) = CH(1,K,J)  
            C1(2,K,J) = CH(2,K,J)  
  122    CONTINUE   
  123 CONTINUE 
      IF (IDOT .GT. L1) GO TO 127  
      IDIJ = 0 
      DO 126 J=2,IP 
         IDIJ = IDIJ+2   
         DO 125 I=4,IDO,2
            IDIJ = IDIJ+2
CDIR$ IVDEP    
            DO 124 K=1,L1
               C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)-WA(IDIJ)*CH(I,K,J)
               C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)+WA(IDIJ)*CH(I-1,K,J)  
  124       CONTINUE
  125    CONTINUE   
  126 CONTINUE 
      RETURN   
  127 IDJ = 2-IDO   
      DO 130 J=2,IP 
         IDJ = IDJ+IDO   
         DO 129 K=1,L1   
            IDIJ = IDJ   
CDIR$ IVDEP    
            DO 128 I=4,IDO,2  
               IDIJ = IDIJ+2  
               C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)-WA(IDIJ)*CH(I,K,J)
               C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)+WA(IDIJ)*CH(I-1,K,J)  
  128       CONTINUE
  129    CONTINUE   
  130 CONTINUE 
      RETURN   
      END 
      SUBROUTINE PART1(NW, W, M, LSTFI, LER, N, LV, LLIM, LT, LP,       PAR  120
     * MAXMC, Q, QT)
C  PART OF ACM 591 FOR ANOVA
C  ****************************** PART1 *****************************   PAR   10
C                                                                       PAR   20
C  RESTRUCTURES THE DATA (CELL FREQUENCIES) WHEN APPROPRIATE; CHECKS    PAR   30
C  FOR BALANCE AND ALTERNATIVE NON-ITERATIVE COMPUTATIONS; TURNS IBST   PAR   40
C  ON WHEN THE EFFECTIVE X MATRIX IS SQUARE OR THE EFFECTIVE D MATRIX   PAR   50
C  IS A SCALAR MULTIPLE OF THE IDENTITY. COMPUTES RANK WITHOUT ITERA-   PAR   60
C  TION IF POSSIBLE OR ITERATIVELY OTHERWISE WHEN THE RANK (R) OPTION   PAR   70
C  IS SPECIFIED; TURNS SWITCH IRST ON IF THE MAXIMUM NUMBER OF ITERA-   PAR   80
C  TIONS IS EXCEEDED IN COMPUTING RANK.                                 PAR   90
C                                                                       PAR  100
C  ******************************************************************   PAR  110
      COMMON /C1/ YPY, SSRM, SSEM, IIN, IOUT, IROPT, IVOPT, IGOPT,
     * IPOPT, IOFLAG, IBST, IHST, IRST, ISST, IXST, ICD, NSUBS, LPOUT,
     * NO1, IDF, IDFM, IDFR
      COMMON /C2/ NCELLS, LOCD1, LOCD2, LOCV, LOCB, LOCA, IRANKM,
     * IRANKR, MAXIT
      DIMENSION W(NW), LSTFI(M), LER(M), LV(N), LLIM(N), LT(N), LP(10)
      DIMENSION Q(MAXMC,MAXMC), QT(MAXMC)
      DOUBLE PRECISION W, C, S, TRACE, TEMP, Q, QT, YPY, SSRM, SSEM
C
      CHARACTER*4 IH, IM, ICD
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 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 IH /1HH/, IM /1HM/
      IHST = 0
      IRST = 0
      IBST = 0
      IRANK = 0
      IF (NSUBS.EQ.N) GO TO 100
C FORM RESTRUCTURED CELL FREQUENCY ARRAY (EFFECTIVE D MATRIX)
      DO 10 I=1,NCELLS
        ID1 = LOCD1 + I
        IA = LOCA + I
        W(IA) = W(ID1)
   10 CONTINUE
      CALL DECOMP(1, LOCA, IOUT, NW, W, M, LSTFI, N, LT, LV, LLIM, LP)
      NS = LOCA
      NN = M - NO1
      DO 20 I=1,NN
        NS = NS + LSTFI(I)
   20 CONTINUE
CNIST CALL LABEL(NO1, 0, LLIM, IOUT, N, LV, LP)
      CALL POOL(0, LOCD2, NS, NW, W, N, LLIM, LT, LP)
C CHECK FOR A SQUARE EFFECTIVE X MATRIX
   30 IF (IXST.EQ.1) GO TO 80
      K = LOCD2 + 1
      IFLAG = 0
      DO 40 I=1,NCELLS
        ID2 = LOCD2 + I
        IF (W(ID2).EQ.0.0) GO TO 130
        IF (W(ID2).NE.W(K)) IFLAG = 1
   40 CONTINUE
      IF (IFLAG.EQ.1) GO TO 70
C THE EFFECTIVE D MATRIX IS A SCALAR TIMES THE IDENTITY
      IRANK = IDF
   50 DO 60 I=1,NCELLS
        ID2 = LOCD2 + I
        W(ID2) = W(ID2)/FLOAT(LPOUT)
   60 CONTINUE
      C = 1.0D0
      IBST = 1
      GO TO 120
C ALL ELEMENTS OF THE EFFECTIVE D MATRIX ARE NONZERO
   70 IRANK = IDF
      GO TO 120
C THE EFFECTIVE X MATRIX IS SQUARE
   80 DO 90 I=1,NCELLS
        ID2 = LOCD2 + I
        IF (W(ID2).NE.0.0) IRANK = IRANK + 1
   90 CONTINUE
      IRANK = IRANK/LPOUT
      GO TO 50
  100 DO 110 I=1,NCELLS
        ID1 = LOCD1 + I
        ID2 = LOCD2 + I
        W(ID2) = W(ID1)
  110 CONTINUE
      GO TO 30
C RANK HAS BEEN DETERMINED (NONITERATIVELY OR ITERATIVELY)
  120 IF (ICD.EQ.IH) IRANKR = IRANK
      IF (ICD.EQ.IM) IRANKM = IRANK
      GO TO 370
  130 IF (ICD.EQ.IM) GO TO 140
      IRANKR = 0
      IF (IRANKM.NE.IDFM) GO TO 150
      IRANKR = IDFR
      IRANK = IDFR
      GO TO 370
  140 IRANKM = 0
  150 IF (IROPT.EQ.0) GO TO 380
C ITERATIVELY COMPUTE RANK OF FULL OR REDUCED MODEL
      C = 1.0D0
      RTOL = 0.1
      NMC = 0
      DO 160 I=1,NCELLS
        ID1 = LOCD1 + I
        ID2 = LOCD2 + I
        IF (W(ID1).EQ.0.0) NMC = NMC + 1
        W(ID2) = W(I)
  160 CONTINUE
      IF (NMC.GT.MAXMC) GO TO 310
C COMPUTE Q, POWERS OF Q, AND RELATED TRACES (FEW EMPTY CELLS)
      K = 1
      IVEC = 0
      DO 190 I=1,NCELLS
        ID1 = LOCD1 + I
        IF (W(ID1).NE.0.0) GO TO 190
        DO 170 J=1,NCELLS
          IV = LOCV + J
          IB = LOCB + J
          W(IV) = 0
          W(IB) = 0
          W(J) = 0
          IF (J.EQ.I) W(J) = 1.0D0
  170   CONTINUE
        CALL STEP(3, C, S, NW, W, M, LSTFI, LER, N, LV, LLIM, LT, LP)
        LL = 1
        DO 180 J=1,NCELLS
          ID1 = LOCD1 + J
          IV = LOCV + J
          IF (W(ID1).NE.0.0) GO TO 180
          Q(K,LL) = W(IV)
          LL = LL + 1
  180   CONTINUE
        K = K + 1
  190 CONTINUE
C POWER Q AND COMPUTE TR(I-Q**(2*K))
      TEMP = IDF
      DO 200 I=1,NMC
        TEMP = TEMP - Q(I,I)
  200 CONTINUE
      IT = 0
  210 IF (IOFLAG.EQ.1) THEN
        WRITE (ICOUT,99999) IT, TEMP
        CALL DPWRST('XXX','BUG ')
      ENDIF
99999 FORMAT (10H ITERATION, I3, 8H, TRACE=, F16.9)
      DO 250 J=1,NMC
        DO 230 I=J,NMC
          QT(I) = 0
          DO 220 K=1,NMC
            QT(I) = QT(I) + Q(K,J)*Q(K,I)
  220     CONTINUE
  230   CONTINUE
        DO 240 K=J,NMC
          Q(K,J) = QT(K)
  240   CONTINUE
  250 CONTINUE
      TRACE = IDF
      DO 270 I=1,NMC
        TRACE = TRACE - Q(I,I)
        DO 260 J=I,NMC
          Q(I,J) = Q(J,I)
  260   CONTINUE
  270 CONTINUE
      IT = IT + 1
      TEMP = TRACE - TEMP
C TRACE IS MONOTONICALLY INCREASING
      IF (TEMP.LE.RTOL) GO TO 280
      IF (IT.GE.MAXIT) GO TO 360
      TEMP = TRACE
      GO TO 210
  280 DO 290 I=1,NCELLS
        ID2 = LOCD2 + I
        W(I) = W(ID2)
  290 CONTINUE
C ADD ONE (BASED ON MONOTONICITY) TO OBTAIN INTEGER RANK
  300 IRANK = TRACE + 1.0D0
      GO TO 120
C COMPUTE S FOR UNIT VECTORS (MANY EMPTY CELLS)
  310 TRACE = 0
      RTOL = RTOL/(FLOAT(NCELLS)-FLOAT(NMC))
      DO 350 I=1,NCELLS
        ID1 = LOCD1 + I
        IF (W(ID1).EQ.0.0) GO TO 350
        DO 320 J=1,NCELLS
          IV = LOCV + J
          IB = LOCB + J
          W(IV) = 0
          W(IB) = 0
          W(J) = 0
          IF (J.EQ.I) W(J) = 1.0D0
  320   CONTINUE
        IT = 0
        TEMP = 0
  330   CALL STEP(3, C, S, NW, W, M, LSTFI, LER, N, LV, LLIM, LT, LP)
        IT = IT + 1
        TEMP = S - TEMP
C THE VALUE OF S IS MONOTONICALLY INCREASING
        IF (TEMP.LE.RTOL) GO TO 340
        IVEC = I
        IF (IT.GE.MAXIT) GO TO 360
        TEMP = S
        GO TO 330
  340   TRACE = TRACE + S
        IF (IOFLAG.EQ.1) THEN
          WRITE (ICOUT,99998) I, IT, TRACE
          CALL DPWRST('XXX','BUG ')
        ENDIF
99998   FORMAT (7H VECTOR, I4, 12H, ITERATIONS, I4, 8H, TRACE=, F16.9)
  350 CONTINUE
      GO TO 280
  360 CONTINUE
      WRITE (ICOUT,99997) MAXIT
      CALL DPWRST('XXX','BUG ')
99997 FORMAT (11H MAXIMUM OF, I4, 34H ITERATIONS EXCEEDED IN COMPUTING ,
     * 4HRANK)
      WRITE (ICOUT,89997) TEMP, RTOL, IVEC
      CALL DPWRST('XXX','BUG ')
89997 FORMAT (7H DELTA=, F22.9, 10X, 8HEPSILON=, F22.9, 10X, 7HVECTOR=,
     * I10)
      IF (NMC.GT.MAXMC) TRACE = TRACE + S
      IRST = 1
      GO TO 300
  370 IF (IROPT.EQ.1) THEN
        WRITE (ICOUT,99996) ICD, IRANK
        CALL DPWRST('XXX','BUG ')
      ENDIF
99996 FORMAT (17H THE RANK OF THE , A1, 17H DESIGN MATRIX IS, I5)
  380 RETURN
      END
      SUBROUTINE PART2(NW, W, M, LSTFI, LER, N, LE, LV, LLIM, LT, LP)   PAR  140
C  PART OF ACM 591 FOR ANOVA
C  ****************************** PART2 *****************************   PAR   10
C                                                                       PAR   20
C  COMPUTES SSE AND SSR FOR THE FULL MODEL (ICD = M); OUTPUTS ESTI-     PAR   30
C  MATES OF EXPECTED CELL MEANS (THE VECTOR V) WHEN THE V OPTION IS     PAR   40
C  SPECIFIED; COMPUTES A G-INVERSE SOLUTION TO THE NORMAL EQUATIONS     PAR   50
C  WHEN THE G OPTION IS SPECIFIED.  COMPUTES SSR FOR THE REDUCED MOD-   PAR   60
C  EL (ICD = H) AND AN F STATISTIC; COMPUTES PROBABILITY VALUES WHEN    PAR   70
C  THE P OPTION IS SPECIFIED.  ALL COMPUTATIONS ARE NON-ITERATIVE IF    PAR   80
C  SWITCH IBST IS ON (IBST = 1)                                         PAR   90
C                                                                       PAR  100
C  (SEE MAIN PROGRAM COMMENTS FOR A DESCRIPTION OF ARGUMENTS)           PAR  110
C                                                                       PAR  120
C  ******************************************************************   PAR  130
      COMMON /C1/ YPY, SSRM, SSEM, IIN, IOUT, IROPT, IVOPT, IGOPT,
     * IPOPT, IOFLAG, IBST, IHST, IRST, ISST, IXST, ICD, NSUBS, LPOUT,
     * NO1, IDF, IDFM, IDFR
      COMMON /C2/ NCELLS, LOCD1, LOCD2, LOCV, LOCB, LOCA, IRANKM,
     * IRANKR, MAXIT
      COMMON /C3/ NOBS, MAXDI, MINDI, FLEVEL, NOSIGD
      DIMENSION W(NW), LSTFI(M), LER(M), LE(N), LV(N), LLIM(N), LT(N),
     * LP(10)
      DOUBLE PRECISION W, C, S, TEMP, YPY, SSRM, SSEM, DABS, F
C
      CHARACTER*1 IBLANK, ISTAR, IM, IH, ISIG
      CHARACTER*4 ICD
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DATA IBLANK /1H /, ISTAR /1H*/, IM /1HM/, IH /1HH/
C
      FTOL = .005
      STOL = (.05*YPY)/(10.0**NOSIGD)
C ZERO THE VECTORS B AND V TO INITIALIZE THE ITERATIVE ALGORITHM
      DO 10 I=1,NCELLS
        IB = LOCB + I
        IV = LOCV + I
        W(IB) = 0
        W(IV) = 0
   10 CONTINUE
      IT = 0
      TEMP = 0
      IF (IBST.EQ.1) GO TO 260
      IF (ICD(1:1).EQ.IH) GO TO 170
C COMPUTE SSR FOR THE FULL MODEL USING OPTIMUM C FOR CONVERGENCE
      C = (FLOAT(MAXDI)+FLOAT(MINDI))/2.0
      IF (MINDI.EQ.0) C = MAXDI
   20 CALL STEP(1, C, S, NW, W, M, LSTFI, LER, N, LV, LLIM, LT, LP)
      IT = IT + 1
      TEMP = S - TEMP
      IF (IOFLAG.EQ.1) THEN
        WRITE (ICOUT,99999) IT, ICD(1:1), S
        CALL DPWRST('XXX','BUG ')
      ENDIF
99999 FORMAT (10H ITERATION, I4, 5H, SSR, A1, 1H=, E16.8)
      IF (DABS(TEMP).LE.STOL) GO TO 30
      IF (IT.GE.MAXIT) GO TO 160
      TEMP = S
      GO TO 20
C APPLY THE E OPERATOR TO THE VECTOR B
   30 DO 40 I=1,NCELLS
        IB = LOCB + I
        IA = LOCA + I
        W(IA) = W(IB)
   40 CONTINUE
      CALL DECOMP(0, LOCA, IOUT, NW, W, M, LSTFI, N, LT, LV, LLIM, LP)
C COMPUTE SSR AND SSE FOR THE FULL MODEL
   50 SSRM = S
      SSEM = YPY - S
      WRITE (ICOUT,99998) IT, SSRM
99998 FORMAT (10H ITERATION, I4, 18H, SSR(FULL MODEL)=, E16.8, 1H,)
      CALL DPWRST('XXX','BUG ')
      WRITE (ICOUT,89998) SSEM
89998 FORMAT (14X,18H  SSE(FULL MODEL)=, E16.8)
      CALL DPWRST('XXX','BUG ')
      IF (IVOPT.EQ.0) GO TO 70
      WRITE (ICOUT,99997)
99997 FORMAT (' ESTIMATES OF EXPECTED CELL MEANS-')
      CALL DPWRST('XXX','BUG ')
      WRITE (ICOUT,89997)
89997 FORMAT ('    CELL  ESTIMATED MEAN')
      CALL DPWRST('XXX','BUG ')
      DO 60 I=1,NCELLS
        ID1 = LOCD1 + I
        IV = LOCV + I
        IF (W(ID1).EQ.0.0) THEN
          WRITE (ICOUT,99996) I, W(IV)
          CALL DPWRST('XXX','BUG ')
        ENDIF
        IF (W(ID1).GT.0.0) THEN
          WRITE (ICOUT,99995) I, W(IV)
          CALL DPWRST('XXX','BUG ')
        ENDIF
   60 CONTINUE
99996 FORMAT (1H , I6, 1X, E16.8, 15H (MISSING CELL))
99995 FORMAT (1H , I6, 1X, E16.8)
   70 IF (IGOPT.EQ.0) GO TO 150
C COMPUTE THE G-INVERSE SOLUTION TO THE NORMAL EQUATIONS
      WRITE (ICOUT,99994)
99994 FORMAT (20H G-INVERSE SOLUTION-)
      CALL DPWRST('XXX','BUG ')
C POOL ARRAYS OF "ESTIMATES" WITH EQUAL E/R LIST VALUES
      NP = LOCA
      DO 140 I=1,M
        NO = LER(I)
        IF (NO.LE.0) GO TO 130
        NS = NP
        NOP = M - I + 1
CNIST   CALL LABEL(NOP, 0, LLIM, IOUT, N, LV, LP)
C POSITIVE VALUES IN LLIM WILL CORRESPOND TO SUBSCRIPTS IN PRIMARY
        DO 80 K=1,N
          IF (LP(K).EQ.0) LLIM(K) = -LLIM(K)
   80   CONTINUE
        DO 100 J=I,M
          IF (J.EQ.I) GO TO 90
          IF (LER(J).NE.NO) GO TO 90
          LER(J) = -NO
          NOS = M - J + 1
C OBTAIN MAP COEFFICIENTS FOR SECONDARY ARRAY AND POOL INTO PRIMARY
CNIST     CALL LABEL(NOS, 0, LLIM, IOUT, N, LV, LP)
          CALL POOL(1, NP, NS, NW, W, N, LLIM, LT, LP)
   90     NS = NS + LSTFI(J)
  100   CONTINUE
        DO 110 K=1,N
          LLIM(K) = IABS(LLIM(K))
  110   CONTINUE
C LABEL AND OUTPUT "ESTIMATES" FOR MODEL TERM
CNIST   CALL LABEL(NO, IBLANK, LE, IOUT, N, LV, LP)
        MST = LSTFI(I)
        DO 120 K=1,MST
          IA = NP + K
          WRITE (ICOUT,99995) K, W(IA)
          CALL DPWRST('XXX','BUG ')
  120   CONTINUE
  130   NP = NP + LSTFI(I)
  140 CONTINUE
  150 RETURN
  160 CONTINUE
      WRITE (ICOUT,99993) MAXIT, ICD(1:1)
99993 FORMAT (11H MAXIMUM OF, I4, 34H ITERATIONS EXCEEDED IN COMPUTING ,
     * 3HSSR, A1)
      CALL DPWRST('XXX','BUG ')
      WRITE (ICOUT,89993) TEMP, STOL
89993 FORMAT (7H DELTA=, E16.8, 10X, 8HEPSILON=, E16.8)
      CALL DPWRST('XXX','BUG ')
      GO TO 30
C SELECT C FOR MONOTONICITY OF SSR AND F
  170 C = MAXDI
C COMPUTE DEGREES OF FREEDOM TO USE FOR F STATISTIC
  180 IF (IRANKM.EQ.0) GO TO 190
      IF (IRANKR.EQ.0) GO TO 190
      IDFD = NOBS - IRANKM
      IDFN = IRANKM - IRANKR
      WRITE (ICOUT,99992) IDFN, IDFD
99992 FORMAT (33H FROM RANK COMPUTATIONS- DF(NUM)=, I4, 10H, DF(DEN)=,
     * I5)
      CALL DPWRST('XXX','BUG ')
      GO TO 200
  190 IDFD = NOBS - IDFM
      IDFN = IDFM - IDFR
      WRITE (ICOUT,99991) IDFN, IDFD
99991 FORMAT (50H ASSUMES FULL RANK AND EQUAL LEVELS WITH- DF(NUM)=,
     * I4, 10H, DF(DEN)=, I5)
      CALL DPWRST('XXX','BUG ')
  200 IF (IDFD*IDFN.LE.0) GO TO 150
      IF (IBST.EQ.1) GO TO 220
C COMPUTE MONOTONICALLY DECREASING APPROXIMATION TO F
  210 CALL STEP(1, C, S, NW, W, M, LSTFI, LER, N, LV, LLIM, LT, LP)
      IT = IT + 1
  220 F = ((SSRM-S)/FLOAT(IDFN))/(SSEM/FLOAT(IDFD))
      IF (IOFLAG.EQ.1) THEN
         WRITE (ICOUT,99999) IT, ICD(1:1), S
         CALL DPWRST('XXX','BUG ')
      ENDIF
C APPROXIMATION TO F PROBABILITY (SMILLIE AND ANSTEY)
      U1 = 2.0/(9.0*FLOAT(IDFN))
      U2 = 2.0/(9.0*FLOAT(IDFD))
      F1 = F**(1.0/3.0)
      U3 = ((1.0-U2)*F1-1.0+U1)/SQRT(2.0*(U2*F1*F1+U1))
      U = ABS(U3)
      PROB = 0.5/(1.0+(((.078108*U+.000972)*U+.230389)*U+.278393)*U)**4
      IF (U3.LT.0.0) PROB = 1.0 - PROB
      IF (IBST.EQ.1) GO TO 250
      IF (IPOPT.EQ.1) GO TO 230
      IF (PROB.GE.FLEVEL) GO TO 250
  230 TEMP = TEMP - F
      IF (DABS(TEMP).LE.FTOL) GO TO 250
      IF (IT.GE.MAXIT) GO TO 240
      TEMP = F
      GO TO 210
  240 CONTINUE
      WRITE (ICOUT,99993) MAXIT, ICD(1:1)
      CALL DPWRST('XXX','BUG ')
      WRITE (ICOUT,89993) TEMP, FTOL
      CALL DPWRST('XXX','BUG ')
  250 ISIG = ISTAR
      IF (PROB.GE.FLEVEL) ISIG = IBLANK
      WRITE (IOUT,99990) IT, F, ISIG, PROB, FLEVEL
99990 FORMAT (10H ITERATION, I4, 4H, F=, F12.3, A1, 15H, PROB(F) .GT. ,
     * F6.4, 16H VS. F LEVEL OF , F6.4)
      CALL DPWRST('XXX','BUG ')
      WRITE (IOUT,89990) S
89990 FORMAT (20H SSR(REDUCED MODEL)=, E16.8)
      CALL DPWRST('XXX','BUG ')
      GO TO 150
C BALANCED CASE; ONE ITERATION
  260 CALL STEP(2, C, S, NW, W, M, LSTFI, LER, N, LV, LLIM, LT, LP)
      IT = IT + 1
      IF (ICD(1:1).EQ.IM) GO TO 50
      GO TO 180
      END
      SUBROUTINE PASSB2(IDO,L1,CC,CH,WA1)    
C***BEGIN PROLOGUE  PASSB2    
C***REFER TO  CFFTB 
C***ROUTINES CALLED  (NONE)   
C***END PROLOGUE  PASSB2 
      DIMENSION       CC(IDO,2,L1)           ,CH(IDO,L1,2)           ,
     1                WA1(*)  
C***FIRST EXECUTABLE STATEMENT  PASSB2  
      IF (IDO .GT. 2) GO TO 102    
      DO 101 K=1,L1 
         CH(1,K,1) = CC(1,1,K)+CC(1,2,K)
         CH(1,K,2) = CC(1,1,K)-CC(1,2,K)
         CH(2,K,1) = CC(2,1,K)+CC(2,2,K)
         CH(2,K,2) = CC(2,1,K)-CC(2,2,K)
  101 CONTINUE 
      RETURN   
  102 IF(IDO/2.LT.L1) GO TO 105    
      DO 104 K=1,L1 
CDIR$ IVDEP    
         DO 103 I=2,IDO,2
            CH(I-1,K,1) = CC(I-1,1,K)+CC(I-1,2,K) 
            TR2 = CC(I-1,1,K)-CC(I-1,2,K)    
            CH(I,K,1) = CC(I,1,K)+CC(I,2,K)  
            TI2 = CC(I,1,K)-CC(I,2,K)   
            CH(I,K,2) = WA1(I-1)*TI2+WA1(I)*TR2   
            CH(I-1,K,2) = WA1(I-1)*TR2-WA1(I)*TI2 
  103    CONTINUE   
  104 CONTINUE 
      RETURN   
  105 DO 107 I=2,IDO,2   
CDIR$ IVDEP    
         DO 106 K=1,L1   
            CH(I-1,K,1) = CC(I-1,1,K)+CC(I-1,2,K) 
            TR2 = CC(I-1,1,K)-CC(I-1,2,K)    
            CH(I,K,1) = CC(I,1,K)+CC(I,2,K)  
            TI2 = CC(I,1,K)-CC(I,2,K)   
            CH(I,K,2) = WA1(I-1)*TI2+WA1(I)*TR2   
            CH(I-1,K,2) = WA1(I-1)*TR2-WA1(I)*TI2 
  106    CONTINUE   
  107 CONTINUE 
      RETURN   
      END 
      SUBROUTINE PASSB3(IDO,L1,CC,CH,WA1,WA2)
C***BEGIN PROLOGUE  PASSB3    
C***REFER TO  CFFTB 
C***ROUTINES CALLED  (NONE)   
C***END PROLOGUE  PASSB3 
      DIMENSION       CC(IDO,3,L1)           ,CH(IDO,L1,3)           ,
     1                WA1(*)     ,WA2(*)
C***FIRST EXECUTABLE STATEMENT  PASSB3  
      TAUR = -.5    
      TAUI = .5*SQRT(3.) 
      IF (IDO .NE. 2) GO TO 102    
      DO 101 K=1,L1 
         TR2 = CC(1,2,K)+CC(1,3,K) 
         CR2 = CC(1,1,K)+TAUR*TR2  
         CH(1,K,1) = CC(1,1,K)+TR2 
         TI2 = CC(2,2,K)+CC(2,3,K) 
         CI2 = CC(2,1,K)+TAUR*TI2  
         CH(2,K,1) = CC(2,1,K)+TI2 
         CR3 = TAUI*(CC(1,2,K)-CC(1,3,K))    
         CI3 = TAUI*(CC(2,2,K)-CC(2,3,K))    
         CH(1,K,2) = CR2-CI3  
         CH(1,K,3) = CR2+CI3  
         CH(2,K,2) = CI2+CR3  
         CH(2,K,3) = CI2-CR3  
  101 CONTINUE 
      RETURN   
  102 IF(IDO/2.LT.L1) GO TO 105    
      DO 104 K=1,L1 
CDIR$ IVDEP    
         DO 103 I=2,IDO,2
            TR2 = CC(I-1,2,K)+CC(I-1,3,K)    
            CR2 = CC(I-1,1,K)+TAUR*TR2  
            CH(I-1,K,1) = CC(I-1,1,K)+TR2    
            TI2 = CC(I,2,K)+CC(I,3,K)   
            CI2 = CC(I,1,K)+TAUR*TI2    
            CH(I,K,1) = CC(I,1,K)+TI2   
            CR3 = TAUI*(CC(I-1,2,K)-CC(I-1,3,K))  
            CI3 = TAUI*(CC(I,2,K)-CC(I,3,K)) 
            DR2 = CR2-CI3
            DR3 = CR2+CI3
            DI2 = CI2+CR3
            DI3 = CI2-CR3
            CH(I,K,2) = WA1(I-1)*DI2+WA1(I)*DR2   
            CH(I-1,K,2) = WA1(I-1)*DR2-WA1(I)*DI2 
            CH(I,K,3) = WA2(I-1)*DI3+WA2(I)*DR3   
            CH(I-1,K,3) = WA2(I-1)*DR3-WA2(I)*DI3 
  103    CONTINUE   
  104 CONTINUE 
      RETURN   
  105 DO 107 I=2,IDO,2   
CDIR$ IVDEP    
         DO 106 K=1,L1   
            TR2 = CC(I-1,2,K)+CC(I-1,3,K)    
            CR2 = CC(I-1,1,K)+TAUR*TR2  
            CH(I-1,K,1) = CC(I-1,1,K)+TR2    
            TI2 = CC(I,2,K)+CC(I,3,K)   
            CI2 = CC(I,1,K)+TAUR*TI2    
            CH(I,K,1) = CC(I,1,K)+TI2   
            CR3 = TAUI*(CC(I-1,2,K)-CC(I-1,3,K))  
            CI3 = TAUI*(CC(I,2,K)-CC(I,3,K)) 
            DR2 = CR2-CI3
            DR3 = CR2+CI3
            DI2 = CI2+CR3
            DI3 = CI2-CR3
            CH(I,K,2) = WA1(I-1)*DI2+WA1(I)*DR2   
            CH(I-1,K,2) = WA1(I-1)*DR2-WA1(I)*DI2 
            CH(I,K,3) = WA2(I-1)*DI3+WA2(I)*DR3   
            CH(I-1,K,3) = WA2(I-1)*DR3-WA2(I)*DI3 
  106    CONTINUE   
  107 CONTINUE 
      RETURN   
      END 
      SUBROUTINE PASSB4(IDO,L1,CC,CH,WA1,WA2,WA3) 
C***BEGIN PROLOGUE  PASSB4    
C***REFER TO  CFFTB 
C***ROUTINES CALLED  (NONE)   
C***END PROLOGUE  PASSB4 
      DIMENSION       CC(IDO,4,L1)           ,CH(IDO,L1,4)           ,
     1                WA1(*)     ,WA2(*)     ,WA3(*)   
C***FIRST EXECUTABLE STATEMENT  PASSB4  
      IF (IDO .NE. 2) GO TO 102    
      DO 101 K=1,L1 
         TI1 = CC(2,1,K)-CC(2,3,K) 
         TI2 = CC(2,1,K)+CC(2,3,K) 
         TR4 = CC(2,4,K)-CC(2,2,K) 
         TI3 = CC(2,2,K)+CC(2,4,K) 
         TR1 = CC(1,1,K)-CC(1,3,K) 
         TR2 = CC(1,1,K)+CC(1,3,K) 
         TI4 = CC(1,2,K)-CC(1,4,K) 
         TR3 = CC(1,2,K)+CC(1,4,K) 
         CH(1,K,1) = TR2+TR3  
         CH(1,K,3) = TR2-TR3  
         CH(2,K,1) = TI2+TI3  
         CH(2,K,3) = TI2-TI3  
         CH(1,K,2) = TR1+TR4  
         CH(1,K,4) = TR1-TR4  
         CH(2,K,2) = TI1+TI4  
         CH(2,K,4) = TI1-TI4  
  101 CONTINUE 
      RETURN   
  102 IF(IDO/2.LT.L1) GO TO 105    
      DO 104 K=1,L1 
CDIR$ IVDEP    
         DO 103 I=2,IDO,2
            TI1 = CC(I,1,K)-CC(I,3,K)   
            TI2 = CC(I,1,K)+CC(I,3,K)   
            TI3 = CC(I,2,K)+CC(I,4,K)   
            TR4 = CC(I,4,K)-CC(I,2,K)   
            TR1 = CC(I-1,1,K)-CC(I-1,3,K)    
            TR2 = CC(I-1,1,K)+CC(I-1,3,K)    
            TI4 = CC(I-1,2,K)-CC(I-1,4,K)    
            TR3 = CC(I-1,2,K)+CC(I-1,4,K)    
            CH(I-1,K,1) = TR2+TR3  
            CR3 = TR2-TR3
            CH(I,K,1) = TI2+TI3    
            CI3 = TI2-TI3
            CR2 = TR1+TR4
            CR4 = TR1-TR4
            CI2 = TI1+TI4
            CI4 = TI1-TI4
            CH(I-1,K,2) = WA1(I-1)*CR2-WA1(I)*CI2 
            CH(I,K,2) = WA1(I-1)*CI2+WA1(I)*CR2   
            CH(I-1,K,3) = WA2(I-1)*CR3-WA2(I)*CI3 
            CH(I,K,3) = WA2(I-1)*CI3+WA2(I)*CR3   
            CH(I-1,K,4) = WA3(I-1)*CR4-WA3(I)*CI4 
            CH(I,K,4) = WA3(I-1)*CI4+WA3(I)*CR4   
  103    CONTINUE   
  104 CONTINUE 
      RETURN   
  105 DO 107 I=2,IDO,2   
CDIR$ IVDEP    
         DO 106 K=1,L1   
            TI1 = CC(I,1,K)-CC(I,3,K)   
            TI2 = CC(I,1,K)+CC(I,3,K)   
            TI3 = CC(I,2,K)+CC(I,4,K)   
            TR4 = CC(I,4,K)-CC(I,2,K)   
            TR1 = CC(I-1,1,K)-CC(I-1,3,K)    
            TR2 = CC(I-1,1,K)+CC(I-1,3,K)    
            TI4 = CC(I-1,2,K)-CC(I-1,4,K)    
            TR3 = CC(I-1,2,K)+CC(I-1,4,K)    
            CH(I-1,K,1) = TR2+TR3  
            CR3 = TR2-TR3
            CH(I,K,1) = TI2+TI3    
            CI3 = TI2-TI3
            CR2 = TR1+TR4
            CR4 = TR1-TR4
            CI2 = TI1+TI4
            CI4 = TI1-TI4
            CH(I-1,K,2) = WA1(I-1)*CR2-WA1(I)*CI2 
            CH(I,K,2) = WA1(I-1)*CI2+WA1(I)*CR2   
            CH(I-1,K,3) = WA2(I-1)*CR3-WA2(I)*CI3 
            CH(I,K,3) = WA2(I-1)*CI3+WA2(I)*CR3   
            CH(I-1,K,4) = WA3(I-1)*CR4-WA3(I)*CI4 
            CH(I,K,4) = WA3(I-1)*CI4+WA3(I)*CR4   
  106    CONTINUE   
  107 CONTINUE 
      RETURN   
      END 
      SUBROUTINE PASSB5(IDO,L1,CC,CH,WA1,WA2,WA3,WA4)  
C***BEGIN PROLOGUE  PASSB5    
C***REFER TO  CFFTB 
C***ROUTINES CALLED  (NONE)   
C***END PROLOGUE  PASSB5 
      DIMENSION       CC(IDO,5,L1)           ,CH(IDO,L1,5)           ,
     1                WA1(*)     ,WA2(*)     ,WA3(*)     ,WA4(*) 
C***FIRST EXECUTABLE STATEMENT  PASSB5  
      PI = 4.*ATAN(1.)   
      TR11 = SIN(.1*PI)  
      TI11 = SIN(.4*PI)  
      TR12 = -SIN(.3*PI) 
      TI12 = SIN(.2*PI)  
      IF (IDO .NE. 2) GO TO 102    
      DO 101 K=1,L1 
         TI5 = CC(2,2,K)-CC(2,5,K) 
         TI2 = CC(2,2,K)+CC(2,5,K) 
         TI4 = CC(2,3,K)-CC(2,4,K) 
         TI3 = CC(2,3,K)+CC(2,4,K) 
         TR5 = CC(1,2,K)-CC(1,5,K) 
         TR2 = CC(1,2,K)+CC(1,5,K) 
         TR4 = CC(1,3,K)-CC(1,4,K) 
         TR3 = CC(1,3,K)+CC(1,4,K) 
         CH(1,K,1) = CC(1,1,K)+TR2+TR3  
         CH(2,K,1) = CC(2,1,K)+TI2+TI3  
         CR2 = CC(1,1,K)+TR11*TR2+TR12*TR3   
         CI2 = CC(2,1,K)+TR11*TI2+TR12*TI3   
         CR3 = CC(1,1,K)+TR12*TR2+TR11*TR3   
         CI3 = CC(2,1,K)+TR12*TI2+TR11*TI3   
         CR5 = TI11*TR5+TI12*TR4   
         CI5 = TI11*TI5+TI12*TI4   
         CR4 = TI12*TR5-TI11*TR4   
         CI4 = TI12*TI5-TI11*TI4   
         CH(1,K,2) = CR2-CI5  
         CH(1,K,5) = CR2+CI5  
         CH(2,K,2) = CI2+CR5  
         CH(2,K,3) = CI3+CR4  
         CH(1,K,3) = CR3-CI4  
         CH(1,K,4) = CR3+CI4  
         CH(2,K,4) = CI3-CR4  
         CH(2,K,5) = CI2-CR5  
  101 CONTINUE 
      RETURN   
  102 IF(IDO/2.LT.L1) GO TO 105    
      DO 104 K=1,L1 
CDIR$ IVDEP    
         DO 103 I=2,IDO,2
            TI5 = CC(I,2,K)-CC(I,5,K)   
            TI2 = CC(I,2,K)+CC(I,5,K)   
            TI4 = CC(I,3,K)-CC(I,4,K)   
            TI3 = CC(I,3,K)+CC(I,4,K)   
            TR5 = CC(I-1,2,K)-CC(I-1,5,K)    
            TR2 = CC(I-1,2,K)+CC(I-1,5,K)    
            TR4 = CC(I-1,3,K)-CC(I-1,4,K)    
            TR3 = CC(I-1,3,K)+CC(I-1,4,K)    
            CH(I-1,K,1) = CC(I-1,1,K)+TR2+TR3
            CH(I,K,1) = CC(I,1,K)+TI2+TI3    
            CR2 = CC(I-1,1,K)+TR11*TR2+TR12*TR3   
            CI2 = CC(I,1,K)+TR11*TI2+TR12*TI3
            CR3 = CC(I-1,1,K)+TR12*TR2+TR11*TR3   
            CI3 = CC(I,1,K)+TR12*TI2+TR11*TI3
            CR5 = TI11*TR5+TI12*TR4
            CI5 = TI11*TI5+TI12*TI4
            CR4 = TI12*TR5-TI11*TR4
            CI4 = TI12*TI5-TI11*TI4
            DR3 = CR3-CI4
            DR4 = CR3+CI4
            DI3 = CI3+CR4
            DI4 = CI3-CR4
            DR5 = CR2+CI5
            DR2 = CR2-CI5
            DI5 = CI2-CR5
            DI2 = CI2+CR5
            CH(I-1,K,2) = WA1(I-1)*DR2-WA1(I)*DI2 
            CH(I,K,2) = WA1(I-1)*DI2+WA1(I)*DR2   
            CH(I-1,K,3) = WA2(I-1)*DR3-WA2(I)*DI3 
            CH(I,K,3) = WA2(I-1)*DI3+WA2(I)*DR3   
            CH(I-1,K,4) = WA3(I-1)*DR4-WA3(I)*DI4 
            CH(I,K,4) = WA3(I-1)*DI4+WA3(I)*DR4   
            CH(I-1,K,5) = WA4(I-1)*DR5-WA4(I)*DI5 
            CH(I,K,5) = WA4(I-1)*DI5+WA4(I)*DR5   
  103    CONTINUE   
  104 CONTINUE 
      RETURN   
  105 DO 107 I=2,IDO,2   
CDIR$ IVDEP    
         DO 106 K=1,L1   
            TI5 = CC(I,2,K)-CC(I,5,K)   
            TI2 = CC(I,2,K)+CC(I,5,K)   
            TI4 = CC(I,3,K)-CC(I,4,K)   
            TI3 = CC(I,3,K)+CC(I,4,K)   
            TR5 = CC(I-1,2,K)-CC(I-1,5,K)    
            TR2 = CC(I-1,2,K)+CC(I-1,5,K)    
            TR4 = CC(I-1,3,K)-CC(I-1,4,K)    
            TR3 = CC(I-1,3,K)+CC(I-1,4,K)    
            CH(I-1,K,1) = CC(I-1,1,K)+TR2+TR3
            CH(I,K,1) = CC(I,1,K)+TI2+TI3    
            CR2 = CC(I-1,1,K)+TR11*TR2+TR12*TR3   
            CI2 = CC(I,1,K)+TR11*TI2+TR12*TI3
            CR3 = CC(I-1,1,K)+TR12*TR2+TR11*TR3   
            CI3 = CC(I,1,K)+TR12*TI2+TR11*TI3
            CR5 = TI11*TR5+TI12*TR4
            CI5 = TI11*TI5+TI12*TI4
            CR4 = TI12*TR5-TI11*TR4
            CI4 = TI12*TI5-TI11*TI4
            DR3 = CR3-CI4
            DR4 = CR3+CI4
            DI3 = CI3+CR4
            DI4 = CI3-CR4
            DR5 = CR2+CI5
            DR2 = CR2-CI5
            DI5 = CI2-CR5
            DI2 = CI2+CR5
            CH(I-1,K,2) = WA1(I-1)*DR2-WA1(I)*DI2 
            CH(I,K,2) = WA1(I-1)*DI2+WA1(I)*DR2   
            CH(I-1,K,3) = WA2(I-1)*DR3-WA2(I)*DI3 
            CH(I,K,3) = WA2(I-1)*DI3+WA2(I)*DR3   
            CH(I-1,K,4) = WA3(I-1)*DR4-WA3(I)*DI4 
            CH(I,K,4) = WA3(I-1)*DI4+WA3(I)*DR4   
            CH(I-1,K,5) = WA4(I-1)*DR5-WA4(I)*DI5 
            CH(I,K,5) = WA4(I-1)*DI5+WA4(I)*DR5   
  106    CONTINUE   
  107 CONTINUE 
      RETURN   
      END 
      SUBROUTINE PASSF(NAC,IDO,IP,L1,IDL1,CC,C1,C2,CH,CH2,WA)    
C***BEGIN PROLOGUE  PASSF
C***REFER TO  CFFTF 
C***ROUTINES CALLED  (NONE)   
C***END PROLOGUE  PASSF  
      DIMENSION       CH(IDO,L1,IP)          ,CC(IDO,IP,L1)          ,
     1                C1(IDO,L1,IP)          ,WA(*)      ,C2(IDL1,IP),
     2                CH2(IDL1,IP) 
C***FIRST EXECUTABLE STATEMENT  PASSF   
      IDOT = IDO/2  
      IPP2 = IP+2   
      IPPH = (IP+1)/2    
      IDP = IP*IDO  
C    
      IF (IDO .LT. L1) GO TO 106   
      DO 103 J=2,IPPH    
         JC = IPP2-J
         DO 102 K=1,L1   
CDIR$ IVDEP    
            DO 101 I=1,IDO    
               CH(I,K,J) = CC(I,J,K)+CC(I,JC,K)   
               CH(I,K,JC) = CC(I,J,K)-CC(I,JC,K)  
  101       CONTINUE
  102    CONTINUE   
  103 CONTINUE 
      DO 105 K=1,L1 
CDIR$ IVDEP    
         DO 104 I=1,IDO  
            CH(I,K,1) = CC(I,1,K)  
  104    CONTINUE   
  105 CONTINUE 
      GO TO 112
  106 DO 109 J=2,IPPH    
         JC = IPP2-J
         DO 108 I=1,IDO  
CDIR$ IVDEP    
            DO 107 K=1,L1
               CH(I,K,J) = CC(I,J,K)+CC(I,JC,K)   
               CH(I,K,JC) = CC(I,J,K)-CC(I,JC,K)  
  107       CONTINUE
  108    CONTINUE   
  109 CONTINUE 
      DO 111 I=1,IDO
CDIR$ IVDEP    
         DO 110 K=1,L1   
            CH(I,K,1) = CC(I,1,K)  
  110    CONTINUE   
  111 CONTINUE 
  112 IDL = 2-IDO   
      INC = 0  
      DO 116 L=2,IPPH    
         LC = IPP2-L
         IDL = IDL+IDO   
CDIR$ IVDEP    
         DO 113 IK=1,IDL1
            C2(IK,L) = CH2(IK,1)+WA(IDL-1)*CH2(IK,2)   
            C2(IK,LC) = -WA(IDL)*CH2(IK,IP)  
  113    CONTINUE   
         IDLJ = IDL 
         INC = INC+IDO   
         DO 115 J=3,IPPH 
            JC = IPP2-J  
            IDLJ = IDLJ+INC   
            IF (IDLJ .GT. IDP) IDLJ = IDLJ-IDP    
            WAR = WA(IDLJ-1)  
            WAI = WA(IDLJ)    
CDIR$ IVDEP    
            DO 114 IK=1,IDL1  
               C2(IK,L) = C2(IK,L)+WAR*CH2(IK,J)  
               C2(IK,LC) = C2(IK,LC)-WAI*CH2(IK,JC)    
  114       CONTINUE
  115    CONTINUE   
  116 CONTINUE 
      DO 118 J=2,IPPH    
CDIR$ IVDEP    
         DO 117 IK=1,IDL1
            CH2(IK,1) = CH2(IK,1)+CH2(IK,J)  
  117    CONTINUE   
  118 CONTINUE 
      DO 120 J=2,IPPH    
         JC = IPP2-J
CDIR$ IVDEP    
         DO 119 IK=2,IDL1,2   
            CH2(IK-1,J) = C2(IK-1,J)-C2(IK,JC)    
            CH2(IK-1,JC) = C2(IK-1,J)+C2(IK,JC)   
            CH2(IK,J) = C2(IK,J)+C2(IK-1,JC) 
            CH2(IK,JC) = C2(IK,J)-C2(IK-1,JC)
  119    CONTINUE   
  120 CONTINUE 
      NAC = 1  
      IF (IDO .EQ. 2) RETURN  
      NAC = 0  
CDIR$ IVDEP    
      DO 121 IK=1,IDL1   
         C2(IK,1) = CH2(IK,1) 
  121 CONTINUE 
      DO 123 J=2,IP 
CDIR$ IVDEP    
         DO 122 K=1,L1   
            C1(1,K,J) = CH(1,K,J)  
            C1(2,K,J) = CH(2,K,J)  
  122    CONTINUE   
  123 CONTINUE 
      IF (IDOT .GT. L1) GO TO 127  
      IDIJ = 0 
      DO 126 J=2,IP 
         IDIJ = IDIJ+2   
         DO 125 I=4,IDO,2
            IDIJ = IDIJ+2
CDIR$ IVDEP    
            DO 124 K=1,L1
               C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)+WA(IDIJ)*CH(I,K,J)
               C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)-WA(IDIJ)*CH(I-1,K,J)  
  124       CONTINUE
  125    CONTINUE   
  126 CONTINUE 
      RETURN   
  127 IDJ = 2-IDO   
      DO 130 J=2,IP 
         IDJ = IDJ+IDO   
         DO 129 K=1,L1   
            IDIJ = IDJ   
CDIR$ IVDEP    
            DO 128 I=4,IDO,2  
               IDIJ = IDIJ+2  
               C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)+WA(IDIJ)*CH(I,K,J)
               C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)-WA(IDIJ)*CH(I-1,K,J)  
  128       CONTINUE
  129    CONTINUE   
  130 CONTINUE 
      RETURN   
      END 
      SUBROUTINE PASSF2(IDO,L1,CC,CH,WA1)    
C***BEGIN PROLOGUE  PASSF2    
C***REFER TO  CFFTF 
C***ROUTINES CALLED  (NONE)   
C***END PROLOGUE  PASSF2 
      DIMENSION       CC(IDO,2,L1)           ,CH(IDO,L1,2)           ,
     1                WA1(*)  
C***FIRST EXECUTABLE STATEMENT  PASSF2  
      IF (IDO .GT. 2) GO TO 102    
      DO 101 K=1,L1 
         CH(1,K,1) = CC(1,1,K)+CC(1,2,K)
         CH(1,K,2) = CC(1,1,K)-CC(1,2,K)
         CH(2,K,1) = CC(2,1,K)+CC(2,2,K)
         CH(2,K,2) = CC(2,1,K)-CC(2,2,K)
  101 CONTINUE 
      RETURN   
  102 IF(IDO/2.LT.L1) GO TO 105    
      DO 104 K=1,L1 
CDIR$ IVDEP    
         DO 103 I=2,IDO,2
            CH(I-1,K,1) = CC(I-1,1,K)+CC(I-1,2,K) 
            TR2 = CC(I-1,1,K)-CC(I-1,2,K)    
            CH(I,K,1) = CC(I,1,K)+CC(I,2,K)  
            TI2 = CC(I,1,K)-CC(I,2,K)   
            CH(I,K,2) = WA1(I-1)*TI2-WA1(I)*TR2   
            CH(I-1,K,2) = WA1(I-1)*TR2+WA1(I)*TI2 
  103    CONTINUE   
  104 CONTINUE 
      RETURN   
  105 DO 107 I=2,IDO,2   
CDIR$ IVDEP    
      DO 106 K=1,L1 
            CH(I-1,K,1) = CC(I-1,1,K)+CC(I-1,2,K) 
            TR2 = CC(I-1,1,K)-CC(I-1,2,K)    
            CH(I,K,1) = CC(I,1,K)+CC(I,2,K)  
            TI2 = CC(I,1,K)-CC(I,2,K)   
            CH(I,K,2) = WA1(I-1)*TI2-WA1(I)*TR2   
            CH(I-1,K,2) = WA1(I-1)*TR2+WA1(I)*TI2 
  106    CONTINUE   
  107 CONTINUE 
      RETURN   
      END 
      SUBROUTINE PASSF3(IDO,L1,CC,CH,WA1,WA2)
C***BEGIN PROLOGUE  PASSF3    
C***REFER TO  CFFTF 
C***ROUTINES CALLED  (NONE)   
C***END PROLOGUE  PASSF3 
      DIMENSION       CC(IDO,3,L1)           ,CH(IDO,L1,3)           ,
     1                WA1(*)     ,WA2(*)
C***FIRST EXECUTABLE STATEMENT  PASSF3  
      TAUR = -.5    
      TAUI = -.5*SQRT(3.)
      IF (IDO .NE. 2) GO TO 102    
      DO 101 K=1,L1 
         TR2 = CC(1,2,K)+CC(1,3,K) 
         CR2 = CC(1,1,K)+TAUR*TR2  
         CH(1,K,1) = CC(1,1,K)+TR2 
         TI2 = CC(2,2,K)+CC(2,3,K) 
         CI2 = CC(2,1,K)+TAUR*TI2  
         CH(2,K,1) = CC(2,1,K)+TI2 
         CR3 = TAUI*(CC(1,2,K)-CC(1,3,K))    
         CI3 = TAUI*(CC(2,2,K)-CC(2,3,K))    
         CH(1,K,2) = CR2-CI3  
         CH(1,K,3) = CR2+CI3  
         CH(2,K,2) = CI2+CR3  
         CH(2,K,3) = CI2-CR3  
  101 CONTINUE 
      RETURN   
  102 IF(IDO/2.LT.L1) GO TO 105    
      DO 104 K=1,L1 
CDIR$ IVDEP    
         DO 103 I=2,IDO,2
            TR2 = CC(I-1,2,K)+CC(I-1,3,K)    
            CR2 = CC(I-1,1,K)+TAUR*TR2  
            CH(I-1,K,1) = CC(I-1,1,K)+TR2    
            TI2 = CC(I,2,K)+CC(I,3,K)   
            CI2 = CC(I,1,K)+TAUR*TI2    
            CH(I,K,1) = CC(I,1,K)+TI2   
            CR3 = TAUI*(CC(I-1,2,K)-CC(I-1,3,K))  
            CI3 = TAUI*(CC(I,2,K)-CC(I,3,K)) 
            DR2 = CR2-CI3
            DR3 = CR2+CI3
            DI2 = CI2+CR3
            DI3 = CI2-CR3
            CH(I,K,2) = WA1(I-1)*DI2-WA1(I)*DR2   
            CH(I-1,K,2) = WA1(I-1)*DR2+WA1(I)*DI2 
            CH(I,K,3) = WA2(I-1)*DI3-WA2(I)*DR3   
            CH(I-1,K,3) = WA2(I-1)*DR3+WA2(I)*DI3 
  103    CONTINUE   
  104 CONTINUE 
      RETURN   
  105 DO 107 I=2,IDO,2   
CDIR$ IVDEP    
         DO 106 K=1,L1   
            TR2 = CC(I-1,2,K)+CC(I-1,3,K)    
            CR2 = CC(I-1,1,K)+TAUR*TR2  
            CH(I-1,K,1) = CC(I-1,1,K)+TR2    
            TI2 = CC(I,2,K)+CC(I,3,K)   
            CI2 = CC(I,1,K)+TAUR*TI2    
            CH(I,K,1) = CC(I,1,K)+TI2   
            CR3 = TAUI*(CC(I-1,2,K)-CC(I-1,3,K))  
            CI3 = TAUI*(CC(I,2,K)-CC(I,3,K)) 
            DR2 = CR2-CI3
            DR3 = CR2+CI3
            DI2 = CI2+CR3
            DI3 = CI2-CR3
            CH(I,K,2) = WA1(I-1)*DI2-WA1(I)*DR2   
            CH(I-1,K,2) = WA1(I-1)*DR2+WA1(I)*DI2 
            CH(I,K,3) = WA2(I-1)*DI3-WA2(I)*DR3   
            CH(I-1,K,3) = WA2(I-1)*DR3+WA2(I)*DI3 
  106    CONTINUE   
  107 CONTINUE 
      RETURN   
      END 
      SUBROUTINE PASSF4(IDO,L1,CC,CH,WA1,WA2,WA3) 
C***BEGIN PROLOGUE  PASSF4    
C***REFER TO  CFFTF 
C***ROUTINES CALLED  (NONE)   
C***END PROLOGUE  PASSF4 
      DIMENSION       CC(IDO,4,L1)           ,CH(IDO,L1,4)           ,
     1                WA1(*)     ,WA2(*)     ,WA3(*)   
C***FIRST EXECUTABLE STATEMENT  PASSF4  
      IF (IDO .NE. 2) GO TO 102    
      DO 101 K=1,L1 
         TI1 = CC(2,1,K)-CC(2,3,K) 
         TI2 = CC(2,1,K)+CC(2,3,K) 
         TR4 = CC(2,2,K)-CC(2,4,K) 
         TI3 = CC(2,2,K)+CC(2,4,K) 
         TR1 = CC(1,1,K)-CC(1,3,K) 
         TR2 = CC(1,1,K)+CC(1,3,K) 
         TI4 = CC(1,4,K)-CC(1,2,K) 
         TR3 = CC(1,2,K)+CC(1,4,K) 
         CH(1,K,1) = TR2+TR3  
         CH(1,K,3) = TR2-TR3  
         CH(2,K,1) = TI2+TI3  
         CH(2,K,3) = TI2-TI3  
         CH(1,K,2) = TR1+TR4  
         CH(1,K,4) = TR1-TR4  
         CH(2,K,2) = TI1+TI4  
         CH(2,K,4) = TI1-TI4  
  101 CONTINUE 
      RETURN   
  102 IF(IDO/2.LT.L1) GO TO 105    
      DO 104 K=1,L1 
CDIR$ IVDEP    
         DO 103 I=2,IDO,2
            TI1 = CC(I,1,K)-CC(I,3,K)   
            TI2 = CC(I,1,K)+CC(I,3,K)   
            TI3 = CC(I,2,K)+CC(I,4,K)   
            TR4 = CC(I,2,K)-CC(I,4,K)   
            TR1 = CC(I-1,1,K)-CC(I-1,3,K)    
            TR2 = CC(I-1,1,K)+CC(I-1,3,K)    
            TI4 = CC(I-1,4,K)-CC(I-1,2,K)    
            TR3 = CC(I-1,2,K)+CC(I-1,4,K)    
            CH(I-1,K,1) = TR2+TR3  
            CR3 = TR2-TR3
            CH(I,K,1) = TI2+TI3    
            CI3 = TI2-TI3
            CR2 = TR1+TR4
            CR4 = TR1-TR4
            CI2 = TI1+TI4
            CI4 = TI1-TI4
            CH(I-1,K,2) = WA1(I-1)*CR2+WA1(I)*CI2 
            CH(I,K,2) = WA1(I-1)*CI2-WA1(I)*CR2   
            CH(I-1,K,3) = WA2(I-1)*CR3+WA2(I)*CI3 
            CH(I,K,3) = WA2(I-1)*CI3-WA2(I)*CR3   
            CH(I-1,K,4) = WA3(I-1)*CR4+WA3(I)*CI4 
            CH(I,K,4) = WA3(I-1)*CI4-WA3(I)*CR4   
  103    CONTINUE   
  104 CONTINUE 
      RETURN   
  105 DO 107 I=2,IDO,2   
CDIR$ IVDEP    
         DO 106 K=1,L1   
            TI1 = CC(I,1,K)-CC(I,3,K)   
            TI2 = CC(I,1,K)+CC(I,3,K)   
            TI3 = CC(I,2,K)+CC(I,4,K)   
            TR4 = CC(I,2,K)-CC(I,4,K)   
            TR1 = CC(I-1,1,K)-CC(I-1,3,K)    
            TR2 = CC(I-1,1,K)+CC(I-1,3,K)    
            TI4 = CC(I-1,4,K)-CC(I-1,2,K)    
            TR3 = CC(I-1,2,K)+CC(I-1,4,K)    
            CH(I-1,K,1) = TR2+TR3  
            CR3 = TR2-TR3
            CH(I,K,1) = TI2+TI3    
            CI3 = TI2-TI3
            CR2 = TR1+TR4
            CR4 = TR1-TR4
            CI2 = TI1+TI4
            CI4 = TI1-TI4
            CH(I-1,K,2) = WA1(I-1)*CR2+WA1(I)*CI2 
            CH(I,K,2) = WA1(I-1)*CI2-WA1(I)*CR2   
            CH(I-1,K,3) = WA2(I-1)*CR3+WA2(I)*CI3 
            CH(I,K,3) = WA2(I-1)*CI3-WA2(I)*CR3   
            CH(I-1,K,4) = WA3(I-1)*CR4+WA3(I)*CI4 
            CH(I,K,4) = WA3(I-1)*CI4-WA3(I)*CR4   
  106    CONTINUE   
  107 CONTINUE 
      RETURN   
      END 
      SUBROUTINE PASSF5(IDO,L1,CC,CH,WA1,WA2,WA3,WA4)  
C***BEGIN PROLOGUE  PASSF5    
C***REFER TO  CFFTF 
C***ROUTINES CALLED  (NONE)   
C***END PROLOGUE  PASSF5 
      DIMENSION       CC(IDO,5,L1)           ,CH(IDO,L1,5)           ,
     1                WA1(*)     ,WA2(*)     ,WA3(*)     ,WA4(*) 
C***FIRST EXECUTABLE STATEMENT  PASSF5  
      PI = 4.*ATAN(1.)   
      TR11 = SIN(.1*PI)  
      TI11 = -SIN(.4*PI) 
      TR12 = -SIN(.3*PI) 
      TI12 = -SIN(.2*PI) 
      IF (IDO .NE. 2) GO TO 102    
      DO 101 K=1,L1 
         TI5 = CC(2,2,K)-CC(2,5,K) 
         TI2 = CC(2,2,K)+CC(2,5,K) 
         TI4 = CC(2,3,K)-CC(2,4,K) 
         TI3 = CC(2,3,K)+CC(2,4,K) 
         TR5 = CC(1,2,K)-CC(1,5,K) 
         TR2 = CC(1,2,K)+CC(1,5,K) 
         TR4 = CC(1,3,K)-CC(1,4,K) 
         TR3 = CC(1,3,K)+CC(1,4,K) 
         CH(1,K,1) = CC(1,1,K)+TR2+TR3  
         CH(2,K,1) = CC(2,1,K)+TI2+TI3  
         CR2 = CC(1,1,K)+TR11*TR2+TR12*TR3   
         CI2 = CC(2,1,K)+TR11*TI2+TR12*TI3   
         CR3 = CC(1,1,K)+TR12*TR2+TR11*TR3   
         CI3 = CC(2,1,K)+TR12*TI2+TR11*TI3   
         CR5 = TI11*TR5+TI12*TR4   
         CI5 = TI11*TI5+TI12*TI4   
         CR4 = TI12*TR5-TI11*TR4   
         CI4 = TI12*TI5-TI11*TI4   
         CH(1,K,2) = CR2-CI5  
         CH(1,K,5) = CR2+CI5  
         CH(2,K,2) = CI2+CR5  
         CH(2,K,3) = CI3+CR4  
         CH(1,K,3) = CR3-CI4  
         CH(1,K,4) = CR3+CI4  
         CH(2,K,4) = CI3-CR4  
         CH(2,K,5) = CI2-CR5  
  101 CONTINUE 
      RETURN   
  102 IF(IDO/2.LT.L1) GO TO 105    
      DO 104 K=1,L1 
CDIR$ IVDEP    
         DO 103 I=2,IDO,2
            TI5 = CC(I,2,K)-CC(I,5,K)   
            TI2 = CC(I,2,K)+CC(I,5,K)   
            TI4 = CC(I,3,K)-CC(I,4,K)   
            TI3 = CC(I,3,K)+CC(I,4,K)   
            TR5 = CC(I-1,2,K)-CC(I-1,5,K)    
            TR2 = CC(I-1,2,K)+CC(I-1,5,K)    
            TR4 = CC(I-1,3,K)-CC(I-1,4,K)    
            TR3 = CC(I-1,3,K)+CC(I-1,4,K)    
            CH(I-1,K,1) = CC(I-1,1,K)+TR2+TR3
            CH(I,K,1) = CC(I,1,K)+TI2+TI3    
            CR2 = CC(I-1,1,K)+TR11*TR2+TR12*TR3   
            CI2 = CC(I,1,K)+TR11*TI2+TR12*TI3
            CR3 = CC(I-1,1,K)+TR12*TR2+TR11*TR3   
            CI3 = CC(I,1,K)+TR12*TI2+TR11*TI3
            CR5 = TI11*TR5+TI12*TR4
            CI5 = TI11*TI5+TI12*TI4
            CR4 = TI12*TR5-TI11*TR4
            CI4 = TI12*TI5-TI11*TI4
            DR3 = CR3-CI4
            DR4 = CR3+CI4
            DI3 = CI3+CR4
            DI4 = CI3-CR4
            DR5 = CR2+CI5
            DR2 = CR2-CI5
            DI5 = CI2-CR5
            DI2 = CI2+CR5
            CH(I-1,K,2) = WA1(I-1)*DR2+WA1(I)*DI2 
            CH(I,K,2) = WA1(I-1)*DI2-WA1(I)*DR2   
            CH(I-1,K,3) = WA2(I-1)*DR3+WA2(I)*DI3 
            CH(I,K,3) = WA2(I-1)*DI3-WA2(I)*DR3   
            CH(I-1,K,4) = WA3(I-1)*DR4+WA3(I)*DI4 
            CH(I,K,4) = WA3(I-1)*DI4-WA3(I)*DR4   
            CH(I-1,K,5) = WA4(I-1)*DR5+WA4(I)*DI5 
            CH(I,K,5) = WA4(I-1)*DI5-WA4(I)*DR5   
  103    CONTINUE   
  104 CONTINUE 
      RETURN   
  105 DO 107 I=2,IDO,2   
CDIR$ IVDEP    
         DO 106 K=1,L1   
            TI5 = CC(I,2,K)-CC(I,5,K)   
            TI2 = CC(I,2,K)+CC(I,5,K)   
            TI4 = CC(I,3,K)-CC(I,4,K)   
            TI3 = CC(I,3,K)+CC(I,4,K)   
            TR5 = CC(I-1,2,K)-CC(I-1,5,K)    
            TR2 = CC(I-1,2,K)+CC(I-1,5,K)    
            TR4 = CC(I-1,3,K)-CC(I-1,4,K)    
            TR3 = CC(I-1,3,K)+CC(I-1,4,K)    
            CH(I-1,K,1) = CC(I-1,1,K)+TR2+TR3
            CH(I,K,1) = CC(I,1,K)+TI2+TI3    
            CR2 = CC(I-1,1,K)+TR11*TR2+TR12*TR3   
            CI2 = CC(I,1,K)+TR11*TI2+TR12*TI3
            CR3 = CC(I-1,1,K)+TR12*TR2+TR11*TR3   
            CI3 = CC(I,1,K)+TR12*TI2+TR11*TI3
            CR5 = TI11*TR5+TI12*TR4
            CI5 = TI11*TI5+TI12*TI4
            CR4 = TI12*TR5-TI11*TR4
            CI4 = TI12*TI5-TI11*TI4
            DR3 = CR3-CI4
            DR4 = CR3+CI4
            DI3 = CI3+CR4
            DI4 = CI3-CR4
            DR5 = CR2+CI5
            DR2 = CR2-CI5
            DI5 = CI2-CR5
            DI2 = CI2+CR5
            CH(I-1,K,2) = WA1(I-1)*DR2+WA1(I)*DI2 
            CH(I,K,2) = WA1(I-1)*DI2-WA1(I)*DR2   
            CH(I-1,K,3) = WA2(I-1)*DR3+WA2(I)*DI3 
            CH(I,K,3) = WA2(I-1)*DI3-WA2(I)*DR3   
            CH(I-1,K,4) = WA3(I-1)*DR4+WA3(I)*DI4 
            CH(I,K,4) = WA3(I-1)*DI4-WA3(I)*DR4   
            CH(I-1,K,5) = WA4(I-1)*DR5+WA4(I)*DI5 
            CH(I,K,5) = WA4(I-1)*DI5-WA4(I)*DR5   
  106    CONTINUE   
  107 CONTINUE 
      RETURN   
      END 
      SUBROUTINE PBDV(V,X,DV,DP,PDF,PDD)
C
C       ====================================================
C       Purpose: Compute parabolic cylinder functions Dv(x)
C                and their derivatives
C       Input:   x --- Argument of Dv(x)
C                v --- Order of Dv(x)
C       Output:  DV(na) --- Dn+v0(x)
C                DP(na) --- Dn+v0'(x)
C                ( na = |n|, v0 = v-n, |v0| < 1, 
C                  n = 0,ñ1,ñ2,úúú )
C                PDF --- Dv(x)
C                PDD --- Dv'(x)
C       Routines called:
C             (1) DVSA for computing Dv(x) for small |x|
C             (2) DVLA for computing Dv(x) for large |x|
C       ====================================================
C
        IMPLICIT DOUBLE PRECISION (A-H,O-Z)
        DIMENSION DV(0:*),DP(0:*)
        XA=DABS(X)
        VH=V
        V=V+DSIGN(1.0D0,V)
        NV=INT(V)
        V0=V-NV
        NA=ABS(NV)
        EP=DEXP(-.25D0*X*X)
        IF (NA.GE.1) JA=1
        IF (V.GE.0.0) THEN
           IF (V0.EQ.0.0) THEN
              PD0=EP
              PD1=X*EP
           ELSE
              DO 10 L=0,JA
                 V1=V0+L
                 IF (XA.LE.5.8) CALL DVSA(V1,X,PD1)
                 IF (XA.GT.5.8) CALL DVLA(V1,X,PD1)
                 IF (L.EQ.0) PD0=PD1
10            CONTINUE
           ENDIF
           DV(0)=PD0
           DV(1)=PD1
           DO 15 K=2,NA
              PDF=X*PD1-(K+V0-1.0D0)*PD0
              DV(K)=PDF
              PD0=PD1
15            PD1=PDF
        ELSE
           IF (X.LE.0.0) THEN
              IF (XA.LE.5.8D0)  THEN
                 CALL DVSA(V0,X,PD0)
                 V1=V0-1.0D0
                 CALL DVSA(V1,X,PD1)
              ELSE
                 CALL DVLA(V0,X,PD0)
                 V1=V0-1.0D0
                 CALL DVLA(V1,X,PD1)
              ENDIF
              DV(0)=PD0
              DV(1)=PD1
              DO 20 K=2,NA
                 PD=(-X*PD1+PD0)/(K-1.0D0-V0)
                 DV(K)=PD
                 PD0=PD1
20               PD1=PD
           ELSE IF (X.LE.2.0) THEN
              V2=NV+V0
              IF (NV.EQ.0) V2=V2-1.0D0
              NK=INT(-V2)
              CALL DVSA(V2,X,F1)
              V1=V2+1.0D0
              CALL DVSA(V1,X,F0)
              DV(NK)=F1
              DV(NK-1)=F0
              DO 25 K=NK-2,0,-1
                 F=X*F0+(K-V0+1.0D0)*F1
                 DV(K)=F
                 F1=F0
25               F0=F
           ELSE
              IF (XA.LE.5.8) CALL DVSA(V0,X,PD0)
              IF (XA.GT.5.8) CALL DVLA(V0,X,PD0)
              DV(0)=PD0
              M=100+NA
              F1=0.0D0
              F0=1.0D-30
              DO 30 K=M,0,-1
                 F=X*F0+(K-V0+1.0D0)*F1
                 IF (K.LE.NA) DV(K)=F
                 F1=F0
30               F0=F
              S0=PD0/F
              DO 35 K=0,NA
35               DV(K)=S0*DV(K)
           ENDIF
        ENDIF
        DO 40 K=0,NA-1
           V1=ABS(V0)+K
           IF (V.GE.0.0D0) THEN
              DP(K)=0.5D0*X*DV(K)-DV(K+1)
           ELSE
              DP(K)=-0.5D0*X*DV(K)-V1*DV(K+1)
           ENDIF
40      CONTINUE
        PDF=DV(NA-1)
        PDD=DP(NA-1)
        V=VH
        RETURN
        END
      SUBROUTINE PBNCOR(X,Y,N,IWRITE,XTEMP1,XTEMP2,MAXNXT,PBCORR,BETA,
     1                  IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE
C              SAMPLE PERCENTAGE BEND CORRELATION
C              OF THE DATA IN THE INPUT VECTORS X AND Y.
C              THIS IS A ROBUST MEASURE OF SCALE DESCRIBED IN
C              "INTRODUCTION TO ROBUST ESTIMATION AND HYPOTHESIS
C              TESTING", RAND R. WILCOX, ACADEMIC PRESS, 1997.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF
C                                (UNSORTED OR SORTED) OBSERVATIONS.
C                     --Y      = 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--PBCORR = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED SAMPLE PERCENTAGE BEND
C                                CORRELATION.
C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
C             SAMPLE PERCENTAGE BEND CORRELATION (WITH DENOMINATOR N-1).
C     OTHER DATAPAC   SUBROUTINES NEEDED--MEDIAN AND SORT.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--"INTRODUCTION TO ROBUST ESTIMATION AND HYPOTHESIS
C                 TESTING", RAND R. WILCOX, ACADEMIC PRESS, 1997.
C                 COMPUTATIONAL STEPS DESCRIBED IN THIS REFERENCE.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-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--2002/7
C     ORIGINAL VERSION--JULY      2002.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 IWRIT2
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
C
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
      DOUBLE PRECISION DTERM4
      DOUBLE PRECISION DTERM5
      DOUBLE PRECISION DTERM6
C
      DIMENSION X(*)
      DIMENSION Y(*)
      DIMENSION XTEMP1(*)
      DIMENSION XTEMP2(*)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
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='NCOR'
      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 PBNCOR--')
      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               **  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 PBNCOR--')
      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 PERCENTAGE BEND CORRELATION 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 PBNCOR--',
     1'THE SECOND INPUT ARGUMENT (N) HAS THE VALUE 1')
      CALL DPWRST('XXX','BUG ')
      PBCORR=0.0
      GOTO9000
  129 CONTINUE
C
  190 CONTINUE
C
C               *************************************************
C               **  STEP 2--                                   **
C               **  COMPUTE THE PERCENTAGE BEND CORRELATION.   **
C               *************************************************
C
      IWRIT2='OFF'
C
      CALL MEDIAN(X,N,IWRIT2,XTEMP1,MAXNXT,XMED,IBUGA3,IERROR)
      CALL MEDIAN(Y,N,IWRIT2,XTEMP1,MAXNXT,YMED,IBUGA3,IERROR)
C
      DO300I=1,N
        XTEMP1(I)=ABS(X(I)-XMED)
        XTEMP2(I)=ABS(Y(I)-YMED)
  300 CONTINUE
C
      IF(BETA.LE.0.01 .OR. BETA.GT.0.99)THEN
        WRITE(ICOUT,121)
  321   FORMAT('***** NON-FATAL DIAGNOSTIC IN PBNCOR--',
     1         'THE VALUE OF BETA OUTSIDE THE (0.01,0.99) INTERVAL.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,323)
  323   FORMAT('      DEFAULT VALUE OF 0.1 USED.')
        CALL DPWRST('XXX','BUG ')
        BETA=0.1
      ENDIF
C
      CALL SORT(XTEMP1,N,XTEMP1)
      CALL SORT(XTEMP2,N,XTEMP2)
C
      AN=REAL(N)
      AM=(1.0 - BETA)*AN + 0.5
      M=INT(AM)
      WBETAX=XTEMP1(M)
      WBETAY=XTEMP2(M)
C
      I1=0
      I2=0
      I3=0
      I6=0
      I7=0
      I8=0
      DTERM1=0.0D0
      DTERM6=0.0D0
      DO400I=1,N
        IF(ABS((X(I)-XMED)/WBETAX).LE.1.0)THEN
          DTERM1=DTERM1 + X(I)
          I3=I3 + 1
        ELSEIF((X(I)-XMED)/WBETAX.LT.-1.0)THEN
          I1=I1 + 1
        ELSEIF((X(I)-XMED)/WBETAX.GT.1.0)THEN
          I2=I2 + 1
        ENDIF
C
        IF(ABS((Y(I)-YMED)/WBETAY).LE.1.0)THEN
          DTERM6=DTERM6 + Y(I)
          I8=I8+1
        ELSEIF((Y(I)-YMED)/WBETAY.LT.-1.0)THEN
          I6=I6 + 1
        ELSEIF((Y(I)-YMED)/WBETAY.GT.1.0)THEN
          I7=I7 + 1
        ENDIF
  400 CONTINUE
      PHIX=(WBETAX*REAL(I2-I1) + REAL(DTERM1))/REAL(N - I1 - I2)
      PHIY=(WBETAY*REAL(I7-I6) + REAL(DTERM6))/REAL(N - I6 - I7)
C
      DTERM1=0.0D0
      DTERM2=0.0D0
      DTERM3=0.0D0
      DO500I=1,N
        UI=(X(I) - PHIX)/WBETAX
        VI=(Y(I) - PHIY)/WBETAY
        DTERM4=MAX(-1.0D0,MIN(1.0D0,DBLE(UI)))
        DTERM5=MAX(-1.0D0,MIN(1.0D0,DBLE(VI)))
        DTERM1=DTERM1 + DTERM4*DTERM4
        DTERM2=DTERM2 + DTERM5*DTERM5
        DTERM3=DTERM3 + DTERM4*DTERM5
  500 CONTINUE
      DTERM4=0.0D0
      IF(DTERM1*DTERM2.GT.0.0D0)DTERM4=DTERM3/DSQRT(DTERM1*DTERM2)
      PBCORR=REAL(DTERM4)
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,PBCORR
  811 FORMAT('THE PERCENTAGE BEND CORRELATION 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 PBNCOR--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IBUGA3,IERROR
 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)N
 9013 FORMAT('N = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9014)XMED,WBETAX,YMED,WBETAY
 9014 FORMAT('XMED,WBETAX,YMED,WBETAY = ',4E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9015)PBCORR
 9015 FORMAT('PBCORR = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9016)DTERM1,DTERM2,DTERM3,DTERM3
 9016 FORMAT('DTERM1,DTERM2,DTERM3,DTERM3 = ',4D15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9018)I1,I2,I3,I6,I7,I8
 9018 FORMAT('I1,I2,I3,I6,I7,I8 = ',6I8)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE PBNMDV(X,N,IWRITE,XTEMP,MAXNXT,PBMDVA,BETA,
     1                  IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE
C              SAMPLE PERCENTAGE BEND MIDVARIANCE
C              OF THE DATA IN THE INPUT VECTOR X.
C              THIS IS A ROBUST MEASURE OF SCALE DESCRIBED IN
C              "INTRODUCTION TO ROBUST ESTIMATION AND HYPOTHESIS
C              TESTING", RAND R. WILCOX, ACADEMIC PRESS, 1997.
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--PBMDVA    = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED SAMPLE PERCENTAGE BEND MIDVARIANCE.
C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
C             SAMPLE PERCENTAGE BEND MIDVARIANCE (WITH DENOMINATOR N-1).
C     OTHER DATAPAC   SUBROUTINES NEEDED--MEDIAN AND SORT.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--"INTRODUCTION TO ROBUST ESTIMATION AND HYPOTHESIS
C                 TESTING", RAND R. WILCOX, ACADEMIC PRESS, 1997.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-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--2002/7
C     ORIGINAL VERSION--JULY      2002.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 IWRIT2
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
C
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
      DOUBLE PRECISION DTERM4
C
      DIMENSION X(*)
      DIMENSION XTEMP(*)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='NMDV '
      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 PBNMDV--')
      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(N.GE.1)GOTO119
      IERROR='YES'
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,111)
  111 FORMAT('***** ERROR IN PBNMDV--')
      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 PERCENTAGE BEND MIDVARIANCE 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 PBNMDV--',
     1'THE SECOND INPUT ARGUMENT (N) HAS THE VALUE 1')
      CALL DPWRST('XXX','BUG ')
      PBMDVA=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 PBNMDV--',
     1'THE FIRST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      PBMDVA=0.0
      GOTO9000
  139 CONTINUE
C
  190 CONTINUE
C
C               *************************************************
C               **  STEP 2--                                   **
C               **  COMPUTE THE PERCENTAGE BEND MIDVARIANCE.   **
C               *************************************************
C
      IWRIT2='OFF'
      CALL MEDIAN(X,N,IWRIT2,XTEMP,MAXNXT,XMED,IBUGA3,IERROR)
C
      DO300I=1,N
      XTEMP(I)=ABS(X(I)-XMED)
  300 CONTINUE
C
      IF(BETA.LE.0.01 .OR. BETA.GT.0.99)THEN
        WRITE(ICOUT,121)
  321   FORMAT('***** NON-FATAL DIAGNOSTIC IN PBNMDV--',
     1         'THE VALUE OF BETA OUTSIDE THE (0.01,0.99) INTERVAL.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,323)
  323   FORMAT('      DEFAULT VALUE OF 0.1 USED.')
        CALL DPWRST('XXX','BUG ')
        BETA=0.1
      ENDIF
C
      CALL SORT(XTEMP,N,XTEMP)
      AN=REAL(N)
      AM=(1.0 - BETA)*AN + 0.5
      M=INT(AM)
      WBETA=XTEMP(M)
C
      DTERM2=0.0D0
      DO400I=1,N
      X(I)=(X(I) - XMED)/WBETA
      IF(ABS(X(I)).LT.1.0)DTERM2=DTERM2+1.0D0
  400 CONTINUE
      DTERM2=DTERM2*DTERM2
C
      DTERM1=DBLE(WBETA)/DTERM2
      DTERM1=DTERM1*DBLE(WBETA)*DBLE(N)
      DTERM3=0.0D0
      DO500I=1,N
        DTERM4=MAX(-1.0D0,MIN(1.0D0,DBLE(X(I))))
        DTERM3=DTERM3 + DTERM4*DTERM4
  500 CONTINUE
      PBMDVA=REAL(DTERM1*DTERM3)
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,PBMDVA
  811 FORMAT('THE PERCENTAGE BEND MIDVARIANCE 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 PBNMDV--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IBUGA3,IERROR
 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)N
 9013 FORMAT('N = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9014)XMED,WBETA
 9014 FORMAT('XMED,WBETA = ',2E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9015)PBMDVA
 9015 FORMAT('PBMDVA = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9016)DTERM1,DTERM2,DTERM3,DTERM4
 9016 FORMAT('DTERM1,DTERM2,DTERM3,DTERM4 = ',4D15.7)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE PBVV(V,X,VV,VP,PVF,PVD)
C
C       ===================================================
C       Purpose: Compute parabolic cylinder functions Vv(x)
C                and their derivatives
C       Input:   x --- Argument of Vv(x)
C                v --- Order of Vv(x)
C       Output:  VV(na) --- Vv(x)
C                VP(na) --- Vv'(x)
C                ( na = |n|, v = n+v0, |v0| < 1
C                  n = 0,ñ1,ñ2,úúú )
C                PVF --- Vv(x)
C                PVD --- Vv'(x)
C       Routines called:
C             (1) VVSA for computing Vv(x) for small |x|
C             (2) VVLA for computing Vv(x) for large |x|
C       ===================================================
C
        IMPLICIT DOUBLE PRECISION (A-H,O-Z)
        DIMENSION VV(0:*),VP(0:*)
        PI=3.141592653589793D0
        XA=DABS(X)
        VH=V
        V=V+DSIGN(1.0D0,V)
        NV=INT(V)
        V0=V-NV
        NA=ABS(NV)
        QE=DEXP(0.25D0*X*X)
        Q2P=DSQRT(2.0D0/PI)
        IF (NA.GE.1) JA=1
        IF (V.LE.0.0) THEN
           IF (V0.EQ.0.0) THEN
              IF (XA.LE.7.5) CALL VVSA(V0,X,PV0)
              IF (XA.GT.7.5) CALL VVLA(V0,X,PV0)
              F0=Q2P*QE
              F1=X*F0
              VV(0)=PV0
              VV(1)=F0
              VV(2)=F1
           ELSE
              DO 10 L=0,JA
                 V1=V0-L
                 IF (XA.LE.7.5) CALL VVSA(V1,X,F1)
                 IF (XA.GT.7.5) CALL VVLA(V1,X,F1)
                 IF (L.EQ.0) F0=F1
10            CONTINUE
              VV(0)=F0
              VV(1)=F1
           ENDIF
           KV=2
           IF (V0.EQ.0.0) KV=3
           DO 15 K=KV,NA
              F=X*F1+(K-V0-2.0D0)*F0
              VV(K)=F
              F0=F1
15            F1=F
        ELSE
           IF (X.GE.0.0.AND.X.LE.7.5D0) THEN
              V2=V
              IF (V2.LT.1.0) V2=V2+1.0D0
              CALL VVSA(V2,X,F1)
              V1=V2-1.0D0
              KV=INT(V2)
              CALL VVSA(V1,X,F0)
              VV(KV)=F1
              VV(KV-1)=F0
              DO 20 K=KV-2,0,-1
                 F=X*F0-(K+V0+2.0D0)*F1
                 IF (K.LE.NA) VV(K)=F
                 F1=F0
20               F0=F
           ELSE IF (X.GT.7.5D0) THEN
              CALL VVLA(V0,X,PV0)
              M=100+ABS(NA)
              VV(1)=PV0
              F1=0.0D0
              F0=1.0D-40
              DO 25 K=M,0,-1
                 F=X*F0-(K+V0+2.0D0)*F1
                 IF (K.LE.NA) VV(K)=F
                 F1=F0
25               F0=F
              S0=PV0/F
              DO 30 K=0,NA
30               VV(K)=S0*VV(K)
           ELSE
              IF (XA.LE.7.5D0) THEN
                 CALL VVSA(V0,X,F0)
                 V1=V0+1.0
                 CALL VVSA(V1,X,F1)
              ELSE
                 CALL VVLA(V0,X,F0)
                 V1=V0+1.0D0
                 CALL VVLA(V1,X,F1)
              ENDIF
              VV(0)=F0
              VV(1)=F1
              DO 35 K=2,NA
                 F=(X*F1-F0)/(K+V0)
                 VV(K)=F
                 F0=F1
35               F1=F
           ENDIF
        ENDIF
        DO 40 K=0,NA-1
           V1=V0+K
           IF (V.GE.0.0D0) THEN
              VP(K)=0.5D0*X*VV(K)-(V1+1.0D0)*VV(K+1)
           ELSE
              VP(K)=-0.5D0*X*VV(K)+VV(K+1)
           ENDIF
40      CONTINUE
        PVF=VV(NA-1)
        PVD=VP(NA-1)
        V=VH
        RETURN
        END
        SUBROUTINE PBWA(A,X,W1F,W1D,W2F,W2D)
C
C       ======================================================
C       Purpose: Compute parabolic cylinder functions W(a,ñx)
C                and their derivatives
C       Input  : a --- Parameter  ( 0 ó |a| ó 5 )
C                x --- Argument of W(a,ñx)  ( 0 ó |x| ó 5 )
C       Output : W1F --- W(a,x)
C                W1D --- W'(a,x)
C                W2F --- W(a,-x)
C                W2D --- W'(a,-x)
C       Routine called:
C               CGAMA for computing complex gamma function
C       ======================================================
C
        IMPLICIT DOUBLE PRECISION (A,B,D-H,O-Y)
CCCCC   IMPLICIT COMPLEX *16 (C,Z)
        DIMENSION H(100),D(100)
        EPS=1.0D-15
        P0=0.59460355750136D0
        IF (A.EQ.0.0D0) THEN
           G1=3.625609908222D0
           G2=1.225416702465D0
        ELSE
           X1=0.25D0
           Y1=0.5D0*A
           CALL CGAMA(X1,Y1,1,UGR,UGI)
           G1=DSQRT(UGR*UGR+UGI*UGI)
           X2=0.75D0
           CALL CGAMA(X2,Y1,1,VGR,VGI)
           G2=DSQRT(VGR*VGR+VGI*VGI)
        ENDIF
        F1=DSQRT(G1/G2)
        F2=DSQRT(2.0D0*G2/G1)
        H0=1.0D0
        H1=A
        H(1)=A
        DO 10 L1=4,200,2
           M=L1/2
           HL=A*H1-0.25D0*(L1-2.0D0)*(L1-3.0D0)*H0
           H(M)=HL
           H0=H1
10         H1=HL
        Y1F=1.0D0
        R=1.0D0
        DO 15 K=1,100
           R=0.5D0*R*X*X/(K*(2.0D0*K-1.0D0))
           R1=H(K)*R
           Y1F=Y1F+R1
           IF (DABS(R1/Y1F).LE.EPS.AND.K.GT.30) GO TO 20
15      CONTINUE
20      Y1D=A
        R=1.0D0
        DO 25 K=1,100
           R=0.5D0*R*X*X/(K*(2.0D0*K+1.0D0))
           R1=H(K+1)*R
           Y1D=Y1D+R1
           IF (DABS(R1/Y1D).LE.EPS.AND.K.GT.30) GO TO 30
25      CONTINUE
30      Y1D=X*Y1D
        D1=1.0D0
        D2=A
        D(1)=1.0D0
        D(2)=A
        DO 40 L2=5,160,2
           M=(L2+1)/2
           DL=A*D2-0.25D0*(L2-2.0D0)*(L2-3.0D0)*D1
           D(M)=DL
           D1=D2
40         D2=DL
        Y2F=1.0D0
        R=1.0D0
        DO 45 K=1,100
           R=0.5D0*R*X*X/(K*(2.0D0*K+1.0D0))
           R1=D(K+1)*R
           Y2F=Y2F+R1
           IF (DABS(R1/Y2F).LE.EPS.AND.K.GT.30) GO TO 50
45      CONTINUE
50      Y2F=X*Y2F
        Y2D=1.0D0
        R=1.0D0
        DO 55 K=1,100
           R=0.5D0*R*X*X/(K*(2.0D0*K-1.0D0))
           R1=D(K+1)*R
           Y2D=Y2D+R1
           IF (DABS(R1/Y2D).LE.EPS.AND.K.GT.30) GO TO 60
55      CONTINUE
60      W1F=P0*(F1*Y1F-F2*Y2F)
        W2F=P0*(F1*Y1F+F2*Y2F)
        W1D=P0*(F1*Y1D-F2*Y2D)
        W2D=P0*(F1*Y1D+F2*Y2D)
        RETURN
        END
      SUBROUTINE PELGLO(XMOM,PARA)
C===================================================== PELGLO.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  PARAMETER ESTIMATION VIA L-MOMENTS FOR THE GENERALIZED LOGISTIC
C  DISTRIBUTION
C
C  PARAMETERS OF ROUTINE:
C  XMOM   * INPUT* ARRAY OF LENGTH 3. CONTAINS THE L-MOMENTS LAMBDA-1,
C                  LAMBDA-2, TAU-3.
C  PARA   *OUTPUT* ARRAY OF LENGTH 3. ON EXIT, CONTAINS THE PARAMETERS
C                  IN THE ORDER XI, ALPHA, K (LOCATION, SCALE, SHAPE).
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DOUBLE PRECISION XMOM(3),PARA(3)
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      REAL CPUMIN
      REAL CPUMAX
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DATA ZERO/0.0D0/
      DATA ONE/1.0D0/
      DATA PI/3.141592653589793238D0/
C
C         SMALL IS USED TO TEST WHETHER K IS EFFECTIVELY ZERO
C
      DATA SMALL/1D-6/
C
C         ESTIMATE K
C
      G=-XMOM(3)
      IF(XMOM(2).LE.ZERO.OR.DABS(G).GE.ONE)THEN
        WRITE(ICOUT,7000)
 7000   FORMAT('***** ERROR IN GENERALIZED LOGISTIC L-MOMENTS ',
     1         'ESTIMATION--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,7005)
 7005   FORMAT('      L-MOMENTS INVALID')
        CALL DPWRST('XXX','WRIT')
        PARA(3)=ZERO
        PARA(2)=ZERO
        PARA(1)=ZERO
        GOTO9000
      ENDIF
C
C         ESTIMATED K EFFECTIVELY ZERO (I.E., USE LOGISTIC RATHER THAN
C         GENERALIZED LOGISTIC)
C
      IF(DABS(G).LE.SMALL)THEN
        PARA(3)=ZERO
        PARA(2)=XMOM(2)
        PARA(1)=XMOM(1)
        GOTO9000
      ENDIF
C
C         ESTIMATE ALPHA, XI
C
      GG=G*PI/DSIN(G*PI)
      A=XMOM(2)/GG
      PARA(1)=XMOM(1)-A*(ONE-GG)/G
      PARA(2)=A
      PARA(3)=G
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE PELWAK(XMOM,PARA,IFAIL)
C===================================================== PELWAK.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  PARAMETER ESTIMATION VIA L-MOMENTS FOR THE WAKEBY DISTRIBUTION
C
C  PARAMETERS OF ROUTINE:
C  XMOM   * INPUT* ARRAY OF LENGTH 5. CONTAINS THE L-MOMENTS LAMBDA-1,
C                  LAMBDA-2, TAU-3, TAU-4, TAU-5.
C  PARA   *OUTPUT* ARRAY OF LENGTH 5. ON EXIT, CONTAINS THE PARAMETERS
C                  IN THE ORDER XI, ALPHA, BETA, GAMMA, DELTA.
C  IFAIL  *OUTPUT* FAIL FLAG. ON EXIT, IT IS SET AS FOLLOWS.
C                  0 SUCCESSFUL EXIT
C                  1 ESTIMATES COULD ONLY BE OBTAINED BY SETTING XI=0
C                  2 ESTIMATES COULD ONLY BE OBTAINED BY FITTING A
C                    GENERALIZED PARETO DISTRIBUTION
C                  3 L-MOMENTS INVALID
C
C  PROCEDURE:
C  1. LOOK FOR A SOLUTION WITH XI UNCONSTRAINED;
C  2. IF NONE FOUND, LOOK FOR A SOLUTION WITH XI=0;
C  3. IF NONE FOUND, FIT A GENERALIZED PARETO DISTRIBUTION TO THE
C     FIRST 3 L-MOMENTS.
C  ESTIMATES ARE CALCULATED USING THE FORMULAS GIVEN BY GREENWOOD ET AL.
C  (1979, WATER RESOUR. RES., TABLE 5), BUT EXPRESSED IN TERMS OF
C  L-MOMENTS RATHER THAN PROBABILITY WEIGHTED MOMENTS.
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DOUBLE PRECISION XMOM(5),PARA(5)
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      REAL CPUMIN
      REAL CPUMAX
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DATA ZERO/0D0/,HALF/0.5D0/,ONE/1D0/,TWO/2D0/,THREE/3D0/,FOUR/4D0/
      DATA X2/2D0/,X3/3D0/,X4/4D0/,X5/5D0/,X7/7D0/,X8/8D0/,X9/9D0/,
     *  X10/10D0/,X11/11D0/,X16/16D0/,X25/25D0/,X29/29D0/,X32/32D0/,
     *  X35/35D0/,X85/85D0/,X125/125D0/,X203/203D0/
C
      IF(DABS(XMOM(2)).LE.ZERO)GOTO 1000
      IF(DABS(XMOM(3)).GE.ONE)GOTO 1000
      IF(DABS(XMOM(4)).GE.ONE)GOTO 1000
      IF(DABS(XMOM(5)).GE.ONE)GOTO 1000
      IFAIL=0
C
C         CALCULATE THE L-MOMENTS (LAMBDA'S)
C
      ALAM1=XMOM(1)
      ALAM2=XMOM(2)
      ALAM3=XMOM(3)*ALAM2
      ALAM4=XMOM(4)*ALAM2
      ALAM5=XMOM(5)*ALAM2
C
C         ESTIMATE N1,N2,N3,C1,C2,C3 WHEN XI.NE.0
C
      XN1= X3*ALAM2-X25*ALAM3 +X32*ALAM4
      XN2=-X3*ALAM2 +X5*ALAM3  +X8*ALAM4
      XN3= X3*ALAM2 +X5*ALAM3  +X2*ALAM4
      XC1= X7*ALAM2-X85*ALAM3+X203*ALAM4-X125*ALAM5
      XC2=-X7*ALAM2+X25*ALAM3  +X7*ALAM4 -X25*ALAM5
      XC3= X7*ALAM2 +X5*ALAM3  -X7*ALAM4  -X5*ALAM5
C
C         ESTIMATE B AND D
C
      XA=XN2*XC3-XC2*XN3
      XB=XN1*XC3-XC1*XN3
      XC=XN1*XC2-XC1*XN2
      DISC=XB*XB-FOUR*XA*XC
      IF(DISC.LT.ZERO)GOTO 10
      DISC=DSQRT(DISC)
      ROOT1=HALF*(-XB+DISC)/XA
      ROOT2=HALF*(-XB-DISC)/XA
      B= DMAX1(ROOT1,ROOT2)
      D=-DMIN1(ROOT1,ROOT2)
      IF(D.GE.ONE)GOTO 10
C
C         ESTIMATE A, C AND XI
C
      A=(ONE+B)*(TWO+B)*(THREE+B)/
     *  (FOUR*(B+D))*((ONE+D)*ALAM2-(THREE-D)*ALAM3)
      C=-(ONE-D)*(TWO-D)*(THREE-D)/
     *  (FOUR*(B+D))*((ONE-B)*ALAM2-(THREE+B)*ALAM3)
      XI=ALAM1-A/(ONE+B)-C/(ONE-D)
C
C         CHECK FOR VALID PARAMETERS
C
      IF(C.GE.ZERO.AND.A+C.GE.ZERO)GOTO 30
C
C         CAN'T FIND VALID ESTIMATES FOR XI UNRESTRICTED, SO TRY XI=0
C
C         ESTIMATE B AND D FOR XI=0
C
   10 CONTINUE
      IFAIL=1
      XI=ZERO
      ZN1=X4*ALAM1-X11*ALAM2+X9*ALAM3
      ZN2=-ALAM2+X3*ALAM3
      ZN3=ALAM2+ALAM3
      ZC1=X10*ALAM1-X29*ALAM2+X35*ALAM3-X16*ALAM4
      ZC2=-ALAM2+X5*ALAM3-X4*ALAM4
      ZC3=ALAM2-ALAM4
      ZA=ZN2*ZC3-ZC2*ZN3
      ZB=ZN1*ZC3-ZC1*ZN3
      ZC=ZN1*ZC2-ZC1*ZN2
      DISC=ZB*ZB-FOUR*ZA*ZC
      IF(DISC.LT.ZERO)GOTO 20
      DISC=DSQRT(DISC)
      ROOT1=HALF*(-ZB+DISC)/ZA
      ROOT2=HALF*(-ZB-DISC)/ZA
      B= DMAX1(ROOT1,ROOT2)
      D=-DMIN1(ROOT1,ROOT2)
      IF(D.GE.ONE)GOTO 20
C
C         ESTIMATE A AND C
C
      A= (ONE+B)*(TWO+B)/(B+D)*(ALAM1-(TWO-D)*ALAM2)
      C=-(ONE-D)*(TWO-D)/(B+D)*(ALAM1-(TWO+B)*ALAM2)
      IF(C.GE.ZERO.AND.A+C.GE.ZERO)GOTO 30
C
C         CAN'T FIND VALID ESTIMATES EVEN WITH XI=0 -
C         FIT GENERALIZED PARETO DISTRIBUTION INSTEAD
C
   20 CONTINUE
      IFAIL=2
      D=-(ONE-THREE*XMOM(3))/(ONE+XMOM(3))
      C=(ONE-D)*(TWO-D)*XMOM(2)
      B=ZERO
      A=ZERO
      XI=XMOM(1)-C/(ONE-D)
      IF(D.GT.ZERO)GOTO 30
      A=C
      B=-D
      C=ZERO
      D=ZERO
C
C         COPY RESULTS INTO ARRAY PARA
C
   30 CONTINUE
      PARA(1)=XI
      PARA(2)=A
      PARA(3)=B
      PARA(4)=C
      PARA(5)=D
      GOTO9000
C
 1000 IFAIL=3
      DO 1010 I=1,5
        PARA(I)=ZERO
 1010 CONTINUE
      GOTO9000
C
 9000 CONTINUE
      RETURN
      END
      COMPLEX FUNCTION PEQ(Z)
C
C     WEIERSTRASS: P-FUNCTION IN THE EQUIANHARMONIC CASE
C     FOR COMPLEX ARGUMENT WITH UNIT PERIOD PARALLELOGRAM
C
      INCLUDE 'DPCOMC.INC'
      COMPLEX Z, Z2, Z4, Z6
      REAL ZR, ZI
      INTEGER M, N
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      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     REDUCTION TO FUNDAMENTAL PARALLELOGRAM
C
      ZI = 1.1547005383792515E0*AIMAG(Z) + 0.5E0
      M = INT(ZI)
      IF (ZI.LT.0E0) M = M - 1
      ZR = REAL(Z) - 0.5E0*FLOAT(M) + 0.5E0
      N = INT(ZR)
      IF (ZR.LT.0E0) N = N - 1
      Z2 = Z - FLOAT(N) - (0.5E0,0.86602540378443865E0)*FLOAT(M)
C
C     IF Z2=0 THEN Z COINCIDES WITH A LATTICE POINT.
C     SINCE P HAS POLES AT THE LATTICE POINTS,
C     A DIVISION ERROR WILL OCCUR
C
      IF(REAL(Z2).EQ.0.0.AND.AIMAG(Z2).EQ.0.0)THEN
        PEQ=R1MACH(2)
        WRITE(ICOUT,91)
        CALL DPWRST('XXX','BUG ')
        RETURN
      ENDIF
   91 FORMAT('***** ERROR: INPUT POINT CORRESPONDS TO A LATTICE ',
     1'POINT.  VALUE SET TO LARGEST REAL. *****')
      Z2 = Z2*Z2
      Z4 = Z2*Z2
      Z6 = Z4*Z2
      PEQ = 1E0/Z2 + 6E0*Z4*(5E0+Z6)/(1E0-Z6)**2 + Z4*
     * (((((-2.6427662E-10*Z6+1.610954818E-8)*Z6+7.38610752879E-6)*
     * Z6+4.3991444671178E-4)*Z6+7.477288220490697E-2)*
     * Z6-6.8484153287299201E-1)/(((((6.2252191E-10*Z6+2.553314573E-7)*
     * Z6-2.619832920421E-5)*Z6-5.6444801847646E-4)*
     * Z6+4.565553484820106E-2)*Z6+1E0)
      RETURN
      END
      COMPLEX FUNCTION PEQ1(Z)
C
C     FIRST DERIVATIVE OF WEIERSTRASS: P-FUNCTION IN THE
C     EQUIANHARMONIC CASE FOR COMPLEX ARGUMENT
C     WITH UNIT PERIOD PARALLELOGRAM
C
      INCLUDE 'DPCOMC.INC'
      COMPLEX Z, Z3, Z6
      REAL ZR, ZI
      INTEGER M, N
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      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     REDUCTION TO FUNDAMENTAL PARALLELOGRAM
C
      ZI = 1.1547005383792515E0*AIMAG(Z) + 0.5E0
      M = INT(ZI)
      IF (ZI.LT.0E0) M = M - 1
      ZR = REAL(Z) - 0.5E0*FLOAT(M) + 0.5E0
      N = INT(ZR)
      IF (ZR.LT.0E0) N = N - 1
      Z3 = Z - FLOAT(N) - (0.5E0,0.86602540378443865E0)*FLOAT(M)
C
C     IF Z3=0 THEN Z COINCIDES WITH A LATTICE POINT.
C     SINCE P: HAS POLES AT THE LATTICE POINTS,
C     A DIVISION ERROR WILL OCCUR
C
      IF(REAL(Z3).EQ.0.0.AND.AIMAG(Z3).EQ.0.0)THEN
        PEQ1=R1MACH(2)
        WRITE(ICOUT,91)
        CALL DPWRST('XXX','BUG ')
        RETURN
      ENDIF
   91 FORMAT('***** ERROR: INPUT POINT CORRESPONDS TO A LATTICE ',
     1'POINT.  VALUE SET TO LARGEST REAL. *****')
      Z3 = Z3*Z3*Z3
      Z6 = Z3*Z3
      PEQ1 = (((14E0*Z6+294E0)*Z6+126E0)*Z6-2E0)/(Z3*(1E0-Z6)**3) +
     * Z3*((((((-2.95539175E-9*Z6-2.6764693031E-7)*Z6+2.402192743346E-5)
     * *Z6+1.9656661451391E-4)*Z6+1.760135529461036E-2)*
     * Z6+8.1026243498822636E-1)*Z6-2.73936613149196804E0)/
     * ((((((4.6397763E-10*Z6+5.413482233E-8)*Z6-1.56293298374E-6)*
     * Z6-1.0393701076352E-4)*Z6+9.5553182532237E-4)*
     * Z6+9.131106969640212E-2)*Z6+1E0)
      RETURN
      END
      SUBROUTINE PERCEN(P100,X,N,IWRITE,XTEMP,MAXNXT,
     1XPERC,IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE
C              SAMPLE PERCENTILE
C              OF THE DATA IN THE INPUT VECTOR X.
C     INPUT  ARGUMENTS--P100   = THE SINGLE PRECISION PERCENTAGE
C                                (BETWEEN 0 AND 100)
C                     --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--XPERC  = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED SAMPLE PERCENTILE.
C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
C             SAMPLE PERCENTILE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--SORT.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--87.11
C     ORIGINAL VERSION--SEPTEMBER 1987.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
      DIMENSION XTEMP(*)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='PERC'
      ISUBN2='EN  '
C
      IERROR='NO'
C
      NI=0
      NIP1=0
C
      ANI=0.0
      A2NI=0.0
      REM=0.0
C
      IF(IBUGA3.EQ.'OFF')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF PERCEN--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)IBUGA3
   52 FORMAT('IBUGA3 = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)P100,N
   53 FORMAT('P100,N = ',E15.7,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 PERCENTILE      **
C               ******************************
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      AN=N
C
      IF(0.0.LT.P100.AND.P100.LT.100.0)GOTO119
      IERROR='YES'
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,111)
  111 FORMAT('***** ERROR IN PERCEN--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,112)
  112 FORMAT('      THE INPUT PERCENTAGE FOR WHICH')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,113)
  113 FORMAT('      THE PERCENTILE IS TO BE COMPUTED')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,115)
  115 FORMAT('      MUST BE LARGER THAN 0 AND SMALLER THAN 100.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,116)
  116 FORMAT('      SUCH WAS NOT THE CASE HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,117)P100
  117 FORMAT('      THE INPUT PERCENTAGE HERE = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      GOTO9000
  119 CONTINUE
C
      IF(1.LE.N.AND.N.LE.MAXNXT)GOTO129
      IERROR='YES'
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,121)
  121 FORMAT('***** ERROR IN PERCEN--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,122)
  122 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,123)
  123 FORMAT('      IN THE VARIABLE FOR WHICH')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,124)
  124 FORMAT('      THE PERCENTILE IS TO BE COMPUTED')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,125)MAXNXT
  125 FORMAT('      MUST BE BETWEEN 1 AND ',I8,' (INCLUSIVELY).')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,126)
  126 FORMAT('      SUCH WAS NOT THE CASE HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,127)N
  127 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8,
     1'.')
      CALL DPWRST('XXX','BUG ')
      GOTO9000
  129 CONTINUE
C
      IF(N.EQ.1)GOTO130
      GOTO139
  130 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,131)
  131 FORMAT('***** NON-FATAL DIAGNOSTIC IN PERCEN--',
     1'THE THIRD INPUT ARGUMENT (N) HAS THE VALUE 1')
      CALL DPWRST('XXX','BUG ')
      XPERC=X(1)
      GOTO9000
  139 CONTINUE
C
      HOLD=X(1)
      DO145I=2,N
      IF(X(I).NE.HOLD)GOTO149
  145 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,146)HOLD
  146 FORMAT('***** NON-FATAL DIAGNOSTIC IN PERCEN--',
     1'THE 2ND INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      XPERC=HOLD
      GOTO9000
  149 CONTINUE
C
  190 CONTINUE
C
C               ***********************************
C               **  STEP 2--                     **
C               **  COMPUTE THE PERCENTILE.      **
C               ***********************************
C
      CALL SORT(X,N,XTEMP)
C
      P=P100/100.0
C
      ANI=P*(AN+1.0)
      NI=ANI
      A2NI=NI
      REM=ANI-A2NI
      NIP1=NI+1
      IF(NI.LE.1)NI=1
      IF(NI.GE.N)NI=N
      IF(NIP1.LE.1)NIP1=1
      IF(NIP1.GE.N)NIP1=N
CCCCC BUG FIX.  WEIGHTS IN WRONG ORDER!  NOVEMBER 1998.
CCCCC XPERC=REM*XTEMP(NI)+(1.0-REM)*XTEMP(NIP1)
      XPERC=(1.0-REM)*XTEMP(NI)+REM*XTEMP(NIP1)
C
C               *******************************
C               **  STEP 3--                 **
C               **  WRITE OUT A LINE         **
C               **  OF SUMMARY INFORMATION.  **
C               *******************************
C
      IF(IFEEDB.EQ.'OFF')GOTO890
      IF(IWRITE.EQ.'OFF')GOTO890
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,811)P100,N,XPERC
  811 FORMAT('THE ',F10.2,'-PERCENTILE 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 PERCEN--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IBUGA3,IERROR
 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)P100,N,P
 9013 FORMAT('P100,N,P = ',E15.7,I8,E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9014)ANI,NI,A2NI,REM,NIP1
 9014 FORMAT('ANI,NI,A2NI,REM,NIP1 = ',E15.7,I8,E15.7,E15.7,I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9015)XPERC
 9015 FORMAT('XPERC = ',E15.7)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE PERDEF(X,N,ENGLSL,ENGUSL,IWRITE,XACTPD,XTHEPD,
     1XACTL,XTHEL,XACTU,XTHEU,
     1IFLAG,IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE
C              ACTUAL PERCENT DEFECTIVE (XACTPD) AND
C              THOERETICAL PERCENT DEFECTIVE (XTHEPD)
C              FROM THE DATA IN THE INPUT VECTOR X.
C              THIS CALCULATION ASSUMES--
C                 1) A NORMAL DISTRIBUTION
C                 2) WITH MEAN XBAR AND STANDARD DEVIATION S
C                 3) THE TARGET IS MIDWAY BETWEEN ENGUSL AND ENGLSL
C              XTHEPD = 100*(AREA UNDER NORMAL CURVE ABOVE USL AND BELOW LSL)
C     THE FINAL FORM FOR XTHEPD IS QUITE SIMPLE--
C        XTHEPD = 100(1-(NORCDF(ZUPPER)-NORCDF(ZLOWER)))
C     WHERE ZUPPER = (ENGUSL-MU)/SIGMA
C     AND   ZLOWER = (ENGLSL-MU)/SIGMA
C     IN PRACTICE, WE USE XBAR FOR MU AND S FOR SIGMA.
C     NOTE--XTHEPD IS A MEASURE OF PROCESS QUALITY AND IS
C           SENSITIVE TO LOSS OF QUALITY FROM BOTH BIAS AND FROM VARIATION.
C     NOTE--XTHEPD IS A MEASURE WHICH TAKES ON
C           THE VALUES 0% TO 100%
C           A GOOD PROCESS YIELDS VALUES OF
C           PERCENT DEFECTIVE NEAR 0%.
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                     --ENGLSL = LOWER (ENGINEERING) SPEC LIMIT
C                     --ENGUSL = UPPER (ENGINEERING) SPEC LIMIT
C                     --IFLAG  = WRITE FLAG (THEO, ACTU, BOTH)
C     OUTPUT ARGUMENTS--PERDEF = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED SAMPLE PERCENT DEFECTIVE
C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
C             SAMPLE PERCENT DEFECTIVE (IN XTHEPD)
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--DSQRT.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION & SINGLE PRECISION
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--R&M 2000 AIR FORCE MANUAL
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--89.5
C     ORIGINAL VERSION--MAY       1989.
C     UPDATED         --SEPTEMBER 1990. REVERSE INPUT ARGS
C     UPDATED         --APRIL     2001. ADD XACTL, XTHEL, XACTU, XTHEU
C                                       THESE ARE ONE SIDED LIMITS
C                                       (CAPABILITY ANALYSIS PRINTS
C                                       THEM)
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 IFLAG
      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
      DOUBLE PRECISION DUSL
      DOUBLE PRECISION DLSL
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='PERD'
      ISUBN2='EF  '
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 PERDEF--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)IFLAG,IBUGA3
   52 FORMAT('IFLAG,IBUGA3 = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)N
   53 FORMAT('N = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,54)ENGUSL,ENGLSL
   54 FORMAT('ENGUSL,ENGLSL = ',2E15.7)
      CALL DPWRST('XXX','BUG ')
      DO55I=1,N
      WRITE(ICOUT,56)I,X(I)
   56 FORMAT('I,X(I) = ',I8,E15.7)
      CALL DPWRST('XXX','BUG ')
   55 CONTINUE
   90 CONTINUE
C
C               ********************************************
C               **  COMPUTE PROCESS CAPABILITY INDEX PERDEF  **
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 PERDEF--')
      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 PERCENT DEFECTIVE 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 PERDEF--',
CCCCC1'THE SECOND 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 PERDEF--',
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               **  COMPUTE THE ACTUAL      PERCENT DEFECTIVE   **
C               **  COMPUTE THE THEORETICAL PERCENT DEFECTIVE   **
C               **************************************************
C
      DUSL=ENGUSL
      DLSL=ENGLSL
C
      IF(DSD.EQ.0.0D0)GOTO410
      GOTO420
C
  410 CONTINUE
      XTHEPD=0.0
      IF(DMEAN.GT.DUSL)XTHEPD=100.0
      IF(DMEAN.LT.DLSL)XTHEPD=100.0
      GOTO490
C
  420 CONTINUE
      ZUPPER=(DUSL-DMEAN)/DSD
      ZLOWER=(DLSL-DMEAN)/DSD
      CALL NORCDF(ZUPPER,CDFUPP)
      CALL NORCDF(ZLOWER,CDFLOW)
      XTHEPD=100.0*(1.0-(CDFUPP-CDFLOW))
      XTHEL=100.0*(CDFLOW)
      XTHEU=100.0*(1.0-CDFUPP)
C
  490 CONTINUE
C
      XACTPD=0.0
      XACTL=0.0
      XACTU=0.0
      ICOUNT=0
      DO510I=1,N
      IF(X(I).LT.ENGLSL.OR.X(I).GT.ENGUSL)ICOUNT=ICOUNT+1
      IF(X(I).LT.ENGLSL)XACTL=XACTL+1.0
      IF(X(I).GT.ENGUSL)XACTU=XACTU+1.0
  510 CONTINUE
      ACOUNT=ICOUNT
      IF(AN.NE.0.0)XACTPD=100.0*(ACOUNT/AN)
      IF(AN.NE.0.0)XACTL=100.0*(XACTL/AN)
      IF(AN.NE.0.0)XACTU=100.0*(XACTU/AN)
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 ')
      IF(IFLAG.EQ.'THEO'.OR.IFLAG.EQ.'BOTH')
     1WRITE(ICOUT,811)N,XTHEPD
  811 FORMAT('THE (THEORETICAL) PERCENT DEFECTIVE OF THE ',I8,
     1' OBSERVATIONS = ',E15.7)
      IF(IFLAG.EQ.'THEO'.OR.IFLAG.EQ.'BOTH')
     1CALL DPWRST('XXX','BUG ')
      IF(IFLAG.EQ.'ACTU'.OR.IFLAG.EQ.'BOTH')
     1WRITE(ICOUT,812)N,XACTPD
  812 FORMAT('THE (ACTUAL     ) PERCENT DEFECTIVE OF THE ',I8,
     1' OBSERVATIONS = ',E15.7)
      IF(IFLAG.EQ.'ACTU'.OR.IFLAG.EQ.'BOTH')
     1CALL 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 PERDEF--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IFLAG,IBUGA3,IERROR
 9012 FORMAT('IFLAG,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)DMEAN
 9014 FORMAT('DMEAN = ',D15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9015)DSD
 9015 FORMAT('DSD = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9016)DUSL,DLSL
 9016 FORMAT('DUSL,DLSL = ',2D15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9017)ZUPPER,ZLOWER,CDFUPP,CDFLOW,XTHEPD
 9017 FORMAT('ZUPPER,ZLOWER,CDFUPP,CDFLOW,XTHEPD = ',5E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9021)ENGLSL,ENGUSL,ACOUNT,AN
 9021 FORMAT('ENGLSL,ENGUSL,ACOUNT,AN = ',4E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9022)XACTPD,XTHEPD
 9022 FORMAT('XACTPD,XTHEPD = ',2E15.7)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE PEXCDF(X,ALPHA,BETA,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE EXPONENTIAL POWER DISTRIBUTION
C              WITH SHAPE PARAMETERS ALPHA AND BETA.
C              THIS DISTRIBUTION IS DEFINED FOR ALL NON-NEGATIVE X,
C              AND HAS THE CUMULATIVE DISTRIBUTION FUNCTION
C              F(X) = 1-EXP(1-EXP((X/ALPHA)**B))
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 NON-NEGATIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--EXP.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN. 
C     REFERENCES--JOHNSON, KOTZ, AND BALKRISHNAN, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--2, 2ND ED 1994, PAGES 643-644.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE:  301-975-2855
C     ORIGINAL VERSION--DECEMBER  1995. 
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DALPHA
      DOUBLE PRECISION DBETA
      DOUBLE PRECISION DCDF
      DOUBLE PRECISION DTERM1, DTERM2, DTERM3
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(X.LT.0.0)THEN
        WRITE(ICOUT,4)
        CALL DPWRST('XXX','BUG')
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','BUG')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG')
        CDF=0.0
        GOTO9999
      ENDIF
      IF(ALPHA.LE.0.0)THEN
        WRITE(ICOUT,14)
        CALL DPWRST('XXX','BUG')
        WRITE(ICOUT,15)
        CALL DPWRST('XXX','BUG')
        WRITE(ICOUT,46)ALPHA
        CALL DPWRST('XXX','BUG')
        CDF=0.0
        GOTO9999
      ENDIF
      IF(BETA.LE.0.0)THEN
        WRITE(ICOUT,24)
        CALL DPWRST('XXX','BUG')
        WRITE(ICOUT,25)
        CALL DPWRST('XXX','BUG')
        WRITE(ICOUT,46)BETA
        CALL DPWRST('XXX','BUG')
        CDF=0.0
        GOTO9999
      ENDIF
    4 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO')
    5 FORMAT('      THE PEXCDF SUBROUTINE IS NEGATIVE *****')
   14 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO')
   15 FORMAT('      THE PEXCDF SUBROUTINE IS ZERO OR NEGATIVE *****')
   24 FORMAT('***** ERROR--THE THIRD INPUT ARGUMENT TO')
   25 FORMAT('      THE PEXCDF SUBROUTINE IS ZERo OR NEGATIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
C-----START POINT-----------------------------------------------------
C
      DALPHA=DBLE(ALPHA)
      DBETA=DBLE(BETA)
      DX=DBLE(X)
C
      IF(DX.LE.0.000000001D0)THEN
        CDF=0.0
        GOTO9999
      ENDIF
C
      DTERM1=DBETA*DLOG(DX/DALPHA)
      IF(DTERM1.GE.80.D0)THEN
        CDF=1.0
        GOTO9999
      ELSE
        DTERM2=DEXP(DTERM1)
        IF(DTERM2.GE.80.D0)THEN
          CDF=1.0
          GOTO9999
        ELSEIF(DTERM2.LE.-80.D0)THEN
          CDF=0.0
          GOTO9999
        ELSE
          DTERM3=1.0D0-DEXP(DTERM2)
        ENDIF
      ENDIF
      DCDF=1.0D0-DEXP(DTERM3)
      CDF=SNGL(DCDF)
C
 9999 CONTINUE
      RETURN
      END 
      SUBROUTINE PEXCHA(X,ALPHA,BETA,HAZ)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE HAZARD
C              FUNCTION VALUE FOR THE EXPONENTIAL POWER DISTRIBUTION
C              WITH SHAPE PARAMETERS ALPHA AND BETA.
C              THIS DISTRIBUTION IS DEFINED FOR ALL NON-NEGATIVE X,
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C              F(X) = (E*BETA/(ALPHA**BETA))*X**(BETA-1)*
C                     EXP((X/ALPHA)**BETA)*EXP(-EXP((X/ALPHA)**BETA))
C              AND HAZARD FUNCTION
C              H(X)=(1/ALPHA)*BETA*X**(X-1)*EXP((1/ALPHA)*X**BETA)
C              AND CUMULATIVE HAZARD FUNCTION
C              H(X)=EXP((X/ALPHA)**BETA) - 1.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE CUMULATIVE HAZARD
C                                FUNCTION IS TO BE EVALUATED.
C     OUTPUT ARGUMENTS--HAZ    = THE SINGLE PRECISION  CUMULATIVE 
C                                HAZARD FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION CUMULATIVE HAZARD
C             FUNCTION VALUE HAZ.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 
C     RESTRICTIONS--X SHOULD BE NON-NEGATIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--EXP.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN. 
C     REFERENCES--JOHNSON, KOTZ, AND BALKRISHNAN, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--2, 2ND ED 1994, PAGES 643-644.
C                 SMITH AND BAIN, "AN EXPONENTIAL POWER LIFE-TESTING
C                 DISTRIBUTION", COMMUNICATIONS IN STATISITCS, 1975,
C                 PP. 469-481.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE:  301-975-2855
C     ORIGINAL VERSION--APRIL     1998. 
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DALPHA
      DOUBLE PRECISION DBETA
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DHAZ
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(X.LT.0.0)THEN
        WRITE(ICOUT,4)
        CALL DPWRST('XXX','BUG')
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','BUG')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG')
        HAZ=0.0
        GOTO9999
      ENDIF
      IF(ALPHA.LE.0.0)THEN
        WRITE(ICOUT,14)
        CALL DPWRST('XXX','BUG')
        WRITE(ICOUT,15)
        CALL DPWRST('XXX','BUG')
        WRITE(ICOUT,46)ALPHA
        CALL DPWRST('XXX','BUG')
        HAZ=0.0
        GOTO9999
      ENDIF
      IF(BETA.LE.0.0)THEN
        WRITE(ICOUT,24)
        CALL DPWRST('XXX','BUG')
        WRITE(ICOUT,25)
        CALL DPWRST('XXX','BUG')
        WRITE(ICOUT,46)BETA
        CALL DPWRST('XXX','BUG')
        HAZ=0.0
        GOTO9999
      ENDIF
    4 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO')
    5 FORMAT('      THE PEXCHA SUBROUTINE IS NEGATIVE *****')
   14 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO')
   15 FORMAT('      THE PEXCHA SUBROUTINE IS ZERO OR NEGATIVE *****')
   24 FORMAT('***** ERROR--THE THIRD INPUT ARGUMENT TO')
   25 FORMAT('      THE PEXCHA SUBROUTINE IS ZERO OR NEGATIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
C-----START POINT-----------------------------------------------------
C
      DALPHA=DBLE(ALPHA)
      DBETA=DBLE(BETA)
      DX=DBLE(X)
C
      IF(DX.LE.0.000000001D0)THEN
        HAZ=0.0
        GOTO9999
      ELSE
C
        DTERM1=DBETA*DLOG(DX/DALPHA)
        IF(DTERM1.GE.80.D0)THEN
          HAZ=0.0
          WRITE(ICOUT,101)
          CALL DPWRST('XXX','BUG')
          GOTO9999
        ELSE
          DTERM2=DEXP(DTERM1)
          IF(DTERM2.GE.80.D0)THEN
            HAZ=0.0
            WRITE(ICOUT,101)
            CALL DPWRST('XXX','BUG')
            GOTO9999
          ELSEIF(DTERM2.LE.-25.D0)THEN
            HAZ=0.0
            GOTO9999
          ELSE
            DHAZ=-(1.0D0 - DEXP(DTERM2))
            HAZ=REAL(DHAZ)
          ENDIF
        ENDIF
      ENDIF
  101 FORMAT('***** ERROR--FOR X = ',E15.7,' THE CDF IS ESSENTIALLY',
     1' 1.')
C
 9999 CONTINUE
      RETURN
      END 
      SUBROUTINE PEXHAZ(X,ALPHA,BETA,HAZ)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE HAZARD
C              FUNCTION VALUE FOR THE EXPONENTIAL POWER DISTRIBUTION
C              WITH SHAPE PARAMETERS ALPHA AND BETA.
C              THIS DISTRIBUTION IS DEFINED FOR ALL NON-NEGATIVE X,
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C              F(X) = (E*BETA/(ALPHA**BETA))*X**(BETA-1)*
C                     EXP((X/ALPHA)**BETA)*EXP(-EXP((X/ALPHA)**BETA))
C              AND HAZARD FUNCTION
C              H(X)=ALPHA*BETA*X**(X-1)*EXP(ALPHA*X**BETA)
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE HAZARD
C                                FUNCTION IS TO BE EVALUATED.
C     OUTPUT ARGUMENTS--HAZ    = THE SINGLE PRECISION 
C                                HAZARD FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION HAZARD
C             FUNCTION VALUE HAZ.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 
C     RESTRICTIONS--X SHOULD BE NON-NEGATIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--EXP.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN. 
C     REFERENCES--JOHNSON, KOTZ, AND BALKRISHNAN, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--2, 2ND ED 1994, PAGES 643-644.
C                 SMITH AND BAIN, "AN EXPONENTIAL POWER LIFE-TESTING
C                 DISTRIBUTION", COMMUNICATIONS IN STATISITCS, 1975,
C                 PP. 469-481.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE:  301-975-2855
C     ORIGINAL VERSION--APRIL     1998. 
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DALPHA
      DOUBLE PRECISION DBETA
      DOUBLE PRECISION DTERM1, DTERM2, DTERM3, DTERM4, DTERM5
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(X.LT.0.0)THEN
        WRITE(ICOUT,4)
        CALL DPWRST('XXX','BUG')
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','BUG')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG')
        HAZ=0.0
        GOTO9999
      ENDIF
      IF(ALPHA.LE.0.0)THEN
        WRITE(ICOUT,14)
        CALL DPWRST('XXX','BUG')
        WRITE(ICOUT,15)
        CALL DPWRST('XXX','BUG')
        WRITE(ICOUT,46)ALPHA
        CALL DPWRST('XXX','BUG')
        HAZ=0.0
        GOTO9999
      ENDIF
      IF(BETA.LE.0.0)THEN
        WRITE(ICOUT,24)
        CALL DPWRST('XXX','BUG')
        WRITE(ICOUT,25)
        CALL DPWRST('XXX','BUG')
        WRITE(ICOUT,46)BETA
        CALL DPWRST('XXX','BUG')
        HAZ=0.0
        GOTO9999
      ENDIF
    4 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO')
    5 FORMAT('      THE PEXHAZ SUBROUTINE IS NEGATIVE *****')
   14 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO')
   15 FORMAT('      THE PEXHAZ SUBROUTINE IS ZERO OR NEGATIVE *****')
   24 FORMAT('***** ERROR--THE THIRD INPUT ARGUMENT TO')
   25 FORMAT('      THE PEXHAZ SUBROUTINE IS ZERO OR NEGATIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
C-----START POINT-----------------------------------------------------
C
      DALPHA=DBLE(1.0/ALPHA)
      DBETA=DBLE(BETA)
      DX=DBLE(X)
C
      DTERM1=DLOG(DALPHA)
      DTERM2=DLOG(DBETA)
      DTERM3=(DBETA-1.0D0)*DLOG(DALPHA*DX)
      DTERM4=(DALPHA*DX)**DBETA
      DTERM5=DTERM1+DTERM2+DTERM3+DTERM4
      IF(DTERM5.LE.-80.D0)THEN
        HAZ=0.0
      ELSEIF(DTERM5.GE.80.D0)THEN
        HAZ=0.0
        WRITE(ICOUT,101)
        CALL DPWRST('XXX','BUG')
        WRITE(ICOUT,47)X
        CALL DPWRST('XXX','BUG')
        WRITE(ICOUT,48)ALPHA
        CALL DPWRST('XXX','BUG')
        WRITE(ICOUT,49)BETA
        CALL DPWRST('XXX','BUG')
      ELSE
        DTERM1=DEXP(DTERM5)
        HAZ=SNGL(DTERM1)
      ENDIF
  101 FORMAT('***** WARNING--THE PEXHAZ ROUTINE OVERFLOWS.  HAZ SET',
     1'TO 0.')
   47 FORMAT('***** THE VALUE OF THE FIRST ARGUMENT IS ',
     1E15.8,' *****')
   48 FORMAT('***** THE VALUE OF THE SECOND ARGUMENT IS ',
     1E15.8,' *****')
   49 FORMAT('***** THE VALUE OF THE THIRD ARGUMENT IS ',
     1E15.8,' *****')
C
 9999 CONTINUE
      RETURN
      END 
      SUBROUTINE PEXPDF(X,ALPHA,BETA,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE EXPONENTIAL POWER DISTRIBUTION
C              WITH SHAPE PARAMETERS ALPHA AND BETA.
C              THIS DISTRIBUTION IS DEFINED FOR ALL NON-NEGATIVE X,
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C              F(X) = (E*BETA/(ALPHA**BETA))*X**(BETA-1)*
C                     EXP((X/ALPHA)**BETA)*EXP(-EXP((X/ALPHA)**BETA))
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 CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE PDF.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 
C     RESTRICTIONS--X SHOULD BE NON-NEGATIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--EXP.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN. 
C     REFERENCES--JOHNSON, KOTZ, AND BALKRISHNAN, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--2, 2ND ED 1994, PAGES 643-644.
C                 SMITH AND BAIN, "AN EXPONENTIAL POWER LIFE-TESTING
C                 DISTRIBUTION", COMMUNICATIONS IN STATISITCS, 1975,
C                 PP. 469-481.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE:  301-975-2855
C     ORIGINAL VERSION--DECEMBER  1995. 
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DALPHA
      DOUBLE PRECISION DBETA
      DOUBLE PRECISION DPDF
      DOUBLE PRECISION DTERM1, DTERM2, DTERM3, DTERM4, DTERM5
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(X.LT.0.0)THEN
        WRITE(ICOUT,4)
        CALL DPWRST('XXX','BUG')
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','BUG')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG')
        PDF=0.0
        GOTO9999
      ENDIF
      IF(ALPHA.LE.0.0)THEN
        WRITE(ICOUT,14)
        CALL DPWRST('XXX','BUG')
        WRITE(ICOUT,15)
        CALL DPWRST('XXX','BUG')
        WRITE(ICOUT,46)ALPHA
        CALL DPWRST('XXX','BUG')
        PDF=0.0
        GOTO9999
      ENDIF
      IF(BETA.LE.0.0)THEN
        WRITE(ICOUT,24)
        CALL DPWRST('XXX','BUG')
        WRITE(ICOUT,25)
        CALL DPWRST('XXX','BUG')
        WRITE(ICOUT,46)BETA
        CALL DPWRST('XXX','BUG')
        PDF=0.0
        GOTO9999
      ENDIF
    4 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO')
    5 FORMAT('      THE PEXPDF SUBROUTINE IS NEGATIVE *****')
   14 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO')
   15 FORMAT('      THE PEXPDF SUBROUTINE IS ZERO OR NEGATIVE *****')
   24 FORMAT('***** ERROR--THE THIRD INPUT ARGUMENT TO')
   25 FORMAT('      THE PEXPDF SUBROUTINE IS ZERO OR NEGATIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
C-----START POINT-----------------------------------------------------
C
      DALPHA=DBLE(ALPHA)
      DBETA=DBLE(BETA)
      DX=DBLE(X)
C
      IF(DX.LE.0.000000000001D0)DX=0.00000000001D0
      DTERM1=DLOG(DEXP(1.0D0)) + DLOG(DBETA) - DBETA*DLOG(DALPHA)
      DTERM2=(DBETA-1.0D0)*DLOG(DX)
      DTERM3=(DX/DALPHA)**DBETA
      DTERM4=EXP((DX/DALPHA)**DBETA)
      DTERM5=DTERM1+DTERM2+DTERM3-DTERM4
      IF(DTERM5.LE.-80.D0)THEN
        PDF=0.0
      ELSEIF(DTERM5.GE.80.D0)THEN
        WRITE(ICOUT,101)
        CALL DPWRST('XXX','BUG')
        WRITE(ICOUT,47)X
        CALL DPWRST('XXX','BUG')
        WRITE(ICOUT,48)ALPHA
        CALL DPWRST('XXX','BUG')
        WRITE(ICOUT,49)BETA
        CALL DPWRST('XXX','BUG')
      ELSE
        DPDF=DEXP(DTERM5)
        PDF=SNGL(DPDF)
      ENDIF
  101 FORMAT('***** WARNING--THE PEXPDF ROUTINE OVERFLOWS.  PDF SET',
     1'TO LOG OF LARGEST MACHINE VALUE.')
   47 FORMAT('***** THE VALUE OF THE FIRST ARGUMENT IS ',
     1E15.8,' *****')
   48 FORMAT('***** THE VALUE OF THE SECOND ARGUMENT IS ',
     1E15.8,' *****')
   49 FORMAT('***** THE VALUE OF THE THIRD ARGUMENT IS ',
     1E15.8,' *****')
C
 9999 CONTINUE
      RETURN
      END 
      SUBROUTINE PEXPPF(P,ALPHA,BETA,PPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE EXPONENTIAL POWER DISTRIBUTION
C              WITH SHAPE PARAMETERS ALPHA AND BETA.
C              THIS DISTRIBUTION IS DEFINED FOR ALL NON-NEGATIVE X,
C              AND HAS THE CUMULATIVE DISTRIBUTION FUNCTION
C              F(X) = 1-EXP(1-EXP((X/ALPHA)**B))
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 (INCLUSIVELY)
C                   AND 1.0 (EXCLUSIVELY).
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--ALOG.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND BALKRISHNAN, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--2, 2ND ED 1994, PAGES 643-644.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE:  301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--96/1
C     ORIGINAL VERSION--JANUARY   1996.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DP
      DOUBLE PRECISION DALPHA
      DOUBLE PRECISION DBETA
      DOUBLE PRECISION DPPF
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(P.LT.0.0.OR.P.GE.1.0)THEN
        WRITE(ICOUT,1)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)P
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
      IF(ALPHA.LE.0.0)THEN
        WRITE(ICOUT,14)
        CALL DPWRST('XXX','BUG')
        WRITE(ICOUT,15)
        CALL DPWRST('XXX','BUG')
        WRITE(ICOUT,46)ALPHA
        CALL DPWRST('XXX','BUG')
        CDF=0.0
        GOTO9999
      ENDIF
      IF(BETA.LE.0.0)THEN
        WRITE(ICOUT,24)
        CALL DPWRST('XXX','BUG')
        WRITE(ICOUT,25)
        CALL DPWRST('XXX','BUG')
        WRITE(ICOUT,46)BETA
        CALL DPWRST('XXX','BUG')
        CDF=0.0
        GOTO9999
      ENDIF
    1 FORMAT('***** FATAL ERROR--THE 1ST  INPUT ARGUMENT TO THE ',
     1'PEXPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL')
   14 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO')
   15 FORMAT('      THE PEXPPF SUBROUTINE IS ZERO OR NEGATIVE *****')
   24 FORMAT('***** ERROR--THE THIRD INPUT ARGUMENT TO')
   25 FORMAT('      THE PEXPPF SUBROUTINE IS ZERO OR NEGATIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
      IF(P.EQ.0.0)THEN
        PPF=0.0
        GOTO9999
      ENDIF
C
      DALPHA=DBLE(ALPHA)
      DBETA=DBLE(BETA)
      DP=DBLE(P)
C
      DPPF=DALPHA*DLOG(1.0D0-DLOG(1.0D0-DP))**(1.0D0/DBETA)
      PPF=SNGL(DPPF)
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE PEXRAN(N,ALPHA,BETA,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE POWER EXPONENTIAL DISTRIBUTION
C              WITH SHAPE PARAMETER VALUES = ALPHA, BETA.
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --ALPHA  = THE SINGLE PRECISION VALUE OF THE
C                                FIRST SHAPE PARAMETER.
C                                ALPHA SHOULD BE POSITIVE.
C                     --BETA  = THE SINGLE PRECISION VALUE OF THE
C                                SECOND SHAPE PARAMETER.
C                                BETA 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 POWER EXPONENTIAL DISTRIBUTION
C             WITH SHAPE PARAMETER VALUES = ALPHA AND BETA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C                 --ALPHA SHOULD BE POSITIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2001.10
C     ORIGINAL VERSION--OCTOBER   2001.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)THEN
        WRITE(ICOUT, 5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
    5 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ',
     1'PEXRAN 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 POWER EXPONENTIAL DISTRIBUTION RANDOM NUMBERS
C     USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD.
C
      DO100I=1,N
        CALL PEXPPF(X(I),ALPHA,BETA,XTEMP)
        X(I)=XTEMP
  100 CONTINUE
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE PHASMP(A,ZINV,K,PP,QQ) 
C THIS ROUTINE DOES PHASE-AMPLITUDE CALCULATIONS FOR BESSEL FUNCTIONS.
C A IS THE ORDER OF THE FUNCTION, AT MOST 1 IN ABSOLUTE VALUE.  ZINV IS
C 2./Z, WHERE Z IS THE ARGUMENT.  TO ACHIEVE 14 FIGURES ACCURACY, ABS(Z)
C MUST BE AT LEAST 14, OR A MUST BE .5 OR -.5.  IF K=0, PHASMP RETURNS
C PP AND QQ FOR EQUATIONS 9.2.5 TO 9.2.8 OF REFERENCE (1) LISTED IN
C BESJCF.  IF K=1 (-1) PHASMP RETURNS PP FOR EQUATION 9.7.2 (9.7.1).
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
      COMPLEX PP,QQ,ZI,ZINV,TERM(25),ZDUMMY
C-----------------------------------------------------------------------
C
C  MACHINE DEPENDENT CONSTANTS.
C  ---------------------------
C
      SAVE ISAVE, DYOUK
      DATA ISAVE /1/
      DATA TERM(1)/(1.,0.)/
C
C Definition of real and imaginary parts of complex number,
C standard Fortran and will work on Convex with -r8 -i8.
      REALP(ZDUMMY) = REAL(ZDUMMY)
      AIMAGP(ZDUMMY) = REAL((0,-1)*ZDUMMY)
C
      IF (ISAVE.GT.0) THEN
        ISAVE = 0
        DYOUK = R1MACH (4)
      ENDIF
C
C-----------------------------------------------------------------------
      ZI=.0625*ZINV 
      S=K 
      IF(K.EQ.0) S=-1.
      C=(DBLE(2.*A))**2-1.D0
      DO 1 N=1,24
      IF(K.EQ.0) S=-S
      TERM(N+1)=TERM(N)*ZI*(S*(C/REAL(N)+REAL(4-4*N)))
      IF(MAX(ABS(REALP(TERM(N+1))),ABS(AIMAGP(TERM(N+1)))).LE.DYOUK)
     1 GO TO 2
    1 CONTINUE
      N=25
    2 PP = (0.0, 0.0)
      QQ = (0.0, 0.0)
      IF ((K .NE. 0) .OR. (MOD (N, 2) .NE. 0)) GO TO 4
    3 QQ=QQ+TERM(N) 
      N=N-1
    4 PP=PP+TERM(N) 
      N=N-1
      IF(N.EQ.0) RETURN
      IF(K) 4,3,4
      END 
      DOUBLE PRECISION FUNCTION PHI(Z)
*     
*     Normal distribution probabilities accurate to 1.e-15.
*     Z = no. of standard deviations from the mean.
*     
*     Based upon algorithm 5666 for the error function, from:
*     Hart, J.F. et al, 'Computer Approximations', Wiley 1968
*     
*     Programmer: Alan Miller
*     
*     Latest revision - 30 March 1986
*     
      DOUBLE PRECISION P0, P1, P2, P3, P4, P5, P6, 
     &     Q0, Q1, Q2, Q3, Q4, Q5, Q6, Q7,
     &     Z, P, EXPNTL, CUTOFF, ROOTPI, ZABS
      PARAMETER(
     &     P0 = 220.20 68679 12376 1D0,
     &     P1 = 221.21 35961 69931 1D0, 
     &     P2 = 112.07 92914 97870 9D0,
     &     P3 = 33.912 86607 83830 0D0,
     &     P4 = 6.3739 62203 53165 0D0,
     &     P5 = .70038 30644 43688 1D0, 
     &     P6 = .035262 49659 98910 9D0)
      PARAMETER(
     &     Q0 = 440.41 37358 24752 2D0,
     &     Q1 = 793.82 65125 19948 4D0, 
     &     Q2 = 637.33 36333 78831 1D0,
     &     Q3 = 296.56 42487 79673 7D0, 
     &     Q4 = 86.780 73220 29460 8D0,
     &     Q5 = 16.064 17757 92069 5D0, 
     &     Q6 = 1.7556 67163 18264 2D0,
     &     Q7 = .088388 34764 83184 4D0)
      PARAMETER(ROOTPI = 2.5066 28274 63100 1D0)
      PARAMETER(CUTOFF = 7.0710 67811 86547 5D0)
*     
      ZABS = ABS(Z)
*     
*     |Z| > 37
*     
      IF (ZABS .GT. 37) THEN
         P = 0
      ELSE
*     
*     |Z| <= 37
*     
         EXPNTL = EXP(-ZABS**2/2)
*     
*     |Z| < CUTOFF = 10/SQRT(2)
*     
         IF (ZABS .LT. CUTOFF) THEN
            P = EXPNTL*((((((P6*ZABS + P5)*ZABS + P4)*ZABS + P3)*ZABS
     &           + P2)*ZABS + P1)*ZABS + P0)/(((((((Q7*ZABS + Q6)*ZABS
     &           + Q5)*ZABS + Q4)*ZABS + Q3)*ZABS + Q2)*ZABS + Q1)*ZABS
     &           + Q0)
*     
*     |Z| >= CUTOFF.
*     
         ELSE
            P = EXPNTL/(ZABS + 1/(ZABS + 2/(ZABS + 3/(ZABS + 4/
     &           (ZABS + 0.65D0)))))/ROOTPI
         END IF
      END IF
      IF (Z .GT. 0) P = 1 - P
      PHI = P
C
      RETURN
      END
      DOUBLE PRECISION FUNCTION PHINV(P)
*
*	ALGORITHM AS241  APPL. STATIST. (1988) VOL. 37, NO. 3
*
*	Produces the normal deviate Z corresponding to a given lower
*	tail area of P.
*
*	The hash sums below are the sums of the mantissas of the
*	coefficients.   They are included for use in checking
*	transcription.
*
      DOUBLE PRECISION SPLIT1, SPLIT2, CONST1, CONST2, 
     &     A0, A1, A2, A3, A4, A5, A6, A7, B1, B2, B3, B4, B5, B6, B7, 
     &     C0, C1, C2, C3, C4, C5, C6, C7, D1, D2, D3, D4, D5, D6, D7, 
     &     E0, E1, E2, E3, E4, E5, E6, E7, F1, F2, F3, F4, F5, F6, F7, 
     &     P, Q, R
      PARAMETER (SPLIT1 = 0.425, SPLIT2 = 5,
     &     CONST1 = 0.180625D0, CONST2 = 1.6D0)
*     
*     Coefficients for P close to 0.5
*     
      PARAMETER (
     &     A0 = 3.38713 28727 96366 6080D0,
     &     A1 = 1.33141 66789 17843 7745D+2,
     &     A2 = 1.97159 09503 06551 4427D+3,
     &     A3 = 1.37316 93765 50946 1125D+4,
     &     A4 = 4.59219 53931 54987 1457D+4,
     &     A5 = 6.72657 70927 00870 0853D+4,
     &     A6 = 3.34305 75583 58812 8105D+4,
     &     A7 = 2.50908 09287 30122 6727D+3,
     &     B1 = 4.23133 30701 60091 1252D+1,
     &     B2 = 6.87187 00749 20579 0830D+2,
     &     B3 = 5.39419 60214 24751 1077D+3,
     &     B4 = 2.12137 94301 58659 5867D+4,
     &     B5 = 3.93078 95800 09271 0610D+4,
     &     B6 = 2.87290 85735 72194 2674D+4,
     &     B7 = 5.22649 52788 52854 5610D+3)
*     HASH SUM AB    55.88319 28806 14901 4439
*     
*     Coefficients for P not close to 0, 0.5 or 1.
*     
      PARAMETER (
     &     C0 = 1.42343 71107 49683 57734D0,
     &     C1 = 4.63033 78461 56545 29590D0,
     &     C2 = 5.76949 72214 60691 40550D0,
     &     C3 = 3.64784 83247 63204 60504D0,
     &     C4 = 1.27045 82524 52368 38258D0,
     &     C5 = 2.41780 72517 74506 11770D-1,
     &     C6 = 2.27238 44989 26918 45833D-2,
     &     C7 = 7.74545 01427 83414 07640D-4,
     &     D1 = 2.05319 16266 37758 82187D0,
     &     D2 = 1.67638 48301 83803 84940D0,
     &     D3 = 6.89767 33498 51000 04550D-1,
     &     D4 = 1.48103 97642 74800 74590D-1,
     &     D5 = 1.51986 66563 61645 71966D-2,
     &     D6 = 5.47593 80849 95344 94600D-4,
     &     D7 = 1.05075 00716 44416 84324D-9)
*     HASH SUM CD    49.33206 50330 16102 89036
*
*   Coefficients for P near 0 or 1.
*
      PARAMETER (
     &     E0 = 6.65790 46435 01103 77720D0,
     &     E1 = 5.46378 49111 64114 36990D0,
     &     E2 = 1.78482 65399 17291 33580D0,
     &     E3 = 2.96560 57182 85048 91230D-1,
     &     E4 = 2.65321 89526 57612 30930D-2,
     &     E5 = 1.24266 09473 88078 43860D-3,
     &     E6 = 2.71155 55687 43487 57815D-5,
     &     E7 = 2.01033 43992 92288 13265D-7,
     &     F1 = 5.99832 20655 58879 37690D-1,
     &     F2 = 1.36929 88092 27358 05310D-1,
     &     F3 = 1.48753 61290 85061 48525D-2,
     &     F4 = 7.86869 13114 56132 59100D-4,
     &     F5 = 1.84631 83175 10054 68180D-5,
     &     F6 = 1.42151 17583 16445 88870D-7,
     &     F7 = 2.04426 31033 89939 78564D-15)
*     HASH SUM EF    47.52583 31754 92896 71629
*     
      Q = ( 2*P - 1 )/2
      IF ( ABS(Q) .LE. SPLIT1 ) THEN
         R = CONST1 - Q*Q
         PHINV = Q*(((((((A7*R + A6)*R + A5)*R + A4)*R + A3)
     &        *R + A2)*R + A1)*R + A0) /
     &        (((((((B7*R + B6)*R + B5)*R + B4)*R + B3)
     &        *R + B2)*R + B1)*R + 1)
      ELSE
         R = MIN( P, 1 - P )
         IF (R .GT. 0) THEN
            R = SQRT( -LOG(R) )
            IF ( R .LE. SPLIT2 ) THEN
               R = R - CONST2
               PHINV = (((((((C7*R + C6)*R + C5)*R + C4)*R + C3)
     &              *R + C2)*R + C1)*R + C0) /
     &              (((((((D7*R + D6)*R + D5)*R + D4)*R + D3)
     &              *R + D2)*R + D1)*R + 1)
            ELSE
               R = R - SPLIT2
               PHINV = (((((((E7*R + E6)*R + E5)*R + E4)*R + E3)
     &              *R + E2)*R + E1)*R + E0) /
     &              (((((((F7*R + F6)*R + F5)*R + F4)*R + F3)
     &              *R + F2)*R + F1)*R + 1)
            END IF
         ELSE
            PHINV = 9
         END IF
         IF ( Q .LT. 0 ) PHINV = - PHINV
      END IF
C
      RETURN
      END
      REAL FUNCTION PKS2(N, D)                                          PKS   10
C     ALGORITHM 487 COLLECTED ALGORITHMS FROM ACM.
C     ALGORITHM APPEARED IN COMM. ACM, VOL. 17, NO. 12,
C     P. 703.
      INTEGER N
C N IS THE SAMPLE SIZE USED.
      REAL D
C D IS THE MAXIMUM MAGNITUDE (OF THE DISCREPANCY
C BETWEEN THE EMPIRICAL AND PROPOSED DISTRIBUTIONS)
C IN EITHER THE POSITIVE OR NEGATIVE DIRECTION.
C PKS2 IS THE EXACT PROBABILITY OF OBTAINING A
C DEVIATION NO LARGER THAN D.
C THESE FORMULAS APPEAR AS (23) AND (24) IN
C J. DURBIN.  THE PROBABILITY THAT THE SAMPLE
C DISTRIBUTION FUNCTION LIES BETWEEN TWO PARALLEL
C STRAIGHT LINES. ANNALS OF MATHEMATICAL STATISTICS
C 39, 2(APRIL 1968),398-411.
      DOUBLE PRECISION Q(141), FACT(141), SUM, CI,
     * FT, FU, FV
      IF (N.EQ.1) GO TO 90
      FN = FLOAT(N)
      FND = FN*D
      NDT = IFIX(2.*FND)
      IF (NDT.LT.1) GO TO 100
      ND = IFIX(FND)
      NDD = MIN0(2*ND,N)
      NDP = ND + 1
      NDDP = NDD + 1
      FACT(1) = 1.
      CI = 1.
      DO 10 I=1,N
        FACT(I+1) = FACT(I)*CI
        CI = CI + 1.
   10 CONTINUE
      Q(1) = 1.
      IF (NDD.EQ.0) GO TO 50
      CI = 1.
      DO 20 I=1,NDD
        Q(I+1) = CI**I/FACT(I+1)
        CI = CI + 1.
   20 CONTINUE
      IF (NDP.GT.N) GO TO 80
      FV = FLOAT(NDP) - FND
      JMAX = IDINT(FV) + 1
      DO 40 I=NDP,NDD
        SUM = 0.
        FT = FND
        K = I
        FU = FV
        DO 30 J=1,JMAX
          SUM = SUM + FT**(J-2)/FACT(J)*FU**K/
     *     FACT(K+1)
          FT = FT + 1.
          FU = FU - 1.
          K = K - 1
   30   CONTINUE
        Q(I+1) = Q(I+1) - 2.*FND*SUM
        JMAX = JMAX + 1
        FV = FV + 1.
   40 CONTINUE
      IF (NDD.EQ.N) GO TO 80
   50 DO 70 I=NDDP,N
        SUM = 0.
        SIGN = 1.
        FT = 2.*FND
        DO 60 J=1,NDT
          FT = FT - 1.
          K = I - J + 1
          SUM = SUM + SIGN*FT**J/FACT(J+1)*Q(K)
          SIGN = -SIGN
   60   CONTINUE
        Q(I+1) = SUM
   70 CONTINUE
   80 PKS2 = Q(N+1)*FACT(N+1)/FN**N
      RETURN
   90 PKS2 = 2.*D - 1.
      RETURN
  100 PKS2 = 0.
      RETURN
      END
      SUBROUTINE PRFAC
      DIMENSION DXA(4)
      COMMON /KSCOMM/ DX, DXA, J
      DOUBLE PRECISION PF
      COMMON /KSCOM2/ PF(4,40)
      DATA I /1/
      DO 10 J=1,4
        IF (DXA(J).EQ.DX) RETURN
   10 CONTINUE
      J = I
      I = I + 1
      IF (I.EQ.5) I = 1
      DXA(J) = DX
      PF(J,1) = 1.
      DO 20 K=2,38
        PF(J,K) = (PF(J,K-1)*DX)/FLOAT(K-1)
   20 CONTINUE
      RETURN
      END
      FUNCTION CEILDP(X)
      IF (X.GE.0.) GO TO 10
      I = -X
      CEILDP = -I
      RETURN
   10 I = X + .99999999
      CEILDP = I
      RETURN
      END
      COMPLEX FUNCTION PLEM(Z)
C
C     WEIERSTRASS: P-FUNCTION IN THE LEMNISCATIC CASE
C     FOR COMPLEX ARGUMENT WITH UNIT PERIOD PARALLELOGRAM
C
      INCLUDE 'DPCOMC.INC'
      COMPLEX Z, Z2, Z4, Z6
      REAL ZR, ZI
      INTEGER M, N
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      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     REDUCTION TO FUNDAMENTAL PARALLELOGRAM
C
      ZR = REAL(Z) + 0.5E0
      ZI = AIMAG(Z) + 0.5E0
      M = INT(ZR)
      N = INT(ZI)
      IF (ZR.LT.0E0) M = M - 1
      IF (ZI.LT.0E0) N = N - 1
      Z2 = Z - FLOAT(M) - (0E0,1E0)*FLOAT(N)
C
C     IF Z2=0 THEN Z COINCIDES WITH A LATTICE POINT.
C     SINCE P HAS POLES AT THE LATTICE POINTS,
C     A DIVISION ERROR WILL OCCUR
C
      IF(REAL(Z2).EQ.0.0.AND.AIMAG(Z2).EQ.0.0)THEN
        PLEM=R1MACH(2)
        WRITE(ICOUT,91)
        CALL DPWRST('XXX','BUG ')
        RETURN
      ENDIF
   91 FORMAT('***** ERROR: INPUT POINT CORRESPONDS TO A LATTICE ',
     1'POINT.  VALUE SET TO LARGEST REAL. *****')
      Z2 = Z2*Z2
      Z4 = Z2*Z2
      Z6 = Z4*Z2
      PLEM = 1E0/Z2 + 4E0*Z2*(3E0+Z4)/(1E0-Z4)**2 +
     * Z2*((((((((-7.233108E-11*Z4+1.714197273E-8)*Z4-2.5369036492E-7)*
     * Z4-7.98710206868E-6)*Z4+6.4850606909737E-4)*Z4+7.39624629362938E-
     * 3)*Z4+2.012382768497244E-2)*Z4+7.1177297543136598E-1)*
     * Z4-2.54636399353830738E0)/((((((((5.1161516E-10*Z4+6.61289408E-9)
     * *Z4+4.4618987048E-7)*Z4-8.42694918892E-6)*Z4+4.42886829095E-6)*
     * Z4-4.22629935217101E-3)*Z4+2.577496871700433E-2)*
     * Z4+4.2359940482277074E-1)*Z4+1E0)
      RETURN
      END
      COMPLEX FUNCTION PLEM1(Z)
C
C     FIRST DERIVATIVE OF WEIERSTRASS: P-FUNCTION IN THE
C     LEMNISCATIC CASE FOR COMPLEX ARGUMENT
C     WITH UNIT PERIOD PARALLELOGRAM
C
      INCLUDE 'DPCOMC.INC'
      COMPLEX Z, Z1, Z3, Z4
      REAL ZR, ZI
      INTEGER M, N
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      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     REDUCTION TO FUNDAMENTAL PARALLELOGRAM
C
      ZR = REAL(Z) + 0.5E0
      ZI = AIMAG(Z) + 0.5E0
      M = INT(ZR)
      N = INT(ZI)
      IF (ZR.LT.0E0) M = M - 1
      IF (ZI.LT.0E0) N = N - 1
      Z1 = Z - FLOAT(M) - (0E0,1E0)*FLOAT(N)
C
C     IF Z1=0 THEN Z COINCIDES WITH A LATTICE POINT.
C     SINCE P: HAS POLES AT THE LATTICE POINTS,
C     A DIVISION ERROR WILL OCCUR
C
      IF(REAL(Z1).EQ.0.0.AND.AIMAG(Z1).EQ.0.0)THEN
        PLEM1=R1MACH(2)
        WRITE(ICOUT,91)
        CALL DPWRST('XXX','BUG ')
        RETURN
      ENDIF
   91 FORMAT('***** ERROR: INPUT POINT CORRESPONDS TO A LATTICE ',
     1'POINT.  VALUE SET TO LARGEST REAL. *****')
      Z3 = Z1*Z1*Z1
      Z4 = Z3*Z1
      PLEM1 = (((1E1*Z4+9E1)*Z4+3E1)*Z4-2E0)/(Z1*(1E0-Z4))**3 +
     * Z1*((((((((((-3.9046302E-9*Z4-1.001487137E-8)*Z4+5.9573043092E-7)
     * *Z4-2.482518130524E-5)*Z4+1.4557266595395E-4)*
     * Z4+4.56633655643206E-3)*Z4+6.224782572111135E-2)*
     * Z4+1.038527937794269E-2)*Z4+1.19804620802637942E0)*
     * Z4+6.42791439683811718E0)*Z4-5.09272798707661477E0)/
     * ((((((((((4.726888E-11*Z4-3.0667983E-9)*Z4+1.0087596089E-7)*
     * Z4-8.060683451E-8)*Z4+1.184299251664E-5)*Z4-2.3096723361547E-4)*
     * Z4-2.90730903142055E-3)*Z4+1.338392411135511E-2)*
     * Z4+2.3098639320021426E-1)*Z4+8.4719880964554148E-1)*Z4+1E0)
      RETURN
      END
      SUBROUTINE PLOTCN(Y,X,D,N,ICHAR,MAXCHA,ICASPL,ICAS3D,
     1ITITTE,NCTITL,
     1IX1LTE,NCX1LA,
     1IX2LTE,NCX2LA,
     1IX3LTE,NCX3LA,
     1IY1LTE,NCY1LA,
     1IY2LTE,NCY2LA,
     1GX1MIN,GX1MAX,GY1MIN,GY1MAX,
     1IERASW,IBUGU2,IERROR)
C
C     PURPOSE--THIS SUBROUTINE YIELDS A NARROW-WIDTH (68-CHARACTER)
C              PLOT OF Y(I) VERSUS X(I) WITH SPECIAL CHARACTERS
C              FOR THE VARIOUS SUB-TRACES DICTATED BY THE
C              CONTENTS OF THE DUMMY VARIABLE D(.)
C              AND THE CHARACTER VARIABLE ICHAR(.).
C              ALL(X,Y) PAIRS CORRESPONING
C              TO THE MINIMUM VALUE IN D(.)
C              WILL BE PLOTTED WITH PLOT CHARACTER = ICHAR(1).
C              ALL(X,Y) PAIRS CORRESPONING
C              TO THE NEXT LARGER VALUE IN D(.)
C              WILL BE PLOTTED WITH PLOT CHARACTER = ICHAR(2).
C              ETC.
C     NOTE--THE NARROW WIDTH OF THIS PLOT
C           MAKES IT APPROPRIATE FOR
C           USE ON A (DISCRETE) TERMINAL.
C     INPUT ARGUMENTS--Y      = THE SINGLE PRECISION VECTOR OF
C                               (UNSORTED OR SORTED) OBSERVATIONS
C                               TO BE PLOTTED VERTICALLY.
C                    --X      = THE SINGLE PRECISION VECTOR OF
C                               (UNSORTED OR SORTED) OBSERVATIONS
C                               TO BE PLOTTED HORIZONTALLY.
C                    --N      = THE INTEGER NUMBER OF OBSERVATIONS
C                               IN THE VECTOR X.
C                    --ICHAR  = THE HOLLERITH VECTOR OF
C                               CHARACTERS
C                               (1 CHARACTER PER TRACE)
C                    --MAXCHA = THE INTEGER NUMBER OF
C                               CHARACTERS IN ICHAR(.)
C     OUTPUT--A NARROW-WIDTH (68-CHARACTER) TERMINAL PLOT
C             OF Y(I) VERSUS I.
C             THE BODY OF THE PLOT (NOT COUNTING AXIS VALUES
C             AND MARGINS) IS 17 ROWS (LINES) AND 41 COLUMNS.
C     PRINTING--YES.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     COMMENT--NOTE THAT THE STORAGE REQUIREMENTS FOR THIS
C              (AND THE OTHER) TERMINAL PLOT SUBROUTINESS ARE .
C              VERY SMALL.
C              THIS IS DUE TO THE 'ONE LINE AT A TIME' ALGORITHM
C              EMPLOYED FOR THE PLOT.
C     REFERENCES--NONE.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--82.6
C     ORIGINAL VERSION--FEBRUARY  1974.
C     UPDATED         --APRIL     1974.
C     UPDATED         --OCTOBER   1974.
C     UPDATED         --OCTOBER   1975.
C     UPDATED         --NOVEMBER  1975.
C     UPDATED         --FEBRUARY  1977.
C     UPDATED         --JUNE      1978.
C     UPDATED         --NOVEMBER  1981.
C     UPDATED         --DECEMBER  1981.
C     UPDATED         --JANUARY   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 ICHAR
      CHARACTER*4 ICASPL
      CHARACTER*4 ICAS3D
C
      CHARACTER*4 ITITTE
      CHARACTER*4 IX1LTE
      CHARACTER*4 IX2LTE
      CHARACTER*4 IX3LTE
      CHARACTER*4 IY1LTE
      CHARACTER*4 IY2LTE
C
      CHARACTER*4 IERASW
      CHARACTER*4 IBUGU2
      CHARACTER*4 IERROR
C
      CHARACTER*4 IBLANK
      CHARACTER*4 IHYPHE
      CHARACTER*4 IALPHI
      CHARACTER*4 IALPHX
      CHARACTER*4 ILABT
      CHARACTER*4 ILABY
      CHARACTER*4 ILABX1
      CHARACTER*4 ILABX2
      CHARACTER*4 ILABX3
      CHARACTER*4 JPLOTC
      CHARACTER*4 ICASP2
      CHARACTER*4 ILINE
      CHARACTER*4 IAXISC
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOPA.INC'
C
      DIMENSION Y(*)
      DIMENSION X(*)
      DIMENSION D(*)
      DIMENSION ICHAR(*)
C
      DIMENSION ITITTE(*)
      DIMENSION IX1LTE(*)
      DIMENSION IX2LTE(*)
      DIMENSION IX3LTE(*)
      DIMENSION IY1LTE(*)
      DIMENSION IY2LTE(*)
C
      DIMENSION ILABT(132)
      DIMENSION ILABY(132)
      DIMENSION ILABX1(132)
      DIMENSION ILABX2(132)
      DIMENSION ILABX3(132)
C
      DIMENSION ILINE(72)
      DIMENSION AILABL(10)
      DIMENSION DISTD(MAXOBV)
CCCCC FOLLOWING LINES ADDED JUNE, 1990
      INCLUDE 'DPCOZZ.INC'
      EQUIVALENCE (GARBAG(IGARB1),DISTD(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
      IERROR='NO'
C
      ISUBN1='PLOT'
      ISUBN2='CN  '
C
      IBLANK=' '
      IHYPHE='-'
      IALPHI='I'
      IALPHX='X'
C
      IMAXT=0
      IMAXX1=0
      IMAXX2=0
      IMAXX3=0
C
      IF(IBUGU2.EQ.'OFF')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('AT THE BEGINNING OF PLOTCN--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)N,IBUGU2
   52 FORMAT('N,IBUGU2 = ',I8,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)Y(1),X(1),D(1),ICHAR(1)
   53 FORMAT('Y(1),X(1),D(1),ICHAR(1) = ',3E15.7,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,54)Y(N),X(N),D(N),ICHAR(N)
   54 FORMAT('Y(N),X(N),D(N),ICHAR(N) = ',3E15.7,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,55)ICASPL,ICAS3D
   55 FORMAT('ICASPL,ICAS3D = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,72)CPUMIN,CPUMAX
   72 FORMAT('CPUMIN,CPUMAX = ',2E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,73)GX1MIN,GX1MAX,GY1MIN,GY1MAX
   73 FORMAT('GX1MIN,GX1MAX,GY1MIN,GY1MAX = ',4E15.7)
      CALL DPWRST('XXX','BUG ')
   90 CONTINUE
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
C               ***************************************************************
C               **  STEP 2--                                                 **
C               **  DEFINE THE NUMBER OF ROWS AND COLUMNS WITHIN THE PLOT--  **
C               **  THIS HAS BEEN SET TO 21 ROWS AND 41 COLUMNS.             **
C               ***************************************************************
C
CCCCC NUMROW=21
      NUMROW=17
      NUMCOL=41
C
      ANUMR=NUMROW
      ANUMRM=NUMROW-1
      ANUMCM=NUMCOL-1
      NUMR25=(NUMROW/4)+1
      NUMR50=(NUMROW/2)+1
      NUMR75=3*(NUMROW/4)+1
      IXDEL=(NUMCOL-1)/4
C
C               ********************************
C               **  STEP 2.2--                **
C               **  DEFINE THE TYPE OF PLOT.  **
C               ********************************
C
      ICASP2=ICASPL
      IF(ICASPL.EQ.'MDBP')ICASP2='BOXP'
      IF(ICASPL.EQ.'MEBP')ICASP2='BOXP'
      IF(ICASPL.EQ.'VIPL')ICASP2='BOXP'
      IF(ICASPL.EQ.'MDIP')ICASP2='IPLO'
      IF(ICASPL.EQ.'MEIP')ICASP2='IPLO'
      IF(ICASPL.EQ.'MRIP')ICASP2='IPLO'
      IF(ICASPL.EQ.'MMIP')ICASP2='IPLO'
C
C               ******************************************************
C               **  STEP 3--                                        **
C               **  PREPARE THE TITLE LINE, THE Y-AXIS LABEL,       **
C               **  AND THE 3 HORIZONTAL AXIS LABELS FOR PRINTING.  **
C               ******************************************************
C
      YMIDL=NUMROW/2
      XMIDL=22+NUMCOL/2
C
      YFACT=1.0
      XFACT=1.0
C
      ILENT=NCTITL
      ILENY1=NCY1LA
      ILENX1=NCX1LA
      ILENX2=NCX2LA
      ILENX3=NCX3LA
C
      ALENT=ILENT
      ALENY1=ILENY1
      ALENX1=ILENX1
      ALENX2=ILENX2
      ALENX3=ILENX3
C
      IX=XMIDL-XFACT*(ALENT/2.0)
      DO310I=1,132
      ILABT(I)=' '
  310 CONTINUE
      J=IX-1
      IF(ILENT.LE.0)GOTO319
      DO315I=1,ILENT
      J=J+1
      ILABT(J)=ITITTE(I)
  315 CONTINUE
      IMAXT=J
  319 CONTINUE
C
      IY=YMIDL-YFACT*(ALENY1/2.0)
      DO320I=1,132
      ILABY(I)=' '
  320 CONTINUE
      J=IY-1
      IF(ILENY1.LE.0)GOTO329
      DO325I=1,ILENY1
      J=J+1
      ILABY(J)=ITITTE(I)
  325 CONTINUE
      IMAXY1=J
  329 CONTINUE
C
      IX=XMIDL-XFACT*(ALENX1/2.0)
      DO330I=1,132
      ILABX1(I)=' '
  330 CONTINUE
      J=IX-1
      IF(ILENX1.LE.0)GOTO339
      DO335I=1,ILENX1
      J=J+1
      ILABX1(J)=IX1LTE(I)
  335 CONTINUE
      IMAXX1=J
  339 CONTINUE
C
      IX=XMIDL-XFACT*(ALENX2/2.0)
      DO340I=1,132
      ILABX2(I)=' '
  340 CONTINUE
      J=IX-1
      IF(ILENX2.LE.0)GOTO349
      DO345I=1,ILENX2
      J=J+1
      ILABX2(J)=IX2LTE(I)
  345 CONTINUE
      IMAXX2=J
  349 CONTINUE
C
      IX=XMIDL-XFACT*(ALENX3/2.0)
      DO350I=1,132
      ILABX3(I)=' '
  350 CONTINUE
      J=IX-1
      IF(ILENX3.LE.0)GOTO359
      DO355I=1,ILENX3
      J=J+1
      ILABX3(J)=IX3LTE(I)
  355 CONTINUE
      IMAXX3=J
  359 CONTINUE
C
C               ****************************************************************
C               **  STEP 4--
C               **  SKIP TO A NEW PAGE;
C               **  WRITE OUT THE TITLE (IF ANY);
C               **  WRITE OUT THE TOP HORIZONTAL AXIS OF THE PLOT;
C               ****************************************************************
C
      IF(IERASW.EQ.'ON')WRITE(ICOUT,504)
  504 FORMAT(1H1)
      IF(IERASW.EQ.'ON')CALL DPWRST('XXX','BUG ')
      IF(IERASW.EQ.'OFF')WRITE(ICOUT,999)
      IF(IERASW.EQ.'OFF')CALL DPWRST('XXX','BUG ')
      IF(IMAXT.GE.1)WRITE(ICOUT,505)(ILABT(I),I=1,IMAXT)
  505 FORMAT(240A1)
      IF(IMAXT.GE.1)CALL DPWRST('XXX','BUG ')
C
      DO500ICOL=1,NUMCOL
      ILINE(ICOL)=IHYPHE
  500 CONTINUE
      DO550ICOL=1,NUMCOL,IXDEL
      ILINE(ICOL)=IALPHI
  550 CONTINUE
      WRITE(ICOUT,555)(ILINE(I),I=1,NUMCOL)
  555 FORMAT(20X,54A1)
      CALL DPWRST('XXX','BUG ')
C
C
C               *******************************************************
C               **  STEP 5--                                         **
C               **  DETERMINE THE MIN AND MAX VALUES OF Y AND OF X.  **
C               *******************************************************
C
      XMIN=X(1)
      XMAX=X(1)
      YMIN=Y(1)
      YMAX=Y(1)
      DO700I=1,N
      IF(X(I).LT.XMIN)XMIN=X(I)
      IF(X(I).GT.XMAX)XMAX=X(I)
      IF(Y(I).LT.YMIN)YMIN=Y(I)
      IF(Y(I).GT.YMAX)YMAX=Y(I)
  700 CONTINUE
      IF(GX1MIN.NE.CPUMIN)XMIN=GX1MIN
      IF(GX1MAX.NE.CPUMAX)XMAX=GX1MAX
      IF(GY1MIN.NE.CPUMIN)YMIN=GY1MIN
      IF(GY1MAX.NE.CPUMAX)YMAX=GY1MAX
      DELX=XMAX-XMIN
      DELY=YMAX-YMIN
      XWIDTH=DELX/ANUMCM
      YWIDTH=DELY/ANUMRM
C
C               *************************************
C               **  STEP 6--                       **
C               **  DETERMINE THE DISTINCT VALUES  **
C               **  IN THE VARIABLE D(.)           **
C               *************************************
C
      MAXDIS=1000
C
      NUMDIS=1
      DISTD(1)=D(1)
C
      DO900I=2,N
      DO910J=1,NUMDIS
      IF(D(I).EQ.DISTD(J))GOTO900
  910 CONTINUE
      IF(NUMDIS.GE.MAXDIS)GOTO990
      NUMDIS=NUMDIS+1
      DISTD(NUMDIS)=D(I)
  900 CONTINUE
  990 CONTINUE
C
C               ****************************************************************
C               **  STEP 7--
C               **  DETERMINE AND WRITE OUT THE PLOT POSITIONS ONE LINE AT A TIM
C               ****************************************************************
C
      DO1100IROW=1,NUMROW
C
      DO1200ICOL=1,NUMCOL
      ILINE(ICOL)=IBLANK
 1200 CONTINUE
C
      AIROW=IROW
      YUPPER=YMAX+(1.5-AIROW)*YWIDTH
      YLABEL=YMAX+(1.0-AIROW)*YWIDTH
      YLOWER=YMAX+(0.5-AIROW)*YWIDTH
      IF(IROW.EQ.NUMROW)YLABEL=YMIN
      DO1300I=1,N
      AI=I
      IF(YLOWER.LE.Y(I).AND.Y(I).LT.YUPPER)GOTO1350
      GOTO1300
 1350 CONTINUE
      ICOL=((X(I)-XMIN)/XWIDTH)+1.5
      IF(ICOL.LT.1.OR.ICOL.GT.NUMCOL)GOTO1300
      DO1360K=1,NUMDIS
      K2=K
      IF(D(I).EQ.DISTD(K))GOTO1370
 1360 CONTINUE
      JPLOTC='X'
      GOTO1390
 1370 CONTINUE
      JPLOTC='X'
      IF(ICASP2.EQ.'BOXP')K2=K2-((K2-1)/20)*20
      IF(ICASP2.EQ.'IPLO')K2=K2-((K2-1)/5)*5
      IF(K2.LE.MAXCHA)JPLOTC=ICHAR(K2)
      IF(JPLOTC.EQ.'    ')JPLOTC='X'
      IF(JPLOTC.EQ.'BLAN')JPLOTC='X'
      IF(JPLOTC.EQ.'NONE')JPLOTC='X'
      GOTO1390
 1390 CONTINUE
      ILINE(ICOL)=JPLOTC
 1300 CONTINUE
C
      ICOLMX=1
      DO1400ICOL=1,NUMCOL
      ICOLRV=NUMCOL-ICOL+1
      IF(ILINE(ICOLRV).EQ.' ')GOTO1400
      ICOLMX=ICOLRV
      GOTO1490
 1400 CONTINUE
 1490 CONTINUE
C
      IAXISC=IALPHI
      IF(IROW.EQ.1.OR.IROW.EQ.NUMROW)IAXISC=IHYPHE
      IF(IROW.EQ.NUMR25.OR.IROW.EQ.NUMR50.OR.IROW.EQ.NUMR75)
     1IAXISC=IHYPHE
      WRITE(ICOUT,1410)ILABY(IROW),YLABEL,IAXISC,
     1(ILINE(ICOL),ICOL=1,ICOLMX)
 1410 FORMAT(A1,1X,E14.7,1X,A1,2X,50A1)
      CALL DPWRST('XXX','BUG ')
C
 1100 CONTINUE
C
C               ************************************************************
C               **  STEP 8--                                              **
C               **  WRITE OUT THE BOTTOM HORIZONTAL AXIS OF THE PLOT;     **
C               **  WRITE OUT THE X-AXIS NUMERIC LABELS;                  **
C               **  WRITE OUT THE FIRST  HORIZONTAL AXIS LABEL (IF ANY);  **
C               **  WRITE OUT THE SECOND HORIZONTAL AXIS LABEL (IF ANY);  **
C               **  WRITE OUT THE THIRD  HORIZONTAL AXIS LABEL (IF ANY).  **
C               ************************************************************
C
C
      DO2200ICOL=1,NUMCOL
      ILINE(ICOL)=IHYPHE
 2200 CONTINUE
      DO2300ICOL=1,NUMCOL,IXDEL
      ILINE(ICOL)=IALPHI
 2300 CONTINUE
      WRITE(ICOUT,2105)(ILINE(ICOL),ICOL=1,NUMCOL)
 2105 FORMAT(20X,54A1)
      CALL DPWRST('XXX','BUG ')
C
      NUMLAB=5
      ANUMLM=NUMLAB-1
      DO2500I=1,NUMLAB
      AIM1=I-1
      AILABL(I)=XMIN+(AIM1/ANUMLM)*DELX
 2500 CONTINUE
      WRITE(ICOUT,2310)(AILABL(I),I=1,NUMLAB)
 2310 FORMAT(13X,5E10.4)
      CALL DPWRST('XXX','BUG ')
C
      IF(IMAXX1.GE.1)WRITE(ICOUT,2311)(ILABX1(I),I=1,IMAXX1)
 2311 FORMAT(240A1)
      IF(IMAXX1.GE.1)CALL DPWRST('XXX','BUG ')
      IF(IMAXX2.GE.1)WRITE(ICOUT,2311)(ILABX2(I),I=1,IMAXX2)
      IF(IMAXX2.GE.1)CALL DPWRST('XXX','BUG ')
      IF(IMAXX3.GE.1)WRITE(ICOUT,2311)(ILABX3(I),I=1,IMAXX3)
      IF(IMAXX3.GE.1)CALL DPWRST('XXX','BUG ')
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE PLOTCW(Y,X,D,N,ICHAR,MAXCHA,ICASPL,ICAS3D,
     1ITITTE,NCTITL,
     1IX1LTE,NCX1LA,
     1IX2LTE,NCX2LA,
     1IX3LTE,NCX3LA,
     1IY1LTE,NCY1LA,
     1IY2LTE,NCY2LA,
     1GX1MIN,GX1MAX,GY1MIN,GY1MAX,
     1IERASW,IBUGU2,IERROR)
C
C     PURPOSE--THIS SUBROUTINE YIELDS A WIDE-WIDTH (130-CHARACTER)
C              PLOT OF Y(I) VERSUS X(I) WITH SPECIAL CHARACTERS
C              FOR THE VARIOUS SUB-TRACES DICTATED BY THE
C              CONTENTS OF THE DUMMY VARIABLE D(.)
C              AND THE CHARACTER VARIABLE ICHAR(.).
C              ALL(X,Y) PAIRS CORRESPONING
C              TO THE MINIMUM VALUE IN D(.)
C              WILL BE PLOTTED WITH PLOT CHARACTER = ICHAR(1).
C              ALL(X,Y) PAIRS CORRESPONING
C              TO THE NEXT LARGER VALUE IN D(.)
C              WILL BE PLOTTED WITH PLOT CHARACTER = ICHAR(2).
C              ETC.
C      NOTE--THE WIDE WIDTH OF THIS PLOT
C            MAKES IT APPROPRIATE FOR
C            USE ON A BATCH PRINTER.
C     INPUT ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF
C                               (UNSORTED OR SORTED) OBSERVATIONS
C                               TO BE PLOTTED VERTICALLY.
C                    --N      = THE INTEGER NUMBER OF OBSERVATIONS
C                               IN THE VECTOR X.
C                    --ICHAR  = THE HOLLERITH VECTOR OF
C                               CHARACTERS (ONLY THE
C                               FIRST OF WHICH WILL BE USED)
C                    --MAXCHA = THE INTEGER NUMBER OF
C                               CHARACTERS IN ICHAR(.)
C     OUTPUT--A WIDE-WIDTH (130-CHARACTER) TERMINAL PLOT
C             OF Y(I) VERSUS X(I).
C             THE BODY OF THE PLOT (NOT COUNTING AXIS VALUES
C             AND MARGINS) IS 41 ROWS (LINES) AND 101 COLUMNS.
C     PRINTING--YES.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--NONE.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (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         --JULY      1975.
C     UPDATED         --SEPTEMBER 1975.
C     UPDATED         --OCTOBER   1975.
C     UPDATED         --NOVEMBER  1975.
C     UPDATED         --FEBRUARY  1976.
C     UPDATED         --FEBRUARY  1977.
C     UPDATED         --JUNE      1978.
C     UPDATED         --NOVEMBER  1981.
C     UPDATED         --DECEMBER  1981.
C     UPDATED         --JANUARY   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 ICHAR
      CHARACTER*4 ICASPL
      CHARACTER*4 ICAS3D
C
      CHARACTER*4 ITITTE
      CHARACTER*4 IX1LTE
      CHARACTER*4 IX2LTE
      CHARACTER*4 IX3LTE
      CHARACTER*4 IY1LTE
      CHARACTER*4 IY2LTE
C
      CHARACTER*4 IERASW
      CHARACTER*4 IBUGU2
      CHARACTER*4 IERROR
C
      CHARACTER*4 IBLANK
      CHARACTER*4 IHYPHE
      CHARACTER*4 IALPHI
      CHARACTER*4 IALPHX
      CHARACTER*4 IALPHM
      CHARACTER*4 IALPHA
      CHARACTER*4 IALPHN
      CHARACTER*4 IALPHD
      CHARACTER*4 IEQUAL
C
      CHARACTER*4 ILABT
      CHARACTER*4 ILABY1
      CHARACTER*4 ILABX1
      CHARACTER*4 ILABX2
      CHARACTER*4 ILABX3
C
      CHARACTER*4 JPLOTC
      CHARACTER*4 IGRAPH
      CHARACTER*4 ICASP2
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOPA.INC'
C
      DIMENSION Y(*)
      DIMENSION X(*)
      DIMENSION D(*)
      DIMENSION ICHAR(*)
      DIMENSION IGRAPH(55,130)
C
      DIMENSION ITITTE(*)
      DIMENSION IX1LTE(*)
      DIMENSION IX2LTE(*)
      DIMENSION IX3LTE(*)
      DIMENSION IY1LTE(*)
      DIMENSION IY2LTE(*)
C
      DIMENSION ILABT(132)
      DIMENSION ILABY1(132)
      DIMENSION ILABX1(132)
      DIMENSION ILABX2(132)
      DIMENSION ILABX3(132)
C
      DIMENSION YLABEL(11)
      DIMENSION DISTD(MAXOBV)
CCCCC FOLLOWING LINES ADDED JUNE, 1990
      INCLUDE 'DPCOZZ.INC'
      EQUIVALENCE (GARBAG(IGARB1),DISTD(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
      IERROR='NO'
C
      IBLANK=' '
      IHYPHE='-'
      IALPHI='I'
      IALPHX='X'
      IALPHM='M'
      IALPHA='A'
      IALPHX='X'
      IALPHN='N'
      IALPHD='D'
      IALPHN='N'
      IEQUAL='='
C
      IMAXT=0
      IMAXX1=0
      IMAXX2=0
      IMAXX3=0
C
      IF(IBUGU2.EQ.'OFF')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('AT THE BEGINNING OF PLOTCW--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)N,IBUGU2
   52 FORMAT('N,IBUGU2 = ',I8,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)Y(1),X(1),D(1),ICHAR(1)
   53 FORMAT('Y(1),X(1),D(1),ICHAR(1) = ',3E15.7,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,54)Y(N),X(N),D(N),ICHAR(N)
   54 FORMAT('Y(N),X(N),D(N),ICHAR(N) = ',3E15.7,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,55)ICASPL,ICAS3D
   55 FORMAT('ICASPL,ICAS3D = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,72)CPUMIN,CPUMAX
   72 FORMAT('CPUMIN,CPUMAX = ',2E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,73)GX1MIN,GX1MAX,GY1MIN,GY1MAX
   73 FORMAT('GX1MIN,GX1MAX,GY1MIN,GY1MAX = ',4E15.7)
      CALL DPWRST('XXX','BUG ')
   90 CONTINUE
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
C               *************************************
C               **  STEP 1.5--                     **
C               **  DETERMINE THE DISTINCT VALUES  **
C               **  IN THE VARIABLE D(.)           **
C               *************************************
C
      MAXDIS=1000
C
      NUMDIS=1
      DISTD(1)=D(1)
C
      DO250I=2,N
      DO260J=1,NUMDIS
      IF(D(I).EQ.DISTD(J))GOTO250
  260 CONTINUE
      IF(NUMDIS.GE.MAXDIS)GOTO269
      NUMDIS=NUMDIS+1
      DISTD(NUMDIS)=D(I)
  250 CONTINUE
  269 CONTINUE
C
C
C               ***************************************************************
C               **  STEP 2--                                                 **
C               **  DEFINE THE NUMBER OF ROWS AND COLUMNS WITHIN THE PLOT--  **
C               **  THIS HAS BEEN SET TO 41 ROWS AND  97 COLUMNS.            **
C               ***************************************************************
C
      NUMROW=41
      NUMCOL=97
C
      ANUMR=NUMROW
      ANUMRM=NUMROW-1
      ANUMCM=NUMCOL-1
      NUMR25=(NUMROW/4)+1
      NUMR50=(NUMROW/2)+1
      NUMR75=3*(NUMROW/4)+1
      IXDEL=(NUMCOL-1)/4
C
C               ***************************
C               **  STEP 2.1--           **
C               **  BLANK OUT THE GRAPH  **
C               ***************************
C
      DO280I=1,55
      DO290J=1,130
      IGRAPH(I,J)=IBLANK
  290 CONTINUE
  280 CONTINUE
C
C               ********************************
C               **  STEP 2.2--                **
C               **  DEFINE THE TYPE OF PLOT.  **
C               ********************************
C
      ICASP2=ICASPL
      IF(ICASPL.EQ.'MDBP')ICASP2='BOXP'
      IF(ICASPL.EQ.'MEBP')ICASP2='BOXP'
      IF(ICASPL.EQ.'VIPL')ICASP2='BOXP'
      IF(ICASPL.EQ.'MDIP')ICASP2='IPLO'
      IF(ICASPL.EQ.'MEIP')ICASP2='IPLO'
      IF(ICASPL.EQ.'MRIP')ICASP2='IPLO'
      IF(ICASPL.EQ.'MMIP')ICASP2='IPLO'
C
C               ******************************************************
C               **  STEP 3--                                        **
C               **  PREPARE THE TITLE LINE, THE Y-AXIS LABEL,       **
C               **  AND THE 3 HORIZONTAL AXIS LABELS FOR PRINTING.  **
C               ******************************************************
C
      YMIDL=(55/2)-4
      XMIDL=29+NUMCOL/2
C
      YFACT=1.0
      XFACT=1.0
C
      ILENT=NCTITL
      ILENY1=NCY1LA
      ILENX1=NCX1LA
      ILENX2=NCX2LA
      ILENX3=NCX3LA
C
      ALENT=ILENT
      ALENY1=ILENY1
      ALENX1=ILENX1
      ALENX2=ILENX2
      ALENX3=ILENX3
C
      IX=XMIDL-XFACT*(ALENT/2.0)
      DO310I=1,132
      ILABT(I)=' '
  310 CONTINUE
      J=IX-1
      IF(ILENT.LE.0)GOTO319
      DO315I=1,ILENT
      J=J+1
      ILABT(J)=ITITTE(I)
  315 CONTINUE
      IMAXT=J
  319 CONTINUE
C
      IY=YMIDL-YFACT*(ALENY1/2.0)
      DO320I=1,132
      ILABY1(I)=' '
  320 CONTINUE
      J=IY-1
      IF(ILENY1.LE.0)GOTO329
      DO325I=1,ILENY1
      J=J+1
      ILABY1(J)=IY1LTE(I)
  325 CONTINUE
      IMAXY1=J
  329 CONTINUE
C
      IX=XMIDL-XFACT*(ALENX1/2.0)
      DO330I=1,132
      ILABX1(I)=' '
  330 CONTINUE
      J=IX-1
      IF(ILENX1.LE.0)GOTO339
      DO335I=1,ILENX1
      J=J+1
      ILABX1(J)=IX1LTE(I)
  335 CONTINUE
      IMAXX1=J
  339 CONTINUE
C
      IX=XMIDL-XFACT*(ALENX2/2.0)
      DO340I=1,132
      ILABX2(I)=' '
  340 CONTINUE
      J=IX-1
      IF(ILENX2.LE.0)GOTO349
      DO345I=1,ILENX2
      J=J+1
      ILABX2(J)=IX2LTE(I)
  345 CONTINUE
      IMAXX2=J
  349 CONTINUE
C
      IX=XMIDL-XFACT*(ALENX3/2.0)
      DO350I=1,132
      ILABX3(I)=' '
  350 CONTINUE
      J=IX-1
      IF(ILENX3.LE.0)GOTO359
      DO355I=1,ILENX3
      J=J+1
      ILABX3(J)=IX3LTE(I)
  355 CONTINUE
      IMAXX3=J
  359 CONTINUE
C
C               *******************************************************
C               **  STEP 5--                                         **
C               **  DETERMINE THE MIN AND MAX VALUES OF Y AND OF X.  **
C               *******************************************************
C
      YMIN=Y(1)
      YMAX=Y(1)
      XMIN=X(1)
      XMAX=X(1)
      DO700I=1,N
      IF(Y(I).LT.YMIN)YMIN=Y(I)
      IF(Y(I).GT.YMAX)YMAX=Y(I)
      IF(X(I).LT.XMIN)XMIN=X(I)
      IF(X(I).GT.XMAX)XMAX=X(I)
  700 CONTINUE
      IF(GX1MIN.NE.CPUMIN)XMIN=GX1MIN
      IF(GX1MAX.NE.CPUMAX)XMAX=GX1MAX
      IF(GY1MIN.NE.CPUMIN)YMIN=GY1MIN
      IF(GY1MAX.NE.CPUMAX)YMAX=GY1MAX
      DELY=YMAX-YMIN
      DELX=XMAX-XMIN
      YWIDTH=DELY/ANUMRM
      XWIDTH=DELX/ANUMCM
C
      XMID=(XMIN+XMAX)/2.0
      X25=0.75*XMIN+0.25*XMAX
      X75=0.25*XMIN+0.75*XMAX
C
      DO800I=1,9
      AIM1=I-1
      YLABEL(I)=YMAX-(AIM1/8.0)*(YMAX-YMIN)
  800 CONTINUE
C
C               *********************************
C               **  STEP 6--                   **
C               **  PRODUCE THE VERTICAL AXES  **
C               *********************************
C
      DO1300I=3,43
      IGRAPH(I,5)=IALPHI
      IGRAPH(I,105)=IALPHI
 1300 CONTINUE
      DO1400I=3,43,5
      IGRAPH(I,5)=IHYPHE
      IGRAPH(I,105)=IHYPHE
 1400 CONTINUE
      IGRAPH(3,1)=IEQUAL
      IGRAPH(3,2)=IALPHM
      IGRAPH(3,3)=IALPHA
      IGRAPH(3,4)=IALPHX
      IGRAPH(23,1)=IEQUAL
      IGRAPH(23,2)=IALPHM
      IGRAPH(23,3)=IALPHI
      IGRAPH(23,4)=IALPHD
      IGRAPH(43,1)=IEQUAL
      IGRAPH(43,2)=IALPHM
      IGRAPH(43,3)=IALPHI
      IGRAPH(43,4)=IALPHN
C
C               ***********************************
C               **  STEP 7--                     **
C               **  PRODUCE THE HORIZONTAL AXES  **
C               ***********************************
C
      DO1500J=7,103
      IGRAPH(1,J)=IHYPHE
      IGRAPH(45,J)=IHYPHE
 1500 CONTINUE
      DO1600J=7,103,12
      IGRAPH(1,J)=IALPHI
      IGRAPH(45,J)=IALPHI
 1600 CONTINUE
C
C               ******************************************
C               **  STEP 8--                            **
C               **  DETERMINE THE (X,Y) PLOT POSITIONS  **
C               ******************************************
C
      RATIOY=ANUMRM/(YMAX-YMIN)
      RATIOX=ANUMCM/(XMAX-XMIN)
      DO1800I=1,N
      XI=X(I)
      MX=RATIOX*(XI-XMIN)+0.5
      MX=MX+7
      IF(MX.LT.7.OR.MX.GT.103)GOTO1800
      MY=RATIOY*(Y(I)-YMIN)+0.5
      MY=43-MY
      IF(MY.LT.3.OR.MY.GT.43)GOTO1800
      DO1860K=1,NUMDIS
      K2=K
      IF(D(I).EQ.DISTD(K))GOTO1870
 1860 CONTINUE
      JPLOTC='X'
      GOTO1890
 1870 CONTINUE
      JPLOTC='X'
      IF(ICASP2.EQ.'BOXP')K2=K2-((K2-1)/20)*20
      IF(ICASP2.EQ.'IPLO')K2=K2-((K2-1)/5)*5
      IF(K2.LE.MAXCHA)JPLOTC=ICHAR(K2)
      IF(JPLOTC.EQ.'    ')JPLOTC='X'
      IF(JPLOTC.EQ.'BLAN')JPLOTC='X'
      IF(JPLOTC.EQ.'NONE')JPLOTC='X'
      GOTO1890
 1890 CONTINUE
      IGRAPH(MY,MX)=JPLOTC
 1800 CONTINUE
C
C               *************************************
C               **  STEP 9--                       **
C               **  SKIP TO A NEW PAGE.            **
C               **  WRITE OUT THE TITLE (IF ANY);  **
C               *************************************
C
      IF(IERASW.EQ.'ON')WRITE(ICOUT,2004)
 2004 FORMAT(1H1)
      IF(IERASW.EQ.'ON')CALL DPWRST('XXX','BUG ')
      IF(IERASW.EQ.'OFF')WRITE(ICOUT,999)
      IF(IERASW.EQ.'OFF')CALL DPWRST('XXX','BUG ')
      IF(IMAXT.GE.1)WRITE(ICOUT,2005)(ILABT(I),I=1,IMAXT)
 2005 FORMAT(240A1)
      IF(IMAXT.GE.1)CALL DPWRST('XXX','BUG ')
      IF(IMAXT.LE.0)WRITE(ICOUT,999)
      IF(IMAXT.LE.0)CALL DPWRST('XXX','BUG ')
C
C               *********************************************
C               **  STEP 10--                              **
C               **  WRITE OUT THE GRAPH                    **
C               **  (INCLUDING THE X-AXIS NUMERIC LABELS)  **
C               *********************************************
C
      DO2100I=1,45
      IP2=I+2
      IFLAG=IP2-(IP2/5)*5
      K=IP2/5
      IF(IFLAG.NE.0)WRITE(ICOUT,2105)ILABY1(I),(IGRAPH(I,J),J=1,105)
 2105 FORMAT(A1,20X,105A1)
      IF(IFLAG.NE.0)CALL DPWRST('XXX','BUG ')
      IF(IFLAG.EQ.0)WRITE(ICOUT,2106)ILABY1(I),YLABEL(K),
     1(IGRAPH(I,J),J=1,105)
 2106 FORMAT(A1,F20.7,105A1)
      IF(IFLAG.EQ.0)CALL DPWRST('XXX','BUG ')
 2100 CONTINUE
      WRITE(ICOUT,2107)XMIN,X25,XMID,X75,XMAX
 2107 FORMAT(14X,F20.7,4X,F20.7,4X,F20.7,4X,F20.7,4X,F20.7)
      CALL DPWRST('XXX','BUG ')
C
C               ************************************************************
C               **  STEP 11--                                             **
C               **  WRITE OUT THE FIRST  HORIZONTAL AXIS LABEL (IF ANY);  **
C               **  WRITE OUT THE SECOND HORIZONTAL AXIS LABEL (IF ANY);  **
C               **  WRITE OUT THE THIRD  HORIZONTAL AXIS LABEL (IF ANY).  **
C               ************************************************************
C
      IF(IMAXX1.GE.1)WRITE(ICOUT,2311)(ILABX1(I),I=1,IMAXX1)
 2311 FORMAT(240A1)
      IF(IMAXX1.GE.1)CALL DPWRST('XXX','BUG ')
      IF(IMAXX1.LE.0)WRITE(ICOUT,999)
      IF(IMAXX1.LE.0)CALL DPWRST('XXX','BUG ')
      IF(IMAXX2.GE.1)WRITE(ICOUT,2311)(ILABX2(I),I=1,IMAXX2)
      IF(IMAXX2.GE.1)CALL DPWRST('XXX','BUG ')
      IF(IMAXX2.LE.0)WRITE(ICOUT,999)
      IF(IMAXX2.LE.0)CALL DPWRST('XXX','BUG ')
      IF(IMAXX3.GE.1)WRITE(ICOUT,2311)(ILABX3(I),I=1,IMAXX3)
      IF(IMAXX3.GE.1)CALL DPWRST('XXX','BUG ')
      IF(IMAXX3.LE.0)WRITE(ICOUT,999)
      IF(IMAXX3.LE.0)CALL DPWRST('XXX','BUG ')
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE PLOTGE(Y,X,X3D,D,N,XIDC,NUMSET,
     1ICASPL,ICAS3D,
     1ISQUAR,
     1YSAVE,
     1IVGMSW,IHGMSW,
     1IFIRST,ILAST,
     1IHNAME,IHNAM2,IUSE,IVALUE,VALUE,NUMNAM,
     1IVSTAR,IVSTOP,IFUNC,NUMCHF,IREPCH,
CCCCC FOLLOWING LINE ADDED AUGUST 1992.
     1DSIZE,DSYMB,DCOLOR,DFILL,
     1ICAPSW,
     1IBUGU2,IBUGU3,IBUGU4,ISUBRO,
     1IERROR)
C
C     PURPOSE--GENERATE A GENERAL (SINGLE OR MULTIPLE TRACE) PLOT
C              ON A GENERAL GRAPHICS DEVICE.
C              THE PLOT WILL CONSIST OF Y VERSUS X
C              WITH EACH DISTINCT VALUE OF THE VARIABLE D
C              RESULTING IN A DISTINCT TRACE ON THE PLOT.
C
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--82.6
C     ORIGINAL VERSION--AUGUST 22, 1977.
C     UPDATED         --DECEMBER  1977.
C     UPDATED         --JUNE      1978.
C     UPDATED         --OCTOBER   1978.
C     UPDATED         --MARCH     1979.
C     UPDATED         --JUNE      1979.
C     UPDATED         --JANUARY   1981.
C     UPDATED         --FEBRUARY  1981.
C     UPDATED         --MARCH     1981.
C     UPDATED         --APRIL     1981.
C     UPDATED         --AUGUST    1981.
C     UPDATED         --DECEMBER  1981.
C     UPDATED         --MAY       1982.
C     UPDATED         --JULY      1983.
C     UPDATED         --SEPTEMBER 1988.  3D HIDDEN LINE ETC.
C     UPDATED         --OCTOBER   1988.  ERROR BAR PLOT
C     UPDATED         --FEBRUARY  1989.  HORIZONTAL SWITCH (ALAN)
C     UPDATED         --MAY       1989.  DES. OF EXP. PLOTS
C     UPDATED         --JUNE      1990. TEMPORARY ARRAYS TO GARBAGE COMMON
C     UPDATED         --JUNE      1992.  BLOCK PLOTS
C     UPDATED         --AUGUST    1992.  VECTOR PLOT.  ALSO, BUG IF
C                                        NUMSET =101, 201, ETC.
C     UPDATED         --AUGUST    1992.  SYMBOL PLOT
C     UPDATED         --NOVEMBER  1993.  MODIFICATION FOR PIE CHART
C     UPDATED         --AUGUST    1994.  BUG FOR VECTOR PLOT
C     UPDATED         --DECEMBER  1994.  EXACT CHARACTER MAPPING
C     UPDATED         --JUNE      1995.  BLOCK PLOT FIX--KEEP
C     UPDATED                                            ISET3 <= 100
C
C     UPDATED         --MAY       1998.  DUANE PLOTS NEED LOG SCALES
C     UPDATED         --DECEMBER  1999. IMPLEMENT SUB-REGIONS
C     UPDATED         --JANUARY   2000. IMPLEMENT ZVAL CHARACTER TYPE
C     UPDATED         --AUGUST    2001. CONSENSUS MEAN PLOT, SET
C                                       CHAR/LINE TYPES SIMILAR TO
C                                       I-PLOT
C     UPDATED         --FEBRUARY  2003. VIOLIN PLOT (SIMILAR TO BOX
C                                       PLOT, EXTRA TRACE AT
C                                       BEGINNING)
C     UPDATED         --MARCH     2003. PARALLEL COORDINATES PLOT
C                                       (PRE-SORT OFF)
C     UPDATED         --MAY       2003. GROUPED PARALLEL COORDINATES
C                                       PLOT
C
C-----NON-COMMON VARIABLES--------------------------------------------
C
C
      CHARACTER*4 ICAPSW
C
      CHARACTER*4 ISQUAR
C
      CHARACTER*4 IVGMSW
      CHARACTER*4 IHGMSW
C
      CHARACTER*4 ICASPL
      CHARACTER*4 ICAS3D
      CHARACTER*4 IFIRST
      CHARACTER*4 ILAST
C
      CHARACTER*4 IHNAME
      CHARACTER*4 IHNAM2
      CHARACTER*4 IUSE
      CHARACTER*4 IFUNC
C
      CHARACTER*1 IREPCH
C
      CHARACTER*4 IBUGU2
      CHARACTER*4 IBUGU3
      CHARACTER*4 IBUGU4
      CHARACTER*4 ISUBRO
C
      CHARACTER*4 IERROR
C
      CHARACTER*4 IMORE
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 ISTEPN
C
      CHARACTER*4 ICH3PA
C
      CHARACTER*4 IOPGRS
      CHARACTER*4 IOPG2S
      CHARACTER*4 IDELIS
      CHARACTER*4 IDRFRS
      CHARACTER*4 IWRLAS
      CHARACTER*4 IWRLES
      CHARACTER*4 IDRTRS
      CHARACTER*4 ICLG2S
      CHARACTER*4 ICLGRS
C
      CHARACTER*4 ISWTCH
CCCCC ADD FOLLOWING 4 LINES MAY, 1998.
      CHARACTER*4 IX1TMP
      CHARACTER*4 IX2TMP
      CHARACTER*4 IY1TMP
      CHARACTER*4 IY2TMP
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOPA.INC'
      INCLUDE 'DPCO3D.INC'
C
      DIMENSION Y(*)
      DIMENSION X(*)
      DIMENSION X3D(*)
      DIMENSION D(*)
CCCCC FOLLOWING 4 LINES ADDED AUGUST 1992
      DIMENSION DSIZE(*)
      DIMENSION DSYMB(*)
      DIMENSION DCOLOR(*)
      DIMENSION DFILL(*)
C
      DIMENSION XIDC(*)
C
      DIMENSION IHNAME(*)
      DIMENSION IHNAM2(*)
      DIMENSION IUSE(*)
      DIMENSION IVALUE(*)
      DIMENSION VALUE(*)
      DIMENSION IVSTAR(*)
      DIMENSION IVSTOP(*)
      DIMENSION IFUNC(*)
C
CCCCC DIMENSION Y2(1000)
CCCCC DIMENSION X2(1000)
C
CCCCC DIMENSION Y3(1000)
CCCCC DIMENSION X3(1000)
C
CCCCC DIMENSION Y4(1000)
CCCCC DIMENSION X4(1000)
C
CCCCC DIMENSION Y5(1000)
CCCCC DIMENSION X5(1000)
C
      DIMENSION X2(MAXPOP)
      DIMENSION Y2(MAXPOP)
      DIMENSION Z2(MAXPOP)
      DIMENSION X3D2(MAXPOP)
C
      DIMENSION X3(MAXPOP)
      DIMENSION Y3(MAXPOP)
      DIMENSION Z3(MAXPOP)
C
      DIMENSION X4(MAXPOP)
      DIMENSION Y4(MAXPOP)
      DIMENSION Z4(MAXPOP)
C
CCCCC I HAVE THE FOLLOWING 2 DIMENSIONS AS MAXPOP.
CCCCC ALAN HAS THE FOLLOWING 2 DIMENSIONS AS 1.
CCCCC CHECK ON THE REASON FOR THE DIFFERENCE.
      DIMENSION X5(MAXPOP)
      DIMENSION Y5(MAXPOP)
CCCCC FOLLOWING LINES ADDED JUNE, 1990
      INCLUDE 'DPCOZZ.INC'
      INCLUDE 'DPCOZ2.INC'
      EQUIVALENCE (GARBAG(IGARG1),X2(1))
      EQUIVALENCE (GARBAG(IGARG2),Y2(1))
      EQUIVALENCE (GARBAG(IGARG3),Z2(1))
      EQUIVALENCE (GARBAG(IGARG4),X3D2(1))
      EQUIVALENCE (GARBAG(IGARG5),X3(1))
      EQUIVALENCE (G2RBAG(IGARG6),Y3(1))
      EQUIVALENCE (G2RBAG(IGARG7),Z3(1))
      EQUIVALENCE (G2RBAG(IGARG8),X4(1))
      EQUIVALENCE (G2RBAG(IGARG9),Y4(1))
      EQUIVALENCE (G2RBAG(IGRG10),Z4(1))
      EQUIVALENCE (G2RBAG(IGRG11),X5(1))
      EQUIVALENCE (G2RBAG(IGRG12),Y5(1))
CCCCC END CHANGE
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOPC.INC'
      INCLUDE 'DPCOGR.INC'
      INCLUDE 'DPCOBE.INC'
      INCLUDE 'DPCOSU.INC'
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='PLOT'
      ISUBN2='GE  '
C
      IBUGG4=IBUGU2
      ISUBG4=ISUBRO
      IERRG4=IERROR
C
      ISWTCH='OFF'
C
CCCCC DECEMBER 1999.  DETERMINE NUMBER OF SUB-REGIONS ON PLOT.
      NUMSBR=0
      DO20I=1,MAXSUB
        IF(ISUBSW(I).EQ.'ON')NUMSBR=NUMSBR+1
   20 CONTINUE
C
CCCCC THE FOLLOWING COMMENT AND REPLACEMENT WAS MADE FEBRUARY 1989 (ALAN)
CCCCC MXNPPC=1000
      MXNPPC=MAXPOP
C
      XDELMN=CPUMAX
      YDELMN=CPUMAX
      ZDELMN=CPUMAX
CCCCC FOLLOWING BLOCK ADDED AUGUST 1992.
      ASETSZ=1.0
      ISETSY=1
      ISETCL=1
      ISETFI=0
CCCCC ADD FOLLOWING SECTION FOR DUANE PLOTS.   MAY 1998.
      IF(ICASPL.EQ.'DUAN')THEN
        IX1TMP=IX1TSC
        IX2TMP=IX2TSC
        IY1TMP=IY1TSC
        IY2TMP=IY2TSC
        IX1TSC='LOG'
        IX2TSC='LOG'
        IY1TSC='LOG'
        IY2TSC='LOG'
      ENDIF
C
CCCCC ALAN COMMENTED OUT THE FOLLOWING LINE FEBRUARY 1989
CCCCC YSAVE=0.0
C
      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'OTGE')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF PLOTGE--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)N,NUMSET
   52 FORMAT('N,NUMSET = ',2I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)ICASPL,ICAS3D,I3DPRO
   53 FORMAT('ICASPL,ICAS3D,I3DPRO,I3DPRO = ',A4,2X,A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,54)ISQUAR
   54 FORMAT('ISQUAR = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,55)IFIRST,ILAST
   55 FORMAT('IFIRST,ILAST = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,58)IBUGG4,ISUBG4,IERRG4
   58 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,59)IBUGU2,ISUBRO,IERROR
   59 FORMAT('IBUGU2,ISUBRO,IERROR = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,61)ILINPA(1),ILINPA(2)
   61 FORMAT('ILINPA(1),ILINPA(2) = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,62)ICHAPA(1),ICHAPA(2)
   62 FORMAT('ICHAPA(1),ICHAPA(2) = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,63)ISPILI(1),ISPILI(2)
   63 FORMAT('ISPILI(1),ISPILI(2) = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,64)IX1JSW,IY1JSW
   64 FORMAT('IX1JSW,IY1JSW = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,65)IX1NSW,IY1NSW
   65 FORMAT('IX1NSW,IY1NSW = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,66)ASPIBA(1),ASPIBA(2)
   66 FORMAT('ASPIBA(1),ASPIBA(2) = ',2E15.7)
      CALL DPWRST('XXX','BUG ')
   90 CONTINUE
C
C               ******************************************
C               **  STEP 1--                            **
C               **  CARRY OUT PRE-PLOT ACTIVITIES.      **
C               ******************************************
C
      IF(IFIRST.EQ.'YES')GOTO1000
      GOTO1090
C
 1000 CONTINUE
C
      ISTEPN='1'
      IF(IBUGG4.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IOPGRS='ON'
      IOPG2S='ON'
      IDELIS='ON'
      IDRFRS='OFF'
      IWRLAS='OFF'
      IWRLES='OFF'
      IDRTRS='OFF'
      ICLG2S='OFF'
      ICLGRS='OFF'
C
      ISTEP=1
      ISUBST=1
      ISET=1
      ISET3=ISET
      ICH3PA=ICHAPA(ISET3)
C
      IF(ICAS3D.EQ.'OFF')
     1CALL PLOTG2(Y,X,Y2,X2,N,Y4,X4,N4,Y5,X5,N5,NUMSET,X3D,
     1ICASPL,ICAS3D,
     1ISQUAR,
     1IVGMSW,IHGMSW,
     1XDELMN,
     1ISTEP,ISUBST,ISET,ISET3,ICH3PA,
     1IOPGRS,IOPG2S,IDELIS,IDRFRS,IWRLAS,IWRLES,IDRTRS,ICLG2S,ICLGRS,
     1IHNAME,IHNAM2,IUSE,IVALUE,VALUE,NUMNAM,
     1ASETSZ,ISETSY,ISETCL,ISETFI,
     1NUMSBR,
     1ICAPSW,
     1IVSTAR,IVSTOP,IFUNC,NUMCHF,IREPCH,ISWTCH)
      IF(ICAS3D.EQ.'ON')
     1CALL PLOTG3(X,X3D,Y,N,DSIZE,
     1X2,Y2,Z2,X4,Y4,Z4,N4,X5,Y5,N5,NUMSET,
     1ICASPL,ICAS3D,
     1ISQUAR,
     1IVGMSW,IHGMSW,
     1XDELMN,YDELMN,ZDELMN,
     1ISTEP,ISUBST,ISET,ISET3,ICH3PA,
     1IOPGRS,IOPG2S,IDELIS,IDRFRS,IWRLAS,IWRLES,IDRTRS,ICLG2S,ICLGRS,
     1ICAPSW,
     1IHNAME,IHNAM2,IUSE,IVALUE,VALUE,NUMNAM,
     1IVSTAR,IVSTOP,IFUNC,NUMCHF,IREPCH,ISWTCH)
      IF(IERRG4.EQ.'YES')GOTO9000
C
 1090 CONTINUE
C
C               ********************************************************
C               **  STEP 2--                                          **
C               **  GENERATE THE TRACES OF THE PLOT.                  **
C               **  LOOP THROUGH THE VARIOUS LEVELS OF D--            **
C               **  ONE LEVEL AT A TIME--SO AS TO INDIVIDUALLY        **
C               **  GENERATE EACH TRACE.                              **
C               **  FOR A GIVEN LEVEL, COLLECT ALL Y AND X            **
C               **  DATA WHICH HAVE THE CORRESPONDING D VALUE         **
C               **  AT THIS LEVEL.  PLACE THESE Y AND X PAIRS         **
C               **  IN THE INTERMEDIATE VECTORS Y2 AND X2             **
C               **  IN ORDER TO BE PLOTTED.                           **
C               **  THE PLOT WILL BE GENERATED 1 'CURVE' AT A TIME--  **
C               **  THAT IS FOR 1 LEVEL OF D AT A TIME.               **
C               **  FOR EFFICIENCY SAKE,                              **
C               **  TREAT EACH OF THE FOLLOWING                       **
C               **  4 CASES SEPARATELY--                              **
C               **     1) ONLY ONE SUBSET AND N NOT EXCEED MXNPPC;
C               **     2) ONLY ONE SUBSET BUT N EXCEEDS MXNPPC;
C               **     3) MORE THAN ONE SUBSET BUT NI NOT EXCEED MXNPPC;
C               **     4) MORE THAN ONE SUBSET AND NI EXCEEDS MXNPPC;
C               ********************************************************
C
      ISTEPN='2'
      IF(IBUGG4.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(ICASPL.EQ.'NONE')GOTO1900
C
      IOPGRS='OFF'
      IOPG2S='OFF'
      IDELIS='OFF'
      IDRFRS='OFF'
      IWRLAS='OFF'
      IWRLES='OFF'
      IDRTRS='ON'
      ICLG2S='OFF'
      ICLGRS='OFF'
C
      IF(NUMSET.LE.0)GOTO1900
CCCCC AUGUST 1992.  HANDLE SYMBOL PLOT CASE SEPARATELY
      IF(ICASPL.EQ.'SYMB')GOTO1500
CCCCC AUGUST 1992.  BUG IF NUMSET = 101, 201, (OR MAX TRACES + 1).
CCCCC GOES TO WRONG CASE, USES WRONG VALUE OF N AND GENERATES
CCCCC EXTRA MISCELLANEOUS LINES THAT ARE NOT DESIRED.  CHECK FOR
CCCCC CASE OF FIRST PASS.
      IF(IFIRST.EQ.'NO')THEN
        IF(N.LE.MXNPPC)GOTO1300
        IF(N.GT.MXNPPC)GOTO1400
      ENDIF
CCCCC END CHANGE
      IF(NUMSET.LE.1.AND.N.LE.MXNPPC)GOTO1100
      IF(NUMSET.LE.1.AND.N.GT.MXNPPC)GOTO1200
      IF(NUMSET.GT.1.AND.N.LE.MXNPPC)GOTO1300
      IF(NUMSET.GT.1.AND.N.GT.MXNPPC)GOTO1400
C
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1106)
 1106 FORMAT('***** INTERNAL ERROR IN PLOTGE--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1107)
 1107 FORMAT('      4-WAY BRANCH UNDER STEP 2 NOT SATISFIED.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1108)
 1108 FORMAT('      NUMSET,N,MXNPPC = ',3I8)
      CALL DPWRST('XXX','BUG ')
      IERRG4='YES'
      GOTO9000
C
C               ********************************************************
C               **  STEP 2.1--                                        **
C               **  TREAT THE CASE WHERE                              **
C               **  THE NUMBER OF TRACES = 1 AND                      **
C               **  THE NUMBER OF PLOT POINTS DOES NOT EXCEED MXNPPC  **
C               ********************************************************
C
 1100 CONTINUE
C
      ISTEPN='2.1'
      IF(IBUGG4.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      ISTEP=2
      ISUBST=1
      ISET=1
      ISET3=ISET
      ICH3PA=ICHAPA(ISET3)
C
      IF(ICAS3D.EQ.'OFF')
     1CALL PLOTG2(Y,X,Y3,X3,N,Y4,X4,N4,Y5,X5,N5,NUMSET,X3D,
     1ICASPL,ICAS3D,
     1ISQUAR,
     1IVGMSW,IHGMSW,
     1XDELMN,
     1ISTEP,ISUBST,ISET,ISET3,ICH3PA,
     1IOPGRS,IOPG2S,IDELIS,IDRFRS,IWRLAS,IWRLES,IDRTRS,ICLG2S,ICLGRS,
     1IHNAME,IHNAM2,IUSE,IVALUE,VALUE,NUMNAM,
     1ASETSZ,ISETSY,ISETCL,ISETFI,
     1NUMSBR,
     1ICAPSW,
     1IVSTAR,IVSTOP,IFUNC,NUMCHF,IREPCH,ISWTCH)
      IF(ICAS3D.EQ.'ON')
     1CALL PLOTG3(X,X3D,Y,N,DSIZE,
     1X3,Y3,Z3,X4,Y4,Z4,N4,X5,Y5,N5,NUMSET,
     1ICASPL,ICAS3D,
     1ISQUAR,
     1IVGMSW,IHGMSW,
     1XDELMN,YDELMN,ZDELMN,
     1ISTEP,ISUBST,ISET,ISET3,ICH3PA,
     1IOPGRS,IOPG2S,IDELIS,IDRFRS,IWRLAS,IWRLES,IDRTRS,ICLG2S,ICLGRS,
     1ICAPSW,
     1IHNAME,IHNAM2,IUSE,IVALUE,VALUE,NUMNAM,
     1IVSTAR,IVSTOP,IFUNC,NUMCHF,IREPCH,ISWTCH)
C
      GOTO1900
C
C               ************************************************
C               **  STEP 2.2--                                **
C               **  TREAT THE CASE WHERE                      **
C               **  THE NUMBER OF TRACES = 1 AND              **
C               **  THE NUMBER OF PLOT POINTS EXCEEDS MXNPPC  **
C               ************************************************
C
 1200 CONTINUE
C
      ISTEPN='2.2'
      IF(IBUGG4.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      ISTEP=2
      ISUBST=2
      ISET=1
      ISET3=ISET
      ICH3PA=ICHAPA(ISET3)
C
      NUMPAS=(N/MXNPPC)+1
      IF(N.EQ.MXNPPC)NUMPAS=1
C
      IMAX=1
      DO1210IPASS=1,NUMPAS
      IMIN=IMAX
      IMAX=IMIN+MXNPPC-1
      IF(IMAX.GT.N)IMAX=N
C
      N2=0
      DO1220I=IMIN,IMAX
      N2=N2+1
      Y2(N2)=Y(I)
      X2(N2)=X(I)
      X3D2(N2)=X3D(I)
      DSYMB(N2)=DSIZE(I)
 1220 CONTINUE
C
      IF(ICAS3D.EQ.'OFF')
     1CALL PLOTG2(Y2,X2,Y3,X3,N2,Y4,X4,N4,Y5,X5,N5,NUMSET,X3D2,
     1ICASPL,ICAS3D,
     1ISQUAR,
     1IVGMSW,IHGMSW,
     1XDELMN,
     1ISTEP,ISUBST,ISET,ISET3,ICH3PA,
     1IOPGRS,IOPG2S,IDELIS,IDRFRS,IWRLAS,IWRLES,IDRTRS,ICLG2S,ICLGRS,
     1IHNAME,IHNAM2,IUSE,IVALUE,VALUE,NUMNAM,
     1ASETSZ,ISETSY,ISETCL,ISETFI,
     1NUMSBR,
     1ICAPSW,
     1IVSTAR,IVSTOP,IFUNC,NUMCHF,IREPCH,ISWTCH)
      IF(ICAS3D.EQ.'ON')
     1CALL PLOTG3(X2,X3D2,Y2,N2,DSYMB,
     1X3,Y3,Z3,X4,Y4,Z4,N4,X5,Y5,N5,NUMSET,
     1ICASPL,ICAS3D,
     1ISQUAR,
     1IVGMSW,IHGMSW,
     1XDELMN,YDELMN,ZDELMN,
     1ISTEP,ISUBST,ISET,ISET3,ICH3PA,
     1IOPGRS,IOPG2S,IDELIS,IDRFRS,IWRLAS,IWRLES,IDRTRS,ICLG2S,ICLGRS,
     1ICAPSW,
     1IHNAME,IHNAM2,IUSE,IVALUE,VALUE,NUMNAM,
     1IVSTAR,IVSTOP,IFUNC,NUMCHF,IREPCH,ISWTCH)
 1210 CONTINUE
C
      GOTO1900
C
C               **************************************************************
C               **  STEP 2.3--                                              **
C               **  TREAT THE CASE WHERE                                    **
C               **  THERE ARE 2 OR MORE TRACES BUT                          **
C               **  THE TOTAL NUMBER OF PLOT POINTS DOES NOT EXCEED MXNPPC  **
C               **************************************************************
C
 1300 CONTINUE
C
      ISTEPN='2.3'
      IF(IBUGG4.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      DO1310ISET=1,NUMSET
C
      ISTEP=2
      ISUBST=3
      ISET3=ISET
C
CCCCC THE FOLLOWING LINE WAS ADDED DECEMBER 1994
CCCCC TO HAVE AN EXACT    IDENTIFIER => CHARACTER    MAPPING
      IF(ICHMAP.EQ.'EXAC')ISET3=XIDC(ISET)+0.5
C
CCCCC ICH3PA=ICHAPA(ISET3)
C
      ASETSZ=1.0
C
      JSET=XIDC(ISET)+0.5
CCCCC NOVEMBER 1993.  COMMENT OUT FOLLOWING LINE
CCCCC PIE CHART MODIFED TO HANDLE ATTRIBUTE SETTINGS.
CCCCC IF(ICASPL.EQ.'PIEC')ISET3=1
CCCCC AUGUST 1992.  FOLLOWING LINE ADDED FOR VECTOR PLOT
      IF(ICASPL.EQ.'VECT')ISET3=1
      IFACT=20
      IF(IFENSW.EQ.'ON')IFACT=24
CCCCC FEBRUARY 2003: VIOLIN PLOT
      IF(ICASPL.EQ.'VIPL')IFACT=IFACT+1
      IF(ICASPL.EQ.'MDBP')ISET3=JSET-IFACT*((JSET-1)/IFACT)
      IF(ICASPL.EQ.'MEBP')ISET3=JSET-IFACT*((JSET-1)/IFACT)
      IF(ICASPL.EQ.'MDIP')ISET3=JSET-5*((JSET-1)/5)
      IF(ICASPL.EQ.'MEIP')ISET3=JSET-5*((JSET-1)/5)
      IF(ICASPL.EQ.'MRIP')ISET3=JSET-5*((JSET-1)/5)
      IF(ICASPL.EQ.'MMIP')ISET3=JSET-5*((JSET-1)/5)
      IF(ICASPL.EQ.'ERBA')ISET3=JSET-7*((JSET-1)/7)
      IF(ICASPL.EQ.'VIPL')ISET3=JSET-IFACT*((JSET-1)/IFACT)
CCCCC AUGUST 2001.  ADD FOLLOWING LINE FOR CONSENSUS MEAN PLOT
      IF(ICASPL.EQ.'CMPL')ISET3=JSET-5*((JSET-1)/5)
CCCCC THE FOLLOWING 2 LINES WERE ADDED FOR DES. OF EXP. PLOTS MAY 1989
      IF(ICASPL.EQ.'DEXP'.AND.JSET.NE.NUMSET)ISET3=1
      IF(ICASPL.EQ.'DEXP'.AND.JSET.EQ.NUMSET)ISET3=2
CCCCC THE FOLLOWING LINE WAS ADDED FOR BLOCK PLOTS  JUNE 1992 (JJF)
      IF(ICASPL.EQ.'BLPL'.AND.IFIRST.EQ.'NO')ISET3=100
CCCCC THE FOLLOWING LINE WAS ADDED FOR BLOCK PLOT   JUNE 1995
CCCCC VERTEX JUNK CHARACTER PROBLEM                 JUNE 1995
      IF(ICASPL.EQ.'BLPL'.AND.ISET3.GT.100)ISET3=100
      IF(ICASPL.EQ.'PCPL'.OR.ICASPL.EQ.'PCPG')ISET3=MOD(JSET-1,100)+1
C
CCCCC THE FOLLOWING SECTION WAS ADDED    DECEMBER 1994
CCCCC ICH3PA=ICHAPA(ISET3)
      IF(ISET3.LE.100)THEN
         ICH3PA=ICHAPA(ISET3)
      ENDIF
      IF(ISET3.GT.100)THEN
         WRITE(ICOUT,1311)
 1311    FORMAT('***** ERROR IN PLOTGE AT STEP 2.3--')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,1312)
 1312    FORMAT('      AN ATTEMPT WAS MADE TO REFERENCE')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,1313)ISET3
 1313    FORMAT('      ELEMENT ',I8,' OF THE DATAPLOT INTERNAL')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,1314)
 1314    FORMAT('      TRACE CHARACTER ARRAY.  THIS IS ILLEGAL.')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,1315)
 1315    FORMAT('      THE MAX NUMBER OF TRACE CHARACTERS THAT CAN')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,1316)
 1316    FORMAT('      BE SET IS 100')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,1317)
 1317    FORMAT('      POSSIBLE CURE--HAS THE ANALYST CHANGED THE')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,1318)
 1318    FORMAT('         CHARACTER MAPPING EXACT      COMMAND TO THE')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,1319)
 1319    FORMAT('         CHARACTER MAPPING RANK       COMMAND?')
         CALL DPWRST('XXX','BUG ')
         IERRG4='YES'
         GOTO9000
      ENDIF
C
      N2=0
CCCCC AUGUST 1992.  HANDLE VECTOR PLOT WITH VARIABLE SIZE ARROW
CCCCC SEPARATELY.
      IF(ICASPL.EQ.'VVAR')THEN
        DO1330I=1,N
          I2=I
          IF(D(I2).EQ.XIDC(ISET))THEN
            N2=N2+1
            Y2(N2)=Y(I2)
            X2(N2)=X(I2)
            X3D2(N2)=X3D(I2)
            DSYMB(N2)=DSIZE(I2)
          ENDIF
 1330   CONTINUE
C
      ELSEIF(ICASPL.EQ.'PCPG')THEN
        DO1339I=1,N
          I2=I
          IF(D(I2).EQ.XIDC(ISET))THEN
            N2=N2+1
            Y2(N2)=Y(I2)
            X2(N2)=X(I2)
            X3D2(N2)=X3D(I2)
            DSYMB(N2)=DSIZE(I2)
            ISET3=DFILL(I2)
          ENDIF
 1339   CONTINUE
      ELSE
        DO1320I=1,N
          I2=I
          IF(D(I2).EQ.XIDC(ISET))THEN
            N2=N2+1
            Y2(N2)=Y(I2)
            X2(N2)=X(I2)
            X3D2(N2)=X3D(I2)
            DSYMB(N2)=DSIZE(I2)
          ENDIF
 1320   CONTINUE
      ENDIF
C
      IF(ICASPL.EQ.'MDBP')GOTO1340
      IF(ICASPL.EQ.'MEBP')GOTO1340
C
      IF(ICASPL.EQ.'VIPL')GOTO1350
C
      GOTO1349
 1340 CONTINUE
CCCCC THE FOLLOWING 5 LINES WERE INSERTED BY ALAN.  FEBRUARY 1989
      IF(IHORSW.EQ.'OFF')GOTO1345
      IF(ISET3.EQ.20)YSAVE=X2(1)
      IF(ISET3.GT.20.AND.N2.EQ.1.AND.X2(1).EQ.YSAVE)ICH3PA='BLAN'
      GOTO1349
 1345 CONTINUE
      IF(ISET3.EQ.20)YSAVE=Y2(1)
      IF(ISET3.GT.20.AND.N2.EQ.1.AND.Y2(1).EQ.YSAVE)ICH3PA='BLAN'
 1349 CONTINUE
C
 1350 CONTINUE
CCCCC THE FOLLOWING 5 LINES WERE INSERTED BY ALAN.  FEBRUARY 1989
      IF(IHORSW.EQ.'OFF')GOTO1355
      IF(ISET3.EQ.21)YSAVE=X2(1)
      IF(ISET3.GT.21.AND.N2.EQ.1.AND.X2(1).EQ.YSAVE)ICH3PA='BLAN'
      GOTO1359
 1355 CONTINUE
      IF(ISET3.EQ.21)YSAVE=Y2(1)
      IF(ISET3.GT.21.AND.N2.EQ.1.AND.Y2(1).EQ.YSAVE)ICH3PA='BLAN'
 1359 CONTINUE
C
      IF(IBUGG4.EQ.'ON')WRITE(ICOUT,1361)N2,ISORSW,ICASPL,ICAS3D,I3DPRO,
     1ICH3PA
 1361 FORMAT('N2,ISORSW,ICASPL,ICAS3D,I3DPRO,ICH3PA = ',
     1I8,2X,A4,2X,A4,2X,A4,2X,A4,2X,A4)
      IF(IBUGG4.EQ.'ON')CALL DPWRST('XXX','BUG ')
C
      IF(ICAS3D.EQ.'OFF')
     1CALL PLOTG2(Y2,X2,Y3,X3,N2,Y4,X4,N4,Y5,X5,N5,NUMSET,X3D2,
     1ICASPL,ICAS3D,
     1ISQUAR,
     1IVGMSW,IHGMSW,
     1XDELMN,
     1ISTEP,ISUBST,ISET,ISET3,ICH3PA,
     1IOPGRS,IOPG2S,IDELIS,IDRFRS,IWRLAS,IWRLES,IDRTRS,ICLG2S,ICLGRS,
     1IHNAME,IHNAM2,IUSE,IVALUE,VALUE,NUMNAM,
     1ASETSZ,ISETSY,ISETCL,ISETFI,
     1NUMSBR,
     1ICAPSW,
     1IVSTAR,IVSTOP,IFUNC,NUMCHF,IREPCH,ISWTCH)
      IF(ICAS3D.EQ.'ON')
     1CALL PLOTG3(X2,X3D2,Y2,N2,DSYMB,
     1X3,Y3,Z3,X4,Y4,Z4,N4,X5,Y5,N5,NUMSET,
     1ICASPL,ICAS3D,
     1ISQUAR,
     1IVGMSW,IHGMSW,
     1XDELMN,YDELMN,ZDELMN,
     1ISTEP,ISUBST,ISET,ISET3,ICH3PA,
     1IOPGRS,IOPG2S,IDELIS,IDRFRS,IWRLAS,IWRLES,IDRTRS,ICLG2S,ICLGRS,
     1ICAPSW,
     1IHNAME,IHNAM2,IUSE,IVALUE,VALUE,NUMNAM,
     1IVSTAR,IVSTOP,IFUNC,NUMCHF,IREPCH,ISWTCH)
C
 1310 CONTINUE
C
      GOTO1900
C
C               *************************************************
C               **  STEP 2.4--                                 **
C               **  TREAT THE CASE WHERE                       **
C               **  THERE ARE 2 OR MORE TRACES AND             **
C               **  THE TOTAL NUMBER OF POINTS EXCEEDS MXNPPC  **
C               *************************************************
C
 1400 CONTINUE
C
      ISTEPN='2.4'
      IF(IBUGG4.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      DO1410ISET=1,NUMSET
C
      ISTEP=2
      ISUBST=4
      ISET3=ISET
CCCCC THE FOLLOWING LINE WAS ADDED DECEMBER 1994
CCCCC TO HAVE AN EXACT    IDENTIFIER => CHARACTER    MAPPING
      IF(ICHMAP.EQ.'EXAC')ISET3=XIDC(ISET)+0.5
C
CCCCC ICH3PA=ICHAPA(ISET3)
C
      ASETSZ=1.0
C
      JSET=XIDC(ISET)+0.5
CCCCC NOVEMBER 1993.  COMMENT OUT FOLLOWING LINE
CCCCC PIE CHART MODIFED TO HANDLE ATTRIBUTE SETTINGS.
CCCCC IF(ICASPL.EQ.'PIEC')ISET3=1
CCCCC AUGUST 1992.  FOLLOWING LINE ADDED FOR VECTOR PLOT
      IF(ICASPL.EQ.'VECT')ISET3=1
      IFACT=20
      IF(IFENSW.EQ.'ON')IFACT=24
      IF(ICASPL.EQ.'VIPL')IFACT=IFACT+1
      IF(ICASPL.EQ.'MDBP')ISET3=JSET-IFACT*((JSET-1)/IFACT)
      IF(ICASPL.EQ.'MEBP')ISET3=JSET-IFACT*((JSET-1)/IFACT)
      IF(ICASPL.EQ.'MDIP')ISET3=JSET-5*((JSET-1)/5)
      IF(ICASPL.EQ.'MEIP')ISET3=JSET-5*((JSET-1)/5)
      IF(ICASPL.EQ.'MRIP')ISET3=JSET-5*((JSET-1)/5)
      IF(ICASPL.EQ.'MMIP')ISET3=JSET-5*((JSET-1)/5)
      IF(ICASPL.EQ.'ERBA')ISET3=JSET-7*((JSET-1)/7)
      IF(ICASPL.EQ.'VIPL')ISET3=JSET-IFACT*((JSET-1)/IFACT)
CCCCC AUGUST 2001.  ADD FOLLOWING LINE FOR CONSENSUS MEAN PLOT
      IF(ICASPL.EQ.'CMPL')ISET3=JSET-5*((JSET-1)/5)
CCCCC THE FOLLOWING 2 LINES WERE ADDED FOR DES. OF EXP. PLOTS MAY 1989
      IF(ICASPL.EQ.'DEXP'.AND.JSET.NE.NUMSET)ISET3=1
      IF(ICASPL.EQ.'DEXP'.AND.JSET.EQ.NUMSET)ISET3=2
CCCCC THE FOLLOWING LINE WAS ADDED FOR BLOCK PLOTS  JUNE 1992 (JJF)
      IF(ICASPL.EQ.'BLPL'.AND.IFIRST.EQ.'NO')ISET3=100
CCCCC THE FOLLOWING LINE WAS ADDED FOR BLOCK PLOT   JUNE 1995
CCCCC VERTEX JUNK CHARACTER PROBLEM                 JUNE 1995
      IF(ICASPL.EQ.'BLPL'.AND.ISET3.GT.100)ISET3=100
C
CCCCC THE FOLLOWING SECTION WAS ADDED    DECEMBER 1994
CCCCC ICH3PA=ICHAPA(ISET3)
      IF(ISET3.LE.100)THEN
         ICH3PA=ICHAPA(ISET3)
      ENDIF
      IF(ISET3.GT.100)THEN
         WRITE(ICOUT,1411)
 1411    FORMAT('***** ERROR IN PLOTGE AT STEP 2.4--')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,1412)
 1412    FORMAT('      AN ATTEMPT WAS MADE TO REFERENCE')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,1413)ISET3
 1413    FORMAT('      ELEMENT ',I8,' OF THE DATAPLOT INTERNAL')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,1414)
 1414    FORMAT('      TRACE CHARACTER ARRAY.  THIS IS ILLEGAL.')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,1415)
 1415    FORMAT('      THE MAX NUMBER OF TRACE CHARACTERS THAT CAN')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,1416)
 1416    FORMAT('      BE SET IS 100')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,1417)
 1417    FORMAT('      POSSIBLE CURE--HAS THE ANALYST CHANGED THE')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,1418)
 1418    FORMAT('         CHARACTER MAPPING EXACT      COMMAND TO THE')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,1419)
 1419    FORMAT('         CHARACTER MAPPING RANK       COMMAND?')
         CALL DPWRST('XXX','BUG ')
         IERRG4='YES'
         GOTO9000
      ENDIF
C
      IMIN=1
 1420 CONTINUE
      IMORE='NO'
C
      N2=0
CCCCC AUGUST 1992.  HANDLE VECTOR PLOT WITH VARIABLE SIZE ARROW
CCCCC SEPARATELY
      IF(ICASPL.EQ.'VVAR')GOTO1489
      DO1430I=IMIN,N
      I2=I
      IF(D(I2).EQ.XIDC(ISET))GOTO1435
      GOTO1430
 1435 CONTINUE
      N2=N2+1
      IF(N2.GE.MXNPPC)GOTO1438
      Y2(N2)=Y(I2)
      X2(N2)=X(I2)
      X3D2(N2)=X3D(I2)
 1430 CONTINUE
      GOTO1439
 1438 CONTINUE
      IMIN=I2
      IMORE='YES'
 1439 CONTINUE
      GOTO1499
C
 1489 CONTINUE
      DO1490I=IMIN,N
      I2=I
      ASETSZ=DSIZE(I2)
      IF(D(I2).EQ.XIDC(ISET))GOTO1495
      GOTO1490
 1495 CONTINUE
      N2=N2+1
      IF(N2.GE.MXNPPC)GOTO1498
      Y2(N2)=Y(I2)
      X2(N2)=X(I2)
      X3D2(N2)=X3D(I2)
      DSYMB(N2)=DSIZE(I2)
 1490 CONTINUE
      GOTO1499
 1498 CONTINUE
      IMIN=I2
      IMORE='YES'
 1499 CONTINUE
C
      IF(ICASPL.EQ.'MDBP')GOTO1440
      IF(ICASPL.EQ.'MEBP')GOTO1440
      IF(ICASPL.EQ.'VIPL')GOTO1450
      GOTO1449
 1440 CONTINUE
CCCCC THE FOLLOWING 5 LINES WERE INSERTED BY ALAN.  FEBRUARY 1989
      IF(IHORSW.EQ.'OFF')GOTO1445
      IF(ISET3.EQ.20)YSAVE=X2(1)
      IF(ISET3.GT.20.AND.N2.EQ.1.AND.X2(1).EQ.YSAVE)ICH3PA='BLAN'
      GOTO1449
 1445 CONTINUE
      IF(ISET3.EQ.20)YSAVE=Y2(1)
      IF(ISET3.GT.20.AND.N2.EQ.1.AND.Y2(1).EQ.YSAVE)ICH3PA='BLAN'
 1449 CONTINUE
C
 1450 CONTINUE
CCCCC THE FOLLOWING 5 LINES WERE INSERTED BY ALAN.  FEBRUARY 1989
      IF(IHORSW.EQ.'OFF')GOTO1455
      IF(ISET3.EQ.20)YSAVE=X2(1)
      IF(ISET3.GT.20.AND.N2.EQ.1.AND.X2(1).EQ.YSAVE)ICH3PA='BLAN'
      GOTO1459
 1455 CONTINUE
      IF(ISET3.EQ.20)YSAVE=Y2(1)
      IF(ISET3.GT.20.AND.N2.EQ.1.AND.Y2(1).EQ.YSAVE)ICH3PA='BLAN'
 1459 CONTINUE
C
      IF(IBUGG4.EQ.'ON')WRITE(ICOUT,1461)N,NUMSET,ISET,JSET,ISET3,N2,
     1                  YSAVE
 1461 FORMAT('N,NUMSET,ISET,JSET,ISET3,N2,YSAVE = ',6I8,E15.7)
      IF(IBUGG4.EQ.'ON')CALL DPWRST('XXX','BUG ')
      IF(IBUGG4.EQ.'ON')WRITE(ICOUT,1462)N2,ISORSW,ICASPL,ICAS3D,I3DPRO,
     1ICH3PA
 1462 FORMAT('N2,ISORSW,ICASPL,ICAS3D,I3DPRO,ICH3PA = ',
     1I8,2X,A4,2X,A4,2X,A4,2X,A4,2X,A4)
      IF(IBUGG4.EQ.'ON')CALL DPWRST('XXX','BUG ')
C
      IF(ICAS3D.EQ.'OFF')
     1CALL PLOTG2(Y2,X2,Y3,X3,N2,Y4,X4,N4,Y5,X5,N5,NUMSET,X3D2,
     1ICASPL,ICAS3D,
     1ISQUAR,
     1IVGMSW,IHGMSW,
     1XDELMN,
     1ISTEP,ISUBST,ISET,ISET3,ICH3PA,
     1IOPGRS,IOPG2S,IDELIS,IDRFRS,IWRLAS,IWRLES,IDRTRS,ICLG2S,ICLGRS,
     1IHNAME,IHNAM2,IUSE,IVALUE,VALUE,NUMNAM,
     1ASETSZ,ISETSY,ISETCL,ISETFI,
     1NUMSBR,
     1ICAPSW,
     1IVSTAR,IVSTOP,IFUNC,NUMCHF,IREPCH,ISWTCH)
      IF(ICAS3D.EQ.'ON')
     1CALL PLOTG3(X2,X3D2,Y2,N2,DSYMB,
     1X3,Y3,Z3,X4,Y4,Z4,N4,X5,Y5,N5,NUMSET,
     1ICASPL,ICAS3D,
     1ISQUAR,
     1IVGMSW,IHGMSW,
     1XDELMN,YDELMN,ZDELMN,
     1ISTEP,ISUBST,ISET,ISET3,ICH3PA,
     1IOPGRS,IOPG2S,IDELIS,IDRFRS,IWRLAS,IWRLES,IDRTRS,ICLG2S,ICLGRS,
     1ICAPSW,
     1IHNAME,IHNAM2,IUSE,IVALUE,VALUE,NUMNAM,
     1IVSTAR,IVSTOP,IFUNC,NUMCHF,IREPCH,ISWTCH)
C
      IF(IMORE.EQ.'YES')GOTO1420
C
 1410 CONTINUE
C
      GOTO1900
C
C               **************************************************************
C               **  STEP 2.5--                                              **
C               **  TREAT THE SYMBOL PLOT CASE WHERE                        **
C               **  LOOP THROUGH AND PLOT EACH POINT INDIVIUALLY            **
C               **  SET SIZE, FILL, COLOR, SYMBOL FOR EACH POINT            **
C               **************************************************************
C
 1500 CONTINUE
C
      ISTEPN='2.5'
      IF(IBUGG4.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      ISTEP=2
      ISUBST=5
      ISET3=ISET
      ICH3PA=ICHAPA(ISET3)
C
      ICH3PA=ICHAPA(ISET3)
C
      N2=1
      DO1520I=1,N
      I2=I
      Y2(N2)=Y(I2)
      X2(N2)=X(I2)
      X3D2(N2)=X3D(I2)
      ASETSZ=DSIZE(I2)
      ISETSY=INT(DSYMB(I2)+0.5)
      IF(ISETSY.LT.1.OR.ISETSY.GT.MAXCH2)ISETSY=1
      ISETFI=INT(DFILL(I2)+0.5)
      ISETCL=INT(DCOLOR(I2)+0.5)
      IF(ISETCL.LT.1.OR.ISETCL.GT.MAXCH2)ISETCL=1
C
      CALL PLOTG2(Y2,X2,Y3,X3,N2,Y4,X4,N4,Y5,X5,N5,NUMSET,X3D2,
     1ICASPL,ICAS3D,
     1ISQUAR,
     1IVGMSW,IHGMSW,
     1XDELMN,
     1ISTEP,ISUBST,ISET,ISET3,ICH3PA,
     1IOPGRS,IOPG2S,IDELIS,IDRFRS,IWRLAS,IWRLES,IDRTRS,ICLG2S,ICLGRS,
     1IHNAME,IHNAM2,IUSE,IVALUE,VALUE,NUMNAM,
     1ASETSZ,ISETSY,ISETCL,ISETFI,
     1NUMSBR,
     1ICAPSW,
     1IVSTAR,IVSTOP,IFUNC,NUMCHF,IREPCH,ISWTCH)
 1520 CONTINUE
C
      GOTO1900
C
 1900 CONTINUE
C
C               ************************************************
C               **  STEP 3--                                  **
C               **  CARRY OUT POST-PLOT ACTIVITIES--          **
C               **  GENERATE THE FRAME, TITLE, LABELS, ETC.   **
C               **  FINISH UP DETAILS FOR THE PLOT            **
C               **  (E.G., MAKING HARDCOPIES IF CALLED FOR).  **
C               ************************************************
C
      IF(ILAST.EQ.'YES')GOTO2100
      GOTO2190
C
 2100 CONTINUE
C
      ISTEPN='3'
      IF(IBUGG4.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IOPGRS='OFF'
      IOPG2S='OFF'
      IDELIS='OFF'
      IDRFRS='ON'
      IWRLAS='ON'
      IWRLES='ON'
      IDRTRS='OFF'
      ICLG2S='ON'
      ICLGRS='ON'
C
      ISTEP=3
      ISUBST=1
      ISET=1
      ISET3=ISET
      ICH3PA=ICHAPA(ISET3)
C
      IF(ICAS3D.EQ.'OFF')
     1CALL PLOTG2(Y,X,Y2,X2,N,Y4,X4,N4,Y5,X5,N5,NUMSET,X3D,
     1ICASPL,ICAS3D,
     1ISQUAR,
     1IVGMSW,IHGMSW,
     1XDELMN,
     1ISTEP,ISUBST,ISET,ISET3,ICH3PA,
     1IOPGRS,IOPG2S,IDELIS,IDRFRS,IWRLAS,IWRLES,IDRTRS,ICLG2S,ICLGRS,
     1IHNAME,IHNAM2,IUSE,IVALUE,VALUE,NUMNAM,
     1ASETSZ,ISETSY,ISETCL,ISETFI,
     1NUMSBR,
     1ICAPSW,
     1IVSTAR,IVSTOP,IFUNC,NUMCHF,IREPCH,ISWTCH)
      IF(ICAS3D.EQ.'ON')
     1CALL PLOTG3(X,X3D,Y,N,DSIZE,
     1X2,Y2,Z2,X4,Y4,Z4,N4,X5,Y5,N5,NUMSET,
     1ICASPL,ICAS3D,
     1ISQUAR,
     1IVGMSW,IHGMSW,
     1XDELMN,YDELMN,ZDELMN,
     1ISTEP,ISUBST,ISET,ISET3,ICH3PA,
     1IOPGRS,IOPG2S,IDELIS,IDRFRS,IWRLAS,IWRLES,IDRTRS,ICLG2S,ICLGRS,
     1ICAPSW,
     1IHNAME,IHNAM2,IUSE,IVALUE,VALUE,NUMNAM,
     1IVSTAR,IVSTOP,IFUNC,NUMCHF,IREPCH,ISWTCH)
C
 2190 CONTINUE
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
CCCCC ADD FOLLOWING SECTION FOR DUANE PLOTS.   MAY 1998.
      IF(ICASPL.EQ.'DUAN')THEN
        IX1TSC=IX1TMP
        IX2TSC=IX2TMP
        IY1TSC=IY1TMP
        IY2TSC=IY2TMP
      ENDIF
C
      IERROR=IERRG4
      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'OTGE')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF PLOTGE--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)N,NUMSET
 9012 FORMAT('N,NUMSET = ',2I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)ICASPL,ICAS3D,I3DPRO
 9013 FORMAT('ICASPL,ICAS3D,I3DPRO,I3DPRO = ',A4,2X,A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9014)ISQUAR
 9014 FORMAT('ISQUAR = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9024)YSAVE
 9024 FORMAT('YSAVE = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9025)XDELMN
 9025 FORMAT('XDELMN = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9028)IBUGG4
 9028 FORMAT('IBUGG4 = ',A4)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE PLOTG2(Y,X,PY,PX,NP,PY2,PX2,NP2,PY3,PX3,NP3,NUMSET,
     1X3D,
     1ICASPL,ICAS3D,
     1ISQUAR,
     1IVGMSW,IHGMSW,
     1XDELMN,
     1ISTEP,ISUBST,ISET,ISET3,ICH3PA,
     1IOPGRS,IOPG2S,IDELIS,IDRFRS,IWRLAS,IWRLES,IDRTRS,ICLG2S,ICLGRS,
     1IHNAME,IHNAM2,IUSE,IVALUE,VALUE,NUMNAM,
CCCCC AUGUST 1992.  ADD FOLLOWING LINE
     1ASETSZ,ISETSY,ISETCL,ISETFI,
     1NUMSBR,
     1ICAPSW,
     1IVSTAR,IVSTOP,IFUNC,NUMCHF,IREPCH,ISWTCH)
C
C     PURPOSE--GENERATE A COMPLETE 2-D PLOT OF A SINGLE TRACE OF Y VERSUS X
C              (INCLUDING FRAME, TICS, LEGENDS, ETC.)
C
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-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--83.6
C     ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MAY       1983.
C     UPDATED         --SEPTEMBER 1988.   BIHISTOGRAM
C     UPDATED         --FEBRUARY  1989.   HORIZONTAL PLOT SWITCH (ALAN)
C     UPDATED         --FEBRUARY  1989.   DEVICE POWER (ALAN)
C     UPDATED         --APRIL     1989.   ANIMATION
C     UPDATED         --MAY       1989.   HAZARD PLOT
C     UPDATED         --MARCH     1990.   X11 PATCH
C     UPDATED         --APRIL     1992.   ISET3,ISET3S TO ISET,ISET3
C     UPDATED         --MAY       1992.   AUTO CLOSE/OPEN OF DEVICE 3 (JJF)
C     UPDATED         --MAY       1992.   DEBUG STATEMENTS
C     UPDATED         --MAY       1992.   IBUGXX, ISUBXX, IERRXX
C     UPDATED         --MAY       1992.   BUG FOR MAXDEV
C     UPDATED         --AUGUS T   1992.   SHADOW FOR BOX
C     UPDATED         --AUGUST    1992.   UPDATE FOR SYMBOL PLOT
C     UPDATED         --OCTOBER   1993.   UPDATE FOR REGION BASE INTER
C     UPDATED         --FEBRUARY  1994.   VECTOR PLOT = PRE-ERASE OFF
C     UPDATED         --MARCH     1994.   REGION BASE INTERPOLATE
C     UPDATED         --AUGUST    1995  ARGUMENT LIST TO DPWRLE
C     UPDATED         --JULY      1996  DEVICE FONT
C     UPDATED         --OCTOBER   1996. QWIN PATCH
C     UPDATED         --APRIL     1997. SUPPORT FOR AUTOMATICALLY
C                                       SAVING X11 PIXMAPS
C     UPDATED         --DECEMBER  1997. GENERALIZE PIXMAPS TO OTHER
C                                       DEVICE
C     UPDATED         --NOVEMBER  1999. ARGUMENT TO DPWRLA
C     UPDATED         --DECEMBER  1999. IMPLEMENT SUBREGIONS
C     UPDATED         --DECEMBER  1999. CROSS TABULATE, DEX CONTOUR
C                                       PLOTS AUTOMATICALLY SET CHAR 1
C                                       TO ZVAL
C     UPDATED         --JANUARY   2000. ADD X3D TO ARGUMENT LIST, PASS
C                                       TO DPDRCH
C     UPDATED         --FEBRUARY  2003. SET PRE-SORT OFF FOR VIOLIN
C                                       PLOT
C     UPDATED         --MARCH     2003. SET PRE-SORT OFF FOR PARALLEL
C                                       COORDINATES PLOT
C     UPDATED         --MAY       2003. GROUP PARALLEL COORD PLOT
C                                       HANDLES "TRACES" DIFFERENTLY
C     UPDATED         --FEBRUARY  2006. FOR DEVICE 1 LATEX, IF
C                                       CAPTURE SWITCH ON, SEND OUTPUT
C                                       TO CAPTURE FILE RATHER THAN
C                                       THE SCREEN
C
C-----FOR NON-COMMON VARIABLES-----------------------------------------
C
      CHARACTER*4 ICONT
C
      CHARACTER*4 ICAPSW
C
      CHARACTER*4 ISQUAR
C
      CHARACTER*4 IVGMSW
      CHARACTER*4 IHGMSW
C
      CHARACTER*4 ICASPL
      CHARACTER*4 ICAS3D
C
      CHARACTER*4 ICH3PA
C
      CHARACTER*4 ILI2SW
      CHARACTER*4 ILI2PA
      CHARACTER*4 ILI2CO
C
      CHARACTER*4 ICH2SW
      CHARACTER*4 ICH2PA
      CHARACTER*4 ICH2FO
      CHARACTER*4 ICH2CA
      CHARACTER*4 ICH2JU
      CHARACTER*4 ICH2DI
      CHARACTER*4 ICH2FI
      CHARACTER*4 ICH2CO
C
      CHARACTER*4 IFI2SW
      CHARACTER*4 IFI2PA
      CHARACTER*4 IFI2CO
C
      CHARACTER*4 IPA2SW
      CHARACTER*4 IPA2PA
      CHARACTER*4 IPA2LI
      CHARACTER*4 IPA2CO
C
      CHARACTER*4 ISP2SW
      CHARACTER*4 ISP2LI
      CHARACTER*4 ISP2CO
      CHARACTER*4 ISP2DI
C
      CHARACTER*4 IBA2SW
      CHARACTER*4 IBA2BL
      CHARACTER*4 IBA2BC
      CHARACTER*4 IBA2FS
      CHARACTER*4 IBA2FC
      CHARACTER*4 IBA2PT
      CHARACTER*4 IBA2PL
      CHARACTER*4 IBA2PC
      CHARACTER*4 IBA2TY
      CHARACTER*4 IBA2DI
C
      CHARACTER*4 IRE2SW
      CHARACTER*4 IRE2BL
      CHARACTER*4 IRE2BC
      CHARACTER*4 IRE2FS
      CHARACTER*4 IRE2FC
      CHARACTER*4 IRE2PT
      CHARACTER*4 IRE2PL
      CHARACTER*4 IRE2PC
      CHARACTER*4 IRE2PZ
C
      CHARACTER*4 IMA2SW
      CHARACTER*4 IMA2BL
      CHARACTER*4 IMA2BC
      CHARACTER*4 IMA2FS
      CHARACTER*4 IMA2FC
      CHARACTER*4 IMA2PT
      CHARACTER*4 IMA2PL
      CHARACTER*4 IMA2PC
C
      CHARACTER*4 ITE2SW
      CHARACTER*4 ITE2BL
      CHARACTER*4 ITE2BC
      CHARACTER*4 ITE2FS
      CHARACTER*4 ITE2FC
      CHARACTER*4 ITE2PT
      CHARACTER*4 ITE2PL
      CHARACTER*4 ITE2PC
C
      CHARACTER*4 IOPGRS
      CHARACTER*4 IOPG2S
      CHARACTER*4 IDELIS
      CHARACTER*4 IDRFRS
      CHARACTER*4 IWRLAS
      CHARACTER*4 IWRLES
      CHARACTER*4 IDRTRS
      CHARACTER*4 ICLG2S
      CHARACTER*4 ICLGRS
C
      CHARACTER*4 ISYMBL
      CHARACTER*4 ISPAC
C
      CHARACTER*4 IHNAME
      CHARACTER*4 IHNAM2
      CHARACTER*4 IUSE
      CHARACTER*4 IFUNC
C
      CHARACTER*1 IREPCH
C
      CHARACTER*4 ITITCV
      CHARACTER*4 IX1LCV
      CHARACTER*4 IX2LCV
      CHARACTER*4 IX3LCV
      CHARACTER*4 IY1LCV
      CHARACTER*4 IY2LCV
C
CCCCC THE FOLLOWING 2 LINES WERE INSERTED FEBRUARY 1989 (ALAN)
      CHARACTER*4 ISWTCH
      CHARACTER*4 IPOWER
C
CCCCC THE FOLLOWING 3 LINES WERE ADDED MAY 1992 (JJF)
      CHARACTER*4 IBUGXX
      CHARACTER*4 ISUBXX
      CHARACTER*4 IERRXX
CCCCC THE FOLLOWING LINE WAS ADDED FEBRUARY 1994
      CHARACTER*4 ISORZZ
C
      CHARACTER*128 ISTRI2
      CHARACTER*128 CTEMP
      CHARACTER*4 ICODE
C
C---------------------------------------------------------------------
C
      DIMENSION Y(*)
      DIMENSION X(*)
      DIMENSION X3D(*)
      DIMENSION PY(*)
      DIMENSION PX(*)
      DIMENSION PY2(*)
      DIMENSION PX2(*)
C
      DIMENSION PY3(*)
      DIMENSION PX3(*)
C
      DIMENSION IHNAME(*)
      DIMENSION IHNAM2(*)
      DIMENSION IUSE(*)
      DIMENSION IVALUE(*)
      DIMENSION VALUE(*)
      DIMENSION IVSTAR(*)
      DIMENSION IVSTOP(*)
      DIMENSION IFUNC(*)
C
      DIMENSION ITITCV(4)
      DIMENSION PTITRV(6)
      DIMENSION IX1LCV(6)
      DIMENSION PX1LRV(8)
      DIMENSION IX2LCV(6)
      DIMENSION PX2LRV(8)
      DIMENSION IX3LCV(6)
      DIMENSION PX3LRV(8)
      DIMENSION IY1LCV(6)
      DIMENSION PY1LRV(8)
      DIMENSION IY2LCV(6)
      DIMENSION PY2LRV(8)
CCCCC ADD FOLLOWING LINE APRIL 1997
CCCCC DIMENSION IADE(128)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOPA.INC'
      INCLUDE 'DPCOPC.INC'
      INCLUDE 'DPCOGR.INC'
      INCLUDE 'DPCOBE.INC'
CCCCC THE FOLLOWING LINE WAS ADDED    MAY 1992 (JJF)
      INCLUDE 'DPCOF2.INC'
CCCCC THE FOLLOWING LINE WAS ADDED    APRIL 1997
      INCLUDE 'DPCOPM.INC'
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      PSAVE=-999.0
C
      ILI2SW='ON'
      ICH2SW='ON'
C
      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'OTG2')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF PLOTG2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)ISTEP,ISUBST,ISET,ISET3,ICH3PA
   53 FORMAT('ISTEP,ISUBST,ISET,ISET3,ICH3PA = ',4I8,2X,A4)
      CALL DPWRST('XXX','BUG ')
CCCCC THE FOLLOWING 2 LINES WERE ADDED   MAY 1992
      WRITE(ICOUT,54)IPL2CS
   54 FORMAT('IPL2CS = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,62)NP
   62 FORMAT('NP = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,63)Y(1),X(1),PY(1),PX(1)
   63 FORMAT('Y(1),X(1),PY(1),PX(1) = ',4E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,64)Y(2),X(2),PY(2),PX(2)
   64 FORMAT('Y(2),X(2),PY(2),PX(2) = ',4E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,65)Y(NP),X(NP),PY(NP),PX(NP)
   65 FORMAT('Y(NP),X(NP),PY(NP),PX(NP) = ',4E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,67)NUMSET
   67 FORMAT('NUMSET = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,68)ICASPL,ICAS3D
   68 FORMAT('ICASPL,ICAS3D = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,69)ISQUAR,XDELMN
   69 FORMAT('ISQUAR,XDELMN = ',A4,2X,E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,71)IOPGRS
   71 FORMAT('IOPGRS = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,72)IOPG2S
   72 FORMAT('IOPG2S = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,73)IDELIS
   73 FORMAT('IDELIS = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,74)IDRFRS
   74 FORMAT('IDRFRS = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,75)IWRLAS
   75 FORMAT('IWRLAS = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,76)IWRLES
   76 FORMAT('IWRLES = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,77)IDRTRS
   77 FORMAT('IDRTRS = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,78)ICLG2S
   78 FORMAT('ICLG2S = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,79)ICLGRS
   79 FORMAT('ICLGRS = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,80)ITEXSY,ITEXSP
   80 FORMAT('ITEXSY,ITEXSP = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,81)IMANUF,IMODEL
   81 FORMAT('IMANUF,IMODEL = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
CCCCC WRITE(ICOUT,82)IREPCH
CCC82 FORMAT('IREPCH = ',A1)
CCCCC CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,83)IBACCO,IANISW
   83 FORMAT('IBACCO,IANISW = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,89)IBUGG4,ISUBG4,IERRG4
   89 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
   90 CONTINUE
C
C               **************************************************
C               **  STEP 11--                                   **
C               **  EXTRACT SETTINGS FOR THIS PARTICULAR TRACE  **
C               **************************************************
C
CCCCC IF(IOPGRS.EQ.'ON')GOTO1109
CCCCC IF(ICLGRS.EQ.'ON')GOTO1109
C
CCCCC IMPLEMENT SUB-REGIONS DECEMBER 1999.
CCCCC CHAR, LINE, SPIKE, BAR SETTINGS SHOULD BE BLANK UNTIL ALL
CCCCC SUB-REGIONS PLOTTED.  THEN SHOULD START WITH FIRST SETTING.
CCCCC REGION SETTINGS SHOULD START WITH 1 REGARDLESS.
      ISET3T=ISET3-NUMSBR
      IF(ISET3T.LT.1)ISET3T=1
C
      ICH2PA=ICHAPA(ISET3T)
      ICH2FO=ICHAFO(ISET3T)
      ICH2CA=ICHACA(ISET3T)
      ICH2JU=ICHAJU(ISET3T)
      ICH2DI=ICHADI(ISET3T)
      ACH2AN=ACHAAN(ISET3T)
      ICH2FI=ICHAFI(ISET3T)
      ICH2CO=ICHACO(ISET3T)
      PCH2HE=PCHAHE(ISET3T)
      PCH2WI=PCHAWI(ISET3T)
      PCH2TH=PCHATH(ISET3T)
      PCH2HO=PCHAHO(ISET3T)
      PCH2VO=PCHAVO(ISET3T)
      ILI2PA=ILINPA(ISET3T)
      ILI2CO=ILINCO(ISET3T)
      PLI2TH=PLINTH(ISET3T)
      IFI2SW=IFILSW(ISET3T)
      IFI2PA=IFILPA(ISET3T)
      IFI2CO=IFILCO(ISET3T)
      PFI2SP=PFILSP(ISET3T)
      PFI2TH=PFILTH(ISET3T)
      IPA2SW=IPATSW(ISET3T)
      IPA2PA=IPATPA(ISET3T)
      IPA2LI=IPATLI(ISET3T)
      IPA2CO=IPATCO(ISET3T)
      PPA2HE=PPATHE(ISET3T)
      PPA2WI=PPATWI(ISET3T)
      PPA2SP=PPATSP(ISET3T)
      PPA2TH=PPATTH(ISET3T)
      ISP2SW=ISPISW(ISET3T)
      ISP2LI=ISPILI(ISET3T)
      ISP2CO=ISPICO(ISET3T)
      ISP2DI=ISPIDI(ISET3T)
CCCCC THE FOLLOWING LINE WAS ADDED FEBRUARY 1989
      IF(IHORSW.EQ.'ON')ISP2DI='H'
      PSP2TH=PSPITH(ISET3T)
      ASP2BA=ASPIBA(ISET3T)
C
      IBA2SW=IBARSW(ISET3T)
      ABA2WI=ABARWI(ISET3T)
      ABA2BA=ABARBA(ISET3T)
      IBA2BL=IBABLI(ISET3T)
      IBA2BC=IBABCO(ISET3T)
      PBA2BT=PBABTH(ISET3T)
      IBA2FS=IBAFSW(ISET3T)
      IBA2FC=IBAFCO(ISET3T)
      IBA2PT=IBAPTY(ISET3T)
      IBA2PL=IBAPLI(ISET3T)
      IBA2PC=IBAPCO(ISET3T)
      IBA2TY=IBARTY(ISET3T)
      IBA2DI=IBARDI(ISET3T)
CCCCC THE FOLLOWING LINE WAS ADDED FEBRUARY 1989
      IF(IHORSW.EQ.'ON')IBA2DI='H'
      PBA2PS=PBAPSP(ISET3T)
      PBA2PT=PBAPTH(ISET3T)
C
      IRE2SW=IREGSW(ISET3)
      ARE2WI=AREGWI(ISET3)
      ARE2BA=AREGBA(ISET3)
      IRE2BL=IREBLI(ISET3)
      IRE2BC=IREBCO(ISET3)
      PRE2BT=PREBTH(ISET3)
      IRE2FS=IREFSW(ISET3)
      IRE2FC=IREFCO(ISET3)
      IRE2PT=IREPTY(ISET3)
      IRE2PL=IREPLI(ISET3)
      IRE2PC=IREPCO(ISET3)
      PRE2PS=PREPSP(ISET3)
      PRE2PT=PREPTH(ISET3)
      IRE2PZ=IREBPL
CCCCC OCTOBER 1993.  ADD FOLLOWING SECTION
      IF(IREBIN.EQ.'OFF')THEN
        ARE3BA=ARE2BA
      ELSE
        ARE3BA=AREGBA(ISET3+1)
        IF(ARE3BA.EQ.CPUMAX)ARE3BA=ARE2BA
      ENDIF
C
      IF(ISET3.LE.NUMSBR)THEN
        ICH2PA='BLAN'
        ILI2PA=IRE2BL
        ILI2CO=IRE2BC
        PLI2TH=PRE2BT
        ISP2SW='OFF'
        IBA2SW='OFF'
        IFI2SW='OFF'
        IRE2SW='ON'
        IRE2PZ='ON'
        IRE2PC=IRE2FC
      ENDIF
C
      IMA2SW=IMARSW(ISET3)
      AMA2WI=AMARWI(ISET3)
      AMA2BA=AMARBA(ISET3)
      IMA2BL=IMABLI(ISET3)
      IMA2BC=IMABCO(ISET3)
      PMA2BT=PMABTH(ISET3)
      IMA2FS=IMAFSW(ISET3)
      IMA2FC=IMAFCO(ISET3)
      IMA2PT=IMAPTY(ISET3)
      IMA2PL=IMAPLI(ISET3)
      IMA2PC=IMAPCO(ISET3)
      PMA2PS=PMAPSP(ISET3)
      PMA2PT=PMAPTH(ISET3)
C
      ITE2SW=ITEXSW(ISET3)
      ATE2WI=ATEXWI(ISET3)
      ATE2BA=ATEXBA(ISET3)
      ITE2BL=ITEBLI(ISET3)
      ITE2BC=ITEBCO(ISET3)
      PTE2BT=PTEBTH(ISET3)
      ITE2FS=ITEFSW(ISET3)
      ITE2FC=ITEFCO(ISET3)
      ITE2PT=ITEPTY(ISET3)
      ITE2PL=ITEPLI(ISET3)
      ITE2PC=ITEPCO(ISET3)
      PTE2PS=PTEPSP(ISET3)
      PTE2PT=PTEPTH(ISET3)
C
      IF(ISTEP.EQ.2.AND.ISUBST.EQ.3.AND.NUMSBR.LE.0)THEN
          ICH2PA=ICH3PA
      ENDIF
      IF(ISTEP.EQ.2.AND.ISUBST.EQ.4.AND.NUMSBR.LE.0)THEN
        ICH2PA=ICH3PA
      ENDIF
C
CCCCC AUGUST 1992.  FOLLOWING BLOCK OF CODE ADDED FOR SYMBOL PLOT
CCCCC AND VECTOR PLOTS WITH VARIABLE ARROW LENGTH
      IF(ISTEP.EQ.2.AND.ICASPL.EQ.'SYMB'.AND.ISET3.GT.NUMSBR)THEN
        ICH2PA=ICHAPA(ISETSY)
        ICH2FI='OFF'
        IF(ISETFI.NE.0)ICH2FI='ON'
        ICH2CO=ICHACO(ISETCL)
        PCH2HE=ASETSZ*PCH2HE
        PCH2WI=ASETSZ*PCH2WI
      ENDIF
      IF(ISTEP.EQ.2.AND.ICASPL.EQ.'VVAR')THEN
        PCH2HE=ASETSZ*PCH2HE
        PCH2WI=ASETSZ*PCH2WI
      ENDIF
CCCCC DECEMBER 1999.  CROSS TABULATE PLOT X1 X2 SETS CHAR TYPE TO
CCCCC ZVAL.
      IF(ISTEP.EQ.2.AND.ICASPL.EQ.'CTCO'.AND.ISET3.GT.NUMSBR)THEN
        ICH2PA='ZVAL'
        ILI2PA='BLAN'
      ENDIF
      IF(ISTEP.EQ.2.AND.ICASPL.EQ.'CTA2'.AND.ISET3.GT.NUMSBR)THEN
        ICH2PA='ZVAL'
        ILI2PA='BLAN'
      ENDIF
      IF(ISTEP.EQ.2.AND.ICASPL.EQ.'DCON'.AND.ISET3.EQ.NUMSBR+1)THEN
        ICH2PA='ZVAL'
        ILI2PA='BLAN'
      ENDIF
C
 1109 CONTINUE
C
CCCCC THE FOLLOWING CHUNK OF CODE WAS ADDED FEBRUARY 1989 (ALAN).
CCCCC SEPTEMBER, 1987: ADD "HORIZONTAL SWITCH ON" CASE, I.E. PLOT
CCCCC THE CHART HORIZONTALLY RATHER THAN VERTICALLY.  NOTE THAT
CCCCC "DPDRBA" AND "DPDRSP" ALREADY HANDLE THIS CASE (SPIKE DIRECTION
CCCCC AND BAR DIRECTION COMMANDS).  OTHER CASES SIMPLY REVERSE VALUE
CCCCC OF X AND Y COORDINATES.  HORIZONTAL ON WILL SET THE SPIKE AND
CCCCC BAR DIRECTIONS TO HORIZONTAL.
CCCCC ONE COMPLICATION IS IF THE BAR OR SPIKE SWITCH IS "ON" AND THE
CCCCC LINE OR CHARACTER SWITCH IS ON AS WELL.  THEN ONE CASE REQUIRES
CCCCC A X AND Y TO SWITCH WHILE THE OTHER DOES NOT.  IN THIS CASE, MAY
CCCCC NEED TO SWITCH X AND Y BACK TO ORIGINAL WAY BEFORE DRAW SPIKE OR
CCCCC BAR (VARIABLE ISWTCH KEEPS TRACK)
CCCCC ISWTCH='OFF'
      IF(IHORSW.EQ.'OFF')GOTO1119
      IF(IDELIS.EQ.'OFF'.AND.IDRTRS.EQ.'OFF')GOTO1119
      IF(ISWTCH.EQ.'ON')GOTO1119
CCCCC IF(ICASPL.EQ.'HIST')GOTO1119
CCCCC IF(ICASPL.EQ.'CUMH')GOTO1119
CCCCC IF(ICASPL.EQ.'BARP')GOTO1119
CCCCC IF(ICASPL.EQ.'ROOT')GOTO1119
CCCCC IF(ICASPL.EQ.'CUMR')GOTO1119
CCCCC IF(ICASPL.EQ.'BIHI')GOTO1119
      DO1115I=1,MAXPOP
      XTEMP=X(I)
      X(I)=Y(I)
      Y(I)=XTEMP
 1115 CONTINUE
      ISWTCH='ON'
 1119 CONTINUE
C
      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'OTG2')GOTO1190
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1121)
 1121 FORMAT('***** FROM THE MIDDLE OF PLOTG2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1131)ILI2PA,PLI2TH,ILI2CO
 1131 FORMAT('ILI2PA,PLI2TH,ILI2CO = ',A4,2X,E15.7,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1132)ICH2PA,ICH2FO,ICH2CA,ICH2JU
 1132 FORMAT('ICH2PA,ICH2FO,ICH2CA,ICH2JU = ',A4,2X,A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1133)ICH2DI,ACH2AN,ICH2FI,ICH2CO
 1133 FORMAT('ICH2DI,ACH2AN,ICH2FI,ICH2CO = ',A4,E15.7,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1134)PCH2HE,PCH2WI,PCH2TH,PCH2HO,PCH2VO
 1134 FORMAT('PCH2HE,PCH2WI,PCH2TH,PCH2HO,PCH2VO = ',5E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1135)IFI2SW,IFI2PA,IFI2CO,PFI2SP,PFI2TH
 1135 FORMAT('IFI2SW,IFI2PA,IFI2CO,PFI2SP,PFI2TH = ',A4,2X,A4,2X,A4,
     12E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1136)IPA2SW,IPA2PA,IPA2LI,IPA2CO
 1136 FORMAT('IPA2SW,IPA2PA,IPA2LI,IPA2CO = ',A4,2X,A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1138)ISP2SW,ISP2LI,ISP2CO,PSP2TH,ASP2BA
 1138 FORMAT('ISP2SW,ISP2LI,ISP2CO,PSP2TH,ASP2BA = ',A4,2X,A4,2X,A4,
     12E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1141)IBA2SW,ABA2WI,ABA2BA
 1141 FORMAT('IBA2SW,ABA2WI,ABA2BA = ',A4,2X,2E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1142)IBA2BL,IBA2BC,PBA2BT
 1142 FORMAT('IBA2BL,IBA2BC,PBA2BT = ',A4,2X,A4,2X,E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1143)IBA2FS,IBA2FC
 1143 FORMAT('IBA2FS,IBA2FC = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1144)IBA2PT,IBA2PL,IBA2PC,IBA2TY,PBA2PS,PBA2PT
 1144 FORMAT('IBA2PT,IBA2PL,IBA2PC,IBA2TY,PBA2PS,PBA2PT = ',
     1A4,2X,A4,2X,A4,2X,A4,2E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1151)IRE2SW,ARE2WI,ARE2BA
 1151 FORMAT('IRE2SW,ARE2WI,ARE2BA = ',A4,2X,2E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1152)IRE2BL,IRE2BC,PRE2BT
 1152 FORMAT('IRE2BL,IRE2BC,PRE2BT = ',A4,2X,A4,2X,E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1153)IRE2FS,IRE2FC
 1153 FORMAT('IRE2FS,IRE2FC = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1154)IRE2PT,IRE2PL,IRE2PC,PRE2PS,PRE2PT
 1154 FORMAT('IRE2PT,IRE2PL,IRE2PC,PRE2PS,PRE2PT = ',A4,2X,A4,2X,
     1A4,2X,2E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1161)IMA2SW,AMA2WI,AMA2BA
 1161 FORMAT('IMA2SW,AMA2WI,AMA2BA = ',A4,2X,2E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1162)IMA2BL,IMA2BC,PMA2BT
 1162 FORMAT('IMA2BL,IMA2BC,PMA2BT = ',A4,2X,A4,2X,E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1163)IMA2FS,IMA2FC
 1163 FORMAT('IMA2FS,IMA2FC = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1164)IMA2PT,IMA2PL,IMA2PC,PMA2PS,PMA2PT
 1164 FORMAT('IMA2PT,IMA2PL,IMA2PC,PMA2PS,PMA2PT = ',A4,2X,A4,2X,
     1A4,2X,2E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1171)ITE2SW,ATE2WI,ATE2BA
 1171 FORMAT('ITE2SW,ATE2WI,ATE2BA = ',A4,2X,2E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1172)ITE2BL,ITE2BC,PTE2BT
 1172 FORMAT('ITE2BL,ITE2BC,PTE2BT = ',A4,2X,A4,2X,E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1173)ITE2FS,ITE2FC
 1173 FORMAT('ITE2FS,ITE2FC = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1174)ITE2PT,ITE2PL,ITE2PC,PTE2PS,PTE2PT
 1174 FORMAT('ITE2PT,ITE2PL,ITE2PC,PTE2PS,PTE2PT = ',A4,2X,A4,2X,
     1A4,2X,2E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1181)IHORSW,ISWTCH
 1181 FORMAT('IHORSW,ISWTCH=',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      DO1182I=1,10
      WRITE(ICOUT,1183)I,X(I),Y(I)
 1183 FORMAT('I,X(I),Y(I)=',I4,2X,E15.7,2X,E15.7)
      CALL DPWRST('XXX','BUG ')
 1182 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
 1190 CONTINUE
C
C               *****************************************
C               **  STEP 21--                          **
C               **  STEP THROUGH EACH GRAPHICS DEVICE  **
C               *****************************************
C
      ISYMBL=ITEXSY
      ISPAC=ITEXSP
C
CCCCC THE FOLLOWING 6 LINES WERE ADDED           MAY 1992 (JJF)
CCCCC TO AUTOMATICALLY CLOSE/OPEN DEVICE 3    MAY 1992
CCCCC WHENEVER AN INITIALIZATION/ERASE IS DONE   MAY 1992
CCCCC (SEE ALSO DPERAS AND MAINOD)               MAY 1992
CCCCC
CCCCC AUGMENTED TO AUTOMATICALLY SAVE THE CURRENT X11 PIXMAP TO
CCCCC A FILE.  APRIL 1997.
C
      IF(IERASW.EQ.'ON')THEN
         IF(IOPG2S.EQ.'ON')THEN
            IBUGXX=IBUGG4
            ISUBXX=ISUBG4
            IERRXX=IERRG4
            IF(IPL2CS.EQ.'OPEN')
     1      CALL DPDEV(3,'CLOS','POST',ICAPSW,IBUGXX,ISUBXX,IERRXX)
            IF(IPL2CS.EQ.'CLOSED')
     1      CALL DPDEV(3,'OPEN','POST',ICAPSW,IBUGXX,ISUBXX,IERRXX)
            IF(IPXMFL.EQ.'ON' .OR. IPXMFL.EQ.'YES')THEN
              NUMPXM=NUMPXM+1
              IF(NUMPXM.GT.MAXPM)THEN
                WRITE(ICOUT,999)
                CALL DPWRST('XXX','BUG')
                WRITE(ICOUT,2011)MAXPM
                GOTO2099
              ENDIF
 2011 FORMAT('***** ERROR FROM PLOTG2.  MAXIMUM NUMBER OF PIXMAPS (',
     1I5,') EXCEEDED.')
              IPXMFN(NUMPXM)(1:IPXMNC)=IPXMFB(1:IPXMNC)
              NCSTR=IPXMNC+1
              IF(NUMPXM.LE.9)THEN
                WRITE(IPXMFN(NUMPXM)(NCSTR:NCSTR),'(I1)')NUMPXM
              ELSEIF(NUMPXM.LE.99)THEN
                WRITE(IPXMFN(NUMPXM)(NCSTR:NCSTR+1),'(I2)')NUMPXM
                NCSTR=NCSTR+1
              ELSEIF(NUMPXM.LE.999)THEN
                WRITE(IPXMFN(NUMPXM)(NCSTR:NCSTR+2),'(I3)')NUMPXM
                NCSTR=NCSTR+2
              ENDIF 
CCCCC DECEMBER 1997.  FOR DEVICE GENERALITY, GO THROUGH GRSAGR.
              ICODE='SAVE'
              CTEMP=' '
              NCTEMP=0
              ISTRI2=' '
              ISTRI2(1:NCSTR)=IPXMFN(NUMPXM)(1:NCSTR)
              CALL GRSAGR(ICODE,ISTRI2,NCSTR,CTEMP,NCTEMP)
            ENDIF
C
CCCCC         DO2030I=1,NCSTR
CCCCC           CALL DPCOAN(IPXMFN(NUMPXM)(I:I),IADE(I))
C2030         CONTINUE
CCCCC         IERR=0
CCCCC         CALL XSAVEG(IADE,IERR)
CCCCC         IF(IERR.EQ.1)THEN
CCCCC           WRITE(ICOUT,999)
CCCCC           CALL DPWRST('XXX','BUG ')
CCCCC           WRITE(ICOUT,2041)
CCCCC           CALL DPWRST('XXX','BUG ')
CCCCC           GOTO2099
C2041 FORMAT('***** ERROR IN PLOTG2--WRITING BIT MAP UNSUCCESSFUL.')
CCCCC         ELSEIF(IERR.EQ.2)THEN
CCCCC           NUMPXM=NUMPXM-1
CCCCC           WRITE(ICOUT,999)
CCCCC           CALL DPWRST('XXX','BUG ')
CCCCC           WRITE(ICOUT,2043)
CCCCC           CALL DPWRST('XXX','BUG ')
CCCCC           GOTO2099
C2043 FORMAT('***** ERROR IN PLOTG2--NO CURRENT PIXMAP TO SAVE.')
CCCCC         ELSEIF(IERR.EQ.3)THEN
CCCCC           WRITE(ICOUT,999)
CCCCC           CALL DPWRST('XXX','BUG ')
CCCCC           WRITE(ICOUT,2045)
CCCCC           CALL DPWRST('XXX','BUG ')
CCCCC           GOTO2099
C2045 FORMAT('***** ERROR IN PLOTG2--X11 HAS NOT BEEN OPENED.')
CCCCC         ELSEIF(IERR.EQ.4)THEN
CCCCC           WRITE(ICOUT,999)
CCCCC           CALL DPWRST('XXX','BUG ')
CCCCC           WRITE(ICOUT,2047)
CCCCC           CALL DPWRST('XXX','BUG ')
CCCCC           GOTO2099
C2047 FORMAT('***** ERROR IN PLOTG2--X11 NOT INSTALLED ON THIS ',
CCCCC1'IMPLEMENTATION.')
CCCCC         ELSE
CCCCC           IF(IPXMCM(NUMPXM).EQ.' ')THEN
CCCCC             IPXMCM(NUMPXM)(1:128)=IPXMFN(NUMPXM)(1:128)
CCCCC           ENDIF
CCCCC           GOTO2099
CCCCC         ENDIF
CCCCC      ENDIF
         ENDIF
      ENDIF
 2099 CONTINUE
C
      DO2100IDEV=1,NUMDEV
C
      ICONT=IDCONT(IDEV)
CCCCC THE FOLLOWING LINE WAS INSERTED FEBRUARY 1989. (ALAN)
      IPOWER=IDPOWE(IDEV)
      IMANUF=IDMANU(IDEV)
      IMODEL=IDMODE(IDEV)
      IMODE2=IDMOD2(IDEV)
      IMODE3=IDMOD3(IDEV)
      IGCODE=IDCODE(IDEV)
      IGUNIT=IDUNIT(IDEV)
C
CCCCC FEBRUARY 2006: DEVICE 1 LATEX TO CAPTURE FILE
C
      IF(IDEV.EQ.1 .AND. IMANUF.EQ.'LATE' .AND.
     1   IPR.EQ.ICAPNU)THEN
        IGUNIT=ICAPNU
      ENDIF
C
      NUMHPP=IDNHPP(IDEV)
      ANUMHP=NUMHPP
      NUMVPP=IDNVPP(IDEV)
      ANUMVP=NUMVPP
CCCCC THE FOLLOWING 2 LINES WERE INSERTED FEBRUARY 1989. (ALAN)
      IOFFSV=IDNVOF(IDEV)
      IOFFSH=IDNHOF(IDEV)
      IGCOLO=IDCOLO(IDEV)
      IGBAUD=IDBAUD(IDEV)
      ISOFT=IDSOFT(IDEV)
      ISOFT2=IDSOF2(IDEV)
      ISOFT3=IDSOF3(IDEV)
CCCCC THE FOLLOWING LINE WAS INSERTED JULY 1996. (ALAN)
      IGFONT=IDFONT(IDEV)
C
      IF(ICONT.EQ.'OFF')GOTO2100
C
CCCCC THE FOLLOWING LINE WAS INSERTED FEBRUARY 1989. (ALAN)
CCCCC IF HAVE   DEVICE 2 OFF    COMMAND,
CCCCC DO NOT SET DEFAULT DEVICE.
CCCCC SET POWER OFF, WHEN POWER OFF DON'T DO PLOT.  DEVICE 2 ON  ???
CCCCC WILL TURN ON WHATEVER CURRENT DEVICE IS.
CCCCC THIS ALLOWS PLOT FILE TO BE TOGGLED ON AND OFF CONVIENTLY.
      IF(IPOWER.EQ.'OFF')GOTO2100
C
      IF(ISQUAR.EQ.'ON')GOTO2110
      IF(ICASPL.EQ.'PIEC')GOTO2110
      GOTO2190
 2110 CONTINUE
      PSAVE=PXMAX
      PYDEL=PYMAX-PYMIN
      PXDEL=PYDEL*(ANUMVP/ANUMHP)
      PXMAX=PXMIN+PXDEL
 2190 CONTINUE
C
C               ***************************************************
C               **  STEP 31--                                    **
C               **  CARRY OUT OPENING OPERATIONS                 **
C               **  ON THE DEVICES AND ON THE GRAPHICS SOFTWARE  **
C               ***************************************************
C
      IF(IOPGRS.EQ.'ON')
     1CALL DPOPDE
C
C               ****************************************************************
C               **  STEP 32--
C               **  CARRY OUT MINOR PRE-PLOT ACTIVITIES--
C               **  ERASE THE SCREEN, FILL  THE BACKGROUND, RING THE BELL, ETC.
C               ****************************************************************
C
      IF(IOPG2S.EQ.'ON')
     1CALL DPOPPL(IGRASW,
     1IBELSW,NUMRIN,IERASW,
     1IBACCO)
CCCCC FOLLOWING LINES ADDED MARCH, 1990 FOR X11 DEVICE.  X11 CAN
CCCCC DYNAMICALLY MODIFY THE PICTURE POINTS (ERASE SCREEN GETS UPDATED
CCCCC VALUES).
      IF(IMANUF.EQ.'X11')THEN
        NUMVPP=ANUMVP+0.5
        NUMHPP=ANUMHP+0.5
        IDNVPP(IDEV)=NUMVPP
        IDNHPP(IDEV)=NUMHPP
      ENDIF
CCCCC END CHANGES
CCCCC FOLLOWING LINES ADDED OCTOBER, 1996 FOR QWIN DEVICE.  QWIN CAN
CCCCC DYNAMICALLY MODIFY THE PICTURE POINTS (ERASE SCREEN GETS UPDATED
CCCCC VALUES).
      IF(IMANUF.EQ.'QWIN')THEN
        NUMVPP=ANUMVP+0.5
        NUMHPP=ANUMHP+0.5
        IDNVPP(IDEV)=NUMVPP
        IDNHPP(IDEV)=NUMHPP
      ENDIF
CCCCC END CHANGES
C
C               ************************************************
C               **  STEP 33--                                 **
C               **  IF HAVE NO POINTS BEING PLOTTED           **
C               **  (AND THEREFORE ONLY INTERESTED IN SEEING  **
C               **  THE TITLES, LABELS, LEGENDS, ETC.)        **
C               **  THEN SKIP DOWN TO THOSE SECTIONS.         **
C               ************************************************
C
      IF(NP.LE.0)GOTO5700
C
C               ********************************************
C               **  STEP 34--                             **
C               **  DETERMINE DATA LIMITS, FRAME LIMITS,  **
C               **  AND TIC COORDINATES.                  **
C               ********************************************
C
      IF(IDELIS.EQ.'ON')GOTO3400
      GOTO3490
C
 3400 CONTINUE
CCCCC THE FOLLOWING LINE WAS INSERTED FEBRUARY 1989
CCCCC TO HANDLE THE CASE OF AN EMPTY SUBSET
      IF(NUMSET.EQ.0)GOTO3490
      CALL DPDELI(Y,X,PX,NP,NUMSET,
     1ICASPL,ICAS3D,
     1XDELMN)
      IF(IERRG4.EQ.'YES')GOTO9000
 3490 CONTINUE
C
C               *********************************************
C               **  STEP 41--                              **
C               **  DRAW A DATA-DEFINED GENERALIZED TRACE. **
C               **  THE TRACE MAY CONSIST OF ANY OR ALL    **
C               **  OF THE FOLLOWING--                     **
C               **     1. CHARACTERS                       **
C               **     2. LINES                            **
C               **     3. BARS                             **
C               **     4. SPIKES                           **
C               *********************************************
C
      IF(IDRTRS.EQ.'ON')GOTO4100
      GOTO4190
C
 4100 CONTINUE
C
CCCCC IF(IFI2SW.EQ.'ON')
CCCCC1CALL DPFIRS(Y,X,PY,PX,NP,
CCCCC1ICASPL,ICAS3D,
CCCCC1ISORSW,
CCCCC1IFI2PA,IFI2CO,PFI2SP,PFI2TH,
CCCCC1PXMIN,PXMAX,PYMIN,PYMAX,
CCCCC1FX1MIN,FX1MAX,FY1MIN,FY1MAX,
CCCCC1IX1TSC,IY1TSC)
C
CCCCC IF(IPA2SW.EQ.'ON')
CCCCC1CALL DPDRPS(Y,X,PY,PX,NP,
CCCCC1ICASPL,ICAS3D,
CCCCC1ISORSW,
CCCCC1IPA2PA,IPA2LI,IPA2CO,PPA2HE,PPA2WI,PPATSP,PPA2TH,
CCCCC1PXMIN,PXMAX,PYMIN,PYMAX,
CCCCC1FX1MIN,FX1MAX,FY1MIN,FY1MAX,
CCCCC1IX1TSC,IY1TSC)
C
      IF(ICASPL.EQ.'HIST')GOTO4119
      IF(ICASPL.EQ.'CUMH')GOTO4119
      IF(ICASPL.EQ.'BARP')GOTO4119
      IF(ICASPL.EQ.'ROOT')GOTO4119
      IF(ICASPL.EQ.'CUMR')GOTO4119
      IF(ICASPL.EQ.'BIHI')GOTO4119
C
      ICH2SW='ON'
      IF(ICH2PA.EQ.'OFF')ICH2SW='OFF'
      IF(ICH2PA.EQ.'BLAN')ICH2SW='OFF'
      IF(ICH2PA.EQ.'BL')ICH2SW='OFF'
      IF(ICH2PA.EQ.'    ')ICH2SW='OFF'
      IF(ICH2PA.EQ.'NONE')ICH2SW='OFF'
      IF(ICH2PA.EQ.'NO')ICH2SW='OFF'
CCCCC THE FOLLOWING 2 LINES WAS ADDED FOR VECTOR PLOT AUGUST 1992
      IF(ICASPL.EQ.'VECT')ICH2PA='VECT'
      IF(ICASPL.EQ.'VVAR')ICH2PA='VECT'
CCCCC THE FOLLOWING BLOCK WAS ADDED FOR VECTOR PLOTS TO AUTOMATICALLY
CCCCC SET THE PRE-SORT OFF.   FEBRUARY 1994.
CCCCC SET THE PRE-SORT OFF FOR VIOLIN PLOT.   FEBRUARY 2003.
CCCCC SET THE PRE-SORT OFF FOR PARALLEL COORDINATES PLOT.  APRIL 2003.
      IF(ICASPL.EQ.'VECT'.OR.ICASPL.EQ.'VVAR'.OR.ICASPL.EQ.'DCON'.OR.
     1   ICASPL.EQ.'YCUB'.OR.ICASPL.EQ.'VIPL'.OR.ICASPL.EQ.'PCPL'.OR.
     1   ICASPL.EQ.'PCPG')THEN
        ISORZZ='OFF'
      ELSE
        ISORZZ=ISORSW
      END IF
C
      IF(ICH2SW.EQ.'ON')
     1CALL DPDRCH(Y,X,PY,PX,NP,PY2,PX2,NP2,X3D,
     1ICASPL,ICAS3D,
CCCCC1ISORSW,
     1ISORZZ,
CCCCC THE FOLLOWING ARGUMENT WAS ADDED MAY 1992 (JJF)
     1ARE2BA,
     1ICH2PA,ICH2FO,ICH2CA,ICH2JU,ICH2DI,ACH2AN,ICH2FI,ICH2CO,
     1PCH2HE,PCH2WI,PCH2TH,PCH2HO,PCH2VO,
     1ITEXSP,
     1PXMIN,PXMAX,PYMIN,PYMAX,
     1FX1MIN,FX1MAX,FY1MIN,FY1MAX,
     1IX1TSC,IY1TSC,
     1IMPSW2,AMPSCH,AMPSCW)
C
CCCCC THE FOLLOWING ANIMATION CHUNK WAS ADDED APRIL 1989
C
      IF(IANISW.EQ.'OFF')GOTO4109
      ICH2CO=IBACCO
      IF(ICH2SW.EQ.'ON')
     1CALL DPDRCH(Y,X,PY,PX,NP,PY2,PX2,NP2,X3D,
     1ICASPL,ICAS3D,
CCCCC1ISORSW,
     1ISORZZ,
CCCCC THE FOLLOWING ARGUMENT WAS ADDED MAY 1992 (JJF)
     1ARE2BA,
     1ICH2PA,ICH2FO,ICH2CA,ICH2JU,ICH2DI,ACH2AN,ICH2FI,ICH2CO,
     1PCH2HE,PCH2WI,PCH2TH,PCH2HO,PCH2VO,
     1ITEXSP,
     1PXMIN,PXMAX,PYMIN,PYMAX,
     1FX1MIN,FX1MAX,FY1MIN,FY1MAX,
     1IX1TSC,IY1TSC,
     1IMPSW2,AMPSCH,AMPSCW)
 4109 CONTINUE
C
      IF(ICASPL.EQ.'DCON'.OR.ICASPL.EQ.'VIPL'.OR.ICASPL.EQ.'PCPL'.OR.
     1   ICASPL.EQ.'PCPG')THEN
        ISORZZ='OFF'
      ELSE
        ISORZZ=ISORSW
      END IF
      ILI2SW='ON'
      IF(ILI2PA.EQ.'OFF')ILI2SW='OFF'
      IF(ILI2PA.EQ.'BLAN')ILI2SW='OFF'
      IF(ILI2PA.EQ.'BL')ILI2SW='OFF'
      IF(ILI2PA.EQ.'    ')ILI2SW='OFF'
      IF(ILI2PA.EQ.'NONE')ILI2SW='OFF'
      IF(ILI2PA.EQ.'NO')ILI2SW='OFF'
CCCCC THE FOLLOWING LINE WAS ADDED FOR HAZARD PLOT MAY 1989
      IF(ICASPL.EQ.'HAZA')ILI2SW='ON'
CCCCC THE FOLLOWING LINE WAS ADDED FOR SYMBOL PLOT AUGUST 1992
      IF(ICASPL.EQ.'SYMB')ILI2SW='OFF'
      IF(ILI2SW.EQ.'ON')
     1CALL DPDRTR(Y,X,PY,PX,NP,PY2,PX2,NP2,PY3,PX3,NP3,
     1ICASPL,ICAS3D,
     1ISORZZ,
     1ILI2PA,ILI2CO,PLI2TH,
CCCCC OCTOBER 1993.  ADD ARE3BA
CCCCC1ARE2BA,
     1ARE2BA,ARE3BA,
     1IRE2FS,IRE2FC,
     1IRE2PT,IRE2PL,IRE2PC,PRE2PT,PRE2PS,
CCCCC MARCH 1994.  ADD FOLLOWING LINE
     1IRE2PZ,
     1PXMIN,PXMAX,PYMIN,PYMAX,
     1FX1MIN,FX1MAX,FY1MIN,FY1MAX,
     1IX1TSC,IY1TSC)
C
CCCCC THE FOLLOWING ANIMATION CHUNK WAS ADDED APRIL 1989
C
      IF(IANISW.EQ.'OFF')GOTO4119
      ILI2CO=IBACCO
      IRE2FC=IBACCO
      IRE2PC=IBACCO
      IF(ILI2SW.EQ.'ON')
     1CALL DPDRTR(Y,X,PY,PX,NP,PY2,PX2,NP2,PY3,PX3,NP3,
     1ICASPL,ICAS3D,
     1ISORZZ,
     1ILI2PA,ILI2CO,PLI2TH,
CCCCC OCTOBER 1993.  ADD ARE3BA
CCCCC1ARE2BA,
     1ARE2BA,ARE3BA,
     1IRE2FS,IRE2FC,
     1IRE2PT,IRE2PL,IRE2PC,PRE2PT,PRE2PS,
CCCCC MARCH 1994.  ADD FOLLOWING LINE
     1IRE2PZ,
     1PXMIN,PXMAX,PYMIN,PYMAX,
     1FX1MIN,FX1MAX,FY1MIN,FY1MAX,
     1IX1TSC,IY1TSC)
 4119 CONTINUE
C
CCCCC THE FOLLOWING CHUNK WAS INSERTED BY ALAN FEBRUARY 1989
CCCCC AND THEN COMMENTED OUT BY ALAN.
CCCCC "HORIZONTAL SWITCH ON" CASE.  SEPTEMBER, 1987.  IF X AND Y REVERSED,
CCCCC SET BACK BEFORE DO BARS OR SPIKES
CCCCC IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'OTG2')GOTO4119
CCCCC WRITE(ICOUT,4111)ISWTCH
C4111 FORMAT('BEFORE DRAW BARS AND SPIKES, ISWTCH=',A4)
CCCCC CALL DPWRST('XXX','BUG ')
CCCCCCCCCDO4115I=1,10
CCCCC WRITE(ICOUT,4116)I,X(I),Y(I)
CCCCC CALL DPWRST('XXX','BUG ')
C4115 CONTINUE
C4116 FORMAT('I,X(I),Y(I)=',I4,2X,E15.7,2X,E15.7)
C4119 CONTINUE
CCCCC IF(ISWTCH.EQ.'OFF')GOTO4120
CCCCC DO4130I=1,MAXPOP
CCCCC XTEMP=X(I)
CCCCC X(I)=Y(I)
CCCCC Y(I)=XTEMP
C4130 CONTINUE
CCCCC ISWTCH='OFF'
C4120 CONTINUE
C
      IF(IBA2SW.EQ.'ON'.OR.
     1ICASPL.EQ.'HIST'.OR.
     1ICASPL.EQ.'CUMH'.OR.
     1ICASPL.EQ.'BARP'.OR.
     1ICASPL.EQ.'ROOT'.OR.
     1ICASPL.EQ.'CUMR'.OR.
     1ICASPL.EQ.'BIHI')
     1CALL DPDRBA(Y,X,PY,PX,NP,
     1ICASPL,ICAS3D,
     1ISORSW,
     1IBA2SW,ABA2WI,ABA2BA,
     1IBA2BL,IBA2BC,PBA2BT,
     1IBA2FS,IBA2FC,
     1IBA2PT,IBA2PL,IBA2PC,IBA2TY,IBA2DI,PBA2PS,PBA2PT,
     1XDELMN,
     1PXMIN,PXMAX,PYMIN,PYMAX,
     1FX1MIN,FX1MAX,FY1MIN,FY1MAX,
     1IX1TSC,IY1TSC)
C
CCCCC THE FOLLOWING ANIMATION CHUNK WAS ADDED APRIL 1989
C
      IF(IANISW.EQ.'OFF')GOTO4129
      IBA2BC=IBACCO
      IBA2FC=IBACCO
      IBA2PC=IBACCO
      IF(IBA2SW.EQ.'ON'.OR.
     1ICASPL.EQ.'HIST'.OR.
     1ICASPL.EQ.'CUMH'.OR.
     1ICASPL.EQ.'BARP'.OR.
     1ICASPL.EQ.'ROOT'.OR.
     1ICASPL.EQ.'CUMR'.OR.
     1ICASPL.EQ.'BIHI')
     1CALL DPDRBA(Y,X,PY,PX,NP,
     1ICASPL,ICAS3D,
     1ISORSW,
     1IBA2SW,ABA2WI,ABA2BA,
     1IBA2BL,IBA2BC,PBA2BT,
     1IBA2FS,IBA2FC,
     1IBA2PT,IBA2PL,IBA2PC,IBA2TY,IBA2DI,PBA2PS,PBA2PT,
     1XDELMN,
     1PXMIN,PXMAX,PYMIN,PYMAX,
     1FX1MIN,FX1MAX,FY1MIN,FY1MAX,
     1IX1TSC,IY1TSC)
 4129 CONTINUE
C
      IF(ISP2SW.EQ.'ON')
     1CALL DPDRSP(Y,X,PY,PX,NP,
     1ICASPL,ICAS3D,
     1ISORSW,
     1ISP2LI,ISP2CO,ISP2DI,PSP2TH,ASP2BA,
     1PXMIN,PXMAX,PYMIN,PYMAX,
     1FX1MIN,FX1MAX,FY1MIN,FY1MAX,
     1IX1TSC,IY1TSC)
C
CCCCC THE FOLLOWING ANIMATION CHUNK WAS ADDED APRIL 1989
C
      IF(IANISW.EQ.'OFF')GOTO4139
      ISP2CO=IBACCO
      IF(ISP2SW.EQ.'ON')
     1CALL DPDRSP(Y,X,PY,PX,NP,
     1ICASPL,ICAS3D,
     1ISORSW,
     1ISP2LI,ISP2CO,ISP2DI,PSP2TH,ASP2BA,
     1PXMIN,PXMAX,PYMIN,PYMAX,
     1FX1MIN,FX1MAX,FY1MIN,FY1MAX,
     1IX1TSC,IY1TSC)
 4139 CONTINUE
 4190 CONTINUE
C
C               ********************************************************
C               **  STEP 56--                                         **
C               **  DRAW THE FRAME, TICS, TIC LABELS, AND GRID LINES  **
C               ********************************************************
C
      IF(IDRFRS.EQ.'ON')
     1CALL DPDRFR(ICASPL,ICAS3D,
     1IVGMSW,IHGMSW)
      IF(IERRG4.EQ.'YES')GOTO9000
C
C               *********************************
C               **  STEP 57--                  **
C               **  DRAW THE LABELS AND TITLE  **
C               *********************************
C
 5700 CONTINUE
C
CCCCC IF(IWRLAS.EQ.'ON')CALL DPWRLA(PXMIN,PYMIN,PXMAX,PYMAX,   DEC. 1986
      IF(IWRLAS.EQ.'ON')GOTO5710
      GOTO5790
C
 5710 CONTINUE
      ITITCV(1)=ITITFO
      ITITCV(2)=ITITCA
      ITITCV(3)=ITITFI
      ITITCV(4)=ITITCO
      PTITRV(1)=PTITHE
      PTITRV(2)=PTITWI
      PTITRV(3)=PTITVG
      PTITRV(4)=PTITHG
      PTITRV(5)=PTITTH
      PTITRV(6)=PTITDS
C
      IX1LCV(1)=IX1LFO
      IX1LCV(2)=IX1LCA
      IX1LCV(3)=IX1LFI
      IX1LCV(4)=IX1LCO
      IX1LCV(5)=IX1LJU
      IX1LCV(6)=IX1LDI
      PX1LRV(1)=PX1LHE
      PX1LRV(2)=PX1LWI
      PX1LRV(3)=PX1LVG
      PX1LRV(4)=PX1LHG
      PX1LRV(5)=PX1LTH
      PX1LRV(6)=PX1LDS
      PX1LRV(7)=PX1LOF
      PX1LRV(8)=PX1LAN
C
      IX2LCV(1)=IX2LFO
      IX2LCV(2)=IX2LCA
      IX2LCV(3)=IX2LFI
      IX2LCV(4)=IX2LCO
      IX2LCV(5)=IX2LJU
      IX2LCV(6)=IX2LDI
      PX2LRV(1)=PX2LHE
      PX2LRV(2)=PX2LWI
      PX2LRV(3)=PX2LVG
      PX2LRV(4)=PX2LHG
      PX2LRV(5)=PX2LTH
      PX2LRV(6)=PX2LDS
      PX2LRV(7)=PX2LOF
      PX2LRV(8)=PX2LAN
C
      IX3LCV(1)=IX3LFO
      IX3LCV(2)=IX3LCA
      IX3LCV(3)=IX3LFI
      IX3LCV(4)=IX3LCO
      IX3LCV(5)=IX3LJU
      IX3LCV(6)=IX3LDI
      PX3LRV(1)=PX3LHE
      PX3LRV(2)=PX3LWI
      PX3LRV(3)=PX3LVG
      PX3LRV(4)=PX3LHG
      PX3LRV(5)=PX3LTH
      PX3LRV(6)=PX3LDS
      PX3LRV(7)=PX3LOF
      PX3LRV(8)=PX3LAN
C
      IY1LCV(1)=IY1LFO
      IY1LCV(2)=IY1LCA
      IY1LCV(3)=IY1LFI
      IY1LCV(4)=IY1LCO
      IY1LCV(5)=IY1LJU
      IY1LCV(6)=IY1LDI
      PY1LRV(1)=PY1LHE
      PY1LRV(2)=PY1LWI
      PY1LRV(3)=PY1LVG
      PY1LRV(4)=PY1LHG
      PY1LRV(5)=PY1LTH
      PY1LRV(6)=PY1LDS
      PY1LRV(7)=PY1LOF
      PY1LRV(8)=PY1LAN
C
      IY2LCV(1)=IY2LFO
      IY2LCV(2)=IY2LCA
      IY2LCV(3)=IY2LFI
      IY2LCV(4)=IY2LCO
      IY2LCV(5)=IY2LJU
      IY2LCV(6)=IY2LDI
      PY2LRV(1)=PY2LHE
      PY2LRV(2)=PY2LWI
      PY2LRV(3)=PY2LVG
      PY2LRV(4)=PY2LHG
      PY2LRV(5)=PY2LTH
      PY2LRV(6)=PY2LDS
      PY2LRV(7)=PY2LOF
      PY2LRV(8)=PY2LAN
C
      CALL DPWRLA(PXMIN,PYMIN,PXMAX,PYMAX,
     1ITITTE,NCTITL,ITITCV,PTITRV,
     1IX1LTE,NCX1LA,IX1LCV,PX1LRV,
     1IX2LTE,NCX2LA,IX2LCV,PX2LRV,
     1IX3LTE,NCX3LA,IX3LCV,PX3LRV,
     1IY1LTE,NCY1LA,IY1LCV,PY1LRV,
     1IY2LTE,NCY2LA,IY2LCV,PY2LRV,
     1ISYMBL,ISPAC,
     1IMPSW2,AMPSCH,AMPSCW,
     1IHNAME,IHNAM2,IUSE,IVALUE,VALUE,NUMNAM,
     1IVSTAR,IVSTOP,IFUNC,NUMCHF,IREPCH,ISEQSW,NUMSEQ)
C
 5790 CONTINUE
C
C               ***********************************************************
C               **  STEP 58--                                            **
C               **  DRAW THE LEGENDS, LEGEND BOXES, SEGMENTS AND ARROWS  **
C               ***********************************************************
C
CCCCC THE PLEGTH ARGUMENT WAS ADDED FEBRUARY 1989 (ALAN)
CCCCC AUGUST 1995.  ADD ILGENA TO LIST
      IF(IWRLES.EQ.'ON')
     1CALL DPWRLE(ILEGTE,ILEGST,ILEGSP,ILEGNA,
     1PLEGXC,PLEGYC,
     1ILEGFO,ILEGCA,ILEGJU,ILEGDI,ALEGAN,ILEGFI,ILEGCO,ILEGUN,
     1PLEGHE,PLEGWI,PLEGVG,PLEGHG,PLEGTH,NUMLEG,
     1PBOXXC,PBOXYC,
     1IBOBCO,
CCCCC THE FOLLOWING LINE WAS MODIFIED AUGUST 1992
CCCCC1IBOPPA,IBOPCO,
     1IBOPPA,IBOBPA,
     1PBOPTH,PBOPGA,
     1IBOFPA,IBOFCO,
CCCCC THE FOLLOWING LINE WAS AUGMENTED FOR BOX SHADOW   AUGUST 1992
CCCCC1PBOFTH,NUMBOX,
     1PBOFTH,PBOSHE,PBOSWI,NUMBOX,
     1PARRXC,PARRYC,
     1IARRPA,IARRCO,
     1PARRTH,
     1PARHLE,PARHWI,NUMARR,
     1PSEGXC,PSEGYC,
     1ISEGPA,ISEGCO,
     1PSEGTH,NUMSEG,
     1IMPSW2,AMPSCH,AMPSCW,
     1IHNAME,IHNAM2,IUSE,IVALUE,VALUE,NUMNAM,
     1IVSTAR,IVSTOP,IFUNC,NUMCHF,IREPCH,ISYMBL,ISPAC)
C
C               ****************************************************************
C               **  STEP 61--                                                 **
C               **  CARRY OUT POST-PLOT OPERATIONS--                          **
C               **  COPYING THE SCREEN, MOVING CURSOR TO HOME POSITION, ETC.  **
C               ****************************************************************
C
      IF(ICLG2S.EQ.'ON')
     1CALL DPCLPL(ICOPSW,NUMCOP,
     1PGRAXF,PGRAYF,
     1IGRASW,PDIAXC,PDIAYC,PDIAX2,PDIAY2,
     1PDIAHE,PDIAWI,PDIAVG,PDIAHG)
C
C               ***************************************************
C               **  STEP 62--                                    **
C               **  CARRY OUT CLOSING OPERATIONS                 **
C               **  ON THE DEVICES AND ON THE GRAPHICS SOFTWARE  **
C               ***************************************************
C
      IF(ICLGRS.EQ.'ON')
     1CALL DPCLDE
C
      IF(ISQUAR.EQ.'ON')GOTO6210
      IF(ICASPL.EQ.'PIEC')GOTO6210
      GOTO6290
C
 6210 CONTINUE
      PXMAX=PSAVE
C
 6290 CONTINUE
C
 2100 CONTINUE
      IF(IWRLAS.EQ.'ON'.AND.ISEQSW.EQ.'ON')NUMSEQ=NUMSEQ+1
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'OTG2')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF PLOTG2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IMANUF,IMODEL
 9012 FORMAT('IMANUF,IMODEL = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9015)IBUGG4,ISUBG4,IERRG4
 9015 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
CCCCC THE FOLLOWING 2 LINES WERE ADDED   MAY 1992
      WRITE(ICOUT,9016)IPL2CS
 9016 FORMAT('IPL2CS = ',A4)
      CALL DPWRST('XXX','BUG ')
C  APRIL 1992.  FIX TYPO IN FOLLOWING 2 LINES
CCCCC WRITE(ICOUT,9017)NUMSET,ISET3,ISET3S
C9017 FORMAT('NUMSET,ISET3,ISET3S = ',3I8)
CCCCC CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9017)NUMSET,ISET,ISET3
 9017 FORMAT('NUMSET,ISET,ISET3 = ',3I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9018)ICASPL,ICAS3D
 9018 FORMAT('ICASPL,ICAS3D = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9019)ISQUAR,XDELMN
 9019 FORMAT('ISQUAR,XDELMN = ',A4,2X,E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9021)ILI2PA,ILI2SW
 9021 FORMAT('ILI2PA,ILI2SW = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9022)ICH2PA,ICH2SW
 9022 FORMAT('ICH2PA,ICH2SW = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9031)IBA2SW,ABA2WI,ABA2BA
 9031 FORMAT('IBA2SW,ABA2WI,ABA2BA = ',A4,2X,2E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9032)IBA2BL,IBA2BC,PBA2BT
 9032 FORMAT('IBA2BL,IBA2BC,PBA2BT = ',A4,2X,A4,2X,E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9033)IBA2FS,IBA2FC
 9033 FORMAT('IBA2FS,IBA2FC = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9034)IBA2PT,IBA2PL,IBA2PC,IBA2TY,PBA2PS,PBA2PT
 9034 FORMAT('IBA2PT,IBA2PL,IBA2PC,IBA2TY,PBA2PS,PBA2PT = ',
     1A4,2X,A4,2X,A4,2X,A4,2X,2E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9035)ITEXSY,ITEXSP
 9035 FORMAT('ITEXSY,ITEXSP = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9036)ISYMBL,ISPAC
 9036 FORMAT('ISYMBL,ISPAC = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9041)IREPCH
 9041 FORMAT('IREPCH = ',A1)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9043)IBACCO,IANISW
 9043 FORMAT('IBACCO,IANISW = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE PLOTG3(XRAW,YRAW,ZRAW,NP,DSIZE,
     1PX,PY,PZ,PX2,PY2,PZ2,NP2,PX3,PY3,NP3,NUMSET,
     1ICASPL,ICAS3D,
     1ISQUAR,
     1IVGMSW,IHGMSW,
     1XDELMN,YDELMN,ZDELMN,
     1ISTEP,ISUBST,ISET,ISET3,ICH3PA,
     1IOPGRS,IOPG2S,IDELIS,IDRFRS,IWRLAS,IWRLES,IDRTRS,ICLG2S,ICLGRS,
     1ICAPSW,
     1IHNAME,IHNAM2,IUSE,IVALUE,VALUE,NUMNAM,
     1IVSTAR,IVSTOP,IFUNC,NUMCHF,IREPCH,ISWTCH)
C
C     PURPOSE--GENERATE A COMPLETE 3-D PLOT OF A SINGLE TRACE OF Y VERSUS X
C              (INCLUDING FRAME, TICS, LEGENDS, ETC.)
C
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-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--83.6
C     ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MAY       1983.
C     UPDATED         --SEPTEMBER 1988  BIHISTOGRAM
C     UPDATED         --MARCH     1990  X11 PATCH
C     UPDATED         --AUGUST    1992  DPWRLE PARAMETERS, BOX NAMES
C     UPDATED         --AUGUST    1992  SOME PLOTG2 BUG FIXES INCORPORATED
C     UPDATED         --SEPTEMBER 1993  3-D FRAMES
C     UPDATED         --AUGUST    1995  ARGUMENT LIST TO DPWRLE
C     UPDATED         --MAY       1996  DIMENSION FOR XT, ZT
C     UPDATED         --JULY      1996  ADD IDFONT
C     UPDATED         --OCTOBER   1996  QWIN PATCH
C     UPDATED         --APRIL     1997. SUPPORT FOR AUTOMATICALLY
C                                       SAVING X11 PIXMAPS
C     UPDATED         --DECEMBER  1997. GENERALIZE PIXMAPS TO OTHER
C                                       DEVICE
C     UPDATED         --NOVEMBER  1999. ARGUMENT TO DPWRLA
C     UPDATED         --FEBRUARY  2006. DEVICE 1 LATEX OUTPUT TO
C                                       CAPTURE FILE
C
C-----FOR NON-COMMON VARIABLES-----------------------------------------
C
      CHARACTER*4 ICONT
C
      CHARACTER*4 ISQUAR
C
      CHARACTER*4 ICAPSW
C
      CHARACTER*4 IVGMSW
      CHARACTER*4 IHGMSW
C
      CHARACTER*4 ICASPL
      CHARACTER*4 ICAS3D
C
      CHARACTER*4 ICH3PA
C
      CHARACTER*4 ILI2SW
      CHARACTER*4 ILI2PA
      CHARACTER*4 ILI2CO
C
      CHARACTER*4 ICH2SW
      CHARACTER*4 ICH2PA
      CHARACTER*4 ICH2FO
      CHARACTER*4 ICH2CA
      CHARACTER*4 ICH2JU
      CHARACTER*4 ICH2DI
      CHARACTER*4 ICH2FI
      CHARACTER*4 ICH2CO
C
      CHARACTER*4 IFI2SW
      CHARACTER*4 IFI2PA
      CHARACTER*4 IFI2CO
C
      CHARACTER*4 IPA2SW
      CHARACTER*4 IPA2PA
      CHARACTER*4 IPA2LI
      CHARACTER*4 IPA2CO
C
      CHARACTER*4 ISP2SW
      CHARACTER*4 ISP2LI
      CHARACTER*4 ISP2CO
      CHARACTER*4 ISP2DI
C
      CHARACTER*4 IBA2SW
      CHARACTER*4 IBA2BL
      CHARACTER*4 IBA2BC
      CHARACTER*4 IBA2FS
      CHARACTER*4 IBA2FC
      CHARACTER*4 IBA2PT
      CHARACTER*4 IBA2PL
      CHARACTER*4 IBA2PC
      CHARACTER*4 IBA2TY
      CHARACTER*4 IBA2DI
C
      CHARACTER*4 IRE2SW
      CHARACTER*4 IRE2BL
      CHARACTER*4 IRE2BC
      CHARACTER*4 IRE2FS
      CHARACTER*4 IRE2FC
      CHARACTER*4 IRE2PT
      CHARACTER*4 IRE2PL
      CHARACTER*4 IRE2PC
C
      CHARACTER*4 IMA2SW
      CHARACTER*4 IMA2BL
      CHARACTER*4 IMA2BC
      CHARACTER*4 IMA2FS
      CHARACTER*4 IMA2FC
      CHARACTER*4 IMA2PT
      CHARACTER*4 IMA2PL
      CHARACTER*4 IMA2PC
C
      CHARACTER*4 ITE2SW
      CHARACTER*4 ITE2BL
      CHARACTER*4 ITE2BC
      CHARACTER*4 ITE2FS
      CHARACTER*4 ITE2FC
      CHARACTER*4 ITE2PT
      CHARACTER*4 ITE2PL
      CHARACTER*4 ITE2PC
C
      CHARACTER*4 IOPGRS
      CHARACTER*4 IOPG2S
      CHARACTER*4 IDELIS
      CHARACTER*4 IDRFRS
      CHARACTER*4 IWRLAS
      CHARACTER*4 IWRLES
      CHARACTER*4 IDRTRS
      CHARACTER*4 ICLG2S
      CHARACTER*4 ICLGRS
C
      CHARACTER*4 ISYMBL
      CHARACTER*4 ISPAC
C
      CHARACTER*4 IHNAME
      CHARACTER*4 IHNAM2
      CHARACTER*4 IUSE
      CHARACTER*4 IFUNC
C
      CHARACTER*1 IREPCH
CCCCC ISWTCH ADDED FOR CONSISTENCY WITH PLOTG2.  NOT YET USED.
      CHARACTER*4 ISWTCH
C
CCCCC FOLLOWING ADDED AUGUST 1992.
      CHARACTER*4 IPOWER
      CHARACTER*4 IBUGXX
      CHARACTER*4 ISUBXX
      CHARACTER*4 IERRXX
C
      CHARACTER*4 ITITCV
      CHARACTER*4 IX1LCV
      CHARACTER*4 IX2LCV
      CHARACTER*4 IX3LCV
      CHARACTER*4 IY1LCV
      CHARACTER*4 IY2LCV
C
      CHARACTER*128 ISTRI2
      CHARACTER*128 CTEMP
      CHARACTER*4 ICODE
C
      DIMENSION XRAW(*)
      DIMENSION YRAW(*)
      DIMENSION ZRAW(*)
      DIMENSION PX(*)
      DIMENSION PY(*)
      DIMENSION PZ(*)
      DIMENSION PX2(*)
      DIMENSION PY2(*)
      DIMENSION PZ2(*)
      DIMENSION PX3(*)
      DIMENSION PY3(*)
C
      DIMENSION DSIZE(*)
C
C     THE FOLLOWING 2 LINES ARE TEMPORARY SETTINGS-- 9/88 --
C
CCCCC THESE NEED TO BE HIGHER.  MAY 1996.  SET TO MAXPOP
CCCCC DIMENSION XT(2048)
CCCCC DIMENSION ZT(2048)
      INCLUDE 'DPCOPA.INC'
      DIMENSION XT(MAXPOP)
      DIMENSION ZT(MAXPOP)
C
      DIMENSION XPRIME(12)
      DIMENSION YPRIME(12)
      DIMENSION ZPRIME(12)
C
      DIMENSION IHNAME(*)
      DIMENSION IHNAM2(*)
      DIMENSION IUSE(*)
      DIMENSION IVALUE(*)
      DIMENSION VALUE(*)
      DIMENSION IVSTAR(*)
      DIMENSION IVSTOP(*)
      DIMENSION IFUNC(*)
C
      DIMENSION ITITCV(4)
      DIMENSION PTITRV(6)
      DIMENSION IX1LCV(6)
      DIMENSION PX1LRV(8)
      DIMENSION IX2LCV(6)
      DIMENSION PX2LRV(8)
      DIMENSION IX3LCV(6)
      DIMENSION PX3LRV(8)
      DIMENSION IY1LCV(6)
      DIMENSION PY1LRV(8)
      DIMENSION IY2LCV(6)
      DIMENSION PY2LRV(8)
C
CCCCC DIMENSION AUPPHX(300)
CCCCC DIMENSION ALOWHX(300)
CCCCC DIMENSION AUPPHY(300)
CCCCC DIMENSION ALOWHY(300)
CCCCC ADD FOLLOWING LINE APRIL 1997
CCCCC DIMENSION IADE(128)
C
C-----COMMON----------------------------------------------------------
C
CCCCC MAY 1996.  MOVE DPCOPA EARLIER
CCCCC INCLUDE 'DPCOPA.INC'
      INCLUDE 'DPCOPC.INC'
      INCLUDE 'DPCOGR.INC'
      INCLUDE 'DPCOBE.INC'
      INCLUDE 'DPCO3D.INC'
CCCCC THE FOLLOWING LINE WAS ADDED AUGUST 1992.
      INCLUDE 'DPCOF2.INC'
CCCCC THE FOLLOWING LINE WAS ADDED APRIL 1997.
      INCLUDE 'DPCOPM.INC'
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      PSAVE=-999.0
C
      ILI2SW='ON'
      ICH2SW='ON'
C
      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'OTG3')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF PLOTG3--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)ISTEP,ISUBST,ISET,ISET3,ICH3PA
   53 FORMAT('ISTEP,ISUBST,ISET,ISET3,ICH3PA = ',4I8,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,62)NP
   62 FORMAT('NP = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,63)XRAW(1),YRAW(1),ZRAW(1),PY(1),PX(1)
   63 FORMAT('XRAW(1),YRAW(1),ZRAW(1),PY(1),PX(1) = ',5E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,64)XRAW(2),YRAW(2),ZRAW(2),PY(2),PX(2)
   64 FORMAT('XRAW(2),YRAW(2),ZRAW(2),PY(2),PX(2) = ',5E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,65)XRAW(NP),YRAW(NP),ZRAW(NP),PY(NP),PX(NP)
CCCCC MAY 1996.  FIX FOLLOWING FORMAT
CCC65 FORMAT('XRAW(NP),YRAW(NP),ZRAW(NP),PY(NP),PX(NP) = ',4E15.7)
   65 FORMAT('XRAW(NP),YRAW(NP),ZRAW(NP),PY(NP),PX(NP) = ',5E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,67)NUMSET
   67 FORMAT('NUMSET = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,68)ICASPL,ICAS3D,I3DPRO
   68 FORMAT('ICASPL,ICAS3D,I3DPRO = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,69)ISQUAR,XDELMN,YDELMN,ZDELMN
   69 FORMAT('ISQUAR,XDELMN,YDELMN,ZDELMN = ',A4,2X,3E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,71)IOPGRS
   71 FORMAT('IOPGRS = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,72)IOPG2S
   72 FORMAT('IOPG2S = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,73)IDELIS
   73 FORMAT('IDELIS = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,74)IDRFRS
   74 FORMAT('IDRFRS = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,75)IWRLAS
   75 FORMAT('IWRLAS = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,76)IWRLES
   76 FORMAT('IWRLES = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,77)IDRTRS
   77 FORMAT('IDRTRS = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,78)ICLG2S
   78 FORMAT('ICLG2S = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,79)ICLGRS
   79 FORMAT('ICLGRS = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,80)ITEXSY,ITEXSP
   80 FORMAT('ITEXSY,ITEXSP = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,81)IMANUF,IMODEL
   81 FORMAT('IMANUF,IMODEL = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,82)IREPCH
   82 FORMAT('IREPCH = ',A1)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,89)IBUGG4,ISUBG4,IERRG4
   89 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
   90 CONTINUE
C
C               **************************************************
C               **  STEP 11--                                   **
C               **  EXTRACT SETTINGS FOR THIS PARTICULAR TRACE  **
C               **************************************************
C
CCCCC IF(IOPGRS.EQ.'ON')GOTO1119
CCCCC IF(ICLGRS.EQ.'ON')GOTO1119
C
      ICH2PA=ICHAPA(ISET3)
      ICH2FO=ICHAFO(ISET3)
      ICH2CA=ICHACA(ISET3)
      ICH2JU=ICHAJU(ISET3)
      ICH2DI=ICHADI(ISET3)
      ACH2AN=ACHAAN(ISET3)
      ICH2FI=ICHAFI(ISET3)
      ICH2CO=ICHACO(ISET3)
      PCH2HE=PCHAHE(ISET3)
      PCH2WI=PCHAWI(ISET3)
      PCH2TH=PCHATH(ISET3)
      PCH2HO=PCHAHO(ISET3)
      PCH2VO=PCHAVO(ISET3)
      ILI2PA=ILINPA(ISET3)
      ILI2CO=ILINCO(ISET3)
      PLI2TH=PLINTH(ISET3)
      IFI2SW=IFILSW(ISET3)
      IFI2PA=IFILPA(ISET3)
      IFI2CO=IFILCO(ISET3)
      PFI2SP=PFILSP(ISET3)
      PFI2TH=PFILTH(ISET3)
      IPA2SW=IPATSW(ISET3)
      IPA2PA=IPATPA(ISET3)
      IPA2LI=IPATLI(ISET3)
      IPA2CO=IPATCO(ISET3)
      PPA2HE=PPATHE(ISET3)
      PPA2WI=PPATWI(ISET3)
      PPA2SP=PPATSP(ISET3)
      PPA2TH=PPATTH(ISET3)
      ISP2SW=ISPISW(ISET3)
      ISP2LI=ISPILI(ISET3)
      ISP2CO=ISPICO(ISET3)
      ISP2DI=ISPIDI(ISET3)
      PSP2TH=PSPITH(ISET3)
      ASP2BA=ASPIBA(ISET3)
C
      IBA2SW=IBARSW(ISET3)
      ABA2WI=ABARWI(ISET3)
      ABA2BA=ABARBA(ISET3)
      IBA2BL=IBABLI(ISET3)
      IBA2BC=IBABCO(ISET3)
      PBA2BT=PBABTH(ISET3)
      IBA2FS=IBAFSW(ISET3)
      IBA2FC=IBAFCO(ISET3)
      IBA2PT=IBAPTY(ISET3)
      IBA2PL=IBAPLI(ISET3)
      IBA2PC=IBAPCO(ISET3)
      IBA2TY=IBARTY(ISET3)
      IBA2DI=IBARDI(ISET3)
      PBA2PS=PBAPSP(ISET3)
      PBA2PT=PBAPTH(ISET3)
C
      IRE2SW=IREGSW(ISET3)
      ARE2WI=AREGWI(ISET3)
      ARE2BA=AREGBA(ISET3)
      IRE2BL=IREBLI(ISET3)
      IRE2BC=IREBCO(ISET3)
      PRE2BT=PREBTH(ISET3)
      IRE2FS=IREFSW(ISET3)
      IRE2FC=IREFCO(ISET3)
      IRE2PT=IREPTY(ISET3)
      IRE2PL=IREPLI(ISET3)
      IRE2PC=IREPCO(ISET3)
      PRE2PS=PREPSP(ISET3)
      PRE2PT=PREPTH(ISET3)
C
      IMA2SW=IMARSW(ISET3)
      AMA2WI=AMARWI(ISET3)
      AMA2BA=AMARBA(ISET3)
      IMA2BL=IMABLI(ISET3)
      IMA2BC=IMABCO(ISET3)
      PMA2BT=PMABTH(ISET3)
      IMA2FS=IMAFSW(ISET3)
      IMA2FC=IMAFCO(ISET3)
      IMA2PT=IMAPTY(ISET3)
      IMA2PL=IMAPLI(ISET3)
      IMA2PC=IMAPCO(ISET3)
      PMA2PS=PMAPSP(ISET3)
      PMA2PT=PMAPTH(ISET3)
C
      ITE2SW=ITEXSW(ISET3)
      ATE2WI=ATEXWI(ISET3)
      ATE2BA=ATEXBA(ISET3)
      ITE2BL=ITEBLI(ISET3)
      ITE2BC=ITEBCO(ISET3)
      PTE2BT=PTEBTH(ISET3)
      ITE2FS=ITEFSW(ISET3)
      ITE2FC=ITEFCO(ISET3)
      ITE2PT=ITEPTY(ISET3)
      ITE2PL=ITEPLI(ISET3)
      ITE2PC=ITEPCO(ISET3)
      PTE2PS=PTEPSP(ISET3)
      PTE2PT=PTEPTH(ISET3)
C
      IF(ISTEP.EQ.2.AND.ISUBST.EQ.3)ICH2PA=ICH3PA
      IF(ISTEP.EQ.2.AND.ISUBST.EQ.4)ICH2PA=ICH3PA
      IF(ICASPL.EQ.'YCUB'.AND.ISET3.EQ.1)THEN
        ICH2PA='ZVAL'
        ILI2PA='BLAN'
      ENDIF
C
 1119 CONTINUE
C
      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'OTG2')GOTO1190
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1121)
 1121 FORMAT('***** FROM THE MIDDLE OF PLOTG3--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1131)ILI2PA,PLI2TH,ILI2CO
 1131 FORMAT('ILI2PA,PLI2TH,ILI2CO = ',A4,2X,E15.7,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1132)ICH2PA,ICH2FO,ICH2CA,ICH2JU
 1132 FORMAT('ICH2PA,ICH2FO,ICH2CA,ICH2JU = ',A4,2X,A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1133)ICH2DI,ACH2AN,ICH2FI,ICH2CO
 1133 FORMAT('ICH2DI,ACH2AN,ICH2FI,ICH2CO = ',A4,E15.7,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1134)PCH2HE,PCH2WI,PCH2TH,PCH2HO,PCH2VO
 1134 FORMAT('PCH2HE,PCH2WI,PCH2TH,PCH2HO,PCH2VO = ',5E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1135)IFI2SW,IFI2PA,IFI2CO,PFI2SP,PFI2TH
 1135 FORMAT('IFI2SW,IFI2PA,IFI2CO,PFI2SP,PFI2TH = ',A4,2X,A4,2X,A4,
     12E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1136)IPA2SW,IPA2PA,IPA2LI,IPA2CO
 1136 FORMAT('IPA2SW,IPA2PA,IPA2LI,IPA2CO = ',A4,2X,A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1138)ISP2SW,ISP2LI,ISP2CO,PSP2TH,ASP2BA
 1138 FORMAT('ISP2SW,ISP2LI,ISP2CO,PSP2TH,ASP2BA = ',A4,2X,A4,2X,A4,
     12E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1141)IBA2SW,ABA2WI,ABA2BA
 1141 FORMAT('IBA2SW,ABA2WI,ABA2BA = ',A4,2X,2E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1142)IBA2BL,IBA2BC,PBA2BT
 1142 FORMAT('IBA2BL,IBA2BC,PBA2BT = ',A4,2X,A4,2X,E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1143)IBA2FS,IBA2FC
 1143 FORMAT('IBA2FS,IBA2FC = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1144)IBA2PT,IBA2PL,IBA2PC,IBA2TY,PBA2PS,PBA2PT
 1144 FORMAT('IBA2PT,IBA2PL,IBA2PC,IBA2TY,PBA2PS,PBA2PT = ',
     1A4,2X,A4,2X,A4,2X,A4,2E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1151)IRE2SW,ARE2WI,ARE2BA
 1151 FORMAT('IRE2SW,ARE2WI,ARE2BA = ',A4,2X,2E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1152)IRE2BL,IRE2BC,PRE2BT
 1152 FORMAT('IRE2BL,IRE2BC,PRE2BT = ',A4,2X,A4,2X,E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1153)IRE2FS,IRE2FC
 1153 FORMAT('IRE2FS,IRE2FC = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1154)IRE2PT,IRE2PL,IRE2PC,PRE2PS,PRE2PT
 1154 FORMAT('IRE2PT,IRE2PL,IRE2PC,PRE2PS,PRE2PT = ',A4,2X,A4,2X,
     1A4,2X,2E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1161)IMA2SW,AMA2WI,AMA2BA
 1161 FORMAT('IMA2SW,AMA2WI,AMA2BA = ',A4,2X,2E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1162)IMA2BL,IMA2BC,PMA2BT
 1162 FORMAT('IMA2BL,IMA2BC,PMA2BT = ',A4,2X,A4,2X,E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1163)IMA2FS,IMA2FC
 1163 FORMAT('IMA2FS,IMA2FC = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1164)IMA2PT,IMA2PL,IMA2PC,PMA2PS,PMA2PT
 1164 FORMAT('IMA2PT,IMA2PL,IMA2PC,PMA2PS,PMA2PT = ',A4,2X,A4,2X,
     1A4,2X,2E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1171)ITE2SW,ATE2WI,ATE2BA
 1171 FORMAT('ITE2SW,ATE2WI,ATE2BA = ',A4,2X,2E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1172)ITE2BL,ITE2BC,PTE2BT
 1172 FORMAT('ITE2BL,ITE2BC,PTE2BT = ',A4,2X,A4,2X,E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1173)ITE2FS,ITE2FC
 1173 FORMAT('ITE2FS,ITE2FC = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1174)ITE2PT,ITE2PL,ITE2PC,PTE2PS,PTE2PT
 1174 FORMAT('ITE2PT,ITE2PL,ITE2PC,PTE2PS,PTE2PT = ',A4,2X,A4,2X,
     1A4,2X,2E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
 1190 CONTINUE
C
C               *****************************************
C               **  STEP 21--                          **
C               **  STEP THROUGH EACH GRAPHICS DEVICE  **
C               *****************************************
C
      ISYMBL=ITEXSY
      ISPAC=ITEXSP
C
CCCCC THE FOLLOWING 6 LINES WERE ADDED           AUGUST 1992
CCCCC TO AUTOMATICALLY CLOSE/OPEN DEVICE 3
CCCCC WHENEVER AN INITIALIZATION/ERASE IS DONE
CCCCC (SEE ALSO DPERAS AND MAINOD)
C
      IF(IERASW.EQ.'ON')THEN
         IF(IOPG2S.EQ.'ON')THEN
            IBUGXX=IBUGG4
            ISUBXX=ISUBG4
            IERRXX=IERRG4
            IF(IPL2CS.EQ.'OPEN')
     1      CALL DPDEV(3,'CLOS','POST',ICAPSW,IBUGXX,ISUBXX,IERRXX)
            IF(IPL2CS.EQ.'CLOSED')
     1      CALL DPDEV(3,'OPEN','POST',ICAPSW,IBUGXX,ISUBXX,IERRXX)
            IF(IPXMFL.EQ.'ON' .OR. IPXMFL.EQ.'YES')THEN
              NUMPXM=NUMPXM+1
              IF(NUMPXM.GT.MAXPM)THEN
                WRITE(ICOUT,999)
                CALL DPWRST('XXX','BUG')
                WRITE(ICOUT,2011)MAXPM
                GOTO2099
              ENDIF
 2011 FORMAT('***** ERROR FROM PLOTG3.  MAXIMUM NUMBER OF PIXMAPS (',
     1I5,') EXCEEDED.')
              IPXMFN(NUMPXM)(1:IPXMNC)=IPXMFB(1:IPXMNC)
              NCSTR=IPXMNC+1
              IF(NUMPXM.LE.9)THEN
                WRITE(IPXMFN(NUMPXM)(NCSTR:NCSTR),'(I1)')NUMPXM
              ELSEIF(NUMPXM.LE.99)THEN
                WRITE(IPXMFN(NUMPXM)(NCSTR:NCSTR+1),'(I2)')NUMPXM
                NCSTR=NCSTR+1
              ELSEIF(NUMPXM.LE.999)THEN
                WRITE(IPXMFN(NUMPXM)(NCSTR:NCSTR+2),'(I3)')NUMPXM
                NCSTR=NCSTR+2
              ENDIF 
CCCCC DECEMBER 1997.  FOR DEVICE GENERALITY, GO THROUGH GRSAGR.
              ICODE='SAVE'
              CTEMP=' '
              NCTEMP=0
              ISTRI2=' '
              ISTRI2(1:NCSTR)=IPXMFN(NUMPXM)(1:NCSTR)
              CALL GRSAGR(ICODE,ISTRI2,NCSTR,CTEMP,NCTEMP)
            ENDIF
C
CCCCC         DO2030I=1,NCSTR
CCCCC           CALL DPCOAN(IPXMFN(NUMPXM)(I:I),IADE(I))
C2030         CONTINUE
CCCCC         IERR=0
CCCCC         CALL XSAVEG(IADE,IERR)
CCCCC         IF(IERR.EQ.1)THEN
CCCCC           WRITE(ICOUT,999)
CCCCC           CALL DPWRST('XXX','BUG ')
CCCCC           WRITE(ICOUT,2041)
CCCCC           CALL DPWRST('XXX','BUG ')
CCCCC           GOTO2099
C2041 FORMAT('***** ERROR IN PLOTG2--WRITING BIT MAP UNSUCCESSFUL.')
CCCCC         ELSEIF(IERR.EQ.2)THEN
CCCCC           NUMPXM=NUMPXM-1
CCCCC           WRITE(ICOUT,999)
CCCCC           CALL DPWRST('XXX','BUG ')
CCCCC           WRITE(ICOUT,2043)
CCCCC           CALL DPWRST('XXX','BUG ')
CCCCC           GOTO2099
C2043 FORMAT('***** ERROR IN PLOTG2--NO CURRENT PIXMAP TO SAVE.')
CCCCC         ELSEIF(IERR.EQ.3)THEN
CCCCC           WRITE(ICOUT,999)
CCCCC           CALL DPWRST('XXX','BUG ')
CCCCC           WRITE(ICOUT,2045)
CCCCC           CALL DPWRST('XXX','BUG ')
CCCCC           GOTO2099
C2045 FORMAT('***** ERROR IN PLOTG2--X11 HAS NOT BEEN OPENED.')
CCCCC         ELSEIF(IERR.EQ.4)THEN
CCCCC           WRITE(ICOUT,999)
CCCCC           CALL DPWRST('XXX','BUG ')
CCCCC           WRITE(ICOUT,2047)
CCCCC           CALL DPWRST('XXX','BUG ')
CCCCC           GOTO2099
C2047 FORMAT('***** ERROR IN PLOTG2--X11 NOT INSTALLED ON THIS ',
CCCCC1'IMPLEMENTATION.')
CCCCC         ELSE
CCCCC           IF(IPXMCM(NUMPXM).EQ.' ')THEN
CCCCC             IPXMCM(NUMPXM)(1:128)=IPXMFN(NUMPXM)(1:128)
CCCCC           ENDIF
CCCCC           GOTO2099
CCCCC         ENDIF
CCCCC      ENDIF
         ENDIF
      ENDIF
 2099 CONTINUE
C
      DO2100IDEV=1,NUMDEV
C
      ICONT=IDCONT(IDEV)
CCCCC THE FOLLOWING LINE WAS INSERTED AUGUST 1992. (ALAN)
      IPOWER=IDPOWE(IDEV)
      IMANUF=IDMANU(IDEV)
      IMODEL=IDMODE(IDEV)
      IMODE2=IDMOD2(IDEV)
      IMODE3=IDMOD3(IDEV)
      IGCODE=IDCODE(IDEV)
      IGUNIT=IDUNIT(IDEV)
C
CCCCC FEBRUARY 2006: DEVICE 1 LATEX TO CAPTURE FILE
C
C     APRIL 2006: COMMENT OUT THIS SECTION FOR NOW, HANDLED
C                 ELSEWHERE (IMACNU NOT PASSED TO THIS ROUTINE)
C
CCCCC IF(IDEV.EQ.1 .AND. IMANUF.EQ.'LATE' .AND.
CCCCC1   IGUNIT.EQ.IMACNU)THEN
CCCCC   IGUNIT=IMACNU
CCCCC ENDIF
C
      NUMHPP=IDNHPP(IDEV)
      ANUMHP=NUMHPP
      NUMVPP=IDNVPP(IDEV)
      ANUMVP=NUMVPP
CCCCC THE FOLLOWING 2 LINES WERE INSERTED AUGUST 1992. (ALAN)
      IOFFSV=IDNVOF(IDEV)
      IOFFSH=IDNHOF(IDEV)
      IGCOLO=IDCOLO(IDEV)
      IGBAUD=IDBAUD(IDEV)
      ISOFT=IDSOFT(IDEV)
      ISOFT2=IDSOF2(IDEV)
      ISOFT3=IDSOF3(IDEV)
CCCCC THE FOLLOWING LINE WAS INSERTED JULY 1996. (ALAN)
      IGFONT=IDFONT(IDEV)
C
      IF(ICONT.EQ.'OFF')GOTO2100
C
CCCCC THE FOLLOWING LINE WAS INSERTED AUGUST 1992. (ALAN)
CCCCC IF HAVE   DEVICE 2 OFF    COMMAND,
CCCCC DO NOT SET DEFAULT DEVICE.
CCCCC SET POWER OFF, WHEN POWER OFF DON'T DO PLOT.  DEVICE 2 ON  ???
CCCCC WILL TURN ON WHATEVER CURRENT DEVICE IS.
CCCCC THIS ALLOWS PLOT FILE TO BE TOGGLED ON AND OFF CONVIENTLY.
      IF(IPOWER.EQ.'OFF')GOTO2100
      IF(ISQUAR.EQ.'ON')GOTO2110
      IF(ICASPL.EQ.'PIEC')GOTO2110
      GOTO2190
 2110 CONTINUE
      PSAVE=PXMAX
      PYDEL=PYMAX-PYMIN
      PXDEL=PYDEL*(ANUMVP/ANUMHP)
      PXMAX=PXMIN+PXDEL
 2190 CONTINUE
C
C               ***************************************************
C               **  STEP 31--                                    **
C               **  CARRY OUT OPENING OPERATIONS                 **
C               **  ON THE DEVICES AND ON THE GRAPHICS SOFTWARE  **
C               ***************************************************
C
      IF(IOPGRS.EQ.'ON')
     1CALL DPOPDE
C
C               ****************************************************************
C               **  STEP 32--
C               **  CARRY OUT MINOR PRE-PLOT ACTIVITIES--
C               **  ERASE THE SCREEN, FILL  THE BACKGROUND, RING THE BELL, ETC.
C               ****************************************************************
C
      IF(IOPG2S.EQ.'ON')
     1CALL DPOPPL(IGRASW,
     1IBELSW,NUMRIN,IERASW,
     1IBACCO)
CCCCC FOLLOWING LINES ADDED MARCH, 1990 FOR X11.  X11 LIBRARY CAN
CCCCC DYNAMICALLY MODIFY THE PICTURE POINTS.  THE ERASE SCREEN ROUTINE
CCCCC GETS THE UPDATED VALUES.
      IF(IMANUF.EQ.'X11')THEN
        NUMVPP=ANUMVP+0.5
        NUMHPP=ANUMHP+0.5
        IDNVPP(IDEV)=NUMVPP
        IDNHPP(IDEV)=NUMHPP
      ENDIF
CCCCC END CHANGES
CCCCC FOLLOWING LINES ADDED OCTOBER, 1996 FOR QWIN.  QWIN LIBRARY CAN
CCCCC DYNAMICALLY MODIFY THE PICTURE POINTS.  THE ERASE SCREEN ROUTINE
CCCCC GETS THE UPDATED VALUES.
      IF(IMANUF.EQ.'QWIN')THEN
        NUMVPP=ANUMVP+0.5
        NUMHPP=ANUMHP+0.5
        IDNVPP(IDEV)=NUMVPP
        IDNHPP(IDEV)=NUMHPP
      ENDIF
CCCCC END CHANGES
C
C               ************************************************
C               **  STEP 33--                                 **
C               **  IF HAVE NO POINTS BEING PLOTTED           **
C               **  (AND THEREFORE ONLY INTERESTED IN SEEING  **
C               **  THE TITLES, LABELS, LEGENDS, ETC.)        **
C               **  THEN SKIP DOWN TO THOSE SECTIONS.         **
C               ************************************************
C
      IF(NP.LE.0)GOTO5700
C
C               **************************************************
C               **  STEP 34--                                   **
C               **  FOR 3-D PLOTS,                              **
C               **  FOR THE FIRST TIME THROUGH,                 **
C               **  COMPUTE MIN'S, MAX'S, MID'S, AND RANGES.    **
C               **  COMPUTE EYE COORDINATES AND ORIGINS.        **
C               **************************************************
C
      IF(IDELIS.EQ.'ON')GOTO3400
      GOTO3790
C
 3400 CONTINUE
      XEYE0=AEYEXC
      YEYE0=AEYEYC
      ZEYE0=AEYEZC
C
      XORIG=AORIXC
      YORIG=AORIYC
      ZORIG=AORIZC
C
      CALL D3DELI(XRAW,YRAW,ZRAW,NP,
     1XEYE0,YEYE0,ZEYE0,
     1XORIG,YORIG,ZORIG,
     1X3DMIN,Y3DMIN,Z3DMIN,
     1X3DMAX,Y3DMAX,Z3DMAX,
     1X3DMID,Y3DMID,Z3DMID,
     1X3DRAN,Y3DRAN,Z3DRAN,
     1X3DEYE,Y3DEYE,Z3DEYE,
     1X3DORI,Y3DORI,Z3DORI,
     1XPRIME,YPRIME,ZPRIME,
     1IBUGG4,ISUBG4,IERRG4)
C
C               **************************************************
C               **  STEP 35--                                   **
C               **  FOR 3-D PLOTS,                              **
C               **  COMPUTE DIRECTION NUMBERS AND DIRECTION COSI**NES
C               **  (THESE ARE NEEDED FOR ROTATION FROM 3-D TO **2-D)
C               **************************************************
C
      CALL D3DEDC(XRAW,YRAW,ZRAW,NP,
     1X3DEYE,Y3DEYE,Z3DEYE,
     1D3DCXX,D3DCXY,D3DCXZ,
     1D3DCYX,D3DCYY,D3DCYZ,
     1D3DCZX,D3DCZY,D3DCZZ,
     1TERMXX,TERMXY,TERMXZ,
     1TERMYX,TERMYY,TERMYZ,
     1TERMZX,TERMZY,TERMZZ,
     1IBUGG4,ISUBG4,IERRG4)
C
C               ********************************************
C               **  STEP 36--                             **
C               **  DETERMINE DATA LIMITS, FRAME LIMITS,  **
C               **  AND TIC COORDINATES.                  **
C               ********************************************
C
      CALL D3TR32(XRAW,YRAW,ZRAW,NP,XT,ZT,NT)
CCCCC NPRIME=12
CCCCC CALL D3TR32(XPRIME,YPRIME,ZPRIME,NPRIME,XT,YT)
C
      CALL DPDELI(ZT,XT,PX,NT,NUMSET,
     1ICASPL,ICAS3D,
     1XDELMN)
      IF(IERRG4.EQ.'YES')GOTO9000
C
C               **************************************************
C               **  STEP 37--                                   **
C               **  FOR 3-D PLOTS,                              **
C               **  DETERMINE MINIMUM DISTANCE BETWEEN POINTS   **
C               **  (NEEDED FOR BAR PLOTS)                      **
C               **************************************************
C
      CALL D3DEMD(XRAW,YRAW,ZRAW,PX3,NP,
     1XDELMN,YDELMN,ZDELMN)
C
 3790 CONTINUE
C
C               *********************************************
C               **  STEP 41--                              **
C               **  DRAW A DATA-DEFINED GENERALIZED TRACE. **
C               **  THE TRACE MAY CONSIST OF ANY OR ALL    **
C               **  OF THE FOLLOWING--                     **
C               **     1. CHARACTERS                       **
C               **     2. LINES                            **
C               **     3. BARS                             **
C               **     4. SPIKES                           **
C               *********************************************
C
      IF(IDRTRS.EQ.'ON')GOTO4100
      GOTO4190
C
 4100 CONTINUE
C
CCCCC IF(IFI2SW.EQ.'ON')
CCCCC1CALL DPFIRS(ZT,XT,PY,PX,NP,
CCCCC1ICASPL,ICAS3D,
CCCCC1ISORSW,
CCCCC1IFI2PA,IFI2CO,PFI2SP,PFI2TH,
CCCCC1PXMIN,PXMAX,PYMIN,PYMAX,
CCCCC1FX1MIN,FX1MAX,FY1MIN,FY1MAX,
CCCCC1IX1TSC,IY1TSC)
C
CCCCC IF(IPA2SW.EQ.'ON')
CCCCC1CALL DPDRPS(ZT,XT,PY,PX,NP,
CCCCC1ICASPL,ICAS3D,
CCCCC1ISORSW,
CCCCC1IPA2PA,IPA2LI,IPA2CO,PPA2HE,PPA2WI,PPATSP,PPA2TH,
CCCCC1PXMIN,PXMAX,PYMIN,PYMAX,
CCCCC1FX1MIN,FX1MAX,FY1MIN,FY1MAX,
CCCCC1IX1TSC,IY1TSC)
C
      IF(ICASPL.EQ.'HIST')GOTO4119
      IF(ICASPL.EQ.'CUMH')GOTO4119
      IF(ICASPL.EQ.'BARP')GOTO4119
      IF(ICASPL.EQ.'ROOT')GOTO4119
      IF(ICASPL.EQ.'CUMR')GOTO4119
      IF(ICASPL.EQ.'BIHI')GOTO4119
C
      ICH2SW='ON'
      IF(ICH2PA.EQ.'OFF')ICH2SW='OFF'
      IF(ICH2PA.EQ.'BLAN')ICH2SW='OFF'
      IF(ICH2PA.EQ.'BL')ICH2SW='OFF'
      IF(ICH2PA.EQ.'    ')ICH2SW='OFF'
      IF(ICH2PA.EQ.'NONE')ICH2SW='OFF'
      IF(ICH2PA.EQ.'NO')ICH2SW='OFF'
      IF(ICH2SW.EQ.'ON')
     1CALL D3DRCH(XRAW,YRAW,ZRAW,PX,PY,PZ,NP,PY2,PX2,NP2,DSIZE,
     1ICASPL,ICAS3D,
     1ISORSW,
     1ICH2PA,ICH2FO,ICH2CA,ICH2JU,ICH2DI,ACH2AN,ICH2FI,ICH2CO,
     1PCH2HE,PCH2WI,PCH2TH,PCH2HO,PCH2VO,
     1ITEXSP,
     1PXMIN,PXMAX,PYMIN,PYMAX,
     1FX1MIN,FX1MAX,FY1MIN,FY1MAX,
     1IX1TSC,IY1TSC,
     1IMPSW2,AMPSCH,AMPSCW)
C
      ILI2SW='ON'
      IF(ILI2PA.EQ.'OFF')ILI2SW='OFF'
      IF(ILI2PA.EQ.'BLAN')ILI2SW='OFF'
      IF(ILI2PA.EQ.'BL')ILI2SW='OFF'
      IF(ILI2PA.EQ.'    ')ILI2SW='OFF'
      IF(ILI2PA.EQ.'NONE')ILI2SW='OFF'
      IF(ILI2PA.EQ.'NO')ILI2SW='OFF'
      IF(ILI2SW.EQ.'ON')
     1CALL D3DRTR(XRAW,YRAW,ZRAW,PX,PY,PZ,NP,PY2,PX2,NP2,
     1PY3,PX3,NP3,
     1ICASPL,ICAS3D,
     1ISORSW,
     1ILI2PA,ILI2CO,PLI2TH,
     1ARE2BA,
     1IRE2FS,IRE2FC,
     1IRE2PT,IRE2PL,IRE2PC,PRE2PT,PRE2PS,
     1PXMIN,PXMAX,PYMIN,PYMAX,
     1FX1MIN,FX1MAX,FY1MIN,FY1MAX,
     1IX1TSC,IY1TSC)
 4119 CONTINUE
C
      IF(IBA2SW.EQ.'ON'.OR.
     1ICASPL.EQ.'HIST'.OR.
     1ICASPL.EQ.'CUMH'.OR.
     1ICASPL.EQ.'BARP'.OR.
     1ICASPL.EQ.'ROOT'.OR.
     1ICASPL.EQ.'CUMR'.OR.
     1ICASPL.EQ.'BIHI')
     1CALL D3DRBA(XRAW,YRAW,ZRAW,NP,
     1PX,PY,PZ,PX2,PY2,PZ2,PX3,PY3,
     1ICASPL,ICAS3D,
     1ISORSW,
     1IBA2SW,ABA2WI,ABA2BA,
     1IBA2BL,IBA2BC,PBA2BT,
     1IBA2FS,IBA2FC,
     1IBA2PT,IBA2PL,IBA2PC,IBA2TY,IBA2DI,PBA2PS,PBA2PT,
     1XDELMN,YDELMN,ZDELMN,
     1PXMIN,PXMAX,PYMIN,PYMAX,
     1FX1MIN,FX1MAX,FY1MIN,FY1MAX,
     1IX1TSC,IY1TSC)
C
      IF(ISP2SW.EQ.'ON')
     1CALL D3DRSP(XRAW,YRAW,ZRAW,NP,
     1PX,PY,PZ,PX2,PY2,PZ2,PX3,PY3,
     1ICASPL,ICAS3D,
     1ISORSW,
     1ISP2LI,ISP2CO,ISP2DI,PSP2TH,ASP2BA,
     1PXMIN,PXMAX,PYMIN,PYMAX,
     1FX1MIN,FX1MAX,FY1MIN,FY1MAX,
     1IX1TSC,IY1TSC)
C
 4190 CONTINUE
C
C               **************************************************
C               **   STEP 51--                                  **
C               **   DRAW THE BASEPLANE AND BACKPLANE           **
C               **************************************************
C
C               **************************************************
C               **  STEP 52--                                   **
C               **  DRAW THE PEDESTAL                           **
C               **************************************************
C
C               ********************************************************
C               **  STEP 56--                                         **
C               **  DRAW THE FRAME, TICS, TIC LABELS, AND GRID LINES  **
C               ********************************************************
C
      IF(IDRFRS.EQ.'ON')
CCCCC THE FOLLOWING LINE WAS CHANGED   SEPTEMBER 1993
CCCCC SO AS TO ALLOW 3-D FRAMES        SEPTEMBER 1993
CCCCC1CALL DPDRFR(ICASPL,ICAS3D,
     1CALL D3DRFR(ICASPL,ICAS3D,FRAM3D,
     1X3DMIN,X3DMAX,Y3DMIN,Y3DMAX,Z3DMIN,Z3DMAX,
     1IVGMSW,IHGMSW)
      IF(IERRG4.EQ.'YES')GOTO9000
C
C               *********************************
C               **  STEP 57--                  **
C               **  DRAW THE LABELS AND TITLE  **
C               *********************************
C
 5700 CONTINUE
C
CCCCC IF(IWRLAS.EQ.'ON')CALL DPWRLA(PXMIN,PYMIN,PXMAX,PYMAX,   DEC. 1986
      IF(IWRLAS.EQ.'ON')GOTO5710
      GOTO5790
C
 5710 CONTINUE
      ITITCV(1)=ITITFO
      ITITCV(2)=ITITCA
      ITITCV(3)=ITITFI
      ITITCV(4)=ITITCO
      PTITRV(1)=PTITHE
      PTITRV(2)=PTITWI
      PTITRV(3)=PTITVG
      PTITRV(4)=PTITHG
      PTITRV(5)=PTITTH
      PTITRV(6)=PTITDS
C
      IX1LCV(1)=IX1LFO
      IX1LCV(2)=IX1LCA
      IX1LCV(3)=IX1LFI
      IX1LCV(4)=IX1LCO
      IX1LCV(5)=IX1LJU
      IX1LCV(6)=IX1LDI
      PX1LRV(1)=PX1LHE
      PX1LRV(2)=PX1LWI
      PX1LRV(3)=PX1LVG
      PX1LRV(4)=PX1LHG
      PX1LRV(5)=PX1LTH
      PX1LRV(6)=PX1LDS
      PX1LRV(7)=PX1LOF
      PX1LRV(8)=PX1LAN
C
      IX2LCV(1)=IX2LFO
      IX2LCV(2)=IX2LCA
      IX2LCV(3)=IX2LFI
      IX2LCV(4)=IX2LCO
      IX2LCV(5)=IX2LJU
      IX2LCV(6)=IX2LDI
      PX2LRV(1)=PX2LHE
      PX2LRV(2)=PX2LWI
      PX2LRV(3)=PX2LVG
      PX2LRV(4)=PX2LHG
      PX2LRV(5)=PX2LTH
      PX2LRV(6)=PX2LDS
      PX2LRV(7)=PX2LOF
      PX2LRV(8)=PX2LAN
C
      IX3LCV(1)=IX3LFO
      IX3LCV(2)=IX3LCA
      IX3LCV(3)=IX3LFI
      IX3LCV(4)=IX3LCO
      IX3LCV(5)=IX3LJU
      IX3LCV(6)=IX3LDI
      PX3LRV(1)=PX3LHE
      PX3LRV(2)=PX3LWI
      PX3LRV(3)=PX3LVG
      PX3LRV(4)=PX3LHG
      PX3LRV(5)=PX3LTH
      PX3LRV(6)=PX3LDS
      PX3LRV(7)=PX3LOF
      PX3LRV(8)=PX3LAN
C
      IY1LCV(1)=IY1LFO
      IY1LCV(2)=IY1LCA
      IY1LCV(3)=IY1LFI
      IY1LCV(4)=IY1LCO
      IY1LCV(5)=IY1LJU
      IY1LCV(6)=IY1LDI
      PY1LRV(1)=PY1LHE
      PY1LRV(2)=PY1LWI
      PY1LRV(3)=PY1LVG
      PY1LRV(4)=PY1LHG
      PY1LRV(5)=PY1LTH
      PY1LRV(6)=PY1LDS
      PY1LRV(7)=PY1LOF
      PY1LRV(8)=PY1LAN
C
      IY2LCV(1)=IY2LFO
      IY2LCV(2)=IY2LCA
      IY2LCV(3)=IY2LFI
      IY2LCV(4)=IY2LCO
      IY2LCV(5)=IY2LJU
      IY2LCV(6)=IY2LDI
      PY2LRV(1)=PY2LHE
      PY2LRV(2)=PY2LWI
      PY2LRV(3)=PY2LVG
      PY2LRV(4)=PY2LHG
      PY2LRV(5)=PY2LTH
      PY2LRV(6)=PY2LDS
      PY2LRV(7)=PY2LOF
      PY2LRV(8)=PY2LAN
C
      CALL DPWRLA(PXMIN,PYMIN,PXMAX,PYMAX,
     1ITITTE,NCTITL,ITITCV,PTITRV,
     1IX1LTE,NCX1LA,IX1LCV,PX1LRV,
     1IX2LTE,NCX2LA,IX2LCV,PX2LRV,
     1IX3LTE,NCX3LA,IX3LCV,PX3LRV,
     1IY1LTE,NCY1LA,IY1LCV,PY1LRV,
     1IY2LTE,NCY2LA,IY2LCV,PY2LRV,
     1ISYMBL,ISPAC,
     1IMPSW2,AMPSCH,AMPSCW,
     1IHNAME,IHNAM2,IUSE,IVALUE,VALUE,NUMNAM,
     1IVSTAR,IVSTOP,IFUNC,NUMCHF,IREPCH,ISEQSW,NUMSEQ)
C
 5790 CONTINUE
C
C               ***********************************************************
C               **  STEP 58--                                            **
C               **  DRAW THE LEGENDS, LEGEND BOXES, SEGMENTS AND ARROWS  **
C               ***********************************************************
C
CCCCC AUGUST 1995.  ADD ILGENA TO LIST
      IF(IWRLES.EQ.'ON')
     1CALL DPWRLE(ILEGTE,ILEGST,ILEGSP,ILEGNA,
     1PLEGXC,PLEGYC,
     1ILEGFO,ILEGCA,ILEGJU,ILEGDI,ALEGAN,ILEGFI,ILEGCO,ILEGUN,
     1PLEGHE,PLEGWI,PLEGVG,PLEGHG,PLEGTH,NUMLEG,
     1PBOXXC,PBOXYC,
     1IBOBCO,
CCCCC AUGUST 1992.  FOLLOWING LINE MODIFIED AUGUST 1992
CCCCC1IBOPPA,IBOPCO,
     1IBOPPA,IBOBPA,
     1PBOPTH,PBOPGA,
     1IBOFPA,IBOFCO,
CCCCC THE FOLLOWING LINE WAS AUGMENTED FOR BOX SHADOW  AUGUST 1992
CCCCC1PBOFTH,NUMBOX,
     1PBOFTH,PBOSHE,PBOSWI,NUMBOX,
     1PARRXC,PARRYC,
     1IARRPA,IARRCO,
     1PARRTH,
     1PARHLE,PARHWI,NUMARR,
     1PSEGXC,PSEGYC,
     1ISEGPA,ISEGCO,
     1PSEGTH,NUMSEG,
     1IMPSW2,AMPSCH,AMPSCW,
     1IHNAME,IHNAM2,IUSE,IVALUE,VALUE,NUMNAM,
     1IVSTAR,IVSTOP,IFUNC,NUMCHF,IREPCH,ISYMBL,ISPAC)
C
C               ****************************************************************
C               **  STEP 61--                                                 **
C               **  CARRY OUT POST-PLOT OPERATIONS--                          **
C               **  COPYING THE SCREEN, MOVING CURSOR TO HOME POSITION, ETC.  **
C               ****************************************************************
C
      IF(ICLG2S.EQ.'ON')
     1CALL DPCLPL(ICOPSW,NUMCOP,
     1PGRAXF,PGRAYF,
     1IGRASW,PDIAXC,PDIAYC,PDIAX2,PDIAY2,
     1PDIAHE,PDIAWI,PDIAVG,PDIAHG)
C
C               ***************************************************
C               **  STEP 62--                                    **
C               **  CARRY OUT CLOSING OPERATIONS                 **
C               **  ON THE DEVICES AND ON THE GRAPHICS SOFTWARE  **
C               ***************************************************
C
      IF(ICLGRS.EQ.'ON')
     1CALL DPCLDE
C
      IF(ISQUAR.EQ.'ON')GOTO6210
      IF(ICASPL.EQ.'PIEC')GOTO6210
      GOTO6290
C
 6210 CONTINUE
      PXMAX=PSAVE
C
 6290 CONTINUE
C
 2100 CONTINUE
      IF(IWRLAS.EQ.'ON'.AND.ISEQSW.EQ.'ON')NUMSEQ=NUMSEQ+1
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'OTG3')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF PLOTG3--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IMANUF,IMODEL
 9012 FORMAT('IMANUF,IMODEL = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9015)IBUGG4,ISUBG4,IERRG4
 9015 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9017)NUMSET
 9017 FORMAT('NUMSET = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9018)ICASPL,ICAS3D,I3DPRO
 9018 FORMAT('ICASPL,ICAS3D,I3DPRO = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9019)ISQUAR,XDELMN
 9019 FORMAT('ISQUAR,XDELMN = ',A4,2X,E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9021)ILI2PA,ILI2SW
 9021 FORMAT('ILI2PA,ILI2SW = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9022)ICH2PA,ICH2SW
 9022 FORMAT('ICH2PA,ICH2SW = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9031)IBA2SW,ABA2WI,ABA2BA
 9031 FORMAT('IBA2SW,ABA2WI,ABA2BA = ',A4,2X,2E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9032)IBA2BL,IBA2BC,PBA2BT
 9032 FORMAT('IBA2BL,IBA2BC,PBA2BT = ',A4,2X,A4,2X,E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9033)IBA2FS,IBA2FC
 9033 FORMAT('IBA2FS,IBA2FC = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9034)IBA2PT,IBA2PL,IBA2PC,IBA2TY,PBA2PS,PBA2PT
 9034 FORMAT('IBA2PT,IBA2PL,IBA2PC,IBA2TY,PBA2PS,PBA2PT = ',
     1A4,2X,A4,2X,A4,2X,A4,2X,2E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9035)ITEXSY,ITEXSP
 9035 FORMAT('ITEXSY,ITEXSP = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9036)ISYMBL,ISPAC
 9036 FORMAT('ISYMBL,ISPAC = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9041)IREPCH
 9041 FORMAT('IREPCH = ',A1)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE PLOTN(Y,X,N,ICHAR,MAXCHA,ICASPL,ICAS3D,
     1ITITTE,NCTITL,
     1IX1LTE,NCX1LA,
     1IX2LTE,NCX2LA,
     1IX3LTE,NCX3LA,
     1IY1LTE,NCY1LA,
     1IY2LTE,NCY2LA,
     1GX1MIN,GX1MAX,GY1MIN,GY1MAX,
     1IERASW,IBUGU2,IERROR)
C
C     PURPOSE--THIS SUBROUTINE YIELDS A NARROW-WIDTH (68-CHARACTER)
C              PLOT OF Y(I) VERSUS X(I).
C     NOTE--THE NARROW WIDTH OF THIS PLOT
C           MAKES IT APPROPRIATE FOR
C           USE ON A (DISCRETE) TERMINAL.
C     INPUT ARGUMENTS--Y      = THE SINGLE PRECISION VECTOR OF
C                               (UNSORTED OR SORTED) OBSERVATIONS
C                               TO BE PLOTTED VERTICALLY.
C                    --X      = THE SINGLE PRECISION VECTOR OF
C                               (UNSORTED OR SORTED) OBSERVATIONS
C                               TO BE PLOTTED HORIZONTALLY.
C                    --N      = THE INTEGER NUMBER OF OBSERVATIONS
C                               IN THE VECTOR X.
C                    --ICHAR  = THE HOLLERITH VECTOR OF
C                               CHARACTERS (ONLY THE
C                               FIRST OF WHICH WILL BE USED)
C                    --MAXCHA = THE INTEGER NUMBER OF
C                               CHARACTERS IN ICHAR(.)
C     OUTPUT--A NARROW-WIDTH (68-CHARACTER) TERMINAL PLOT
C             OF Y(I) VERSUS I.
C             THE BODY OF THE PLOT (NOT COUNTING AXIS VALUES
C             AND MARGINS) IS 17 ROWS (LINES) AND 41 COLUMNS.
C     PRINTING--YES.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     COMMENT--NOTE THAT THE STORAGE REQUIREMENTS FOR THIS
C              (AND THE OTHER) TERMINAL PLOT SUBROUTINESS ARE .
C              VERY SMALL.
C              THIS IS DUE TO THE 'ONE LINE AT A TIME' ALGORITHM
C              EMPLOYED FOR THE PLOT.
C     REFERENCES--NONE.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--82.6
C     ORIGINAL VERSION--FEBRUARY  1974.
C     UPDATED         --APRIL     1974.
C     UPDATED         --OCTOBER   1974.
C     UPDATED         --OCTOBER   1975.
C     UPDATED         --NOVEMBER  1975.
C     UPDATED         --FEBRUARY  1977.
C     UPDATED         --JUNE      1978.
C     UPDATED         --NOVEMBER  1981.
C     UPDATED         --DECEMBER  1981.
C     UPDATED         --JANUARY   1982.
C     UPDATED         --MAY       1982.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 ICHAR
      CHARACTER*4 ICASPL
      CHARACTER*4 ICAS3D
C
      CHARACTER*4 ITITTE
      CHARACTER*4 IX1LTE
      CHARACTER*4 IX2LTE
      CHARACTER*4 IX3LTE
      CHARACTER*4 IY1LTE
      CHARACTER*4 IY2LTE
C
      CHARACTER*4 IERASW
      CHARACTER*4 IBUGU2
      CHARACTER*4 IERROR
C
      CHARACTER*4 IBLANK
      CHARACTER*4 IHYPHE
      CHARACTER*4 IALPHI
      CHARACTER*4 IALPHX
      CHARACTER*4 ILABT
      CHARACTER*4 ILABY1
      CHARACTER*4 ILABX1
      CHARACTER*4 ILABX2
      CHARACTER*4 ILABX3
      CHARACTER*4 JPLOTC
      CHARACTER*4 ILINE
      CHARACTER*4 ICASP2
      CHARACTER*4 IAXISC
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DIMENSION Y(*)
      DIMENSION X(*)
      DIMENSION ICHAR(*)
C
      DIMENSION ITITTE(*)
      DIMENSION IX1LTE(*)
      DIMENSION IX2LTE(*)
      DIMENSION IX3LTE(*)
      DIMENSION IY1LTE(*)
      DIMENSION IY2LTE(*)
C
      DIMENSION ILABT(132)
      DIMENSION ILABY1(132)
      DIMENSION ILABX1(132)
      DIMENSION ILABX2(132)
      DIMENSION ILABX3(132)
C
      DIMENSION ILINE(72)
      DIMENSION AILABL(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
      ISUBN1='PLOT'
      ISUBN2='N   '
C
      IBLANK=' '
      IHYPHE='-'
      IALPHI='I'
      IALPHX='X'
C
      IMAXT=0
      IMAXX1=0
      IMAXX2=0
      IMAXX3=0
C
      IF(IBUGU2.EQ.'OFF')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('AT THE BEGINNING OF PLOTN--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)N,IBUGU2
   52 FORMAT('N,IBUGU2 = ',I8,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)Y(1),X(1)
   53 FORMAT('Y(1),X(1) = ',2E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,54)Y(N),X(N)
   54 FORMAT('Y(N),X(N) = ',2E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,55)ICASPL,ICAS3D
   55 FORMAT('ICASPL,ICAS3D = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,72)CPUMIN,CPUMAX
   72 FORMAT('CPUMIN,CPUMAX = ',2E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,73)GX1MIN,GX1MAX,GY1MIN,GY1MAX
   73 FORMAT('GX1MIN,GX1MAX,GY1MIN,GY1MAX = ',4E15.7)
      CALL DPWRST('XXX','BUG ')
   90 CONTINUE
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
C               ***************************************************************
C               **  STEP 2--                                                 **
C               **  DEFINE THE NUMBER OF ROWS AND COLUMNS WITHIN THE PLOT--  **
C               **  THIS HAS BEEN SET TO 21 ROWS AND 41 COLUMNS.             **
C               ***************************************************************
C
CCCCC NUMROW=21
      NUMROW=17
      NUMCOL=41
C
      ANUMR=NUMROW
      ANUMRM=NUMROW-1
      ANUMCM=NUMCOL-1
 
      NUMR25=(NUMROW/4)+1
      NUMR50=(NUMROW/2)+1
      NUMR75=3*(NUMROW/4)+1
      IXDEL=(NUMCOL-1)/4
C
C               ********************************
C               **  STEP 2.2--                **
C               **  DEFINE THE TYPE OF PLOT.  **
C               ********************************
C
      ICASP2=ICASPL
      IF(ICASPL.EQ.'MDBP')ICASP2='BOXP'
      IF(ICASPL.EQ.'MEBP')ICASP2='BOXP'
      IF(ICASPL.EQ.'VIPL')ICASP2='BOXP'
      IF(ICASPL.EQ.'MDIP')ICASP2='IPLO'
      IF(ICASPL.EQ.'MEIP')ICASP2='IPLO'
      IF(ICASPL.EQ.'MRIP')ICASP2='IPLO'
      IF(ICASPL.EQ.'MMIP')ICASP2='IPLO'
C
C               ******************************************************
C               **  STEP 3--                                        **
C               **  PREPARE THE TITLE LINE, THE Y-AXIS LABEL,       **
C               **  AND THE 3 HORIZONTAL AXIS LABELS FOR PRINTING.  **
C               ******************************************************
C
      YMIDL=NUMROW/2
      XMIDL=22+NUMCOL/2
C
      YFACT=1.0
      XFACT=1.0
C
      ILENT=NCTITL
      ILENY1=NCY1LA
      ILENX1=NCX1LA
      ILENX2=NCX2LA
      ILENX3=NCX3LA
C
      ALENT=ILENT
      ALENY1=ILENY1
      ALENX1=ILENX1
      ALENX2=ILENX2
      ALENX3=ILENX3
C
      IX=XMIDL-XFACT*(ALENT/2.0)
      DO310I=1,132
      ILABT(I)=' '
  310 CONTINUE
      J=IX-1
      IF(ILENT.LE.0)GOTO319
      DO315I=1,ILENT
      J=J+1
      ILABT(J)=ITITTE(I)
  315 CONTINUE
      IMAXT=J
  319 CONTINUE
C
      IY=YMIDL-YFACT*(ALENY1/2.0)
      DO320I=1,132
      ILABY1(I)=' '
  320 CONTINUE
      J=IY-1
      IF(ILENY1.LE.0)GOTO329
      WRITE(6,777)I,J,ILENY1,IY,YMIDL,YFACT,ALENY1
  777 FORMAT('I,J,ILENY1,IY,YMIDL,YFACT,ALENY1 = ',4I8,3E15.7)
      DO325I=1,ILENY1
      J=J+1
      ILABY1(J)=IY1LTE(I)
  325 CONTINUE
      IMAXY1=J
  329 CONTINUE
C
      IX=XMIDL-XFACT*(ALENX1/2.0)
      DO330I=1,132
      ILABX1(I)=' '
  330 CONTINUE
      J=IX-1
      IF(ILENX1.LE.0)GOTO339
      DO335I=1,ILENX1
      J=J+1
      ILABX1(J)=IX1LTE(I)
  335 CONTINUE
      IMAXX1=J
  339 CONTINUE
C
      IX=XMIDL-XFACT*(ALENX2/2.0)
      DO340I=1,132
      ILABX2(I)=' '
  340 CONTINUE
      J=IX-1
      IF(ILENX2.LE.0)GOTO349
      DO345I=1,ILENX2
      J=J+1
      ILABX2(J)=IX2LTE(I)
  345 CONTINUE
      IMAXX2=J
  349 CONTINUE
C
      IX=XMIDL-XFACT*(ALENX3/2.0)
      DO350I=1,132
      ILABX3(I)=' '
  350 CONTINUE
      J=IX-1
      IF(ILENX3.LE.0)GOTO359
      DO355I=1,ILENX3
      J=J+1
      ILABX3(J)=IX3LTE(I)
  355 CONTINUE
      IMAXX3=J
  359 CONTINUE
C
C               ****************************************************************
C               **  STEP 4--
C               **  SKIP TO NEW PAGE;
C               **  WRITE OUT THE TITLE (IF ANY);
C               **  WRITE OUT THE TOP HORIZONTAL AXIS OF THE PLOT;
C               ****************************************************************
C
      IF(IERASW.EQ.'ON')WRITE(ICOUT,504)
  504 FORMAT(1H1)
      IF(IERASW.EQ.'ON')CALL DPWRST('XXX','BUG ')
      IF(IERASW.EQ.'OFF')WRITE(ICOUT,999)
      IF(IERASW.EQ.'OFF')CALL DPWRST('XXX','BUG ')
      IF(IMAXT.GE.1)WRITE(ICOUT,505)(ILABT(I),I=1,IMAXT)
  505 FORMAT(240A1)
      IF(IMAXT.GE.1)CALL DPWRST('XXX','BUG ')
C
      DO500ICOL=1,NUMCOL
      ILINE(ICOL)=IHYPHE
  500 CONTINUE
      DO550ICOL=1,NUMCOL,IXDEL
      ILINE(ICOL)=IALPHI
  550 CONTINUE
      WRITE(ICOUT,555)(ILINE(I),I=1,NUMCOL)
  555 FORMAT(20X,54A1)
      CALL DPWRST('XXX','BUG ')
C
C
C               *******************************************************
C               **  STEP 5--                                         **
C               **  DETERMINE THE MIN AND MAX VALUES OF Y AND OF X.  **
C               *******************************************************
C
      XMIN=X(1)
      XMAX=X(1)
      YMIN=Y(1)
      YMAX=Y(1)
      DO700I=1,N
      IF(X(I).LT.XMIN)XMIN=X(I)
      IF(X(I).GT.XMAX)XMAX=X(I)
      IF(Y(I).LT.YMIN)YMIN=Y(I)
      IF(Y(I).GT.YMAX)YMAX=Y(I)
  700 CONTINUE
      IF(GX1MIN.NE.CPUMIN)XMIN=GX1MIN
      IF(GX1MAX.NE.CPUMAX)XMAX=GX1MAX
      IF(GY1MIN.NE.CPUMIN)YMIN=GY1MIN
      IF(GY1MAX.NE.CPUMAX)YMAX=GY1MAX
      DELX=XMAX-XMIN
      DELY=YMAX-YMIN
      XWIDTH=DELX/ANUMCM
      YWIDTH=DELY/ANUMRM
C
C               ****************************************************************
C               **  STEP 6--
C               **  DETERMINE AND WRITE OUT THE PLOT POSITIONS ONE LINE AT A TIM
C               ****************************************************************
C
      DO1100IROW=1,NUMROW
C
      DO1200ICOL=1,NUMCOL
      ILINE(ICOL)=IBLANK
 1200 CONTINUE
C
      AIROW=IROW
      YUPPER=YMAX+(1.5-AIROW)*YWIDTH
      YLABEL=YMAX+(1.0-AIROW)*YWIDTH
      YLOWER=YMAX+(0.5-AIROW)*YWIDTH
      IF(IROW.EQ.NUMROW)YLABEL=YMIN
      DO1300I=1,N
      AI=I
      IF(YLOWER.LE.Y(I).AND.Y(I).LT.YUPPER)GOTO1350
      GOTO1300
 1350 CONTINUE
      ICOL=((X(I)-XMIN)/XWIDTH)+1.5
      IF(ICOL.LT.1.OR.ICOL.GT.NUMCOL)GOTO1300
      JPLOTC=ICHAR(1)
      IF(JPLOTC.EQ.'    ')JPLOTC='X'
      IF(JPLOTC.EQ.'BLAN')JPLOTC='X'
      IF(JPLOTC.EQ.'NONE')JPLOTC='X'
      ILINE(ICOL)=JPLOTC
 1300 CONTINUE
C
      ICOLMX=1
      DO1400ICOL=1,NUMCOL
      ICOLRV=NUMCOL-ICOL+1
      IF(ILINE(ICOLRV).EQ.' ')GOTO1400
      ICOLMX=ICOLRV
      GOTO1490
 1400 CONTINUE
 1490 CONTINUE
C
      IAXISC=IALPHI
      IF(IROW.EQ.1.OR.IROW.EQ.NUMROW)IAXISC=IHYPHE
      IF(IROW.EQ.NUMR25.OR.IROW.EQ.NUMR50.OR.IROW.EQ.NUMR75)
     1IAXISC=IHYPHE
      WRITE(ICOUT,1410)ILABY1(IROW),YLABEL,IAXISC,
     1(ILINE(ICOL),ICOL=1,ICOLMX)
 1410 FORMAT(A1,1X,E14.7,1X,A1,2X,50A1)
      CALL DPWRST('XXX','BUG ')
C
 1100 CONTINUE
C
C               ************************************************************
C               **  STEP 7--                                              **
C               **  WRITE OUT THE BOTTOM HORIZONTAL AXIS OF THE PLOT;     **
C               **  WRITE OUT THE X-AXIS NUMERIC LABELS;                  **
C               **  WRITE OUT THE FIRST  HORIZONTAL AXIS LABEL (IF ANY);  **
C               **  WRITE OUT THE SECOND HORIZONTAL AXIS LABEL (IF ANY);  **
C               **  WRITE OUT THE THIRD  HORIZONTAL AXIS LABEL (IF ANY).  **
C               ************************************************************
C
C
      DO2200ICOL=1,NUMCOL
      ILINE(ICOL)=IHYPHE
 2200 CONTINUE
      DO2300ICOL=1,NUMCOL,IXDEL
      ILINE(ICOL)=IALPHI
 2300 CONTINUE
      WRITE(ICOUT,2105)(ILINE(ICOL),ICOL=1,NUMCOL)
 2105 FORMAT(20X,54A1)
      CALL DPWRST('XXX','BUG ')
C
      NUMLAB=5
      ANUMLM=NUMLAB-1
      DO2500I=1,NUMLAB
      AIM1=I-1
      AILABL(I)=XMIN+(AIM1/ANUMLM)*DELX
 2500 CONTINUE
      WRITE(ICOUT,2310)(AILABL(I),I=1,NUMLAB)
 2310 FORMAT(13X,5E10.4)
      CALL DPWRST('XXX','BUG ')
C
      IF(IMAXX1.GE.1)WRITE(ICOUT,2311)(ILABX1(I),I=1,IMAXX1)
 2311 FORMAT(240A1)
      IF(IMAXX1.GE.1)CALL DPWRST('XXX','BUG ')
      IF(IMAXX2.GE.1)WRITE(ICOUT,2311)(ILABX2(I),I=1,IMAXX2)
      IF(IMAXX2.GE.1)CALL DPWRST('XXX','BUG ')
      IF(IMAXX3.GE.1)WRITE(ICOUT,2311)(ILABX3(I),I=1,IMAXX3)
      IF(IMAXX3.GE.1)CALL DPWRST('XXX','BUG ')
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE PLOTW(Y,X,N,ICHAR,MAXCHA,ICASPL,ICAS3D,
     1ITITTE,NCTITL,
     1IX1LTE,NCX1LA,
     1IX2LTE,NCX2LA,
     1IX3LTE,NCX3LA,
     1IY1LTE,NCY1LA,
     1IY2LTE,NCY2LA,
     1GX1MIN,GX1MAX,GY1MIN,GY1MAX,
     1IERASW,IBUGU2,IERROR)
C
C     PURPOSE--THIS SUBROUTINE YIELDS A WIDE-WIDTH (130-CHARACTER)
C              PLOT OF Y(I) VERSUS X(I).
C     NOTE--THE WIDE WIDTH OF THIS PLOT
C            MAKES IT APPROPRIATE FOR
C            USE ON A BATCH PRINTER.
C     INPUT ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF
C                               (UNSORTED OR SORTED) OBSERVATIONS
C                               TO BE PLOTTED VERTICALLY.
C                    --N      = THE INTEGER NUMBER OF OBSERVATIONS
C                               IN THE VECTOR X.
C                    --ICHAR  = THE HOLLERITH VECTOR OF
C                               CHARACTERS (ONLY THE
C                               FIRST OF WHICH WILL BE USED)
C                    --MAXCHA = THE INTEGER NUMBER OF
C                               CHARACTERS IN ICHAR(.)
C     OUTPUT--A WIDE-WIDTH (130-CHARACTER) TERMINAL PLOT
C             OF X(I) VERSUS I.
C             THE BODY OF THE PLOT (NOT COUNTING AXIS VALUES
C             AND MARGINS) IS 41 ROWS (LINES) AND 101 COLUMNS.
C     PRINTING--YES.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--NONE.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (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         --JULY      1975.
C     UPDATED         --SEPTEMBER 1975.
C     UPDATED         --OCTOBER   1975.
C     UPDATED         --NOVEMBER  1975.
C     UPDATED         --FEBRUARY  1976.
C     UPDATED         --FEBRUARY  1977.
C     UPDATED         --JUNE      1978.
C     UPDATED         --NOVEMBER  1981.
C     UPDATED         --DECEMBER  1981.
C     UPDATED         --JANUARY   1982.
C     UPDATED         --MAY       1982.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 ICHAR
C
      CHARACTER*4 ICASPL
      CHARACTER*4 ICAS3D
C
      CHARACTER*4 ITITTE
      CHARACTER*4 IX1LTE
      CHARACTER*4 IX2LTE
      CHARACTER*4 IX3LTE
      CHARACTER*4 IY1LTE
      CHARACTER*4 IY2LTE
C
      CHARACTER*4 IERASW
      CHARACTER*4 IBUGU2
      CHARACTER*4 IERROR
C
      CHARACTER*4 IBLANK
      CHARACTER*4 IHYPHE
      CHARACTER*4 IALPHI
      CHARACTER*4 IALPHX
      CHARACTER*4 IALPHM
      CHARACTER*4 IALPHA
      CHARACTER*4 IALPHN
      CHARACTER*4 IALPHD
      CHARACTER*4 IEQUAL
C
      CHARACTER*4 ILABT
      CHARACTER*4 ILABX1
      CHARACTER*4 ILABX2
      CHARACTER*4 ILABX3
      CHARACTER*4 ILABY1
      CHARACTER*4 JPLOTC
      CHARACTER*4 IGRAPH
      CHARACTER*4 ICASP2
C
C---------------------------------------------------------------------
C
      DIMENSION Y(*)
      DIMENSION X(*)
      DIMENSION ICHAR(*)
      DIMENSION IGRAPH(55,130)
C
      DIMENSION ITITTE(*)
      DIMENSION IX1LTE(*)
      DIMENSION IX2LTE(*)
      DIMENSION IX3LTE(*)
      DIMENSION IY1LTE(*)
      DIMENSION IY2LTE(*)
C
      DIMENSION ILABT(132)
      DIMENSION ILABY1(132)
      DIMENSION ILABX1(132)
      DIMENSION ILABX2(132)
      DIMENSION ILABX3(132)
C
      DIMENSION YLABEL(11)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      IBLANK=' '
      IHYPHE='-'
      IALPHI='I'
      IALPHX='X'
      IALPHM='M'
      IALPHA='A'
      IALPHX='X'
      IALPHN='N'
      IALPHD='D'
      IALPHN='N'
      IEQUAL='='
C
      IMAXT=0
      IMAXX1=0
      IMAXX2=0
      IMAXX3=0
C
      IF(IBUGU2.EQ.'OFF')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('AT THE BEGINNING OF PLOTW--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)N,IBUGU2
   52 FORMAT('N,IBUGU2 = ',I8,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)Y(1),X(1)
   53 FORMAT('Y(1),X(1) = ',2E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,54)Y(N),X(N)
   54 FORMAT('Y(N),X(N) = ',2E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,55)ICASPL,ICAS3D
   55 FORMAT('ICASPL,ICAS3D = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,61)NCTITL
   61 FORMAT('NCTITL = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,72)CPUMIN,CPUMAX
   72 FORMAT('CPUMIN,CPUMAX = ',2E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,73)GX1MIN,GX1MAX,GY1MIN,GY1MAX
   73 FORMAT('GX1MIN,GX1MAX,GY1MIN,GY1MAX = ',4E15.7)
      CALL DPWRST('XXX','BUG ')
   90 CONTINUE
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
C               ***************************************************************
C               **  STEP 2--                                                 **
C               **  DEFINE THE NUMBER OF ROWS AND COLUMNS WITHIN THE PLOT--  **
C               **  THIS HAS BEEN SET TO 41 ROWS AND  97 COLUMNS.            **
C               ***************************************************************
C
      NUMROW=41
      NUMCOL=97
C
      ANUMR=NUMROW
      ANUMRM=NUMROW-1
      ANUMCM=NUMCOL-1
 
      NUMR25=(NUMROW/4)+1
      NUMR50=(NUMROW/2)+1
      NUMR75=3*(NUMROW/4)+1
      IXDEL=(NUMCOL-1)/4
C
C               ***************************
C               **  STEP 2.1--           **
C               **  BLANK OUT THE GRAPH  **
C               ***************************
C
      DO280I=1,55
      DO290J=1,130
      IGRAPH(I,J)=IBLANK
  290 CONTINUE
  280 CONTINUE
C
C               ********************************
C               **  STEP 2.2--                **
C               **  DEFINE THE TYPE OF PLOT.  **
C               ********************************
C
      ICASP2=ICASPL
      IF(ICASPL.EQ.'MDBP')ICASP2='BOXP'
      IF(ICASPL.EQ.'MEBP')ICASP2='BOXP'
      IF(ICASPL.EQ.'VIPL')ICASP2='BOXP'
      IF(ICASPL.EQ.'MDIP')ICASP2='IPLO'
      IF(ICASPL.EQ.'MEIP')ICASP2='IPLO'
      IF(ICASPL.EQ.'MRIP')ICASP2='IPLO'
      IF(ICASPL.EQ.'MMIP')ICASP2='IPLO'
C
C               ******************************************************
C               **  STEP 3--                                        **
C               **  PREPARE THE TITLE LINE, THE Y-AXIS LABEL,       **
C               **  AND THE 3 HORIZONTAL AXIS LABELS FOR PRINTING.  **
C               ******************************************************
C
      YMIDL=(55/2)-4
      XMIDL=29+NUMCOL/2
C
      YFACT=1.0
      XFACT=1.0
C
      ILENT=NCTITL
      ILENY1=NCY1LA
      ILENX1=NCX1LA
      ILENX2=NCX2LA
      ILENX3=NCX3LA
C
      ALENT=ILENT
      ALENY1=ILENY1
      ALENX1=ILENX1
      ALENX2=ILENX2
      ALENX3=ILENX3
C
      IX=XMIDL-XFACT*(ALENT/2.0)
      DO310I=1,132
      ILABT(I)=' '
  310 CONTINUE
      J=IX-1
      IF(ILENT.LE.0)GOTO319
      DO315I=1,ILENT
      J=J+1
      ILABT(J)=ITITTE(I)
  315 CONTINUE
      IMAXT=J
  319 CONTINUE
C
      IY=YMIDL-YFACT*(ALENY1/2.0)
      DO320I=1,132
      ILABY1(I)=' '
  320 CONTINUE
      J=IY-1
      IF(ILENY1.LE.0)GOTO329
      DO325I=1,ILENY1
      J=J+1
      ILABY1(J)=IY1LTE(I)
  325 CONTINUE
      IMAXY1=J
  329 CONTINUE
C
      IX=XMIDL-XFACT*(ALENX1/2.0)
      DO330I=1,132
      ILABX1(I)=' '
  330 CONTINUE
      J=IX-1
      IF(ILENX1.LE.0)GOTO339
      DO335I=1,ILENX1
      J=J+1
      ILABX1(J)=IX1LTE(I)
  335 CONTINUE
      IMAXX1=J
  339 CONTINUE
C
      IX=XMIDL-XFACT*(ALENX2/2.0)
      DO340I=1,132
      ILABX2(I)=' '
  340 CONTINUE
      J=IX-1
      IF(ILENX2.LE.0)GOTO349
      DO345I=1,ILENX2
 
      J=J+1
      ILABX2(J)=IX2LTE(I)
  345 CONTINUE
      IMAXX2=J
  349 CONTINUE
C
      IX=XMIDL-XFACT*(ALENX3/2.0)
      DO350I=1,132
      ILABX3(I)=' '
  350 CONTINUE
      J=IX-1
      IF(ILENX3.LE.0)GOTO359
      DO355I=1,ILENX3
      J=J+1
      ILABX3(J)=IX3LTE(I)
  355 CONTINUE
      IMAXX3=J
  359 CONTINUE
C
C               *******************************************************
C               **  STEP 5--                                         **
C               **  DETERMINE THE MIN AND MAX VALUES OF Y AND OF X.  **
C               *******************************************************
C
      YMIN=Y(1)
      YMAX=Y(1)
      XMIN=X(1)
      XMAX=X(1)
      DO700I=1,N
      IF(Y(I).LT.YMIN)YMIN=Y(I)
      IF(Y(I).GT.YMAX)YMAX=Y(I)
      IF(X(I).LT.XMIN)XMIN=X(I)
      IF(X(I).GT.XMAX)XMAX=X(I)
  700 CONTINUE
      IF(GX1MIN.NE.CPUMIN)XMIN=GX1MIN
      IF(GX1MAX.NE.CPUMAX)XMAX=GX1MAX
      IF(GY1MIN.NE.CPUMIN)YMIN=GY1MIN
      IF(GY1MAX.NE.CPUMAX)YMAX=GY1MAX
      DELY=YMAX-YMIN
      DELX=XMAX-XMIN
      YWIDTH=DELY/ANUMRM
      XWIDTH=DELX/ANUMCM
C
      XMID=(XMIN+XMAX)/2.0
      X25=0.75*XMIN+0.25*XMAX
      X75=0.25*XMIN+0.75*XMAX
C
      DO800I=1,9
      AIM1=I-1
      YLABEL(I)=YMAX-(AIM1/8.0)*(YMAX-YMIN)
  800 CONTINUE
C
C               *********************************
C               **  STEP 6--                   **
C               **  PRODUCE THE VERTICAL AXES  **
C               *********************************
C
      DO1300I=3,43
      IGRAPH(I,5)=IALPHI
      IGRAPH(I,105)=IALPHI
 1300 CONTINUE
      DO1400I=3,43,5
      IGRAPH(I,5)=IHYPHE
      IGRAPH(I,105)=IHYPHE
 1400 CONTINUE
      IGRAPH(3,1)=IEQUAL
      IGRAPH(3,2)=IALPHM
      IGRAPH(3,3)=IALPHA
      IGRAPH(3,4)=IALPHX
      IGRAPH(23,1)=IEQUAL
      IGRAPH(23,2)=IALPHM
      IGRAPH(23,3)=IALPHI
      IGRAPH(23,4)=IALPHD
      IGRAPH(43,1)=IEQUAL
      IGRAPH(43,2)=IALPHM
      IGRAPH(43,3)=IALPHI
      IGRAPH(43,4)=IALPHN
C
C               ***********************************
C               **  STEP 7--                     **
C               **  PRODUCE THE HORIZONTAL AXES  **
C               ***********************************
C
      DO1500J=7,103
      IGRAPH(1,J)=IHYPHE
      IGRAPH(45,J)=IHYPHE
 1500 CONTINUE
      DO1600J=7,103,12
      IGRAPH(1,J)=IALPHI
      IGRAPH(45,J)=IALPHI
 1600 CONTINUE
C
C               ******************************************
C               **  STEP 8--                            **
C               **  DETERMINE THE (X,Y) PLOT POSITIONS  **
C               ******************************************
C
      RATIOY=ANUMRM/(YMAX-YMIN)
      RATIOX=ANUMCM/(XMAX-XMIN)
      DO1800I=1,N
      XI=X(I)
      MX=RATIOX*(XI-XMIN)+0.5
      MX=MX+7
      IF(MX.LT.7.OR.MX.GT.103)GOTO1800
      MY=RATIOY*(Y(I)-YMIN)+0.5
      MY=43-MY
      IF(MY.LT.3.OR.MY.GT.43)GOTO1800
      JPLOTC=ICHAR(1)
      IF(JPLOTC.EQ.'    ')JPLOTC='X'
      IF(JPLOTC.EQ.'BLAN')JPLOTC='X'
      IF(JPLOTC.EQ.'NONE')JPLOTC='X'
      IGRAPH(MY,MX)=JPLOTC
 1800 CONTINUE
C
C               *************************************
C               **  STEP 9--                       **
C               **  SKIP TO A NEW PAGE.            **
C               **  WRITE OUT THE TITLE (IF ANY);  **
C               *************************************
C
      IF(IERASW.EQ.'ON')WRITE(ICOUT,2004)
 2004 FORMAT(1H1)
      IF(IERASW.EQ.'ON')CALL DPWRST('XXX','BUG ')
      IF(IERASW.EQ.'OFF')WRITE(ICOUT,999)
      IF(IERASW.EQ.'OFF')CALL DPWRST('XXX','BUG ')
      IF(IMAXT.GE.1)WRITE(ICOUT,2005)(ILABT(I),I=1,IMAXT)
 2005 FORMAT(240A1)
      IF(IMAXT.GE.1)CALL DPWRST('XXX','BUG ')
      IF(IMAXT.LE.0)WRITE(ICOUT,999)
      IF(IMAXT.LE.0)CALL DPWRST('XXX','BUG ')
C
C               *********************************************
C               **  STEP 10--                              **
C               **  WRITE OUT THE GRAPH                    **
C               **  (INCLUDING THE X-AXIS NUMERIC LABELS)  **
C               *********************************************
C
      DO2100I=1,45
      IP2=I+2
      IFLAG=IP2-(IP2/5)*5
      K=IP2/5
      IF(IFLAG.NE.0)WRITE(ICOUT,2105)ILABY1(I),(IGRAPH(I,J),J=1,105)
 2105 FORMAT(A1,20X,105A1)
      IF(IFLAG.NE.0)CALL DPWRST('XXX','BUG ')
      IF(IFLAG.EQ.0)WRITE(ICOUT,2106)ILABY1(I),YLABEL(K),
     1(IGRAPH(I,J),J=1,105)
 2106 FORMAT(A1,F20.7,105A1)
      IF(IFLAG.EQ.0)CALL DPWRST('XXX','BUG ')
 2100 CONTINUE
      WRITE(ICOUT,2107)XMIN,X25,XMID,X75,XMAX
 2107 FORMAT(14X,F20.7,4X,F20.7,4X,F20.7,4X,F20.7,4X,F20.7)
      CALL DPWRST('XXX','BUG ')
C
C               ************************************************************
C               **  STEP 11--                                             **
C               **  WRITE OUT THE FIRST  HORIZONTAL AXIS LABEL (IF ANY);  **
C               **  WRITE OUT THE SECOND HORIZONTAL AXIS LABEL (IF ANY);  **
C               **  WRITE OUT THE THIRD  HORIZONTAL AXIS LABEL (IF ANY).  **
C               ************************************************************
C
      IF(IMAXX1.GE.1)WRITE(ICOUT,2311)(ILABX1(I),I=1,IMAXX1)
 2311 FORMAT(240A1)
      IF(IMAXX1.GE.1)CALL DPWRST('XXX','BUG ')
      IF(IMAXX1.LE.0)WRITE(ICOUT,999)
      IF(IMAXX1.LE.0)CALL DPWRST('XXX','BUG ')
      IF(IMAXX2.GE.1)WRITE(ICOUT,2311)(ILABX2(I),I=1,IMAXX2)
      IF(IMAXX2.GE.1)CALL DPWRST('XXX','BUG ')
      IF(IMAXX2.LE.0)WRITE(ICOUT,999)
      IF(IMAXX2.LE.0)CALL DPWRST('XXX','BUG ')
      IF(IMAXX3.GE.1)WRITE(ICOUT,2311)(ILABX3(I),I=1,IMAXX3)
      IF(IMAXX3.GE.1)CALL DPWRST('XXX','BUG ')
      IF(IMAXX3.LE.0)WRITE(ICOUT,999)
      IF(IMAXX3.LE.0)CALL DPWRST('XXX','BUG ')
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE PLYSRT(XC,YC,NMX,NSEG,NSGE,NSGCL,NSGCH,NPTS,NTPE,
     1 NTPCL,NTPCH,SNSE,CLSD,NSGX,X,Y,IMX,JMX,IB,JB,NBX,PRMTR,NS,D)
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     UPDATED         --JULY      1996.  EXPLICITLY INITIALIZE SOME
C                                        ARRAYS (BOMBED ON SGI WHICH
C                                        DOESN'T PRESET TO 0)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOCP.INC'
C
C---------------------------------------------------------------------
C
CCCCC INTEGER NPTS(NSGX,3),SNSE(NSGX,3),CLSD(NSGX,3),NSEG(3),
CCCCC1 LC(4),NSGE(3),NSGCL(3),NSGCH(3),NTPE(3),NTPCL(3),NTPCH(3),
CCCCC2 ESTR
C
CCCCC DIMENSION XC(NMX,3),YC(NMX,3),D(2,NSGX,3),X(IMX),Y(JMX),
CCCCC1 IB(NBX),JB(NBX),NS(2,NSGX,3)
C
      INTEGER NPTS
      INTEGER SNSE
      INTEGER CLSD
      INTEGER NSEG
CCCCC INTEGER LC
      INTEGER NSGE
      INTEGER NSGCL
      INTEGER NSGCH
      INTEGER NTPE
      INTEGER NTPCL
      INTEGER NTPCH
      INTEGER ESTR
C
      DIMENSION NPTS(MAXNSG,3)
      DIMENSION SNSE(MAXNSG,3)
      DIMENSION CLSD(MAXNSG,3)
      DIMENSION NSEG(3)
CCCCC DIMENSION LC(4)
      DIMENSION NSGE(3)
      DIMENSION NSGCL(3)
      DIMENSION NSGCH(3)
      DIMENSION NTPE(3)
      DIMENSION NTPCL(3)
      DIMENSION NTPCH(3)
C
      DIMENSION XC(MAXNMX,3)
      DIMENSION YC(MAXNMX,3)
      DIMENSION D(2,MAXNSG,3)
      DIMENSION X(*)
      DIMENSION Y(*)
      DIMENSION IB(*)
      DIMENSION JB(*)
      DIMENSION NS(2,MAXNSG,3)
C
C-----START POINT-----------------------------------------------------
C
CCCCC JULY 1996.  ADD FOLLOING 9 LINES FOR SGI BUG.
      NSGE(1)=0
      NSGE(2)=0
      NSGE(3)=0
      NSGCH(1)=0
      NSGCH(2)=0
      NSGCH(3)=0
      NSGCL(1)=0
      NSGCL(2)=0
      NSGCL(3)=0
C
      IF (NSEG(1).EQ.0) THEN
        NSGE(1)=0
        NSGCL(1)=0
        NSGCH(1)=0
        NTPE(1)=0
        NTPCL(1)=0
        NTPCH(1)=0
      END IF
      IF (NSEG(2).EQ.0) THEN
        NSGE(2)=0
        NSGCL(2)=0
        NSGCH(2)=0
        NTPE(2)=0
        NTPCL(2)=0
        NTPCH(2)=0
      ELSE
C   BEGIN SORTING THE *(*,2) ARRAYS
        NSG=NSEG(2)
        NTP=0
        NTPE(2)=0
        NTPCL(2)=0
        NTPCH(2)=0
        NSGE(2)=0
        NSGCL(2)=0
        NSGCH(2)=0
        DO 100 N=1,NSG
          NTP=NTP+NPTS(N,2)
          IF (CLSD(N,2).EQ.0) THEN
            NSGE(2)=NSGE(2)+1
            NTPE(2)=NTPE(2)+NPTS(N,2)
          ELSE IF (CLSD(N,2).LT.0) THEN
            NSGCL(2)=NSGCL(2)+1
            NTPCL(2)=NTPCL(2)+NPTS(N,2)
          ELSE
            NSGCH(2)=NSGCH(2)+1
            NTPCH(2)=NTPCH(2)+NPTS(N,2)
          END IF
  100   CONTINUE
C   MAKE SURE EACH CONTOUR SEGMENT PROCEEDS IN THE CORRECT SENSE
C    WHICH IS WITH LOW VALUES TO THE RIGHT OF THE CONTOUR
        LN=0
        DO 200 N=1,NSG
          LS=LN+1
          LN=LN+NPTS(N,2)
          IF (SNSE(N,2).LT.0) THEN
            LN2=(LS+LN-1)/2
            DO 210 L=LS,LN2
              LL=LN-L+LS
              H=XC(LL,2)
              XC(LL,2)=XC(L,2)
              XC(L,2)=H
              H=YC(LL,2)
              YC(LL,2)=YC(L,2)
              YC(L,2)=H
  210       CONTINUE
            SNSE(N,2)=1
          END IF
  200   CONTINUE
C   SEPARATE THE EDGE-TO-EDGE SEGMENTS FROM THE CLOSED SEGMENTS
        IF (NSGE(2).GT.0) THEN
          NSGM=NSG-1
          DO 300 N=1,NSGM
            L1=1
            DO 310 M=1,NSGM
              IF (CLSD(M,2).NE.0.AND.CLSD(M+1,2).EQ.0) THEN
                IH=CLSD(M,2)
                CLSD(M,2)=CLSD(M+1,2)
                CLSD(M+1,2)=IH
                L2=L1+NPTS(M,2)
                L3=L2+NPTS(M+1,2)
                CALL STRSWP(XC(1,2),L1,L2,L3)
                CALL STRSWP(YC(1,2),L1,L2,L3)
                IH=NPTS(M,2)
                NPTS(M,2)=NPTS(M+1,2)
                NPTS(M+1,2)=IH
              END IF
              L1=L1+NPTS(M,2)
  310       CONTINUE
  300     CONTINUE
C   DETERMINE THE BOUNDARY POINTS FOR EACH EDGE-TO-EDGE SEGMENT'S ENTRY & EXIT
C    AND THE DISTANCE OF THESE POINTS FROM THE LOWER LEFT CORNER
          NBM=NBX-1
          LN=0
          NSG=NSGE(2)
          DO 400 N=1,NSG
            LS=LN+1
            LN=LN+NPTS(N,2)
            L=LS
            DO 410 K=1,2
              CALL SIDEDI(XC(L,2),YC(L,2),NS(K,N,2),D(K,N,2),
     1                    IB,JB,X,Y)
               L=LN
  410       CONTINUE
  400     CONTINUE
        END IF
C   SEPARATE CLOSED LOW SEGMENTS FROM CLOSED HIGH SEGMENTS
        IF (NSGCL(2).GT.0.AND.NSGCH(2).GT.0) THEN
          NSGM=NSEG(2)-1
          DO 500 N=NSGE(2)+1,NSGM
            L1=NTPE(2)+1
            DO 510 M=NSGE(2)+1,NSGM
              IF (CLSD(M,2).GT.0.AND.CLSD(M+1,2).LT.0) THEN
                IH=CLSD(M,2)
                CLSD(M,2)=CLSD(M+1,2)
                CLSD(M+1,2)=IH
                L2=L1+NPTS(M,2)
                L3=L2+NPTS(M+1,2)
                CALL STRSWP(XC(1,2),L1,L2,L3)
                CALL STRSWP(YC(1,2),L1,L2,L3)
                IH=NPTS(M,2)
                NPTS(M,2)=NPTS(M+1,2)
                NPTS(M+1,2)=IH
              END IF
              L1=L1+NPTS(M,2)
  510       CONTINUE
  500     CONTINUE
        END IF
C   DETERMINE AREA OF CLOSED SEGMENTS AND STORE IN D(1,*,*)
        IF (NSGCL(2).GT.0.OR.NSGCH(2).GT.0) THEN
          N1=NSGE(2)+1
          NSG=N1+NSGCL(2)+NSGCH(2)-1
          LE=NTPE(2)
          DO600N=N1,NSG
            LS=LE+1
            LE=LE+NPTS(N,2)
            D(1,N,2)=0.
            DO610L=LS+1,LE
              D(1,N,2)=D(1,N,2)+0.5*(XC(L,2)-XC(L-1,2))*
     1                           (YC(L,2)+YC(L-1,2))
  610       CONTINUE
            D(1,N,2)=ABS(D(1,N,2))
  600     CONTINUE
        END IF
      END IF
C     WRITE(9,'(''  EDGE CONTOURS'')')
C     CALL PRT_STR(9,XC(1,2),YC(1,2),NSGE(2),NPTS(1,2))
C   SORT BOTH 1 AND 2 EDGE-TO-EDGE SEGMENTS BY DISTANCE OF
C    ENTRY POINTS FROM LOWER LEFT CORNER.
      DO700K=1,2
        IF (NSGE(K).GT.0) THEN
          NSGM=NSGE(K)-1
          DO710N=1,NSGM
            L1=1
            DO720M=1,NSGM
              IF (D(1,M,K).GT.D(1,M+1,K)) THEN
                DO730L=1,2
                  H=D(L,M,K)
                  D(L,M,K)=D(L,M+1,K)
                  D(L,M+1,K)=H
                  IH=NS(L,M,K)
                  NS(L,M,K)=NS(L,M+1,K)
                  NS(L,M+1,K)=IH
  730           CONTINUE
                IH=CLSD(M,K)
                CLSD(M,K)=CLSD(M+1,K)
                CLSD(M+1,K)=IH
                L2=L1+NPTS(M,K)
                L3=L2+NPTS(M+1,K)
                CALL STRSWP(XC(1,K),L1,L2,L3)
                CALL STRSWP(YC(1,K),L1,L2,L3)
                IH=NPTS(M,K)
                NPTS(M,K)=NPTS(M+1,K)
                NPTS(M+1,K)=IH
              END IF
              L1=L1+NPTS(M,K)
  720       CONTINUE
  710     CONTINUE
        END IF
  700 CONTINUE
C     WRITE(9,'(''  SORTED EDGE CONTOURS 1'')')
C     CALL PRT_STR(9,XC(1,1),YC(1,1),NSGE(1),NPTS(1,1))
C     WRITE(9,'(''  SORTED EDGE CONTOURS 2'')')
C     CALL PRT_STR(9,XC(1,2),YC(1,2),NSGE(2),NPTS(1,2))
C   BEGIN CONVERTING EDGE-TO-EDGE SEGMENTS TO CLOSED SEGMENTS
      L3=0
      N3=0
      IF (NSGE(2).GT.0.OR.NSGE(1).GT.0) THEN
        DO800K=2,1,-1
          NSG=NSGE(K)
          LE=0
          DO810N=1,NSG
            LS=LE+1
            LE=LE+IABS(NPTS(N,K))
            IF (NPTS(N,K).GT.0) THEN
              N3=N3+1
              DO820L=LS,LE
                LL=L3+L-LS+1
                XC(LL,3)=XC(L,K)
                YC(LL,3)=YC(L,K)
  820         CONTINUE
              NPTS(N3,3)=NPTS(N,K)
              NPTS(N,K)=-NPTS(N,K)
              NS(1,N3,3)=NS(1,N,K)
              NS(2,N3,3)=NS(2,N,K)
              D(1,N3,3)=D(1,N,K)
              D(2,N3,3)=D(2,N,K)
              ESTR=0
  900         CONTINUE
              IF(ESTR.EQ.1)GOTO999
C     WRITE(9,'('' PRMTR'',F10.2)') PRMTR
              DD=D(1,N3,3)-D(2,N3,3)
              SGNDD=SIGN(1.0,DD)
              IF (DD.LT.0.) DD=DD+PRMTR
              KE=K
              NE=N
C     WRITE(9,'('' D1 D2 DD SGNDD KE NE'',4F8.2,2I6)')
C     1               D(1,N3,3),D(2,N3,3),DD,SGNDD,KE,NE
              DO910KK=1,2
                NNSG=NSGE(KK)
                DO920NN=1,NNSG
C     WRITE(9,'('' KK NN NPTS'',3I6)') KK,NN,NPTS(KK,NN)
                  IF (NPTS(NN,KK).GT.0) THEN
                    D0=D(1,NN,KK)-D(2,N3,3)
                    SGND0=SIGN(1.0,D0)
                    IF (D0.LT.0.) D0=D0+PRMTR
C     WRITE(9,'('' D1 D2 D0 SGND0'',4F8.2)')
C     1               D(1,NN,KK),D(2,N3,3),D0,SGND0
                    IF (D0.LT.DD) THEN
                      DD=D0
                      SGNDD=SGND0
                      KE=KK
                      NE=NN
                    END IF
                  END IF
  920           CONTINUE
  910         CONTINUE
C     WRITE(9,'('' KE NE'',2I6)') KE,NE
C     WRITE(9,'('' NS2 NS1 SGNDD'',2I6,F6.0)')
C     1               NS(2,N3,3),NS(1,NE,KE),SGNDD
              IF (NS(2,N3,3).NE.NS(1,NE,KE).OR.SGNDD.LT.0.) THEN
                NB1=NS(2,N3,3)+1
                NB2=NS(1,NE,KE)
                LL=L3+NPTS(N3,3)
C     WRITE(9,'('' NB1 NB2'',2I6)') NB1,NB2
                IF (NS(2,N3,3).LT.NS(1,NE,KE)) THEN
                  DO930NB=NB1,NB2
                    LL=LL+1
                    XC(LL,3)=X(IB(NB))
                    YC(LL,3)=Y(JB(NB))
  930             CONTINUE
                  NPTS(N3,3)=NPTS(N3,3)+NB2-NB1+1
                ELSE
                  DO940NB=NB1,NBX
                    LL=LL+1
                    XC(LL,3)=X(IB(NB))
                    YC(LL,3)=Y(JB(NB))
  940             CONTINUE
                  DO950NB=2,NB2
                    LL=LL+1
                    XC(LL,3)=X(IB(NB))
                    YC(LL,3)=Y(JB(NB))
  950             CONTINUE
                  NPTS(N3,3)=NPTS(N3,3)+NB2-NB1+NBX
                END IF
                CALL SIDEDI(XC(LL,3),YC(LL,3),NS(2,N3,3),
     1                         D(2,N3,3),IB,JB,X,Y)
                DD=D(1,NE,KE)-D(2,N3,3)
                SGNDD=SIGN(1.0,DD)
                IF (DD.LT.0.) DD=DD+PRMTR
              END IF
              IF (KE.EQ.K.AND.NE.EQ.N) THEN
                ESTR=1
                NPTS(N3,3)=NPTS(N3,3)+1
                LL=L3+NPTS(N3,3)
                XC(LL,3)=XC(L3+1,3)
                YC(LL,3)=YC(L3+1,3)
              ELSE
                LLE=0
                DO960NN=1,NE
                  LLS=LLE+1
                  LLE=LLE+IABS(NPTS(NN,KE))
  960           CONTINUE
                LL3=L3+NPTS(N3,3)
                DO970LL=LLS,LLE
                  LLL=LL3+LL-LLS+1
                  XC(LLL,3)=XC(LL,KE)
                  YC(LLL,3)=YC(LL,KE)
  970           CONTINUE
                NPTS(N3,3)=NPTS(N3,3)+NPTS(NE,KE)
                NPTS(NE,KE)=-NPTS(NE,KE)
                NS(2,N3,3)=NS(2,NE,KE)
                D(2,N3,3)=D(2,NE,KE)
              END IF
              GOTO900
  999         CONTINUE
C
C
C
              IF (NSGCH(1).GT.0.OR.NSGCH(2).GT.0) THEN
                LLL=L3+1
                ESTR=0
 2000           CONTINUE
                IF(ESTR.EQ.1)GOTO2099
                  A=0.
                  KE=0
                  DO2010KK=1,2
                    LL=1+NTPE(KK)+NTPCL(KK)
                    NN1=1+NSGE(KK)+NSGCL(KK)
                    NNSG=NN1+NSGCH(KK)-1
                    DO2020NN=NN1,NNSG
                      IF (NPTS(NN,KK).GT.0) THEN
                        CALL INOUT(XC(LL,KK),YC(LL,KK),XC(LLL,3),
     1                    YC(LLL,3),NPTS(N3,3),IO)
                        IF (IO.EQ.1.AND.D(1,NN,KK).GT.A) THEN
                          A=D(1,NN,KK)
                          NE=NN
                          KE=KK
                        END IF
                      END IF
                      LL=LL+IABS(NPTS(NN,KK))
 2020               CONTINUE
 2010             CONTINUE
                  IF (KE.EQ.0) THEN
                    ESTR=1
                  ELSE
                    LL=1+NTPE(KE)+NTPCL(KE)
                    NN1=1+NSGE(KE)+NSGCL(KE)
                    DO2030NN=NN1,NE-1
                      LL=LL+IABS(NPTS(NN,KE))
 2030               CONTINUE
                    CALL CONINS(XC(LLL,3),YC(LLL,3),NPTS(N3,3),
     1                XC(LL,KE),YC(LL,KE),NPTS(NE,KE))
                    NPTS(NE,KE)=-NPTS(NE,KE)
                  END IF
                  GOTO2000
 2099           CONTINUE
              END IF
              L3=L3+NPTS(N3,3)
            END IF
  810     CONTINUE
  800   CONTINUE
      END IF
C   BEGIN COMBINING CLOSED SEGMENTS
      IF (NSGCL(2).GT.0.OR.NSGCL(1).GT.0) THEN
        DO3000K=2,1,-1
          N1=NSGE(K)+1
          NSG=N1+NSGCL(K)-1
          LE=NTPE(K)
          DO3010N=N1,NSG
            LS=LE+1
            LE=LE+IABS(NPTS(N,K))
            N3=N3+1
            DO3020L=LS,LE
              LL=L3+L-LS+1
              XC(LL,3)=XC(L,K)
              YC(LL,3)=YC(L,K)
 3020       CONTINUE
            NPTS(N3,3)=NPTS(N,K)
            IF (NSGCH(1).GT.0.OR.NSGCH(2).GT.0) THEN
              LLL=L3+1
              ESTR=0
 4000         CONTINUE
              IF(ESTR.EQ.1)GOTO4099
                A=0.
                KE=0
                DO4010KK=1,2
                  LL=1+NTPE(KK)+NTPCL(KK)
                  NN1=1+NSGE(KK)+NSGCL(KK)
                  NNSG=NN1+NSGCH(KK)-1
                  DO4020NN=NN1,NNSG
                    IF (NPTS(NN,KK).GT.0) THEN
                      CALL INOUT(XC(LL,KK),YC(LL,KK),XC(LLL,3),
     1                    YC(LLL,3),NPTS(N3,3),IO)
                      IF (IO.EQ.1.AND.D(1,NN,KK).GT.A) THEN
                        A=D(1,NN,KK)
                        NE=NN
                        KE=KK
                      END IF
                    END IF
                    LL=LL+IABS(NPTS(NN,KK))
 4020             CONTINUE
 4010           CONTINUE
                IF (KE.EQ.0) THEN
                  ESTR=1
                ELSE
                  LL=1+NTPE(KE)+NTPCL(KE)
                  NN1=1+NSGE(KE)+NSGCL(KE)
                  DO4030NN=NN1,NE-1
                    LL=LL+IABS(NPTS(NN,KE))
 4030             CONTINUE
                  CALL CONINS(XC(LLL,3),YC(LLL,3),NPTS(N3,3),
     1                XC(LL,KE),YC(LL,KE),NPTS(NE,KE))
                  NPTS(NE,KE)=-NPTS(NE,KE)
                END IF
                GOTO4000
 4099         CONTINUE
            END IF
            L3=L3+NPTS(N3,3)
 3010     CONTINUE
 3000   CONTINUE
      END IF
C   HANDLE SITUATION WHERE THERE ARE ONLY CLOSED HIGH SEGMENTS
      IF ((NSGE(1)+NSGE(2)+NSGCL(1)+NSGCL(2)).EQ.0) THEN
        N3=N3+1
        DO5000NB=1,NBX
          XC(L3+NB,3)=X(IB(NB))
          YC(L3+NB,3)=Y(JB(NB))
 5000   CONTINUE
        NPTS(N3,3)=NBX
        IF (NSGCH(1).GT.0.OR.NSGCH(2).GT.0) THEN
          LLL=L3+1
          ESTR=0
 5100     CONTINUE
          IF(ESTR.EQ.1)GOTO5199
            A=0.
            KE=0
            DO5110KK=1,2
              LL=1
              NNSG=NSGCH(KK)
              DO5120NN=1,NNSG
                IF (NPTS(NN,KK).GT.0) THEN
                  CALL INOUT(XC(LL,KK),YC(LL,KK),XC(LLL,3),
     1                    YC(LLL,3),NPTS(N3,3),IO)
                  IF (IO.EQ.1.AND.D(1,NN,KK).GT.A) THEN
                    A=D(1,NN,KK)
                    NE=NN
                    KE=KK
                  END IF
                END IF
                LL=LL+IABS(NPTS(NN,KK))
 5120         CONTINUE
 5110       CONTINUE
            IF (KE.EQ.0) THEN
              ESTR=1
            ELSE
              LL=1
              DO5130NN=1,NE-1
                LL=LL+IABS(NPTS(NN,KE))
 5130         CONTINUE
              CALL CONINS(XC(LLL,3),YC(LLL,3),NPTS(N3,3),
     1                XC(LL,KE),YC(LL,KE),NPTS(NE,KE))
              NPTS(NE,KE)=-NPTS(NE,KE)
            END IF
            GOTO5100
 5199     CONTINUE
        END IF
        L3=L3+NPTS(N3,3)
      END IF
      NSEG(3)=N3
C     WRITE(9,'(''  TOTAL CONTOURS'')')
C     CALL PRT_STR(9,XC(1,3),YC(1,3),NSEG(3),NPTS(1,3))
      RETURN
      END
      SUBROUTINE PLNCDF(X,P,SD,CDF)
C
C     NOTE--POWER-LOGNORMAL CDF IS:
C              PLNCDF(X,U,SD,P) = 1 - [NORCDF(-(LN(X)-U)/SD)]**P
C           STANDARD FORM OF THIS DISTRIBUTION IS:
C              PLNCDF(X,P) = 1 - [NORCDF(-LN(X))]**P
C           FOR CONSISTENCY WITH PLNPDF ROUTINE, ALLOW SD AS 
C           OPTIONAL PARAMETER.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--95/4
C     ORIGINAL VERSION--APRIL     1995.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
      DOUBLE PRECISION DTERM4
      DOUBLE PRECISION DEPS
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DATA DEPS/0.1D-100/
C
C-----START POINT-----------------------------------------------------
C
      CDF=0.0
C
      IF(X.LE.0.0)THEN
        WRITE(ICOUT,301)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,203)X
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
      IF(P.LE.0.0)THEN
        WRITE(ICOUT,101)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,103)P
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
      IF(SD.LE.0.0)THEN
        WRITE(ICOUT,201)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,203)SD
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
  101 FORMAT('***** FATAL DIAGNOSTIC--THE POWER PARAMETER, P, IS ',
     1       '      NON-POSITIVE.')
  103 FORMAT('      THE VALUE OF P IS ',E15.7)
  201 FORMAT('***** FATAL DIAGNOSTIC--THE STANDARD DEVIATION ',
     1       'PARAMETER IS NON-POSITIVE.')
  203 FORMAT('      THE VALUE IS ',E15.7)
  301 FORMAT('***** FATAL DIAGNOSTIC--THE INPUT ARGUMENT IS ',
     1       '      NON-POSITIVE.')
C
      TERM1=-LOG(X)/SD
      CALL NODCDF(DBLE(TERM1),DTERM1)
      IF(DTERM1.LE.DEPS)DTERM1=DEPS
      DTERM2=DBLE(P)*DLOG(DTERM1)
      DTERM3=DEXP(DTERM2)
      DTERM4=1.0D0-DTERM3
      CDF=REAL(DTERM4)
      GOTO9999
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE PLNCHA(X,P,SD,HAZ)
C
C     NOTE--POWER-LOGNORMAL PDF IS:
C              PLNPDF(X,U,S,P) = (P/(X*SD))*NORPDF((LN(X)-U)/SD)*
C                                   NORCDF(-(LN(X)-U)/SD))**(P-1)
C           STANDARD FORM OF THIS DISTRIBUTION IS:
C              PLNPDF(X,S,P) = (P/(X*SD))*NORPDF(LN(X))*
C                                NORCDF(-LN(X)/SD)**(P-1)
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--98/4
C     ORIGINAL VERSION--APRIL     1998.
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
      HAZ=0.0
C
      IF(X.LT.0.0)THEN
        WRITE(ICOUT,301)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,203)X
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ELSEIF(X.EQ.0.0)THEN
        HAZ=0.0
        GOTO9999
      ENDIF
      IF(P.LE.0.0)THEN
        WRITE(ICOUT,101)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,103)P
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
      IF(SD.LE.0.0)THEN
        WRITE(ICOUT,201)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,203)SD
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
  101 FORMAT('***** FATAL DIAGNOSTIC--THE POWER PARAMETER, P, IS ',
     1       '      NON-POSITIVE.')
  103 FORMAT('      THE VALUE OF P IS ',E15.7)
  201 FORMAT('***** FATAL DIAGNOSTIC--THE STANDARD DEVIATION ',
     1       'PARAMETER IS NON-POSITIVE.')
  203 FORMAT('      THE VALUE IS ',E15.7)
  301 FORMAT('***** FATAL DIAGNOSTIC--THE INPUT ARGUMENT IS ',
     1       '      NON-POSITIVE.')
C
      CALL PLNCDF(X,SD,P,CDF)
      CDF=1.0-CDF
      IF(CDF.GT.0.0)THEN
        HAZ=-LOG(CDF)
      ELSE
        HAZ=0.0
        WRITE(ICOUT,901)X
        CALL DPWRST('XXX','BUG ')
      ENDIF
  901 FORMAT('**** ERROR: FOR X = ',E15.7,' THE CDF IS ',
     1'ESSENTIALLY 1.')
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE PLNHAZ(X,P,SD,HAZ)
C
C     NOTE--POWER-LOGNORMAL PDF IS:
C              PLNPDF(X,U,S,P) = (P/(X*SD))*NORPDF((LN(X)-U)/SD)*
C                                   NORCDF(-(LN(X)-U)/SD))**(P-1)
C           STANDARD FORM OF THIS DISTRIBUTION IS:
C              PLNPDF(X,S,P) = (P/(X*SD))*NORPDF(LN(X))*
C                                NORCDF(-LN(X)/SD)**(P-1)
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--98/4
C     ORIGINAL VERSION--APRIL     1998.
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
      HAZ=0.0
C
      IF(X.LT.0.0)THEN
        WRITE(ICOUT,301)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,203)X
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ELSEIF(X.EQ.0.0)THEN
        HAZ=0.0
        GOTO9999
      ENDIF
      IF(P.LE.0.0)THEN
        WRITE(ICOUT,101)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,103)P
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
      IF(SD.LE.0.0)THEN
        WRITE(ICOUT,201)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,203)SD
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
  101 FORMAT('***** FATAL DIAGNOSTIC--THE POWER PARAMETER, P, IS ',
     1       '      NON-POSITIVE.')
  103 FORMAT('      THE VALUE OF P IS ',E15.7)
  201 FORMAT('***** FATAL DIAGNOSTIC--THE STANDARD DEVIATION ',
     1       'PARAMETER IS NON-POSITIVE.')
  203 FORMAT('      THE VALUE IS ',E15.7)
  301 FORMAT('***** FATAL DIAGNOSTIC--THE INPUT ARGUMENT IS ',
     1       '      NON-POSITIVE.')
C
      CALL LGNHAZ(X,SD,ALGCDF)
      HAZ=P*ALGCDF
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE PLNPDF(X,P,SD,PDF)
C
C     NOTE--POWER-LOGNORMAL PDF IS:
C              PLNPDF(X,U,S,P) = (P/(X*SD))*NORPDF((LN(X)-U)/SD)*
C                                   NORCDF(-(LN(X)-U)/SD))**(P-1)
C           STANDARD FORM OF THIS DISTRIBUTION IS:
C              PLNPDF(X,S,P) = (P/(X*SD))*NORPDF(LN(X))*
C                                NORCDF(-LN(X)/SD)**(P-1)
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--95/4
C     ORIGINAL VERSION--APRIL     1995.
C     UPDATED         --JULY      1999. FIXED THIS ROUTINE
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
      DOUBLE PRECISION DTERM4
      DOUBLE PRECISION DTERM5
CCCCC JULY 1999.  ADD FOLLOWING LINES.
      DOUBLE PRECISION DX
      DOUBLE PRECISION DXLOG
      DOUBLE PRECISION DP
      DOUBLE PRECISION DSD
C
CCCCC JULY 1995.  ADD FOLLOWING LINE.
      DOUBLE PRECISION DPDF
      DOUBLE PRECISION DEPS
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOMC.INC'
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      PDF=0.0
      DEPS=D1MACH(1)
C
      IF(X.LE.0.0)THEN
        WRITE(ICOUT,301)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,203)X
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
      IF(P.LE.0.0)THEN
        WRITE(ICOUT,101)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,103)P
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
      IF(SD.LE.0.0)THEN
        WRITE(ICOUT,201)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,203)SD
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
  101 FORMAT('***** FATAL DIAGNOSTIC--THE POWER PARAMETER, P, IS ',
     1       '      NON-POSITIVE.')
  103 FORMAT('      THE VALUE OF P IS ',E15.7)
  201 FORMAT('***** FATAL DIAGNOSTIC--THE STANDARD DEVIATION ',
     1       'PARAMETER IS NON-POSITIVE.')
  203 FORMAT('      THE VALUE IS ',E15.7)
  301 FORMAT('***** FATAL DIAGNOSTIC--THE INPUT ARGUMENT IS ',
     1       '      NON-POSITIVE.')
C
      DX=DBLE(X)
      DSD=DBLE(SD)
      DP=DBLE(P)
      DXLOG=DLOG(DX)
C
      DTERM1=DLOG(DP) - DLOG(DSD) - DXLOG
      CALL NODPDF(DXLOG/DSD,DTERM2)
      IF(DTERM2.LT.DEPS)DTERM2=DEPS
      DTERM2=DLOG(DTERM2)
      CALL NODCDF(-DXLOG/DSD,DTERM3)
      IF(DTERM3.LT.DEPS)DTERM3=DEPS
      DTERM4=(DP-1.0D0)*DLOG(DTERM3)
      DTERM5=DTERM1 + DTERM2 + DTERM4
      IF(DTERM5.LE.I1MACH(12))THEN
        PDF=0.0
      ELSEIF(DPDF.GT.I1MACH(13))THEN
        PDF=0.0
        WRITE(ICOUT,503)X,P,SD
        CALL DPWRST('XXX','BUG ')
      ELSE
        DPDF=DEXP(DTERM5)
        PDF=REAL(DPDF)
      ENDIF
  503 FORMAT('**** FROM PLNPDF: COMPUTATION OVERFLOWS FOR ',
     1       'ARGUMENTS ',3G16.7)
      GOTO9999
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE PLNPPF(P,POWER,SD,PPF)
C
C     NOTE--POWER-LOGNORMAL PPF IS:
C              PLNPPF(P,U,SD,POWER) = EXP(U+Zf*SD)
C           WHERE Zf = NORPPF(1-(1-P)**(1/POWER))
C           STANDARD FORM OF THIS DISTRIBUTION IS:
C              PLNPPF(P,U,SD,POWER) = EXP(Zf)
C           FOR CONSISTENCY WITH PLNPDF ROUTINE, ALLOW SD AS 
C           OPTIONAL PARAMETER.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--95/4
C     ORIGINAL VERSION--APRIL     1995.
C     MODIFIED        --JUNE      1995. CHECK FOR MAXIMUM VALUE
C     MODIFIED        --SEPTEMBER 1995. BETTER HANDLING OF CASE WHEN
C                                       NORPPF CALLED WITH VALUE CLOSE
C                                       TO 1.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
      DOUBLE PRECISION DTERM4
      DOUBLE PRECISION DTERM5
      DOUBLE PRECISION DTERM6
      DOUBLE PRECISION DTMIN
CCCCC DOUBLE PRECISION DTMAX
      DOUBLE PRECISION DEPS
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOMC.INC'
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DATA DEPS / 1.0D-16/
C
C-----START POINT-----------------------------------------------------
C
      PPF=0.0
C
      IF(P.LT.0.0 .OR. P.GE.1.0)THEN
        WRITE(ICOUT,1)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)P
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
        GOTO9999
      ELSEIF(P.EQ.0.0)THEN
        PPF=0.0
        GOTO9999
      ENDIF
      IF(POWER.LE.0.0)THEN
        WRITE(ICOUT,101)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,203)POWER
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
      IF(SD.LE.0.0)THEN
        WRITE(ICOUT,201)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,203)SD
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
    1 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ',
     1' PLNPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
  101 FORMAT('***** FATAL DIAGNOSTIC--THE POWER PARAMETER IS ',
     1       '      NON-POSITIVE.')
  201 FORMAT('***** FATAL DIAGNOSTIC--THE STANDARD DEVIATION ',
     1       'PARAMETER IS NON-POSITIVE.')
  203 FORMAT('      THE VALUE IS ',E15.7)
C
      DTMIN=D1MACH(1)
      DTERM1= 1.0D0 - DBLE(P)
      DTERM2=1.0D0/DBLE(POWER)
CCCCC SEPTEMBER 1995.  HANDLE CASE WHERE NORPPF CALLED WITH ARGUMENT
CCCCC CLOSE TO 1 BETTER.
CCCCC DTERM3=1.0D0 - DTERM1**DTERM2
      DTERM3=DTERM1**DTERM2
      IF(DTERM3.LT.DEPS)THEN
        IF(DTERM3.LE.DTMIN)DTERM3=DTMIN
        CALL NODPPF(DTERM3,DTERM4)
        DTERM4=-DTERM4
      ELSE
        DTERM3=1.0D0 - DTERM3
        IF(DTERM3.LE.DTMIN)DTERM3=DTMIN
CCCCC JUNE 1995.  ADD FOLLOWING 2 LINES
CCCCC DTMAX=1.0D0-DEPS
CCCCC IF(DTERM3.GE.DTMAX)DTERM3=DTMAX
        CALL NODPPF(DTERM3,DTERM4)
      ENDIF
C
      DTERM5=DBLE(SD)*DTERM4
      DTERM6=DEXP(DTERM5)
      PPF=REAL(DTERM6)
      GOTO9999
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE PLNRAN(N,P,SD,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE POWER LOGNORMAL DISTRIBUTION
C              WITH SHAPE PARAMETER VALUES = P AND SD.
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --P  = THE SINGLE PRECISION VALUE OF THE
C                                FIRST SHAPE PARAMETER.
C                                P SHOULD BE POSITIVE.
C                     --SD = THE SINGLE PRECISION VALUE OF THE
C                                SECOND SHAPE PARAMETER.
C                                SD 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 POWER LOGNORMAL DISTRIBUTION
C             WITH TAIL LENGTH PARAMETER VALUES = P AND SD.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C                 --P 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                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2001.11
C     ORIGINAL VERSION--NOVEMBER  2001.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)THEN
        WRITE(ICOUT, 5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
      IF(P.LE.0.0)THEN
        WRITE(ICOUT,15)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)P
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
      IF(SD.LE.0.0)THEN
        WRITE(ICOUT,25)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)SD
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
    5 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ',
     1'PLNRAN SUBROUTINE IS NON-POSITIVE *****')
   15 FORMAT('***** FATAL ERROR--THE 2ND INPUT ARGUMENT TO THE ',
     1'PLNRAN SUBROUTINE IS NON-POSITIVE *****')
   25 FORMAT('***** FATAL ERROR--THE THIRD INPUT ARGUMENT TO THE ',
     1'PLNRAN SUBROUTINE IS NON-POSITIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
C
C     GENERATE N UNIFORM (0,1) RANDOM NUMBERS;
C
      CALL UNIRAN(N,ISEED,X)
C
C     GENERATE N POWER LOGNORMAL DISTRIBUTION RANDOM NUMBERS
C     USING PERCENT POINT FUNCTION
C
      SD=1.0
      DO100I=1,N
        CALL PLNPPF(X(I),P,SD,XTEMP)
        X(I)=XTEMP
  100 CONTINUE
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE PNRCDF(X,P,CDF)
CCCCC SUBROUTINE PNRCDF(X,P,SD,CDF)
C
C     NOTE--POWER-NORMAL CDF IS:
C              PNRCDF(X,U,SD,P) = 1 - [NORCDF(-(X-U)/SD)]**P
C           STANDARD FORM OF THIS DISTRIBUTION IS:
C              PNRCDF(X,P) = 1 - [NORCDF(X)]**P
C           FOR CONSISTENCY WITH PNRPDF ROUTINE, ALLOW SD AS 
C           OPTIONAL PARAMETER.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--95/4
C     ORIGINAL VERSION--APRIL     1995.
C     UPDATED         --OCTOBER   2001.  ALGORITHM UPDATED
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
      DOUBLE PRECISION DTERM4
      DOUBLE PRECISION DEPS
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DATA DEPS/0.1D-20/
C
C-----START POINT-----------------------------------------------------
C
      CDF=0.0
      XMAXVL=38.0
C
      IF(P.LE.0.0)THEN
        WRITE(ICOUT,101)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,103)P
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
CCCCC IF(SD.LE.0.0)THEN
CCCCC   WRITE(ICOUT,201)
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   WRITE(ICOUT,203)SD
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   GOTO9999
CCCCC ENDIF
      IF(ABS(X).GT.XMAXVL)THEN
        WRITE(ICOUT,301)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,303)-XMAXVL,XMAXVL
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,305)X
        CALL DPWRST('XXX','BUG ')
        IF(X.GT.XMAXVL)CDF=1.0 
        GOTO9999
      ENDIF
  101 FORMAT('***** FATAL DIAGNOSTIC--THE POWER PARAMETER, P, IS ',
     1       '      NON-POSITIVE.')
  103 FORMAT('      THE VALUE OF P IS ',E15.7)
  201 FORMAT('***** FATAL DIAGNOSTIC--THE STANDARD DEVIATION ',
     1       'PARAMETER IS NON-POSITIVE.')
  203 FORMAT('      THE VALUE IS ',E15.7)
  301 FORMAT('***** FATAL DIAGNOSTIC--FOR THE PNRCDF FUNCTION--')
  303 FORMAT('      DATAPLOT IS UNABLE TO COMPUTE NORCDF FOR VALUES',
     1       ' OUTSIDE THE RANGE (',E15.7,',',E15.7,')') 
  305 FORMAT('      THE VALUE OF THE INPUT ARGUMENT IS ',E15.7)
C
      CALL NODCDF(DBLE(-X),DTERM1)
      DTERM2=DBLE(P)*DLOG(DTERM1)
      DTERM3=DEXP(DTERM2)
      DTERM4=1.0D0-DTERM3
      CDF=REAL(DTERM4)
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE PNRCHA(X,P,S,HAZ)
C
C     NOTE--POWER-NORMAL PDF IS:
C              PNRPDF(X,U,S,P) = (P/S)*NORPDF((X-U)/S)*
C                                   NORCDF(-(X-U)/S))**(P-1)
C           STANDARD FORM OF THIS DISTRIBUTION IS:
C              PNRPDF(X,S,P) = (P/S)*NORPDF(X)*NORCDF(-X/S)**(P-1)
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--98/4
C     ORIGINAL VERSION--APRIL     1998.
C     UPDATED         --NOVEMBER  2001. FORCE SD PARAMETER TO BE 1
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C
      DOUBLE PRECISION DCDF
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      HAZ=0.0
      SD=1.0
C
      IF(P.LE.0.0)THEN
        WRITE(ICOUT,101)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,103)P
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
      IF(SD.LE.0.0)THEN
        WRITE(ICOUT,201)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,203)SD
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
  101 FORMAT('***** FATAL DIAGNOSTIC--THE POWER PARAMETER, P, IS ',
     1       '      NON-POSITIVE.')
  103 FORMAT('      THE VALUE OF P IS ',E15.7)
  201 FORMAT('***** FATAL DIAGNOSTIC--THE STANDARD DEVIATION ',
     1       'PARAMETER IS NON-POSITIVE.')
  203 FORMAT('      THE VALUE IS ',E15.7)
C
      Z=-X/SD
      CALL NODCDF(DBLE(Z),DCDF)
      IF(DCDF.GT.0.0D0)THEN
        HAZ=-REAL(DLOG(DCDF**DBLE(P)))
      ELSE
        HAZ=0.0
        WRITE(ICOUT,901)X
        CALL DPWRST('XXX','BUG ')
      ENDIF 
  901 FORMAT('***** ERROR: FOR X = ',E15.7,' THE POWER NORMAL CDF ',
     1'IS ESSENTIALLY 1.')
C
 9999 CONTINUE
      RETURN
      END
      subroutine pnrerr(icode,number)
C
C *   AUTHORS: Necip Doganaksoy and Wayne Nelson
C *   PURPOSE: Maximum likelihood fitting of the power-normal and
C *            -lognormal models to censored life or strength data
C *            from specimens of various sizes
C *   DOCUMENTATION: Wayne Nelson and Necip Doganaksoy, "A Computer
C *                  Program POWNOR for Fitting the Power-Normal and
C *                  -Lognormal Models to Life or Strength Data from
C *                  Specimens of Various Sizes", NISTIR 4760, 3/1992.
C *   PROJECT: 1990-91 ASA/NIST/NSF Fellowship
C
C     Modifed by Alan Heckert (6/2005) for incorporation into Dataplot.
C ERROR MESSAGES
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
C
      if (icode.eq.1)then
         WRITE(ICOUT,101)
  101    FORMAT('****** ERROR FROM POWER NORMAL MAXIMUM LIKELIHOOD:')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,103)
  103    FORMAT('       LENGTHS MUST BE POSITIVE.')
         CALL DPWRST('XXX','BUG ')
      elseif (icode.eq.2)then
         WRITE(ICOUT,101)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,203)
  203    FORMAT('       PARAMETER TYPES MUST BE 0 OR 1.')
         CALL DPWRST('XXX','BUG ')
      elseif (icode.eq.3)then
         WRITE(ICOUT,101)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,303)
  303    FORMAT('       VALUE OF THE PRINT VARIABLE MUST BE 0 OR 1.')
         CALL DPWRST('XXX','BUG ')
      elseif (icode.eq.4)then
         WRITE(ICOUT,101)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,403)NUMBER
  403    FORMAT('        INVALID DATA VALUE ENCOUNTERED ON ROW ',
     1          I8,'.')
         CALL DPWRST('XXX','BUG ')
      elseif (icode.eq.6)then
         WRITE(ICOUT,101)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,603)
  603    FORMAT('        THE INFORMATION MATRIX IS ILL-CONDITIONED.')
         CALL DPWRST('XXX','BUG ')
      elseif (icode.eq.7)then
         WRITE(ICOUT,101)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,703)
  703    FORMAT('        CONVERGENCE PROBLEMS ENCOUNTERED DURING ',
     1          'MAXIMIZATION OF THE LOGLIKELIHOOD FUNCTION.')
         CALL DPWRST('XXX','BUG ')
      elseif (icode.eq.8)then
         WRITE(ICOUT,101)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,803)
  803    FORMAT('       MORE THAN TEN LENGTHS WERE SPECIFIED.')
         CALL DPWRST('XXX','BUG ')
      elseif (icode.eq.9)then
         WRITE(ICOUT,101)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,903)
  903    FORMAT('        VALUE OF THE LOG TRANSFORMATION VARIABLE ',
     1          'MUST BE 0 OR 1.')
         CALL DPWRST('XXX','BUG ')
      endif
C
CCCCC close (unit=1,status='save')
CCCCC close (unit=8,status='save')
      WRITE(ICOUT,101)
      CALL DPWRST('XXX','BUG ')
C
      return
      end
      SUBROUTINE PNRHAZ(X,P,S,HAZ)
C
C     NOTE--POWER-NORMAL PDF IS:
C              PNRPDF(X,U,S,P) = (P/S)*NORPDF((X-U)/S)*
C                                   NORCDF(-(X-U)/S))**(P-1)
C           STANDARD FORM OF THIS DISTRIBUTION IS:
C              PNRPDF(X,S,P) = (P/S)*NORPDF(X)*NORCDF(-X/S)**(P-1)
C           HAZARD FUNCTION IS:
C              H(X,S,P) = P*NORHAZ(Z)
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--98/4
C     ORIGINAL VERSION--APRIL     1998.
C     UPDATED         --NOVEMBER  2001. FORCE SD PARAMETER TO BE 1
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C
      DOUBLE PRECISION DPDF
      DOUBLE PRECISION DCDF
      DOUBLE PRECISION DHAZ
      DOUBLE PRECISION DNORHZ
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      HAZ=0.0
      SD=1.0
C
      IF(P.LE.0.0)THEN
        WRITE(ICOUT,101)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,103)P
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
      IF(SD.LE.0.0)THEN
        WRITE(ICOUT,201)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,203)SD
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
  101 FORMAT('***** FATAL DIAGNOSTIC--THE POWER PARAMETER, P, IS ',
     1       '      NON-POSITIVE.')
  103 FORMAT('      THE VALUE OF P IS ',E15.7)
  201 FORMAT('***** FATAL DIAGNOSTIC--THE STANDARD DEVIATION ',
     1       'PARAMETER IS NON-POSITIVE.')
  203 FORMAT('      THE VALUE IS ',E15.7)
C
      Z=X/SD
      CALL NODPDF(DBLE(Z),DPDF)
      CALL NODCDF(DBLE(-Z),DCDF)
      IF(DCDF.GT.0.0D0)THEN
        DNORHZ=(DPDF/DCDF)/DBLE(SD)
        DHAZ=DBLE(P)*DNORHZ
        HAZ=REAL(DHAZ)
      ELSE
        HAZ=0.0
        WRITE(ICOUT,901)X
        CALL DPWRST('XXX','BUG ')
      ENDIF 
  901 FORMAT('***** ERROR: FOR X = ',E15.7,' THE NORMAL CDF IS ',
     1'ESSENTIALLY 0.')
C
 9999 CONTINUE
      RETURN
      END
      DOUBLE PRECISION FUNCTION PNRFUN(x,npar)
C
C *   AUTHORS: Necip Doganaksoy and Wayne Nelson
C *   PURPOSE: Maximum likelihood fitting of the power-normal and
C *            -lognormal models to censored life or strength data
C *            from specimens of various sizes
C *   DOCUMENTATION: Wayne Nelson and Necip Doganaksoy, "A Computer
C *                  Program POWNOR for Fitting the Power-Normal and
C *                  -Lognormal Models to Life or Strength Data from
C *                  Specimens of Various Sizes", NISTIR 4760, 3/1992.
C *   PROJECT: 1990-91 ASA/NIST/NSF Fellowship
C
C LOGLIKELIHOOD FUNCTION
C
      implicit DOUBLE PRECISION (a-h,o-z)
      DOUBLE PRECISION x(npar)
      DOUBLE PRECISION timel(10000)
      DOUBLE PRECISION timeu(10000)
      DOUBLE PRECISION rlengt(10000)
C
      common /PNRDAT/ timel,timeu,rlengt,iss
      common /PNRFVA/ rmufix,rlnsig,rlnfix
      common /PNRVAR/ mutype,lnsigt,lntype
C
CCCCC external dnordf
      external alnorm
C
      ipar=0
      if (mutype.eq.0) then
         ipar=ipar+1
         rmu=x(ipar)
      else
         rmu=rmufix
      endif

      if (lnsigt.eq.0) then
         ipar=ipar+1
         rlnsig=x(ipar)
      else
         rlnsig=rlnsig
      endif

      if (lntype.eq.0) then
         ipar=ipar+1
         rlnlno=x(ipar)
      else
         rlnlno=rlnfix
      endif

      zero=0.0d0
      pi=4.d0*(datan(.5d0)+datan(1.d0/3.d0))
      accum=0.d0

      do 100 i=1,iss

c complete data
         if (timel(i).eq.timeu(i))then
            z=(timel(i)-rmu)/exp(rlnsig)
            z=ztran(z)
            phi=((2.d0*pi)**(-.5d0))*exp(-.5d0*z*z)
            relphi=alnorm(-z,.false.)
            rho=rlengt(i)/exp(rlnlno)
            rlogli=-log(rlengt(i))+rlnlno+rlnsig+(z*z)/2.d0-
     1              (rho-1.d0)*log(relphi)
c
c right censored data
c
         elseif (timeu(i).eq.1e10)then
            z=(timel(i)-rmu)/exp(rlnsig)
            z=ztran(z)
            relphi=alnorm(-z,.false.)
            rho=rlengt(i)/exp(rlnlno)
            rlogli=-rho*log(relphi)
c
c left censored data
c
         elseif (timel(i).eq.-1e10)then
            z=(timeu(i)-rmu)/exp(rlnsig)
            z=ztran(z)
            relphi=alnorm(-z,.false.)
            rho=rlengt(i)/exp(rlnlno)
            rlogli=-log(1.d0-(relphi**rho))
c
c interval data
c
         elseif (timeu(i).gt.timel(i))then
            zl=(timel(i)-rmu)/exp(rlnsig)
            zl=ztran(zl)
            zu=(timeu(i)-rmu)/exp(rlnsig)
            zu=ztran(zu)
            relphl=alnorm(-zl,.false.)
            relphu=alnorm(-zu,.false.)
            rho=rlengt(i)/exp(rlnlno)
            rlogli=-log((relphl**rho)-(relphu**rho))
         endif
c
         accum=accum+rlogli
100   continue
c
      pnrfun=accum
c
      return
      end
      SUBROUTINE PNRPDF(X,P,PDF)
CCCCC SUBROUTINE PNRPDF(X,P,SD,PDF)
CCCCC SD IS ACTUALLY A SCALE PARAMETER IN THIS CASE.  DON'T USE
CCCCC IT COMPUTATION OF STANDARD FORM OF DISTRIBUTION.
C
C     NOTE--POWER-NORMAL PDF IS:
C              PNRPDF(X,U,S,P) = (P/S)*NORPDF((X-U)/S)*
C                                   NORCDF(-(X-U)/S))**(P-1)
C           STANDARD FORM OF THIS DISTRIBUTION IS:
C              PNRPDF(X,P) = P*NORPDF(X)*NORCDF(-X)**(P-1)
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--95/4
C     ORIGINAL VERSION--APRIL     1995.
C     UPDATED         --NOVEMBER  2001.  MODIFY TO NOT USE SD, SOME
C                                        OTHER COMPUTATIONAL
C                                        MODIFICATIONS.
C
CCCCC NOTE: THE NODCDF ROUTINE (BASED ON ALNORM FROM APPLIED
CCCCC       STATISTICS) RETURNS 0 FOR X < -18.66 WHICH IN TURN
CCCCC       MAKES THIS PDF=0.
C                                       
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C
      DOUBLE PRECISION DTERM1
CCCCC DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
      DOUBLE PRECISION DTERM4
      DOUBLE PRECISION DTERM5
CCCCC JULY 1995.  ADD FOLLOWING LINE.
      DOUBLE PRECISION DPDF
      DOUBLE PRECISION DEPS
      DOUBLE PRECISION DEPS2
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      INCLUDE 'DPCOMC.INC'
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DATA DEPS/0.1D-300/
      DATA DEPS2/-0.1D35/
C
C-----START POINT-----------------------------------------------------
C
      PDF=0.0
      XMAXVL=38.0
C
      IF(P.LE.0.0)THEN
        WRITE(ICOUT,101)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,103)P
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
      IF(ABS(X).GT.XMAXVL)THEN
        WRITE(ICOUT,301)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,303)-XMAXVL,XMAXVL
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,305)X
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
CCCCC IF(SD.LE.0.0)THEN
CCCCC   WRITE(ICOUT,201)
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   WRITE(ICOUT,203)SD
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   GOTO9999
CCCCC ENDIF
  101 FORMAT('***** FATAL DIAGNOSTIC--THE POWER PARAMETER, P, IS ',
     1       '      NON-POSITIVE.')
  103 FORMAT('      THE VALUE OF P IS ',E15.7)
CC201 FORMAT('***** FATAL DIAGNOSTIC--THE STANDARD DEVIATION ',
CCCCC1       'PARAMETER IS NON-POSITIVE.')
  203 FORMAT('      THE VALUE IS ',E15.7)
  301 FORMAT('***** FATAL DIAGNOSTIC--FOR THE PNRPDF FUNCTION--')
  303 FORMAT('      DATAPLOT IS UNABLE TO COMPUTE NORCDF FOR VALUES',
     1       ' OUTSIDE THE RANGE (',E15.7,',',E15.7,')') 
  305 FORMAT('      THE VALUE OF THE INPUT ARGUMENT IS ',E15.7)
C
CCCCC DEPS=D1MACH(1)
C
      DTERM1=DLOG(DBLE(P))
CCCCC DTERM2=DLOG(DBLE(SD))
CCCCC TERM1=X/SD
C
      IF(ABS(X).GT.38.D0)THEN
        DTERM3=DEPS
      ELSE
        CALL NODPDF(DBLE(X),DTERM3)
      ENDIF
      IF(DTERM3.LE.DEPS)DTERM3=DEPS
      DTERM3=DLOG(DTERM3)
CCCCC TERM3=-TERM1
      IF(X.GT.DBLE(XMAXVL))THEN
        CALL NODCDF(DBLE(-XMAXVL),DTERM4)
      ELSEIF(X.LT.-DBLE(XMAXVL))THEN
        CALL NODCDF(DBLE(XMAXVL),DTERM4)
      ELSE
        CALL NODCDF(DBLE(-X),DTERM4)
      ENDIF
      IF(DTERM4.LE.DEPS)DTERM4=DEPS
      DTERM4=DBLE(P-1.0)*DLOG(DTERM4)
      DTERM5=DTERM1 + DTERM3 + DTERM4
      IF(DTERM5.LT.DEPS2)THEN
        PDF=0.0
      ELSEIF(DTERM5.GT.-DEPS2)THEN
        PDF=0.0
      ELSE
        DPDF=DEXP(DTERM5)
        PDF=REAL(DPDF)
      ENDIF
      GOTO9999
C
 9999 CONTINUE
      RETURN
      END
      subroutine pnrper(p1,tp2,tp3,vp1,vtp2,vtp3,cp1tp2,cp1tp3,ctp2tp3,
     *      slengt,noleng,allfix,
     *      icapty,icapsw)
c
C *   AUTHORS: Necip Doganaksoy and Wayne Nelson
C *   PURPOSE: Maximum likelihood fitting of the power-normal and
C *            -lognormal models to censored life or strength data
C *            from specimens of various sizes
C *   DOCUMENTATION: Wayne Nelson and Necip Doganaksoy, "A Computer
C *                  Program POWNOR for Fitting the Power-Normal and
C *                  -Lognormal Models to Life or Strength Data from
C *                  Specimens of Various Sizes", NISTIR 4760, 3/1992.
C *   PROJECT: 1990-91 ASA/NIST/NSF Fellowship
C
c ML ESTIMATES OF PERCENTILES AND THEIR CONFIDENCE LIMITS
c
      implicit double precision (a-h,o-z)
      double precision f(16),slengt(15)
      dimension pctpri(16)
      character*4 pctpri
      logical allfix
CCCCC external dnorin
C
      character*4 ICAPSW
      character*4 ICAPTY
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      REAL CPUMIN
      REAL CPUMAX
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
c
      data f /.001d0, .002d0, .005d0, .01d0, .02d0, .05d0,.1d0,
     *     .3d0, .5d0, .7d0, .9d0, .95d0, .98d0, .99d0, .995d0,
     *     .999d0/
      data pctpri /'0.1','0.2','0.5','1','2','5','10','30','50','70',
     *                '90', '95','98','99','99.5','99.9'/
      p2=exp(tp2)
      p3=exp(tp3)
      pinum=4.d0*(datan(.5d0)+datan(1.d0/3.d0))
      const=(2.d0*pinum)**(-.5d0)
      if(icapsw.eq.'ON' .and. icapty.eq.'HTML')then
      elseif(icapsw.eq.'ON' .and. icapty.eq.'LATE')then
      elseif(icapsw.eq.'ON' .and. icapty.eq.'RTF ')then
      else
        write(icout,999)
  999   format(1x)
        CALL DPWRST('XXX','WRIT')
        write(icout,999)
        CALL DPWRST('XXX','WRIT')
        if(noleng.ne.0)then
          if (allfix) then
            write(icout,4201)
 4201       format('PERCENTILE ESTIMATES')
            CALL DPWRST('XXX','WRIT')
          else
            write(icout,4203)
 4203       format('MAXIMUM LIKELIHOOD ESTIMATES FOR DISTRIBUTION ',
     1            'PERCENTILES')
            CALL DPWRST('XXX','WRIT')
            write(icout,4205)
 4205       format('WITH APPROXIMATE 95% CONFIDENCE LIMITS')
            CALL DPWRST('XXX','WRIT')
          endif
        endif
        do 177 maini=1,noleng
          write(icout,999)
          CALL DPWRST('XXX','WRIT')
          write(icout,4211)SLENGT(MAINI)
 4211     format('LENGTH = ',F15.4)
          CALL DPWRST('XXX','WRIT')
          write(icout,999)
          CALL DPWRST('XXX','WRIT')
          if(allfix)then
            write(icout,4221)
 4221       format('PCT.       ESTIMATE')
            CALL DPWRST('XXX','WRIT')
          else
            write(icout,4223)
 4223       format('PCT.    ML ESTIMATE    LOWER LIMIT     ',
     1             'UPPER LIMIT     STD. ERROR')
            CALL DPWRST('XXX','WRIT')
          endif
          do 100 i=1,16,1
            fhp=1.d0-((1.d0-f(i))**(p3/slengt(maini)))
CNIST       zfhp=dnorin(fhp)
            CALL NODPPF(FHP,ZFHP)
            rmlper=p1+zfhp*p2
            if (allfix) then
              write(icout,4231)pctpri(i),rmlper
 4231         format(1X,A4,3X,F12.4)
              CALL DPWRST('XXX','WRIT')
            else
              phi=const*exp(-.5d0*zfhp*zfhp)
              term=-(p2*(1.d0-fhp)*p3*
     1             log(1.d0-f(i)))/(slengt(maini)*phi)
              varper=vp1+((zfhp*p2)**2.d0)*vtp2+
     1               (term*term*vtp3)+2.d0*zfhp*p2*cp1tp2
     1               +2.d0*term*cp1tp3+2.d0*zfhp*p2*term*ctp2tp3
              rstd=varper**.5d0
              rlow=rmlper-1.96d0*rstd
              rup=rmlper+1.96d0*rstd
              write(icout,4236)pctpri(i),rmlper,rlow,rup,rstd
 4236         format(1x,a4,3x,f12.4,3x,f12.4,3x,f12.4,3x,f12.4)
              CALL DPWRST('XXX','WRIT')
            endif
  100     continue
  177   continue
      endif
c
      return
      end
      SUBROUTINE PNRPPF(P,POWER,S,PPF)
C
C     NOTE--POWER-NORMAL PPF IS:
C              PNRPPF(P,U,SD,POWER) = U+Zf*SD
C           WHERE Zf = NORPPF(1-(1-P)**(1/POWER))
C           STANDARD FORM OF THIS DISTRIBUTION IS:
C              PNRPPF(P,U,SD,POWER) = Zf
C           FOR CONSISTENCY WITH PNRPDF ROUTINE, ALLOW SD AS 
C           OPTIONAL PARAMETER.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--95/4
C     ORIGINAL VERSION--APRIL     1995.
C     MODIFIED        --JUNE      1995. CHECK FOR MAXIMUM VALUE
C     MODIFIED        --SEPTEMBER 1995. BETTER HANDLING OF CASE WHEN
C                                       NORPPF CALLED WITH VALUE CLOSE
C                                       TO 1.
C     MODIFIED        --NOVEMBER  2001. ALGORITHM UPDATES
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
      DOUBLE PRECISION DTERM4
      DOUBLE PRECISION DTERM5
CCCCC DOUBLE PRECISION DTMIN, DTMAX, DEPS
      DOUBLE PRECISION DTMIN, DEPS
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOMC.INC'
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DATA DEPS/1.0D-16/
C
C-----START POINT-----------------------------------------------------
C
      PPF=0.0
C
CCCCC NOVEMBER 2001: FORCE SD TO BE 1 (THIS IS ACTUALLY A SCALE
CCCCC PARAMETER, SO HANDLE IN THE STANDARD WAY).
C
      SD=1.0
      DTMIN=D1MACH(1)
C
      IF(P.LE.0.0 .OR. P.GE.1.0)THEN
        WRITE(ICOUT,1)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)P
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
        GOTO9999
      ENDIF
      IF(POWER.LE.0.0)THEN
        WRITE(ICOUT,101)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,203)POWER
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
      IF(SD.LE.0.0)THEN
        WRITE(ICOUT,201)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,203)SD
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
    1 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ',
     1' PNRPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
  101 FORMAT('***** FATAL DIAGNOSTIC--THE POWER PARAMETER IS ',
     1       '      NON-POSITIVE.')
  201 FORMAT('***** FATAL DIAGNOSTIC--THE STANDARD DEVIATION ',
     1       'PARAMETER IS NON-POSITIVE.')
  203 FORMAT('      THE VALUE IS ',E15.7)
C
      DTERM1= 1.0D0 - DBLE(P)
      DTERM2=1.0D0/DBLE(POWER)
      DTERM3=DTERM1**DTERM2
CCCCC SEPTEMBER 1995.  HANDLE CASE WHERE NORPPF CALLED WITH ARGUMENT
CCCCC CLOSE TO 1 BETTER.
      IF(DTERM3.LT.DEPS)THEN
        IF(DTERM3.LE.DTMIN)DTERM3=DTMIN
        CALL NODPPF(DTERM3,DTERM4)
        DTERM4=-DTERM4
      ELSE
        DTERM3=1.0D0 - DTERM3
        IF(DTERM3.LE.DTMIN)DTERM3=DTMIN
CCCCC JUNE 1995.  ADD FOLLOWING 2 LINES
CCCCC DTMAX=1.0D0-DEPS
CCCCC IF(DTERM3.GE.DTMAX)DTERM3=DTMAX
        CALL NODPPF(DTERM3,DTERM4)
      ENDIF
C
      DTERM5=DBLE(SD)*DTERM4
      PPF=REAL(DTERM5)
      GOTO9999
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE PNRRAN(N,P,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE POWER NORMAL DISTRIBUTION
C              WITH SHAPE PARAMETER VALUE = P.
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --P  = THE SINGLE PRECISION VALUE OF THE
C                                SHAPE PARAMETER.
C                                P 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 POWER NORMAL DISTRIBUTION
C             WITH TAIL LENGTH PARAMETER VALUE = P.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C                 --P 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                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--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(P.LE.0.0)THEN
        WRITE(ICOUT,15)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)P
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
    5 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ',
     1'PNRRAN SUBROUTINE IS NON-POSITIVE *****')
   15 FORMAT('***** FATAL ERROR--THE 2ND INPUT ARGUMENT TO THE ',
     1'PNRRAN SUBROUTINE IS NON-POSITIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
C
C     GENERATE N UNIFORM (0,1) RANDOM NUMBERS;
C
      CALL UNIRAN(N,ISEED,X)
C
C     GENERATE N POWER NORMAL DISTRIBUTION RANDOM NUMBERS
C     USING PERCENT POINT FUNCTION
C
      SD=1.0
      DO100I=1,N
        CALL PNRPPF(X(I),P,SD,XTEMP)
        X(I)=XTEMP
  100 CONTINUE
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE POICDF(X,ALAMBA,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE AT THE SINGLE PRECISION VALUE X
C              FOR THE POISSON DISTRIBUTION
C              WITH SINGLE PRECISION
C              TAIL LENGTH PARAMETER = ALAMBA.
C              THE POISSON DISTRIBUTION USED
C              HEREIN HAS MEAN = ALAMBA
C              AND STANDARD DEVIATION = SQRT(ALAMBA).
C              THIS DISTRIBUTION IS DEFINED FOR
C              ALL DISCRETE NON-NEGATIVE INTEGER  X--X = 0, 1, 2, ... .
C              THIS DISTRIBUTION HAS THE PROBABILITY FUNCTION
C              F(X) = EXP(-ALAMBA) * ALAMBA**X / X!.
C              THE POISSON DISTRIBUTION IS THE
C              DISTRIBUTION OF THE NUMBER OF EVENTS
C              IN THE INTERVAL (0,ALAMBA) WHEN
C              THE WAITING TIME BETWEEN EVENTS
C              IS EXPONENTIALLY DISTRIBUTED
C              WITH MEAN = 1 AND STANDARD DEVIATION = 1.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE
C                                AT WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE NON-NEGATIVE AND
C                                INTEGRAL-VALUED.
C                     --ALAMBA = THE SINGLE PRECISION VALUE
C                                OF THE TAIL LENGTH PARAMETER.
C                                ALAMBA 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
C             FOR THE POISSON DISTRIBUTION
C             WITH TAIL LENGTH PARAMETER = ALAMBA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE NON-NEGATIVE AND INTEGRAL-VALUED.
C                 --ALAMBA SHOULD BE POSITIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NORCDF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--DSQRT, DATAN.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     COMMENT--THE SINGLE PRECISION TAIL LENGTH
C              PARAMETER ALAMBA IS     NOT     RESTRICTED
C              TO ONLY INTEGER VALUES.
C              ALAMBA CAN BE SET TO ANY POSITIVE REAL
C              VALUE--INTEGER OR NON-INTEGER.
C            --NOTE THAT EVEN THOUGH THE INPUT
C              TO THIS CUMULATIVE
C              DISTRIBUTION FUNCTION SUBROUTINE
C              FOR THIS DISCRETE DISTRIBUTION
C              SHOULD (UNDER NORMAL CIRCUMSTANCES) BE A
C              DISCRETE INTEGER VALUE,
C              THE INPUT VARIABLE X IS SINGLE
C              PRECISION IN MODE.
C              X HAS BEEN SPECIFIED AS SINGLE
C              PRECISION SO AS TO CONFORM WITH THE DATAPAC
C              CONVENTION THAT ALL INPUT ****DATA****
C              (AS OPPOSED TO SAMPLE SIZE, FOR EXAMPLE)
C              VARIABLES TO ALL
C              DATAPAC SUBROUTINES ARE SINGLE PRECISION.
C              THIS CONVENTION IS BASED ON THE BELIEF THAT
C              1) A MIXTURE OF MODES (FLOATING POINT
C              VERSUS INTEGER) IS INCONSISTENT AND
C              AN UNNECESSARY COMPLICATION
C              IN A DATA ANALYSIS; AND
C              2) FLOATING POINT MACHINE ARITHMETIC
C              (AS OPPOSED TO INTEGER ARITHMETIC)
C              IS THE MORE NATURAL MODE FOR DOING
C              DATA ANALYSIS.
C     REFERENCES--JOHNSON AND KOTZ, DISCRETE
C                 DISTRIBUTIONS, 1969, PAGES 87-121,
C                 ESPECIALLY PAGE 114, FORMULA 93.
C               --HASTINGS AND PEACOCK, STATISTICAL
C                 DISTRIBUTIONS--A HANDBOOK FOR
C                 STUDENTS AND PRACTITIONERS, 1975,
C                 PAGE 112.
C               --NATIONAL BUREAU OF STANDARDS APPLIED MATHEMATICS
C                 SERIES 55, 1964, PAGE 941, FORMULAE 26.4.4 AND 26.4.5,
C                 AND PAGE 929.
C               --FELLER, AN INTRODUCTION TO PROBABILITY
C                 THEORY AND ITS APPLICATIONS, VOLUME 1,
C                 EDITION 2, 1957, PAGES 146-154.
C               --COX AND MILLER, THE THEORY OF STOCHASTIC
C                 PROCESSES, 1965, PAGE 7.
C               --GENERAL ELECTRIC COMPANY, TABLES OF THE
C                 INDIVIDUAL AND CUMULATIVE TERMS OF POISSON
C                 DISTRIBUTION, 1962.
C               --OWEN, HANDBOOK OF STATISTICAL
C                 TABLES, 1962, PAGES 259-261.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--82.6
C     ORIGINAL VERSION--NOVEMBER  1975.
C     UPDATED         --DECEMBER  1981.
C     UPDATED         --MAY       1982.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX,PI,CHI,SUM,TERM,AI,DGCDF
      DOUBLE PRECISION DSQRT,DEXP
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      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.14159265358979D0/
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(ALAMBA.LE.0.0)GOTO50
      IF(X.LT.0.0)GOTO55
      INTX=X+0.0001
      FINTX=INTX
      DEL=X-FINTX
      IF(DEL.LT.0.0)DEL=-DEL
      IF(DEL.GT.0.001)GOTO60
      GOTO90
   50 WRITE(ICOUT,15)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)ALAMBA
      CALL DPWRST('XXX','BUG ')
      CDF=0.0
      RETURN
   55 WRITE(ICOUT,4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)X
      CALL DPWRST('XXX','BUG ')
      CDF=0.0
      RETURN
   60 WRITE(ICOUT,5)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)X
      CALL DPWRST('XXX','BUG ')
   90 CONTINUE
    4 FORMAT('***** NON-FATAL DIAGNOSTIC--THE 1ST INPUT ARGUMENT ',
     1'TO THE POICDF SUBROUTINE IS NEGATIVE *****')
    5 FORMAT('***** NON-FATAL DIAGNOSTIC--THE 1ST INPUT ARGUMENT ',
     1'TO THE POICDF SUBROUTINE IS NON-INTEGRAL *****')
   15 FORMAT('***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE ',
     1'POICDF SUBROUTINE IS NON-POSITIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
C
C     EXPRESS THE POISSON CUMULATIVE DISTRIBUTION
C     FUNCTION IN TERMS OF THE EQUIVALENT CHI-SQUARED
C     CUMULATIVE DISTRIBUTION FUNCTION,
C     AND THEN EVALUATE THE LATTER.
C
      DX=ALAMBA
      DX=2.0D0*DX
      NU=X+0.0001
      NU=2*(1+NU)
C
  110 CHI=DSQRT(DX)
      IEVODD=NU-2*(NU/2)
      IF(IEVODD.EQ.0)GOTO120
C
      SUM=0.0D0
      TERM=1.0/CHI
      IMIN=1
      IMAX=NU-1
      GOTO130
C
  120 SUM=1.0D0
      TERM=1.0D0
      IMIN=2
      IMAX=NU-2
C
  130 IF(IMIN.GT.IMAX)GOTO160
      DO100I=IMIN,IMAX,2
      AI=I
      TERM=TERM*(DX/AI)
      SUM=SUM+TERM
  100 CONTINUE
C
  160 SUM=SUM*DEXP(-DX/2.0D0)
      IF(IEVODD.EQ.0)GOTO170
      SUM=(DSQRT(2.0D0/PI))*SUM
      SPCHI=CHI
      CALL NORCDF(SPCHI,GCDF)
      DGCDF=GCDF
      SUM=SUM+2.0D0*(1.0D0-DGCDF)
  170 CDF=SUM
C
      RETURN
      END
      REAL FUNCTION POIFUN(ALAMB)
C
C     PURPOSE--DPMLPO CALLS FZERO TO FIND A ROOT FOR ONE OF
C              THE FOLLOWING FUNCTIONS:
C
C                 POICDF(S;N*LAMBDAL) - (1 - ALPHA/2) = 0
C                 POICDF(S;N*LAMBDAU) - (ALPHA/2)     = 0
C
C              WITH
C
C                  S        = SUM[i=1 to n][X(i)]
C                  N        = SAMPLE SIZE
C                  LAMBDAL  = LOWER CONFIDENCE LEVEL FOR LAMBDA
C                  LAMBDAU  = UPPER CONFIDENCE LEVEL FOR LAMBDA
C                  ALPHA    = DESIRED SIGNIFICANCE LEVEL
C
C              DPMLPO IS TRYING TO DETERMINE AN CONFIDENCE INTERVAL
C              FOR LAMBDA.  THE VALUES FOR S, N, (1-ALPHA/2),
C              (OR ALPHA/2) ARE PASSED IN VIA A COMMON BLOCK.
C
C     INPUT  ARGUMENTS--ALAMB  = THE SINGLE PRECISION VALUE THAT
C                                SPECIFIES THE SHAPE PARAMETER FOR
C                                THE POISSON DISTRIBUTION.
C     OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE POIFUN.
C     PRINTING--NONE.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--POICDF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--KARL BURY (1999). "STATISTICAL DISTRIBUTIONS IN
C                 ENGINEERING", CAMBRIDGE UNIVERSITY PRESS,
C                 PP. 105-106.
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--2005.8
C     ORIGINAL VERSION--SEPTEMBER 2005.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      COMMON/POICOM/N,S,CONST
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
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 POICDF(S,REAL(N)*ALAMB,CDF)
      POIFUN=CDF - CONST
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE POIPPF(P,ALAMBA,PPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE AT THE SINGLE PRECISION VALUE P
C              FOR THE POISSON DISTRIBUTION
C              WITH SINGLE PRECISION
C              TAIL LENGTH PARAMETER = ALAMBA.
C              THE POISSON DISTRIBUTION USED
C              HEREIN HAS MEAN = ALAMBA
C              AND STANDARD DEVIATION = SQRT(ALAMBA).
C              THIS DISTRIBUTION IS DEFINED FOR
C              ALL DISCRETE NON-NEGATIVE INTEGER  X--X = 0, 1, 2, ... .
C              THIS DISTRIBUTION HAS THE PROBABILITY FUNCTION
C              F(X) = EXP(-ALAMBA) * ALAMBA**X / X!.
C              THE POISSON DISTRIBUTION IS THE
C              DISTRIBUTION OF THE NUMBER OF EVENTS
C              IN THE INTERVAL (0,ALAMBA) WHEN
C              THE WAITING TIME BETWEEN EVENTS
C              IS EXPONENTIALLY DISTRIBUTED
C              WITH MEAN = 1 AND STANDARD DEVIATION = 1.
C              NOTE THAT THE PERCENT POINT FUNCTION OF A DISTRIBUTION
C              IS IDENTICALLY THE SAME AS THE INVERSE CUMULATIVE
C              DISTRIBUTION FUNCTION OF THE DISTRIBUTION.
C     INPUT  ARGUMENTS--P      = THE SINGLE PRECISION VALUE
C                                (BETWEEN 0.0 (INCLUSIVELY)
C                                AND 1.0 (EXCLUSIVELY))
C                                AT WHICH THE PERCENT POINT
C                                FUNCTION IS TO BE EVALUATED.
C                     --ALAMBA = THE SINGLE PRECISION VALUE
C                                OF THE TAIL LENGTH PARAMETER.
C                                ALAMBA SHOULD BE POSITIVE.
C     OUTPUT ARGUMENTS--PPF    = THE SINGLE PRECISION PERCENT
C                                POINT FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PERCENT POINT  .
C             FUNCTION VALUE PPF
C             FOR THE POISSON DISTRIBUTION
C             WITH TAIL LENGTH PARAMETER = ALAMBA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--ALAMBA SHOULD BE POSITIVE.
C                 --P SHOULD BE BETWEEN 0.0 (INCLUSIVELY)
C                   AND 1.0 (EXCLUSIVELY).
C     OTHER DATAPAC   SUBROUTINES NEEDED--NORPPF, POICDF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--SQRT, DEXP.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION AND DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     COMMENT--THE SINGLE PRECISION TAIL LENGTH
C              PARAMETER ALAMBA IS     NOT     RESTRICTED
C              TO ONLY INTEGER VALUES.
C              ALAMBA CAN BE SET TO ANY POSITIVE REAL
C              VALUE--INTEGER OR NON-INTEGER.
C            --NOTE THAT EVEN THOUGH THE OUTPUT
C              FROM THIS DISCRETE DISTRIBUTION
C              PERCENT POINT FUNCTION
C              SUBROUTINE MUST NECESSARILY BE A
C              DISCRETE INTEGER VALUE,
C              THE OUTPUT VARIABLE PPF IS SINGLE
C              PRECISION IN MODE.
C              PPF HAS BEEN SPECIFIED AS SINGLE
C              PRECISION SO AS TO CONFORM WITH THE DATAPAC
C              CONVENTION THAT ALL OUTPUT VARIABLES FROM ALL
C              DATAPAC SUBROUTINES ARE SINGLE PRECISION.
C              THIS CONVENTION IS BASED ON THE BELIEF THAT
C              1) A MIXTURE OF MODES (FLOATING POINT
C              VERSUS INTEGER) IS INCONSISTENT AND
C              AN UNNECESSARY COMPLICATION
C              IN A DATA ANALYSIS; AND
C              2) FLOATING POINT MACHINE ARITHMETIC
C              (AS OPPOSED TO INTEGER ARITHMETIC)
C              IS THE MORE NATURAL MODE FOR DOING
C              DATA ANALYSIS.
C     REFERENCES--JOHNSON AND KOTZ, DISCRETE
C                 DISTRIBUTIONS, 1969, PAGES 87-121,
C                 ESPECIALLY PAGE 102, FORMULA 36.1.
C               --HASTINGS AND PEACOCK, STATISTICAL
C                 DISTRIBUTIONS--A HANDBOOK FOR
C                 STUDENTS AND PRACTITIONERS, 1975,
C                 PAGES 108-113.
C               --NATIONAL BUREAU OF STANDARDS APPLIED MATHEMATICS
C                 SERIES 55, 1964, PAGE 929.
C               --FELLER, AN INTRODUCTION TO PROBABILITY
C                 THEORY AND ITS APPLICATIONS, VOLUME 1,
C                 EDITION 2, 1957, PAGES 146-154.
C               --COX AND MILLER, THE THEORY OF STOCHASTIC
C                 PROCESSES, 1965, PAGE 7.
C               --GENERAL ELECTRIC COMPANY, TABLES OF THE
C                 INDIVIDUAL AND CUMULATIVE TERMS OF POISSON
C                 DISTRIBUTION, 1962.
C               --OWEN, HANDBOOK OF STATISTICAL
C                 TABLES, 1962, PAGES 259-261.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--82.6
C     ORIGINAL VERSION--NOVEMBER  1975.
C     UPDATED         --OCTOBER   1978.
C     UPDATED         --NOVEMBER  1981.
C     UPDATED         --DECEMBER  1981.
C     UPDATED         --FEBRUARY  1982.
C     UPDATED         --MARCH     1982.
C     UPDATED         --MAY       1982.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DLAMBA
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(P.LT.0.0.OR.P.GE.1.0)GOTO50
      IF(ALAMBA.LE.0.0)GOTO55
      GOTO90
   50 WRITE(ICOUT,1)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)P
      CALL DPWRST('XXX','BUG ')
      PPF=0.0
      RETURN
   55 WRITE(ICOUT,15)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)ALAMBA
      CALL DPWRST('XXX','BUG ')
      PPF=0.0
      RETURN
   90 CONTINUE
    1 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ',
     1'POIPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL')
   15 FORMAT('***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE ',
     1'POIPPF SUBROUTINE IS NON-POSITIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
      DLAMBA=ALAMBA
      PPF=0.0
      IX0=0
      IX1=0
      IX2=0
      P0=0.0
      P1=0.0
      P2=0.0
C
C     TREAT CERTAIN SPECIAL CASES IMMEDIATELY--
C     1) P = 0.0
C     2) PPF = 0
C
      IF(P.EQ.0.0)GOTO110
      PF0=DEXP(-DLAMBA)
      IF(P.LE.PF0)GOTO110
      GOTO190
  110 PPF=0.0
      RETURN
  190 CONTINUE
C
C     DETERMINE AN INITIAL APPROXIMATION TO THE POISSON
C     PERCENT POINT BY USE OF THE NORMAL APPROXIMATION
C     TO THE POISSON.
C     (SEE JOHNSON AND KOTZ, DISCRETE DISTRIBUTIONS,
C     PAGE 102, FORMULA 36.1).
C
      AMEAN=ALAMBA
      SD=SQRT(ALAMBA)
      CALL NORPPF(P,ZPPF)
      X2=AMEAN-1.0+ZPPF*SD
      IX2=X2
C
C     CHECK AND MODIFY (IF NECESSARY) THIS INITIAL
C     ESTIMATE OF THE PERCENT POINT
C     TO ASSURE THAT IT BE NON-NEGATIVE.
C
      IF(IX2.LT.0)IX2=0
C
C     DETERMINE UPPER AND LOWER BOUNDS ON THE DESIRED
C     PERCENT POINT BY ITERATING OUT (BOTH BELOW AND ABOVE)
C     FROM THE ORIGINAL APPROXIMATION AT STEPS
C     OF 1 STANDARD DEVIATION.
C     THE RESULTING BOUNDS WILL BE AT MOST
C     1 STANDARD DEVIATION APART.
C
      IX0=0
      IX1=INT(10.0**7 + 0.01)
      ISD=SD+1.0
      X2=IX2
      CALL POICDF(X2,ALAMBA,P2)
C
      IF(P2.LT.P)GOTO210
      GOTO250
C
  210 CONTINUE
      IX0=IX2
      I=1
  215 CONTINUE
      IX2=IX0+ISD
      IF(IX2.GE.IX1)GOTO275
      X2=IX2
      CALL POICDF(X2,ALAMBA,P2)
      IF(P2.GE.P)GOTO230
      IX0=IX2
  220 CONTINUE
      I=I+1
      IF(I.LE.1000000)GOTO215
      WRITE(ICOUT,249)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,222)
      CALL DPWRST('XXX','BUG ')
      GOTO950
  230 IX1=IX2
      GOTO275
C
  250 CONTINUE
      IX1=IX2
      I=1
  255 CONTINUE
      IX2=IX1-ISD
      IF(IX2.LE.IX0)GOTO275
      X2=IX2
      CALL POICDF(X2,ALAMBA,P2)
      IF(P2.LT.P)GOTO270
      IX1=IX2
  260 CONTINUE
      I=I+1
      IF(I.LE.1000000)GOTO255
      WRITE(ICOUT,249)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,262)
      CALL DPWRST('XXX','BUG ')
      GOTO950
  270 IX0=IX2
C
  275 IF(IX0.EQ.IX1)GOTO280
      GOTO295
  280 IF(IX0.EQ.0)GOTO285
      WRITE(ICOUT,249)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,282)
      CALL DPWRST('XXX','BUG ')
      GOTO950
  285 IX1=IX1+1
      GOTO295
  295 CONTINUE
C
C     COMPUTE POISSON PROBABILITIES FOR THE
C     DERIVED LOWER AND UPPER BOUNDS.
C
      X0=IX0
      X1=IX1
      CALL POICDF(X0,ALAMBA,P0)
      CALL POICDF(X1,ALAMBA,P1)
C
C     CHECK THE PROBABILITIES FOR PROPER ORDERING
C
      IF(P0.LT.P.AND.P.LE.P1)GOTO490
      IF(P0.EQ.P)GOTO410
      IF(P1.EQ.P)GOTO420
      IF(P0.GT.P1)GOTO430
      IF(P0.GT.P)GOTO440
      IF(P1.LT.P)GOTO450
      WRITE(ICOUT,249)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,401)
      CALL DPWRST('XXX','BUG ')
      GOTO950
  410 PPF=IX0
      RETURN
  420 PPF=IX1
      RETURN
  430 WRITE(ICOUT,249)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,431)
      CALL DPWRST('XXX','BUG ')
      GOTO950
  440 WRITE(ICOUT,249)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,441)
      CALL DPWRST('XXX','BUG ')
      GOTO950
  450 WRITE(ICOUT,249)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,451)
      CALL DPWRST('XXX','BUG ')
      GOTO950
  490 CONTINUE
C
C     THE STOPPING CRITERION IS THAT THE LOWER BOUND
C     AND UPPER BOUND ARE EXACTLY 1 UNIT APART.
C     CHECK TO SEE IF IX1 = IX0 + 1;
C     IF SO, THE ITERATIONS ARE COMPLETE;
C     IF NOT, THEN BISECT, COMPUTE PROBABILIIES,
C     CHECK PROBABILITIES, AND CONTINUE ITERATING
C     UNTIL IX1 = IX0 + 1.
C
  300 IX0P1=IX0+1
      IF(IX1.EQ.IX0P1)GOTO690
      IX2=(IX0+IX1)/2
      IF(IX2.EQ.IX0)GOTO610
      IF(IX2.EQ.IX1)GOTO620
      X2=IX2
      CALL POICDF(X2,ALAMBA,P2)
      IF(P0.LT.P2.AND.P2.LT.P1)GOTO630
      IF(P2.LE.P0)GOTO640
      IF(P2.GE.P1)GOTO650
  610 WRITE(ICOUT,249)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,611)
      CALL DPWRST('XXX','BUG ')
      GOTO950
  620 WRITE(ICOUT,249)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,611)
      CALL DPWRST('XXX','BUG ')
      GOTO950
  630 IF(P2.LE.P)GOTO635
      IX1=IX2
      P1=P2
      GOTO300
  635 IX0=IX2
      P0=P2
      GOTO300
  640 WRITE(ICOUT,249)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,641)
      CALL DPWRST('XXX','BUG ')
      GOTO950
  650 WRITE(ICOUT,249)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,651)
      CALL DPWRST('XXX','BUG ')
      GOTO950
  690 PPF=IX1
      IF(P0.EQ.P)PPF=IX0
      RETURN
C
  950 WRITE(ICOUT,240)IX0,P0
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,241)IX1,P1
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,242)IX2,P2
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,244)P
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,245)ALAMBA
      CALL DPWRST('XXX','BUG ')
      RETURN
C
  222 FORMAT(43HNO UPPER BOUND FOUND AFTER 10**7 ITERATIONS)
  240 FORMAT(9HIX0    = ,I8,10X,5HP0 = ,F14.7)
  241 FORMAT(9HIX1    = ,I8,10X,5HP1 = ,F14.7)
  242 FORMAT(9HIX2    = ,I8,10X,5HP2 = ,F14.7)
  244 FORMAT(9HP      = ,F14.7)
  245 FORMAT(9HALAMBA = ,F14.7)
  249 FORMAT('***** INTERNAL ERROR IN POIPPF SUBROUTINE *****')
  262 FORMAT(43HNO LOWER BOUND FOUND AFTER 10**7 ITERATIONS)
  282 FORMAT(31HLOWER AND UPPER BOUND IDENTICAL)
  401 FORMAT(39HIMPOSSIBLE BRANCH CONDITION ENCOUNTERED)
  431 FORMAT(42HLOWER BOUND PROBABILITY (P0) GREATER THAN ,
     1 28HUPPER BOUND PROBABILITY (P1))
  441 FORMAT(42HLOWER BOUND PROBABILITY (P0) GREATER THAN ,
     1 21HINPUT PROBABILITY (P))
  451 FORMAT(42HUPPER BOUND PROBABILITY (P1) LESS    THAN ,
     1 21HINPUT PROBABILITY (P))
  611 FORMAT(39HBISECTION VALUE (X2) = LOWER BOUND (X0))
  621 FORMAT(39HBISECTION VALUE (X2) = UPPER BOUND (X1))
  641 FORMAT(33HBISECTION VALUE PROBABILITY (P2) ,
     1 38HLESS THAN LOWER BOUND PROBABILITY (P0))
  651 FORMAT(33HBISECTION VALUE PROBABILITY (P2) ,
     1 41HGREATER THAN UPPER BOUND PROBABILITY (P1))
C
      END
      SUBROUTINE POIRAN(N,ALAMBA,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE POISSON DISTRIBUTION
C              WITH SINGLE PRECISION
C              TAIL LENGTH PARAMETER = ALAMBA.
C              THE POISSON DISTRIBUTION USED
C              HEREIN HAS MEAN = ALAMBA
C              AND STANDARD DEVIATION = SQRT(ALAMBA).
C              THIS DISTRIBUTION IS DEFINED FOR
C              ALL DISCRETE NON-NEGATIVE INTEGER  X--X = 0, 1, 2, ... .
C              THIS DISTRIBUTION HAS THE PROBABILITY FUNCTION
C              F(X) = EXP(-ALAMBA) * ALAMBA**X / X!.
C              THE POISSON DISTRIBUTION IS THE
C              DISTRIBUTION OF THE NUMBER OF EVENTS
C              IN THE INTERVAL (0,ALAMBA) WHEN
C              THE WAITING TIME BETWEEN EVENTS
C              IS EXPONENTIALLY DISTRIBUTED
C              WITH MEAN = 1 AND STANDARD DEVIATION = 1.
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --ALAMBA = THE SINGLE PRECISION VALUE
C                                OF THE TAIL LENGTH PARAMETER.
C                                ALAMBA 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 POISSON DISTRIBUTION
C             WITH TAIL LENGTH PARAMETER = ALAMBA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C                 --ALAMBA SHOULD BE POSITIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--ALOG.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     COMMENT--THE SINGLE PRECISION TAIL LENGTH
C              PARAMETER ALAMBA IS     NOT     RESTRICTED
C              TO ONLY INTEGER VALUES.
C              ALAMBA CAN BE SET TO ANY POSITIVE REAL
C              VALUE--INTEGER OR NON-INTEGER.
C     COMMENT--NOTE THAT EVEN THOUGH THE OUTPUT
C              FROM THIS DISCRETE RANDOM NUMBER
C              GENERATOR MUST NECESSARILY BE A
C              SEQUENCE OF ***INTEGER*** VALUES,
C              THE OUTPUT VECTOR X IS SINGLE
C              PRECISION IN MODE.
C              X HAS BEEN SPECIFIED AS SINGLE
C              PRECISION SO AS TO CONFORM WITH THE DATAPAC
C              CONVENTION THAT ALL OUTPUT VECTORS FROM ALL
C              DATAPAC SUBROUTINES ARE SINGLE PRECISION.
C              THIS CONVENTION IS BASED ON THE BELIEF THAT
C              1) A MIXTURE OF MODES (FLOATING POINT
C              VERSUS INTEGER) IS INCONSISTENT AND
C              AN UNNECESSARY COMPLICATION
C              IN A DATA ANALYSIS; AND
C              2) FLOATING POINT MACHINE ARITHMETIC
C              (AS OPPOSED TO INTEGER ARITHMETIC)
C              IS THE MORE NATURAL MODE FOR DOING
C              DATA ANALYSIS.
C     REFERENCES--COX AND MILLER, THE THEORY OF STOCHASTIC
C                 PROCESSES, 1965, PAGE 7.
C               --TOCHER, THE ART OF SIMULATION,
C                 1963, PAGES 36-37.
C               --JOHNSON AND KOTZ, DISCRETE
C                 DISTRIBUTIONS, 1969, PAGES 87-121.
C               --HASTINGS AND PEACOCK, STATISTICAL
C                 DISTRIBUTIONS--A HANDBOOK FOR
C                 STUDENTS AND PRACTITIONERS, 1975,
C                 PAGES 108-113.
C               --FELLER, AN INTRODUCTION TO PROBABILITY
C                 THEORY AND ITS APPLICATIONS, VOLUME 1,
C                 EDITION 2, 1957, PAGES 146-154.
C               --NATIONAL BUREAU OF STANDARDS APPLIED MATHEMATICS
C                 SERIES 55, 1964, PAGE 929.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--82.6
C     ORIGINAL VERSION--NOVEMBER  1975.
C     UPDATED         --DECEMBER  1981.
C     UPDATED         --MAY       1982.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
C
      DIMENSION U(2)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)GOTO50
      IF(ALAMBA.LE.0.0)GOTO55
      GOTO90
   50 WRITE(ICOUT, 5)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,47)N
      CALL DPWRST('XXX','BUG ')
      RETURN
   55 WRITE(ICOUT,15)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)ALAMBA
      CALL DPWRST('XXX','BUG ')
      RETURN
   90 CONTINUE
    5 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ',
     1'POIRAN SUBROUTINE IS NON-POSITIVE *****')
   15 FORMAT('***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE ',
     1'POIRAN SUBROUTINE IS NON-POSITIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
C
C     GENERATE N POISSON RANDOM NUMBERS
C     USING THE FACT THAT THE DISTRIBUTION
C     OF EXPONENTIAL WAITING TIMES IS POISSON.
C
      DO100I=1,N
      SUM=0.0
      J=1
  150 CALL UNIRAN(1,ISEED,U)
      E=-ALOG(1.0-U(1))
      SUM=SUM+E
      IF(SUM.GT.ALAMBA)GOTO250
      J=J+1
      GOTO150
  250 X(I)=J-1
  100 CONTINUE
C
      RETURN
      END
      SUBROUTINE POISSF(ALAMB,EPS,L,NSPAN,V,NV,IFLAG)
C
C--- COMPUTE THE POISSON(ALAMB) PROBABILITIES OVER THE RANGE [L,K]
C--- WHERE THE TOTAL TAIL PROBABILITY IS LESS THAN EPS/2, SUM THE
C--- PROBABILITIES IN DOUBLE PRECISION, AND SHIFT THEM TO THE
C--- BEGINNING OF VECTOR V.
C
      DIMENSION V(*)
      DOUBLE PRECISION DAL,DK,DLIMIT,DSUM,DLNGAM
      DLIMIT = 1.0D0-0.5D0*DBLE(EPS)
      K = INT(ALAMB)
      L = K+1
      IF (ALAMB.EQ.0.0) THEN
         PL = 1.0
      ELSE
         DAL = DBLE(ALAMB)
         DK = DBLE(K)
         PL = REAL(DEXP(DK*DLOG(DAL)-DAL-DLNGAM(DBLE(K+1))))
      ENDIF
      PK = ALAMB*PL/REAL(L)
      NK = NV/2
      NL = NK+1
      DSUM = 0.0
   10 IF (PL.LT.PK) THEN
         NK = NK+1
         IF (NK.GT.NV) THEN
            IFLAG = 6
            RETURN
         ENDIF
         V(NK) = PK 
         DSUM = DSUM+DBLE(PK) 
         K = K+1
         IF (DSUM.GE.DLIMIT) GO TO 20
         PK = ALAMB*PK/REAL(K+1)
      ELSE
         NL = NL-1
         V(NL) = PL 
         DSUM = DSUM+DBLE(PL) 
         L = L-1
         IF (DSUM.GE.DLIMIT) GO TO 20
         PL = REAL(L)*PL/ALAMB
      ENDIF
      GO TO 10
   20 INC = NL-1
      DO 30 I = NL, NK
         V(I-INC) = V(I)
   30 CONTINUE
      NSPAN = NK-INC
      RETURN
      END 
      SUBROUTINE POISST(ALAMB,EPS,L,NSPAN,V,NV,IFLAG)
CCCCC CONVERT TO DOUBLE PRECISION.  SINGLE PRECISION ON 32-BIT
CCCCC MACHINES DOES NOT GIVE ACCURATE RESULTS.
C
C--- COMPUTE THE POISSON(ALAMB) PROBABILITIES OVER THE RANGE [L,K]
C--- WHERE THE TOTAL TAIL PROBABILITY IS LESS THAN EPS/3, SUM THE
C--- PROBABILITIES IN DOUBLE PRECISION, AND SHIFT THEM TO THE
C--- BEGINNING OF VECTOR V.
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      DIMENSION V(*)
CCCCC DOUBLE PRECISION DAL,DK,DLIMIT,DSUM,DLNGAM
C
      DLIMIT = 1.0D0-2.0D0*EPS/3.0D0
      K = INT(ALAMB)
      L = K+1
      IF (ALAMB.EQ.0.0D0) THEN
         PL = 1.0D0
      ELSE
         DAL = ALAMB
         DK = DBLE(K)
CCCCC    PL = SNGL(DEXP(DK*DLOG(DAL)-DAL-DLNGAM(DBLE(K+1))))
         PL = DEXP(DK*DLOG(DAL)-DAL-DLNGAM(DBLE(K+1)))
      ENDIF
      PK = ALAMB*PL/DBLE(L)
      NK = NV/2
      NL = NK+1
      DSUM = 0.0D0
   10 IF (PL.LT.PK) THEN
         NK = NK+1
         IF (NK.GT.NV) THEN
            IFLAG = 6
            RETURN
         ENDIF
         V(NK) = PK 
         DSUM = DSUM+PK
         K = K+1
         IF (DSUM.GE.DLIMIT) GO TO 20
         PK = ALAMB*PK/DBLE(K+1)
      ELSE
         NL = NL-1
         IF (NL.LT.1) THEN
            IFLAG = 6
            RETURN
         ENDIF
         V(NL) = PL 
         DSUM = DSUM+PL
         L = L-1
         IF (DSUM.GE.DLIMIT) GO TO 20
         PL = DBLE(L)*PL/ALAMB
      ENDIF
      GO TO 10
   20 INC = NL-1
      DO 30 I = NL, NK
         V(I-INC) = V(I)
   30 CONTINUE
      NSPAN = NK-INC
      RETURN
      END 
      SUBROUTINE POLARI(Y1,Y2,Y3,Y4,N1,N3,IACASE,IWRITE,
     1Y5,Y6,N5,N6,SCAL3,ITYP3,
     1DTOP,DBOT,DMID,
     1IBUGA3,ISUBRO,IERROR)
C
C     PURPOSE--CARRY OUT POLYNOMIAL ARITHMETIC OPERATIONS
C              OF THE REAL DATA IN Y1 AND Y3.
C
C     OPERATIONS--ADDITION
C                 SUBTRACTION
C                 MULTIPLICATION
C                 DIVISION                      (FUTURE--NOT YET IMPLEMENTED)
C                 SQUARE
C                 SQUARE ROOT                   (FUTURE--NOT YET IMPLEMENTED)
C                 GCD (GREATEST COMMON DIVISOR) (FUTURE--NOT YET IMPLEMENTED)
C                 LCM (LEAST COMMON MULTIPLE)   (FUTURE--NOT YET IMPLEMENTED)
C                 EVALUATION
C
C     INPUT  ARGUMENTS--Y1 (REAL PART)       Y2 (IMAGINARY PART)
C                     --Y3 (REAL PART)       Y4 (IMAGINARY PART)
C     OUTPUT ARGUMENTS--Y5 (REAL PART)       Y6 (IMAGINARY PART)
C
C     NOTE--IT IS NOT PERMISSIBLE TO HAVE THE OUTPUT VECTORS Y5(.) AND Y6(.)
C           BEING IDENTICAL TO THE INPUT VECTORS Y1(.) AND Y2(.), OR
C           Y3(.) AND Y4(.).
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--87/9
C     ORIGINAL VERSION--AUGUST   1987.
C     UPDATED         --JUNE     1990. TEMPORARY ARRAYS TO GARBAGE COMMON
C     UPDATED         --JANUARY  2006. PASS DOUBLE PRECISION ARRAYS
C                                      FROM DPMATC
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IACASE
      CHARACTER*4 IWRITE
      CHARACTER*4 ITYP3
      CHARACTER*4 IBUGA3
      CHARACTER*4 ISUBRO
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C-----DOUBLE PRECISION STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DOUBLE PRECISION DY1
CCCCC DOUBLE PRECISION DY2
      DOUBLE PRECISION DY3
CCCC  DOUBLE PRECISION DY4
      DOUBLE PRECISION DY5
CCCCC DOUBLE PRECISION DY6
      DOUBLE PRECISION DSUM5
CCCCC DOUBLE PRECISION DSUM6
C
      DOUBLE PRECISION DTOP
      DOUBLE PRECISION DMID
      DOUBLE PRECISION DBOT
      DOUBLE PRECISION DRATIO
C
      DOUBLE PRECISION DCUM
      DOUBLE PRECISION DX
      DOUBLE PRECISION DC
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOPA.INC'
C
      DIMENSION Y1(*)
      DIMENSION Y2(*)
      DIMENSION Y3(*)
      DIMENSION Y4(*)
      DIMENSION Y5(*)
      DIMENSION Y6(*)
C
      DIMENSION DTOP(*)
      DIMENSION DMID(*)
      DIMENSION DBOT(*)
CCCCC DIMENSION DTOP(MAXOBV)
CCCCC DIMENSION DMID(MAXOBV)
CCCCC DIMENSION DBOT(MAXOBV)
CCCCC FOLLOWING LINES ADDED JUNE, 1990
CCCCC INCLUDE 'DPCOZD.INC'
CCCCC EQUIVALENCE (DGARBG(IDGAR1),DTOP(1))
CCCCC EQUIVALENCE (DGARBG(IDGAR2),DMID(1))
CCCCC EQUIVALENCE (DGARBG(IDGAR3),DBOT(1))
CCCCC END CHANGE
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='POLA'
      ISUBN2='RI  '
C
      IERROR='NO'
C
      SCAL3=(-999.0)
      ITYP3='VECT'
C
      IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'PARI')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF POLARI--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)IBUGA3,ISUBRO,IACASE,IWRITE
   52 FORMAT('IBUGA3,ISUBRO,IACASE,IWRITE = ',A4,2X,A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)N1,N3
   53 FORMAT('N1,N3 = ',2I8)
      CALL DPWRST('XXX','BUG ')
      DO55I=1,N1
      WRITE(ICOUT,56)I,Y1(I),Y2(I)
   56 FORMAT('I,Y1(I),Y2(I) = ',I8,2E13.5)
      CALL DPWRST('XXX','BUG ')
   55 CONTINUE
      DO65I=1,N3
      WRITE(ICOUT,66)I,Y3(I),Y4(I)
   66 FORMAT('I,Y3(I),Y4(I) = ',I8,2E13.5)
      CALL DPWRST('XXX','BUG ')
   65 CONTINUE
   90 CONTINUE
C
C               **************************************************
C               **  CARRY OUT POLYNOMIAL ARITHMETIC OPERATIONS  **
C               **************************************************
C
C               ********************************************
C               **  STEP 11--                             **
C               **  CHECK NUMBER OF INPUT OBSERVATIONS.   **
C               ********************************************
C
      IF(N1.LT.1)GOTO1100
      IF(IACASE.EQ.'POSQ')GOTO1190
      IF(IACASE.EQ.'POSR')GOTO1190
      IF(N3.LT.1)GOTO1100
      GOTO1190
C
 1100 CONTINUE
      IERROR='YES'
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1151)
 1151 FORMAT('***** ERROR IN POLARI--')
      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.'POAD')WRITE(ICOUT,1161)
 1161 FORMAT('      THE POLYNOMIAL ADDITION IS TO BE ',
     1'COMPUTED')
      IF(IACASE.EQ.'POAD')CALL DPWRST('XXX','BUG ')
      IF(IACASE.EQ.'POSU')WRITE(ICOUT,1162)
 1162 FORMAT('      THE POLYNOMIAL SUBTRACTION IS TO BE ',
     1'COMPUTED')
      IF(IACASE.EQ.'POSU')CALL DPWRST('XXX','BUG ')
      IF(IACASE.EQ.'POMU')WRITE(ICOUT,1163)
 1163 FORMAT('      THE POLYNOMIAL MULTIPLICATION IS TO BE ',
     1'COMPUTED')
      IF(IACASE.EQ.'POMU')CALL DPWRST('XXX','BUG ')
      IF(IACASE.EQ.'PODI')WRITE(ICOUT,1164)
 1164 FORMAT('      THE POLYNOMIAL DIVISION IS TO BE ',
     1'COMPUTED')
      IF(IACASE.EQ.'PODI')CALL DPWRST('XXX','BUG ')
      IF(IACASE.EQ.'POSQ')WRITE(ICOUT,1165)
 1165 FORMAT('      THE POLYNOMIAL SQUARE IS TO BE ',
     1'COMPUTED')
      IF(IACASE.EQ.'POSQ')CALL DPWRST('XXX','BUG ')
      IF(IACASE.EQ.'POSR')WRITE(ICOUT,1166)
 1166 FORMAT('      THE POLYNOMIAL SQUARE ROOT IS TO BE ',
     1'COMPUTED')
      IF(IACASE.EQ.'POSR')CALL DPWRST('XXX','BUG ')
      IF(IACASE.EQ.'POGC')WRITE(ICOUT,1167)
 1167 FORMAT('      THE POLYNOMIAL GCD IS TO BE ',
     1'COMPUTED')
      IF(IACASE.EQ.'POGC')CALL DPWRST('XXX','BUG ')
      IF(IACASE.EQ.'POLC')WRITE(ICOUT,1168)
 1168 FORMAT('      THE POLYNOMIAL LCM IS TO BE ',
     1'COMPUTED')
      IF(IACASE.EQ.'POLC')CALL DPWRST('XXX','BUG ')
      IF(IACASE.EQ.'POEV')WRITE(ICOUT,1169)
 1169 FORMAT('      THE POLYNOMIAL EVALUATION IS TO BE ',
     1'COMPUTED')
      IF(IACASE.EQ.'POEV')CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1181)
 1181 FORMAT('      MUST BE 1 OR LARGER.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1182)
 1182 FORMAT('      SUCH WAS NOT THE CASE HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1183)N1,N3
 1183 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS HERE = ',2I8,
     1'.')
      CALL DPWRST('XXX','BUG ')
      GOTO9000
C
 1190 CONTINUE
C
C               *********************************
C               **  STEP 12--                  **
C               **  BRANCH TO THE PROPER CASE  **
C               *********************************
C
      IF(IACASE.EQ.'POAD')GOTO2100
      IF(IACASE.EQ.'POSU')GOTO2200
      IF(IACASE.EQ.'POMU')GOTO2300
      IF(IACASE.EQ.'PODI')GOTO2400
      IF(IACASE.EQ.'POSQ')GOTO2500
      IF(IACASE.EQ.'POSR')GOTO2600
      IF(IACASE.EQ.'POGC')GOTO2700
      IF(IACASE.EQ.'POLC')GOTO2800
      IF(IACASE.EQ.'POEV')GOTO2900
C
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1211)
 1211 FORMAT('***** INTERNAL ERROR IN POLARI--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1212)
 1212 FORMAT('      IACASE NOT EQUAL TO')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1213)
 1213 FORMAT('      POAD, POSU, POMU, PODI, ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1214)
 1214 FORMAT('      POSQ, POSR, POGC, POLC, OR POEV')
      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 POLYNOMIAL ADDITION    CASE  **
C               *********************************************
C
 2100 CONTINUE
      N13MAX=N1
      IF(N3.GT.N1)N13MAX=N3
      DO2110I=1,N13MAX
      DY1=0.0D0
CCCCC DY2=0.0D0
      DY3=0.0D0
CCCCC DY4=0.0D0
      IF(I.LE.N1)DY1=Y1(I)
CCCCC IF(I.LE.N1)DY2=Y2(I)
      IF(I.LE.N3)DY3=Y3(I)
CCCCC IF(I.LE.N3)DY4=Y4(I)
      DY5=DY1+DY3
CCCCC DY6=DY2+DY4
      Y5(I)=DY5
CCCCC Y6(I)=DY6
 2110 CONTINUE
C
      ITYP3='VECT'
      N5=N13MAX
      N6=N5
      GOTO9000
C
C               *********************************************
C               **  STEP 22--                              **
C               **  TREAT THE POLYNOMIAL SUBTRACTION CASE  **
C               *********************************************
C
 2200 CONTINUE
      N13MAX=N1
      IF(N3.GT.N1)N13MAX=N3
      DO2210I=1,N13MAX
      DY1=0.0D0
CCCCC DY2=0.0D0
      DY3=0.0D0
CCCCC DY4=0.0D0
      IF(I.LE.N1)DY1=Y1(I)
CCCCC IF(I.LE.N1)DY2=Y2(I)
      IF(I.LE.N3)DY3=Y3(I)
CCCCC IF(I.LE.N3)DY4=Y4(I)
      DY5=DY1-DY3
CCCCC DY6=DY2-DY4
      Y5(I)=DY5
CCCCC Y6(I)=DY6
 2210 CONTINUE
C
      ITYP3='VECT'
      N5=N13MAX
      N6=N5
      GOTO9000
C
C               ************************************************
C               **  STEP 23--                                 **
C               **  TREAT THE POLYNOMIAL MULTIPLICATION CASE  **
C               ************************************************
C
 2300 CONTINUE
      N1PN3M=N1+N3-1
      DO2310I=1,N1PN3M
      DSUM5=0.0D0
CCCCC DSUM6=0.0D0
      DO2320J=1,N1
      K=I-J+1
      IF(K.LT.1.OR.K.GT.N3)GOTO2320
      DY1=Y1(J)
CCCCC DY2=Y2(J)
      DY3=Y3(K)
CCCCC DY4=Y4(K)
CCCCC DY5=DY1*DY3-DY2*DY4
      DY5=DY1*DY3
CCCCC DY6=DY1*DY4+DY2*DY3
      DSUM5=DSUM5+DY5
CCCCC DSUM6=DSUM6+DY6
 2320 CONTINUE
      Y5(I)=DSUM5
CCCCC Y6(I)=DSUM6
 2310 CONTINUE
C
      ITYP3='VECT'
      N5=N1PN3M
      N6=N5
      GOTO9000
C
C               ************************************************
C               **  STEP 24--                                 **
C               **  TREAT THE POLYNOMIAL DIVISION       CASE  **
C               ************************************************
C
 2400 CONTINUE
C
      DO2410I=1,N1
      DBOT(I)=Y1(I)
 2410 CONTINUE
C
      NLOOP=N1-N3+1
      NTOP=N1+1
      IF(NLOOP.LE.0)GOTO2455
      DO2420ILOOP=1,NLOOP
      NTOP=NTOP-1
C
      DO2430I=1,NTOP
      DTOP(I)=DBOT(I)
      DMID(I)=0.0D0
 2430 CONTINUE
C
      IDEL=NTOP-N3
      DO2440I=1,N3
      J=I+IDEL
      DMID(J)=Y3(I)
 2440 CONTINUE
C
      DRATIO=DTOP(NTOP)/DMID(NTOP)
      ILOOPR=NLOOP-ILOOP+1
      Y5(ILOOPR)=DRATIO
C
      DO2450I=1,NTOP
      DMID(I)=DMID(I)*DRATIO
      DBOT(I)=DTOP(I)-DMID(I)
 2450 CONTINUE
C
 2420 CONTINUE
      N5=NLOOP
C
 2455 CONTINUE
      NTOP=NTOP-1
      DO2460I=1,NTOP
      Y6(I)=DBOT(I)
 2460 CONTINUE
      N6=NTOP
C
      IF(NLOOP.GE.1)GOTO2479
      DO2470I=1,N6
      Y5(I)=0.0
 2470 CONTINUE
      N5=N6
 2479 CONTINUE
C
      ITYP3='VECT'
      GOTO9000
C
C               ***************************************************
C               **  STEP 25--                                    **
C               **  TREAT THE POLYNOMIAL SQUARE (SQUARING) CASE  **
C               ***************************************************
C
 2500 CONTINUE
      N1PN1M=N1+N1-1
      DO2510I=1,N1PN1M
      DSUM5=0.0D0
CCCCC DSUM6=0.0D0
      DO2520J=1,N1
      K=I-J+1
      IF(K.LT.1.OR.K.GT.N1)GOTO2520
      DY1=Y1(J)
CCCCC DY2=Y2(J)
      DY3=Y1(K)
CCCCC DY4=Y2(K)
CCCCC DY5=DY1*DY3-DY2*DY4
      DY5=DY1*DY3
CCCCC DY6=DY1*DY4+DY2*DY3
      DSUM5=DSUM5+DY5
CCCCC DSUM6=DSUM6+DY6
 2520 CONTINUE
      Y5(I)=DSUM5
CCCCC Y6(I)=DSUM6
 2510 CONTINUE
C
      ITYP3='VECT'
      N5=N1PN1M
      N6=N5
      GOTO9000
C
C               ************************************************
C               **  STEP 26--                                 **
C               **  TREAT THE POLYNOMIAL SQUARE ROOT    CASE  **
C               ************************************************
C
 2600 CONTINUE
C
C     NOTE YET DONE
C
      GOTO9000
C
C               *********************************************************
C               **  STEP 27--                                          **
C               **  TREAT THE POLYNOMIAL GREATEST COMMON DIVISOR CASE  **
C               *********************************************************
C
 2700 CONTINUE
C
C     NOTE YET DONE
C
      GOTO9000
C
C               *******************************************************
C               **  STEP 28--                                        **
C               **  TREAT THE POLYNOMIAL LEAST COMMON MULTIPLE CASE  **
C               *******************************************************
C
 2800 CONTINUE
C
C     NOTE YET DONE
C
      GOTO9000
C
C               *********************************************
C               **  STEP 29--                              **
C               **  TREAT THE POLYNOMIAL EVALUATION  CASE  **
C               *********************************************
C
 2900 CONTINUE
      N1M1=N1-1
      DO2910I=1,N3
      DX=Y3(I)
      DCUM=Y1(N1)
      IF(N1M1.LE.0)GOTO2925
      DO2920J=1,N1M1
      JREV=N1-J+1
      JREVM=JREV-1
      DC=Y1(JREVM)
      DCUM=DX*DCUM+DC
 2920 CONTINUE
 2925 CONTINUE
      Y5(I)=DCUM
 2910 CONTINUE
C
      ITYP3='VECT'
      N5=N3
      N6=N5
      GOTO9000
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
C
      IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'PARI')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF POLARI--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IBUGA3,ISUBRO,IACASE,IWRITE
 9012 FORMAT('IBUGA3,ISUBRO,IACASE,IWRITE = ',A4,2X,A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)IERROR
 9013 FORMAT('IERROR = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9017)N1,N3,N5,N6
 9017 FORMAT('N1,N3,N5,N6 = ',4I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9018)SCAL3,ITYP3
 9018 FORMAT('SCAL3,ITYP3 = ',E15.7,2X,A4)
      CALL DPWRST('XXX','BUG ')
      IF(ITYP3.EQ.'SCAL')GOTO9090
      DO9021I=1,N1
      WRITE(ICOUT,9022)I,Y1(I),Y2(I)
 9022 FORMAT('I,Y1(I),Y2(I) = ',I8,2E13.5)
      CALL DPWRST('XXX','BUG ')
 9021 CONTINUE
      DO9031I=1,N3
      WRITE(ICOUT,9032)I,Y3(I),Y4(I)
 9032 FORMAT('I,Y3(I),Y4(I) = ',I8,2E13.5)
      CALL DPWRST('XXX','BUG ')
 9031 CONTINUE
      DO9041I=1,N5
      WRITE(ICOUT,9042)I,Y5(I),Y6(I)
 9042 FORMAT('I,Y5(I),Y6(I) = ',I8,2E13.5)
      CALL DPWRST('XXX','BUG ')
 9041 CONTINUE
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE POLCDF(X,V,W,N,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE AT THE SINGLE PRECISION VALUE X
C              FOR THE POLYA DISTRIBUTION
C              WITH SINGLE PRECISION PARAMETERS V AND W
C              AND INTEGER 'NUMBER OF BERNOULLI TRIALS'
C              PARAMETER = N.
C              THIS DISTRIBUTION HAS THE PROBABILITY FUNCTION
C              P(X) = (N X)*B(X+V,N+X+W)/B(V,W)
C              WITH B(.,.) DENOTING THE BETA FUNCTION AND (N X)
C              DENOTING THE BINOMIAL COEFFICIENT.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE
C                                AT WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE INTEGRAL-VALUED,
C                                AND BETWEEN 0.0 (INCLUSIVELY)
C                                AND N (INCLUSIVELY).
C                     --V      = THE SINGLE PRECISION VALUE
C                                OF THE FIRST SHAPE PARAMETER.
C                     --W      = THE SINGLE PRECISION VALUE
C                                OF THE SECOND SHAPE PARAMETER.
C                     --N      = THE INTEGER VALUE
C                                OF THE 'NUMBER OF BERNOULLI TRIALS'
C                                PARAMETER.
C                                N SHOULD BE A POSITIVE INTEGER.
C     OUTPUT ARGUMENTS--CDF    = THE SINGLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE CDF
C             FOR THE BINOMIAL DISTRIBUTION
C             WITH 'BERNOULLI PROBABILITY' PARAMETER = P
C             AND 'NUMBER OF BERNOULLI TRIALS' PARAMETER = N.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE INTEGRAL-VALUED,
C                   AND BETWEEN 0.0 (INCLUSIVELY)
C                   AND N (INCLUSIVELY).
C                 --V AND W SHOULD BOTH BE POSITIVE.
C                 --N SHOULD BE A POSITIVE INTEGER.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--DBINOM, DLBETA
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--EVANS, HASTINGS AND PEACOCK, STATISTICAL
C                 DISTRIBUTIONS--THIRD ED., CHAPTER 5
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004/3
C     ORIGINAL VERSION--MARCH     2004.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX, DV, DW, DN, DCDF
      DOUBLE PRECISION DTERM1, DTERM2, DTERM4
      DOUBLE PRECISION DLBETA, DBINOM
      DOUBLE PRECISION DSUM1, DSUM2
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      CDF=0.0
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      AN=N
      IF(V.LE.0.0)THEN
        WRITE(ICOUT,11)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)V
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9999
      ENDIF
      IF(W.LE.0.0)THEN
        WRITE(ICOUT,12)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)V
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9999
      ENDIF
      IF(N.LE.0)THEN
        WRITE(ICOUT,25)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9999
      ENDIF
      INTX=X+0.0001
      FINTX=INTX
      DEL=X-FINTX
      IF(DEL.LT.0.0)DEL=-DEL
      IF(DEL.GT.0.001)THEN
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,6)INT(FINTX)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
      ENDIF
      IF(FINTX.LT.0.0 .OR. FINTX.GT.AN)THEN
        WRITE(ICOUT,4)N
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
C
    4 FORMAT('***** FATAL ERROR--THE FIRST INPUT ',
     1'ARGUMENT TO THE POLCDF SUBROUTINE IS OUTSIDE THE USUAL ',
     1'(0,N) = (0,',I8,') INTERVAL')
    5 FORMAT('***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ',
     1'ARGUMENT TO THE POLCDF SUBROUTINE IS NON-INTEGRAL *****')
    6 FORMAT('      IT HAS BEEN SET TO ',I8)
   11 FORMAT('***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE ',
     1' POLCDF SUBROUTINE IS NON-POSITIVE')
   12 FORMAT('***** FATAL ERROR--THE THIRD INPUT ARGUMENT TO THE ',
     1' POLCDF SUBROUTINE IS NON-POSITIVE')
   25 FORMAT('***** FATAL ERROR--THE FOURTH INPUT ARGUMENT TO THE ',
     1' POLCDF SUBROUTINE IS NON-POSITIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
C
      DV=DBLE(V)
      DW=DBLE(W)
      DN=DBLE(N)
      DSUM1=0.0D0
      DSUM2=0.0D0
C
      DMEAN=DN*DW/(DV+DW)
      ICUT=INT(DMEAN)+1
C
C  SUM TERMS UP TO AND INCLUDING MEAN
C
      DO1000I=0,MIN(ICUT,INTX),1
        DX=DBLE(I)
        DTERM1=DLOG(DBINOM(N,I))
        DTERM2=DLBETA(DX+DV,DN+DW-DX)
        DTERM4=DLBETA(DV,DW)
        DCDF=DEXP(DTERM1 + DTERM2 - DTERM4)
        DSUM1=DSUM1+DCDF
 1000 CONTINUE
C
C  SUM TERMS FROM X DOWN TO MEAN MEAN
C
      IF(INTX.GT.ICUT)THEN
        DO2000I=INTX,ICUT+1,-1
          DX=DBLE(I)
          DTERM1=DLOG(DBINOM(N,I))
          DTERM2=DLBETA(DX+DV,DN+DW-DX)
          DTERM4=DLBETA(DV,DW)
          DCDF=DEXP(DTERM1 + DTERM2 - DTERM4)
          DSUM2=DSUM2+DCDF
 2000   CONTINUE
      ENDIF
      DCDF=DSUM1+DSUM2
      CDF=REAL(DCDF)
  101 FORMAT('****** FATAL ERROR--OVERFLOW IN POLCDF ROUTINE.')
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE POLPDF(X,W,B,C,N,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE AT THE SINGLE PRECISION VALUE X
C              FOR THE POLYA DISTRIBUTION
C              WITH SINGLE PRECISION PARAMETERS W, B, AND C
C              AND INTEGER PARAMETER N.
C              THIS DISTRIBUTION IS DEFINED FOR ALL
C              DISCRETE INTEGER X BETWEEN 0 (INCLUSIVELY)
C              AND N (INCLUSIVELY).
C              THIS DISTRIBUTION HAS THE PROBABILITY FUNCTION
C                 P(X) = (N X)*B(X+ALPHA,N+X+BETA)/B(ALPHA,BETA)
C                        X = 0, 1, 2, ..., N.
C              WITH ALPHA = W/C AND BETA = B/C,
C              B(.,.) DENOTING THE BETA FUNCTION, AND (N X)
C              DENOTING THE BINOMIAL COEFFICIENT.
C              THIS FORM OF THE OF THE PDF IS ONLY USEFUL FOR
C              ALPHA AND BETA POSITIVE.
C              AN ALTERNATIVE FORM THAT CAN BE USED FOR NEGATIVE
C              VALUES FOR W, B, AND C IS:
C                 P(X) = (-W/C  X)*(-B/C  N-X)/(-(W+B)/C  N)
C              FOR NEGATIVE VALUES OF W, B, AND C, USE THE
C              FORMULA:
C              (-N  R) = (-1)**R*(N+R-1  R)
C              NOTE THAT IF C = 0, THEN POLYA DEGENERATES TO
C              BINOMIAL WITH P = W/(W+B) AND N.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE
C                                AT WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE INTEGRAL-VALUED,
C                                AND BETWEEN 0.0 (INCLUSIVELY)
C                                AND N (INCLUSIVELY).
C                     --W      = THE SINGLE PRECISION VALUE
C                                OF THE FIRST SHAPE PARAMETER.
C                     --B      = THE SINGLE PRECISION VALUE
C                                OF THE SECOND SHAPE PARAMETER.
C                     --C      = THE SINGLE PRECISION VALUE
C                                OF THE THURD SHAPE PARAMETER.
C                     --N      = THE INTEGER VALUE
C                                OF THE 'NUMBER OF BERNOULLI TRIALS'
C                                PARAMETER.
C                                N SHOULD BE A POSITIVE INTEGER.
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 POLYA DISTRIBUTION
C             WITH SHAPE PARAMETERS W, B, C, AD N.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE INTEGRAL-VALUED,
C                   AND BETWEEN 0.0 (INCLUSIVELY)
C                   AND N (INCLUSIVELY).
C                 --N SHOULD BE A POSITIVE INTEGER.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--DLBETA, DBINOM, DLNGAM
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND KEMP, "UNIVARIATE DISCRETE
C                 DISTRIBUTIONS--SECOND EDITION, WILEY, 1992,
C                 PP. 244-249.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--2004/4
C     ORIGINAL VERSION--APRIL     2004.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      REAL W
      REAL B
      REAL C
      REAL ALPHA
      REAL BETA
      REAL P
      DOUBLE PRECISION DX, DV, DW, DN, DPDF
      DOUBLE PRECISION DA, DR, DWC, DBC, DWBC
      DOUBLE PRECISION DCONST
      DOUBLE PRECISION D1, D2, D3
      DOUBLE PRECISION DTERM1, DTERM2, DTERM3, DTERM4
      DOUBLE PRECISION DLBETA, DBINOM
      DOUBLE PRECISION DLNGAM
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      PDF=0.0
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      AN=N
      ALPHA=W/C
      BETA=B/C
      P=W/(W+B)
      print *,'n,w,b,c,p=',n,w,b,c,p
CCCCC IF(V.LE.0.0)THEN
CCCCC   WRITE(ICOUT,11)
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   WRITE(ICOUT,46)V
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   PDF=0.0
CCCCC   GOTO9999
CCCCC ENDIF
CCCCC IF(W.LE.0.0)THEN
CCCCC   WRITE(ICOUT,12)
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   WRITE(ICOUT,46)V
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   PDF=0.0
CCCCC   GOTO9999
CCCCC ENDIF
      IF(N.LE.0)THEN
        WRITE(ICOUT,25)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ENDIF
      INTX=X+0.0001
      FINTX=INTX
      DEL=X-FINTX
      IF(DEL.LT.0.0)DEL=-DEL
      IF(DEL.GT.0.001)THEN
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,6)INT(FINTX)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
      ENDIF
      IF(FINTX.LT.0.0 .OR. FINTX.GT.AN)THEN
        WRITE(ICOUT,4)N
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
C
    4 FORMAT('***** ERROR--THE FIRST INPUT ',
     1'ARGUMENT TO THE POLPDF SUBROUTINE IS OUTSIDE THE USUAL ',
     1'(0,N) = (0,',I8,') INTERVAL')
    5 FORMAT('***** WARNING--THE FIRST INPUT ',
     1'ARGUMENT TO THE POLPDF SUBROUTINE IS NON-INTEGRAL *****')
    6 FORMAT('      IT HAS BEEN SET TO ',I8)
CCC11 FORMAT('***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE ',
CCCCC1' POLPDF SUBROUTINE IS NON-POSITIVE')
CCC12 FORMAT('***** FATAL ERROR--THE THIRD INPUT ARGUMENT TO THE ',
CCCCC1' POLPDF SUBROUTINE IS NON-POSITIVE')
   25 FORMAT('***** ERROR--THE FIFTH INPUT ARGUMENT TO THE ',
     1' POLPDF SUBROUTINE IS NON-POSITIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
C
C
      IF(C.EQ.0.0)THEN
C
C  CASE 1: C = 0 DEGENERATES TO A BINOMIAL DISTRIBUTION
C
        print *,'p=',p
        CALL BINCDF(X,P,N,CDF1)
        IF(X.LE.0.1)THEN
          PDF=CDF1
        ELSE
          ARG1=X-1.0
          CALL BINCDF(ARG1,P,N,CDF2)
          PDF=CDF1-CDF2
        ENDIF
      ELSEIF(ALPHA.GT.0.0 .AND. BETA.GT.0)THEN
C
C  CASE 2: W/C AND B/C BOTH POSITIVE, USE DEFINITION BASED ON
C          BETA FUNCTIONS (THIS CASE IS EQUIVALENT TO
C          BETA-BINOMIAL WITH ALPHA AND BETA ARGUMENTS REVERSED).
C
        print *,'alpha, beta = ',alpha,beta
        DX=DBLE(FINTX)
        DV=DBLE(ALPHA)
        DW=DBLE(BETA)
        DN=DBLE(N)
        DTERM1=DLOG(DBINOM(N,INTX))
        DTERM2=DLBETA(DX+DV,DN+DW-DX)
        DTERM4=DLBETA(DV,DW)
        DPDF=DTERM1 + DTERM2 - DTERM4
        IF(DPDF.LE.-80.D0)THEN
          PDF=0.0
        ELSEIF(DPDF.GT.80.D0)THEN
          WRITE(ICOUT,101)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,46)X
          CALL DPWRST('XXX','BUG ')
          PDF=0.0
        ELSE
          DPDF=DEXP(DPDF)
          PDF=SNGL(DPDF)
        ENDIF
      ELSE
C
C  CASE 3: W/C OR B/C OR BOTH ARE NEGATIVE.  USE DEFINTION BASED
C          ON BINOMIAL COEFFICIENT WHERE SOME OF THE TERMS MAY
C          HAVE NEGATIVE ARGUMENTS FOR TOP COEFFICIENT.
C
C          (-N  R) = (-1)**R*(N+R-1  R)
C                  = (-1)**R*(N+R-1)!/[R!*(N+R-1-R)!]
C                  = (-1)**R*(N+R-1)!/[R!*(N-1)!]
C                  = (-1)**R*GAMMA(N+R)/[GAMMA(R+1)*GAMMA(N)]
C
C          IF TERM IS POSITIVE, USE
C          (N  R) = N!/(R!*(N-R)!)
C                 = GAMMA(N+1)/[GAMMA(R+1)*GAMMA(N-R+1)]
C          USE LOG GAMMA FUNCTION FOR BETTER NUMERICAL STABILITY
C
        print *,'w,b,c=',w,b,c
        DX=DBLE(FINTX)
        DWC=DBLE(W)/DBLE(C)
        DBC=DBLE(B)/DBLE(C)
        DWBC=DBLE(W+B)/DBLE(C)
        DN=DBLE(N)
C
C  FIRST TERM: (-DWC  X)
C
        DA=-DWC
        DR=DX
        IF(DA.GE.0.0)THEN
          D1=DLNGAM(DA+1.0D0)
          D2=DLNGAM(DR+1.0)
          D3=DLNGAM(DA-DR+1.0)
          DTERM1=DEXP(D1 - D2 - D3)
        ELSE
          DCONST=(-1.0D0)**INT(DR+0.01)
          DA=DABS(DA)
          D1=DLNGAM(DA+DR)
          D2=DLNGAM(DR+1)
          D3=DLNGAM(DA)
          DTERM1=DCONST*DEXP(D1 - D2 - D3)
        ENDIF
C
C  SECOND TERM: (-DBC  N-X)
C
        DA=-DBC
        DR=DN-DX
        IF(DA.GE.0.0)THEN
          D1=DLNGAM(DA+1.0D0)
          D2=DLNGAM(DR+1.0)
          D3=DLNGAM(DA-DR+1.0)
          DTERM2=DEXP(D1 - D2 - D3)
        ELSE
          DCONST=(-1.0D0)**INT(DR+0.01)
          DA=DABS(DA)
          D1=DLNGAM(DA+DR)
          D2=DLNGAM(DR+1)
          D3=DLNGAM(DA)
          DTERM2=DCONST*DEXP(D1 - D2 - D3)
        ENDIF
C
C  THIRD TERM: (-(W+B)/C  N)
C
        DA=-DWBC
        DR=DN
        IF(DA.GE.0.0)THEN
          D1=DLNGAM(DA+1.0D0)
          D2=DLNGAM(DR+1.0)
          D3=DLNGAM(DA-DR+1.0)
          DTERM3=DEXP(D1 - D2 - D3)
        ELSE
          DCONST=(-1.0D0)**INT(DR+0.01)
          DA=DABS(DA)
          D1=DLNGAM(DA+DR)
          D2=DLNGAM(DR+1)
          D3=DLNGAM(DA)
          DTERM3=DCONST*DEXP(D1 - D2 - D3)
        ENDIF
        DPDF=(DTERM1*DTERM2)/DTERM3
        PDF=REAL(DPDF)
      ENDIF
  101 FORMAT('****** FATAL ERROR--OVERFLOW IN POLPDF ROUTINE.')
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE POLPPF(P,V,W,N,PPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE AT THE SINGLE PRECISION VALUE P
C              FOR THE POLYA DISTRIBUTION
C              WITH SINGLE PRECISION PARAMETERS V AND W
C              AND INTEGER 'NUMBER OF BERNOULLI TRIALS'
C              PARAMETER = N.
C              THIS DISTRIBUTION HAS THE PROBABILITY FUNCTION
C              P(X) = (N X)*B(X+V,N+X+W)/B(V,W)
C              WITH B(.,.) DENOTING THE BETA FUNCTION AND (N X)
C              DENOTING THE BINOMIAL COEFFICIENT.
C     INPUT  ARGUMENTS--P      = THE SINGLE PRECISION VALUE
C                                (BETWEEN 0.0 (INCLUSIVELY)
C                                AND 1.0 (INCLUSIVELY))
C                                AT WHICH THE PERCENT POINT
C                                FUNCTION IS TO BE EVALUATED.
C                     --V      = THE SINGLE PRECISION VALUE
C                                OF THE FIRST SHAPE PARAMETER.
C                     --W      = THE SINGLE PRECISION VALUE
C                                OF THE SECOND SHAPE PARAMETER.
C                     --N      = THE INTEGER VALUE
C                                OF THE 'NUMBER OF BERNOULLI TRIALS'
C                                PARAMETER.
C                                N SHOULD BE A POSITIVE INTEGER.
C     OUTPUT ARGUMENTS--PPF    = THE SINGLE PRECISION PERCENT
C                                POINT FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PERCENT POINT  .
C             FUNCTION VALUE PPF
C             FOR THE POLYA DISTRIBUTION
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--N SHOULD BE A POSITIVE INTEGER.
C                 --P SHOULD BE BETWEEN 0.0 (INCLUSIVELY)
C                   AND 1.0 (INCLUSIVELY).
C     OTHER DATAPAC   SUBROUTINES NEEDED--BBNCDF
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION AND DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     COMMENT--NOTE THAT EVEN THOUGH THE OUTPUT
C              FROM THIS DISCRETE DISTRIBUTION
C              PERCENT POINT FUNCTION
C              SUBROUTINE MUST NECESSARILY BE A
C              DISCRETE INTEGER VALUE,
C              THE OUTPUT VARIABLE PPF IS SINGLE
C              PRECISION IN MODE.
C              PPF HAS BEEN SPECIFIED AS SINGLE
C              PRECISION SO AS TO CONFORM WITH THE DATAPAC
C              CONVENTION THAT ALL OUTPUT VARIABLES FROM ALL
C              DATAPAC SUBROUTINES ARE SINGLE PRECISION.
C              THIS CONVENTION IS BASED ON THE BELIEF THAT
C              1) A MIXTURE OF MODES (FLOATING POINT
C              VERSUS INTEGER) IS INCONSISTENT AND
C              AN UNNECESSARY COMPLICATION
C              IN A DATA ANALYSIS; AND
C              2) FLOATING POINT MACHINE ARITHMETIC
C              (AS OPPOSED TO INTEGER ARITHMETIC)
C              IS THE MORE NATURAL MODE FOR DOING
C              DATA ANALYSIS.
C     REFERENCES--EVANS, HASTINGS AND PEACOCK, STATISTICAL
C                 DISTRIBUTIONS--THIRD ED., CHAPTER 5
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004/3
C     ORIGINAL VERSION--MARCH     2004.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX, DV, DW, DN, DCDF
      DOUBLE PRECISION DTERM1, DTERM2, DTERM3, DTERM4
      DOUBLE PRECISION DLBETA, DBINOM
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DP
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(P.LT.0.0.OR.P.GT.1.0)THEN
        WRITE(ICOUT,1)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)P
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
        GOTO9999
      ENDIF
      IF(V.LE.0.0)THEN
        WRITE(ICOUT,11)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)V
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ENDIF
      IF(W.LE.0.0)THEN
        WRITE(ICOUT,12)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)V
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ENDIF
      IF(N.LE.0)THEN
        WRITE(ICOUT,25)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ENDIF
    1 FORMAT('***** FATAL ERROR--THE FIRST INPUT ARGUMENT TO THE ',
     1' POLPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL')
   11 FORMAT('***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE ',
     1' POLPPF SUBROUTINE IS NON-POSITIVE')
   12 FORMAT('***** FATAL ERROR--THE THIRD INPUT ARGUMENT TO THE ',
     1' POLPPF SUBROUTINE IS NON-POSITIVE')
   25 FORMAT('***** FATAL ERROR--THE FOURTH INPUT ARGUMENT TO THE ',
     1' POLPPF SUBROUTINE IS NON-POSITIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
C
      AN=N
      PPF=0.0
C
C     TREAT CERTAIN SPECIAL CASES IMMEDIATELY--
C     1) P = 0.0
C     2) P = 1.0
C
      IF(P.EQ.0.0)THEN
        PPF=0.0
        GOTO9999
      ENDIF
C
      IF(P.EQ.1.0)THEN
        PPF=REAL(N)
        GOTO9999
      ENDIF
C
C     COMPUTE THE POLCDF, TERMINATE WHEN CDF IS GREATER THAN OR
C     EQUAL TO P.
C
      DP=DBLE(P)
      DN=DBLE(N)
      DV=DBLE(V)
      DW=DBLE(W)
      DSUM1=0.0D0
      DO1000I=0,N
        DX=DBLE(I)
        DTERM1=DLOG(DBINOM(N,I))
        DTERM2=DLBETA(DX+DV,DN+DW-DX)
        DTERM4=DLBETA(DV,DW)
        DCDF=DEXP(DTERM1 + DTERM2 - DTERM4)
        DSUM1=DSUM1+DCDF
        IF(DSUM1.GE.DP)THEN
          PPF=REAL(I)
          GOTO9999
        ENDIF
 1000 CONTINUE
      PPF=REAL(N)
C
 9999 CONTINUE
      RETURN
      END
      function poly(c, nord, x)
c
c
c        Algorithm AS 181.2   Appl. Statist.  (1982) Vol. 31, No. 2
c
c        Calculates the algebraic polynomial of order nored-1 with
c        array of coefficients c.  Zero order coefficient is c(1)
c
      real c(nord)
      poly = c(1)
      if(nord.eq.1) return
      p = x*c(nord)
      if(nord.eq.2) goto 20
      n2 = nord-2
      j = n2+1
      do 10 i = 1,n2
      p = (p+c(j))*x
      j = j-1
   10 continue
   20 poly = poly+p
      return
      end
      SUBROUTINE POOL(IND, NP, NS, NW, W, N, LLIM, LT, LP)              POO  230
C  PART OF ACM 591 FOR ANOVA
C  ****************************** POOL ******************************   POO   10
C                                                                       POO   20
C  OPERATES UPON THE VECTORS IN ARRAY W, PRINCIPALLY THE ARRAYS OF A    POO   30
C  FACTORIAL DECOMPOSITION WITHIN VECTOR A OF W.  EITHER MOVES THE      POO   40
C  SECONDARY ARRAY INTO THE PRIMARY ARRAY, DUPLICATING ENTRIES WHERE    POO   50
C  NEEDED, OR POOLS THE SECONDARY ARRAY AND THE PRIMARY ARRAY BY AD-    POO   60
C  DITION INTO THE PRIMARY ARRAY (FOR DESCRIPTION OF MAPPING FUNCTION   POO   70
C  SEE SCHLATER AND HEMMERLE, CACM 1966)                                POO   80
C                                                                       POO   90
C  IND = 0 (REPLACEMENT); IND = 1 (POOLING)                             POO  100
C                                                                       POO  110
C  NP = BASE ADDRESS OF PRIMARY ARRAY (WITHIN ARRAY W)                  POO  120
C  NS = BASE ADDRESS OF SECONDARY ARRAY (WITHIN ARRAY W)                POO  130
C                                                                       POO  140
C  WHEN THE PRIMARY ARRAY HAS LESS THAN N SUBSCRIPTS, THE ENTRIES IN    POO  150
C  LLIM CORRESPONDING TO THE MISSING SUBSCRIPTS MUST BE MADE NEGATIVE   POO  160
C  PRIOR TO ENTRY AND THEN SET POSITIVE AGAIN AFTER RETURN; ARRAY LP    POO  170
C  MUST CONTAIN THE COEFFICIENTS OF THE MAPPING FUNCTION UPON ENTRY.    POO  180
C                                                                       POO  190
C  (SEE MAIN PROGRAM COMMENTS FOR DESCRIPTION OF OTHER ARGUMENTS)       POO  200
C                                                                       POO  210
C  ******************************************************************   POO  220
      DIMENSION W(NW), LLIM(N), LT(N), LP(10)
      DOUBLE PRECISION W, TEMP
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C NP=LOCATION OF PRIMARY ARRAY; NS=LOCATION OF SECONDARY ARRAY;
C MAP COEFFICIENTS OBTAINED FROM LP; REPLACE (IND=0); ADD (IND .NE. 0)
      LOC1 = NP
      I = 1
   10 DO 20 J=I,N
        LT(J) = 1
   20 CONTINUE
   30 LOC1 = LOC1 + 1
      LOC2 = NS + 1
      DO 40 J=1,N
        LOC2 = LOC2 + (LT(J)-1)*LP(J)
   40 CONTINUE
      TEMP = W(LOC2)
      IF (IND.NE.0) TEMP = TEMP + W(LOC1)
      W(LOC1) = TEMP
      DO 50 J=1,N
        K = N - J + 1
        IF (LLIM(K).LT.0) GO TO 50
        IF (LT(K).EQ.LLIM(K)) GO TO 50
        LT(K) = LT(K) + 1
        IF (K.EQ.N) GO TO 30
        I = K + 1
        GO TO 10
   50 CONTINUE
      RETURN
      END
      SUBROUTINE POWCDF(X,C,CDF)
C
C     NOTE--POWER FUNCTION PDF IS:
C              POWPDF(X,C,B) = C*X**(C-1)/B**C      0 <= X <= B, B > 0
C           WHERE C IS THE SHAPE PARAMETER AND B IS A SCALE PARAMETER.
C           THE STANDARD FORM OF THIS DISTRIBUTION IS:
C              POWPDF(X,C) = C*X**(C-1)             0 <= X <= 1
C           THE CUMULATIVE DISTRIBUTION FUNCTIONS ARE:
C              POWCDF(X,C,B) = (X/B)**C
C              POWCDF(X,C) = X**C
C     REFERENCE --"STATISTICAL DISTRIBUTIONS", EVANS, HASTINGS, PEACOCK
C                 CHAPTER 32.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--95/4
C     ORIGINAL VERSION--APRIL     1995.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
      DOUBLE PRECISION DCDF
C
      INCLUDE 'DPCOMC.INC'
C
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      CDF=0.0
      IF(X.LT.0.0 .OR. X.GT.1.0)THEN
        WRITE(ICOUT,301)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,302)X
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
  301 FORMAT('***** FATAL DIAGNOSTIC--THE INPUT ARGUMENT IS NOT IN 
     1       THE INTERVAL (0,1).')
  302 FORMAT('      IT HAS THE VALUE ',E15.7)
C
      IF(X.LE.0.0)THEN
        CDF=0.0
        RETURN
      ENDIF
      IF(X.GE.1.0)THEN
        CDF=1.0
        RETURN
      ENDIF
C
      DTERM1=DBLE(C)
      DTERM2=DLOG(DBLE(X))
      DTERM3=DTERM1*DTERM2
      DCDF=DEXP(DTERM3)
      CDF=REAL(DCDF)
      GOTO9999
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE POWELD(X,E,N,F,ESCALE,IPRNT,ICON,MAXIT,FUNC)
C
C *   AUTHORS: Necip Doganaksoy and Wayne Nelson
C *   PURPOSE: Maximum likelihood fitting of the power-normal and
C *            -lognormal models to censored life or strength data
C *            from specimens of various sizes
C *   DOCUMENTATION: Wayne Nelson and Necip Doganaksoy, "A Computer
C *                  Program POWNOR for Fitting the Power-Normal and
C *                  -Lognormal Models to Life or Strength Data from
C *                  Specimens of Various Sizes", NISTIR 4760, 3/1992.
C *   PROJECT: 1990-91 ASA/NIST/NSF Fellowship
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      LOGICAL LTP
      LOGICAL LDUMP
C
      COMMON/PNRLST/LTP
      COMMON/PNRIO/INPUT,IOUT
      COMMON/PNRSSS/SCRAT(300)
C
      DIMENSION X(N),E(N)
      DIMENSION W(100)
C
      EXTERNAL PNRFUN
C
      REAL R1MACH
      INCLUDE 'DPCOMC.INC'
      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
      DATA FOUR/4.0D00/
      DATA ZERO,PZ3,PZ5,P1,P4,HALF,ONE,TWO,FIVE,TEN,TWENTY/
     @0.0D00,0.03D00,0.05D00,0.1D00,0.4D00,0.5D00,1.0D00,2.0D00,5.0D00,
     @10.0D00,20.0D00/
C
C     POWELL ALGORTHIM FOR MINIMIZING A FUNCTION OF N VARIABLES
C     WITHOUT THE USE OF DERIVATIVES.
C
      LDUMP=.FALSE.
      NM1=N-1
      LTP=.TRUE.
      FSAVQ=1.0D35
      IPRNT2=IPRNT
      KTO=0
      IF(IPRNT.EQ.5)THEN
         KTO=1
         IPRNT2=1
      ENDIF
      DDMAG=P1*ESCALE
      SCER=PZ5/ESCALE
      JJ=N*N+N
      JJJ=JJ+N
      K=N+1
      NFCC=1
      IND=1
      INN=1
C
      DO 1 I=1,N
         DO 2 J=1,N
            W(K)=ZERO
            IF(I.EQ.J)THEN
               W(K)=DABS(E(I))
               W(I)=ESCALE
            ENDIF
            K=K+1
2        CONTINUE
1     CONTINUE
C
      ITERC=1
      ISGRAD=2
      F=PNRFUN(X,N)
      FKEEP=DABS(F)+DABS(F)
C
 5    CONTINUE
C
      ITONE=1
      FP=F
      SUM=ZERO
      IXP=JJ
      DO 6 I=1,N
         IXP=IXP+1
         W(IXP)=X(I)
 6    CONTINUE
      IDIRN=N+1
      ILINE=1
C
 7    CONTINUE
C
      DMAX=W(ILINE)
      DACC=DMAX*SCER
      DMAG=DMIN1(DDMAG, P1*DMAX)
      DMAG=DMAX1(DMAG,TWENTY*DACC)
      DDMAX=TEN*DMAG
      IF(ITONE.EQ.3)GOTO71
      DL=ZERO
      D=DMAG
      FPREV=F
      IS=5
      FA=F
      DA=DL
C
 8    CONTINUE
C
      DD=D-DL
      DL=D
C
 58   CONTINUE
      K=IDIRN
      DO 9 I=1,N
         X(I)=X(I)+DD*W(K)
         K=K+1
9     CONTINUE
      F=PNRFUN(X,N)
      NFCC=NFCC+1
      GO TO(10,11,12,13,14,96),IS
14    CONTINUE
      IF(F.LT.FA)THEN
         FB=F
         DB=D
         GO TO 21
      ELSEIF(F.EQ.FA)THEN
         IF(DABS(D).LE.DMAX)THEN
            D=D+D
            GO TO 8
         ELSE
            WRITE(ICOUT,19)
19          FORMAT(5X,'MAXIMUM CHANGE DOES NOT ALTER FUNCTION')
            CALL DPWRST('XXX','WRIT')
            RETURN
         ENDIF
      ENDIF
      FB=FA
      DB=DA
      FA=F
      DA=D
C
21    CONTINUE
      IF(ISGRAD.NE.1)GOTO921
         D=HALF*(DA+DB-(FA-FB)/(DA-DB))
         IS=4
         IF((DA-D)*(D-DB).GE.0.0D0)GOTO8
25       CONTINUE
         IS=1
         IF(DABS(D-DB)-DDMAX.LE.0.0D0)GOTO8
26       CONTINUE
         D=DB+DSIGN(DDMAX,DB-DA)
         IS=1
         DDMAX=DDMAX+DDMAX
         DDMAG=DDMAG+DDMAG
         IF(DDMAX.LE.DMAX)GOTO8
         DDMAX=DMAX
         GO TO 8
921   CONTINUE
C
23    CONTINUE
      D=DB+DB-DA
      IS=1
      GO TO 8
C
 13   IF(F.GE.FA)GOTO23
 28   CONTINUE
      FC=FB
      DC=DB
29    CONTINUE
      FB=F
      DB=D
      GO TO 30
C
12    IF(F.LE.FB)GOTO28
      FA=F
      DA=D
      GO TO 30
C
11    CONTINUE
      IF(F.GE.FB)GOTO10
      FA=FB
      DA=DB
      GO TO 29
C
71    DL=ONE
      DDMAX=FIVE
      FA=FP
      DA=-ONE
      FB=FHOLD
      DB=ZERO
      D=ONE
C
10    CONTINUE
      FC=F
      DC=D
C
30    CONTINUE
      A=(DB-DC)*(FA-FC)
      B=(DC-DA)*(FB-FC)
      IF((A+B)*(DA-DC).LE.0.0D0)THEN
         FA=FB
         DA=DB
         FB=FC
         DB=DC
         GO TO 26
      ELSE
         D=HALF*(A*(DB+DC)+B*(DA+DC))/(A+B)
         DI=DB
         FI=FB
         IF(FB.GT.FC)THEN
            DI=DC
            FI=FC
         ENDIF
         IF(ITONE.EQ.2)THEN
            ITONE=2
            GO TO 45
         ENDIF
      ENDIF
      IF(DABS(D-DI)-DACC.LE.0.0D0)GOTO41
      IF(DABS(D-DI)- PZ3*DABS(D).LE.0.0D0)GOTO41
45    CONTINUE
      IF((DA-DC)*(DC-D).GE.0.0D0)THEN
         FA=FB
         DA=DB
         FB=FC
         DB=DC
         GO TO 25
      ELSE
        IS=2
        IF((DB-D)*(D-DC).GE.0.0D0)GOTO8
        IS=3
        GO TO 8
      ENDIF
41    CONTINUE
      F=FI
      D=DI-DL
      DD=DSQRT((DC-DB)*(DC-DA)*(DA-DB)/(A+B))
      DO 49 I=1,N
         X(I)=X(I)+D*W(IDIRN)
         W(IDIRN)=DD*W(IDIRN)
         IDIRN=IDIRN+1
49    CONTINUE
      W(ILINE)=W(ILINE)/DD
      ILINE=ILINE+1
      IF(IPRNT2.EQ.1)THEN
         IF(KTO.EQ.1) THEN
            FMVAL=-F
            WRITE(ICOUT,555)ITERC,NFCC,FMVAL,(X(I),I=1,N)
555         FORMAT(2X,I4,12X,I5,8X,D16.5,2X,6D13.5)
            CALL DPWRST('XXX','WRIT')
         ELSE
            WRITE(ICOUT,52)ITERC,NFCC
52          FORMAT(' ITERATION ',I5,I10,' FUNCT. EVAL.')
            CALL DPWRST('XXX','WRIT')
            WRITE(ICOUT,952)F
952         FORMAT(' F =',E18.8)
            CALL DPWRST('XXX','WRIT')
            WRITE(ICOUT,953)(X(I),I=1,N)
953         FORMAT(8F14.8)
            CALL DPWRST('XXX','WRIT')
         ENDIF
         IF(IPRNT2.EQ.2)GOTO53
      ENDIF
      IF(ITONE.EQ.2)GOTO38
      IF(FPREV-F-SUM.GE.0.0D0)THEN
         SUM=FPREV-F
         JTL=ILINE
      ENDIF
      IF(IDIRN.LE.JJ)GOTO7
      IF(IND.EQ.2)GOTO72
C
 92   CONTINUE
      FHOLD=F
      IS=6
      IXP=JJ
      DO 59 I=1,N
         IXP=IXP+1
         W(IXP)=X(I)-W(IXP)
59    CONTINUE
      DD=ONE
      GO TO 58
C
 96   CONTINUE
      IF(IND.EQ.1)THEN
         IF(FP-F.LE.0.0D0)GOTO37
         D=TWO*(FP+F-TWO*FHOLD)/(FP-F)**2
         IF(D*(FP-FHOLD-SUM)**2-SUM.GE.0.0D0)GOTO37
      ENDIF
      J=JTL*N+1
      IF(J.GT.JJ)THEN
         DO 62 I=J,JJ
            K=I-N
            W(K)=W(I)
62       CONTINUE
         DO 97 I=JTL,N
            W(I-1)=W(I)
97       CONTINUE
      ENDIF
      IDIRN=IDIRN-N
      ITONE=3
      K=IDIRN
      IXP=JJ
      AAA=ZERO
      DO 65 I=1,N
         IXP=IXP+1
         W(K)=W(IXP)
         IF(AAA-DABS(W(K)/E(I)).LE.0.0D0)THEN
            AAA=DABS(W(K)/E(I))
         ENDIF
         K=K+1
65    CONTINUE
      DDMAG=ONE
      W(N)=ESCALE/AAA
      ILINE=N
      GO TO 7
C
 37   IXP=JJ
      AAA=ZERO
      F=FHOLD
      DO 99 I=1,N
         IXP=IXP+1
         X(I)=X(I)-W(IXP)
         IF(AAA*DABS(E(I))-DABS(W(IXP)).LE.0.0D0)THEN
            AAA=DABS(W(IXP)/E(I))
         ENDIF
99    CONTINUE
      GO TO 72
C
 38   CONTINUE
      AAA=AAA*(ONE+DI)
      IF(IND.EQ.2)GOTO106
C
72    CONTINUE
C
      IF(IPRNT2.LT.2)THEN
         IF(KTO.EQ.1) THEN
            FMVAL=-F
            WRITE(ICOUT,555)ITERC,NFCC,FMVAL,(X(I),I=1,N)
            CALL DPWRST('XXX','WRIT')
         ELSE
            WRITE(ICOUT,52)ITERC,NFCC
            CALL DPWRST('XXX','WRIT')
            WRITE(ICOUT,952)F
            CALL DPWRST('XXX','WRIT')
            WRITE(ICOUT,953)(X(I),I=1,N)
            CALL DPWRST('XXX','WRIT')
         ENDIF
      ENDIF
C
 53   CONTINUE
      IF(IND.EQ.2)GOTO88
      IF(AAA.GT.P1)GOTO76
      IF(ICON.EQ.1)RETURN
      IND=2
      IF(INN.EQ.2)GOTO101
      INN=2
      K=JJJ
      DO 102 I=1,N
         K=K+1
         W(K)=X(I)
         X(I)=X(I)+TEN*E(I)
102   CONTINUE
      FKEEP=F
      F=FUNC(X,N)
      NFCC=NFCC+1
      DDMAG=ZERO
      GO TO 108
C
 76   CONTINUE
      IF(F.LT.FP)GOTO35
C
 78   CONTINUE
      WRITE(ICOUT,80)
80    FORMAT('ACCURACY LIMITED BY ERRORS IN FUNCTION')
      CALL DPWRST('XXX','WRIT')
      RETURN
C
 88   CONTINUE
      IND=1
C
 35   CONTINUE
      DDMAG=FOUR*DSQRT(FP-F)
      ISGRAD=1
108   CONTINUE
      ITERC=ITERC+1
C
C        CHECK TO SEE IF THE LIKELIHOOD IS CHANGING SLOWLY
C
      IF(.NOT.LTP) GO TO 2002
      IF(DABS(F-FSAVQ).GT.ONE) GO TO 2001
      IF(LDUMP)THEN
         WRITE(ICOUT,4998)
4998     FORMAT('***LOGLIKELIHOOD CHANGED BY LESS THAN ONE IN THIS')
         CALL DPWRST('XXX','WRIT')
         WRITE(ICOUT,4999)
4999     FORMAT('ITERATION.  CHANGING TO UNTRANSFORMED OBSERVATIONS')
         CALL DPWRST('XXX','WRIT')
      ENDIF
      LTP=.FALSE.
2001  FSAVQ=F
2002  CONTINUE
      IF(ITERC.LE.MAXIT)GOTO5
      WRITE(ICOUT,82)MAXIT
82    FORMAT(1X,I4,' ITERATIONS COMPLETED WITHOUT MEETING ',
     1       'SPECIFICATIONS')
      CALL DPWRST('XXX','WRIT')
      IF(F.LE.FKEEP)RETURN
      F=FKEEP
      DO 111 I=1,N
         JJJ=JJJ+1
         X(I)=W(JJJ)
111   CONTINUE
      RETURN
C
101   JTL=1
      FP=FKEEP
      IF(F.EQ.FKEEP)THEN
         GOTO78
      ELSEIF(F.GT.FKEEP)THEN
         JTL=2
         FP=F
         F=FKEEP
      ENDIF
      IXP=JJ
      DO 113 I=1,N
         IXP=IXP+1
         K=IXP+N
         IF(JTL.EQ.1)THEN
            W(IXP)=W(K)
         ELSE
            W(IXP)=X(I)
            X(I)=W(K)
         ENDIF
113   CONTINUE
      JTL=2
      GO TO 92
C
106   CONTINUE
      IF(AAA.LE.P1)THEN
         RETURN
      ELSE
         INN=1
         GO TO 35
      ENDIF
C
      END
      SUBROUTINE POWPDF(X,C,PDF)
C
C     NOTE--POWER FUNCTION PDF IS:
C              POWPDF(X,C,B) = C*X**(C-1)/B**C      0 <= X <= B, B > 0
C           WHERE C IS THE SHAPE PARAMETER AND B IS A SCALE PARAMETER.
C           THE STANDARD FORM OF THIS DISTRIBUTION IS:
C              POWPDF(X,C,B) = C*X**(C-1)           0 <= X <= 1
C     REFERENCE --"STATISTICAL DISTRIBUTIONS", EVANS, HASTINGS, PEACOCK
C                 CHAPTER 32.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--95/4
C     ORIGINAL VERSION--APRIL     1995.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
      DOUBLE PRECISION DARG
      DOUBLE PRECISION DMIN
      DOUBLE PRECISION DPDF
C
      INCLUDE 'DPCOMC.INC'
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      PDF=0.0
      IF(X.LT.0.0 .OR. X.GT.1.0)THEN
        WRITE(ICOUT,301)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,302)X
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
  301 FORMAT('***** FATAL DIAGNOSTIC--THE INPUT ARGUMENT IS NOT IN 
     1       THE INTERVAL (0,1).')
  302 FORMAT('      IT HAS THE VALUE ',E15.7)
C
      DARG=DBLE(X)
      DMIN=D1MACH(1)
      IF(DARG.LE.DMIN)DARG=DMIN
      DTERM1=DLOG(DBLE(C))
      DTERM2=DBLE(C-1.0)*DLOG(DARG)
      DTERM3=DTERM1 + DTERM2
      IF(REAL(DTERM3).GE.LOG(R1MACH(2)))THEN
        WRITE(ICOUT,401)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,402)X
        CALL DPWRST('XXX','BUG ')
        PDF=LOG(R1MACH(2))
        GOTO9999
      ENDIF
  401 FORMAT('***** FATAL DIAGNOSTIC--THE COMPUTED VALUE OF THE PDF ',
     1       'OVERFLOWS.  SET TO THE LOG OF LARGEST NUMBER.')
  402 FORMAT('      THE INPUT ARGUMENT HAS THE VALUE ',E15.7)
      DPDF=DEXP(DTERM3)
      PDF=REAL(DPDF)
      GOTO9999
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE POWRAN(N,C,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE THE POWER FUNCTION
C              DISTRIBUTION WITH SCALE PARAMETER = 1
C              THIS DISTRIBUTION IS DEFINED FOR 0 <= X <= 1
C              THE PROBABILITY DENSITY FUNCTION
C              F(X) = C*X**(C-1)/(B**C)
C              WHERE C IS THE SHAPE PARAMETER AND B IS THE SCALE
C              PARAMETER.
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 NORMAL DISTRIBUTION
C             WITH MEAN = 0 AND STANDARD DEVIATION = 1.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--EXP
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--EVANS, HASTINGS, AND PEACOCK  "STATISTICAL
C                 DISTRIBUTIONS", CHAPTER 32.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--95.4
C     ORIGINAL VERSION--APRIL     1995.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      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'POWRAN SUBROUTINE IS NON-POSITIVE *****')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
C
C     GENERATE N UNIFORM (0,1) RANDOM NUMBERS;
C     THEN GENERATE 2 ADDITIONAL UNIFORM (0,1) RANDOM NUMBERS
C     (TO BE USED BELOW IN FORMING THE N-TH NORMAL
C     RANDOM NUMBER WHEN THE DESIRED SAMPLE SIZE N
C     HAPPENS TO BE ODD).
C
      CALL UNIRAN(N,ISEED,X)
C
C     POWER FUNCTION RANDOM NUMBERS = (UNIFORM)**(1/C)
C
      DO200I=1,N
      X(I)=X(I)**(1.0/C)
  200 CONTINUE
C
      RETURN
      END
      SUBROUTINE POWPPF(P,C,PPF)
C
C     NOTE--POWER FUNCTION PDF IS:
C              POWPDF(X,C,B) = C*X**(C-1)/B**C      0 <= X <= B, B > 0
C           WHERE C IS THE SHAPE PARAMETER AND B IS A SCALE PARAMETER.
C           THE STANDARD FORM OF THIS DISTRIBUTION IS:
C              POWPDF(X,C) = C*X**(C-1)             0 <= X <= 1
C           THE PERCENT POINT FUNCTIONS ARE:
C              POWPPF(X,C,B) = B*P**(1/C)
C              POWPPF(X,C)   = P**(1/C)
C     REFERENCE --"STATISTICAL DISTRIBUTIONS", EVANS, HASTINGS, PEACOCK
C                 CHAPTER 32.
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE POWER FUNCTION 
C              DISTRIBUTION FROM 0 TO 1
C     INPUT  ARGUMENTS--P      = THE SINGLE PRECISION VALUE
C                                (BETWEEN 0.0 AND 1.0)
C                                AT WHICH THE PERCENT POINT
C                                FUNCTION IS TO BE EVALUATED.
C     OUTPUT ARGUMENTS--PPF    = THE SINGLE PRECISION PERCENT
C                                POINT FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PERCENT POINT
C             FUNCTION VALUE PPF.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--P SHOULD BE BETWEEN 0.0 AND 1.0, INCLUSIVELY.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--95.4
C     ORIGINAL VERSION--APRIL     1995.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
      DOUBLE PRECISION DPPF
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(P.LT.0.0.OR.P.GT.1.0)GOTO50
      GOTO90
   50 WRITE(ICOUT,1)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)P
      CALL DPWRST('XXX','BUG ')
      RETURN
   90 CONTINUE
    1 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ',
     1'POWPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
C-----START POINT-----------------------------------------------------
C
      IF(P.EQ.0.0)THEN
        PPF=0.0
      ELSEIF(P.EQ.1.0)THEN
        PPF=1.0
      ELSE
        DTERM1=DBLE(1.0/C)
        DTERM2=DLOG(DBLE(P))
        DTERM3=DTERM1*DTERM2
        DPPF=DEXP(DTERM3)
        PPF=REAL(DPPF)
      ENDIF
C
      RETURN
      END
      REAL FUNCTION PPND(P, IFAULT)
C
C  ALGORITHM AS 111  APPL. STATIST. (1977), VOL.26, NO.1
C
C  PRODUCES NORMAL DEVIATE CORRESPONDING TO LOWER TAIL AREA OF P
C  REAL VERSION FOR EPS = 2 **(-31)
C  THE HASH SUMS ARE THE SUMS OF THE MODULI OF THE COEFFICIENTS
C  THEY HAVE NO INHERENT MEANINGS BUT ARE INCLUDED FOR USE IN
C  CHECKING TRANSCRIPTIONS
C  STANDARD FUNCTIONS ABS, ALOG AND SQRT ARE USED
C
C  NOTE: WE COULD USE DATAPLOT NORPPF, BUT VARIOUS APPLIED
C        STATISTICS ALGORITHMS USE THIS.  SO WE PROVIDE IT TO
C        MAKE USE OF APPLIED STATISTICS ALGORITHMS EASIER.
C
      REAL ZERO, SPLIT, HALF, ONE
      REAL A0, A1, A2, A3, B1, B2, B3, B4, C0, C1, C2, C3, D1, D2
      REAL P, Q, R
      INTEGER IFAULT
      DATA ZERO /0.0E0/, HALF/0.5E0/, ONE/1.0E0/
      DATA SPLIT /0.42E0/
      DATA A0 / 2.50662823884E0/
      DATA A1 / -18.61500062529E0/
      DATA A2 / 41.39119773534E0/
      DATA A3 / -25.44106049637E0/
      DATA B1 / -8.47351093090E0/
      DATA B2 / 23.08336743743E0/
      DATA B3 / -21.06224101826E0/
      DATA B4 / 3.13082909833E0/
      DATA C0 / -2.78718931138E0/
      DATA C1 / -2.29796479134E0/
      DATA C2 / 4.85014127135E0/
      DATA C3 / 2.32121276858E0/
      DATA D1 / 3.54388924762E0/
      DATA D2 / 1.63706781897E0/
C
      IFAULT = 0
      Q = P - HALF
      IF (ABS(Q) .GT. SPLIT) GOTO 1
      R = Q*Q
      PPND = Q * (((A3*R + A2)*R + A1) * R + A0) /
     *  ((((B4*R + B3)*R + B2) * R + B1) * R + ONE)
      RETURN
1     R = P
      IF (Q .GT. ZERO)R = ONE - P
      IF (R .LE. ZERO) GOTO 2
      R = SQRT(-ALOG(R))
      PPND = (((C3 * R + C2) * R + C1) * R + C0)/
     *  ((D2*R + D1) * R + ONE)
      IF (Q .LT. ZERO) PPND = -PPND
      RETURN
2     IFAULT = 1
      PPND = ZERO
      RETURN
      END
      SUBROUTINE PRIMES(N,X,IERROR)
C
C     PURPOSE--THIS SUBROUTINE GENERATES THE FIRST N PRIME NUMBERS--
C              2, 3, 5, 7, 11, ...
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF PRIME NUMBERS
C                                TO BE GENERATED.
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST N)
C                                INTO WHICH THE GENERATED
C                                PRIME NUMBERS
C                                WILL BE PLACED.
C     OUTPUT--THE FIRST N PRIME NUMBERS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C     LANGUAGE--ANSI FORTRAN (1977)
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--87.10
C     ORIGINAL VERSION--SEPTEMBER 1987.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IERROR
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C               ******************************************
C               **  TREAT THE PRIMES NUMBERS CASE       **
C               ******************************************
C
C               *******************************************
C               **  STEP 1--                             **
C               **  TEST THE INPUT ARGUMENTS FOR ERRORS  **
C               *******************************************
C
      IF(N.GE.1)GOTO190
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,101)
  101 FORMAT('***** ERROR IN GENMS--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,102)
  102 FORMAT('      THE LENGTH OF THE DESIRED SEQUENCE')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,103)
  103 FORMAT('      OF PRIME NUMBERS MUST BE 1 OR LARGER;')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,104)
  104 FORMAT('      SUCH WAS NOT THE CASE HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,105)N
  105 FORMAT('      N = ',I8)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
  190 CONTINUE
C
C               ******************************
C               **  STEP 2--                **
C               **  GENERATE THE SEQUENCE   **
C               ******************************
C
      X(1)=2
      X(2)=3
      X(3)=5
C
      NP=3
      DO1100I=7,100000,2
      ANP=NP
      JMAX=SQRT(ANP)+1.5
C
      DO1200J=2,JMAX
      IXJ=X(J)+0.5
      K=MOD(I,IXJ)
      IF(K.EQ.0)GOTO1100
 1200 CONTINUE
C
      NP=NP+1
      X(NP)=I
      IF(NP.GE.N)GOTO1190
C
 1100 CONTINUE
 1190 CONTINUE
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE PROD(X,N,IWRITE,XPROD,IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE
C              SAMPLE PRODUCT
C              OF THE DATA IN THE INPUT VECTOR X.
C              THE SAMPLE PRODUCT = PRODUCT 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--XPROD   = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED SAMPLE PRODUCT.
C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
C             SAMPLE PRODUCT.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (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         --FEBRUARY  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
      DOUBLE PRECISION DX
      DOUBLE PRECISION DPROD
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='PROD'
      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 PROD--')
      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 PRODUCT  **
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 PROD--')
      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 PRODUCT 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 PROD--',
     1'THE SECOND INPUT ARGUMENT (N) HAS THE VALUE 1')
      CALL DPWRST('XXX','BUG ')
      XPROD=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 PROD--',
     1'THE FIRST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      XPROD=HOLD**N
      GOTO9000
  139 CONTINUE
C
  190 CONTINUE
C
C               ****************************
C               **  STEP 2--              **
C               **  COMPUTE THE PRODUCT.  **
C               ****************************
C
      DPROD=1.0D0
      DO200I=1,N
      DX=X(I)
      DPROD=DPROD*DX
  200 CONTINUE
      XPROD=DPROD
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,XPROD
  811 FORMAT('THE PRODUCT 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 PROD--')
      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)XPROD
 9015 FORMAT('XPROD = ',E15.7)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE PROP(X,N,ANOPL1,ANOPL2,IWRITE,XPROP,
     1IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE
C              PROPORTION (0 TO 100%) OF DATA
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                     --ANOPL1 = UPPER (ENGINEERING) SPEC LIMIT
C                     --ANOPL2 = LOWER (ENGINEERING) SPEC LIMIT
C     OUTPUT ARGUMENTS--PROP = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED SAMPLE EXPECTED LOSS
C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
C             SAMPLE EXPECTED LOSS (IN XPROP)
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C     LANGUAGE--ANSI FORTRAN (1977)
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--89.5
C     ORIGINAL VERSION--MAY       1989.
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='PROP'
      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 PROP--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)IBUGA3
   52 FORMAT('IBUGA3 = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)N
   53 FORMAT('N = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,54)ANOPL1,ANOPL2
   54 FORMAT('ANOPL1,ANOPL2 = ',2E15.7)
      CALL DPWRST('XXX','BUG ')
      DO55I=1,N
      WRITE(ICOUT,56)I,X(I)
   56 FORMAT('I,X(I) = ',I8,E15.7)
      CALL DPWRST('XXX','BUG ')
   55 CONTINUE
   90 CONTINUE
C
C               ********************************************
C               **  COMPUTE THE PROPORTION STATISTIC      **
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 PROP--')
      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 PROPORTION 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 PROP--',
CCCCC1'THE SECOND INPUT ARGUMENT (N) HAS THE VALUE 1')
CCCCC CALL DPWRST('XXX','BUG ')
      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 PROP--',
CCCCC1'THE FIRST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7)
CCCCC CALL DPWRST('XXX','BUG ')
      GOTO9000
  139 CONTINUE
C
  190 CONTINUE
C
C               *******************************
C               **  STEP 2--                 **
C               **  COMPUTE THE PROPORTION.  **
C               *******************************
C
      ANOPL3=ANOPL1
      IF(ANOPL1.GT.ANOPL2)ANOPL3=ANOPL2
C
      ANOPL4=ANOPL2
      IF(ANOPL1.GT.ANOPL2)ANOPL4=ANOPL1
C
      XPROP=0.0
      ICOUNT=0
      DO200I=1,N
      IF(ANOPL3.LE.X(I).AND.X(I).LE.ANOPL4)ICOUNT=ICOUNT+1
  200 CONTINUE
      COUNT=ICOUNT
C
      P=COUNT/AN
      XPROP=100.0*P
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,XPROP
  811 FORMAT('THE PROPORTION 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 PROP--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IBUGA3,IERROR
 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9015)ANOPL1,ANOPL2
 9015 FORMAT('ANOPL1,ANOPL2 = ',2E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9016)ANOPL3,ANOPL4
 9016 FORMAT('ANOPL3,ANOPL4 = ',2E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9017)N,ICOUNT,AN,COUNT
 9017 FORMAT('N,ICOUNT,AN,COUNT = ',2I8,2E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9018)P,XPROP
 9018 FORMAT('P,XPROP = ',2E15.7)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      double precision function prtrng(q, v, r, ifault)
      implicit double precision (a-h, o-z)
c
c        Algorithm AS 190  Appl. Statist. (1983) Vol.32, No. 2
c       Incorporates corrections from Appl. Statist. (1985) Vol.34 (1)
c
c        Evaluates the probability from 0 to q for a studentized
c        range having v degrees of freedom and r samples.
c
c        Uses subroutine ALNORM = algorithm AS66.
c
c        Arrays vw and qw store transient values used in the
c        quadrature summation.  Node spacing is controlled by
c        step.  pcutj and pcutk control truncation.
c        Minimum and maximum number of steps are controlled by
c        jmin, jmax, kmin and kmax.  Accuracy can be increased
c        by use of a finer grid - Increase sizes of arrays vw
c        and qw, and jmin, jmax, kmin, kmax and 1/step proportionally.
c
      double precision q,v,r,vw(30), qw(30), pcutj, pcutk, step,
     #    vmax,zero,fifth,half,one,two,cv1,cv2,cvmax,cv(4)
      double precision g, gmid, r1, c, h, v2, gstep, pk1, pk2, gk, pk
      double precision w0, pz, x, hj, ehj, pj
      double precision alnorm
      external alnorm
      data pcutj, pcutk, step, vmax /0.00003d0, 0.0001d0, 0.45d0,
     #   120.0d0/, zero, fifth, half, one, two /0.0d0, 0.2d0, 0.5d0,
     #   1.0d0, 2.0d0/, cv1, cv2, cvmax /0.193064705d0, 0.293525326d0,
     #   0.39894228d0/, cv(1), cv(2), cv(3), cv(4) /0.318309886d0,
     #   -0.268132716d-2, 0.347222222d-2, 0.833333333d-1/
      data jmin, jmax, kmin, kmax/3, 15, 7, 15/
c
c        Check initial values
c
      prtrng = zero
      ifault = 0
      if (v .lt. one .or. r .lt. two) ifault = 1
      if (q .le. zero .or. ifault .eq. 1) goto 99
c
c        Computing constants, local midpoint, adjusting steps.
c
      g = step * r ** (-fifth)
      gmid = half * log(r)
      r1 = r - one
      c = log(r * g * cvmax)
      if(v.gt.vmax) goto 20
c
      h = step * v ** (-half)
      v2 = v * half
      if (v .eq. one) c = cv1
      if (v .eq. two) c = cv2
      if (.not. (v .eq. one .or. v .eq. two)) c = sqrt(v2)
     #    * cv(1) / (one + ((cv(2) / v2 + cv(3)) / v2 + cv(4)) / v2)
      c = log(c * r * g * h)
c
c        Computing integral
c        Given a row k, the procedure starts at the midpoint and works
c        outward (index j) in calculating the probability at nodes
c        symmetric about the midpoint.  The rows (index k) are also
c        processed outwards symmetrically about the midpoint.  The
c        centre row is unpaired.
c
   20 gstep = g
      qw(1) = -one
      qw(jmax + 1) = -one
      pk1 = one
      pk2 = one
      do 28 k = 1, kmax
      gstep = gstep - g
   21   gstep = -gstep
      gk = gmid + gstep
      pk = zero
      if (pk2 .le. pcutk .and. k .gt. kmin) goto 26
      w0 = c - gk * gk * half
        pz = alnorm(gk, .true.)
        x = alnorm(gk - q, .true.) - pz
      if (x .gt. zero) pk = exp(w0 + r1 * log(x))
      if (v .gt. vmax) goto 26
c
      jump = -jmax
   22   jump = jump + jmax
      do 24 j = 1, jmax
        jj = j + jump
        if (qw(jj) .gt. zero) goto 23
        hj = h * j
        if (j .lt. jmax) qw(jj + 1) = -one
        ehj = exp(hj)
        qw(jj) = q * ehj
        vw(jj) = v * (hj + half - ehj * ehj * half)
c
   23     pj = zero
          x = alnorm(gk - qw(jj), .true.) - pz
        if (x .gt. zero) pj = exp(w0 + vw(jj) + r1 * log(x))
        pk = pk + pj
        if (pj .gt. pcutj) goto 24
        if (jj .gt. jmin .or. k .gt. kmin) goto 25
   24   continue
   25   h = -h
      if (h .lt. zero) goto 22
c
   26   prtrng = prtrng + pk
      if (k .gt. kmin .and. pk .le. pcutk .and. pk1 .le. pcutk)goto 99
      pk2 = pk1
      pk1 = pk
      if (gstep .gt. zero) goto 21
   28 continue
c
   99 return
      end
      FUNCTION PSIXN (N)
C***BEGIN PROLOGUE  PSIXN
C***SUBSIDIARY
C***PURPOSE  Subsidiary to EXINT
C***LIBRARY   SLATEC
C***TYPE      SINGLE PRECISION (PSIXN-S, DPSIXN-D)
C***AUTHOR  Amos, D. E., (SNLA)
C***DESCRIPTION
C
C     This subroutine returns values of PSI(X)=derivative of log
C     GAMMA(X), X .GT. 0.0 at integer arguments. A table look-up is
C     performed for N .LE. 100, and the asymptotic expansion is
C     evaluated for N .GT. 100.
C
C***SEE ALSO  EXINT
C***ROUTINES CALLED  R1MACH
C***REVISION HISTORY  (YYMMDD)
C   800501  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900328  Added TYPE section.  (WRB)
C   910722  Updated AUTHOR section.  (ALS)
C***END PROLOGUE  PSIXN
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C
      INTEGER N, K
      REAL             AX, B, C, FN, RFN2, TRM, S, WDTOL
      DIMENSION B(6), C(100)
C-----------------------------------------------------------------------
C             PSIXN(N), N = 1,100
C-----------------------------------------------------------------------
      DATA C(1), C(2), C(3), C(4), C(5), C(6), C(7), C(8), C(9), C(10),
     1     C(11), C(12), C(13), C(14), C(15), C(16), C(17), C(18),
     2     C(19), C(20), C(21), C(22), C(23), C(24)/
     3    -5.77215664901532861E-01,     4.22784335098467139E-01,
     4     9.22784335098467139E-01,     1.25611766843180047E+00,
     5     1.50611766843180047E+00,     1.70611766843180047E+00,
     6     1.87278433509846714E+00,     2.01564147795561000E+00,
     7     2.14064147795561000E+00,     2.25175258906672111E+00,
     8     2.35175258906672111E+00,     2.44266167997581202E+00,
     9     2.52599501330914535E+00,     2.60291809023222227E+00,
     1     2.67434666166079370E+00,     2.74101332832746037E+00,
     2     2.80351332832746037E+00,     2.86233685773922507E+00,
     3     2.91789241329478063E+00,     2.97052399224214905E+00,
     4     3.02052399224214905E+00,     3.06814303986119667E+00,
     5     3.11359758531574212E+00,     3.15707584618530734E+00/
      DATA C(25), C(26), C(27), C(28), C(29), C(30), C(31), C(32),
     1     C(33), C(34), C(35), C(36), C(37), C(38), C(39), C(40),
     2     C(41), C(42), C(43), C(44), C(45), C(46), C(47), C(48)/
     3     3.19874251285197401E+00,     3.23874251285197401E+00,
     4     3.27720405131351247E+00,     3.31424108835054951E+00,
     5     3.34995537406483522E+00,     3.38443813268552488E+00,
     6     3.41777146601885821E+00,     3.45002953053498724E+00,
     7     3.48127953053498724E+00,     3.51158256083801755E+00,
     8     3.54099432554389990E+00,     3.56956575411532847E+00,
     9     3.59734353189310625E+00,     3.62437055892013327E+00,
     1     3.65068634839381748E+00,     3.67632737403484313E+00,
     2     3.70132737403484313E+00,     3.72571761793728215E+00,
     3     3.74952714174680596E+00,     3.77278295570029433E+00,
     4     3.79551022842756706E+00,     3.81773245064978928E+00,
     5     3.83947158108457189E+00,     3.86074817682925274E+00/
      DATA C(49), C(50), C(51), C(52), C(53), C(54), C(55), C(56),
     1     C(57), C(58), C(59), C(60), C(61), C(62), C(63), C(64),
     2     C(65), C(66), C(67), C(68), C(69), C(70), C(71), C(72)/
     3     3.88158151016258607E+00,     3.90198967342789220E+00,
     4     3.92198967342789220E+00,     3.94159751656514710E+00,
     5     3.96082828579591633E+00,     3.97969621032421822E+00,
     6     3.99821472884273674E+00,     4.01639654702455492E+00,
     7     4.03425368988169777E+00,     4.05179754953082058E+00,
     8     4.06903892884116541E+00,     4.08598808138353829E+00,
     9     4.10265474805020496E+00,     4.11904819067315578E+00,
     1     4.13517722293122029E+00,     4.15105023880423617E+00,
     2     4.16667523880423617E+00,     4.18205985418885155E+00,
     3     4.19721136934036670E+00,     4.21213674247469506E+00,
     4     4.22684262482763624E+00,     4.24133537845082464E+00,
     5     4.25562109273653893E+00,     4.26970559977879245E+00/
      DATA C(73), C(74), C(75), C(76), C(77), C(78), C(79), C(80),
     1     C(81), C(82), C(83), C(84), C(85), C(86), C(87), C(88),
     2     C(89), C(90), C(91), C(92), C(93), C(94), C(95), C(96)/
     3     4.28359448866768134E+00,     4.29729311880466764E+00,
     4     4.31080663231818115E+00,     4.32413996565151449E+00,
     5     4.33729786038835659E+00,     4.35028487337536958E+00,
     6     4.36310538619588240E+00,     4.37576361404398366E+00,
     7     4.38826361404398366E+00,     4.40060929305632934E+00,
     8     4.41280441500754886E+00,     4.42485260777863319E+00,
     9     4.43675736968339510E+00,     4.44852207556574804E+00,
     1     4.46014998254249223E+00,     4.47164423541605544E+00,
     2     4.48300787177969181E+00,     4.49424382683587158E+00,
     3     4.50535493794698269E+00,     4.51634394893599368E+00,
     4     4.52721351415338499E+00,     4.53796620232542800E+00,
     5     4.54860450019776842E+00,     4.55913081598724211E+00/
      DATA C(97), C(98), C(99), C(100)/
     1     4.56954748265390877E+00,     4.57985676100442424E+00,
     2     4.59006084263707730E+00,     4.60016185273808740E+00/
C-----------------------------------------------------------------------
C             COEFFICIENTS OF ASYMPTOTIC EXPANSION
C-----------------------------------------------------------------------
      DATA B(1), B(2), B(3), B(4), B(5), B(6)/
     1     8.33333333333333333E-02,    -8.33333333333333333E-03,
     2     3.96825396825396825E-03,    -4.16666666666666666E-03,
     3     7.57575757575757576E-03,    -2.10927960927960928E-02/
C
C***FIRST EXECUTABLE STATEMENT  PSIXN
      IF (N.GT.100) GO TO 10
      PSIXN = C(N)
      RETURN
   10 CONTINUE
      WDTOL = MAX(R1MACH(4),1.0E-18)
      FN = N
      AX = 1.0E0
      S = -0.5E0/FN
      IF (ABS(S).LE.WDTOL) GO TO 30
      RFN2 = 1.0E0/(FN*FN)
      DO 20 K=1,6
        AX = AX*RFN2
        TRM = -B(K)*AX
        IF (ABS(TRM).LT.WDTOL) GO TO 30
        S = S + TRM
   20 CONTINUE
   30 CONTINUE
      PSIXN = S + LOG(FN)
      RETURN
      END
      subroutine psort(a,n,ind,ni)
c
c  This routine is part of the Bill Cleveland seasonal loess
c  program.
c
      real a(n)
      integer n,ind(ni),ni
      integer indu(16),indl(16),iu(16),il(16),p,jl,ju,i,j,m,k,ij,l
      real t,tt
      if(.not.(n .lt. 0 .or. ni .lt. 0))goto 23157
      return
23157 continue
      if(.not.(n .lt. 2  .or.  ni .eq. 0))goto 23159
      return
23159 continue
      jl = 1
      ju = ni
      indl(1) = 1
      indu(1) = ni
      i = 1
      j = n
      m = 1
23161 continue
      if(.not.(i .lt. j))goto 23164
      go to 10
23164 continue
23166 continue
      m = m-1
      if(.not.(m .eq. 0))goto 23169
      goto 23163
23169 continue
      i = il(m)
      j = iu(m)
      jl = indl(m)
      ju = indu(m)
      if(.not.(jl .le. ju))goto 23171
23173 if(.not.(j-i .gt. 10))goto 23174
10    k = i
      ij = (i+j)/2
      t = a(ij)
      if(.not.(a(i) .gt. t))goto 23175
      a(ij) = a(i)
      a(i) = t
      t = a(ij)
23175 continue
      l = j
      if(.not.(a(j) .lt. t))goto 23177
      a(ij) = a(j)
      a(j) = t
      t = a(ij)
      if(.not.(a(i) .gt. t))goto 23179
      a(ij) = a(i)
      a(i) = t
      t = a(ij)
23179 continue
23177 continue
23181 continue
      l = l-1
      if(.not.(a(l) .le. t))goto 23184
      tt = a(l)
23186 continue
      k = k+1
23187 if(.not.(a(k) .ge. t))goto 23186
      if(.not.(k .gt. l))goto 23189
      goto 23183
23189 continue
      a(l) = a(k)
      a(k) = tt
23184 continue
23182 goto 23181
23183 continue
      indl(m) = jl
      indu(m) = ju
      p = m
      m = m+1
      if(.not.(l-i .le. j-k))goto 23191
      il(p) = k
      iu(p) = j
      j = l
23193 continue
      if(.not.(jl .gt. ju))goto 23196
      goto 23167
23196 continue
      if(.not.(ind(ju) .le. j))goto 23198
      goto 23195
23198 continue
      ju = ju-1
23194 goto 23193
23195 continue
      indl(p) = ju+1
      goto 23192
23191 continue
      il(p) = i
      iu(p) = l
      i = k
23200 continue
      if(.not.(jl .gt. ju))goto 23203
      goto 23167
23203 continue
      if(.not.(ind(jl) .ge. i))goto 23205
      goto 23202
23205 continue
      jl = jl+1
23201 goto 23200
23202 continue
      indu(p) = jl-1
23192 continue
      goto 23173
23174 continue
      if(.not.(i .eq. 1))goto 23207
      goto 23168
23207 continue
      i = i-1
23209 continue
      i = i+1
      if(.not.(i .eq. j))goto 23212
      goto 23211
23212 continue
      t = a(i+1)
      if(.not.(a(i) .gt. t))goto 23214
      k = i
23216 continue
      a(k+1) = a(k)
      k = k-1
23217 if(.not.(t .ge. a(k)))goto 23216
      a(k+1) = t
23214 continue
23210 goto 23209
23211 continue
23171 continue
23167 goto 23166
23168 continue
23162 goto 23161
23163 continue
      return
      end
      function pull(a,n,k,b)
cc  Finds the kth order statistic of an array a of length n<=1000
      dimension a(*),b(*)
C
      do 15 j=1,n
        b(j)=a(j)
15    continue
C
      l=1
      lr=n
C
20    continue
      if (l.ge.lr)then
        pull=b(k)
        goto 9999
      endif
      ax=b(k)
      jnc=l
      j=lr
C
30    continue
      if(jnc.gt.j)then
        if(j.lt.k)l=jnc
        if(k.lt.jnc)lr=j
        goto 20
      endif
C
40    continue
      if (b(jnc).ge.ax)then
50      continue
        if (b(j).le.ax)then
60        continue
          if(jnc.gt.j)goto 30
          buffer=b(jnc)
          b(jnc)=b(j)
          b(j)=buffer
          jnc=jnc+1
          j=j-1
          goto 30
        endif
        j=j-1
        goto 50
      endif
      jnc=jnc+1
      goto 40
C
 9999 CONTINUE
      return
      end
      SUBROUTINE PWLRAN(N,ALPHA,BETA,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FOR THE POWER LAW FAILURTE TIMES.
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 POWER LAW 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--EXP
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--98.6
C     ORIGINAL VERSION--JUNE      1998.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)THEN
        WRITE(ICOUT, 5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
    5 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ',
     1'PWLRAN 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     POWER LAW RANDOM NUMBERS
C
      C2=(1.0/BETA)
      X(1)=((-1.0/ALPHA)*LOG(X(1)))**C2
      IF(N.EQ.1)GOTO9999
C
      DO200I=2,N
        C3=X(I-1)
        C4=(-1.0/ALPHA)*LOG(X(I))
        X(I)=(C3**BETA + C4)**C2
  200 CONTINUE
C
 9999 CONTINUE
      RETURN
      END
      REAL FUNCTION PYTHAG(A,B)
C***BEGIN PROLOGUE  PYTHAG
C***REFER TO  EISDOC
C
C     Finds sqrt(A**2+B**2) without overflow or destructive underflow
C***ROUTINES CALLED  (NONE)
C***END PROLOGUE  PYTHAG
      REAL A,B
C
      REAL P,Q,R,S,T
C***FIRST EXECUTABLE STATEMENT  PYTHAG
      P = AMAX1(ABS(A),ABS(B))
      Q = AMIN1(ABS(A),ABS(B))
      IF (Q .EQ. 0.0E0) GO TO 20
   10 CONTINUE
         R = (Q/P)**2
         T = 4.0E0 + R
         IF (T .EQ. 4.0E0) GO TO 20
         S = R/T
         P = P + 2.0E0*P*S
         Q = Q*S
      GO TO 10
   20 PYTHAG = P
      RETURN
      END
      function Qn(x,n,y,work,work2,
     &            left,right,weight,q,p,iwork)
C
cc#####################################################################
cc######################  file Qn.for :  ##############################
cc#####################################################################
cc
cc   This file contains a Fortran function for a new robust estimator
cc   of scale denoted as Qn, proposed in Rousseeuw and Croux (1993).
cc   The estimator has a high breakdown point and a smooth and bounded
cc   influence function. The algorithm given here is very fast (running
cc   in 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 Sn, described in the same
cc   paper, is attached above. 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       Qn = dn * 2.2219 * {|x_i-x_j|; i<j}_(k)
cc
cc   Parameters of the function Qn :
cc       x  : real array containing the observations
cc       n  : number of observations (n >=2)
cc
cc   The function Qn uses the procedures:
cc      whimed(a,iw,n): finds the weighted high median of an array
cc                      a of length n, using the array iw (also of
cc                      length n) with positive integer weights.
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
      dimension x(*)
      dimension y(*),work(*),work2(*)
      integer left(*),right(*),weight(*),Q(*),P(*),iwork(*)
ccccc dimension y(500),work(500)
ccccc integer left(500),right(500),weight(500),Q(500),P(500)
      integer h,k,knew,jhelp,nL,nR,sumQ,sumP
      logical found
      h=n/2+1
      k=h*(h-1)/2
      call sort(x,n,y)
      do 20 i=1,n
          left(i)=n-i+2
          right(i)=n
20    continue 
      jhelp=n*(n+1)/2
      knew=k+jhelp
      nL=jhelp
      nR=n*n
      found=.false.
200   continue
      if ( (nR-nL.gt.n).and.(.not.found) ) then
          j=1
          do 30 i=2,n
          if (left(i).le.right(i)) then
              weight(j)=right(i)-left(i)+1
              jhelp=left(i)+weight(j)/2
              work(j)=y(i)-y(n+1-jhelp)
              j=j+1
          endif
30        continue
          trial=whimed(work,weight,j-1,work2,iwork)
          j=0
          do 40 i=n,1,-1
45            continue
              if ((j.lt.n).and.((y(i)-y(n-j)).lt.trial)) then
                  j=j+1
                  goto 45
              endif
              P(i)=j
40        continue
          j=n+1
          do 50 i=1,n
55            continue
              if ((y(i)-y(n-j+2)).gt.trial) then
                  j=j-1
                  goto 55
              endif
              Q(i)=j
50        continue
          sumP=0
          sumQ=0
          do 60 i=1,n
              sumP=sumP+P(i)
              sumQ=sumQ+Q(i)-1
60        continue
          if (knew.le.sumP) then
              do 70 i=1,n
                  right(i)=P(i)
70            continue
              nR=sumP
          else
              if (knew.gt.sumQ) then
                  do 80 i=1,n
                      left(i)=Q(i)
80                continue
                  nL=sumQ
              else
                  Qn=trial
                  found=.true.
              endif
          endif
      goto 200
      endif
      if (.not.found) then
          j=1
          do 90 i=2,n
          if (left(i).le.right(i)) then
              do 100 jj=left(i),right(i)
                  work(j)=y(i)-y(n-jj+1)
                  j=j+1
100           continue
          endif
90        continue
          Qn=pull(work,j-1,knew-nL,work2)
      endif
      if (n.le.9) then
          if (n.eq.2) dn=0.399
          if (n.eq.3) dn=0.994
          if (n.eq.4) dn=0.512
          if (n.eq.5) dn=0.844
          if (n.eq.6) dn=0.611
          if (n.eq.7) dn=0.857
          if (n.eq.8) dn=0.669
          if (n.eq.9) dn=0.872
      else
          if (mod(n,2).eq.1) dn=n/(n+1.4)
          if (mod(n,2).eq.0) dn=n/(n+3.8)
      endif
      Qn=dn*2.2219*Qn
      return
      end
      SUBROUTINE QAGI(F,BOUND,INF,EPSABS,EPSREL,RESULT,ABSERR,NEVAL,
     1   IER,LIMIT,LENW,LAST,IWORK,WORK)
C
C   ADDED TO DATAPLOT 12/2003.  THIS ROUTINE ADDED FOR INTERNAL
C   DATAPLOT USAGE.
C
C***BEGIN PROLOGUE  QAGI
C***DATE WRITTEN   800101   (YYMMDD)
C***REVISION DATE  830518   (YYMMDD)
C***CATEGORY NO.  H2A3A1,H2A4A1
C***KEYWORDS  AUTOMATIC INTEGRATOR,EXTRAPOLATION,GENERAL-PURPOSE,
C             GLOBALLY ADAPTIVE,INFINITE INTERVALS,TRANSFORMATION
C***AUTHOR  PIESSENS, ROBERT, APPLIED MATH. AND PROGR. DIV. -
C             K. U. LEUVEN
C           DE DONCKER, ELISE, APPLIED MATH. AND PROGR. DIV. -
C             K. U. LEUVEN
C***PURPOSE  The routine calculates an approximation result to a given
C            INTEGRAL   I = Integral of F over (BOUND,+INFINITY)
C                    OR I = Integral of F over (-INFINITY,BOUND)
C                    OR I = Integral of F over (-INFINITY,+INFINITY)
C            Hopefully satisfying following claim for accuracy
C            ABS(I-RESULT).LE.MAX(EPSABS,EPSREL*ABS(I)).
C***DESCRIPTION
C
C     From the book "Numerical Methods and Software"
C          by  D. Kahaner, C. Moler, S. Nash
C               Prentice Hall 1988
C
C        Integration over infinite intervals
C        Standard fortran subroutine
C
C        PARAMETERS
C         ON ENTRY
C            F      - Real
C                     Function subprogram defining the integrand
C                     function F(X). The actual name for F needs to be
C                     declared E X T E R N A L in the driver program.
C
C            BOUND  - Real
C                     Finite bound of integration range
C                     (has no meaning if interval is doubly-infinite)
C
C            INF    - Integer
C                     indicating the kind of integration range involved
C                     INF = 1 corresponds to  (BOUND,+INFINITY),
C                     INF = -1            to  (-INFINITY,BOUND),
C                     INF = 2             to (-INFINITY,+INFINITY).
C
C            EPSABS - Real
C                     Absolute accuracy requested
C            EPSREL - Real
C                     Relative accuracy requested
C                     If  EPSABS.LE.0
C                     and EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28),
C                     the routine will end with IER = 6.
C
C
C         ON RETURN
C            RESULT - Real
C                     Approximation to the integral
C
C            ABSERR - Real
C                     Estimate of the modulus of the absolute error,
C                     which should equal or exceed ABS(I-RESULT)
C
C            NEVAL  - Integer
C                     Number of integrand evaluations
C
C            IER    - Integer
C                     IER = 0 normal and reliable termination of the
C                             routine. It is assumed that the requested
C                             accuracy has been achieved.
C                   - IER.GT.0 abnormal termination of the routine. The
C                             estimates for result and error are less
C                             reliable. It is assumed that the requested
C                             accuracy has not been achieved.
C            ERROR MESSAGES
C                     IER = 1 Maximum number of subdivisions allowed
C                             has been achieved. One can allow more
C                             subdivisions by increasing the value of
C                             LIMIT (and taking the according dimension
C                             adjustments into account). However, if
C                             this yields no improvement it is advised
C                             to analyze the integrand in order to
C                             determine the integration difficulties. If
C                             the position of a local difficulty can be
C                             determined (e.g. SINGULARITY,
C                             DISCONTINUITY within the interval) one
C                             will probably gain from splitting up the
C                             interval at this point and calling the
C                             integrator on the subranges. If possible,
C                             an appropriate special-purpose integrator
C                             should be used, which is designed for
C                             handling the type of difficulty involved.
C                         = 2 The occurrence of roundoff error is
C                             detected, which prevents the requested
C                             tolerance from being achieved.
C                             The error may be under-estimated.
C                         = 3 Extremely bad integrand behaviour occurs
C                             at some points of the integration
C                             interval.
C                         = 4 The algorithm does not converge.
C                             Roundoff error is detected in the
C                             extrapolation table.
C                             It is assumed that the requested tolerance
C                             cannot be achieved, and that the returned
C                             RESULT is the best which can be obtained.
C                         = 5 The integral is probably divergent, or
C                             slowly convergent. It must be noted that
C                             divergence can occur with any other value
C                             of IER.
C                         = 6 The input is invalid, because
C                             (EPSABS.LE.0 and
C                              EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28))
C                              or LIMIT.LT.1 or LENIW.LT.LIMIT*4.
C                             RESULT, ABSERR, NEVAL, LAST are set to
C                             zero. Exept when LIMIT or LENIW is
C                             invalid, IWORK(1), WORK(LIMIT*2+1) and
C                             WORK(LIMIT*3+1) are set to ZERO, WORK(1)
C                             is set to A and WORK(LIMIT+1) to B.
C
C         DIMENSIONING PARAMETERS
C            LIMIT - Integer
C                    Dimensioning parameter for IWORK
C                    LIMIT determines the maximum number of subintervals
C                    in the partition of the given integration interval
C                    (A,B), LIMIT.GE.1. In many cases LIMIT = 100 is ok.
C                    If LIMIT.LT.1, the routine will end with IER = 6.
C
C            LENW  - Integer
C                    Dimensioning parameter for WORK
C                    LENW must be at least LIMIT*4.
C                    If LENW.LT.LIMIT*4, the routine will end
C                    with IER = 6. 
C
C            LAST  - Integer
C                    On return, LAST equals the number of subintervals
C                    produced in the subdivision process, which
C                    determines the number of significant elements
C                    actually in the WORK ARRAYS.
C
C         WORK ARRAYS
C            IWORK - Integer
C                    Vector of dimension at least LIMIT, the first
C                    K elements of which contain pointers
C                    to the error estimates over the subintervals,
C                    such that WORK(LIMIT*3+IWORK(1)),... ,
C                    WORK(LIMIT*3+IWORK(K)) form a decreasing
C                    sequence, with K = LAST if LAST.LE.(LIMIT/2+2), and
C                    K = LIMIT+1-LAST otherwise
C
C            WORK  - Real
C                    Vector of dimension at least LENW
C                    on return
C                    WORK(1), ..., WORK(LAST) contain the left
C                     end points of the subintervals in the
C                     partition of (A,B),
C                    WORK(LIMIT+1), ..., WORK(LIMIT+LAST) Contain
C                     the right end points,
C                    WORK(LIMIT*2+1), ...,WORK(LIMIT*2+LAST) contain the
C                     integral approximations over the subintervals,
C                    WORK(LIMIT*3+1), ..., WORK(LIMIT*3)
C                     contain the error estimates.
C***REFERENCES  (NONE)
C***ROUTINES CALLED  QAGIE,XERROR
C***END PROLOGUE  QAGI
C
      REAL ABSERR,BOUND,EPSABS,EPSREL,F,RESULT,WORK
      INTEGER IER,INF,IWORK,LAST,LENW,LIMIT,LVL,L1,L2,L3,NEVAL
C
      DIMENSION IWORK(LIMIT),WORK(LENW)
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
      EXTERNAL F
C
C         CHECK VALIDITY OF LIMIT AND LENW.
C
C***FIRST EXECUTABLE STATEMENT  QAGI
      IER = 6
      NEVAL = 0
      LAST = 0
      RESULT = 0.0E+00
      ABSERR = 0.0E+00
      IF(LIMIT.LT.1.OR.LENW.LT.LIMIT*4) GO TO 10
C
C         PREPARE CALL FOR QAGIE.
C
      L1 = LIMIT+1
      L2 = LIMIT+L1
      L3 = LIMIT+L2
C
      CALL QAGIE(F,BOUND,INF,EPSABS,EPSREL,LIMIT,RESULT,ABSERR,
     1  NEVAL,IER,WORK(1),WORK(L1),WORK(L2),WORK(L3),IWORK,LAST)
C
C         CALL ERROR HANDLER IF NECESSARY.
C
      LVL = 0
10    IF(IER.EQ.6) LVL = 1
      IF(IER.NE.0) THEN
CCCCC   CALL XERROR( 'ABNORMAL RETURN FROM  QAGI',
CCCCC1  26,IER,LVL)
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,901)
  901   FORMAT('***** ERROR--ABNORMAL RETURN FROM QAGI INTEGRATION ',
     1         'ROUTINE.')
        CALL DPWRST('XXX','BUG ')
      ENDIF
      RETURN
      END
      SUBROUTINE QAGIE(F,BOUND,INF,EPSABS,EPSREL,LIMIT,RESULT,ABSERR,
     1   NEVAL,IER,ALIST,BLIST,RLIST,ELIST,IORD,LAST)
C   PART OF QAGI CODE.
C***BEGIN PROLOGUE  QAGIE
C     THIS PROLOGUE HAS BEEN REMOVED FOR REASONS OF SPACE
C     FOR A COMPLETE COPY OF THIS ROUTINE CONTACT THE AUTHORS
C     From the book "Numerical Methods and Software"
C          by  D. Kahaner, C. Moler, S. Nash
C               Prentice Hall 1988
C***END PROLOGUE  QAGIE
C
      REAL ABSEPS,ABSERR,ALIST,AREA,AREA1,AREA12,AREA2,A1,
     1  A2,BLIST,BOUN,BOUND,B1,B2,CORREC,DEFABS,DEFAB1,DEFAB2,
     2  DRES,ELIST,EPMACH,EPSABS,EPSREL,ERLARG,ERLAST,ERRBND,
     3  ERRMAX,ERROR1,ERROR2,ERRO12,ERRSUM,ERTEST,F,RESABS,
     4  RESEPS,RESULT,RLIST,RLIST2,R1MACH,SMALL,UFLOW
      INTEGER ID,IER,IERR,IERRO,INF,IORD,IROFF1,IROFF2,IROFF3,JUPBND,K,
     1  KSGN,KTMIN,LAST,LIMEXP,LIMIT,MAXERR,NEVAL,NRMAX
      LOGICAL EXTRAP,LERR,NEWFLG,NOEXT
C
      PARAMETER (LIMEXP = 50)
C
C           LIMEXP IS THE SIZE OF THE EPSILON TABLE THAT CAN BE
C           GENERATED IN EA
C
      DIMENSION ALIST(LIMIT),BLIST(LIMIT),ELIST(LIMIT),IORD(LIMIT),
     1  RLIST(LIMIT),RLIST2(LIMEXP+7)
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
      EXTERNAL F
C
C***FIRST EXECUTABLE STATEMENT  QAGIE
       EPMACH = R1MACH(4)
C
C           TEST ON VALIDITY OF PARAMETERS
C           -----------------------------
C
      IER = 0
      NEVAL = 0
      LAST = 0
      RESULT = 0.0E+00
      ABSERR = 0.0E+00
      ALIST(1) = 0.0E+00
      BLIST(1) = 0.1E+01
      RLIST(1) = 0.0E+00
      ELIST(1) = 0.0E+00
      IORD(1) = 0
      NEWFLG = .TRUE.
      IF(EPSABS.LE.0.0E+00.AND.EPSREL.LT.AMAX1(0.5E+02*EPMACH,0.5E-14))
     1  IER = 6
      IF(IER.EQ.6) GO TO 999
C
C
C           FIRST APPROXIMATION TO THE INTEGRAL
C           -----------------------------------
C
C           DETERMINE THE INTERVAL TO BE MAPPED ONTO (0,1).
C           IF INF = 2 THE INTEGRAL IS COMPUTED AS I = I1+I2, WHERE
C           I1 = INTEGRAL OF F OVER (-INFINITY,0),
C           I2 = INTEGRAL OF F OVER (0,+INFINITY).
C
      BOUN = BOUND
      IF(INF.EQ.2) BOUN = 0.0E+00
      CALL QK15I(F,BOUN,INF,0.0E+00,0.1E+01,RESULT,ABSERR,
     1  DEFABS,RESABS)
C
C           TEST ON ACCURACY
C
      LAST = 1
      RLIST(1) = RESULT
      ELIST(1) = ABSERR
      IORD(1) = 1
      DRES = ABS(RESULT)
      ERRBND = AMAX1(EPSABS,EPSREL*DRES)
      IF(ABSERR.LE.1.0E+02*EPMACH*DEFABS.AND.ABSERR.GT.
     1  ERRBND) IER = 2
      IF(LIMIT.EQ.1) IER = 1
      IF(IER.NE.0.OR.(ABSERR.LE.ERRBND.AND.ABSERR.NE.RESABS).OR.
     1  ABSERR.EQ.0.0E+00) GO TO 130
C
C           INITIALIZATION
C           --------------
C
      UFLOW = R1MACH(1) * 0.2E+01
      LERR = .FALSE.
      CALL EA(NEWFLG,RESULT,LIMEXP,RESEPS,ABSEPS,RLIST2,IERR)
      ERRMAX = ABSERR
      MAXERR = 1
      AREA = RESULT
      ERRSUM = ABSERR
      NRMAX = 1
      KTMIN = 0
      EXTRAP = .FALSE.
      NOEXT = .FALSE.
      IERRO = 0
      IROFF1 = 0
      IROFF2 = 0
      IROFF3 = 0
      KSGN = -1
      IF(DRES.GE.(0.1E+01-0.5E+02*EPMACH)*DEFABS) KSGN = 1
C
C           MAIN DO-LOOP
C           ------------
C
      DO 90 LAST = 2,LIMIT
C
C           BISECT THE SUBINTERVAL WITH NRMAX-TH LARGEST
C           ERROR ESTIMATE.
C
        A1 = ALIST(MAXERR)
        B1 = 0.5E+00*(ALIST(MAXERR)+BLIST(MAXERR))
        A2 = B1
        B2 = BLIST(MAXERR)
        ERLAST = ERRMAX
        CALL QK15I(F,BOUN,INF,A1,B1,AREA1,ERROR1,RESABS,DEFAB1)
        CALL QK15I(F,BOUN,INF,A2,B2,AREA2,ERROR2,RESABS,DEFAB2)
C
C           IMPROVE PREVIOUS APPROXIMATIONS TO INTEGRAL
C           AND ERROR AND TEST FOR ACCURACY.
C
        AREA12 = AREA1+AREA2
        ERRO12 = ERROR1+ERROR2
        ERRSUM = ERRSUM+ERRO12-ERRMAX
        AREA = AREA+AREA12-RLIST(MAXERR)
        IF(DEFAB1.EQ.ERROR1.OR.DEFAB2.EQ.ERROR2)GO TO 15
        IF(ABS(RLIST(MAXERR)-AREA12).GT.0.1E-04*ABS(AREA12)
     1  .OR.ERRO12.LT.0.99E+00*ERRMAX) GO TO 10
        IF(EXTRAP) IROFF2 = IROFF2+1
        IF(.NOT.EXTRAP) IROFF1 = IROFF1+1
   10   IF(LAST.GT.10.AND.ERRO12.GT.ERRMAX) IROFF3 = IROFF3+1
   15   RLIST(MAXERR) = AREA1
        RLIST(LAST) = AREA2
        ERRBND = AMAX1(EPSABS,EPSREL*ABS(AREA))
C
C           TEST FOR ROUNDOFF ERROR AND EVENTUALLY
C           SET ERROR FLAG.
C
        IF(IROFF1+IROFF2.GE.10.OR.IROFF3.GE.20) IER = 2
        IF(IROFF2.GE.5) IERRO = 3
C
C           SET ERROR FLAG IN THE CASE THAT THE NUMBER OF
C           SUBINTERVALS EQUALS LIMIT.
C
        IF(LAST.EQ.LIMIT) IER = 1
C
C           SET ERROR FLAG IN THE CASE OF BAD INTEGRAND BEHAVIOUR
C           AT SOME POINTS OF THE INTEGRATION RANGE.
C
        IF(AMAX1(ABS(A1),ABS(B2)).LE.(0.1E+01+0.1E+03*EPMACH)*
     1  (ABS(A2)+0.1E+04*UFLOW)) IER = 4
C
C           APPEND THE NEWLY-CREATED INTERVALS TO THE LIST.
C
        IF(ERROR2.GT.ERROR1) GO TO 20
        ALIST(LAST) = A2
        BLIST(MAXERR) = B1
        BLIST(LAST) = B2
        ELIST(MAXERR) = ERROR1
        ELIST(LAST) = ERROR2
        GO TO 30
   20   ALIST(MAXERR) = A2
        ALIST(LAST) = A1
        BLIST(LAST) = B1
        RLIST(MAXERR) = AREA2
        RLIST(LAST) = AREA1
        ELIST(MAXERR) = ERROR2
        ELIST(LAST) = ERROR1
C
C           CALL SUBROUTINE QPSRT TO MAINTAIN THE DESCENDING ORDERING
C           IN THE LIST OF ERROR ESTIMATES AND SELECT THE
C           SUBINTERVAL WITH NRMAX-TH LARGEST ERROR ESTIMATE (TO BE
C           BISECTED NEXT).
C
   30   CALL QPSRT(LIMIT,LAST,MAXERR,ERRMAX,ELIST,IORD,NRMAX)
        IF(ERRSUM.LE.ERRBND) GO TO 115
        IF(IER.NE.0) GO TO 100
        IF(LAST.EQ.2) GO TO 80
        IF(NOEXT) GO TO 90
        ERLARG = ERLARG-ERLAST
        IF(ABS(B1-A1).GT.SMALL) ERLARG = ERLARG+ERRO12
        IF(EXTRAP) GO TO 40
C
C           TEST WHETHER THE INTERVAL TO BE BISECTED NEXT IS THE
C           SMALLEST INTERVAL.
C
        IF(ABS(BLIST(MAXERR)-ALIST(MAXERR)).GT.SMALL) GO TO 90
        EXTRAP = .TRUE.
        NRMAX = 2
   40   IF(IERRO.EQ.3.OR.ERLARG.LE.ERTEST) GO TO 60
C
C           THE SMALLEST INTERVAL HAS THE LARGEST ERROR.
C           BEFORE BISECTING DECREASE THE SUM OF THE ERRORS
C           OVER THE LARGER INTERVALS (ERLARG) AND PERFORM
C           EXTRAPOLATION.
C
        ID = NRMAX
        JUPBND = LAST
        IF(LAST.GT.(2+LIMIT/2)) JUPBND = LIMIT+3-LAST
        DO 50 K = ID,JUPBND
          MAXERR = IORD(NRMAX)
          ERRMAX = ELIST(MAXERR)
          IF(ABS(BLIST(MAXERR)-ALIST(MAXERR)).GT.SMALL) GO TO 90
          NRMAX = NRMAX+1
   50   CONTINUE
C
C           PERFORM EXTRAPOLATION.
C
   60   CALL EA(NEWFLG,AREA,LIMEXP,RESEPS,ABSEPS,RLIST2,IERR)
        KTMIN = KTMIN+1
        IF((KTMIN.GT.5).AND.(ABSERR.LT.0.1E-02*ERRSUM).AND.(LERR))
     1     IER = 5
        IF((ABSEPS.GE.ABSERR).AND.(LERR)) GO TO 70
        KTMIN = 0
        ABSERR = ABSEPS
        LERR = .TRUE.
        RESULT = RESEPS
        CORREC = ERLARG
        ERTEST = AMAX1(EPSABS,EPSREL*ABS(RESEPS))
        IF((ABSERR.LE.ERTEST).AND.(LERR)) GO TO 100
C
C            PREPARE BISECTION OF THE SMALLEST INTERVAL.
C
   70   IF(RLIST2(LIMEXP+3).EQ.1) NOEXT = .TRUE.
        IF(IER.EQ.5) GO TO 100
        MAXERR = IORD(1)
        ERRMAX = ELIST(MAXERR)
        NRMAX = 1
        EXTRAP = .FALSE.
        SMALL = SMALL*0.5E+00
        ERLARG = ERRSUM
        GO TO 90
   80   SMALL = 0.375E+00
        ERLARG = ERRSUM
        ERTEST = ERRBND
        CALL EA(NEWFLG,AREA,LIMEXP,RESEPS,ABSEPS,RLIST2,IERR)
   90 CONTINUE
C
C           SET FINAL RESULT AND ERROR ESTIMATE.
C           ------------------------------------
C
  100 IF(.NOT.LERR) GO TO 115
      IF((IER+IERRO).EQ.0) GO TO 110
      IF(IERRO.EQ.3) ABSERR = ABSERR+CORREC
      IF(IER.EQ.0) IER = 3
      IF(RESULT.NE.0.0E+00.AND.AREA.NE.0.0E+00)GO TO 105
      IF(ABSERR.GT.ERRSUM)GO TO 115
      IF(AREA.EQ.0.0E+00) GO TO 130
      GO TO 110
  105 IF(ABSERR/ABS(RESULT).GT.ERRSUM/ABS(AREA))GO TO 115
C
C           TEST ON DIVERGENCE
C
  110 IF(KSGN.EQ.(-1).AND.AMAX1(ABS(RESULT),ABS(AREA)).LE.
     1 DEFABS*0.1E-01) GO TO 130
      IF(0.1E-01.GT.(RESULT/AREA).OR.(RESULT/AREA).GT.0.1E+03.
     1OR.ERRSUM.GT.ABS(AREA)) IER = 6
      GO TO 130
C
C           COMPUTE GLOBAL INTEGRAL SUM.
C
  115 RESULT = 0.0E+00
      DO 120 K = 1,LAST
        RESULT = RESULT+RLIST(K)
  120 CONTINUE
      ABSERR = ERRSUM
  130 NEVAL = 30*LAST-15
      IF(INF.EQ.2) NEVAL = 2*NEVAL
      IF(IER.GT.2) IER=IER-1
  999 RETURN
      END
      SUBROUTINE QK15I(F,BOUN,INF,A,B,RESULT,ABSERR,RESABS,RESASC)
C   PART OF QAGI CODE.
C***BEGIN PROLOGUE  QK15I
C     THIS PROLOGUE HAS BEEN REMOVED FOR REASONS OF SPACE
C     FOR A COMPLETE COPY OF THIS ROUTINE CONTACT THE AUTHORS
C     From the book "Numerical Methods and Software"
C          by  D. Kahaner, C. Moler, S. Nash
C               Prentice Hall 1988
C***END PROLOGUE  QK15I
C
      REAL A,ABSC,ABSC1,ABSC2,ABSERR,B,BOUN,CENTR,
     1  DINF,R1MACH,EPMACH,F,FC,FSUM,FVAL1,FVAL2,FV1,
     2  FV2,HLGTH,RESABS,RESASC,RESG,RESK,RESKH,RESULT,TABSC1,TABSC2,
     3  UFLOW,WG,WGK,XGK
      INTEGER INF,J,MIN0
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
      EXTERNAL F
C
      DIMENSION FV1(7),FV2(7),XGK(8),WGK(8),WG(8)
C
C
      DATA XGK(1),XGK(2),XGK(3),XGK(4),XGK(5),XGK(6),XGK(7),
     1  XGK(8)/
     2     0.9914553711208126E+00,     0.9491079123427585E+00,
     3     0.8648644233597691E+00,     0.7415311855993944E+00,
     4     0.5860872354676911E+00,     0.4058451513773972E+00,
     5     0.2077849550078985E+00,     0.0000000000000000E+00/
C
      DATA WGK(1),WGK(2),WGK(3),WGK(4),WGK(5),WGK(6),WGK(7),
     1  WGK(8)/
     2     0.2293532201052922E-01,     0.6309209262997855E-01,
     3     0.1047900103222502E+00,     0.1406532597155259E+00,
     4     0.1690047266392679E+00,     0.1903505780647854E+00,
     5     0.2044329400752989E+00,     0.2094821410847278E+00/
C
      DATA WG(1),WG(2),WG(3),WG(4),WG(5),WG(6),WG(7),WG(8)/
     1     0.0000000000000000E+00,     0.1294849661688697E+00,
     2     0.0000000000000000E+00,     0.2797053914892767E+00,
     3     0.0000000000000000E+00,     0.3818300505051189E+00,
     4     0.0000000000000000E+00,     0.4179591836734694E+00/
C
C
C***FIRST EXECUTABLE STATEMENT  QK15I
      EPMACH = R1MACH(4)
      UFLOW = R1MACH(1)
      DINF = MIN0(1,INF)
C
      CENTR = 0.5E+00*(A+B)
      HLGTH = 0.5E+00*(B-A)
      TABSC1 = BOUN+DINF*(0.1E+01-CENTR)/CENTR
      FVAL1 = F(TABSC1)
      IF(INF.EQ.2) FVAL1 = FVAL1+F(-TABSC1)
      FC = (FVAL1/CENTR)/CENTR
C
C           COMPUTE THE 15-POINT KRONROD APPROXIMATION TO
C           THE INTEGRAL, AND ESTIMATE THE ERROR.
C
      RESG = WG(8)*FC
      RESK = WGK(8)*FC
      RESABS = ABS(RESK)
      DO 10 J=1,7
        ABSC = HLGTH*XGK(J)
        ABSC1 = CENTR-ABSC
        ABSC2 = CENTR+ABSC
        TABSC1 = BOUN+DINF*(0.1E+01-ABSC1)/ABSC1
        TABSC2 = BOUN+DINF*(0.1E+01-ABSC2)/ABSC2
        FVAL1 = F(TABSC1)
        FVAL2 = F(TABSC2)
        IF(INF.EQ.2) FVAL1 = FVAL1+F(-TABSC1)
        IF(INF.EQ.2) FVAL2 = FVAL2+F(-TABSC2)
        FVAL1 = (FVAL1/ABSC1)/ABSC1
        FVAL2 = (FVAL2/ABSC2)/ABSC2
        FV1(J) = FVAL1
        FV2(J) = FVAL2
        FSUM = FVAL1+FVAL2
        RESG = RESG+WG(J)*FSUM
        RESK = RESK+WGK(J)*FSUM
        RESABS = RESABS+WGK(J)*(ABS(FVAL1)+ABS(FVAL2))
   10 CONTINUE
      RESKH = RESK*0.5E+00
      RESASC = WGK(8)*ABS(FC-RESKH)
      DO 20 J=1,7
        RESASC = RESASC+WGK(J)*(ABS(FV1(J)-RESKH)+ABS(FV2(J)-RESKH))
   20 CONTINUE
      RESULT = RESK*HLGTH
      RESASC = RESASC*HLGTH
      RESABS = RESABS*HLGTH
      ABSERR = ABS((RESK-RESG)*HLGTH)
      IF(RESASC.NE.0.0E+00.AND.ABSERR.NE.0.E0) ABSERR = RESASC*
     1 AMIN1(0.1E+01,(0.2E+03*ABSERR/RESASC)**1.5E+00)
      IF(RESABS.GT.UFLOW/(0.5E+02*EPMACH)) ABSERR = AMAX1
     1 ((EPMACH*0.5E+02)*RESABS,ABSERR)
      RETURN
      END
      SUBROUTINE QPSRT(LIMIT,LAST,MAXERR,ERMAX,ELIST,IORD,NRMAX)
C***BEGIN PROLOGUE  QPSRT
C   PART OF QAGI CODE.
C     THIS PROLOGUE HAS BEEN REMOVED FOR REASONS OF SPACE
C     FOR A COMPLETE COPY OF THIS ROUTINE CONTACT THE AUTHORS
C     From the book "Numerical Methods and Software"
C          by  D. Kahaner, C. Moler, S. Nash
C               Prentice Hall 1988
C***END PROLOGUE  QPSRT
C
      REAL ELIST,ERMAX,ERRMAX,ERRMIN
      INTEGER I,IBEG,IDO,IORD,ISUCC,J,JBND,JUPBN,K,LAST,LIMIT,MAXERR,
     1  NRMAX
      DIMENSION ELIST(LAST),IORD(LAST)
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C           CHECK WHETHER THE LIST CONTAINS MORE THAN
C           TWO ERROR ESTIMATES.
C
C***FIRST EXECUTABLE STATEMENT  QPSRT
      IF(LAST.GT.2) GO TO 10
      IORD(1) = 1
      IORD(2) = 2
      GO TO 90
C
C           THIS PART OF THE ROUTINE IS ONLY EXECUTED
C           IF, DUE TO A DIFFICULT INTEGRAND, SUBDIVISION
C           INCREASED THE ERROR ESTIMATE. IN THE NORMAL CASE
C           THE INSERT PROCEDURE SHOULD START AFTER THE
C           NRMAX-TH LARGEST ERROR ESTIMATE.
C
   10 ERRMAX = ELIST(MAXERR)
      IF(NRMAX.EQ.1) GO TO 30
      IDO = NRMAX-1
      DO 20 I = 1,IDO
        ISUCC = IORD(NRMAX-1)
C ***JUMP OUT OF DO-LOOP
        IF(ERRMAX.LE.ELIST(ISUCC)) GO TO 30
        IORD(NRMAX) = ISUCC
        NRMAX = NRMAX-1
   20    CONTINUE
C
C           COMPUTE THE NUMBER OF ELEMENTS IN THE LIST TO
C           BE MAINTAINED IN DESCENDING ORDER. THIS NUMBER
C           DEPENDS ON THE NUMBER OF SUBDIVISIONS STILL
C           ALLOWED.
C
   30 JUPBN = LAST
      IF(LAST.GT.(LIMIT/2+2)) JUPBN = LIMIT+3-LAST
      ERRMIN = ELIST(LAST)
C
C           INSERT ERRMAX BY TRAVERSING THE LIST TOP-DOWN,
C           STARTING COMPARISON FROM THE ELEMENT ELIST(IORD(NRMAX+1)).
C
      JBND = JUPBN-1
      IBEG = NRMAX+1
      IF(IBEG.GT.JBND) GO TO 50
      DO 40 I=IBEG,JBND
        ISUCC = IORD(I)
C ***JUMP OUT OF DO-LOOP
        IF(ERRMAX.GE.ELIST(ISUCC)) GO TO 60
        IORD(I-1) = ISUCC
   40 CONTINUE
   50 IORD(JBND) = MAXERR
      IORD(JUPBN) = LAST
      GO TO 90
C
C           INSERT ERRMIN BY TRAVERSING THE LIST BOTTOM-UP.
C
   60 IORD(I-1) = MAXERR
      K = JBND
      DO 70 J=I,JBND
        ISUCC = IORD(K)
C ***JUMP OUT OF DO-LOOP
        IF(ERRMIN.LT.ELIST(ISUCC)) GO TO 80
        IORD(K+1) = ISUCC
        K = K-1
   70 CONTINUE
      IORD(I) = LAST
      GO TO 90
   80 IORD(K+1) = LAST
C
C           SET MAXERR AND ERMAX.
C
   90 MAXERR = IORD(NRMAX)
      ERMAX = ELIST(MAXERR)
      RETURN
      END
      SUBROUTINE QRAUX1(NR,N,R,I)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C PURPOSE
C -------
C INTERCHANGE ROWS I,I+1 OF THE UPPER HESSENBERG MATRIX R,
C COLUMNS I TO N
C
C PARAMETERS
C ----------
C NR           --> ROW DIMENSION OF MATRIX
C N            --> DIMENSION OF MATRIX
C R(N,N)      <--> UPPER HESSENBERG MATRIX
C I            --> INDEX OF ROW TO INTERCHANGE (I.LT.N)
C
      DIMENSION R(NR,1)
      DO 10 J=I,N
        TMP=R(I,J)
        R(I,J)=R(I+1,J)
        R(I+1,J)=TMP
   10 CONTINUE
      RETURN
      END
      SUBROUTINE QRAUX2(NR,N,R,I,A,B)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C PURPOSE
C -------
C PRE-MULTIPLY R BY THE JACOBI ROTATION J(I,I+1,A,B)
C
C PARAMETERS
C ----------
C NR           --> ROW DIMENSION OF MATRIX
C N            --> DIMENSION OF MATRIX
C R(N,N)      <--> UPPER HESSENBERG MATRIX
C I            --> INDEX OF ROW
C A            --> SCALAR
C B            --> SCALAR
C
      DIMENSION R(NR,1)
      DEN=SQRT(A*A + B*B)
      C=A/DEN
      S=B/DEN
      DO 10 J=I,N
        Y=R(I,J)
        Z=R(I+1,J)
        R(I,J)=C*Y - S*Z
        R(I+1,J)=S*Y + C*Z
   10 CONTINUE
      RETURN
      END
      SUBROUTINE QRUPDT(NR,N,A,U,V)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C PURPOSE
C -------
C FIND AN ORTHOGONAL (N*N) MATRIX (Q*) AND AN UPPER TRIANGULAR (N*N)
C MATRIX (R*) SUCH THAT (Q*)(R*)=R+U(V+)
C
C PARAMETERS
C ----------
C NR           --> ROW DIMENSION OF MATRIX
C N            --> DIMENSION OF PROBLEM
C A(N,N)      <--> ON INPUT:  CONTAINS R
C                  ON OUTPUT: CONTAINS (R*)
C U(N)         --> VECTOR
C V(N)         --> VECTOR
C
      DIMENSION A(NR,1)
      DIMENSION U(N),V(N)
C
C DETERMINE LAST NON-ZERO IN U(.)
C
      K=N
   10 IF(U(K).NE.0. .OR. K.EQ.1) GO TO 20
C     IF(U(K).EQ.0. .AND. K.GT.1)
C     THEN
        K=K-1
        GO TO 10
C     ENDIF
C
C (K-1) JACOBI ROTATIONS TRANSFORM
C     R + U(V+) --> (R*) + (U(1)*E1)(V+)
C WHICH IS UPPER HESSENBERG
C
   20 IF(K.LE.1) GO TO 40
        KM1=K-1
        DO 30 II=1,KM1
          I=KM1-II+1
          IF(U(I).NE.0.) GO TO 25
C         IF(U(I).EQ.0.)
C         THEN
            CALL QRAUX1(NR,N,A,I)
            U(I)=U(I+1)
            GO TO 30
C         ELSE
   25       CALL QRAUX2(NR,N,A,I,U(I),-U(I+1))
            U(I)=SQRT(U(I)*U(I) + U(I+1)*U(I+1))
C         ENDIF
   30   CONTINUE
C     ENDIF
C
C R <-- R + (U(1)*E1)(V+)
C
   40 DO 50 J=1,N
        A(1,J)=A(1,J) +U(1)*V(J)
   50 CONTINUE
C
C (K-1) JACOBI ROTATIONS TRANSFORM UPPER HESSENBERG R
C TO UPPER TRIANGULAR (R*)
C
      IF(K.LE.1) GO TO 100
        KM1=K-1
        DO 80 I=1,KM1
          IF(A(I,I).NE.0.) GO TO 70
C         IF(A(I,I).EQ.0.)
C         THEN
            CALL QRAUX1(NR,N,A,I)
            GO TO 80
C         ELSE
   70       T1=A(I,I)
            T2=-A(I+1,I)
            CALL QRAUX2(NR,N,A,I,T1,T2)
C         ENDIF
   80   CONTINUE
C     ENDIF
  100 RETURN
      END
      double precision function qtrng(p, v, r, ifault)
      implicit double precision (a-h, o-z)
c
c        Algorithm AS 190.1  Appl. Statist. (1983) Vol.32, No. 2
c
c        Approximates the quantile p for a studentized range
c        distribution having v degrees of freedom and r samples
c        for probability p, p.ge.0.90 .and. p.le.0.99.
c
c        Uses functions  alnorm, ppnd, prtrng and qtrng0 -
c        Algorithms AS 66, AS 111, AS 190 and AS 190.2
c
      double precision p, v, r, pcut, p75, p80, p90, p99, p995
      double precision p175, one, two, five
      double precision q1, p1, q2, p2, e1, e2
      double precision eps
      data jmax, pcut, p75, p80, p90, p99, p995, p175, one, two, five
     #  /8, 0.001d0, 0.75d0, 0.80d0, 0.90d0, 0.99d0, 0.995d0, 1.75d0,
     #  1.0d0, 2.0d0, 5.0d0/
      data eps/1.0d-4/
c
c        Check input parameters
c
      ifault = 0
      nfault = 0
      if (v .lt. one .or. r.lt. two) ifault = 1
      if (p .lt. p90 .or. p .gt. p99) ifault = 2
      if (ifault .ne. 0) goto 99
c
c        Obtain initial values
c
      q1 = qtrng0(p, v, r, nfault)
      if (nfault .ne. 0) goto 99
      p1 = prtrng(q1, v, r, nfault)
      if (nfault .ne. 0) goto 99
      qtrng = q1
      if (abs(p1-p) .lt. pcut) goto 99
      if (p1 .gt. p) p1 = p175 * p - p75 * p1
      if (p1 .lt. p) p2 = p + (p - p1) * (one - p) / (one - p1) * p75
      if (p2 .lt. p80) p2 = p80
      if (p2 .gt. p995) p2 = p995
      q2 = qtrng0(p2, v, r, nfault)
      if (nfault .ne. 0) goto 99
c
c        Refine approximation
c
      do 14 j = 2, jmax
      p2 = prtrng(q2, v, r, nfault)
      if (nfault .ne. 0) goto 99
      e1 = p1 - p
      e2 = p2 - p
      qtrng = (q1 + q2) / two
      d = e2 - e1
      if (abs(d) .gt. eps) qtrng = (e2 * q1 - e1 * q2) / d
      if(abs(e1) .lt. abs(e2)) goto 12
      q1 = q2
      p1 = p2
   12   if (abs(p1 - p) .lt. pcut * five) goto 99
      q2 = qtrng
   14 continue
c
   99 if (nfault .ne. 0) ifault = 9
      return
      end
      double precision function qtrng0(p, v, r, ifault)
      implicit double precision (a-h, o-z)
c
c        Algorithm AS 190.2  Appl. Statist. (1983) Vol.32, No.2
c
c        Calculates an initial quantile p for a studentized range
c        distribution having v degrees of freedom and r samples
c        for probability p, p.gt.0.80 .and. p.lt.0.995.
c
c        Uses function ppnd - Algorithm AS 111
c
      double precision p, v, r, q, t, vmax, half, one, four, c1, c2, c3
      double precision c4, c5
      real ppnd
      data vmax, half, one, four, c1, c2, c3, c4, c5 / 120.0d0, 0.5d0,
     #  1.0d0, 4.0d0, 0.8843d0, 0.2368d0, 1.214d0, 1.208d0, 1.4142d0/
c
      t=dble(ppnd(real(half + half * p),ifault))
      if (v .lt. vmax) t = t + (t * t* t + t) / v / four
      q = c1 - c2 * t
      if (v .lt. vmax) q = q - c3 / v + c4 * t / v
      qtrng0 = t * (q * log(r - one) + c5)
      return
      end
      SUBROUTINE QUAFIT(IT,I1,I2,XS,YS,WH,WV,N,XMAXHF,I3,I4,
     1ALPHA,BETA1,BETA2,PRED,RES,ISUBRO,IBUGA3,IERROR)
C
C     PURPOSE--CARRY OUT A LEAST SQUARES WEIGHTED QUARADITIC FIT
C              OF THE DATA IN LOCATIONS I1 TO I2
C              OF THE HORIZONTALLY SORTED DATA
C              IN VARIABLES XS(.) AND YS(.).
C              AFTER THE FIT IS DONE, COMPUTE PREDICTED VALUES
C              AND RESIDUALS FOR ELEMENTS I3 TO I4 OF XS(.).
C              THIS ROUTINE IS USED FOR UNIVARIATE LOWESS OF DEGREE 2.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--94/4
C     ORIGINAL VERSION--MARCH      1994
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 ISUBRO
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DSUM2
      DOUBLE PRECISION DSUM3
      DOUBLE PRECISION DSUM4
      DOUBLE PRECISION DSUM5
      DOUBLE PRECISION DSUM6
      DOUBLE PRECISION DSUM7
      DOUBLE PRECISION DSUM8
C
C---------------------------------------------------------------------
C
      DIMENSION XMAT(3,3)
      DIMENSION IPVT(3)
      DIMENSION RHS(3)
      DIMENSION XS(*)
      DIMENSION YS(*)
      DIMENSION WH(*)
      DIMENSION WV(*)
      DIMENSION PRED(*)
      DIMENSION RES(*)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='QUAF'
      ISUBN2='IT  '
C
      IERROR='NO'
C
      IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'AFIT')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF QUAFIT--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)ISUBRO,IBUGA3,IERROR
   52 FORMAT('ISUBRO,IBUGA3,IERROR = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)IT,I1,I2,N,I3,I4
   53 FORMAT('IT,I1,I2,N,I3,I4 = ',6I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,54)XMAXHF
   54 FORMAT('XMAXHF = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      IF(N.LE.0)GOTO63
      DO61I=1,N
      WRITE(ICOUT,62)I,XS(I),YS(I),WH(I),WV(I)
   62 FORMAT('I,XS(I),YS(I),WH(I),WV(I) = ',I8,4E15.7)
      CALL DPWRST('XXX','BUG ')
   61 CONTINUE
   63 CONTINUE
   90 CONTINUE
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      IF(N.GE.1)GOTO119
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,111)
  111 FORMAT('***** ERROR IN QUAFIT--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,112)
  112 FORMAT('      THE INPUT FULL SAMPLE SIZE,')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,113)
  113 FORMAT('      FOR WHICH LOWESS HORIZONTAL WEIGHTS')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,114)
  114 FORMAT('      ARE TO BE COMPUTED, MUST BE 1 OR LARGER.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,115)
  115 FORMAT('      SUCH WAS NOT THE CASE HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,116)N
  116 FORMAT('      THE FULL SAMPLE SIZE N = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
  119 CONTINUE
C
      IF(IT.GE.1)GOTO129
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,121)
  121 FORMAT('***** ERROR IN QUAFIT--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,122)
  122 FORMAT('      THE INPUT TARGET OBSERVATION INDEX')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,123)
  123 FORMAT('      FOR WHICH A LOWESS IS TO BE CARRIED OUT')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,124)N
  124 FORMAT('      MUST BE BETWEEN 1 AND ',I8,' (INCLUSIVE).')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,125)
  125 FORMAT('      SUCH WAS NOT THE CASE HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,126)IT
  126 FORMAT('      THE TARGET OBSERVATION INDEX IT = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
  129 CONTINUE
C
      IF(I1.LE.I2)GOTO139
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,131)
  131 FORMAT('***** ERROR IN QUAFIT--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,132)
  132 FORMAT('      THE  NEIGHBORHOOD LOWER INDEX')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,133)
  133 FORMAT('      FOR WHICH A LOWESS IS TO BE CARRIED OUT')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,134)
  134 FORMAT('      MUST NOT EXCEED THE NEIGHBORHOOD UPPER INDEX.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,135)
  135 FORMAT('      SUCH WAS NOT THE CASE HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,136)IT
  136 FORMAT('      THE NEIGHBORHOOD INDICES I1 AND I2 = ',2I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
  139 CONTINUE
C
      IF(I3.LE.I4)GOTO149
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,141)
  141 FORMAT('***** ERROR IN QUAFIT--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,142)
  142 FORMAT('      THE  DESIRED LOWER INDEX FOR WHICH')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,143)
  143 FORMAT('      LOWESS PREDICTED VALUES ARE TO BE COMPUTED')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,144)
  144 FORMAT('      MUST NOT EXCEED THE DESIRED UPPER INDEX.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,145)
  145 FORMAT('      SUCH WAS NOT THE CASE HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,146)I3,I4
  146 FORMAT('      THE DESIRED INDICES I3 AND I4 = ',2I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
  149 CONTINUE
C
C               ***********************************************
C               **  STEP 11--                                **
C               **  CARRY OUT A LEAST SQUARES WEIGHTED       **
C               **  QUAFIT FIT                               **
C               ***********************************************
C
      IF(XMAXHF.LE.0.0)GOTO1200
      GOTO1300
C
C               ***********************************************
C               **  STEP 12--                                **
C               **  TREAT THE CASE WHEN ALL HORIXONTAL AXIS  **
C               **  VALUES ARE IDENTICAL                     **
C               ***********************************************
C
 1200 CONTINUE
      NN=I2-I1+1
      ANN=NN
C
      SUMY=0.0
      SUMW=0.0
      DO1210I=I1,I2
      W=WH(I)*WV(I)
      SUMY=SUMY+W*YS(I)
      SUMW=SUMW+W
 1210 CONTINUE
      YBAR=SUMY/SUMW
C
      ALPHA=YBAR
      BETA1=0.0
      BETA2=0.0
C
      DO1220I=I3,I4
      PRED(I)=ALPHA
      RES(I)=YS(I)-PRED(I)
 1220 CONTINUE
C
      GOTO9000
C               *********************************************
C               **  STEP 13--                              **
C               **  TREAT THE CASE WHEN AT LEAST 1         **
C               **  HORIZONTAL AXIS VALUE IS DIFFERENT     **
C               *********************************************
C
 1300 CONTINUE
      NN=I2-I1+1
      ANN=NN
C
      SUMW=0.0
      DO1310I=I1,I2
      W=WH(I)*WV(I)
      SUMW=SUMW+W
 1310 CONTINUE
C
      IF(SUMW.GT.0.0)GOTO1319
      WRITE(ICOUT,1311)
 1311 FORMAT('***** ERROR IN QUAFIT--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1312)
 1312 FORMAT('      SUM OF WEIGHTS = 0')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1313)IT,I1,I2,N
 1313 FORMAT('IT,I1,I2,N = ',4I8)
      CALL DPWRST('XXX','BUG ')
      DO1314I=I1,I2
      WPROD=WH(I)*WV(I)
      WRITE(ICOUT,1315)I,WH(I),WV(I),WPROD
 1315 FORMAT('I,WH(I),WV(I),WPROD = ',I8,3E15.7)
      CALL DPWRST('XXX','BUG ')
 1314 CONTINUE
      IERROR='YES'
      GOTO9000
 1319 CONTINUE
C
C  FOR A QUADRATIC, WEIGHTED FIT, THE NORMAL EQUATIONS ARE:
C  [SUM(W)      SUM(W*X)      SUM(W*X**2)]  [ALPHA]   [SUM(W*Y)  ]
C  [SUM(W*X)    SUM(W*X**2)   SUM(W*X**3)]  [BETA1] = [SUM(W*X*Y]
C  [SUM(W*X**2) SUM(W*X**3)   SUM(W*X**4)]  [BETA2]   [SUM(W*X**2*Y]
C
C  FORM THE FOLLOWING SUMS (IN DOUBLE PRECISION):
C  1) W
C  2) W*X
C  3) W*X**2
C  4) W*X**3
C  5) W*X**4
C  6) W*Y
C  7) W*Y*X
C  8) W*Y*X**2
C
      DSUM1=0.0
      DSUM2=0.0
      DSUM3=0.0
      DSUM4=0.0
      DSUM5=0.0
      DSUM6=0.0
      DSUM7=0.0
      DSUM8=0.0
      DO1320I=I1,I2
        W=WH(I)*WV(I)
        DSUM1=DSUM1+W
        DSUM2=DSUM2+W*XS(I)
        DSUM3=DSUM3+W*XS(I)*XS(I)
        DSUM4=DSUM4+W*XS(I)**3
        DSUM5=DSUM5+W*XS(I)**4
        DSUM6=DSUM6+W*YS(I)
        DSUM7=DSUM7+W*YS(I)*XS(I)
        DSUM8=DSUM8+W*YS(I)*XS(I)*XS(I)
 1320 CONTINUE
C
      IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'AFIT')GOTO1390
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1351)
 1351 FORMAT('***** IN THE MIDDLE OF QUAFIT--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1352)DSUM1,DSUM2,DSUM3,DSUM4
 1352 FORMAT('DSUM1,DSUM2,DSUM3,DSUM4 = ',4E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1353)DSUM5,DSUM6,DSUM7,DSUM8
 1353 FORMAT('DSUM5,DSUM6,DSUM7,DSUM8 = ',4E15.7)
      CALL DPWRST('XXX','BUG ')
 1390 CONTINUE
C
      XMAT(1,1)=DSUM1
      XMAT(2,1)=DSUM2
      XMAT(3,1)=DSUM3
      XMAT(1,2)=DSUM2
      XMAT(2,2)=DSUM3
      XMAT(2,3)=DSUM4
      XMAT(1,3)=DSUM3
      XMAT(2,3)=DSUM4
      XMAT(3,3)=DSUM5
      RHS(1)=DSUM6
      RHS(2)=DSUM7
      RHS(3)=DSUM8
      IPVT(1)=0
      IPVT(2)=0
      IPVT(3)=0
C
C  USE LINPACK TO SOLVE 3X3 EQUATION
C
      INFO=0
      NP=3
      CALL SGEFA(XMAT,NP,NP,IPVT,INFO)
      IF(INFO.NE.0)THEN
        ALPHA=0.0
        BETA1=0.0
        BETA2=0.0
        IERROR='YES'
      ELSE
        IJOB=0
        CALL SGESL(XMAT,NP,NP,IPVT,RHS,IJOB)
        ALPHA=RHS(1)
        BETA1=RHS(2)
        BETA2=RHS(3)
      END IF
C
      DO1340I=I3,I4
      PRED(I)=ALPHA+BETA1*XS(I)+BETA2*XS(I)*XS(I)
      RES(I)=YS(I)-PRED(I)
 1340 CONTINUE
C
      GOTO9000
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'AFIT')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF QUAFIT--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)ISUBRO,IBUGA3,IERROR
 9012 FORMAT('ISUBRO,IBUGA3,IERROR = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)IT,I1,I2,N,I3,I4
 9013 FORMAT('IT,I1,I2,N,I3,I4 = ',6I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9014)XMAXHF
 9014 FORMAT('XMAXHF = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      IF(N.LE.0)GOTO9033
      DO9031I=I1,I2
      WRITE(ICOUT,9032)I,XS(I),YS(I),WH(I),WV(I)
 9032 FORMAT('I,XS(I),YS(I),WH(I),WV(I) = ',I8,4E15.7)
      CALL DPWRST('XXX','BUG ')
 9031 CONTINUE
 9033 CONTINUE
      WRITE(ICOUT,9040)ALPHA,BETA1,BETA2
 9040 FORMAT('ALPHA,BETA1,BETA2 = ',3E15.7)
      CALL DPWRST('XXX','BUG ')
      IF(N.LE.0)GOTO9043
      DO9041I=I3,I4
      WRITE(ICOUT,9042)I,PRED(I),RES(I)
 9042 FORMAT('I,PRED(I),RES(I) = ',I8,2E15.7)
      CALL DPWRST('XXX','BUG ')
 9041 CONTINUE
 9043 CONTINUE
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE QUAFI2(XS,YS,N,
     1XTEMP,
     1ALPHA,BETA1,BETA2,
     1ISUBRO,IBUGA3,IERROR)
C
C     PURPOSE--CARRY OUT A LEAST SQUARES NON-WEIGHTED QUARADITIC FIT
C              OF THE VARIABLES XS(.) AND YS(.).
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2002/7
C     ORIGINAL VERSION--JULY       2002
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 ISUBRO
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
      DOUBLE PRECISION DMEANX
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DSUM2
      DOUBLE PRECISION DSUM3
      DOUBLE PRECISION DSUM4
      DOUBLE PRECISION DSUM5
      DOUBLE PRECISION DSUM6
C
C---------------------------------------------------------------------
C
      DIMENSION XMAT(3,3)
      DIMENSION IPVT(3)
      DIMENSION RHS(3)
      DIMENSION XS(*)
      DIMENSION YS(*)
      DIMENSION XTEMP(*)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='QUAF'
      ISUBN2='I2  '
C
      IERROR='NO'
C
      IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'AFI2')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF QUAFI2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)ISUBRO,IBUGA3,IERROR
   52 FORMAT('ISUBRO,IBUGA3,IERROR = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)N
   53 FORMAT('N = ',I8)
      CALL DPWRST('XXX','BUG ')
      IF(N.LE.0)GOTO63
      DO61I=1,N
      WRITE(ICOUT,62)I,XS(I),YS(I)
   62 FORMAT('I,XS(I),YS(I) = ',I8,2E15.7)
      CALL DPWRST('XXX','BUG ')
   61 CONTINUE
   63 CONTINUE
   90 CONTINUE
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      IF(N.GE.1)GOTO119
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,111)
  111 FORMAT('***** ERROR IN QUAFI2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,112)
  112 FORMAT('      THE INPUT SAMPLE SIZE MUST BE 1 OR LARGER.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,115)N
  115 FORMAT('      SUCH WAS NOT THE CASE HERE.  THE SAMPLE SIZE N = ',
     1       I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
  119 CONTINUE
C
C               ***********************************************
C               **  STEP 11--                                **
C               **  CARRY OUT A LEAST SQUARES QUADRATIC FIT  **
C               ***********************************************
C
      AN=N
C
C  SCALE THE DATA: SUBTRACT MEAN FROM X ARRAY
C
      DSUM1=0.0D0
      DO1310I=1,N
        DSUM1=DSUM1 + DBLE(XS(I))
 1310 CONTINUE
      DMEANX=DSUM1/DBLE(N)
C
      AMEANX=REAL(DMEANX)
      DO1320I=1,N
        XTEMP(I)=XS(I) - AMEANX
 1320 CONTINUE
C
      DSUM1=0.0D0
      DSUM2=0.0D0
      DSUM3=0.0D0
      DSUM4=0.0D0
      DSUM5=0.0D0
      DSUM6=0.0D0
      DO1330I=1,N
        DSUM1=DSUM1 + DBLE(YS(I))
        DSUM2=DSUM2 + DBLE(XTEMP(I))**2
        DSUM3=DSUM3 + DBLE(XTEMP(I))**3
        DSUM4=DSUM4 + DBLE(XTEMP(I))**4
        DSUM5=DSUM5 + DBLE(YS(I))*DBLE(XTEMP(I))
        DSUM6=DSUM6 + DBLE(YS(I))*DBLE(XTEMP(I))**2
 1330 CONTINUE
C
      IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'AFI2')GOTO1390
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1351)
 1351 FORMAT('***** IN THE MIDDLE OF QUAFI2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1352)DSUM1,DSUM2,DSUM3,DSUM4
 1352 FORMAT('DSUM1,DSUM2,DSUM3,DSUM4 = ',4E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1353)DSUM5,DSUM6,DMEANX
 1353 FORMAT('DSUM5,DSUM6,DMEANX = ',3D15.7)
      CALL DPWRST('XXX','BUG ')
 1390 CONTINUE
C
      XMAT(1,1)=AN
      XMAT(1,2)=0.0
      XMAT(1,3)=REAL(DSUM2)
      XMAT(2,1)=0.0
      XMAT(2,2)=REAL(DSUM2)
      XMAT(2,3)=REAL(DSUM3)
      XMAT(3,1)=REAL(DSUM2)
      XMAT(3,2)=REAL(DSUM3)
      XMAT(3,3)=REAL(DSUM4)
      RHS(1)=REAL(DSUM1)
      RHS(2)=REAL(DSUM5)
      RHS(3)=REAL(DSUM6)
      IPVT(1)=0
      IPVT(2)=0
      IPVT(3)=0
C
C  USE LINPACK TO SOLVE 2X2 EQUATION
C
      INFO=0
      NP=3
      CALL SGEFA(XMAT,NP,NP,IPVT,INFO)
      IF(INFO.NE.0)THEN
        ALPHA=0.0
        BETA1=0.0
        BETA2=0.0
        IERROR='YES'
      ELSE
        IJOB=0
        CALL SGESL(XMAT,NP,NP,IPVT,RHS,IJOB)
        B0=RHS(1)
        B1=RHS(2)
        B2=RHS(3)
        ALPHA=B0 - B1*AMEANX + B2*AMEANX*AMEANX
        BETA1=B1 - 2*B2*AMEANX
        BETA2=B2
      END IF
C
      GOTO9000
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'AFI2')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF QUAFI2--')
      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 ')
      IF(N.LE.0)GOTO9033
      DO9031I=1,N
      WRITE(ICOUT,9032)I,XS(I),YS(I)
 9032 FORMAT('I,XS(I),YS(I) = ',I8,2E15.7)
      CALL DPWRST('XXX','BUG ')
 9031 CONTINUE
 9033 CONTINUE
      WRITE(ICOUT,9040)ALPHA,BETA1,BETA2
 9040 FORMAT('ALPHA,BETA1,BETA2 = ',3E15.7)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      DOUBLE PRECISION FUNCTION QUAGLO(F,PARA)
C===================================================== QUAGLO.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  QUANTILE FUNCTION OF THE GENERALIZED LOGISTIC DISTRIBUTION
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DOUBLE PRECISION PARA(3)
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      REAL CPUMIN
      REAL CPUMAX
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DATA ZERO/0.0D0/,ONE/1.0D0/
C
      U=PARA(1)
      A=PARA(2)
      G=PARA(3)
C
      IF(A.LE.ZERO)THEN
        QUAGLO=ZERO
        WRITE(ICOUT,7010)
 7010   FORMAT('***** ERROR IN GL5PPF--NON-POSITIVE SCALE ',
     1         'PARAMETER.')
        CALL DPWRST('XXX','WRIT')
C
      ELSEIF(F.LE.ZERO.OR.F.GE.ONE)THEN
        IF((F.EQ.ZERO.AND.G.LT.ZERO) .OR. (F.EQ.ONE .AND.G.GT.ZERO))
     1    THEN
          QUAGLO=U+A/G
        ELSE
          WRITE(ICOUT,7000)
 7000     FORMAT('***** ERROR IN GL5PPF--ARGUMENT IS INVALID.')
          CALL DPWRST('XXX','WRIT')
          QUAGLO=ZERO
        ENDIF
      ELSE
        Y=DLOG(F/(ONE-F))
        IF(G.NE.ZERO)Y=(ONE-DEXP(-G*Y))/G
        QUAGLO=U+A*Y
      ENDIF
C
      RETURN
      END
      DOUBLE PRECISION FUNCTION QUAWAK(F,PARA)
C===================================================== QUAWAK.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  QUANTILE FUNCTION OF THE WAKEBY DISTRIBUTION
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DOUBLE PRECISION PARA(5)
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      REAL CPUMIN
      REAL CPUMAX
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DATA ZERO/0.0D0/,ONE/1.0D0/
C
C         UFL SHOULD BE CHOSEN SO THAT EXP(UFL) JUST DOES NOT CAUSE
C         UNDERFLOW
C
      DATA UFL/-170.0D0/
C
      XI=PARA(1)
      A=PARA(2)
      B=PARA(3)
      C=PARA(4)
      D=PARA(5)
C
C         TEST FOR VALID PARAMETERS
C
      IF(B+D.LE.ZERO.AND.(B.NE.ZERO.OR.C.NE.ZERO.OR.D.NE.ZERO))GOTO 1000
      IF(A.EQ.ZERO.AND.B.NE.ZERO)GOTO 1000
      IF(C.EQ.ZERO.AND.D.NE.ZERO)GOTO 1000
      IF(C.LT.ZERO.OR.A+C.LT.ZERO)GOTO 1000
      IF(A.EQ.ZERO.AND.C.EQ.ZERO)GOTO 1000
C
      IF(F.LE.ZERO.OR.F.GE.ONE)GOTO 10
      Z=-DLOG(ONE-F)
      Y1=Z
      IF(B.NE.ZERO)THEN
        TEMP=-B*Z
        IF(TEMP.LT.UFL)Y1=ONE/B
        IF(TEMP.GE.UFL)Y1=(ONE-DEXP(TEMP))/B
      ENDIF
      Y2=Z
      IF(D.NE.ZERO)Y2=(ONE-DEXP(D*Y2))/(-D)
      QUAWAK=XI+A*Y1+C*Y2
      GOTO9000
C
   10 CONTINUE
      IF(F.EQ.ZERO)THEN
        QUAWAK=XI
        GOTO9000
      ELSEIF(F.EQ.ONE)THEN
        IF(D.GT.ZERO)GOTO 1010
        IF(D.LT.ZERO)QUAWAK=XI+A/B-C/D
        IF(D.EQ.ZERO.AND.C.GT.ZERO)GOTO 1010
        IF(D.EQ.ZERO.AND.C.EQ.ZERO.AND.B.EQ.ZERO)GOTO 1010
        IF(D.EQ.ZERO.AND.C.EQ.ZERO.AND.B.GT.ZERO)QUAWAK=XI+A/B
        GOTO9000
      ELSE
        GOTO 1010
      ENDIF
C
 1000 CONTINUE
      WRITE(ICOUT,7000)
 7000 FORMAT('***** ERROR IN WAKPPF--PARAMETERS INVALID.')
      CALL DPWRST('XXX','WRIT')
      GOTO9000
C
 1010 CONTINUE
      WRITE(ICOUT,7010)
 7010 FORMAT('***** ERROR IN WAKPPF--ARGUMENT INVALID.')
      CALL DPWRST('XXX','WRIT')
      QUAWAK=ZERO
      GOTO9000
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE QUICH1(ICTEXT,NCTEXT,PLEC,PLECG,ANUMPP)
C
C     PURPOSE--FOR THE QMS GRAPHICS DEVICE,
C              FOR THE "104" (STANDARD ROMAN MEDIUM FONT)
C              10 POINT PROPORTIONAL FONT (TABLE ON APPENDIX B-4 OF
C              QUIC PROGRAMMERS MANUAL FROM QMS)
C              AND FOR THE HORIZONTAL DIRECTION,
C              DETERMINE THE LENGTH OF THE TEXT STRING IN THE
C              CHARACTER VECTOR ICTEXT(.),
C              WHICH CONSISTS OF NTEXT CHARACTERS.
C     NOTE--THE LENGTH IS IN STANDARDIZED COORDINATES
C           THAT IS, 0.0 TO 100.0
C
C     WRITTEN BY--ALAN HECKERT
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2899
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONCTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--89.2
C     ORIGINAL VERSION--JANUARY   1989.
C     UPDATED         --APRIL     1992. IIVALUE TO IVALUE
C
C-----NON-COMMON VARIABLES (GRAPHICS)-------------------------------------------
C
      CHARACTER*4 ICTEXT
      CHARACTER*4 ICTEMP
      CHARACTER*1 IC
C
      DIMENSION ICTEXT(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOGR.INC'
      INCLUDE 'DPCOBE.INC'
      INCLUDE 'DPCODV.INC'
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C     WIDTH TABLE, NOTE THAT ASCII CHARACTER 1-31 ARE CONTROL
C     CHARACTERS WITH ZERO WIDTH, CHARACTERS 127-255 ARE UNDEFINED.
C     THERFORE TABLE GOES FROM 32 TO 126.
C
      DIMENSION WIDTAB(95)
C
      DATA WIDTAB( 1) /25./
      DATA WIDTAB( 2) / 8./
      DATA WIDTAB( 3) /20./
      DATA WIDTAB( 4) /26./
      DATA WIDTAB( 5) /19./
      DATA WIDTAB( 6) /32./
      DATA WIDTAB( 7) /34./
      DATA WIDTAB( 8) / 9./
      DATA WIDTAB( 9) /15./
      DATA WIDTAB(10) /15./
      DATA WIDTAB(11) /17./
      DATA WIDTAB(12) /24./
      DATA WIDTAB(13) / 9./
      DATA WIDTAB(14) /15./
      DATA WIDTAB(15) / 9./
      DATA WIDTAB(16) /19./
      DATA WIDTAB(17) /23./
      DATA WIDTAB(18) /23./
      DATA WIDTAB(19) /23./
      DATA WIDTAB(20) /23./
      DATA WIDTAB(21) /23./
      DATA WIDTAB(22) /23./
      DATA WIDTAB(23) /23./
      DATA WIDTAB(24) /23./
      DATA WIDTAB(25) /23./
      DATA WIDTAB(26) /23./
      DATA WIDTAB(27) / 9./
      DATA WIDTAB(28) / 9./
      DATA WIDTAB(29) /19./
      DATA WIDTAB(30) /24./
      DATA WIDTAB(31) /19./
      DATA WIDTAB(32) /18./
      DATA WIDTAB(33) /25./
      DATA WIDTAB(34) /34./
      DATA WIDTAB(35) /26./
      DATA WIDTAB(36) /29./
      DATA WIDTAB(37) /31./
      DATA WIDTAB(38) /26./
      DATA WIDTAB(39) /25./
      DATA WIDTAB(40) /30./
      DATA WIDTAB(41) /32./
      DATA WIDTAB(42) /14./
      DATA WIDTAB(43) /18./
      DATA WIDTAB(44) /32./
      DATA WIDTAB(45) /27./
      DATA WIDTAB(46) /37./
      DATA WIDTAB(47) /29./
      DATA WIDTAB(48) /30./
      DATA WIDTAB(49) /24./
      DATA WIDTAB(50) /30./
      DATA WIDTAB(51) /28./
      DATA WIDTAB(52) /22./
      DATA WIDTAB(53) /28./
      DATA WIDTAB(54) /33./
      DATA WIDTAB(55) /34./
      DATA WIDTAB(56) /45./
      DATA WIDTAB(57) /31./
      DATA WIDTAB(58) /31./
      DATA WIDTAB(59) /27./
      DATA WIDTAB(60) /11./
      DATA WIDTAB(61) /20./
      DATA WIDTAB(62) /11./
      DATA WIDTAB(63) /20./
      DATA WIDTAB(64) /40./
      DATA WIDTAB(65) / 9./
      DATA WIDTAB(66) /20./
      DATA WIDTAB(67) /22./
      DATA WIDTAB(68) /18./
      DATA WIDTAB(69) /23./
      DATA WIDTAB(70) /18./
      DATA WIDTAB(71) /19./
      DATA WIDTAB(72) /21./
      DATA WIDTAB(73) /25./
      DATA WIDTAB(74) /13./
      DATA WIDTAB(75) /13./
      DATA WIDTAB(76) /26./
      DATA WIDTAB(77) /15./
      DATA WIDTAB(78) /37./
      DATA WIDTAB(79) /25./
      DATA WIDTAB(80) /20./
      DATA WIDTAB(81) /23./
      DATA WIDTAB(82) /23./
      DATA WIDTAB(83) /18./
      DATA WIDTAB(84) /16./
      DATA WIDTAB(85) /16./
      DATA WIDTAB(86) /25./
      DATA WIDTAB(87) /26./
      DATA WIDTAB(88) /39./
      DATA WIDTAB(89) /23./
      DATA WIDTAB(90) /26./
      DATA WIDTAB(91) /19./
      DATA WIDTAB(92) /15./
      DATA WIDTAB(93) / 5./
      DATA WIDTAB(94) /15./
      DATA WIDTAB(95) /18./
C
C-----START POINT-----------------------------------------------------
C
C
C     **************************************************************
C     **    STEP 1 - SUM UP THE LENGTH OF THE STRING (IN "DOTS")  **
C     **************************************************************
C
      SUM=0.
      DO100I=1,NCTEXT
      ICTEMP=ICTEXT(I)
      IC=ICTEMP(1:1)
      CALL DPCOAN(IC,IVALUE)
CCCCC THE FOLLOWING LINE WAS FIXED   APRIL 1992
CCCCC IF(IVALUE.LT.32..OR.IIVALUE.GT.126)GOTO100
      IF(IVALUE.LT.32.OR.IVALUE.GT.126)GOTO100
      IVALUE=IVALUE-31
      SUM=SUM+WIDTAB(IVALUE)
 100  CONTINUE
C
C     **************************************************************
C     **    STEP 2 - CONVERT DOTS TO DATAPLOT PERCENT UNITS       **
C     **************************************************************
C
      PLEC=100.*(SUM/ANUMPP)
      PLECG=PLEC
C
C     **************************************************************
C     **    RETURN                                                **
C     **************************************************************
C
      RETURN
      END
      SUBROUTINE QUICH2(ICTEXT,NCTEXT,PLEC,PLECG,ANUMPP)
C
C     PURPOSE--FOR THE QMS GRAPHICS DEVICE,
C              FOR THE "124" (STANDARD ROMAN BOLD FONT)
C              10 POINT PROPORTIONAL FONT (TABLE ON APPENDIX B-6 OF
C              QUIC PROGRAMMERS MANUAL FROM QMS)
C              AND FOR THE HORIZONTAL DIRECTION,
C              DETERMINE THE LENGTH OF THE TEXT STRING IN THE
C              CHARACTER VECTOR ICTEXT(.),
C              WHICH CONSISTS OF NTEXT CHARACTERS.
C     NOTE--THE LENGTH IS IN STANDARDIZED COORDINATES
C           THAT IS, 0.0 TO 100.0
C
C     WRITTEN BY--ALAN HECKERT
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2899
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONCTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--89.2
C     ORIGINAL VERSION--JANUARY   1989.
C     UPDATED         --APRIL     1992. IIVALUE TO IVALUE
C
C-----NON-COMMON VARIABLES (GRAPHICS)-------------------------------------------
C
      CHARACTER*4 ICTEXT
      CHARACTER*4 ICTEMP
      CHARACTER*1 IC
C
      DIMENSION ICTEXT(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOGR.INC'
      INCLUDE 'DPCOBE.INC'
      INCLUDE 'DPCODV.INC'
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C     WIDTH TABLE, NOTE THAT ASCII CHARACTER 1-31 ARE CONTROL
C     CHARACTERS WITH ZERO WIDTH, CHARACTERS 127-255 ARE UNDEFINED.
C     THERFORE TABLE GOES FROM 32 TO 126.
C
      DIMENSION WIDTAB(95)
C
      DATA WIDTAB( 1) /25./
      DATA WIDTAB( 2) /10./
      DATA WIDTAB( 3) /22./
      DATA WIDTAB( 4) /28./
      DATA WIDTAB( 5) /21./
      DATA WIDTAB( 6) /34./
      DATA WIDTAB( 7) /36./
      DATA WIDTAB( 8) /11./
      DATA WIDTAB( 9) /15./
      DATA WIDTAB(10) /15./
      DATA WIDTAB(11) /19./
      DATA WIDTAB(12) /23./
      DATA WIDTAB(13) /11./
      DATA WIDTAB(14) /16./
      DATA WIDTAB(15) /11./
      DATA WIDTAB(16) /21./
      DATA WIDTAB(17) /24./
      DATA WIDTAB(18) /24./
      DATA WIDTAB(19) /24./
      DATA WIDTAB(20) /24./
      DATA WIDTAB(21) /24./
      DATA WIDTAB(22) /24./
      DATA WIDTAB(23) /24./
      DATA WIDTAB(24) /24./
      DATA WIDTAB(25) /24./
      DATA WIDTAB(26) /24./
      DATA WIDTAB(27) /11./
      DATA WIDTAB(28) /11./
      DATA WIDTAB(29) /21./
      DATA WIDTAB(30) /25./
      DATA WIDTAB(31) /21./
      DATA WIDTAB(32) /20./
      DATA WIDTAB(33) /27./
      DATA WIDTAB(34) /34./
      DATA WIDTAB(35) /27./
      DATA WIDTAB(36) /30./
      DATA WIDTAB(37) /33./
      DATA WIDTAB(38) /28./
      DATA WIDTAB(39) /27./
      DATA WIDTAB(40) /32./
      DATA WIDTAB(41) /34./
      DATA WIDTAB(42) /16./
      DATA WIDTAB(43) /21./
      DATA WIDTAB(44) /33./
      DATA WIDTAB(45) /29./
      DATA WIDTAB(46) /43./
      DATA WIDTAB(47) /35./
      DATA WIDTAB(48) /32./
      DATA WIDTAB(49) /27./
      DATA WIDTAB(50) /33./
      DATA WIDTAB(51) /30./
      DATA WIDTAB(52) /25./
      DATA WIDTAB(53) /31./
      DATA WIDTAB(54) /34./
      DATA WIDTAB(55) /35./
      DATA WIDTAB(56) /46./
      DATA WIDTAB(57) /35./
      DATA WIDTAB(58) /34./
      DATA WIDTAB(59) /30./
      DATA WIDTAB(60) /15./
      DATA WIDTAB(61) /21./
      DATA WIDTAB(62) /15./
      DATA WIDTAB(63) /20./
      DATA WIDTAB(64) /40./
      DATA WIDTAB(65) /12./
      DATA WIDTAB(66) /23./
      DATA WIDTAB(67) /25./
      DATA WIDTAB(68) /21./
      DATA WIDTAB(69) /25./
      DATA WIDTAB(70) /21./
      DATA WIDTAB(71) /22./
      DATA WIDTAB(72) /23./
      DATA WIDTAB(73) /28./
      DATA WIDTAB(74) /16./
      DATA WIDTAB(75) /15./
      DATA WIDTAB(76) /28./
      DATA WIDTAB(77) /16./
      DATA WIDTAB(78) /40./
      DATA WIDTAB(79) /28./
      DATA WIDTAB(80) /23./
      DATA WIDTAB(81) /25./
      DATA WIDTAB(82) /26./
      DATA WIDTAB(83) /22./
      DATA WIDTAB(84) /18./
      DATA WIDTAB(85) /19./
      DATA WIDTAB(86) /25./
      DATA WIDTAB(87) /28./
      DATA WIDTAB(88) /39./
      DATA WIDTAB(89) /26./
      DATA WIDTAB(90) /29./
      DATA WIDTAB(91) /21./
      DATA WIDTAB(92) /18./
      DATA WIDTAB(93) / 5./
      DATA WIDTAB(94) /18./
      DATA WIDTAB(95) /21./
C
C-----START POINT-----------------------------------------------------
C
C
C     **************************************************************
C     **    STEP 1 - SUM UP THE LENGTH OF THE STRING (IN "DOTS")  **
C     **************************************************************
C
      SUM=0.
      DO100I=1,NCTEXT
      ICTEMP=ICTEXT(I)
      IC=ICTEMP(1:1)
      CALL DPCOAN(IC,IVALUE)
CCCCC THE FOLLOWING LINE WAS FIXED   APRIL 1992
CCCCC IF(IVALUE.LT.32..OR.IIVALUE.GT.126)GOTO100
      IF(IVALUE.LT.32.OR.IVALUE.GT.126)GOTO100
      IVALUE=IVALUE-31
      SUM=SUM+WIDTAB(IVALUE)
 100  CONTINUE
C
C     **************************************************************
C     **    STEP 2 - CONVERT DOTS TO DATAPLOT PERCENT UNITS       **
C     **************************************************************
C
      PLEC=100.*(SUM/ANUMPP)
      PLECG=PLEC
C
C     **************************************************************
C     **    RETURN                                                **
C     **************************************************************
C
      RETURN
      END
 
      SUBROUTINE QUICH3(ICTEXT,NCTEXT,PLEC,PLECG,ANUMPP)
C
C     PURPOSE--FOR THE QMS GRAPHICS DEVICE,
C              FOR THE "144" (STANDARD ROMAN ITALIC FONT)
C              10 POINT PROPORTIONAL FONT (TABLE ON APPENDIX B-8 OF
C              QUIC PROGRAMMERS MANUAL FROM QMS)
C              AND FOR THE HORIZONTAL DIRECTION,
C              DETERMINE THE LENGTH OF THE TEXT STRING IN THE
C              CHARACTER VECTOR ICTEXT(.),
C              WHICH CONSISTS OF NTEXT CHARACTERS.
C     NOTE--THE LENGTH IS IN STANDARDIZED COORDINATES
C           THAT IS, 0.0 TO 100.0
C
C     WRITTEN BY--ALAN HECKERT
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2899
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONCTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--89.2
C     ORIGINAL VERSION--JANUARY   1989.
C     UPDATED         --APRIL     1992. IIVALUE TO IVALUE
C
C-----NON-COMMON VARIABLES (GRAPHICS)-------------------------------------------
C
      CHARACTER*4 ICTEXT
      CHARACTER*4 ICTEMP
      CHARACTER*1 IC
C
      DIMENSION ICTEXT(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOGR.INC'
      INCLUDE 'DPCOBE.INC'
      INCLUDE 'DPCODV.INC'
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C     WIDTH TABLE, NOTE THAT ASCII CHARACTER 1-31 ARE CONTROL
C     CHARACTERS WITH ZERO WIDTH, CHARACTERS 127-255 ARE UNDEFINED.
C     THERFORE TABLE GOES FROM 32 TO 126.
C
      DIMENSION WIDTAB(95)
C
      DATA WIDTAB( 1) /28./
      DATA WIDTAB( 2) /13./
      DATA WIDTAB( 3) /16./
      DATA WIDTAB( 4) /25./
      DATA WIDTAB( 5) /21./
      DATA WIDTAB( 6) /34./
      DATA WIDTAB( 7) /31./
      DATA WIDTAB( 8) / 8./
      DATA WIDTAB( 9) /13./
      DATA WIDTAB(10) /13./
      DATA WIDTAB(11) /17./
      DATA WIDTAB(12) /24./
      DATA WIDTAB(13) / 8./
      DATA WIDTAB(14) /15./
      DATA WIDTAB(15) / 8./
      DATA WIDTAB(16) /19./
      DATA WIDTAB(17) /23./
      DATA WIDTAB(18) /23./
      DATA WIDTAB(19) /23./
      DATA WIDTAB(20) /23./
      DATA WIDTAB(21) /23./
      DATA WIDTAB(22) /23./
      DATA WIDTAB(23) /23./
      DATA WIDTAB(24) /23./
      DATA WIDTAB(25) /23./
      DATA WIDTAB(26) /23./
      DATA WIDTAB(27) /11./
      DATA WIDTAB(28) /11./
      DATA WIDTAB(29) /15./
      DATA WIDTAB(30) /24./
      DATA WIDTAB(31) /16./
      DATA WIDTAB(32) /16./
      DATA WIDTAB(33) /25./
      DATA WIDTAB(34) /33./
      DATA WIDTAB(35) /30./
      DATA WIDTAB(36) /29./
      DATA WIDTAB(37) /34./
      DATA WIDTAB(38) /32./
      DATA WIDTAB(39) /33./
      DATA WIDTAB(40) /31./
      DATA WIDTAB(41) /41./
      DATA WIDTAB(42) /24./
      DATA WIDTAB(43) /26./
      DATA WIDTAB(44) /38./
      DATA WIDTAB(45) /30./
      DATA WIDTAB(46) /45./
      DATA WIDTAB(47) /39./
      DATA WIDTAB(48) /30./
      DATA WIDTAB(49) /30./
      DATA WIDTAB(50) /29./
      DATA WIDTAB(51) /30./
      DATA WIDTAB(52) /25./
      DATA WIDTAB(53) /29./
      DATA WIDTAB(54) /33./
      DATA WIDTAB(55) /33./
      DATA WIDTAB(56) /43./
      DATA WIDTAB(57) /36./
      DATA WIDTAB(58) /31./
      DATA WIDTAB(59) /29./
      DATA WIDTAB(60) /18./
      DATA WIDTAB(61) /18./
      DATA WIDTAB(62) /19./
      DATA WIDTAB(63) /19./
      DATA WIDTAB(64) /40./
      DATA WIDTAB(65) / 8./
      DATA WIDTAB(66) /22./
      DATA WIDTAB(67) /21./
      DATA WIDTAB(68) /20./
      DATA WIDTAB(69) /25./
      DATA WIDTAB(70) /19./
      DATA WIDTAB(71) /28./
      DATA WIDTAB(72) /23./
      DATA WIDTAB(73) /25./
      DATA WIDTAB(74) /12./
      DATA WIDTAB(75) /19./
      DATA WIDTAB(76) /24./
      DATA WIDTAB(77) /13./
      DATA WIDTAB(78) /34./
      DATA WIDTAB(79) /25./
      DATA WIDTAB(80) /20./
      DATA WIDTAB(81) /25./
      DATA WIDTAB(82) /21./
      DATA WIDTAB(83) /20./
      DATA WIDTAB(84) /19./
      DATA WIDTAB(85) /15./
      DATA WIDTAB(86) /22./
      DATA WIDTAB(87) /22./
      DATA WIDTAB(88) /31./
      DATA WIDTAB(89) /24./
      DATA WIDTAB(90) /23./
      DATA WIDTAB(91) /21./
      DATA WIDTAB(92) /19./
      DATA WIDTAB(93) / 5./
      DATA WIDTAB(94) /19./
      DATA WIDTAB(95) /17./
C
C-----START POINT-----------------------------------------------------
C
C
C     **************************************************************
C     **    STEP 1 - SUM UP THE LENGTH OF THE STRING (IN "DOTS")  **
C     **************************************************************
C
      SUM=0.
      DO100I=1,NCTEXT
      ICTEMP=ICTEXT(I)
      IC=ICTEMP(1:1)
      CALL DPCOAN(IC,IVALUE)
CCCCC THE FOLLOWING LINE WAS FIXED   APRIL 1992
CCCCC IF(IVALUE.LT.32..OR.IIVALUE.GT.126)GOTO100
      IF(IVALUE.LT.32.OR.IVALUE.GT.126)GOTO100
      IVALUE=IVALUE-31
      SUM=SUM+WIDTAB(IVALUE)
 100  CONTINUE
C
C     **************************************************************
C     **    STEP 2 - CONVERT DOTS TO DATAPLOT PERCENT UNITS       **
C     **************************************************************
C
      PLEC=100.*(SUM/ANUMPP)
      PLECG=PLEC
C
C     **************************************************************
C     **    RETURN                                                **
C     **************************************************************
C
      RETURN
      END
      SUBROUTINE QUICH4(ICTEXT,NCTEXT,PLEC,PLECG,ANUMPP)
C
C     PURPOSE--FOR THE QMS GRAPHICS DEVICE,
C              FOR THE "16" (SIMPLEX ROMAN FONT)
C              5 POINT PROPORTIONAL FONT (TABLE ON APPENDIX B-10 OF
C              QUIC PROGRAMMERS MANUAL FROM QMS)
C              AND FOR THE HORIZONTAL DIRECTION,
C              DETERMINE THE LENGTH OF THE TEXT STRING IN THE
C              CHARACTER VECTOR ICTEXT(.),
C              WHICH CONSISTS OF NTEXT CHARACTERS.
C     NOTE--THE LENGTH IS IN STANDARDIZED COORDINATES
C           THAT IS, 0.0 TO 100.0
C
C     WRITTEN BY--ALAN HECKERT
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2899
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONCTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--89.2
C     ORIGINAL VERSION--JANUARY   1989.
C     UPDATED         --APRIL     1992. IIVALUE TO IVALUE
C
C-----NON-COMMON VARIABLES (GRAPHICS)-------------------------------------------
C
      CHARACTER*4 ICTEXT
      CHARACTER*4 ICTEMP
      CHARACTER*1 IC
C
      DIMENSION ICTEXT(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOGR.INC'
      INCLUDE 'DPCOBE.INC'
      INCLUDE 'DPCODV.INC'
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C     WIDTH TABLE, NOTE THAT ASCII CHARACTER 1-31 ARE CONTROL
C     CHARACTERS WITH ZERO WIDTH, CHARACTERS 127-255 ARE UNDEFINED.
C     THERFORE TABLE GOES FROM 32 TO 126.
C
      DIMENSION WIDTAB(95)
C
      DATA WIDTAB( 1) /13./
      DATA WIDTAB( 2) / 9./
      DATA WIDTAB( 3) /13./
      DATA WIDTAB( 4) /17./
      DATA WIDTAB( 5) /17./
      DATA WIDTAB( 6) /19./
      DATA WIDTAB( 7) /19./
      DATA WIDTAB( 8) / 9./
      DATA WIDTAB( 9) /11./
      DATA WIDTAB(10) /11./
      DATA WIDTAB(11) /13./
      DATA WIDTAB(12) /21./
      DATA WIDTAB(13) / 9./
      DATA WIDTAB(14) /21./
      DATA WIDTAB(15) / 9./
      DATA WIDTAB(16) /17./
      DATA WIDTAB(17) /17./
      DATA WIDTAB(18) /17./
      DATA WIDTAB(19) /17./
      DATA WIDTAB(20) /17./
      DATA WIDTAB(21) /17./
      DATA WIDTAB(22) /17./
      DATA WIDTAB(23) /17./
      DATA WIDTAB(24) /17./
      DATA WIDTAB(25) /17./
      DATA WIDTAB(26) /17./
      DATA WIDTAB(27) / 9./
      DATA WIDTAB(28) / 9./
      DATA WIDTAB(29) /19./
      DATA WIDTAB(30) /21./
      DATA WIDTAB(31) /19./
      DATA WIDTAB(32) /15./
      DATA WIDTAB(33) /17./
      DATA WIDTAB(34) /15./
      DATA WIDTAB(35) /17./
      DATA WIDTAB(36) /17./
      DATA WIDTAB(37) /17./
      DATA WIDTAB(38) /16./
      DATA WIDTAB(39) /15./
      DATA WIDTAB(40) /17./
      DATA WIDTAB(41) /17./
      DATA WIDTAB(42) / 7./
      DATA WIDTAB(43) /13./
      DATA WIDTAB(44) /17./
      DATA WIDTAB(45) /14./
      DATA WIDTAB(46) /19./
      DATA WIDTAB(47) /17./
      DATA WIDTAB(48) /17./
      DATA WIDTAB(49) /17./
      DATA WIDTAB(50) /17./
      DATA WIDTAB(51) /17./
      DATA WIDTAB(52) /17./
      DATA WIDTAB(53) /13./
      DATA WIDTAB(54) /17./
      DATA WIDTAB(55) /15./
      DATA WIDTAB(56) /19./
      DATA WIDTAB(57) /17./
      DATA WIDTAB(58) /15./
      DATA WIDTAB(59) /17./
      DATA WIDTAB(60) /11./
      DATA WIDTAB(61) /15./
      DATA WIDTAB(62) /11./
      DATA WIDTAB(63) /13./
      DATA WIDTAB(64) /15./
      DATA WIDTAB(65) / 9./
      DATA WIDTAB(66) /16./
      DATA WIDTAB(67) /16./
      DATA WIDTAB(68) /15./
      DATA WIDTAB(69) /16./
      DATA WIDTAB(70) /15./
      DATA WIDTAB(71) /10./
      DATA WIDTAB(72) /16./
      DATA WIDTAB(73) /16./
      DATA WIDTAB(74) / 7./
      DATA WIDTAB(75) / 9./
      DATA WIDTAB(76) /14./
      DATA WIDTAB(77) / 7./
      DATA WIDTAB(78) /17./
      DATA WIDTAB(79) /16./
      DATA WIDTAB(80) /16./
      DATA WIDTAB(81) /16./
      DATA WIDTAB(82) /16./
      DATA WIDTAB(83) /11./
      DATA WIDTAB(84) /14./
      DATA WIDTAB(85) /10./
      DATA WIDTAB(86) /16./
      DATA WIDTAB(87) /13./
      DATA WIDTAB(88) /17./
      DATA WIDTAB(89) /14./
      DATA WIDTAB(90) /13./
      DATA WIDTAB(91) /14./
      DATA WIDTAB(92) /11./
      DATA WIDTAB(93) / 7./
      DATA WIDTAB(94) /11./
      DATA WIDTAB(95) /19./
C
C-----START POINT-----------------------------------------------------
C
C
C     **************************************************************
C     **    STEP 1 - SUM UP THE LENGTH OF THE STRING (IN "DOTS")  **
C     **************************************************************
C
      SUM=0.
      DO100I=1,NCTEXT
      ICTEMP=ICTEXT(I)
      IC=ICTEMP(1:1)
      CALL DPCOAN(IC,IVALUE)
CCCCC THE FOLLOWING LINE WAS FIXED   APRIL 1992
CCCCC IF(IVALUE.LT.32..OR.IIVALUE.GT.126)GOTO100
      IF(IVALUE.LT.32.OR.IVALUE.GT.126)GOTO100
      IVALUE=IVALUE-31
      SUM=SUM+WIDTAB(IVALUE)
 100  CONTINUE
C
C     **************************************************************
C     **    STEP 2 - CONVERT DOTS TO DATAPLOT PERCENT UNITS       **
C     **************************************************************
C
      PLEC=100.*(SUM/ANUMPP)
      PLECG=PLEC
C
C     **************************************************************
C     **    RETURN                                                **
C     **************************************************************
C
      RETURN
      END
      SUBROUTINE QUICH5(ICTEXT,NCTEXT,PLEC,PLECG,ANUMPP)
C
C     PURPOSE--FOR THE QMS GRAPHICS DEVICE,
C              FOR THE "204" (APOLLO MEDIUM FONT)
C              10 POINT PROPORTIONAL FONT (TABLE ON APPENDIX B-12 OF
C              QUIC PROGRAMMERS MANUAL FROM QMS)
C              AND FOR THE HORIZONTAL DIRECTION,
C              DETERMINE THE LENGTH OF THE TEXT STRING IN THE
C              CHARACTER VECTOR ICTEXT(.),
C              WHICH CONSISTS OF NTEXT CHARACTERS.
C     NOTE--THE LENGTH IS IN STANDARDIZED COORDINATES
C           THAT IS, 0.0 TO 100.0
C
C     WRITTEN BY--ALAN HECKERT
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2899
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONCTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--89.2
C     ORIGINAL VERSION--JANUARY   1989.
C     UPDATED         --APRIL     1992. IIVALUE TO IVALUE
C
C-----NON-COMMON VARIABLES (GRAPHICS)-------------------------------------------
C
      CHARACTER*4 ICTEXT
      CHARACTER*4 ICTEMP
      CHARACTER*1 IC
C
      DIMENSION ICTEXT(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOGR.INC'
      INCLUDE 'DPCOBE.INC'
      INCLUDE 'DPCODV.INC'
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C     WIDTH TABLE, NOTE THAT ASCII CHARACTER 1-31 ARE CONTROL
C     CHARACTERS WITH ZERO WIDTH, CHARACTERS 127-255 ARE UNDEFINED.
C     THERFORE TABLE GOES FROM 32 TO 126.
C
      DIMENSION WIDTAB(95)
C
      DATA WIDTAB( 1) /23./
      DATA WIDTAB( 2) / 9./
      DATA WIDTAB( 3) /14./
      DATA WIDTAB( 4) /28./
      DATA WIDTAB( 5) /21./
      DATA WIDTAB( 6) /32./
      DATA WIDTAB( 7) /31./
      DATA WIDTAB( 8) / 7./
      DATA WIDTAB( 9) /12./
      DATA WIDTAB(10) /12./
      DATA WIDTAB(11) /19./
      DATA WIDTAB(12) /26./
      DATA WIDTAB(13) /10./
      DATA WIDTAB(14) /25./
      DATA WIDTAB(15) / 8./
      DATA WIDTAB(16) /16./
      DATA WIDTAB(17) /28./
      DATA WIDTAB(18) /28./
      DATA WIDTAB(19) /28./
      DATA WIDTAB(20) /28./
      DATA WIDTAB(21) /28./
      DATA WIDTAB(22) /28./
      DATA WIDTAB(23) /28./
      DATA WIDTAB(24) /28./
      DATA WIDTAB(25) /28./
      DATA WIDTAB(26) /28./
      DATA WIDTAB(27) / 8./
      DATA WIDTAB(28) /10./
      DATA WIDTAB(29) /13./
      DATA WIDTAB(30) /25./
      DATA WIDTAB(31) /13./
      DATA WIDTAB(32) /22./
      DATA WIDTAB(33) /34./
      DATA WIDTAB(34) /31./
      DATA WIDTAB(35) /28./
      DATA WIDTAB(36) /30./
      DATA WIDTAB(37) /31./
      DATA WIDTAB(38) /26./
      DATA WIDTAB(39) /24./
      DATA WIDTAB(40) /29./
      DATA WIDTAB(41) /30./
      DATA WIDTAB(42) /11./
      DATA WIDTAB(43) /22./
      DATA WIDTAB(44) /28./
      DATA WIDTAB(45) /24./
      DATA WIDTAB(46) /33./
      DATA WIDTAB(47) /25./
      DATA WIDTAB(48) /33./
      DATA WIDTAB(49) /25./
      DATA WIDTAB(50) /33./
      DATA WIDTAB(51) /26./
      DATA WIDTAB(52) /27./
      DATA WIDTAB(53) /27./
      DATA WIDTAB(54) /31./
      DATA WIDTAB(55) /31./
      DATA WIDTAB(56) /48./
      DATA WIDTAB(57) /30./
      DATA WIDTAB(58) /31./
      DATA WIDTAB(59) /28./
      DATA WIDTAB(60) /11./
      DATA WIDTAB(61) /16./
      DATA WIDTAB(62) /11./
      DATA WIDTAB(63) /21./
      DATA WIDTAB(64) /35./
      DATA WIDTAB(65) / 7./
      DATA WIDTAB(66) /25./
      DATA WIDTAB(67) /27./
      DATA WIDTAB(68) /24./
      DATA WIDTAB(69) /27./
      DATA WIDTAB(70) /25./
      DATA WIDTAB(71) /19./
      DATA WIDTAB(72) /26./
      DATA WIDTAB(73) /23./
      DATA WIDTAB(74) /11./
      DATA WIDTAB(75) /14./
      DATA WIDTAB(76) /23./
      DATA WIDTAB(77) /11./
      DATA WIDTAB(78) /39./
      DATA WIDTAB(79) /25./
      DATA WIDTAB(80) /27./
      DATA WIDTAB(81) /27./
      DATA WIDTAB(82) /27./
      DATA WIDTAB(83) /19./
      DATA WIDTAB(84) /22./
      DATA WIDTAB(85) /17./
      DATA WIDTAB(86) /28./
      DATA WIDTAB(87) /27./
      DATA WIDTAB(88) /40./
      DATA WIDTAB(89) /28./
      DATA WIDTAB(90) /26./
      DATA WIDTAB(91) /22./
      DATA WIDTAB(92) /15./
      DATA WIDTAB(93) / 6./
      DATA WIDTAB(94) /15./
      DATA WIDTAB(95) /20./
C
C-----START POINT-----------------------------------------------------
C
C
C     **************************************************************
C     **    STEP 1 - SUM UP THE LENGTH OF THE STRING (IN "DOTS")  **
C     **************************************************************
C
      SUM=0.
      DO100I=1,NCTEXT
      ICTEMP=ICTEXT(I)
      IC=ICTEMP(1:1)
      CALL DPCOAN(IC,IVALUE)
CCCCC THE FOLLOWING LINE WAS FIXED   APRIL 1992
CCCCC IF(IVALUE.LT.32..OR.IIVALUE.GT.126)GOTO100
      IF(IVALUE.LT.32.OR.IVALUE.GT.126)GOTO100
      IVALUE=IVALUE-31
      SUM=SUM+WIDTAB(IVALUE)
 100  CONTINUE
C
C     **************************************************************
C     **    STEP 2 - CONVERT DOTS TO DATAPLOT PERCENT UNITS       **
C     **************************************************************
C
      PLEC=100.*(SUM/ANUMPP)
      PLECG=PLEC
C
C     **************************************************************
C     **    RETURN                                                **
C     **************************************************************
C
      RETURN
      END
      SUBROUTINE QUICH6(ICTEXT,NCTEXT,PLEC,PLECG,ANUMPP)
C
C     PURPOSE--FOR THE QMS GRAPHICS DEVICE,
C              FOR THE "328" (COMPLEX ROMAN BOLD FONT)
C              15 POINT PROPORTIONAL FONT (TABLE ON APPENDIX B-14 OF
C              QUIC PROGRAMMERS MANUAL FROM QMS)
C              AND FOR THE HORIZONTAL DIRECTION,
C              DETERMINE THE LENGTH OF THE TEXT STRING IN THE
C              CHARACTER VECTOR ICTEXT(.),
C              WHICH CONSISTS OF NTEXT CHARACTERS.
C     NOTE--THE LENGTH IS IN STANDARDIZED COORDINATES
C           THAT IS, 0.0 TO 100.0
C
C     WRITTEN BY--ALAN HECKERT
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2899
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONCTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--89.2
C     ORIGINAL VERSION--JANUARY   1989.
C     UPDATED         --APRIL     1992. IIVALUE TO IVALUE
C
C-----NON-COMMON VARIABLES (GRAPHICS)-------------------------------------------
C
      CHARACTER*4 ICTEXT
      CHARACTER*4 ICTEMP
      CHARACTER*1 IC
C
      DIMENSION ICTEXT(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOGR.INC'
      INCLUDE 'DPCOBE.INC'
      INCLUDE 'DPCODV.INC'
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C     WIDTH TABLE, NOTE THAT ASCII CHARACTER 1-31 ARE CONTROL
C     CHARACTERS WITH ZERO WIDTH, CHARACTERS 127-255 ARE UNDEFINED.
C     THERFORE TABLE GOES FROM 32 TO 126.
C
      DIMENSION WIDTAB(95)
C
      DATA WIDTAB( 1) /35./
      DATA WIDTAB( 2) /12./
      DATA WIDTAB( 3) /18./
      DATA WIDTAB( 4) /41./
      DATA WIDTAB( 5) /32./
      DATA WIDTAB( 6) /50./
      DATA WIDTAB( 7) /52./
      DATA WIDTAB( 8) / 8./
      DATA WIDTAB( 9) /15./
      DATA WIDTAB(10) /15./
      DATA WIDTAB(11) /16./
      DATA WIDTAB(12) /38./
      DATA WIDTAB(13) /13./
      DATA WIDTAB(14) /23./
      DATA WIDTAB(15) /11./
      DATA WIDTAB(16) /28./
      DATA WIDTAB(17) /45./
      DATA WIDTAB(18) /45./
      DATA WIDTAB(19) /45./
      DATA WIDTAB(20) /45./
      DATA WIDTAB(21) /45./
      DATA WIDTAB(22) /45./
      DATA WIDTAB(23) /45./
      DATA WIDTAB(24) /45./
      DATA WIDTAB(25) /45./
      DATA WIDTAB(26) /45./
      DATA WIDTAB(27) /13./
      DATA WIDTAB(28) /13./
      DATA WIDTAB(29) /17./
      DATA WIDTAB(30) /36./
      DATA WIDTAB(31) /17./
      DATA WIDTAB(32) /32./
      DATA WIDTAB(33) /43./
      DATA WIDTAB(34) /51./
      DATA WIDTAB(35) /48./
      DATA WIDTAB(36) /42./
      DATA WIDTAB(37) /49./
      DATA WIDTAB(38) /47./
      DATA WIDTAB(39) /46./
      DATA WIDTAB(40) /48./
      DATA WIDTAB(41) /52./
      DATA WIDTAB(42) /27./
      DATA WIDTAB(43) /40./
      DATA WIDTAB(44) /55./
      DATA WIDTAB(45) /44./
      DATA WIDTAB(46) /63./
      DATA WIDTAB(47) /53./
      DATA WIDTAB(48) /48./
      DATA WIDTAB(49) /45./
      DATA WIDTAB(50) /54./
      DATA WIDTAB(51) /53./
      DATA WIDTAB(52) /40./
      DATA WIDTAB(53) /45./
      DATA WIDTAB(54) /52./
      DATA WIDTAB(55) /49./
      DATA WIDTAB(56) /77./
      DATA WIDTAB(57) /57./
      DATA WIDTAB(58) /56./
      DATA WIDTAB(59) /42./
      DATA WIDTAB(60) /14./
      DATA WIDTAB(61) /28./
      DATA WIDTAB(62) /14./
      DATA WIDTAB(63) /21./
      DATA WIDTAB(64) /50./
      DATA WIDTAB(65) / 8./
      DATA WIDTAB(66) /36./
      DATA WIDTAB(67) /38./
      DATA WIDTAB(68) /31./
      DATA WIDTAB(69) /40./
      DATA WIDTAB(70) /33./
      DATA WIDTAB(71) /28./
      DATA WIDTAB(72) /41./
      DATA WIDTAB(73) /41./
      DATA WIDTAB(74) /22./
      DATA WIDTAB(75) /23./
      DATA WIDTAB(76) /43./
      DATA WIDTAB(77) /20./
      DATA WIDTAB(78) /60./
      DATA WIDTAB(79) /40./
      DATA WIDTAB(80) /34./
      DATA WIDTAB(81) /39./
      DATA WIDTAB(82) /39./
      DATA WIDTAB(83) /30./
      DATA WIDTAB(84) /31./
      DATA WIDTAB(85) /26./
      DATA WIDTAB(86) /40./
      DATA WIDTAB(87) /39./
      DATA WIDTAB(88) /58./
      DATA WIDTAB(89) /41./
      DATA WIDTAB(90) /41./
      DATA WIDTAB(91) /35./
      DATA WIDTAB(92) /18./
      DATA WIDTAB(93) / 6./
      DATA WIDTAB(94) /18./
      DATA WIDTAB(95) /34./
C
C-----START POINT-----------------------------------------------------
C
C
C     **************************************************************
C     **    STEP 1 - SUM UP THE LENGTH OF THE STRING (IN "DOTS")  **
C     **************************************************************
C
      SUM=0.
      DO100I=1,NCTEXT
      ICTEMP=ICTEXT(I)
      IC=ICTEMP(1:1)
      CALL DPCOAN(IC,IVALUE)
CCCCC THE FOLLOWING LINE WAS FIXED   APRIL 1992
CCCCC IF(IVALUE.LT.32..OR.IIVALUE.GT.126)GOTO100
      IF(IVALUE.LT.32.OR.IVALUE.GT.126)GOTO100
      IVALUE=IVALUE-31
      SUM=SUM+WIDTAB(IVALUE)
 100  CONTINUE
C
C     **************************************************************
C     **    STEP 2 - CONVERT DOTS TO DATAPLOT PERCENT UNITS       **
C     **************************************************************
C
      PLEC=100.*(SUM/ANUMPP)
      PLECG=PLEC
C
C     **************************************************************
C     **    RETURN                                                **
C     **************************************************************
C
      RETURN
      END
      SUBROUTINE QUICH7(ICTEXT,NCTEXT,PLEC,PLECG,ANUMPP)
C
C     PURPOSE--FOR THE QMS GRAPHICS DEVICE,
C              FOR THE "998" (COMPLEX ROMAN BOLD FONT)
C              15 POINT PROPORTIONAL FONT (NOTE: THIS IS AN NBS MODIFIED
C              VERSION OF THE 328 FONT.  IT WILL NOT BE VALID FOR
C              OTHER SITES!!!!!!
C              AND FOR THE HORIZONTAL DIRECTION,
C              DETERMINE THE LENGTH OF THE TEXT STRING IN THE
C              CHARACTER VECTOR ICTEXT(.),
C              WHICH CONSISTS OF NTEXT CHARACTERS.
C     NOTE--THE LENGTH IS IN STANDARDIZED COORDINATES
C           THAT IS, 0.0 TO 100.0
C
C     WRITTEN BY--ALAN HECKERT
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2899
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONCTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--89.2
C     ORIGINAL VERSION--JANUARY   1989.
C     UPDATED         --APRIL     1992. IIVALUE TO IVALUE
C
C-----NON-COMMON VARIABLES (GRAPHICS)-------------------------------------------
C
      CHARACTER*4 ICTEXT
      CHARACTER*4 ICTEMP
      CHARACTER*1 IC
C
      DIMENSION ICTEXT(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOGR.INC'
      INCLUDE 'DPCOBE.INC'
      INCLUDE 'DPCODV.INC'
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C     WIDTH TABLE, NOTE THAT ASCII CHARACTER 1-31 ARE CONTROL
C     CHARACTERS WITH ZERO WIDTH, CHARACTERS 127-255 ARE UNDEFINED.
C     THERFORE TABLE GOES FROM 32 TO 126.
C
      DIMENSION WIDTAB(95)
C
      DATA WIDTAB( 1) /35./
      DATA WIDTAB( 2) /24./
      DATA WIDTAB( 3) /32./
      DATA WIDTAB( 4) /41./
      DATA WIDTAB( 5) /32./
      DATA WIDTAB( 6) /50./
      DATA WIDTAB( 7) /52./
      DATA WIDTAB( 8) /20./
      DATA WIDTAB( 9) /27./
      DATA WIDTAB(10) /27./
      DATA WIDTAB(11) /32./
      DATA WIDTAB(12) /38./
      DATA WIDTAB(13) /25./
      DATA WIDTAB(14) /23./
      DATA WIDTAB(15) /23./
      DATA WIDTAB(16) /28./
      DATA WIDTAB(17) /45./
      DATA WIDTAB(18) /45./
      DATA WIDTAB(19) /45./
      DATA WIDTAB(20) /45./
      DATA WIDTAB(21) /45./
      DATA WIDTAB(22) /45./
      DATA WIDTAB(23) /45./
      DATA WIDTAB(24) /45./
      DATA WIDTAB(25) /45./
      DATA WIDTAB(26) /45./
      DATA WIDTAB(27) /25./
      DATA WIDTAB(28) /25./
      DATA WIDTAB(29) /38./
      DATA WIDTAB(30) /36./
      DATA WIDTAB(31) /38./
      DATA WIDTAB(32) /32./
      DATA WIDTAB(33) /43./
      DATA WIDTAB(34) /51./
      DATA WIDTAB(35) /48./
      DATA WIDTAB(36) /42./
      DATA WIDTAB(37) /49./
      DATA WIDTAB(38) /47./
      DATA WIDTAB(39) /46./
      DATA WIDTAB(40) /48./
      DATA WIDTAB(41) /52./
      DATA WIDTAB(42) /27./
      DATA WIDTAB(43) /40./
      DATA WIDTAB(44) /55./
      DATA WIDTAB(45) /44./
      DATA WIDTAB(46) /63./
      DATA WIDTAB(47) /53./
      DATA WIDTAB(48) /48./
      DATA WIDTAB(49) /45./
      DATA WIDTAB(50) /54./
      DATA WIDTAB(51) /53./
      DATA WIDTAB(52) /40./
      DATA WIDTAB(53) /45./
      DATA WIDTAB(54) /52./
      DATA WIDTAB(55) /49./
      DATA WIDTAB(56) /77./
      DATA WIDTAB(57) /57./
      DATA WIDTAB(58) /56./
      DATA WIDTAB(59) /42./
      DATA WIDTAB(60) /26./
      DATA WIDTAB(61) /28./
      DATA WIDTAB(62) /26./
      DATA WIDTAB(63) /33./
      DATA WIDTAB(64) /50./
      DATA WIDTAB(65) /36./
      DATA WIDTAB(66) /36./
      DATA WIDTAB(67) /38./
      DATA WIDTAB(68) /31./
      DATA WIDTAB(69) /40./
      DATA WIDTAB(70) /33./
      DATA WIDTAB(71) /28./
      DATA WIDTAB(72) /41./
      DATA WIDTAB(73) /41./
      DATA WIDTAB(74) /22./
      DATA WIDTAB(75) /23./
      DATA WIDTAB(76) /43./
      DATA WIDTAB(77) /20./
      DATA WIDTAB(78) /60./
      DATA WIDTAB(79) /40./
      DATA WIDTAB(80) /34./
      DATA WIDTAB(81) /39./
      DATA WIDTAB(82) /39./
      DATA WIDTAB(83) /30./
      DATA WIDTAB(84) /31./
      DATA WIDTAB(85) /26./
      DATA WIDTAB(86) /40./
      DATA WIDTAB(87) /39./
      DATA WIDTAB(88) /58./
      DATA WIDTAB(89) /41./
      DATA WIDTAB(90) /41./
      DATA WIDTAB(91) /35./
      DATA WIDTAB(92) /30./
      DATA WIDTAB(93) /18./
      DATA WIDTAB(94) /30./
      DATA WIDTAB(95) /34./
C
C-----START POINT-----------------------------------------------------
C
C
C     **************************************************************
C     **    STEP 1 - SUM UP THE LENGTH OF THE STRING (IN "DOTS")  **
C     **************************************************************
C
      SUM=0.
      DO100I=1,NCTEXT
      ICTEMP=ICTEXT(I)
      IC=ICTEMP(1:1)
      CALL DPCOAN(IC,IVALUE)
CCCCC THE FOLLOWING LINE WAS FIXED   APRIL 1992
CCCCC IF(IVALUE.LT.32..OR.IIVALUE.GT.126)GOTO100
      IF(IVALUE.LT.32.OR.IVALUE.GT.126)GOTO100
      IVALUE=IVALUE-31
      SUM=SUM+WIDTAB(IVALUE)
 100  CONTINUE
C
C     **************************************************************
C     **    STEP 2 - CONVERT DOTS TO DATAPLOT PERCENT UNITS       **
C     **************************************************************
C
      PLEC=100.*(SUM/ANUMPP)
      PLECG=PLEC
C
C     **************************************************************
C     **    RETURN                                                **
C     **************************************************************
C
      RETURN
      END
      SUBROUTINE QUICH8(ICTEXT,NCTEXT,PLEC,PLECG,ANUMPP)
C
C     PURPOSE--FOR THE QMS GRAPHICS DEVICE,
C              FOR THE "664" (SPECIAL MATH FONT)
C              10 POINT PROPORTIONAL FONT (TABLE FROM QMS)
C              AND FOR THE HORIZONTAL DIRECTION,
C              DETERMINE THE LENGTH OF THE TEXT STRING IN THE
C              CHARACTER VECTOR ICTEXT(.),
C              WHICH CONSISTS OF NTEXT CHARACTERS.
C     NOTE--THE LENGTH IS IN STANDARDIZED COORDINATES
C           THAT IS, 0.0 TO 100.0
C
C     WRITTEN BY--ALAN HECKERT
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2899
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONCTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--89.2
C     ORIGINAL VERSION--JANUARY   1989.
C     UPDATED         --APRIL     1992. IIVALUE TO IVALUE
C
C-----NON-COMMON VARIABLES (GRAPHICS)-------------------------------------------
C
      CHARACTER*4 ICTEXT
      CHARACTER*4 ICTEMP
      CHARACTER*1 IC
C
      DIMENSION ICTEXT(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOGR.INC'
      INCLUDE 'DPCOBE.INC'
      INCLUDE 'DPCODV.INC'
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C     WIDTH TABLE, NOTE THAT ASCII CHARACTER 1-31 ARE CONTROL
C     CHARACTERS, REPLACED WITH SPECIAL SYMBOLS IN THIS FONT.  WIDTH
C     INCLUDED, BUT NOT YET SURE HOW TO GET DATAPLOT TO USE THESE YET.
C
      DIMENSION WIDTAB(128)
C
      DATA WIDTAB( 1) / 0./
      DATA WIDTAB( 2) /40./
      DATA WIDTAB( 3) /42./
      DATA WIDTAB( 4) /32./
      DATA WIDTAB( 5) /48./
      DATA WIDTAB( 6) /42./
      DATA WIDTAB( 7) /22./
      DATA WIDTAB( 8) /47./
      DATA WIDTAB( 9) /42./
      DATA WIDTAB(10) /42./
      DATA WIDTAB(11) /42./
      DATA WIDTAB(12) /35./
      DATA WIDTAB(13) /20./
      DATA WIDTAB(14) /28./
      DATA WIDTAB(15) /17./
      DATA WIDTAB(16) /10./
      DATA WIDTAB(17) /10./
      DATA WIDTAB(18) /10./
      DATA WIDTAB(19) /10./
      DATA WIDTAB(20) /10./
      DATA WIDTAB(21) /10./
      DATA WIDTAB(22) /10./
      DATA WIDTAB(23) /10./
      DATA WIDTAB(24) /10./
      DATA WIDTAB(25) /10./
      DATA WIDTAB(26) /10./
      DATA WIDTAB(27) /42./
      DATA WIDTAB(28) /42./
      DATA WIDTAB(29) /42./
      DATA WIDTAB(30) /25./
      DATA WIDTAB(31) /48./
      DATA WIDTAB(32) /32./
      DATA WIDTAB(33) /25./
      DATA WIDTAB(34) / 0./
      DATA WIDTAB(35) /15./
      DATA WIDTAB(36) /33./
      DATA WIDTAB(37) / 0./
      DATA WIDTAB(38) / 0./
      DATA WIDTAB(39) / 0./
      DATA WIDTAB(40) /12./
      DATA WIDTAB(41) /42./
      DATA WIDTAB(42) / 0./
      DATA WIDTAB(43) /32./
      DATA WIDTAB(44) /32./
      DATA WIDTAB(45) / 0./
      DATA WIDTAB(46) /32./
      DATA WIDTAB(47) / 0./
      DATA WIDTAB(48) /32./
      DATA WIDTAB(49) /42./
      DATA WIDTAB(50) /42./
      DATA WIDTAB(51) /42./
      DATA WIDTAB(52) /42./
      DATA WIDTAB(53) /42./
      DATA WIDTAB(54) /42./
      DATA WIDTAB(55) /20./
      DATA WIDTAB(56) /20./
      DATA WIDTAB(57) /20./
      DATA WIDTAB(58) /18./
      DATA WIDTAB(59) / 0./
      DATA WIDTAB(60) / 0./
      DATA WIDTAB(61) /42./
      DATA WIDTAB(62) /32./
      DATA WIDTAB(63) /42./
      DATA WIDTAB(64) / 0./
      DATA WIDTAB(65) /38./
      DATA WIDTAB(66) / 0./
      DATA WIDTAB(67) / 0./
      DATA WIDTAB(68) /28./
      DATA WIDTAB(69) /30./
      DATA WIDTAB(70) / 0./
      DATA WIDTAB(71) / 0./
      DATA WIDTAB(72) / 0./
      DATA WIDTAB(73) /32./
      DATA WIDTAB(74) / 0./
      DATA WIDTAB(75) / 0./
      DATA WIDTAB(76) /32./
      DATA WIDTAB(77) / 0./
      DATA WIDTAB(78) / 0./
      DATA WIDTAB(79) /32./
      DATA WIDTAB(80) / 0./
      DATA WIDTAB(81) /33./
      DATA WIDTAB(82) / 0./
      DATA WIDTAB(83) /28./
      DATA WIDTAB(84) / 0./
      DATA WIDTAB(85) /32./
      DATA WIDTAB(86) /33./
      DATA WIDTAB(87) / 0./
      DATA WIDTAB(88) /37./
      DATA WIDTAB(89) /42./
      DATA WIDTAB(90) /20./
      DATA WIDTAB(91) / 3./
      DATA WIDTAB(92) /42./
      DATA WIDTAB(93) /17./
      DATA WIDTAB(94) /32./
      DATA WIDTAB(95) /17./
      DATA WIDTAB(96) /34./
      DATA WIDTAB(97) /12./
      DATA WIDTAB(98) /28./
      DATA WIDTAB(99) /27./
      DATA WIDTAB(100) /27./
      DATA WIDTAB(101) /22./
      DATA WIDTAB(102) /20./
      DATA WIDTAB(103) /20./
      DATA WIDTAB(104) /27./
      DATA WIDTAB(105) /22./
      DATA WIDTAB(106) /15./
      DATA WIDTAB(107) /23./
      DATA WIDTAB(108) /25./
      DATA WIDTAB(109) /28./
      DATA WIDTAB(110) /23./
      DATA WIDTAB(111) /23./
      DATA WIDTAB(112) /23./
      DATA WIDTAB(113) /32./
      DATA WIDTAB(114) /23./
      DATA WIDTAB(115) /32./
      DATA WIDTAB(116) /23./
      DATA WIDTAB(117) /23./
      DATA WIDTAB(118) /28./
      DATA WIDTAB(119) /25./
      DATA WIDTAB(120) /28./
      DATA WIDTAB(121) /28./
      DATA WIDTAB(122) /23./
      DATA WIDTAB(123) /32./
      DATA WIDTAB(124) /17./
      DATA WIDTAB(125) /10./
      DATA WIDTAB(126) /17./
      DATA WIDTAB(127) /17./
      DATA WIDTAB(128) / 0./
C
C-----START POINT-----------------------------------------------------
C
C
C     **************************************************************
C     **    STEP 1 - SUM UP THE LENGTH OF THE STRING (IN "DOTS")  **
C     **************************************************************
C
      SUM=0.
      DO100I=1,NCTEXT
      ICTEMP=ICTEXT(I)
      IC=ICTEMP(1:1)
      CALL DPCOAN(IC,IVALUE)
CCCCC THE FOLLOWING LINE WAS FIXED   APRIL 1992
CCCCC IF(IVALUE.LT.32..OR.IIVALUE.GT.126)GOTO100
      IF(IVALUE.LT.32.OR.IVALUE.GT.126)GOTO100
      IVALUE=IVALUE+1
      SUM=SUM+WIDTAB(IVALUE)
 100  CONTINUE
C
C     **************************************************************
C     **    STEP 2 - CONVERT DOTS TO DATAPLOT PERCENT UNITS       **
C     **************************************************************
C
      PLEC=100.*(SUM/ANUMPP)
      PLECG=PLEC
C
C     **************************************************************
C     **    RETURN                                                **
C     **************************************************************
C
      RETURN
      END
      SUBROUTINE QUICPT(PX1,PY1,IX1,IY1,ISUBN0)
C
C     THIS ROUTINE IS A MODIFIED VERSION OF GRTRSD.  IT IS USED
C     ONLY BY THE "QUIC" DEVICES (QMS LASER PRINTER).
C     QUICPT CONVERTS FROM DATAPLOT
C     UNITS TO DEVICE INTEGER UNITS, BUT IT ALSO APPLIES "WINDOW"
C     TRANSFORMATIONS NEEDED BY THE "MULTI-PLOT" AND "WINDOW
C     COORDINATE" COMMANDS.  THE QUIC COORDINATES NEED TO BE TRANSLATED
C     TO INCHES IN THE FORM (XXXXX) WHERE THERE IS AN IMPLIED DECIMAL
C     POINT BETWEEN THE SECOND AND THIRD "X".
C
C     QUIC USES 300 DOT PER INCH RESOLUTION.  THE DIMENSIONS OF THE
C     PAGE ARE DETERMINED BY USING (PICTURE POINTS/DOTS PER INCH).
C
C     PURPOSE--TRANSLATE THE STANDARDIZED (0.0 TO 100.0) COORDINATES (PX1,PY1)
C              INTO (INTEGER PICTURE POINT) DEVICE COORDINATES (AX1,AY1)
C     ISUBN0 = NAME OF SUBROUTINE WHICH CALLED GRWRST.
C              (AND THEREBY HAVE WALKBACK INFORMATION).
C     NOTE--THE ONLY VARIABLES IN THE    PLOT CONTROL COMMON
C           THAT ARE USED HEREIN ARE THE ONES IN /RWIND/
C
C     WRITTEN BY--ALAN HECKERT
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2899
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--88.6
C     ORIGINAL VERSION--JANUARY   1989.
C
C-----NON-COMMON VARIABLES (GRAPHICS)-------------------------------------------
C
      CHARACTER*4 ISUBN0
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOPA.INC'
      INCLUDE 'DPCOPC.INC'
      INCLUDE 'DPCOGR.INC'
      INCLUDE 'DPCOBE.INC'
      INCLUDE 'DPCODV.INC'
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      IERRG4='NO'
C
      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'ICPT')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF QUICPT--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)ISUBN0
   52 FORMAT('ISUBN0 (NAME OF THE CALLING SUBROUTINE) = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)IMANUF,IMODEL
   53 FORMAT('IMANUF,IMODEL = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,54)NUMHPP,NUMVPP
   54 FORMAT('NUMHPP,NUMVPP = ',I8,I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,55)ANUMHP,ANUMVP
   55 FORMAT('ANUMHP,ANUMVP = ',E15.7,E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,56)PX1,PY1
   56 FORMAT('PX1,PY1 = ',E15.7,E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,57)IOFFSH,IOFFSV
   57 FORMAT('IOFFSH,IOFFSV = ',I10,I10)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,61)PWXMIN,PWXMAX,PWYMIN,PWYMAX
   61 FORMAT('PWXMIN,PWXMAX,PWYMIN,PWYMAX = ',4E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,69)IBUGG4
   69 FORMAT('IBUGG4 = ',A4)
      CALL DPWRST('XXX','BUG ')
   90 CONTINUE
C
C              **************************************
C              **  STEP 0--                        **
C              **  DETERMINE THE DIMENSION OF THE  **
C              **  IN INCHES                       **
C              **************************************
C
      DOTPPI=QUIPPI
      XPAGE=ANUMHP/DOTPPI
      YPAGE=ANUMVP/DOTPPI
C
C               *************************************
C               **  STEP 1--                       **
C               **  CARRY OUT THE TRANSFORMATION.  **
C               *************************************
C
C  NOTE: QMS POSITIONS FROM TOP TO BOTTOM RATHER THAN BOTTOM TO
C        TOP AS DATAPLOT ASSUMES.  CONVERT PWYMIN AND PWYMAX TO
C        REFLECT THIS.
C
      PWYMNT=100.-PWYMAX
      PWYMXT=100.-PWYMIN
C
      AX1=PWXMIN+(PX1/100.0)*(PWXMAX-PWXMIN)
      IF(AX1.LE.0.0)AX1=0.0
      IF(AX1.GE.100.)AX1=100.
C
      AY1=PWYMNT+(PY1/100.0)*(PWYMXT-PWYMNT)
      IF(AY1.LE.0.0)AY1=0.0
      IF(AY1.GE.100.)AY1=100.
C
C              **************************************
C              **  STEP 2--                        **
C              **  CONVERT TO INCH FORMAT "XXXXX"  **
C              **  WITH IMPLIED DECIMAL AFTER      **
C              **  SECOND "X"                      **
C              **  INCH = PAGE SIZE * VALUE/100    **
C              **  QMS FORMAT=INT(INCH*1000.)      **
C              **  NOTE: THE LEFT AND TOP MARGINS  **
C              **        NEED TO BE ADDED IN SINCE **
C              **        THE "ABSOLUTE" POSITIONING**
C              **        COMMANDS ARE FROM PAGE    **
C              **        RATHER THAN MARGIN BOUNDARY*
C              **************************************
C
      ALMRG=1000.*REAL(IOFFSH)/DOTPPI
      ATPMRG=1000.*REAL(IOFFSV)/DOTPPI
      AXINCH=XPAGE*AX1*10.+ALMRG
      AYINCH=YPAGE*AY1*10.+ATPMRG
      IX1=INT(AXINCH+0.5)
      IY1=INT(AYINCH+0.5)
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'ICPT')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF QUICPT--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9015)PX1,PY1
 9015 FORMAT('PX1,PY1   = ',E15.7,E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9018)IX1,IY1
 9018 FORMAT('IX1,IY1   = ',I8,I8)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE QUAFRM(AMAT,MAXROM,MAXCOM,NR1,NC1,X,IWRITE,
     1XQUAD,IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE
C              QUADRATIC FORM OF A VECTOR AND A SQUARE MATRIX,
C              I.E., x'Mx
C              THE RESULT IS A SCALAR.
C     INPUT  ARGUMENTS--AMAT   = THE SINGLE PRECISION MATRIX
C                     --X      = THE SINGLE PRECISION VECTOR
C                     --MAXROM = THE INTEGER ROW DIMENSION OF AMAT
C                     --MAXCOM = THE INTEGER COUMN DIMENSION OF AMAT
C                     --NR1    = THE INTEGER NUMBER OF ROWS OF AMAT
C                     --NC1    = THE INTEGER NUMBER OF COLUMNS OF AMAT
C     OUTPUT ARGUMENTS--XQUAD    = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED SAMPLE QUADRATIC FORM.
C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
C             QUADRATIC FORM.
C     NOTE--THIS ROUTINE ASSUMES THE ERROR CHECKING (FOR EQUAL
C           ROWS AND COLUMNS, MATCHING DIMENSIONS FOR X AND AMAT)
C           IS DONE BT THE CALLING SUBROUTINE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     LANGUAGE--ANSI FORTRAN (1977)
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--98.6
C     ORIGINAL VERSION--JUNE      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
      DOUBLE PRECISION DSUM
      DOUBLE PRECISION DYM1
      DOUBLE PRECISION DYM2
      DOUBLE PRECISION DYM3
C
      DIMENSION AMAT(MAXROM,MAXCOM)
      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='QUAF'
      ISUBN2='RM  '
C
      IERROR='NO'
C
      IF(IBUGA3.EQ.'OFF')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF QUAFRM--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)IBUGA3
   52 FORMAT('IBUGA3 = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)NR1,NC1
   53 FORMAT('NR1, NC1 = ',2I8)
      CALL DPWRST('XXX','BUG ')
      DO55I=1,NR1
      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 QUADRATIC FORM  **
C               ******************************
C
      DSUM=0.0D0
      DO5861I=1,NR1
        DO5863J=1,NC1
          DYM1=AMAT(I,J)
          DYM2=X(I)
          DYM3=X(J)
          DSUM=DSUM+DYM2*DYM1*DYM3
 5863   CONTINUE
 5861 CONTINUE
C
      XQUAD=REAL(DSUM)
C
C               *******************************
C               **  STEP 3--                 **
C               **  WRITE OUT A LINE         **
C               **  OF SUMMARY INFORMATION.  **
C               *******************************
C
      IF(IFEEDB.EQ.'OFF')GOTO890
      IF(IWRITE.EQ.'OFF'.OR.IWRITE.EQ.'NO')GOTO890
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,811)XQUAD
  811 FORMAT('THE QUADRATIC FORM  = ',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 QUAFRM--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IBUGA3,IERROR
 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)NR1,NC1
 9013 FORMAT('NR1,NC1 = ',2I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9015)XQUAD
 9015 FORMAT('XQUAFRM = ',E15.7)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE QUANT(QNT,X,N,IWRITE,XTEMP,MAXNXT,
     1IQUAME,
     1XQUANT,IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE
C              SAMPLE QUANTTILE
C              OF THE DATA IN THE INPUT VECTOR X.
C     INPUT  ARGUMENTS--QNT   = THE SINGLE PRECISION QUANTILE
C                                (BETWEEN 0 AND 1)
C                     --X      = THE SINGLE PRECISION VECTOR OF
C                                (UNSORTED OR SORTED) OBSERVATIONS.
C                     --IQUAME = METHOD:
C                                1. ORDER STATISTIC (IQUAME=ORDE)
C                                2. HERRELL-DAVIS   (IQUAME=HD)
C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR X.
C     OUTPUT ARGUMENTS--XQUANT = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED SAMPLE QUANTTILE.
C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
C             SAMPLE QUANTTILE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--SORT.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--2002.7
C     ORIGINAL VERSION--JULY      2002.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
      CHARACTER*4 IQUAME
C
      CHARACTER*16 IMETH
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
      DIMENSION XTEMP(*)
C
      DOUBLE PRECISION DTEMP1
      DOUBLE PRECISION DTEMP2
      DOUBLE PRECISION WTEMP
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DBETAI
      DOUBLE PRECISION DA
      DOUBLE PRECISION DB
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
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='QUAN'
      ISUBN2='T   '
C
      IERROR='NO'
C
      NI=0
      NIP1=0
C
      ANI=0.0
      A2NI=0.0
      REM=0.0
C
      IF(IBUGA3.EQ.'OFF')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF QUANT--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)IBUGA3
   52 FORMAT('IBUGA3 = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)QNT,N
   53 FORMAT('QNT,N = ',E15.7,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 QUANTTILE      **
C               ******************************
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      AN=N
C
      IF(0.0.LE.QNT.AND.QNT.LE.1.0)GOTO119
      IERROR='YES'
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,111)
  111 FORMAT('***** ERROR IN QUANT--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,112)
  112 FORMAT('      THE INPUT QUANTILE TO BE COMPUTED')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,115)
  115 FORMAT('      MUST BE LARGER THAN 0 AND SMALLER THAN 1.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,116)
  116 FORMAT('      SUCH WAS NOT THE CASE HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,117)QNT
  117 FORMAT('      THE INPUT QUANTILE      = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      GOTO9000
  119 CONTINUE
C
      IF(1.LE.N.AND.N.LE.MAXNXT)GOTO129
      IERROR='YES'
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,121)
  121 FORMAT('***** ERROR IN QUANT--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,122)
  122 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS IN THE VARIABLE')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,124)
  124 FORMAT('      FOR WHICH THE QUANTTILE IS TO BE COMPUTED')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,125)MAXNXT
  125 FORMAT('      MUST BE BETWEEN 1 AND ',I8,' (INCLUSIVELY).')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,126)
  126 FORMAT('      SUCH WAS NOT THE CASE HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,127)N
  127 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS = ',I8,
     1'.')
      CALL DPWRST('XXX','BUG ')
      GOTO9000
  129 CONTINUE
C
      IF(N.EQ.1)GOTO130
      GOTO139
  130 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,131)
  131 FORMAT('***** NON-FATAL DIAGNOSTIC IN QUANT--',
     1'THE THIRD INPUT ARGUMENT (N) HAS THE VALUE 1')
      CALL DPWRST('XXX','BUG ')
      XQUANT=X(1)
      GOTO9000
  139 CONTINUE
C
      HOLD=X(1)
      DO145I=2,N
      IF(X(I).NE.HOLD)GOTO149
  145 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,146)HOLD
  146 FORMAT('***** NON-FATAL DIAGNOSTIC IN QUANT--',
     1'THE INPUT DATA HAS ALL ELEMENTS = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      XQUANT=HOLD
      GOTO9000
  149 CONTINUE
C
  190 CONTINUE
C
C               ***********************************
C               **  STEP 2--                     **
C               **  COMPUTE THE QUANTTILE.      **
C               ***********************************
C
      CALL SORT(X,N,XTEMP)
C
      IF(IQUAME.EQ.'ORDE')THEN
        P=QNT
        ANI=P*(AN+1.0)
        NI=ANI
        A2NI=NI
        REM=ANI-A2NI
        NIP1=NI+1
        IF(NI.LE.1)NI=1
        IF(NI.GE.N)NI=N
        IF(NIP1.LE.1)NIP1=1
        IF(NIP1.GE.N)NIP1=N
        XQUANT=(1.0-REM)*XTEMP(NI)+REM*XTEMP(NIP1)
        IMETH='ORDER STATISTIC'
      ELSEIF(IQUAME.EQ.'HD')THEN
        P=QNT
CCCCC   A=(AN+1.0)*P - 1.0
CCCCC   B=(AN+1.0)*(1.0-P) - 1.0
        A=(AN+1.0)*P
        B=(AN+1.0)*(1.0-P)
        DA=DBLE(A)
        DB=DBLE(B)
        IF(A.EQ.0.0)DA=0.1D-15
        IF(B.EQ.0.0)DB=0.1D-15
C
        DSUM1=0.0D0
        DO500I=1,N
          ATEMP1=REAL(I)/AN
          DTEMP1=DBETAI(DBLE(ATEMP1),DA,DB)
          ATEMP2=REAL(I-1)/AN
          DTEMP2=DBETAI(DBLE(ATEMP2),DA,DB)
          WTEMP=DTEMP1-DTEMP2
          DSUM1=DSUM1 + WTEMP*DBLE(XTEMP(I))
  500   CONTINUE
C
        XQUANT=REAL(DSUM1)
        IMETH='HERRELL-DAVIS'
      ELSE
        P=QNT
        ANI=P*(AN+1.0)
        NI=ANI
        A2NI=NI
        REM=ANI-A2NI
        NIP1=NI+1
        IF(NI.LE.1)NI=1
        IF(NI.GE.N)NI=N
        IF(NIP1.LE.1)NIP1=1
        IF(NIP1.GE.N)NIP1=N
        XQUANT=(1.0-REM)*XTEMP(NI)+REM*XTEMP(NIP1)
        IMETH='ORDER STATISTIC'
      END IF
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)QNT,IMETH,N,XQUANT
  811 FORMAT('THE ',F10.2,'-QUANTTILE (',A16,' METHOD) 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 QUANT--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IBUGA3,IERROR
 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)QNT,N,P
 9013 FORMAT('QNT,N,P = ',E15.7,I8,E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9014)ANI,NI,A2NI,REM,NIP1
 9014 FORMAT('ANI,NI,A2NI,REM,NIP1 = ',E15.7,I8,E15.7,E15.7,I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9015)XQUANT
 9015 FORMAT('XQUANT = ',E15.7)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE QUANSE(QNT,X,N,IWRITE,XTEMP,MAXNXT,
     1IQUASE,
     1XQUASE,IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE STANDARD ERROR OF A
C              SAMPLE QUANTTILE, USING EITHER A MARITZ-JARRETT OR
C              A KERNEL DENSITY BASED METHOD,
C              OF THE DATA IN THE INPUT VECTOR X.
C     INPUT  ARGUMENTS--QNT   = THE SINGLE PRECISION QUANTILE
C                                (BETWEEN 0 AND 1)
C                     --X      = THE SINGLE PRECISION VECTOR OF
C                                (UNSORTED OR SORTED) OBSERVATIONS.
C                     --IQUASE = METHOD:
C                                1. MARITZ-JARRETT  (IQUASE=MJ)
C                                2. KERNEL DENSITY  (IQUASE=KD)
C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR X.
C     OUTPUT ARGUMENTS--XQUASE = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED SAMPLE QUANTTILE.
C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
C             SAMPLE QUANTTILE STANDARD ERROR.
C     OTHER DATAPAC   SUBROUTINES NEEDED--SORT.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--2002.7
C     ORIGINAL VERSION--JULY      2002.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 IWRIT2
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
      CHARACTER*4 IQUAME
      CHARACTER*4 IQUASE
C
      CHARACTER*16 IMETH
C
C---------------------------------------------------------------------
C
      REAL IQRANG
      DIMENSION X(*)
      DIMENSION XTEMP(*)
C
      DOUBLE PRECISION DTEMP1
      DOUBLE PRECISION DTEMP2
      DOUBLE PRECISION WTEMP
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DSUM2
      DOUBLE PRECISION DBETAI
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
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='QUAN'
      ISUBN2='SE  '
C
      IQUAME='ORDE'
      IERROR='NO'
C
      NI=0
      NIP1=0
C
      ANI=0.0
      A2NI=0.0
      REM=0.0
C
      IF(IBUGA3.EQ.'OFF')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF QUANT--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)IBUGA3
   52 FORMAT('IBUGA3 = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)QNT,N
   53 FORMAT('QNT,N = ',E15.7,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 QUANTTILE      **
C               ******************************
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      AN=N
C
      IF(0.0.LT.QNT.AND.QNT.LT.1.0)GOTO119
      IERROR='YES'
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,111)
  111 FORMAT('***** ERROR IN QUANTILE STANDARD ERROR--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,112)
  112 FORMAT('      THE INPUT QUANTILE FOR WHICH THE STANDARD ',
     1       'ERROR IS TO BE COMPUTED')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,115)
  115 FORMAT('      MUST BE LARGER THAN 0 AND SMALLER THAN 1.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,116)
  116 FORMAT('      SUCH WAS NOT THE CASE HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,117)QNT
  117 FORMAT('      THE INPUT QUANTILE      = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      GOTO9000
  119 CONTINUE
C
      IF(1.LE.N.AND.N.LE.MAXNXT)GOTO129
      IERROR='YES'
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,121)
  121 FORMAT('***** ERROR IN QUANTILE STANDARD ERROR--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,122)
  122 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS IN THE VARIABLE')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,124)
  124 FORMAT('      FOR WHICH THE QUANTTILE STANDARD ERROR IS TO BE ',
     1       'COMPUTED')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,125)MAXNXT
  125 FORMAT('      MUST BE BETWEEN 1 AND ',I8,' (INCLUSIVELY).')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,126)
  126 FORMAT('      SUCH WAS NOT THE CASE HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,127)N
  127 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS = ',I8,
     1'.')
      CALL DPWRST('XXX','BUG ')
      GOTO9000
  129 CONTINUE
C
C               *******************************************
C               **  STEP 2--                             **
C               **  COMPUTE THE QUANTTILE STANDARD ERROR **
C               *******************************************
C
CCCCC NOTE: QUANT WILL SORT THE DATA.
      IWRIT2='OFF'
      CALL QUANT(QNT,X,N,IWRIT2,XTEMP,MAXNXT,
     1IQUAME,
     1XQUANT,IBUGA3,IERROR)
C
      IF(IQUASE.EQ.'KERD')THEN
        CALL SORT(X,N,XTEMP)
        IUPP=INT(AN*0.75 + 0.5)
        RIGH1=XTEMP(IUPP)
        ILOW=INT(AN*0.25 + 0.5)
        RIGH2=XTEMP(ILOW)
CCCCC   CALL LOWQUA(X,N,IWRITE,XTEMP,MAXNXT,RIGH1,IBUGG3,IERROR)
CCCCC   CALL UPPQUA(X,N,IWRITE,XTEMP,MAXNXT,RIGH2,IBUGG3,IERROR)
        IQRANG=RIGH1-RIGH2
        ATEMP=AN**0.2
        AH=1.2*IQRANG/ATEMP
        XLOW=XQUANT - AH
        XHIGH=XQUANT + AH
        ICOUNT=0
        DO400I=1,N
          IF(X(I).GE.XLOW .AND. X(I).LE.XHIGH)ICOUNT=ICOUNT+1
  400   CONTINUE
        FX=REAL(ICOUNT)/(2.0*AN*AH)
        XQUASE=AN*AH/(SQRT(AN)*REAL(ICOUNT))
        IMETH='KERNEL DENSITY'
      ELSEIF(IQUASE.EQ.'MJ')THEN
        P=QNT
        IM=INT(P*AN + 0.5)
        IA=IM - 1
        IB=N - IM
C
        DSUM1=0.0D0
        DSUM2=0.0D0
        DO500I=1,N
          ATEMP1=REAL(I)/AN
          DTEMP1=DBETAI(DBLE(ATEMP1),DBLE(IA),DBLE(IB))
          ATEMP2=REAL(I-1)/AN
          DTEMP2=DBETAI(DBLE(ATEMP2),DBLE(IA),DBLE(IB))
          WTEMP=DTEMP1-DTEMP2
          DSUM1=DSUM1 + WTEMP*DBLE(X(I))
          DSUM2=DSUM2 + WTEMP*DBLE(X(I))*DBLE(X(I))
  500   CONTINUE
C
        XQUASE=REAL(DSQRT(DSUM2 - DSUM1*DSUM1))
        IMETH='MARITZ-JARRETT'
      ELSE
        WRITE(ICOUT,600)
  600   FORMAT('***** FROM QUANTILE STANDARD ERROR: METHOD ',A4,' IS ',
     1         'UNKNOWN.')
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      END IF
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)QNT,XQUANT
  811 FORMAT('THE ',F6.2,'-QUANTTILE (ORDER STATISTIC METHOD) = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,813)XQUASE
  813 FORMAT('THE STANDARD ERROR = ',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 QUANT--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IBUGA3,IERROR
 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)QNT,N,P
 9013 FORMAT('QNT,N,P = ',E15.7,I8,E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9014)ANI,NI,A2NI,REM,NIP1
 9014 FORMAT('ANI,NI,A2NI,REM,NIP1 = ',E15.7,I8,E15.7,E15.7,I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9015)XQUASE
 9015 FORMAT('XQUASE = ',E15.7)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
