      SUBROUTINE TAGUCH(X,N,ICASPL,IWRITE,XTAGUC,IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE
C              SAMPLE TAGUCHI SIGNAL-TO-NOISE RATIO
C              OF THE DATA IN THE INPUT VECTOR X.
C              THE SAMPLE TAGUCHI SIGNAL-TO-NOISE RATIO
C              (FOR THE "TARGET IS BEST WITH
C              VARIANCE DEPENDENT ON MEAN" CASE) =
C              10 * LOG10 ( YBAR**2 / S**2)
C              THE SAMPLE TAGUCHI SIGNAL-TO-NOISE RATIO
C              (FOR THE "LARGE IS BEST" CASE) =
C              -10 * LOG10 (AVERAGE SUM OF SQUARED INVERSES)
C              THE SAMPLE TAGUCHI SIGNAL-TO-NOISE RATIO
C              (FOR THE "SMALL IS BEST" CASE) =
C              -10 * LOG10 (AVERAGE SUM OF SQUARED OBSERVATIONS)
C              THE SAMPLE TAGUCHI SIGNAL-TO-NOISE RATIO
C              (FOR THE "TARGET IS BEST WITH
C              VARIANCE NOT DEPENDENT ON MEAN" CASE) =
C              -10 * LOG10 (VARIANCE)
C              THE DENOMINATOR N-1 IS USED IN COMPUTING THE
C              SAMPLE STANDARD DEVIATION.
C              THE SAMPLE STANDARD DEVIATION = SQRT((THE SUM OF THE
C              SQUARED DEVIATIONS ABOUT THE SAMPLE MEAN)/(N-1)).
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF
C                                (UNSORTED OR SORTED) OBSERVATIONS.
C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR X.
C     OUTPUT ARGUMENTS--XTAGUC = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED SAMPLE TAGUCHI SIGNAL-TO-NOISE RATIO.
C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
C             SAMPLE TAGUCHI SIGNAL-TO-NOISE RATIO.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--DSQRT, DABS, DLOG10.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--ELLIOT, JACK G.
C                 STATISTICAL METHODS AND APPLICATIONS
C                 ALLIED SIGNAL, 1987, PAGES 4-3 AND 4-4.
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--88.8
C     ORIGINAL VERSION--AUGUST    1988.
C     UPDATED         --MAY       1989.  SN0, SN+, SN-, SN00
C     UPDATED         --APRIL     1992.  DELETE DRATIO
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 ICASPL
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DN
      DOUBLE PRECISION DX
      DOUBLE PRECISION DSUM
      DOUBLE PRECISION DMEAN
      DOUBLE PRECISION DVAR
      DOUBLE PRECISION DSD
      DOUBLE PRECISION DTERM
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
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='TAGU'
      ISUBN2='CH  '
C
      IERROR='NO'
C
      DMEAN=0.0D0
      DSD=0.0D0
C
      IF(IBUGA3.EQ.'OFF')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF TAGUCH--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)ICASPL,IWRITE,IBUGA3
   52 FORMAT('ICASPL,IWRITE,IBUGA3 = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)N
   53 FORMAT('N = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO55I=1,N
      WRITE(ICOUT,56)I,X(I)
   56 FORMAT('I,X(I) = ',I8,E15.7)
      CALL DPWRST('XXX','BUG ')
   55 CONTINUE
   90 CONTINUE
C
C               **********************************************
C               **  COMPUTE  TAGUCHI SIGNAL-TO-NOISE RATIO  **
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 TAGUCH--')
      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 TAGUCHI SIGNAL-TO-NOISE RATIO IS TO BE ',
     1'COMPUTED')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,115)
  115 FORMAT('      MUST BE 1 OR LARGER.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,116)
  116 FORMAT('      SUCH WAS NOT THE CASE HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,117)N
  117 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8,
     1'.')
      CALL DPWRST('XXX','BUG ')
      GOTO9000
  119 CONTINUE
C
      IF(N.EQ.1)GOTO120
      GOTO129
  120 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,121)
  121 FORMAT('***** NON-FATAL DIAGNOSTIC IN TAGUCH--',
     1'THE 2ND INPUT ARGUMENT (N) HAS THE VALUE 1')
      CALL DPWRST('XXX','BUG ')
      XTAGUC=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 TAGUCH--',
     1'THE FIRST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      XTAGUC=0.0
      GOTO9000
  139 CONTINUE
C
  190 CONTINUE
C
C               **************************************************
C               **  STEP 10--                                   **
C               **  BRANCH TO THE APPROPRIATE SUBCASE           **
C               **************************************************
C
CCCCC THE FOLLOWING 4 LINES WERE FIXED MAY 1989
      IF(ICASPL.EQ.'SN0')GOTO1100
      IF(ICASPL.EQ.'SN+')GOTO1200
      IF(ICASPL.EQ.'SN-')GOTO1300
      IF(ICASPL.EQ.'SN00')GOTO1400
      GOTO1100
C
C               ******************************************************
C               **  STEP 11--                                       **
C               **  COMPUTE THE TAGUCHI SIGNAL-TO-NOISE RATIO       **
C               **  FOR THE "TARGET IS BEST" CASE                   **
C               **  (AND WITH THE VARIANCE CHANGING WITH THE MEAN)  **
C               ******************************************************
C
 1100 CONTINUE
      DN=N
      DSUM=0.0D0
      DO1110I=1,N
      DX=X(I)
      DSUM=DSUM+DX
 1110 CONTINUE
      DMEAN=DSUM/DN
C
      DSUM=0.0D0
      DO1120I=1,N
      DX=X(I)
      DSUM=DSUM+(DX-DMEAN)**2
 1120 CONTINUE
      DVAR=DSUM/(DN-1.0D0)
      DSD=0.0D0
      IF(DVAR.GT.0.0D0)DSD=DSQRT(DVAR)
C
      IF(DSD.EQ.0.0D0)DTERM=(-999.99D0)
      IF(DSD.NE.0.0D0)DTERM=DMEAN/DSD
      IF(DSD.EQ.0.0D0)DTERM2=(-999.99D0)
      IF(DSD.NE.0.0D0)DTERM2=DABS(DTERM)
      IF(DSD.EQ.0.0D0)DTERM3=(-999.99D0)
      IF(DSD.NE.0.0D0)DTERM3=DLOG10(DTERM2)
      XTAGUC=20.0D0*DTERM3
C
      IF(IFEEDB.EQ.'OFF')GOTO1190
      IF(IWRITE.EQ.'OFF')GOTO1190
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1181)
 1181 FORMAT('THE TAGUCHI SIGNAL-TO-NOISE RATIO')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1182)
 1182 FORMAT('(FOR THE "TARGET IS BEST WITH')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1183)
 1183 FORMAT('VARIANCE DEPENDENT ON MEAN" CASE)')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1184)N,XTAGUC
 1184 FORMAT('OF THE ',I8,' OBSERVATIONS = ',E15.7)
      CALL DPWRST('XXX','BUG ')
 1190 CONTINUE
      GOTO9000
C
C               **************************************************
C               **  STEP 12--                                   **
C               **  COMPUTE THE TAGUCHI SIGNAL-TO-NOISE RATIO   **
C               **  FOR THE "LARGE IS BEST" CASE                **
C               **************************************************
C
 1200 CONTINUE
      DN=N
      DSUM=0.0D0
      DO1210I=1,N
      DX=X(I)
      DARG=1.0D0/DX
      DSUM=DSUM+DARG*DARG
 1210 CONTINUE
      DTERM=DSUM/DN
C
      DTERM2=DABS(DTERM)
      DTERM3=DLOG10(DTERM2)
      XTAGUC=(-10.0D0*DTERM3)
C
      IF(IFEEDB.EQ.'OFF')GOTO1290
      IF(IWRITE.EQ.'OFF')GOTO1290
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1281)
 1281 FORMAT('THE TAGUCHI SIGNAL-TO-NOISE RATIO')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1282)
 1282 FORMAT('(FOR THE "LARGE IS BEST" CASE)')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1283)N,XTAGUC
 1283 FORMAT('OF THE ',I8,' OBSERVATIONS = ',E15.7)
      CALL DPWRST('XXX','BUG ')
 1290 CONTINUE
      GOTO9000
C
C               **************************************************
C               **  STEP 13--                                   **
C               **  COMPUTE THE TAGUCHI SIGNAL-TO-NOISE RATIO   **
C               **  FOR THE "SMALL IS BEST" CASE                **
C               **************************************************
C
 1300 CONTINUE
      DN=N
      DSUM=0.0D0
      DO1310I=1,N
      DX=X(I)
      DSUM=DSUM+DX*DX
 1310 CONTINUE
      DTERM=DSUM/DN
C
      DTERM2=DABS(DTERM)
      DTERM3=DLOG10(DTERM2)
      XTAGUC=(-10.0D0*DTERM3)
C
      IF(IFEEDB.EQ.'OFF')GOTO1390
      IF(IWRITE.EQ.'OFF')GOTO1390
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1381)
 1381 FORMAT('THE TAGUCHI SIGNAL-TO-NOISE RATIO')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1382)
 1382 FORMAT('(FOR THE "SMALL IS BEST" CASE)')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1383)N,XTAGUC
 1383 FORMAT('OF THE ',I8,' OBSERVATIONS = ',E15.7)
      CALL DPWRST('XXX','BUG ')
 1390 CONTINUE
      GOTO9000
C
C               **********************************************************
C               **  STEP 14--                                           **
C               **  COMPUTE THE TAGUCHI SIGNAL-TO-NOISE RATIO           **
C               **  FOR THE "TARGET IS BEST" CASE                       **
C               **  (AND WITH THE VARIANCE NOT CHANGING WITH THE MEAN)  **
C               **********************************************************
C
 1400 CONTINUE
      DN=N
      DSUM=0.0D0
      DO1410I=1,N
      DX=X(I)
      DSUM=DSUM+DX
 1410 CONTINUE
      DMEAN=DSUM/DN
C
      DSUM=0.0D0
      DO1420I=1,N
      DX=X(I)
      DSUM=DSUM+(DX-DMEAN)**2
 1420 CONTINUE
      DVAR=DSUM/(DN-1.0D0)
      DSD=0.0D0
      IF(DVAR.GT.0.0D0)DSD=DSQRT(DVAR)
C
      IF(DSD.LE.0.0D0)DTERM=(-999.99D0)
      IF(DSD.GT.0.0D0)DTERM=DSD
      IF(DSD.LE.0.0D0)DTERM2=(-999.99D0)
      IF(DSD.GT.0.0D0)DTERM2=DABS(DTERM)
      IF(DSD.LE.0.0D0)DTERM3=(-999.99D0)
      IF(DSD.GT.0.0D0)DTERM3=DLOG10(DTERM2)
      XTAGUC=(-20.0D0*DTERM3)
C
      IF(IFEEDB.EQ.'OFF')GOTO1490
      IF(IWRITE.EQ.'OFF')GOTO1490
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1481)
 1481 FORMAT('THE TAGUCHI SIGNAL-TO-NOISE RATIO')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1482)
 1482 FORMAT('(FOR THE "TARGET IS BEST WITH')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1483)
 1483 FORMAT('VARIANCE NOT DEPENDENT ON MEAN" CASE)')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1484)N,XTAGUC
 1484 FORMAT('OF THE ',I8,' OBSERVATIONS = ',E15.7)
      CALL DPWRST('XXX','BUG ')
 1490 CONTINUE
      GOTO9000
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'OFF')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF TAGUCH--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)ICASPL,IWRITE,IBUGA3,IERROR
 9012 FORMAT('ICASPL,IWRITE,IBUGA3,IERROR = ',
     1A4,2X,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,DSD
 9014 FORMAT('DMEAN,DSD = ',2D15.7)
      CALL DPWRST('XXX','BUG ')
CCCCC THE FOLLOWING 2 LINES WERE FIXED   APRIL 1992
CCCCC WRITE(ICOUT,9015)DRATIO,DTERM,DTERM2,DTERM3
C9015 FORMAT('DRATIO,DTERM,DTERM2,DTERM3 = ',4E15.7)
CCCCC CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9015)DTERM,DTERM2,DTERM3
 9015 FORMAT('DTERM,DTERM2,DTERM3 = ',3E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9016)XTAGUC
 9016 FORMAT('XTAGUC = ',E15.7)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE TCDF(X,NU,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR STUDENT'S T DISTRIBUTION
C              WITH INTEGER DEGREES OF FREEDOM PARAMETER = NU.
C              THIS DISTRIBUTION IS DEFINED FOR ALL 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                     --NU     = THE INTEGER NUMBER OF DEGREES
C                                OF FREEDOM.
C                                NU 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 STUDENT'S T DISTRIBUTION
C             WITH DEGREES OF FREEDOM PARAMETER = NU.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--NU SHOULD BE A POSITIVE INTEGER VARIABLE.
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     REFERENCES--NATIONAL BUREAU OF STANDARDS APPLIED MATHMATICS
C                 SERIES 55, 1964, PAGE 948, FORMULAE 26.7.3 AND 26.7.4.
C               --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--2, 1970, PAGES 94-129.
C               --FEDERIGHI, EXTENDED TABLES OF THE
C                 PERCENTAGE POINTS OF STUDENT'S
C                 T-DISTRIBUTION, JOURNAL OF THE
C                 AMERICAN STATISTICAL ASSOCIATION,
C                 1959, PAGES 683-688.
C               --OWEN, HANDBOOK OF STATISTICAL TABLES,
C                 1962, PAGES 27-30.
C               --PEARSON AND HARTLEY, BIOMETRIKA TABLES
C                 FOR STATISTICIANS, VOLUME 1, 1954,
C                 PAGES 132-134.
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--82.6
C     ORIGINAL VERSION--JUNE      1972.
C     UPDATED         --MAY       1974.
C     UPDATED         --SEPTEMBER 1975.
C     UPDATED         --NOVEMBER  1975.
C     UPDATED         --OCTOBER   1976.
C     UPDATED         --OCTOBER   1981.
C     UPDATED         --MAY       1982.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX,DNU,PI,C,CSQ,S,SUM,TERM,AI
      DOUBLE PRECISION DSQRT,DATAN
      DOUBLE PRECISION DCONST
      DOUBLE PRECISION TERM1,TERM2,TERM3
      DOUBLE PRECISION DCDFN
      DOUBLE PRECISION DCDF
      DOUBLE PRECISION B11
      DOUBLE PRECISION B21,B22,B23,B24,B25
      DOUBLE PRECISION B31,B32,B33,B34,B35,B36,B37
      DOUBLE PRECISION D1,D3,D5,D7,D9,D11
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      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 NUCUT/1000/
      DATA PI/3.14159265358979D0/
      DATA DCONST/0.3989422804D0/
      DATA B11/0.25D0/
      DATA B21/0.01041666666667D0/
      DATA B22,B23,B24,B25/3.0D0,-7.0D0,-5.0D0,-3.0D0/
      DATA B31/0.00260416666667D0/
      DATA B32,B33,B34,B35,B36,B37/1.0D0,-11.0D0,14.0D0,6.0D0,
     1                            -3.0D0,-15.0D0/
C
C-----START POINT-----------------------------------------------------
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      IF(NU.LE.0)GOTO50
      GOTO90
   50 WRITE(ICOUT,15)
   15 FORMAT('***** FATAL ERROR--THE 2ND INPUT ARGUMENT ',
     1'TO THE TCDF   SUBROUTINE IS NON-POSITIVE *****')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,47)NU
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8   ,'*****')
      CALL DPWRST('XXX','BUG ')
      CDF=0.0
      GOTO9000
   90 CONTINUE
C
C               ****************************************************
C               **  STEP 2--                                      **
C               **  IF NU IS 3 THROUGH 9 AND X IS MORE THAN 3000  **
C               **  STANDARD DEVIATIONS BELOW THE MEAN,           **
C               **  SET CDF = 0.0 AND RETURN.                     **
C               **  IF NU IS 10 OR LARGER AND X IS MORE THAN 150  **
C               **  STANDARD DEVIATIONS BELOW THE MEAN,           **
C               **  SET CDF = 0.0 AND RETURN.                     **
C               **  IF NU IS 3 THROUGH 9 AND X IS MORE THAN 3000  **
C               **  STANDARD DEVIATIONS ABOVE THE MEAN,           **
C               **  SET CDF = 1.0 AND RETURN.                     **
C               **  IF NU IS 10 OR LARGER AND X IS MORE THAN 150  **
C               **  STANDARD DEVIATIONS ABOVE THE MEAN,           **
C               **  SET CDF = 1.0 AND RETURN.                     **
C               ****************************************************
C
      DX=X
      ANU=NU
      DNU=NU
C
      IF(NU.LE.2)GOTO109
      SD=SQRT(ANU/(ANU-2.0))
      Z=X/SD
      IF(NU.LT.10.AND.Z.LT.-3000.0)GOTO107
      IF(NU.GE.10.AND.Z.LT.-150.0)GOTO107
      IF(NU.LT.10.AND.Z.GT.3000.0)GOTO108
      IF(NU.GE.10.AND.Z.GT.150.0)GOTO108
      GOTO109
  107 CDF=0.0
      GOTO9000
  108 CDF=1.0
      GOTO9000
  109 CONTINUE
C
C               **************************************************
C               **  STEP 3--                                    **
C               **  DISTINGUISH BETWEEN THE SMALL AND MODERATE  **
C               **  DEGREES OF FREEDOM CASE VERSUS THE          **
C               **  LARGE DEGREES OF FREEDOM CASE               **
C               **************************************************
C
      IF(NU.LT.NUCUT)GOTO110
      GOTO250
C
C               ************************************************************
C               **  STEP 3.1--                                            **
C               **  TREAT THE SMALL AND MODERATE DEGREES OF FREEDOM CASE  **
C               **  METHOD UTILIZED--EXACT FINITE SUM                     **
C               **  (SEE AMS 55, PAGE 948, FORMULAE 26.7.3 AND 26.7.4).   **
C               ************************************************************
C
  110 CONTINUE
      C=DSQRT(DNU/(DX*DX+DNU))
      CSQ=DNU/(DX*DX+DNU)
      S=DX/DSQRT(DX*DX+DNU)
      IMAX=NU-2
      IEVODD=NU-2*(NU/2)
      IF(IEVODD.EQ.0)GOTO120
C
      SUM=C
      IF(NU.EQ.1)SUM=0.0D0
      TERM=C
      IMIN=3
      GOTO130
C
  120 SUM=1.0D0
      TERM=1.0D0
      IMIN=2
C
  130 IF(IMIN.GT.IMAX)GOTO160
      DO100I=IMIN,IMAX,2
      AI=I
      TERM=TERM*((AI-1.0D0)/AI)*CSQ
      SUM=SUM+TERM
  100 CONTINUE
C
  160 SUM=SUM*S
      IF(IEVODD.EQ.0)GOTO170
      SUM=(2.0D0/PI)*(DATAN(DX/DSQRT(DNU))+SUM)
  170 CDF=0.5D0+SUM/2.0D0
      GOTO9000
C
C               **************************************************************
C               **  STEP 3.2--                                              **
C               **  TREAT THE LARGE DEGREES OF FREEDOM CASE.                **
C               **  METHOD UTILIZED--TRUNCATED ASYMPTOTIC EXPANSION         **
C               **  (SEE JOHNSON AND KOTZ, VOLUME 2, PAGE 102, FORMULA 10;  **
C               **  SEE FEDERIGHI, PAGE 687).                               **
C               **************************************************************
C
  250 CONTINUE
      CALL NORCDF(X,CDFN)
      DCDFN=CDFN
      D1=DX
      D3=DX**3
      D5=DX**5
      D7=DX**7
      D9=DX**9
      D11=DX**11
      TERM1=B11*(D3+D1)/DNU
      TERM2=B21*(B22*D7+B23*D5+B24*D3+B25*D1)/(DNU**2)
      TERM3=B31*(B32*D11+B33*D9+B34*D7+B35*D5+B36*D3+B37*D1)/(DNU**3)
      DCDF=TERM1+TERM2+TERM3
      DCDF=DCDFN-(DCONST*(DEXP(-DX*DX/2.0D0)))*DCDF
      CDF=DCDF
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE TCRUDE( NDIM, MAXPTS, ABSEST, FINEST, IR )
*
*     Crude Monte-Carlo Algorithm for Deak method with
*      weighted results on restart
*
      INTEGER NDIM, MAXPTS, M, K, IR, NPTS
      DOUBLE PRECISION FINEST, ABSEST, X(100), SPMVT, UNI, 
     *     VARSQR, VAREST, VARPRD, FINDIF, FINVAL
      SAVE VAREST
      IF ( IR .LE. 0 ) THEN
         VAREST = 0.0D0
         FINEST = 0.0D0
      ENDIF
      FINVAL = 0.0D0
      VARSQR = 0.0D0
      DO 100 M = 1, MAXPTS
         FINDIF = ( SPMVT(NDIM) - FINVAL )/DBLE(M)
         FINVAL = FINVAL + FINDIF
         VARSQR = DBLE( M - 2 )*VARSQR/DBLE(M) + FINDIF**2 
  100 CONTINUE
      VARPRD = VAREST*VARSQR
      FINEST = FINEST + ( FINVAL - FINEST )/(1.0D0 + VARPRD)
      IF ( VARSQR .GT. 0.0D0 ) VAREST = (1.0D0 + VARPRD)/VARSQR
      ABSEST = 3.0D0*SQRT( VARSQR/( 1.0D0 + VARPRD ) )
C
      RETURN
      END
      FUNCTION TFN(X, FX)
C
C Two versions of algorithm AS 76 are given here; the original with one
C correction incorporated, and AS R55, also amended.   AS R55 requires
C AS 76.   N.B. The accuracy of AS 76 could be increased by using more
C Gaussian quadrature points, or better, by using Hermite integration.
C
C
C     ALGORITHM AS 76  APPL. STATIST. (1974) VOL.23, NO.3
C
C     Calculates the T-function of Owen, using Gaussian quadrature.
C     Incorporates correction AS R30 (vol.28, no.1, 1979)
C
      REAL U(5), R(5)
C
      DATA U /0.0744372, 0.2166977, 0.3397048, 0.4325317, 0.4869533/
      DATA R /0.1477621, 0.1346334, 0.1095432, 0.0747257, 0.0333357/
      DATA NG,    TP,    TV1,     TV2,     TV3,     TV4
     *   /  5, 0.159155, 1.E-35,  15.0,    15.0,   1.E-5 /
      DATA ZERO, QUART, HALF, ONE,  TWO
     *   / 0.0,  0.25,  0.5,  1.0,  2.0 /
C
C     Test for X near zero
C
      IF (ABS(X) .GE. TV1) GO TO 5
      TFN = TP * ATAN(FX)
      RETURN
C
C     Test for large values of abs(X)
C
    5 IF (ABS(X) .GT. TV2) GO TO 10
C
C     Test for FX near zero
C
      IF (ABS(FX) .GE. TV1) GO TO 15
   10 TFN = ZERO
      RETURN
C
C     Test whether abs(FX) is so large that it must be truncated
C
   15 XS = -HALF * X * X
      X2 = FX
      FXS = FX * FX
      IF (LOG(ONE + FXS) - XS * FXS .LT. TV3) GO TO 25
C
C     Computation of truncation point by Newton iteration
C
      X1 = HALF * FX
      FXS = QUART * FXS
   20 RT = FXS + ONE
      X2 = X1 + (XS * FXS + TV3 - LOG(RT)) / (TWO * X1 * (ONE/RT - XS))
      FXS = X2 * X2
      IF (ABS(X2 - X1) .LT. TV4) GO TO 25
      X1 = X2
      GO TO 20
C
C     Gaussian quadrature
C
   25 RT = ZERO
      DO 30 I = 1, NG
      R1 = ONE + FXS * (HALF + U(I))**2
      R2 = ONE + FXS * (HALF - U(I))**2
      RT = RT + R(I) * (EXP(XS * R1) / R1 + EXP(XS * R2) / R2)
   30 CONTINUE
      TFN = RT * X2 * TP
C
      RETURN
      END
      REAL FUNCTION THA(H1, H2, A1, A2)
C
C     AS R55  APPL. STATIST. (1985) VOL.34, NO.1
C
C     A remark on AS 76
C     Incorporating improvements in AS R80 (Appl. Statist. (1989) 
C     vol.38, no.3), and AS R89 (Appl. Statist. (1992) vol.41, no.2).
C
C     Computes T(H1/H2, A1/A2) for any real numbers H1, H2, A1 and A2
C
C     Auxiliary function required: ALNORM (= AS 66) and AS 76
C
      REAL A, A1, A2, G, H, H1, H2, TFN, ABSA, AH, GH, GAH,
     *  TWOPI, LAM, EX, C1, C2,
     *  ZERO, ONE, TWO, PT3, SEVEN, HALF, SIX, QUART
C
      DATA TWOPI /6.2831853/, ZERO /0.0/, ONE /1.0/, TWO /2.0/,
     *   PT3 /0.3/, SEVEN /7.0/, HALF /0.5/, SIX /6.0/, QUART /0.25/
C
      IF (H2 .NE. ZERO) GO TO 1
      THA = ZERO
      RETURN
C
    1 H = H1 / H2
      IF (A2 .EQ. ZERO) GO TO 2
      A = A1 / A2
      IF ((ABS(H) .LT. PT3) .AND. (ABS(A) .GT. SEVEN)) GO TO 6
C
C     Correction AS R89
C
      ABSA = ABS(A)
      IF (ABSA .GT. ONE) GO TO 7
      THA = TFN(H, A)
      RETURN
    7 AH = ABSA * H
CNIST GH = ALNORM(H, .FALSE.)
      CALL NORCDF(H,GH)
CNIST GAH = ALNORM(AH, .FALSE.)
      CALL NORCDF(AH,GAH)
      THA = HALF * (GH + GAH) - GH * GAH - TFN(AH, ONE/ABSA)
      IF (A .LT. ZERO) THA = - THA
      RETURN
C
 2    CONTINUE
CNIST G = ALNORM(H, .FALSE.)
      CALL NORCDF(H,G)
      IF (H .GE. ZERO) GO TO 3
      THA = G / TWO
      GO TO 4
    3 THA = (ONE - G) / TWO
    4 IF (A1 .GE. ZERO) RETURN
      THA = -THA
      RETURN
C
    6 LAM = ABS(A * H)
      EX = EXP(-LAM * LAM / TWO)
CNIST G = ALNORM(LAM, .FALSE.)
      CALL NORCDF(LAM,G)
      C1 = (EX/LAM + SQRT(TWOPI) * (G - HALF)) / (TWOPI)
      C2 = ((LAM * LAM + TWO) * EX/LAM**3 + SQRT(TWOPI) * (G - HALF))
     *       / (SIX * TWOPI)
      AH = ABS(H)
      THA = QUART - C1 * AH + C2 * AH**3
      THA = SIGN(THA, A)
C
      RETURN
      END
      SUBROUTINE TDCDF(DX,NU,DCDF)
C
C     DOUBLE PRECISION VERSION OF TCDF.  CALLED BY SKEW-T DISTRIBUTION.
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR STUDENT'S T DISTRIBUTION
C              WITH INTEGER DEGREES OF FREEDOM PARAMETER = NU.
C              THIS DISTRIBUTION IS DEFINED FOR ALL X.
C              THE PROBABILITY DENSITY FUNCTION IS GIVEN
C              IN THE REFERENCES BELOW.
C     INPUT  ARGUMENTS--DX     = THE DOUBLE PRECISION VALUE AT
C                                WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE NON-NEGATIVE.
C                     --NU     = THE INTEGER NUMBER OF DEGREES
C                                OF FREEDOM.
C                                NU SHOULD BE POSITIVE.
C     OUTPUT ARGUMENTS--DCDF   = THE DOUBLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE CDF FOR THE STUDENT'S T DISTRIBUTION
C             WITH DEGREES OF FREEDOM PARAMETER = NU.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--NU SHOULD BE A POSITIVE INTEGER VARIABLE.
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     REFERENCES--NATIONAL BUREAU OF STANDARDS APPLIED MATHMATICS
C                 SERIES 55, 1964, PAGE 948, FORMULAE 26.7.3 AND 26.7.4.
C               --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--2, 1970, PAGES 94-129.
C               --FEDERIGHI, EXTENDED TABLES OF THE
C                 PERCENTAGE POINTS OF STUDENT'S
C                 T-DISTRIBUTION, JOURNAL OF THE
C                 AMERICAN STATISTICAL ASSOCIATION,
C                 1959, PAGES 683-688.
C               --OWEN, HANDBOOK OF STATISTICAL TABLES,
C                 1962, PAGES 27-30.
C               --PEARSON AND HARTLEY, BIOMETRIKA TABLES
C                 FOR STATISTICIANS, VOLUME 1, 1954,
C                 PAGES 132-134.
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--2003.12
C     ORIGINAL VERSION--DECEMBER  2003.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX,DNU,PI,C,CSQ,S,SUM,TERM,AI
      DOUBLE PRECISION DSQRT,DATAN
      DOUBLE PRECISION DCONST
      DOUBLE PRECISION TERM1,TERM2,TERM3
      DOUBLE PRECISION DCDFN
      DOUBLE PRECISION DCDF
      DOUBLE PRECISION B11
      DOUBLE PRECISION B21,B22,B23,B24,B25
      DOUBLE PRECISION B31,B32,B33,B34,B35,B36,B37
      DOUBLE PRECISION D1,D3,D5,D7,D9,D11
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      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 NUCUT/1000/
      DATA PI/3.14159265358979D0/
      DATA DCONST/0.3989422804D0/
      DATA B11/0.25D0/
      DATA B21/0.01041666666667D0/
      DATA B22,B23,B24,B25/3.0D0,-7.0D0,-5.0D0,-3.0D0/
      DATA B31/0.00260416666667D0/
      DATA B32,B33,B34,B35,B36,B37/1.0D0,-11.0D0,14.0D0,6.0D0,
     1                            -3.0D0,-15.0D0/
C
C-----START POINT-----------------------------------------------------
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      IF(NU.LE.0)THEN
        WRITE(ICOUT,15)
   15   FORMAT('***** FATAL ERROR--THE DEGREES OF FREEDOM PARAMETER ',
     1         'TO THE TDCDF SUBROUTINE IS NON-POSITIVE')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)NU
   47   FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8   ,'*****')
        CALL DPWRST('XXX','BUG ')
        DCDF=0.0D0
        GOTO9000
      ENDIF
C
C               ****************************************************
C               **  STEP 2--                                      **
C               **  IF NU IS 3 THROUGH 9 AND X IS MORE THAN 3000  **
C               **  STANDARD DEVIATIONS BELOW THE MEAN,           **
C               **  SET CDF = 0.0 AND RETURN.                     **
C               **  IF NU IS 10 OR LARGER AND X IS MORE THAN 150  **
C               **  STANDARD DEVIATIONS BELOW THE MEAN,           **
C               **  SET CDF = 0.0 AND RETURN.                     **
C               **  IF NU IS 3 THROUGH 9 AND X IS MORE THAN 3000  **
C               **  STANDARD DEVIATIONS ABOVE THE MEAN,           **
C               **  SET CDF = 1.0 AND RETURN.                     **
C               **  IF NU IS 10 OR LARGER AND X IS MORE THAN 150  **
C               **  STANDARD DEVIATIONS ABOVE THE MEAN,           **
C               **  SET CDF = 1.0 AND RETURN.                     **
C               ****************************************************
C
      ANU=NU
      DNU=NU
C
      IF(NU.LE.2)GOTO109
      SD=SQRT(ANU/(ANU-2.0))
      Z=REAL(DX)/SD
      IF(NU.LT.10.AND.Z.LT.-3000.0)GOTO107
      IF(NU.GE.10.AND.Z.LT.-150.0)GOTO107
      IF(NU.LT.10.AND.Z.GT.3000.0)GOTO108
      IF(NU.GE.10.AND.Z.GT.150.0)GOTO108
      GOTO109
  107 DCDF=0.0D0
      GOTO9000
  108 DCDF=1.0D0
      GOTO9000
  109 CONTINUE
C
C               **************************************************
C               **  STEP 3--                                    **
C               **  DISTINGUISH BETWEEN THE SMALL AND MODERATE  **
C               **  DEGREES OF FREEDOM CASE VERSUS THE          **
C               **  LARGE DEGREES OF FREEDOM CASE               **
C               **************************************************
C
      IF(NU.LT.NUCUT)GOTO110
      GOTO250
C
C               ************************************************************
C               **  STEP 3.1--                                            **
C               **  TREAT THE SMALL AND MODERATE DEGREES OF FREEDOM CASE  **
C               **  METHOD UTILIZED--EXACT FINITE SUM                     **
C               **  (SEE AMS 55, PAGE 948, FORMULAE 26.7.3 AND 26.7.4).   **
C               ************************************************************
C
  110 CONTINUE
      C=DSQRT(DNU/(DX*DX+DNU))
      CSQ=DNU/(DX*DX+DNU)
      S=DX/DSQRT(DX*DX+DNU)
      IMAX=NU-2
      IEVODD=NU-2*(NU/2)
      IF(IEVODD.EQ.0)GOTO120
C
      SUM=C
      IF(NU.EQ.1)SUM=0.0D0
      TERM=C
      IMIN=3
      GOTO130
C
  120 SUM=1.0D0
      TERM=1.0D0
      IMIN=2
C
  130 IF(IMIN.GT.IMAX)GOTO160
      DO100I=IMIN,IMAX,2
      AI=I
      TERM=TERM*((AI-1.0D0)/AI)*CSQ
      SUM=SUM+TERM
  100 CONTINUE
C
  160 SUM=SUM*S
      IF(IEVODD.EQ.0)GOTO170
      SUM=(2.0D0/PI)*(DATAN(DX/DSQRT(DNU))+SUM)
  170 DCDF=0.5D0+SUM/2.0D0
      GOTO9000
C
C               **************************************************************
C               **  STEP 3.2--                                              **
C               **  TREAT THE LARGE DEGREES OF FREEDOM CASE.                **
C               **  METHOD UTILIZED--TRUNCATED ASYMPTOTIC EXPANSION         **
C               **  (SEE JOHNSON AND KOTZ, VOLUME 2, PAGE 102, FORMULA 10;  **
C               **  SEE FEDERIGHI, PAGE 687).                               **
C               **************************************************************
C
  250 CONTINUE
      CALL NODCDF(DX,DCDFN)
      D1=DX
      D3=DX**3
      D5=DX**5
      D7=DX**7
      D9=DX**9
      D11=DX**11
      TERM1=B11*(D3+D1)/DNU
      TERM2=B21*(B22*D7+B23*D5+B24*D3+B25*D1)/(DNU**2)
      TERM3=B31*(B32*D11+B33*D9+B34*D7+B35*D5+B36*D3+B37*D1)/(DNU**3)
      DCDF=TERM1+TERM2+TERM3
      DCDF=DCDFN-(DCONST*(DEXP(-DX*DX/2.0D0)))*DCDF
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE TDPDF(DX,NU,DPDF)
C
C     DOUBLE PRECISION VERSION OF TPDF.  USED BY SKEW T DISTRIBUTION.
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR STUDENT'S T DISTRIBUTION
C              WITH INTEGER DEGREES OF FREEDOM PARAMETER = NU.
C              THIS DISTRIBUTION IS DEFINED FOR ALL X.
C              THE PROBABILITY DENSITY FUNCTION IS GIVEN
C              IN THE REFERENCES BELOW.
C     INPUT  ARGUMENTS--DX     = THE DOUBLE PRECISION VALUE AT
C                                WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                                DX SHOULD BE NON-NEGATIVE.
C                     --NU     = THE INTEGER NUMBER OF DEGREES
C                                OF FREEDOM.
C                                NU SHOULD BE POSITIVE.
C     OUTPUT ARGUMENTS--DPDF   = THE DOUBLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE PDF FOR THE STUDENT'S T DISTRIBUTION
C             WITH DEGREES OF FREEDOM PARAMETER = NU.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--NU SHOULD BE A POSITIVE INTEGER VARIABLE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--DSQRT, DATAN.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--NATIONAL BUREAU OF STANDARDS APPLIED MATHMATICS
C                 SERIES 55, 1964, PAGE 948, FORMULAE 26.7.3 AND 26.7.4.
C               --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--2, 1970, PAGES 94-129.
C               --FEDERIGHI, EXTENDED TABLES OF THE
C                 PERCENTAGE POINTS OF STUDENT'S
C                 T-DISTRIBUTION, JOURNAL OF THE
C                 AMERICAN STATISTICAL ASSOCIATION,
C                 1959, PAGES 683-688.
C               --OWEN, HANDBOOK OF STATISTICAL TABLES,
C                 1962, PAGES 27-30.
C               --PEARSON AND HARTLEY, BIOMETRIKA TABLES
C                 FOR STATISTICIANS, VOLUME 1, 1954,
C                 PAGES 132-134.
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--2003.12
C     ORIGINAL VERSION--DECEMBER  2003.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX,DNU, DPDF
      DOUBLE PRECISION DSQTPI,DRATIO
      DOUBLE PRECISION DCONST,DPOWER
      DOUBLE PRECISION AI
      DOUBLE PRECISION DSQRT
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      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 DSQTPI/1.77245385090552D0/
C
C-----START POINT-----------------------------------------------------
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      IF(NU.LE.0)THEN
        WRITE(ICOUT,115)
  115   FORMAT('***** FATAL ERROR--THE DEGREES OF FREEDOM PARAMETER ',
     1         'TO THE TDPDF SUBROUTINE IS NON-POSITIVE')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,147)NU
  147   FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
        CALL DPWRST('XXX','BUG ')
        DPDF=0.0
      ENDIF
C
C               ****************************************************
C               **  STEP 2--
C               **  COMPUTE THE CONSTANT = 1/(SQRT(NU)*BETA(1/2,NU/2))
C               **  = (1/(SQRT(NU)*SQRT(PI))) * (GAMMA((NU/2)+(1/2))/GAMMA(NU/2)
C               ****************************************************
C
      DNU=NU
C
      DRATIO=1.0D0
      IEVODD=NU-2*(NU/2)
      IMIN=3
      IF(IEVODD.EQ.0)IMIN=2
      IF(NU.LT.IMIN)GOTO250
      DO300I=IMIN,NU,2
      AI=I
      DRATIO=((AI-1.0D0)/AI)*DRATIO
  300 CONTINUE
  250 CONTINUE
      DRATIO=DRATIO*DNU
      IF(IEVODD.EQ.0)GOTO260
      DRATIO=DRATIO/DSQTPI
      GOTO400
  260 CONTINUE
      DRATIO=DRATIO*DSQTPI/2.0D0
  400 CONTINUE
C
      DCONST=DRATIO/(DSQTPI*DSQRT(DNU))
C
C               ************************************
C               **  STEP 3--                      **
C               **  COMPUTE THE DENSITY FUNCTION  **
C               ************************************
C
      DPOWER=-(DNU+1.0D0)/2.0D0
      DPDF=DCONST*((1.0D0+DX*DX/DNU)**DPOWER)
      GOTO9000
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE TKTRBY(IBHIX,IBLOX,IBHIY,IBLOY,IFACTO,IX,IY)
C
C     PURPOSE--TRANSLATE 4 BYTES--
C              5 HIGH-ORDER BITS OF X
C              5 LOW -ORDER BITS OF X
C              5 HIGH-ORDER BITS OF Y
C              5 LOW -ORDER BITS OF Y
C              INTO 2 INTEGER TEKTRONIX COORDINATES
C              (0 TO 1023)
C
C     REFERENCE--TEKTRONIX 4014 TERMINAL USERS GUIDE, PAGE 3-31
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--83.6
C     ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MAY       1983.
C
C-----NON-COMMON VARIABLES (GRAPHICS)-------------------------------------------
C
      CHARACTER*1 IBHIX
      CHARACTER*1 IBLOX
      CHARACTER*1 IBHIY
      CHARACTER*1 IBLOY
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOGR.INC'
      INCLUDE 'DPCOBE.INC'
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      IERRG4='NO'
C
      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'TRBY')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF TKTRBY--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,61)IBHIX
   61 FORMAT('IBHIX = ',A1)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,62)IBLOX
   62 FORMAT('IBLOX = ',A1)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,63)IBHIY
   63 FORMAT('IBHIY = ',A1)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,64)IBLOY
   64 FORMAT('IBLOY = ',A1)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,65)IFACTO
   65 FORMAT('IFACTO = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,69)IBUGG4,ISUBG4,IERRG4
   69 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
   90 CONTINUE
C
CCCCC IHIX=ICHAR(IBHIX)
      CALL DPCOAN(IBHIX,IHIX)
CCCCC ILOX=ICHAR(IBLOX)
      CALL DPCOAN(IBLOX,ILOX)
CCCCC IHIY=ICHAR(IBHIY)
      CALL DPCOAN(IBHIY,IHIY)
CCCCC ILOY=ICHAR(IBLOY)
      CALL DPCOAN(IBLOY,ILOY)
C
      IHIX2=MOD(IHIX,32)
      ILOX2=MOD(ILOX,32)
      IHIY2=MOD(IHIY,32)
      ILOY2=MOD(ILOY,32)
C
      IHIX3=IHIX2*32
      ILOX3=ILOX2
      IHIY3=IHIY2*32
      ILOY3=ILOY2
C
      IX3=IHIX3+ILOX3
      IY3=IHIY3+ILOY3
C
      IX4=IX3*4
      IY4=IY3*4
C
      IX=IX4/IFACTO
      IY=IY4/IFACTO
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'TRBY')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF TKTRBY--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9021)IBHIX
 9021 FORMAT('IBHIX = ',A1)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9022)IBLOX
 9022 FORMAT('IBLOX = ',A1)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9023)IBHIY
 9023 FORMAT('IBHIY = ',A1)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9024)IBLOY
 9024 FORMAT('IBLOY = ',A1)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9025)IFACTO
 9025 FORMAT('IFACTO = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9031)IHIX,ILOX,IHIY,ILOY
 9031 FORMAT('IHIX,ILOX,IHIY,ILOY = ',4I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9032)IHIX2,ILOX2,IHIY2,ILOY2
 9032 FORMAT('IHIX2,ILOX2,IHIY2,ILOY2 = ',4I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9033)IHIX3,ILOX3,IHIY3,ILOY3
 9033 FORMAT('IHIX3,ILOX3,IHIY3,ILOY3 = ',4I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9034)IX3,IY3
 9034 FORMAT('IX3,IY3 = ',2I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9035)IX4,IY4
 9035 FORMAT('IX4,IY4 = ',2I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9036)IX,IY
 9036 FORMAT('IX,IY = ',2I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9039)IBUGG4,ISUBG4,IERRG4
 9039 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE TKTRPT(IXC,IYC,IFACTO,ICSTR,NCSTR,ISUBN0)
C
C     PURPOSE--TRANSLATE AN INTEGER PAIR OF COORDINATES
C              INTO A PACKED CHARACTER REPRESENTATION
C              THAT WILL BE UNDERSTOOD BY A TEKTRONIX
C              GRAPHICS DEVICE.
C     NOTE--THE RESULTING PACKED WORDS
C           WILL BE PLACED IN SPECIFIC ELEMENTS
C           OF THE CHARACTER*130 VARIABLE ICSTR(.:.).
C           THE VALUE OF THE VARIABLE    NCSTR
C           REPRESENTS THE NUMBER OF ELEMENTS IN ICSTR(.:.)
C           THAT HAVE ALREADY BEEN FILLED.
C           THE RESULTRING CHARACTER STING WILL GO INTO
C           THE NEXT AVAILABLE ELEMENTS OF ICSTR(.:.)
C           AND THE VALUE OF    NCSTR    WILL BE
C           UPDATED ACCORDINGLY.
C     DANGER--NCSTR IS BOTH AN INPUT ARGUMENT
C             AND AN OUTPUT ARGUMENT OF THIS SUBROUTINE.
C     NOTE--ISUBN0 = NAME OF SUBROUTINE WHICH CALLED TKTRPT
C                    (AND THEREBY HAVE WALKBACK INFORMATION).
C     REFERENCE--4105 PROGRAMMER'S REFERENCE MANUAL
C                PAGE 5-4
C     REFERENCE--MAHLON KELLY, BYTE, OCTOBER 1983,
C                PAGES 439 TO 442.
C
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 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--83.6
C     ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MAY       1983.
C
C-----NON-COMMON VARIABLES (GRAPHICS)-------------------------------------------
C
      CHARACTER*4 ISUBN0
C
      CHARACTER*130 ICSTR
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOGR.INC'
      INCLUDE 'DPCOBE.INC'
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----DATA STATEMENTS----------------------------------------
C
      DATA K2/4/
      DATA K5/32/
      DATA K7/128/
C
C-----START POINT-----------------------------------------------------
C
      IERRG4='NO'
C
      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'TRPT')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF TKTRPT--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)ISUBN0
   52 FORMAT('ISUBN0 (NAME OF THE CALLING SUBROUTINE) = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)IXC,IYC
   53 FORMAT('IXC,IYC = ',2I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,54)IFACTO
   54 FORMAT('IFACTO = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,55)K2,K5,K7
   55 FORMAT('K2,K5,K7 = ',3I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,56)IGUNIT
   56 FORMAT('IGUNIT = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,63)NCSTR
   63 FORMAT('NCSTR = ',I8)
      CALL DPWRST('XXX','BUG ')
      IF(NCSTR.LE.0)GOTO67
      DO65I=1,NCSTR
CCCCC IASCNE=ICHAR(ICSTR(I:I))
      CALL DPCOAN(ICSTR(I:I),IASCNE)
      WRITE(ICOUT,66)I,ICSTR(I:I),IASCNE
   66 FORMAT('I,ICSTR(I:I),IASCNE = ',I8,2X,A1,I8)
      CALL DPWRST('XXX','BUG ')
   65 CONTINUE
   67 CONTINUE
      WRITE(ICOUT,69)IBUGG4,ISUBG4,IERRG4
   69 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
   90 CONTINUE
C
      IVX=IXC*IFACTO
      IVY=IYC*IFACTO
      IF(IVX.LT.0)IVX=0
      IF(IVY.LT.0)IVY=0
C
C               *******************************************************
C               **  STEP 1--                                         **
C               **  FORM THE HIGH Y 7-BIT BYTE--                     **
C               **  SHIFT THE Y VALUE TO THE RIGHT 7 PLACES;         **
C               **  THEN KEEP ONLY THE RIGHT 5 PLACES;               **
C               **  THEN PLACE A 1 IN THE 6TH PLACE FROM THE RIGHT.  **
C               *******************************************************
C
      NCSTR=NCSTR+1
      IBYTE1=MOD(IVY/K7,K5)+32
CCCCC ICSTR(NCSTR:NCSTR)=CHAR(IBYTE1)
      CALL DPCONA(IBYTE1,ICSTR(NCSTR:NCSTR))
C
C               ***********************************************************
C               **  STEP 2--                                             **
C               **  FORM THE EXTRA 7-BIT BYTE--                          **
C               **  KEEP ONLY THE RIGHT 2 PLACES OF THE Y VALUE;         **
C               **  THEN SHIFT THESE 2 PLACES TO THE LEFT  2 PLACES;     **
C               **  KEEP ONLY THE RIGHT 2 PLACES OF THE X VALUE;         **
C               **  PLACE A 1 IN THE 6TH AND 7TH PLACES FFOM THE RIGHT.  **
C               **  THEN MERGE THE 2 TOGETHER.                         **
C               ***********************************************************
C
      NCSTR=NCSTR+1
      IBYTE2=MOD(IVY,K2)*K2+MOD(IVX,K2)+96
CCCCC ICSTR(NCSTR:NCSTR)=CHAR(IBYTE2)
      CALL DPCONA(IBYTE2,ICSTR(NCSTR:NCSTR))
C
C               ****************************************************************
C               **  STEP 3--                                                  **
C               **  FORM THE LOW Y 7-BIT BYTE--                               **
C               **  SHIFT THE Y VALUE TO THE RIGHT 2 PLACES;                  **
C               **  THEN KEEP ONLY THE RIGHT 5 PLACES;                        **
C               **  THEN PLACE A 1 IN THE 6TH AND 7TH PLACES FROM THE RIGHT.  **
C               ****************************************************************
C
      NCSTR=NCSTR+1
      IBYTE3=MOD(IVY/K2,K5)+96
CCCCC ICSTR(NCSTR:NCSTR)=CHAR(IBYTE3)
      CALL DPCONA(IBYTE3,ICSTR(NCSTR:NCSTR))
C
C               *******************************************************
C               **  STEP 4--                                         **
C               **  FORM THE HIGH X 7-BIT BYTE--                     **
C               **  SHIFT THE X VALUE TO THE RIGHT 7 PLACES;         **
C               **  THEN KEEP ONLY THE RIGHT 5 PLACES;               **
C               **  THEN PLACE A 1 IN THE 6TH PLACE FROM THE RIGHT.  **
C               *******************************************************
C
      NCSTR=NCSTR+1
      IBYTE4=MOD(IVX/K7,K5)+32
CCCCC ICSTR(NCSTR:NCSTR)=CHAR(IBYTE4)
      CALL DPCONA(IBYTE4,ICSTR(NCSTR:NCSTR))
C
C               *******************************************************
C               **  STEP 5--                                         **
C               **  FORM THE LOW X 7-BIT BYTE--                      **
C               **  SHIFT THE X VALUE TO THE RIGHT 2 PLACES;         **
C               **  THEN KEEP ONLY THE RIGHT 5 PLACES;               **
C               **  THEN PLACE A 1 IN THE 6TH PLACE FROM THE RIGHT.  **
C               *******************************************************
C
      NCSTR=NCSTR+1
      IBYTE5=MOD(IVX/K2,K5)+64
CCCCC ICSTR(NCSTR:NCSTR)=CHAR(IBYTE5)
      CALL DPCONA(IBYTE5,ICSTR(NCSTR:NCSTR))
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'TRPT')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF TKTRPT--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IXC,IYC
 9012 FORMAT('IXC,IYC = ',2I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)IVX,IVY
 9013 FORMAT('IVX,IVY = ',2I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9014)IFACTO
 9014 FORMAT('IFACTO = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9015)K2,K5,K7
 9015 FORMAT('K2,K5,K7 = ',3I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9016)IGUNIT
 9016 FORMAT('IGUNIT = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9017)IBYTE1,IBYTE2,IBYTE3,IBYTE4,IBYTE5
 9017 FORMAT('IBYTE1,IBYTE2,IBYTE3,IBYTE4,IBYTE5 = ',5I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9023)NCSTR
 9023 FORMAT('NCSTR = ',I8)
      CALL DPWRST('XXX','BUG ')
      IF(NCSTR.LE.0)GOTO9027
      DO9025I=1,NCSTR
CCCCC IASCNE=ICHAR(ICSTR(I:I))
      CALL DPCOAN(ICSTR(I:I),IASCNE)
      WRITE(ICOUT,9026)I,ICSTR(I:I),IASCNE
 9026 FORMAT('I,ICSTR(I:I),IASCNE = ',I8,2X,A1,I8)
      CALL DPWRST('XXX','BUG ')
 9025 CONTINUE
 9027 CONTINUE
      WRITE(ICOUT,9029)IBUGG4,ISUBG4,IERRG4
 9029 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE TNRCDF(X,A,B,U,SD,CDF)
C
C     NOTE--TRUNCATED-NORMAL PDF IS:
C              TNRPDF(X,A,B,U,S) = (1/S)*NORPDF((X-U)/S)/
C                                    [NORCDF((B-U)/S)-NORCDF((A-U)/S)]
C           THE TNRCDF IS DEFINED FOR A<=X<=B
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/9
C     ORIGINAL VERSION--SEPTEMBER 1995.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
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
      IF(A.EQ.-99.9)THEN
        ALL=-99.9
        AUL=B
      ELSEIF(B.EQ.-99.9)THEN
        ALL=A
        AUL=-99.9
      ELSEIF(A.LE.B)THEN
        ALL=A
        AUL=B
      ELSE
        ALL=B
        AUL=A
      ENDIF
C
      IF(X.LE.ALL .AND. ALL.NE.-99.9)THEN
        CDF=0.0
        GOTO9999
      ELSEIF(X.GE.AUL .AND. AUL.NE.-99.9)THEN
        CDF=1.0
        GOTO9999
      ENDIF 
C
      CALL NORCDF((X-U)/SD,TERM1)
C
      IF(AUL.EQ.-99.9)THEN
        TERM2=1.0
      ELSE
        CALL NORCDF((ALL-U)/SD,TERM2)
      ENDIF
      IF(ALL.EQ.-99.9)THEN
        TERM3=0.0
        TERM4=0.0
      ELSE
        CALL NORCDF((AUL-U)/SD,TERM3)
        CALL NORCDF((ALL-U)/SD,TERM4)
      ENDIF
      CONST=1.0/(TERM3-TERM2)
C
      CDF=CONST*(TERM1 - TERM4)
C
      GOTO9999
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE TNRPDF(X,A,B,U,SD,PDF)
C
C     NOTE--TRUNCATED-NORMAL PDF IS:
C              TNRPDF(X,A,B,U,S) = (1/S)*NORPDF((X-U)/S)/
C                                    [NORCDF((B-U)/S)-NORCDF((A-U)/S)]
C           THE TNRPDF IS DEFINED FOR A<=X<=B
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
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
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
      IF(A.EQ.-99.9)THEN
        ALL=-99.9
        AUL=B
      ELSEIF(B.EQ.-99.9)THEN
        ALL=A
        AUL=-99.9
      ELSEIF(A.LE.B)THEN
        ALL=A
        AUL=B
      ELSE
        ALL=B
        AUL=A
      ENDIF
C
      IF((X.LT.ALL.AND.ALL.NE.-99.9) .OR.
     1   (X.GT.AUL.AND.AUL.NE.-99.9))THEN
        WRITE(ICOUT,4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)A
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,48)B
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
    4 FORMAT('***** NON-FATAL DIAGNOSTIC--THE FIRST  INPUT ARGUMENT',
     1' TO THE TNRPDF ROUTINE')
    5 FORMAT('      OUTSIDE THE ALLOWABLE (A,B) INTERVAL. *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
   47 FORMAT('***** THE VALUE OF A IS ',E15.8,' *****')
   48 FORMAT('***** THE VALUE OF B IS ',E15.8,' *****')
C
      CALL NORPDF((X-U)/SD,TERM1)
      TERM1=(1/SD)*TERM1
C
      IF(AUL.EQ.-99.9)THEN
        TERM2=1.0
      ELSE
        CALL NORCDF((ALL-U)/SD,TERM2)
      ENDIF
      IF(ALL.EQ.-99.9)THEN
        TERM3=0.0
      ELSE
        CALL NORCDF((AUL-U)/SD,TERM3)
      ENDIF
C
      PDF=TERM1/(TERM3-TERM2)
C
      GOTO9999
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE TNRPPF(P,A,B,U,SD,PPF)
C
C     PURPOSE   --PERCENT POINT FUNCTION FOR THE TRUNCATED NORMAL
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--95/9
C     ORIGINAL VERSION--SEPTEMBER 1995.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DATA DPI /3.14159265358979D0/
      DATA EPS /0.00001/
      DATA SIG /1.0E-6/
      DATA ZERO /0./
      DATA MAXIT /10000/
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(SD.LE.0.0)GOTO70
      GOTO90
   50 WRITE(ICOUT,1)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)P
      CALL DPWRST('XXX','BUG ')
      PPF=0.0
      RETURN
   70 WRITE(ICOUT,35)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)SD
      CALL DPWRST('XXX','BUG ')
      PPF=0.0
      GOTO9999
C
    1 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ',
     1' TNRPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL.')
   35 FORMAT('***** FATAL ERROR--THE FIFTH INPUT ARGUMENT TO THE ',
     1' TNRPPF SUBROUTINE IS NEGATIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
   90 CONTINUE
C
C  FIND BRACKETING INTERVAL.
C  AFTER SUCCESSFULLY FIND BRACKETING INTERVAL, THEN SWITCH TO 
C  MORE EFFICIENT BISECTION METHOD.
C
C  CALCULATE MEAN AND STANDARD DEVIATION OF FOLDED NORMAL
C
C
      IF(A.EQ.-99.9)THEN
        ALL=-99.9
        AUL=B
      ELSEIF(B.EQ.-99.9)THEN
        ALL=A
        AUL=-99.9
      ELSEIF(A.LE.B)THEN
        ALL=A
        AUL=B
      ELSE
        ALL=B
        AUL=A
      ENDIF
C
      IF(ALL.NE.-99.9 .AND. AUL.NE.-99.9)THEN
        XL=ALL
        XR=AUL
        IF(P.LE.0.)THEN
          PPF=ALL
          GOTO9999
        ELSEIF(P.GE.1.)THEN
          PPF=AUL
          GOTO9999
        ENDIF
        GOTO99
      ELSEIF(ALL.NE.-99.9)THEN
        XL=ALL
        XR=U
        XINC=SD
        IF(P.LE.0.)THEN
          PPF=ALL
          GOTO9999
        ELSEIF(P.GE.1.)THEN
          P=.9999999
        ENDIF
        GOTO99
      ELSEIF(AUL.NE.-99.9)THEN
        XR=AUL
        XL=U
        XINC=SD
        IF(P.LE.0.)THEN
          P=0.0000001
        ELSEIF(P.GE.1.)THEN
          PPF=AUL
          GOTO9999
        ENDIF
        GOTO99
      ELSE
        XL=U
        XR=U+SD
        XINC=SD
        IF(P.LE.0.)THEN
          P=0.0000001
        ELSEIF(P.GE.1.)THEN
          P=0.9999999
        ENDIF
        GOTO99
      ENDIF
C
      ICOUNT=0
   91 CONTINUE
      XR=XL+XINC
      IF(XL.LE.ALL.AND.ALL.NE.-99.9)XL=ALL
      IF(XR.GE.AUL.AND.AUL.NE.-99.9)XR=AUL
      CALL TNRCDF(XL,ALL,AUL,U,SD,CDFL)
      CALL TNRCDF(XR,ALL,AUL,U,SD,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.MAXIT)THEN
        WRITE(ICOUT,96)
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
        GOTO9999
      ENDIF
   96 FORMAT('***** FATAL ERROR--TNRPPF 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 TNRCDF(X,ALL,AUL,U,SD,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--TNRPPF ROUTINE DID NOT CONVERGE. ***')
      GOTO9999
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE TNRRAN(N,A,B,U,SD,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE THE TRUNCATED NORMAL (GAUSSIAN)
C              DISTRIBUTION WITH MEAN = U AND STANDARD DEVIATION = SD.
C              THE TRUNCATED-NORMAL PDF IS:
C              TNRPDF(X,A,B,U,S) = (1/S)*NORPDF((X-U)/S)/
C                                    [NORCDF((B-U)/S)-NORCDF((A-U)/S)]
C              THE TNRPDF IS DEFINED FOR A<=X<=B
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                       A      = A SINGLE PRECISION SCALAR THAT
C                                DEFINES THE LOWER TRUNCATION POINT.
C                       B      = A SINGLE PRECISION SCALAR THAT
C                                DEFINES THE UPPER TRUNCATION POINT.
C                       U      = A SINGLE PRECISION SCALAR THAT
C                                DEFINES THE LOCATION PARAMETER FOR
C                                THE PARENT NORMAL DISTRIBUTION.
C                       SD     = A SINGLE PRECISION SCALAR THAT
C                                DEFINES THE SCALE PARAMETER FOR
C                                THE PARENT NORMAL DISTRIBUTION.
C                       ISEED  = AN INTEGER NUMBER THAT DEFINES THE
C                                SEED FOR THE UNIFORM RANDOM NUMBER
C                                GENERATOR.
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST N)
C                                INTO WHICH THE GENERATED
C                                RANDOM SAMPLE WILL BE PLACED.
C     OUTPUT--A RANDOM SAMPLE OF SIZE N
C             FROM THE TRUNCATED NORMAL 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--BOX-MULLER ALGORITHM USED TO GENERATE NORMAL RANDOM
C             NUMBERS, THEN REJECT IF GENERATED NUMBER OUTSIDE THE
C             TRUNCATION POINT.
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--2003.7
C     ORIGINAL VERSION--JULY      2003.
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)THEN
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,6)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
    5 FORMAT('***** FATAL ERROR--THE REQUESTED NUMBER OF TRUNCATED')
    6 FORMAT('      NORMAL RANDOM NUMBERS IS NON-POSITIVE.')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
      IF(SD.LE.0.0)THEN
        WRITE(ICOUT,15)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,16)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,48)SD
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
   15 FORMAT('***** FATAL ERROR--THE REQUESTED STANDARD DEVIATION OF')
   16 FORMAT('      THE TRUNCATED NORMAL RANDOM NUMBERS IS ',
     1       'NON-POSITIVE.')
   48 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.7)
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(2,ISEED,Y)
C
      NTEMP=2
      I=0
      INC=1
  100 CONTINUE
        I=I+INC
        IF(I.GT.N)GOTO9000
C
          CALL UNIRAN(NTEMP,ISEED,X(I))
C
C         GENERATE NORMAL RANDOM NUMBERS USING THE BOX-MULLER METHOD.
C
          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)
          Z1=U + SD*Z1
          Z2=U + SD*Z2
C
C         REJECT IF OUTSIDE THE BOUNDS
C
          INC=0
          IF(Z1.GE.A .AND. Z1.LE.B)THEN
            X(I)=Z1
            INC=INC + 1
          ENDIF
          IF(I.LT.N)THEN
            IF(Z2.GE.A .AND. Z2.LE.B)THEN
              X(IP1)=Z2
              INC=INC + 1
            ENDIF
          ENDIF
          GOTO100
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE TNECDF(X,X0,U,SD,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE TRUNCATED EXPONENTIAL DISTRIBUTION
C              WITH MEAN = 0 AND STANDARD DEVIATION = 1.
C              THIS DISTRIBUTION IS DEFINED FOR ALL NON-NEGATIVE X,
C              LESS THAN OR EQUAL TO THE TRUNCATION VALUE X0.
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C              F(X) = EXP(-(X-U)/S)/(S*(1-EXP(-(X0-U)/S))  U<=X<=X0
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                     --X0     = SINGLE PRECISION VALUE DEFINING THE
C                                TRUNCATION POINT.
C                     --U      = SINGLE PRECISION VALUE DEFINING THE
C                                MEAN OF THE PARENT EXPONENTIAL 
C                                DISTRIBUTION
C                     --SD     = SINGLE PRECISION VALUE DEFINING THE
C                                SD OF THE PARENT EXPONENTIAL 
C                                DISTRIBUTION
C     OUTPUT ARGUMENTS--CDF    = THE SINGLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE CDF.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 
C     RESTRICTIONS--X SHOULD BE 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 AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1994, CHAPTER 19.
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 DX
      DOUBLE PRECISION DX0
      DOUBLE PRECISION DCDF
      DOUBLE PRECISION DTERM1
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
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(X.LT.U.OR.X.GT.X0)THEN
        WRITE(ICOUT,4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)X0
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        IF(X.GE.X0)CDF=1.0
        GOTO9999
      ENDIF
      IF(X0.LT.AMAX1(0.0,U))THEN
        WRITE(ICOUT,14)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,15)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X0
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,48)U
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9999
      ENDIF
      IF(U.LT.0.0)THEN
        WRITE(ICOUT,24)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)U
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9999
      ENDIF
      IF(SD.LE.0.0)THEN
        WRITE(ICOUT,34)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)SD
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9999
      ENDIF
    4 FORMAT('***** WARNING--THE FIRST  INPUT ARGUMENT TO ',
     1'THE TNECDF ROUTINE IS')
    5 FORMAT('      OUTSIDE THE (U,X0) INTERVAL')
   14 FORMAT('***** FATAL DIAGNOSTIC--THE SECOND INPUT ARGUMENT TO ',
     1'THE TNECDF ROUTINE IS')
   15 FORMAT('      EITHER NON-POSITIVE OR LESS THAN U.')
   24 FORMAT('***** FATAL DIAGNOSTIC--THE THIRD INPUT ARGUMENT TO ',
     1'THE TNECDF ROUTINE IS NEGATIVE.')
   34 FORMAT('***** FATAL DIAGNOSTIC--THE FOURTH INPUT ARGUMENT TO ',
     1'THE TNECDF ROUTINE IS NON-POSITIVE.')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
   47 FORMAT('***** THE VALUE OF X0 IS ',E15.8,' *****')
   48 FORMAT('***** THE VALUE OF U IS ',E15.8,' *****')
C
C-----START POINT-----------------------------------------------------
C
      DX=DBLE((X-U)/SD)
      DX0=DBLE((X0-U)/SD)
      DTERM1=DEXP(DX)*(DEXP(-DX0)-1.0D0)
      DCDF=1.0D0/DTERM1
      ARG1=U
      CALL TNEPDF(ARG1,X0,U,SD,ARG2)
      CDF=SNGL(DCDF)+SD*ARG2
C
 9999 CONTINUE
      RETURN
      END 
      SUBROUTINE TNEPDF(X,X0,U,SD,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE TRUNCATED EXPONENTIAL DISTRIBUTION
C              WITH LOCATION = U AND SCALE = SD.
C              THIS DISTRIBUTION IS DEFINED FOR ALL NON-NEGATIVE X,
C              LESS THAN OR EQUAL TO THE TRUNCATION VALUE X0.
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C              F(X) = EXP(-(X-U)/S)/(S*(1-EXP(-(X0-U)/S)).
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                     --X0     = SINGLE PRECISION VALUE DEFINING THE
C                                TRUNCATION POINT.
C                     --U      = SINGLE PRECISION VALUE DEFINING THE
C                                MEAN OF THE PARENT EXPONENTIAL 
C                                DISTRIBUTION
C                     --SD     = SINGLE PRECISION VALUE DEFINING THE
C                                SD OF THE PARENT EXPONENTIAL 
C                                DISTRIBUTION
C     OUTPUT ARGUMENTS--PDF    = THE SINGLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE PDF.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 
C     RESTRICTIONS--X SHOULD BE 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 AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1994, CHAPTER 19.
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 DX
      DOUBLE PRECISION DX0
      DOUBLE PRECISION DPDF
      DOUBLE PRECISION DTERM1
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
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(X.LT.U.OR.X.GT.X0)THEN
        WRITE(ICOUT,4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)X0
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ENDIF
      IF(X0.LT.AMAX1(0.0,U))THEN
        WRITE(ICOUT,14)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,15)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X0
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,48)U
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ENDIF
      IF(U.LT.0.0)THEN
        WRITE(ICOUT,24)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)U
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ENDIF
      IF(SD.LE.0.0)THEN
        WRITE(ICOUT,34)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)SD
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ENDIF
    4 FORMAT('***** FATAL DIAGNOSTIC--THE FIRST  INPUT ARGUMENT TO ',
     1'THE TNEPDF ROUTINE IS')
    5 FORMAT('      OUTSIDE THE (U,X0) INTERVAL')
   14 FORMAT('***** FATAL DIAGNOSTIC--THE SECOND INPUT ARGUMENT TO ',
     1'THE TNEPDF ROUTINE IS')
   15 FORMAT('      EITHER NON-POSITIVE OR LESS THAN U.')
   24 FORMAT('***** FATAL DIAGNOSTIC--THE THIRD INPUT ARGUMENT TO ',
     1'THE TNEPDF ROUTINE IS NEGATIVE.')
   34 FORMAT('***** FATAL DIAGNOSTIC--THE FOURTH INPUT ARGUMENT TO ',
     1'THE TNEPDF ROUTINE IS NON-POSITIVE.')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
   47 FORMAT('***** THE VALUE OF X0 IS ',E15.8,' *****')
   48 FORMAT('***** THE VALUE OF U IS ',E15.8,' *****')
C
C-----START POINT-----------------------------------------------------
C
      DX=DBLE((X-U)/SD)
      DX0=DBLE((X0-U)/SD)
      DTERM1=-DX - DLOG(1.0D0-DEXP(-DX0)) - DLOG(DBLE(SD))
      DPDF=DEXP(DTERM1)
      PDF=SNGL(DPDF)
C
 9999 CONTINUE
      RETURN
      END 
      SUBROUTINE TNEPPF(P,X0,U,SD,PPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE TRUNCATED EXPONENTIAL DISTRIBUTION
C              THIS DISTRIBUTION IS DEFINED FOR U<=X<=X0
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C              F(X) = EXP(-(X-U)/S)/(S*(1-EXP(-(X0-U)/S)).
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                     --X0     = SINGLE PRECISION VALUE DEFINING THE
C                                TRUNCATION POINT.
C                     --U      = SINGLE PRECISION VALUE DEFINING THE
C                                MEAN OF THE PARENT EXPONENTIAL 
C                                DISTRIBUTION
C                     --SD     = SINGLE PRECISION VALUE DEFINING THE
C                                SD OF THE PARENT EXPONENTIAL 
C                                DISTRIBUTION
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--ALOG.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1994, CHAPTER 19.
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 (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
CCCCC DOUBLE PRECISION DP
CCCCC DOUBLE PRECISION DX0
CCCCC DOUBLE PRECISION DPPF
CCCCC DOUBLE PRECISION DTERM1
CCCCC DOUBLE PRECISION DTERM2
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DATA EPS /1.0E-6/
      DATA SIG /1.0E-5/
      DATA ZERO /0./
      DATA MAXIT /2000/
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(P.LT.0.0.OR.P.GT.1.0)THEN
        WRITE(ICOUT,1)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)P
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
      IF(X0.LT.AMAX1(0.0,U))THEN
        WRITE(ICOUT,14)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,15)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X0
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,48)U
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ENDIF
      IF(U.LT.0.0)THEN
        WRITE(ICOUT,24)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)U
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ENDIF
      IF(SD.LE.0.0)THEN
        WRITE(ICOUT,34)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)SD
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ENDIF
    1 FORMAT('***** FATAL ERROR--THE 1ST  INPUT ARGUMENT TO THE ',
     1'TNEPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
   14 FORMAT('***** FATAL DIAGNOSTIC--THE SECOND INPUT ARGUMENT TO ',
     1'THE TNEPPF ROUTINE IS')
   15 FORMAT('      EITHER NON-POSITIVE OR LESS THAN U.')
   24 FORMAT('***** FATAL DIAGNOSTIC--THE THIRD INPUT ARGUMENT TO ',
     1'THE TNEPPF ROUTINE IS NEGATIVE.')
   34 FORMAT('***** FATAL DIAGNOSTIC--THE FOURTH INPUT ARGUMENT TO ',
     1'THE TNEPPF ROUTINE IS NON-POSITIVE.')
   47 FORMAT('***** THE VALUE OF X0 IS ',E15.8,' *****')
   48 FORMAT('***** THE VALUE OF U IS ',E15.8,' *****')
C
      IF(P.EQ.0.0)THEN
        PPF=U
        GOTO9999
      ELSEIF(P.EQ.1.0)THEN
        PPF=X0
        GOTO9999
      ENDIF
C
CCCCC CALL TNEPDF(U,X0,U,SD,ARG2)
CCCCC DTERM1=DBLE(SD)*DBLE(ARG2)
CCCCC DP=DBLE(P)
CCCCC DX0=DBLE((X0-U)/SD)
CCCCC DTERM2=DEXP(-DX0)-1.0D0
CCCCC DTERM3=1.0D0/(DTERM2*(DP-DTERM1))
CCCCC IF(DTERM3.GT.0.0D0)THEN
CCCCC   DPPF=DLOG(1.0D0/(DTERM2*(DP-DTERM1)))
CCCCC ELSE
CCCCC   DPPF=0.0
CCCCC ENDIF
CCCCC PPF=U + S*SNGL(DPPF)
C
      IERR=0
      IC = 0
      XL = U
      XR = X0
      FXL = -P
      FXR = 1.0 - P
CCCCC INVALID P EXPLICITLY CHECKED FOR EARLIER.
CCCCC IF(FXL*FXR .GT. ZERO)GOTO50
C
C  BISECTION METHOD
C
  105 CONTINUE
      X = (XL+XR)*0.5
      CALL TNECDF(X,X0,U,SD,P1)
      PPF=X
CCCCC IF(IERR.NE.0)THEN
CCCCC   WRITE(ICOUT,120)
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC ENDIF
CC120 FORMAT('***** FATAL ERROR--ERROR IN BETCDF ROUTINE.  *****')
      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--TNEPPF ROUTINE DID NOT CONVERGE. ***')
      GOTO9999
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE TNERAN(N,X0,U,SD,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE THE TRUNCATED EXPONENTIAL DISTRIBUTION
C              WITH LOCATION = U AND SCALE = SD.
C              THIS DISTRIBUTION IS DEFINED FOR ALL NON-NEGATIVE X,
C              LESS THAN OR EQUAL TO THE TRUNCATION VALUE X0.
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C              F(X) = EXP(-(X-U)/S)/(S*(1-EXP(-(X0-U)/S)).
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --X0     = SINGLE PRECISION VALUE DEFINING THE
C                                TRUNCATION POINT.
C                     --U      = SINGLE PRECISION VALUE DEFINING THE
C                                MEAN OF THE PARENT EXPONENTIAL 
C                                DISTRIBUTION
C                     --SD     = SINGLE PRECISION VALUE DEFINING THE
C                                SD OF THE PARENT EXPONENTIAL 
C                                DISTRIBUTION
C                       ISEED  = AN INTEGER NUMBER THAT DEFINES THE
C                                SEED FOR THE UNIFORM RANDOM NUMBER
C                                GENERATOR.
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST N)
C                                INTO WHICH THE GENERATED
C                                RANDOM SAMPLE WILL BE PLACED.
C     OUTPUT--A RANDOM SAMPLE OF SIZE N
C             FROM THE TRUNCATED EXPONENTIAL 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.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     METHOD--BOX-MULLER ALGORITHM USED TO GENERATE NORMAL RANDOM
C             NUMBERS, THEN REJECT IF GENERATED NUMBER OUTSIDE THE
C             TRUNCATION POINT.
C     REFERENCES--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               --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1970, PAGES 207-232.
C               --HASTINGS AND PEACOCK, STATISTICAL
C                 DISTRIBUTIONS--A HANDBOOK FOR
C                 STUDENTS AND PRACTITIONERS, 1975,
C                 PAGE 58.
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.7
C     ORIGINAL VERSION--JULY      2003.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----DATA STATEMENTS-------------------------------------------------
C
      DATA PI/3.14159265359/
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)THEN
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,6)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
    5 FORMAT('***** FATAL ERROR--THE REQUESTED NUMBER OF TRUNCATED')
    6 FORMAT('      EXPONENTIAL RANDOM NUMBERS IS NON-POSITIVE.')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
      IF(X0.LT.AMAX1(0.0,U))THEN
        WRITE(ICOUT,14)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,15)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X0
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,48)U
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
      IF(U.LT.0.0)THEN
        WRITE(ICOUT,24)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,49)U
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
      IF(SD.LE.0.0)THEN
        WRITE(ICOUT,34)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,49)SD
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
   14 FORMAT('***** FATAL DIAGNOSTIC--THE TRUNCATION PARAMETER FOR',
     1' THE TRUNCATED EXPONENTIAL DISTRIBUTION')
   15 FORMAT('      IS EITHER NON-POSITIVE OR LESS THAN U.')
   24 FORMAT('***** FATAL DIAGNOSTIC--THE LOCATION PARAMETER FOR THE ',
     1'TRUNCATED EXPONENTIAL DISTRIBUTION IS NEGATIVE.')
   34 FORMAT('***** FATAL DIAGNOSTIC--THE SCALE PARAMETER FOR THE ',
     1'TRUNCATED EXPONENTIAL DISTRIBUTION IS NON-POSITIVE.')
   46 FORMAT('***** THE VALUE OF THE TRUNCATION PARAMETER IS ',E15.7)
   48 FORMAT('***** THE VALUE OF THE LOCATION PARAMETER IS ',E15.7)
   49 FORMAT('***** THE VALUE OF THE PARAMETER IS ',E15.7)
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
C
      NTEMP=1
      I=0
  100 CONTINUE
        I=I+1
        IF(I.GT.N)GOTO9000
  199   CONTINUE
C
        CALL UNIRAN(NTEMP,ISEED,X(I))
        X(I)=-ALOG(X(I))
        X(I)=U + SD*X(I)
        IF(X(I).GT.X0)GOTO199
      GOTO100
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE TOL(X,N,ICASAN)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES NORMAL AND
C              DISTRIBUTION-FREE TOLERANCE LIMITS 
C              FOR THE DATA IN THE INPUT VECTOR X.
C              15 NORMAL TOLERANCE LIMITS ARE COMPUTED; AND 
C              30 DISTRIBUTION-FREE TOLERANCE LIMITS ARE COMPUTED.
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--2 PAGES OF AUTOMATIC PRINTOUT--
C             1 PAGE GIVING NORMAL TOLERANCE LIMITS; AND
C             1 PAGE GIVING DISTRIBUTION-FREE TOLERANCE LIMITS.
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--SQRT.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN. 
C     REFERENCES--GARDINER AND HULL, TECHNOMETRICS, 1966, PAGES 115-122
C               --WILKS, ANNALS OF MATHEMATICAL STATISTICS, 1941, PAGE 92
C               --MOOD AND GRABLE, PAGES 416-417
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--JUNE      1972. 
C     UPDATED         --NOVEMBER  1975. 
C     UPDATED         --NOVEMBER  1998. CHANGES TO INCORPORATE INTO
C                                       DATAPLOT
C     UPDATED         --DECEMBER  2005. OPTIONALLY SELECT WHETHER
C                                       NORMAL/NON-PARAMETERIC CASES
C                                       PERFORMED
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
      DIMENSION PA(6),PC(6),Z1(3),A(6),B(6),C(6),RSMALL(5,6),USMALL(6,6)
      DIMENSION TMIN(3,6),TMAX(3,6)
      DIMENSION P(10),C1(10),C2(10),C3(10)
C
      CHARACTER*4 ICASAN
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
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
      DATA PA(1),PA(2),PA(3),PA(4),PA(5),PA(6)/50.,75.,90.,95.,99.,99.9/
      DATA PC(1),PC(2),PC(3)/90.,95.,99./
      DATA Z1(1),Z1(2),Z1(3)/-1.28155157,-1.64485363,-2.32634787/
      DATA A(1),A(2),A(3),A(4),A(5),A(6)/.6745,1.1504,1.6449,1.9600,2.57
     158,3.2905/
      DATA B(1),B(2),B(3),B(4),B(5),B(6)/.33734,.57335,.82140,.97910,1.2
     1889,1.64038/
      DATA C(1),C(2),C(3),C(4),C(5),C(6)/-0.15460,-0.02991,.22044,.40675
     1,.85514,1.42601/
      DATA RSMALL(1,1),RSMALL(1,2),RSMALL(1,3),RSMALL(1,4),RSMALL(1,5),
     1RSMALL(1,6)            /1.0505,1.6859,2.2844,2.6463,3.3266,4.0903/
      DATA RSMALL(2,1),RSMALL(2,2),RSMALL(2,3),RSMALL(2,4),RSMALL(2,5),
     1RSMALL(2,6)            /0.8557,1.4333,2.0078,2.3624,3.0368,3.7983/
      DATA RSMALL(3,1),RSMALL(3,2),RSMALL(3,3),RSMALL(3,4),RSMALL(3,5),
     1RSMALL(3,6)            /0.7929,1.3412,1.8979,2.2457,2.9128,3.6708/
      DATA RSMALL(4,1),RSMALL(4,2),RSMALL(4,3),RSMALL(4,4),RSMALL(4,5),
     1RSMALL(4,6)            /0.7622,1.2940,1.8388,2.1815,2.8422,3.5965/
      DATA RSMALL(5,1),RSMALL(5,2),RSMALL(5,3),RSMALL(5,4),RSMALL(5,5),
     1RSMALL(5,6)            /0.7442,1.2654,1.8019,2.1408,2.7963,3.5472/
      DATA USMALL(1,1),USMALL(1,2),USMALL(1,3)/0.,0.,0./
      DATA USMALL(2,1),USMALL(2,2),USMALL(2,3)/7.9579,15.9472,79.7863/
      DATA USMALL(3,1),USMALL(3,2),USMALL(3,3)/3.0808,4.4154,9.9749/
      DATA USMALL(4,1),USMALL(4,2),USMALL(4,3)/2.2658,2.9200,5.1113/
      DATA USMALL(5,1),USMALL(5,2),USMALL(5,3)/1.9393,2.3724,3.6692/
      DATA USMALL(6,1),USMALL(6,2),USMALL(6,3)/1.7621,2.0893,3.0034/
      DATA P(1),P(2),P(3),P(4),P(5),P(6),P(7),P(8),P(9),P(10)
     1/50.,75.,90.,95.,97.5,99.,99.5,99.9,99.95,99.99/
C
CCCCC IPR=6
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)GOTO50
      IF(N.EQ.1)GOTO55
      HOLD=X(1)
      DO60I=2,N
      IF(X(I).NE.HOLD)GOTO90
   60 CONTINUE
      WRITE(ICOUT, 9)HOLD
      CALL DPWRST('XXX','BUG ')
      RETURN
   50 WRITE(ICOUT,15) 
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,47)N
      CALL DPWRST('XXX','BUG ')
      RETURN
   55 WRITE(ICOUT,18) 
      CALL DPWRST('XXX','BUG ')
      RETURN
   90 CONTINUE
    9 FORMAT(1H ,109H***** NON-FATAL DIAGNOSTIC--THE FIRST  INPUT ARGUME
     1NT (A VECTOR) TO THE TOL    SUBROUTINE HAS ALL ELEMENTS = ,E15.8,6
     1H *****)
   15 FORMAT(1H , 91H***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE
     1 TOL    SUBROUTINE IS NON-POSITIVE *****)
   18 FORMAT(1H ,100H***** NON-FATAL DIAGNOSTIC--THE SECOND INPUT ARGUME
     1NT TO THE TOL    SUBROUTINE HAS THE VALUE 1 *****)
   47 FORMAT(1H , 35H***** THE VALUE OF THE ARGUMENT IS ,I8   ,6H *****)
C
C-----START POINT-----------------------------------------------------
C
      AN=N
C
C     COMPUTE NORMAL TOLERANCE LIMITS
C
C     COMPUTE THE SAMPLE MEAN 
C
      XBAR=0.0
      DO100I=1,N
      XBAR=XBAR+X(I)
  100 CONTINUE
      XBAR=XBAR/AN
C
C     COMPUTE THE SAMPLE STANDARD DEVIATION
C
      VAR=0.0
      DO200I=1,N
      VAR=VAR+(X(I)-XBAR)**2
  200 CONTINUE
      VAR=VAR/(AN-1.0)
      SD=SQRT(VAR)
C
C     COMPUTE THE NORMAL TOLERANCE LIMITS
C
      IF(ICASAN.NE.'TOLE' .AND. ICASAN.NE.'NTOL')GOTO799
C
      DO 300 I=1,3
      Z=Z1(I)
      F=N-1
      IF(N.LE.6)U=USMALL(N,I) 
      IF(N.LE.6)GOTO390
      D1=1.0+Z*SQRT(2.0)/SQRT(F)
      D2=2.0*(Z**2-1.0)/(3.0*F)
      D3=(Z**3-7.0*Z)/(9.0*SQRT(2.0)*F**1.5)
      D4=(6.0*Z**4+14.0*Z**2-32.0)/(405.0*F**2.0) 
      D5=(9.0*Z**5+256.0*Z**3-433.0*Z)/(4860.0*SQRT(2.0)*F**2.5)
      D6=(12.0*Z**6-243.0*Z**4-923.0*Z**2+1472.0)/(25515.0*F**3.0)
      D7=(3753.0*Z**7+4353.0*Z**5-289517.0*Z**3-289717.0*Z)/(9185400.0*S
     1QRT(2.0)*F**3.5)
      UNIV=D1+D2+D3-D4+D5+D6-D7
      U=1.0/UNIV
      U=SQRT(U)
  390 DO 400 J=1,6
      R=A(J)+(B(J)/(C(J)+AN)) 
      IF(N.LE.5)R=RSMALL(N,J) 
      AK=R*U
      TMIN(I,J)=XBAR-AK*SD
      TMAX(I,J)=XBAR+AK*SD
  400 CONTINUE
  300 CONTINUE
C
C     WRITE OUT THE NORMAL TOLERANCE LIMITS
C
      WRITE(ICOUT,998)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,605)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,609)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,610)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,614)N
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,615)XBAR
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,616)SD
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
C
      DO 600 I=1,3
        WRITE(ICOUT,620)PC(I)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,621)
        CALL DPWRST('XXX','BUG ')
        DO 700 J=1,6
          WRITE(ICOUT,622)PA(J),TMIN(I,J),TMAX(I,J)
          CALL DPWRST('XXX','BUG ')
  700   CONTINUE
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
  600 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,997)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
C
  605 FORMAT('2-SIDED NORMAL TOLERANCE LIMITS: XBAR +- K*S')
  609 FORMAT('             REFERENCE--CRC HANDBOOK, PAGES 32-35')
  610 FORMAT('             REFERENCE--GARDINER AND HULL, ',
     1'TECHNOMETRICS, 1966, PAGES 115-122')
  614 FORMAT('             NUMBER OF OBSERVATIONS    = ',I6)
  615 FORMAT('             SAMPLE MEAN               = ',G15.8)
  616 FORMAT('             SAMPLE STANDARD DEVIATION = ',G15.8)
  620 FORMAT('CONFIDENCE = ',F6.0,'%')
  621 FORMAT('     COVERAGE (%)         LOWER LIMIT         ',
     1'UPPER LIMIT')
  622 FORMAT(10X,F7.1,5X,G15.7,5X,G15.7)
  997 FORMAT('----------------------------------------')
C
  799 CONTINUE
C
C     COMPUTE DISTRIBUTION-FREE TOLERANCE LIMITS
C
      IF(ICASAN.NE.'TOLE' .AND. ICASAN.NE.'NPTO')GOTO1999
C
      K=N/2
      NUMSEC=3
      IF(K.LT.NUMSEC)NUMSEC=K 
C
C     DETERMINE THE SMALLEST 3 AND LARGEST 3 OBSERVATIONS
C
      LOCMIN=1
      XMIN=X(1)
      DO800I=1,N
      IF(X(I).LE.XMIN)LOCMIN=I
      IF(X(I).LE.XMIN)XMIN=X(I)
  800 CONTINUE
      LOCMAX=1
      XMAX=X(1)
      DO850I=1,N
      IF(X(I).GE.XMAX)LOCMAX=I
      IF(X(I).GE.XMAX)XMAX=X(I)
  850 CONTINUE
      DO900I=1,N
      IF(I.NE.LOCMIN)GOTO910
  900 CONTINUE
  910 LOCMN2=I
      XMIN2=X(I)
      DO950I=1,N
      IF(I.EQ.LOCMIN)GOTO950
      IF(X(I).LE.XMIN2)LOCMN2=I
      IF(X(I).LE.XMIN2)XMIN2=X(I)
  950 CONTINUE
      DO1000I=1,N
      IF(I.NE.LOCMAX)GOTO1010 
 1000 CONTINUE
 1010 LOCMX2=I
      XMAX2=X(I)
      DO1050I=1,N
      IF(I.EQ.LOCMAX)GOTO1050 
      IF(X(I).GE.XMAX2)LOCMX2=I
      IF(X(I).GE.XMAX2)XMAX2=X(I)
 1050 CONTINUE
      DO1100I=1,N
      IF(I.NE.LOCMIN.AND.I.NE.LOCMN2)GOTO1110
 1100 CONTINUE
 1110 LOCMN3=I
      XMIN3=X(I)
      DO1150I=1,N
      IF(I.EQ.LOCMIN.OR.I.EQ.LOCMN2)GOTO1150
      IF(X(I).LE.XMIN3)LOCMN3=I
      IF(X(I).LE.XMIN3)XMIN3=X(I)
 1150 CONTINUE
      DO1200I=1,N
      IF(I.NE.LOCMAX.AND.I.NE.LOCMX2)GOTO1210
 1200 CONTINUE
 1210 LOCMX3=I
      XMAX3=X(I)
      DO1250I=1,N
      IF(I.EQ.LOCMAX.OR.I.EQ.LOCMX2)GOTO1250
      IF(X(I).GE.XMAX3)LOCMX3=I
      IF(X(I).GE.XMAX3)XMAX3=X(I)
 1250 CONTINUE
      AN1=AN-1.0
      AN2=AN-2.0
      AN3=AN-3.0
      AN4=AN-4.0
      AN5=AN-5.0
      AN6=AN-6.0
      DO1600I=1,10
      D=P(I)/100.0
      C1(I)=(D**AN1)*(-AN   +AN1*D)
      C1(I)=1.0-C1(I)
      Q=1.0-D
      T=Q*AN
      C1(I)=1.0+AN1*Q
      C1(I)=1.0-(D**AN1)*C1(I)
      C1(I)=C1(I)*100.0
      IF(NUMSEC.EQ.1)GOTO1600 
      A0=6.0*D*D*D
      A1=2.0-7.0*D+11.0*D*D
      A2=-3.0+6.0*D 
      A3=1.0
      C2(I)=A0+A1*T+A2*T*T+A3*T*T*T
      C2(I)=1.0-(D**AN3)*C2(I)/6.0
      C2(I)=C2(I)*100.0
      IF(NUMSEC.EQ.2)GOTO1600 
      A0=120.0*D*D*D*D*D
      A1=24.0-126.0*D+274.0*D*D-326.0*D*D*D+274.0*D*D*D*D
      A2=-50.0+205.0*D-320.0*D*D+225.0*D*D*D
      A3=35.0-100.0*D+85.0*D*D
      A4=-10.0+15.0*D
      A5=1.0D0
      C3(I)=A0+A1*T+A2*T*T+A3*T*T*T+A4*T*T*T*T+A5*T*T*T*T*T 
      C3(I)=1.0-(D**AN5)*C3(I)/120.0
      C3(I)=C3(I)*100.0
 1600 CONTINUE
C
C     WRITE OUT THE DISTRIBUTION-FREE TOLERANCE LIMITS
C
      WRITE(ICOUT,998)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,205)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
CCCCC WRITE(ICOUT,207)N
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC WRITE(ICOUT,999)
CCCCC CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,209)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,210)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      IF(NUMSEC.EQ.1)GOTO1850 
      IF(NUMSEC.EQ.2)GOTO1750 
C
      WRITE(ICOUT,315)XMIN3,XMAX3
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,215)
      CALL DPWRST('XXX','BUG ')
      DO1700I=1,10
      WRITE(ICOUT,216)C3(I),P(I)
      CALL DPWRST('XXX','BUG ')
 1700 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
C
 1750 CONTINUE
      WRITE(ICOUT,316)XMIN2,XMAX2
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,215)
      CALL DPWRST('XXX','BUG ')
      DO1800I=1,10
      WRITE(ICOUT,216)C2(I),P(I)
      CALL DPWRST('XXX','BUG ')
 1800 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
C
 1850 CONTINUE
      WRITE(ICOUT,317)XMIN,XMAX
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,215)
      CALL DPWRST('XXX','BUG ')
      DO1900I=1,10
      WRITE(ICOUT,216)C1(I),P(I)
      CALL DPWRST('XXX','BUG ')
 1900 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
C
 1999 CONTINUE
C
  205 FORMAT('2-SIDED DISTRIBUTION-FREE TOLERANCE LIMITS:')
  207 FORMAT('            NUMBER OF OBSERVATIONS  = ',I8)
  209 FORMAT('            REFERENCE--WILKS, ANNALS, 1941, PAGE 92')
  210 FORMAT('            REFERENCE--MOOD AND GRABLE, PAGES 416-417')
C
  215 FORMAT('    CONFIDENCE (%)       COVERAGE (%)')
  216 FORMAT(8X,F7.1,5X,E15.7)
  315 FORMAT('INVOLVING X(3) = ',G15.7,' AND X(N-2) = ',G15.7)
  316 FORMAT('INVOLVING X(2) = ',G15.7,' AND X(N-1) = ',G15.7)
  317 FORMAT('INVOLVING XMIN = ',G15.7,' AND XMAX = ',G15.7)
  998 FORMAT(' ')
  999 FORMAT(' ')
C
      RETURN
      END 
      SUBROUTINE TPDF(X,NU,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR STUDENT'S T DISTRIBUTION
C              WITH INTEGER DEGREES OF FREEDOM PARAMETER = NU.
C              THIS DISTRIBUTION IS DEFINED FOR ALL 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 PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE NON-NEGATIVE.
C                     --NU     = THE INTEGER NUMBER OF DEGREES
C                                OF FREEDOM.
C                                NU SHOULD BE POSITIVE.
C     OUTPUT ARGUMENTS--PDF    = THE SINGLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE PDF FOR THE STUDENT'S T DISTRIBUTION
C             WITH DEGREES OF FREEDOM PARAMETER = NU.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--NU SHOULD BE A POSITIVE INTEGER VARIABLE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--DSQRT, DATAN.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--NATIONAL BUREAU OF STANDARDS APPLIED MATHMATICS
C                 SERIES 55, 1964, PAGE 948, FORMULAE 26.7.3 AND 26.7.4.
C               --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--2, 1970, PAGES 94-129.
C               --FEDERIGHI, EXTENDED TABLES OF THE
C                 PERCENTAGE POINTS OF STUDENT'S
C                 T-DISTRIBUTION, JOURNAL OF THE
C                 AMERICAN STATISTICAL ASSOCIATION,
C                 1959, PAGES 683-688.
C               --OWEN, HANDBOOK OF STATISTICAL TABLES,
C                 1962, PAGES 27-30.
C               --PEARSON AND HARTLEY, BIOMETRIKA TABLES
C                 FOR STATISTICIANS, VOLUME 1, 1954,
C                 PAGES 132-134.
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--82.6
C     ORIGINAL VERSION--AUGUST    1977.
C     UPDATED         --NOVEMBER  1981.
C     UPDATED         --MAY       1982.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX,DNU
      DOUBLE PRECISION DSQTPI,DRATIO
      DOUBLE PRECISION DCONST,DPOWER
      DOUBLE PRECISION AI
      DOUBLE PRECISION DSQRT
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      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 DSQTPI/1.77245385090552D0/
C
C-----START POINT-----------------------------------------------------
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      IF(NU.LE.0)GOTO150
      GOTO190
  150 CONTINUE
      WRITE(ICOUT,115)
  115 FORMAT('***** FATAL ERROR--THE 2ND INPUT ARGUMENT ',
     1'TO THE   TPDF   SUBROUTINE IS NON-POSITIVE *****')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,147)NU
  147 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,
     1' *****')
      CALL DPWRST('XXX','BUG ')
      PDF=0.0
      GOTO9000
  190 CONTINUE
C
C               ****************************************************************
C               **  STEP 2--
C               **  COMPUTE THE CONSTANT = 1/(SQRT(NU)*BETA(1/2,NU/2))
C               **  = (1/(SQRT(NU)*SQRT(PI))) * (GAMMA((NU/2)+(1/2))/GAMMA(NU/2)
C               ****************************************************************
C
      DX=X
      DNU=NU
C
      DRATIO=1.0D0
      IEVODD=NU-2*(NU/2)
      IMIN=3
      IF(IEVODD.EQ.0)IMIN=2
      IF(NU.LT.IMIN)GOTO250
      DO300I=IMIN,NU,2
      AI=I
      DRATIO=((AI-1.0D0)/AI)*DRATIO
  300 CONTINUE
  250 CONTINUE
      DRATIO=DRATIO*DNU
      IF(IEVODD.EQ.0)GOTO260
      DRATIO=DRATIO/DSQTPI
      GOTO400
  260 CONTINUE
      DRATIO=DRATIO*DSQTPI/2.0D0
  400 CONTINUE
C
      DCONST=DRATIO/(DSQTPI*DSQRT(DNU))
C
C               ************************************
C               **  STEP 3--                      **
C               **  COMPUTE THE DENSITY FUNCTION  **
C               ************************************
C
      DPOWER=-(DNU+1.0D0)/2.0D0
      PDF=DCONST*((1.0D0+DX*DX/DNU)**DPOWER)
      GOTO9000
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE TPPF(P,NU,PPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE STUDENT'S T DISTRIBUTION
C              WITH INTEGER DEGREES OF FREEDOM PARAMETER = NU.
C              THE STUDENT'S T DISTRIBUTION USED
C              HEREIN IS DEFINED FOR ALL X,
C              AND ITS PROBABILITY DENSITY FUNCTION IS GIVEN
C              IN THE REFERENCES BELOW.
C              NOTE THAT THE PERCENT POINT FUNCTION OF A DISTRIBUTION
C              IS IDENTICALLY THE SAME AS THE INVERSE CUMULATIVE
C              DISTRIBUTION FUNCTION OF THE DISTRIBUTION.
C     INPUT  ARGUMENTS--P      = THE SINGLE PRECISION VALUE
C                                (BETWEEN 0.0 (EXCLUSIVELY)
C                                AND 1.0 (EXCLUSIVELY))
C                                AT WHICH THE PERCENT POINT
C                                FUNCTION IS TO BE EVALUATED.
C                     --NU     = THE INTEGER NUMBER OF DEGREES
C                                OF FREEDOM.
C                                NU 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 STUDENT'S T DISTRIBUTION
C             WITH DEGREES OF FREEDOM PARAMETER = NU.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--NU SHOULD BE A POSITIVE INTEGER VARIABLE.
C                 --P SHOULD BE BETWEEN 0.0 (EXCLUSIVELY)
C                   AND 1.0 (EXCLUSIVELY).
C     OTHER DATAPAC   SUBROUTINES NEEDED--NORPPF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--DSIN, DCOS, DSQRT, DATAN.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     COMMENT--FOR NU = 1 AND NU = 2, THE PERCENT POINT FUNCTION
C              FOR THE T DISTRIBUTION EXISTS IN SIMPLE CLOSED FORM
C              AND SO THE COMPUTED PERCENT POINTS ARE EXACT.
C            --FOR OTHER SMALL VALUES OF NU (NU BETWEEN 3 AND 6,
C              INCLUSIVELY), THE APPROXIMATION
C              OF THE T PERCENT POINT BY THE FORMULA
C              GIVEN IN THE REFERENCE BELOW IS AUGMENTED
C              BY 3 ITERATIONS OF NEWTON'S METHOD FOR
C              ROOT DETERMINATION.
C              THIS IMPROVES THE ACCURACY--ESPECIALLY FOR
C              VALUES OF P NEAR 0 OR 1.
C     REFERENCES--NATIONAL BUREAU OF STANDARDS APPLIED MATHMATICS
C                 SERIES 55, 1964, PAGE 949, FORMULA 26.7.5.
C               --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--2, 1970, PAGE 102,
C                 FORMULA 11.
C               --FEDERIGHI, 'EXTENDED TABLES OF THE
C                 PERCENTAGE POINTS OF STUDENT'S T
C                 DISTRIBUTION, JOURNAL OF THE
C                 AMERICAN STATISTICAL ASSOCIATION,
C                 1969, PAGES 683-688.
C               --HASTINGS AND PEACOCK, STATISTICAL
C                 DISTRIBUTIONS--A HANDBOOK FOR
C                 STUDENTS AND PRACTITIONERS, 1975,
C                 PAGES 120-123.
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--82.6
C     ORIGINAL VERSION--OCTOBER   1975.
C     UPDATED         --NOVEMBER  1975.
C     UPDATED         --DECEMBER  1981.
C     UPDATED         --MAY       1982.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION PI
      DOUBLE PRECISION SQRT2
      DOUBLE PRECISION DP
      DOUBLE PRECISION DNU
      DOUBLE PRECISION TERM1,TERM2,TERM3,TERM4,TERM5
      DOUBLE PRECISION DPPFN
      DOUBLE PRECISION DPPF,DCON,DARG,Z,S,C
      DOUBLE PRECISION B21
      DOUBLE PRECISION B31,B32,B33,B34
      DOUBLE PRECISION B41,B42,B43,B44,B45
      DOUBLE PRECISION B51,B52,B53,B54,B55,B56
      DOUBLE PRECISION D1,D3,D5,D7,D9
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      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 SQRT2/1.414213562D0/
      DATA B21/0.25D0/
      DATA B31,B32,B33,B34/0.01041666666667D0,5.0D0,16.0D0,3.0D0/
      DATA B41,B42,B43,B44,B45/0.00260416666667D0,3.0D0,19.0D0,17.0D0,
     1                         -15.0D0/
      DATA B51,B52,B53,B54,B55,B56/0.00001085069444D0,79.0D0,776.0D0,
     1                             1482.0D0,-1920.0D0,-945.0D0/
C
C-----START POINT-----------------------------------------------------
C
      S=0.0D0
      C=0.0D0
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(P.LE.0.0.OR.P.GE.1.0)GOTO50
      GOTO90
   50 WRITE(ICOUT,1)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)P
      CALL DPWRST('XXX','BUG ')
      RETURN
   90 CONTINUE
    1 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ',
     1'TPPF   SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
      DNU=NU
      DP=P
      MAXIT=5
C
      IF(NU.GE.3)GOTO250
      IF(NU.EQ.1)GOTO100
      IF(NU.EQ.2)GOTO200
      WRITE(ICOUT,105)
  105 FORMAT(33HINTERNAL ERROR IN TPPF SUBROUTINE)
      CALL DPWRST('XXX','BUG ')
      PPF=0.0
      RETURN
C
C     TREAT THE NU = 1 (CAUCHY) CASE
C
  100 DARG=PI*DP
      PPF=-DCOS(DARG)/DSIN(DARG)
      RETURN
C
C     TREAT THE NU = 2 CASE
C
  200 TERM1=SQRT2/2.0D0
      TERM2=2.0D0*DP-1.0D0
      TERM3=DSQRT(DP*(1.0D0-DP))
      PPF=TERM1*TERM2/TERM3
      RETURN
C
C     TREAT THE NU GREATER THAN OR EQUAL TO 3 CASE
C
  250 CALL NORPPF(P,PPFN)
      DPPFN=PPFN
      D1=DPPFN
      D3=DPPFN**3
      D5=DPPFN**5
      D7=DPPFN**7
      D9=DPPFN**9
      TERM1=D1
      TERM2=B21*(D3+D1)/DNU
      TERM3=B31*(B32*D5+B33*D3+B34*D1)/(DNU**2)
      TERM4=B41*(B42*D7+B43*D5+B44*D3+B45*D1)/(DNU**3)
      TERM5=B51*(B52*D9+B53*D7+B54*D5+B55*D3+B56*D1)/(DNU**4)
      DPPF=TERM1+TERM2+TERM3+TERM4+TERM5
      PPF=DPPF
      IF(NU.GE.7)RETURN
      IF(NU.EQ.3)GOTO300
      IF(NU.EQ.4)GOTO400
      IF(NU.EQ.5)GOTO500
      IF(NU.EQ.6)GOTO600
      RETURN
C
C     AUGMENT THE RESULTS FOR THE NU = 3 CASE
C
  300 DCON=PI*(DP-0.5D0)
      DARG=DPPF/DSQRT(DNU)
      Z=DATAN(DARG)
      DO350IPASS=1,MAXIT
      S=DSIN(Z)
      C=DCOS(Z)
      Z=Z-(Z+S*C-DCON)/(2.0D0*C*C)
  350 CONTINUE
      PPF=DSQRT(DNU)*S/C
      RETURN
C
C     AUGMENT THE RESULTS FOR THE NU = 4 CASE
C
  400 DCON=2.0D0*(DP-0.5D0)
      DARG=DPPF/DSQRT(DNU)
      Z=DATAN(DARG)
      DO450IPASS=1,MAXIT
      S=DSIN(Z)
      C=DCOS(Z)
      Z=Z-((1.0D0+0.5D0*C*C)*S-DCON)/(1.5D0*C*C*C)
  450 CONTINUE
      PPF=DSQRT(DNU)*S/C
      RETURN
C
C     AUGMENT THE RESULTS FOR THE NU = 5 CASE
C
  500 DCON=PI*(DP-0.5D0)
      DARG=DPPF/DSQRT(DNU)
      Z=DATAN(DARG)
      DO550IPASS=1,MAXIT
      S=DSIN(Z)
      C=DCOS(Z)
      Z=Z-(Z+(C+(2.0D0/3.0D0)*C*C*C)*S-DCON)/((8.0D0/3.0D0)*C**4)
  550 CONTINUE
      PPF=DSQRT(DNU)*S/C
      RETURN
C
C     AUGMENT THE RESULTS FOR THE NU = 6 CASE
C
  600 DCON=2.0D0*(DP-0.5D0)
      DARG=DPPF/DSQRT(DNU)
      Z=DATAN(DARG)
      DO650IPASS=1,MAXIT
      S=DSIN(Z)
      C=DCOS(Z)
      Z=Z-((1.0D0+0.5D0*C*C+0.375D0*C**4)*S-DCON)/((15.0D0/8.0D0)*C**5)
  650 CONTINUE
      PPF=DSQRT(DNU)*S/C
      RETURN
C
      END
      SUBROUTINE TQLRAT(N,D,E2,IERR)
C***BEGIN PROLOGUE  TQLRAT
C***DATE WRITTEN   760101   (YYMMDD)
C***REVISION DATE  830518   (YYMMDD)
C***CATEGORY NO.  D4A5,D4C2A
C***KEYWORDS  EIGENVALUES,EIGENVECTORS,EISPACK
C***AUTHOR  SMITH, B. T., ET AL.
C***PURPOSE  Computes eigenvalues of symmetric tridiagonal matrix
C            a rational variant of the QL method.
C***DESCRIPTION
C
C     This subroutine is a translation of the ALGOL procedure TQLRAT,
C     ALGORITHM 464, COMM. ACM 16, 689(1973) by Reinsch.
C
C     This subroutine finds the eigenvalues of a SYMMETRIC
C     TRIDIAGONAL matrix by the rational QL method.
C
C     On Input
C
C        N is the order of the matrix.
C
C        D contains the diagonal elements of the input matrix.
C
C        E2 contains the squares of the subdiagonal elements of the
C          input matrix in its last N-1 positions.  E2(1) is arbitrary.
C
C      On Output
C
C        D contains the eigenvalues in ascending order.  If an
C          error exit is made, the eigenvalues are correct and
C          ordered for indices 1,2,...IERR-1, but may not be
C          the smallest eigenvalues.
C
C        E2 has been destroyed.
C
C        IERR is set to
C          Zero       for normal return,
C          J          if the J-th eigenvalue has not been
C                     determined after 30 iterations.
C
C     Calls PYTHAG(A,B) for sqrt(A**2 + B**2).
C
C     Questions and comments should be directed to B. S. Garbow,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C     ------------------------------------------------------------------
C***REFERENCES  B. T. SMITH, J. M. BOYLE, J. J. DONGARRA, B. S. GARBOW,
C                 Y. IKEBE, V. C. KLEMA, C. B. MOLER, *MATRIX EIGEN-
C                 SYSTEM ROUTINES - EISPACK GUIDE*, SPRINGER-VERLAG,
C                 1976.
C***ROUTINES CALLED  PYTHAG
C***END PROLOGUE  TQLRAT
C
      INTEGER I,J,L,M,N,II,L1,MML,IERR
      REAL D(N),E2(N)
      REAL B,C,F,G,H,P,R,S,MACHEP
      REAL PYTHAG
C
      DATA MACHEP/1.0E0/
C***FIRST EXECUTABLE STATEMENT  TQLRAT
      IF (MACHEP .NE. 1.0E0) GO TO 10
   05 MACHEP = 0.5E0*MACHEP
      IF (1.0E0 + MACHEP .GT. 1.0E0) GO TO 05
      MACHEP = 2.0E0*MACHEP
C
   10 IERR = 0
      IF (N .EQ. 1) GO TO 1001
C
      DO 100 I = 2, N
  100 E2(I-1) = E2(I)
C
      F = 0.0E0
      B = 0.0E0
      E2(N) = 0.0E0
C
      DO 290 L = 1, N
         J = 0
         H = MACHEP * (ABS(D(L)) + SQRT(E2(L)))
         IF (B .GT. H) GO TO 105
         B = H
         C = B * B
C     .......... LOOK FOR SMALL SQUARED SUB-DIAGONAL ELEMENT ..........
  105    DO 110 M = L, N
            IF (E2(M) .LE. C) GO TO 120
C     .......... E2(N) IS ALWAYS ZERO, SO THERE IS NO EXIT
C                THROUGH THE BOTTOM OF THE LOOP ..........
  110    CONTINUE
C
  120    IF (M .EQ. L) GO TO 210
  130    IF (J .EQ. 30) GO TO 1000
         J = J + 1
C     .......... FORM SHIFT ..........
         L1 = L + 1
         S = SQRT(E2(L))
         G = D(L)
         P = (D(L1) - G) / (2.0E0 * S)
         R = PYTHAG(P,1.0E0)
         D(L) = S / (P + SIGN(R,P))
         H = G - D(L)
C
         DO 140 I = L1, N
  140    D(I) = D(I) - H
C
         F = F + H
C     .......... RATIONAL QL TRANSFORMATION ..........
         G = D(M)
         IF (G .EQ. 0.0E0) G = B
         H = G
         S = 0.0E0
         MML = M - L
C     .......... FOR I=M-1 STEP -1 UNTIL L DO -- ..........
         DO 200 II = 1, MML
            I = M - II
            P = G * H
            R = P + E2(I)
            E2(I+1) = S * R
            S = E2(I) / R
            D(I+1) = H + S * (H + D(I))
            G = D(I) - E2(I) / G
            IF (G .EQ. 0.0E0) G = B
            H = G * P / R
  200    CONTINUE
C
         E2(L) = S * G
         D(L) = H
C     .......... GUARD AGAINST UNDERFLOW IN CONVERGENCE TEST ..........
         IF (H .EQ. 0.0E0) GO TO 210
         IF (ABS(E2(L)) .LE. ABS(C/H)) GO TO 210
         E2(L) = H * E2(L)
         IF (E2(L) .NE. 0.0E0) GO TO 130
  210    P = D(L) + F
C     .......... ORDER EIGENVALUES ..........
         IF (L .EQ. 1) GO TO 250
C     .......... FOR I=L STEP -1 UNTIL 2 DO -- ..........
         DO 230 II = 2, L
            I = L + 2 - II
            IF (P .GE. D(I-1)) GO TO 270
            D(I) = D(I-1)
  230    CONTINUE
C
  250    I = 1
  270    D(I) = P
  290 CONTINUE
C
      GO TO 1001
C     .......... SET ERROR -- NO CONVERGENCE TO AN
C                EIGENVALUE AFTER 30 ITERATIONS ..........
 1000 IERR = L
 1001 RETURN
      END
      SUBROUTINE TRACDF(X,A,B,C,D,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE TRAPEZOID DISTRIBUTION.
C              THIS DISTRIBUTION HAS THE FOLLOWING CDF FUNCTION:
C              F(X,A,B,C,D) = 0                   X <  A
C                           = (B-A)/(D+C-B-A)*((X-A)/(B-A))**2   A<=X<B
C                           = ((B-A)+2*(X-B))/(D+C-B-A)          B<=X<C
C                           = 1-(D-C)/(D+C-B-A)*((D-X)/(D-C))**2 C<=X<D
C                           = 1                                  X>D
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                     --A      = THE SINGLE PRECISION SHAPE PARAMETER
C                       B      = THE SINGLE PRECISION SHAPE PARAMETER
C                       C      = THE SINGLE PRECISION SHAPE PARAMETER
C                       D      = THE SINGLE PRECISION SHAPE PARAMETER
C     OUTPUT ARGUMENTS--CDF    = THE SINGLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE CDF.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 
C     RESTRICTIONS--X SHOULD BE BETWEEN A AND D, INCLUSIVELY.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN. 
C     REFERENCES--J. RENE VAN DORP AND SAMIEL KOTZ, "GENERALIZED
C                 TRAPEZOIDAL DISTRIBUTIONS", METRIKA, VOL. 58,
C                 ISSUE 1, JULY 2003.
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--JUNE      2003. 
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(A.GE.B .OR. B.GE.C .OR. C.GE.D)THEN
        WRITE(ICOUT,12)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,13)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,14)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,16)A,B,C,D
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9000
      ENDIF
   12 FORMAT(
     1'***** FATAL ERROR--FOR THE TRAPEZOID DISTRIBUTION, THE FOUR')
   13 FORMAT(
     1'      SHAPE PARAMETERS (A, B, C, D) MUST SATISFY')
   14 FORMAT(
     1'         A < B < C < D')
   16 FORMAT(
     1'      A, B, C, D = ',4E15.7)
C
C-----START POINT-----------------------------------------------------
C
      IF(A.LE.X .AND. X.LT.B)THEN
        TERM1=(B-A)/(D+C-B-A)
        TERM2=((X-A)/(B-A))**2
        CDF=TERM1*TERM2
      ELSEIF(B.LE.X .AND. X.LT.C)THEN
        CDF=((B-A) + 2*(X-B))/(D+C-B-A)
      ELSEIF(C.LE.X .AND. X.LT.D)THEN
        TERM1=(D-C)/(D+C-B-A)
        TERM2=((D-X)/(D-C))**2
        CDF=1.0 - TERM1*TERM2
      ELSEIF(X.GE.D)THEN
        CDF=1.0
      ELSE
        CDF=0.0
      ENDIF
C
 9000 CONTINUE
      RETURN
      END 
      SUBROUTINE TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
C     PURPOSE--PRINT OUT A TRACE LINE FOR DEBUGGING.
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--JANUARY 1979.
C     UPDATED         --DECEMBER  1981.
C     UPDATED         --MAY       1982.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 ISTEPN
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
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,105)ISTEPN,ISUBN1,ISUBN2
  105 FORMAT('TRACE AT STEP ',A4,' OF ',A4,A4)
      CALL DPWRST('XXX','BUG ')
C
      RETURN
      END
      SUBROUTINE TRAN(N,ANU,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE STUDENT'S T DISTRIBUTION
C              WITH INTEGER DEGREES OF FREEDOM PARAMETER = NU.
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) FOR THE T
C                                DISTRIBUTION.
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST N)
C                                INTO WHICH THE GENERATED
C                                RANDOM SAMPLE WILL BE PLACED.
C     OUTPUT--A RANDOM SAMPLE OF SIZE N
C             FROM THE STUDENT'S T DISTRIBUTION
C             WITH DEGREES OF FREEDOM PARAMETER = NU.
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     FORTRAN LIBRARY SUBROUTINES NEEDED--ALOG, SQRT, SIN, COS.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--MOOD AND GRABLE, INTRODUCTION TO THE
C                 THEORY OF STATISTICS, 1963, PAGE 233.
C               --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--2, 1970, PAGE 94.
C               --HASTINGS AND PEACOCK, STATISTICAL
C                 DISTRIBUTIONS--A HANDBOOK FOR
C                 STUDENTS AND PRACTITIONERS, 1975,
C                 PAGE 121.
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--82.6
C     ORIGINAL VERSION--NOVEMBER  1975.
C     UPDATED         --DECEMBER  1981.
C     UPDATED         --MAY       1982.
C     UPDATED         --MAY       2004. SUPPORT NON-INTEGER DEGREES
C                                       OF FREEDOM
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
      DIMENSION Y(2),Z(2)
C
      CHARACTER*4 ICASE
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      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)GOTO50
      IF(ANU.LE.0.0)GOTO60
      GOTO90
   50 WRITE(ICOUT,5)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,47)N
      CALL DPWRST('XXX','BUG ')
      RETURN
   60 WRITE(ICOUT,15)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,48)ANU
      CALL DPWRST('XXX','BUG ')
      RETURN
   90 CONTINUE
    5 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO THE ',
     1'TRAN   SUBROUTINE IS NON-POSITIVE *****')
   15 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO THE ',
     1'TRAN   SUBROUTINE IS NON-POSITIVE *****')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
   48 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',F12.5,' *****')
C
      NU=INT(ANU+0.1)
      ANU2=REAL(NU)
      IF(ABS(ANU-ANU2).LE.EPS)THEN
        ICASE='INTE'
        IF(NU.EQ.0)THEN
          ICASE='REAL'
          ANU=EPS
        ENDIF
      ELSE
        ICASE='REAL'
      ENDIF
C
C     CASE 1: INTEGER DEGREES OF FREEDOM
C
      IF(ICASE.EQ.'INTE')THEN
C       GENERATE N STUDENT'S T RANDOM NUMBERS
C       USING THE DEFINITION THAT
C       A STUDENT'S T VARIATE WITH NU DEGREES OF FREEDOM
C       EQUALS A NORMAL VARIATE DIVIDED BY
C       A STANDARDIZED CHI VARIATE
C       (WHERE THE LATTER EQUALS SQRT(CHI-SQUARED/NU).
C       FIRST GENERATE A NORMAL RANDOM NUMBER,
C       THEN GENERATE A STANDARDIZED CHI RANDOM NUMBER,
C       THEN FORM THE RATIO OF THE FIRST DIVIDED BY
C       THE SECOND.
C
        ANU=NU
        DO100I=1,N
C
        CALL UNIRAN(2,ISEED,Y)
        ARG1=-2.0*ALOG(Y(1))
        ARG2=2.0*PI*Y(2)
        ZNORM=(SQRT(ARG1))*(COS(ARG2))
C
        SUM=0.0
        DO200J=1,NU,2
        CALL UNIRAN(2,ISEED,Y)
        ARG1=-2.0*ALOG(Y(1))
        ARG2=2.0*PI*Y(2)
        Z(1)=(SQRT(ARG1))*(COS(ARG2))
        Z(2)=(SQRT(ARG1))*(SIN(ARG2))
        SUM=SUM+Z(1)*Z(1)
        IF(J.EQ.NU)GOTO200
        SUM=SUM+Z(2)*Z(2)
  200   CONTINUE
C
        X(I)=ZNORM/SQRT(SUM/ANU)
C
  100  CONTINUE
C
      ELSE
        DO300I=1,N
          ATEMP=RDT(ANU,ISEED)
          X(I)=ATEMP
  300   CONTINUE
      ENDIF
      RETURN
      END
      DOUBLE PRECISION FUNCTION TRAN02(XVALUE)
C
C  DESCRIPTION:
C
C    This program calculates the transport integral of order 2, defined as
C
C      TRAN02(X) = integral 0 to X { t**2 exp(t)/[exp(t)-1]**2 } dt
C
C    The program uses a Chebyshev series, the coefficients of which are
C    given to an accuracy of 20 decimal places.
C
C
C  ERROR RETURNS:
C
C    If XVALUE < 0.0, an error message is printed, and the program 
C    returns the value 0.0. 
C
C
C  MACHINE-DEPENDENT CONSTANTS:
C
C    NTERMS - INTEGER - The number of terms of the array ATRAN to be used.
C                       The recommended value is such that
C                             ATRAN(NTERMS) < EPS/100
C
C    XLOW1 - DOUBLE PRECISION - The value below which TRAN02 = x to
C                   machine precision. The recommended value is
C                             sqrt(8*EPSNEG)
C
C    XHIGH1 - DOUBLE PRECISION - The value above which the exponential series for
C                    large x contains only one term. The recommended value
C                    is        - ln(EPS).
C
C    XHIGH2 - DOUBLE PRECISION - The value above which 
C                       TRAN02 = VALINF  -  x**2 exp(-x)
C                    The recommended value is 2/EPS
C
C    XHIGH3 - DOUBLE PRECISION - The value of ln(EPSNEG). Used to prevent overflow
C                    for large x.
C
C     For values of EPS, EPSNEG, and XMIN refer to the file MACHCON.TXT
C
C     The machine-dependent constants are computed internally by
C     using the D1MACH subroutine.
C
C
C  INTRINSIC FUNCTIONS USED:
C
C     EXP, INT, LOG, SQRT
C
C
C   OTHER MISCFUN SUBROUTINES USED:
C
C          CHEVAL , ERRPRN, D1MACH
C
C
C  AUTHOR:
C
C     DR. ALLAN J. MACLEOD,
C     DEPT. OF MATHEMATICS AND STATISTICS,
C     UNIVERSITY OF PAISLEY ,
C     HIGH ST.,
C     PAISLEY,
C     SCOTLAND.
C     PA1 2BE.
C
C     (e-mail: macl_ms0@paisley.ac.uk )
C
C
C  LATEST REVISION:    23 January, 1996
C
C
      INTEGER K1,K2,NTERMS,NUMEXP,NUMJN
      DOUBLE PRECISION ATRAN(0:19),CHEVAL,EIGHT,FOUR,HALF,ONE,ONEHUN,RK,
     &     RNUMJN,SUMEXP,SUM2,T,VALINF,X,XHIGH1,XHIGH2,
     &     XHIGH3,XK,XK1,XLOW1,XVALUE,ZERO
CCCCC CHARACTER FNNAME*6,ERRMSG*14
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
CCCCC DATA FNNAME/'TRAN02'/
CCCCC DATA ERRMSG/'ARGUMENT < 0.0'/
      DATA ZERO,HALF,ONE/ 0.0 D 0 , 0.5 D 0 , 1.0 D 0 /
      DATA FOUR,EIGHT,ONEHUN/ 4.0 D 0 , 8.0 D 0 , 100.0 D 0 /
      DATA NUMJN,RNUMJN/ 2 , 2.0 D 0 /
      DATA VALINF/0.32898 68133 69645 28729 D 1/
      DATA ATRAN/1.67176 04464 34538 50301  D    0,
     1          -0.14773 53599 46794 48986  D    0,
     2           0.14821 38199 46936 3384   D   -1,
     3          -0.14195 33032 63056 126    D   -2,
     4           0.13065 41324 41570 83     D   -3,
     5          -0.11715 57958 67579 0      D   -4,
     6           0.10333 49844 57557        D   -5,
     7          -0.90191 13042 227          D   -7,
     8           0.78177 16983 31           D   -8,
     9          -0.67445 65684 0            D   -9,
     X           0.57994 63945              D  -10,
     1          -0.49747 6185               D  -11,
     2           0.42596 097                D  -12,
     3          -0.36421 89                 D  -13,
     4           0.31108 6                  D  -14,
     5          -0.26547                    D  -15,
     6           0.2264                     D  -16,
     7          -0.193                      D  -17,
     8           0.16                       D  -18,
     9          -0.1                        D  -19/
C
C  Start execution
C
      X = XVALUE
C
C  Error test
C
      IF ( X .LT. ZERO ) THEN
CCCCC    CALL ERRPRN(FNNAME,ERRMSG)
         WRITE(ICOUT,999)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,101)X
         CALL DPWRST('XXX','BUG ')
         TRAN02 = ZERO
         RETURN
      ENDIF
  999 FORMAT(1X)
  101 FORMAT('***** ERROR FROM TRAN02--ARGUMENT MUST BE ',
     1       'NON-NEGATIVE, ARGUMENT = ',G15.7)
C
C   Compute the machine-dependent constants.
C
      XK = D1MACH(3)
      T = XK / ONEHUN
      IF ( X .LE. FOUR ) THEN
         DO 10 NTERMS = 19 , 0 , -1
            IF ( ABS(ATRAN(NTERMS)) .GT. T ) GOTO 19
 10      CONTINUE
 19      XLOW1 = SQRT( EIGHT * XK )
      ELSE
         XHIGH1 = - LOG(D1MACH(4))
         XHIGH2 = ONE / (HALF * XK)
         XHIGH3 = LOG(XK)
      ENDIF
C
C   Code for x < =  4.0
C
      IF ( X .LE. FOUR ) THEN
         IF ( X .LT. XLOW1 ) THEN
            TRAN02 =  ( X ** ( NUMJN - 1 ) ) / ( RNUMJN - ONE ) 
         ELSE
            T = ( ( ( X * X ) / EIGHT ) - HALF ) - HALF
            TRAN02 = ( X ** ( NUMJN - 1 ) ) * CHEVAL(NTERMS,ATRAN,T) 
         ENDIF
      ELSE
C 
C  Code for x > 4.0
C
         IF ( X .GT. XHIGH2 ) THEN
            SUMEXP = ONE
         ELSE
            IF ( X .LE. XHIGH1 ) THEN
               NUMEXP = INT ( XHIGH1 / X ) + 1
               T = EXP(-X) 
            ELSE
               NUMEXP = 1
               T = ONE
            ENDIF
            RK = ZERO
            DO 100 K1 = 1 , NUMEXP
               RK = RK + ONE
  100       CONTINUE
            SUMEXP = ZERO
            DO 300 K1 = 1 , NUMEXP
               SUM2 = ONE
               XK = ONE / ( RK * X ) 
               XK1 = ONE
               DO 200 K2 = 1 , NUMJN
                  SUM2 = SUM2 * XK1 * XK + ONE
                  XK1 = XK1 + ONE
  200          CONTINUE
               SUMEXP = SUMEXP * T + SUM2
               RK = RK - ONE
  300       CONTINUE
         ENDIF
         T = RNUMJN * LOG(X) - X + LOG(SUMEXP) 
         IF ( T .LT. XHIGH3 ) THEN
            TRAN02 = VALINF
         ELSE
            TRAN02 = VALINF - EXP(T) 
         ENDIF
      ENDIF
      RETURN
      END
      DOUBLE PRECISION FUNCTION TRAN03(XVALUE)
C
C  DESCRIPTION:
C
C    This program calculates the transport integral of order 3, defined as
C
C      TRAN03(X) = integral 0 to X { t**3 exp(t)/[exp(t)-1]**2 } dt
C
C    The program uses a Chebyshev series, the coefficients of which are
C    given to an accuracy of 20 decimal places.
C
C
C  ERROR RETURNS:
C
C    If XVALUE < 0.0, an error message is printed, and the program 
C    returns the value 0.0. 
C
C
C  MACHINE-DEPENDENT CONSTANTS:
C
C    NTERMS - INTEGER - The number of terms of the array ATRAN to be used.
C                       The recommended value is such that
C                             ATRAN(NTERMS) < EPS/100
C
C    XLOW2 - DOUBLE PRECISION - The value below which TRAN03 = 0.0 to machine
C                    precision. The recommended value is
C                          square root of (2*XMIN)
C
C    XLOW1 - DOUBLE PRECISION - The value below which TRAN03 = X**2/2 to
C                   machine precision. The recommended value is
C                             sqrt(8*EPSNEG)
C
C    XHIGH1 - DOUBLE PRECISION - The value above which the exponential series for
C                    large X contains only one term. The recommended value
C                    is        - ln(EPS).
C
C    XHIGH2 - DOUBLE PRECISION - The value above which 
C                       TRAN03 = VALINF  -  X**3 exp(-X)
C                    The recommended value is 3/EPS
C
C    XHIGH3 - DOUBLE PRECISION - The value of ln(EPSNEG). Used to prevent overflow
C                    for large x.
C
C     For values of EPS, EPSNEG, and XMIN refer to the file MACHCON.TXT
C
C     The machine-dependent constants are computed internally by
C     using the D1MACH subroutine.
C
C
C  INTRINSIC FUNCTIONS USED:
C
C     EXP, INT, LOG, SQRT
C
C
C   OTHER MISCFUN SUBROUTINES USED:
C
C          CHEVAL , ERRPRN, D1MACH
C
C
C  AUTHOR:
C
C     DR. ALLAN J. MACLEOD,
C     DEPT. OF MATHEMATICS AND STATISTICS,
C     UNIVERSITY OF PAISLEY ,
C     HIGH ST.,
C     PAISLEY,
C     SCOTLAND.
C     PA1 2BE.
C
C     (e-mail: macl_ms0@paisley.ac.uk )
C
C
C  LATEST REVISION:   23 January, 1996
C
C
      INTEGER K1,K2,NTERMS,NUMEXP,NUMJN
      DOUBLE PRECISION ATRAN(0:19),CHEVAL,EIGHT,FOUR,HALF,ONE,ONEHUN,RK,
     &     RNUMJN,SUMEXP,SUM2,T,VALINF,X,XHIGH1,XHIGH2,
     &     XHIGH3,XK,XK1,XLOW1,XLOW2,XVALUE,ZERO
CCCCC CHARACTER FNNAME*6,ERRMSG*14
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
CCCCC DATA FNNAME/'TRAN03'/
CCCCC DATA ERRMSG/'ARGUMENT < 0.0'/
      DATA ZERO,HALF,ONE/ 0.0 D 0 , 0.5 D 0 , 1.0 D 0/
      DATA FOUR,EIGHT,ONEHUN/ 4.0 D 0 , 8.0 D 0 , 100.0 D 0 /
      DATA NUMJN,RNUMJN/ 3 , 3.0 D 0 /
      DATA VALINF/0.72123 41418 95756 57124 D 1/
      DATA ATRAN/0.76201 25432 43872 00657  D    0,
     1          -0.10567 43877 05058 53250  D    0,
     2           0.11977 80848 19657 8097   D   -1,
     3          -0.12144 01520 36983 073    D   -2,
     4           0.11550 99769 39285 47     D   -3,
     5          -0.10581 59921 24422 9      D   -4,
     6           0.94746 63385 3018         D   -6,
     7          -0.83622 12128 581          D   -7,
     8           0.73109 09927 75           D   -8,
     9          -0.63505 94778 8            D   -9,
     X           0.54911 82819              D  -10,
     1          -0.47321 3954               D  -11,
     2           0.40676 948                D  -12,
     3          -0.34897 06                 D  -13,
     4           0.29892 3                  D  -14,
     5          -0.25574                    D  -15,
     6           0.2186                     D  -16,
     7          -0.187                      D  -17,
     8           0.16                       D  -18,
     9          -0.1                        D  -19/
C
C  Start execution
C
      X = XVALUE
C
C  Error test
C
      IF ( X .LT. ZERO ) THEN
CCCCC    CALL ERRPRN(FNNAME,ERRMSG)
         WRITE(ICOUT,999)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,101)X
         CALL DPWRST('XXX','BUG ')
         TRAN03 = ZERO
         RETURN
      ENDIF
  999 FORMAT(1X)
  101 FORMAT('***** ERROR FROM TRAN03--ARGUMENT MUST BE ',
     1       'NON-NEGATIVE, ARGUMENT = ',G15.7)
C
C   Compute the machine-dependent constants.
C
      XK = D1MACH(3)
      T = XK / ONEHUN
      IF ( X .LE. FOUR ) THEN
         DO 10 NTERMS = 19 , 0 , -1
            IF ( ABS(ATRAN(NTERMS)) .GT. T ) GOTO 19
 10      CONTINUE
 19      XLOW1 = SQRT( EIGHT * XK )
         XLOW2 = SQRT( D1MACH(1) / HALF )
      ELSE
         XHIGH1 = - LOG(D1MACH(4))
         XHIGH2 = RNUMJN / XK
         XHIGH3 = LOG(XK)
      ENDIF
C
C   Code for x < =  4.0
C
      IF ( X .LE. FOUR ) THEN
         IF ( X .LT. XLOW2 ) THEN
            TRAN03 = ZERO
         ELSE
            IF ( X .LT. XLOW1 ) THEN
               TRAN03 = ( X**(NUMJN-1) ) / ( RNUMJN - ONE )
            ELSE
               T = ( ( ( X*X ) / EIGHT ) - HALF ) - HALF
               TRAN03 = ( X**(NUMJN-1) ) * CHEVAL(NTERMS,ATRAN,T)
            ENDIF
         ENDIF
      ELSE
C 
C  Code for x > 4.0
C
         IF ( X .GT. XHIGH2 ) THEN
            SUMEXP = ONE
         ELSE
            IF ( X .LE. XHIGH1 ) THEN
               NUMEXP = INT(XHIGH1/X) + 1
               T = EXP(-X)
            ELSE
               NUMEXP = 1
               T = ONE
            ENDIF
            RK = ZERO
            DO 100 K1 = 1 , NUMEXP
               RK = RK + ONE
  100       CONTINUE
            SUMEXP = ZERO
            DO 300 K1 = 1 , NUMEXP
               SUM2 = ONE
               XK = ONE / ( RK * X )
               XK1 = ONE
               DO 200 K2 = 1 , NUMJN
                  SUM2 = SUM2 * XK1 * XK + ONE
                  XK1 = XK1 + ONE
  200          CONTINUE
               SUMEXP = SUMEXP * T + SUM2
               RK = RK - ONE
  300       CONTINUE
         ENDIF
         T = RNUMJN * LOG(X) - X + LOG(SUMEXP)
         IF ( T .LT. XHIGH3 ) THEN
            TRAN03 = VALINF
         ELSE
            TRAN03 = VALINF - EXP(T)
         ENDIF
      ENDIF
      RETURN
      END
      DOUBLE PRECISION FUNCTION TRAN04(XVALUE)
C
C  DESCRIPTION:
C
C    This program calculates the transport integral of order 4, defined as
C
C      TRAN04(X) = integral 0 to X { t**4 exp(t)/[exp(t)-1]**2 } dt
C
C    The program uses a Chebyshev series, the coefficients of which are
C    given to an accuracy of 20 decimal places.
C
C
C  ERROR RETURNS:
C
C    If XVALUE < 0.0, an error message is printed, and the program 
C    returns the value 0.0. 
C
C
C  MACHINE-DEPENDENT CONSTANTS:
C
C    NTERMS - INTEGER - The number of terms of the array ATRAN to be used.
C                       The recommended value is such that
C                             ATRAN(NTERMS) < EPS/100
C
C    XLOW2 - DOUBLE PRECISION - The value below which TRAN04 = 0.0 to machine
C                   precision. The recommended value is
C                          cube root of (3*XMIN)
C
C    XLOW1 - DOUBLE PRECISION - The value below which TRAN04 = X**3/3 to
C                   machine precision. The recommended value is
C                             sqrt(8*EPSNEG)
C
C    XHIGH1 - DOUBLE PRECISION - The value above which the exponential series for
C                    large X contains only one term. The recommended value
C                    is        - ln(EPS).
C
C    XHIGH2 - DOUBLE PRECISION - The value above which 
C                       TRAN04 = VALINF  -  X**4 exp(-X)
C                    The recommended value is 4/EPS
C
C    XHIGH3 - DOUBLE PRECISION - The value of ln(EPSNEG). Used to prevent overflow
C                    for large x.
C
C
C    For values of EPS, EPSNEG, and XMIN refer to the file MACHCON.TXT
C
C     The machine-dependent constants are computed internally by
C     using the D1MACH subroutine.
C
C
C  INTRINSIC FUNCTIONS USED:
C
C     EXP, INT, LOG, SQRT
C
C
C   OTHER MISCFUN SUBROUTINES USED:
C
C          CHEVAL , ERRPRN, D1MACH
C
C
C  AUTHOR:
C
C     DR. ALLAN J. MACLEOD,
C     DEPT. OF MATHEMATICS AND STATISTICS,
C     UNIVERSITY OF PAISLEY ,
C     HIGH ST.,
C     PAISLEY,
C     SCOTLAND.
C     PA1 2BE.
C
C     (e-mail: macl_ms0@paisley.ac.uk )
C
C
C  LATEST REVISION:   23 January, 1996
C
      INTEGER K1,K2,NTERMS,NUMEXP,NUMJN
      DOUBLE PRECISION ATRAN(0:19),CHEVAL,EIGHT,FOUR,HALF,ONE,ONEHUN,RK,
     &     RNUMJN,SUMEXP,SUM2,T,VALINF,X,XHIGH1,XHIGH2,
     &     XHIGH3,XK,XK1,XLOW1,XLOW2,XVALUE,ZERO
CCCCC CHARACTER FNNAME*6,ERRMSG*14
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
CCCCC DATA FNNAME/'TRAN04'/
CCCCC DATA ERRMSG/'ARGUMENT < 0.0'/
      DATA ZERO,HALF,ONE/ 0.0 D 0 , 0.5 D 0 , 1.0 D 0 /
      DATA FOUR,EIGHT,ONEHUN/ 4.0 D 0 , 8.0 D 0 , 100.0 D 0 /
      DATA NUMJN,RNUMJN/ 4 , 4.0 D 0 / 
      DATA VALINF/0.25975 75760 90673 16596 D 2/
      DATA ATRAN/0.48075 70994 61511 05786  D    0,
     1          -0.81753 78810 32108 3956   D   -1,
     2           0.10027 00665 97516 2973   D   -1,
     3          -0.10599 33935 98201 507    D   -2,
     4           0.10345 06245 03040 53     D   -3,
     5          -0.96442 70548 58991        D   -5,
     6           0.87455 44408 5147         D   -6,
     7          -0.77932 12079 811          D   -7,
     8           0.68649 88614 10           D   -8,
     9          -0.59995 71076 4            D   -9,
     X           0.52136 62413              D  -10,
     1          -0.45118 3819               D  -11,
     2           0.38921 592                D  -12,
     3          -0.33493 60                 D  -13,
     4           0.28766 7                  D  -14,
     5          -0.24668                    D  -15,
     6           0.2113                     D  -16,
     7          -0.181                      D  -17,
     8           0.15                       D  -18,
     9          -0.1                        D  -19/
C
C  Start execution
C
      X = XVALUE
C
C  Error test
C
      IF ( X .LT. ZERO ) THEN
CCCCC    CALL ERRPRN(FNNAME,ERRMSG)
         WRITE(ICOUT,999)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,101)X
         CALL DPWRST('XXX','BUG ')
         TRAN04 = ZERO
         RETURN
      ENDIF
  999 FORMAT(1X)
  101 FORMAT('***** ERROR FROM TRAN04--ARGUMENT MUST BE ',
     1       'NON-NEGATIVE, ARGUMENT = ',G15.7)
C
C   Compute the machine-dependent constants.
C
      XK = D1MACH(3)
      T = XK / ONEHUN
      IF ( X .LE. FOUR ) THEN
         DO 10 NTERMS = 19 , 0 , -1
            IF ( ABS(ATRAN(NTERMS)) .GT. T ) GOTO 19
 10      CONTINUE
 19      XLOW1 = SQRT( EIGHT * XK )
         XK1 = RNUMJN - ONE
         XLOW2 = ( XK1 * D1MACH(1) ) ** (ONE/XK1)
      ELSE
         XHIGH1 = - LOG(D1MACH(4))
         XHIGH2 = RNUMJN / XK
         XHIGH3 = LOG(XK)
      ENDIF
C
C   Code for x < =  4.0
C
      IF ( X .LE. FOUR ) THEN
         IF ( X .LT. XLOW2 ) THEN
            TRAN04 = ZERO
         ELSE
            IF ( X .LT. XLOW1 ) THEN
               TRAN04 =  ( X ** ( NUMJN-1 ) ) / ( RNUMJN - ONE ) 
            ELSE
               T = ( ( ( X * X ) / EIGHT ) - HALF ) - HALF
               TRAN04 = ( X ** ( NUMJN-1 ) ) * CHEVAL(NTERMS,ATRAN,T) 
            ENDIF
         ENDIF
      ELSE
C 
C  Code for x > 4.0
C
         IF ( X .GT. XHIGH2 ) THEN
            SUMEXP = ONE
         ELSE
            IF ( X .LE. XHIGH1 ) THEN
               NUMEXP = INT ( XHIGH1 / X ) + 1
               T = EXP ( -X ) 
            ELSE
               NUMEXP = 1
               T = ONE
            ENDIF
            RK = ZERO
            DO 100 K1 = 1 , NUMEXP
               RK = RK + ONE
  100       CONTINUE
            SUMEXP = ZERO
            DO 300 K1 = 1 , NUMEXP
               SUM2 = ONE
               XK = ONE/ ( RK * X ) 
               XK1 = ONE
               DO 200 K2 = 1 , NUMJN
                  SUM2 = SUM2 * XK1 * XK + ONE
                  XK1 = XK1 + ONE
  200          CONTINUE
               SUMEXP = SUMEXP * T + SUM2
               RK = RK - ONE
  300       CONTINUE
         ENDIF
         T = RNUMJN * LOG( X ) - X + LOG( SUMEXP ) 
         IF ( T .LT. XHIGH3 ) THEN
            TRAN04 = VALINF
         ELSE
            TRAN04 = VALINF - EXP( T ) 
         ENDIF
      ENDIF
      RETURN
      END
      DOUBLE PRECISION FUNCTION TRAN05(XVALUE)
C
C  DESCRIPTION:
C
C    This program calculates the transport integral of order n, defined as
C
C      TRAN05(X) = integral 0 to X { t**5 exp(t)/[exp(t)-1]**2 } dt
C
C    The program uses a Chebyshev series, the coefficients of which are
C    given to an accuracy of 20 decimal places.
C
C
C  ERROR RETURNS:
C
C    If XVALUE < 0.0, an error message is printed, and the program 
C    returns the value 0.0. 
C
C
C  MACHINE-DEPENDENT CONSTANTS:
C
C    NTERMS - INTEGER - The number of terms of the array ATRAN to be used.
C                       The recommended value is such that
C                             ATRAN(NTERMS) < EPS/100
C
C    XLOW2 - DOUBLE PRECISION - The value below which TRAN05 = 0.0 to machine
C                   precision. The recommended value is
C                          4th root of (4*XMIN)
C
C    XLOW1 - DOUBLE PRECISION - The value below which TRAN05 = X**4/4 to
C                   machine precision. The recommended value is
C                             sqrt(8*EPSNEG)
C
C    XHIGH1 - DOUBLE PRECISION - The value above which the exponential series for
C                    large X contains only one term. The recommended value
C                    is        - ln(EPS).
C
C    XHIGH2 - DOUBLE PRECISION - The value above which 
C                       TRAN05 = VALINF  -  X**5 exp(-X)
C                    The recommended value is 5/EPS
C
C    XHIGH3 - DOUBLE PRECISION - The value of ln(EPSNEG). Used to prevent overflow
C                    for large x.
C
C     For values of EPS, EPSNEG, and XMIN refer to the file MACHCON.TXT
C
C     The machine-dependent constants are computed internally by
C     using the D1MACH subroutine.
C
C
C  INTRINSIC FUNCTIONS USED:
C
C     EXP, INT, LOG, SQRT
C
C
C   OTHER MISCFUN SUBROUTINES USED:
C
C          CHEVAL , ERRPRN, D1MACH
C
C
C  AUTHOR:
C
C     DR. ALLAN J. MACLEOD,
C     DEPT. OF MATHEMATICS AND STATISTICS,
C     UNIVERSITY OF PAISLEY ,
C     HIGH ST.,
C     PAISLEY,
C     SCOTLAND.
C     PA1 2BE.
C
C     (e-mail: macl_ms0@paisley.ac.uk )
C
C
C  LATEST REVISION:  23 January, 1996
C
C
      INTEGER K1,K2,NTERMS,NUMEXP,NUMJN
      DOUBLE PRECISION ATRAN(0:19),CHEVAL,EIGHT,FOUR,HALF,ONE,ONEHUN,RK,
     &     RNUMJN,SUMEXP,SUM2,T,VALINF,X,XHIGH1,XHIGH2,
     &     XHIGH3,XK,XK1,XLOW1,XLOW2,XVALUE,ZERO
CCCC  CHARACTER FNNAME*6,ERRMSG*14
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
CCCCC DATA FNNAME/'TRAN05'/
CCCCC DATA ERRMSG/'ARGUMENT < 0.0'/
      DATA ZERO,HALF,ONE/ 0.0 D 0 , 0.5 D 0 , 1.0 D 0 /
      DATA FOUR,EIGHT,ONEHUN/ 4.0 D 0 , 8.0 D 0 , 100.0 D 0 /
      DATA NUMJN,RNUMJN/ 5 , 5.0 D 0 /
      DATA VALINF/0.12443 13306 17204 39116 D 3/
      DATA ATRAN/0.34777 77771 33910 78928  D    0,
     1          -0.66456 98897 60504 2801   D   -1,
     2           0.86110 72656 88330 882    D   -2,
     3          -0.93966 82223 75553 84     D   -3,
     4           0.93632 48060 81513 4      D   -4,
     5          -0.88571 31934 08328        D   -5,
     6           0.81191 49891 4503         D   -6,
     7          -0.72957 65423 277          D   -7,
     8           0.64697 14550 45           D   -8,
     9          -0.56849 02825 5            D   -9,
     X           0.49625 59787              D  -10,
     1          -0.43109 3996               D  -11,
     2           0.37310 094                D  -12,
     3          -0.32197 69                 D  -13,
     4           0.27722 0                  D  -14,
     5          -0.23824                    D  -15,
     6           0.2044                     D  -16,
     7          -0.175                      D  -17,
     8           0.15                       D  -18,
     9          -0.1                        D  -19/
C
C  Start execution
C
      X = XVALUE
C
C  Error test
C
      IF ( X .LT. ZERO ) THEN
CCCCC    CALL ERRPRN(FNNAME,ERRMSG)
         WRITE(ICOUT,999)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,101)X
         CALL DPWRST('XXX','BUG ')
         TRAN05 = ZERO
         RETURN
      ENDIF
  999 FORMAT(1X)
  101 FORMAT('***** ERROR FROM TRAN05--ARGUMENT MUST BE ',
     1       'NON-NEGATIVE, ARGUMENT = ',G15.7)
C
C   Compute the machine-dependent constants.
C
      XK = D1MACH(3)
      T = XK / ONEHUN
      IF ( X .LE. FOUR ) THEN
         DO 10 NTERMS = 19 , 0 , -1
            IF ( ABS(ATRAN(NTERMS)) .GT. T ) GOTO 19
 10      CONTINUE
 19      XLOW1 = SQRT( EIGHT * XK )
         XK1 = RNUMJN - ONE
         XLOW2 = ( XK1 * D1MACH(1) ) ** (ONE/XK1)
      ELSE
         XHIGH1 = - LOG(D1MACH(4))
         XHIGH2 = RNUMJN / XK
         XHIGH3 = LOG(XK)
      ENDIF
C
C   Code for x < =  4.0
C
      IF ( X .LE. FOUR ) THEN
         IF ( X .LT. XLOW2 ) THEN
            TRAN05 = ZERO
         ELSE
            IF ( X .LT. XLOW1 ) THEN
               TRAN05 =  ( X ** ( NUMJN - 1 ) ) / ( RNUMJN - ONE ) 
            ELSE
               T = ( ( ( X * X ) / EIGHT ) - HALF ) - HALF
               TRAN05 = ( X ** ( NUMJN-1 ) ) * CHEVAL(NTERMS,ATRAN,T) 
            ENDIF
         ENDIF
      ELSE
C 
C  Code for x > 4.0
C
         IF ( X .GT. XHIGH2 ) THEN
            SUMEXP = ONE
         ELSE
            IF ( X .LE. XHIGH1 ) THEN
               NUMEXP = INT ( XHIGH1 / X )  + 1
               T = EXP ( -X ) 
            ELSE
               NUMEXP = 1
               T = ONE
            ENDIF
            RK = ZERO
            DO 100 K1 = 1 , NUMEXP
               RK = RK + ONE
  100       CONTINUE
            SUMEXP = ZERO
            DO 300 K1 = 1 , NUMEXP
               SUM2 = ONE
               XK = ONE / ( RK * X ) 
               XK1 = ONE
               DO 200 K2 = 1 , NUMJN
                  SUM2 = SUM2 * XK1 * XK + ONE
                  XK1 = XK1 + ONE
  200          CONTINUE
               SUMEXP = SUMEXP * T + SUM2
               RK = RK - ONE
  300       CONTINUE
         ENDIF
         T = RNUMJN * LOG ( X ) - X + LOG( SUMEXP ) 
         IF ( T .LT. XHIGH3 ) THEN
            TRAN05 = VALINF
         ELSE
            TRAN05 = VALINF - EXP( T ) 
         ENDIF
      ENDIF
      RETURN
      END
      DOUBLE PRECISION FUNCTION TRAN06(XVALUE)
C
C  DESCRIPTION:
C
C    This program calculates the transport integral of order 6, defined as
C
C      TRAN06(X) = integral 0 to X { t**6 exp(t)/[exp(t)-1]**2 } dt
C
C    The program uses a Chebyshev series, the coefficients of which are
C    given to an accuracy of 20 decimal places.
C
C
C  ERROR RETURNS:
C
C    If XVALUE < 0.0, an error message is printed, and the program 
C    returns the value 0.0. 
C
C
C  MACHINE-DEPENDENT CONSTANTS:
C
C    NTERMS - INTEGER - The number of terms of the array ATRAN to be used.
C                       The recommended value is such that
C                             ATRAN(NTERMS) < EPS/100
C
C    XLOW2 - DOUBLE PRECISION - The value below which TRAN06 = 0.0 to machine
C                   precision. The recommended value is
C                          5th root of (5*XMIN)
C
C    XLOW1 - DOUBLE PRECISION - The value below which TRAN06 = X**5/5 to
C                   machine precision. The recommended value is
C                             sqrt(8*EPSNEG)
C
C    XHIGH1 - DOUBLE PRECISION - The value above which the exponential series for
C                    large X contains only one term. The recommended value
C                    is        - ln(EPS).
C
C    XHIGH2 - DOUBLE PRECISION - The value above which 
C                       TRAN06 = VALINF  -  X**6 exp(-X)
C                    The recommended value is 6/EPS
C
C    XHIGH3 - DOUBLE PRECISION - The value of ln(EPSNEG). Used to prevent overflow
C                    for large x.
C
C     For values of EPS, EPSNEG, and XMIN refer to the file MACHCON.TXT
C
C     The machine-dependent constants are computed internally by
C     using the D1MACH subroutine.
C
C
C  INTRINSIC FUNCTIONS USED:
C
C     EXP, INT, LOG, SQRT
C
C
C   OTHER MISCFUN SUBROUTINES USED:
C
C          CHEVAL , ERRPRN, D1MACH
C
C
C  AUTHOR:
C
C     DR. ALLAN J. MACLEOD,
C     DEPT. OF MATHEMATICS AND STATISTICS,
C     UNIVERSITY OF PAISLEY ,
C     HIGH ST.,
C     PAISLEY,
C     SCOTLAND.
C     PA1 2BE.
C
C     (e-mail: macl_ms0@paisley.ac.uk )
C
C
C  LATEST REVISION:   23 January, 1996
C
      INTEGER K1,K2,NTERMS,NUMEXP,NUMJN
      DOUBLE PRECISION ATRAN(0:19),CHEVAL,EIGHT,FOUR,HALF,ONE,ONEHUN,RK,
     &     RNUMJN,SUMEXP,SUM2,T,VALINF,X,XHIGH1,XHIGH2,
     &     XHIGH3,XK,XK1,XLOW1,XLOW2,XVALUE,ZERO
CCCCC CHARACTER FNNAME*6,ERRMSG*14
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
CCCCC DATA FNNAME/'TRAN06'/
CCCCC DATA ERRMSG/'ARGUMENT < 0.0'/
      DATA ZERO,HALF,ONE/ 0.0 D 0 , 0.5 D 0 , 1.0 D 0 /
      DATA FOUR,EIGHT,ONEHUN/ 4.0 D 0 , 8.0 D 0 , 100.0 D 0 /
      DATA NUMJN,RNUMJN/ 6 , 6.0 D 0 /
      DATA VALINF/0.73248 70046 28803 38059 D 3/
      DATA ATRAN/0.27127 33539 78400 08227  D    0,
     1          -0.55886 10553 19145 3393   D   -1,
     2           0.75391 95132 90083 056    D   -2,
     3          -0.84351 13857 92112 19     D   -3,
     4           0.85490 98079 67670 2      D   -4,
     5          -0.81871 54932 93098        D   -5,
     6           0.75754 24042 7986         D   -6,
     7          -0.68573 06541 831          D   -7,
     8           0.61170 03760 31           D   -8,
     9          -0.54012 70702 4            D   -9,
     X           0.47343 06435              D  -10,
     1          -0.41270 1055               D  -11,
     2           0.35825 603                D  -12,
     3          -0.30997 52                 D  -13,
     4           0.26750 1                  D  -14,
     5          -0.23036                    D  -15,
     6           0.1980                     D  -16,
     7          -0.170                      D  -17,
     8           0.15                       D  -18,
     9          -0.1                        D  -19/
C
C  Start execution
C
      X = XVALUE
C
C  Error test
C
      IF ( X .LT. ZERO ) THEN
CCCCC    CALL ERRPRN(FNNAME,ERRMSG)
         WRITE(ICOUT,999)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,101)X
         CALL DPWRST('XXX','BUG ')
         TRAN06 = ZERO
         RETURN
      ENDIF
  999 FORMAT(1X)
  101 FORMAT('***** ERROR FROM TRAN06--ARGUMENT MUST BE ',
     1       'NON-NEGATIVE, ARGUMENT = ',G15.7)
C
C   Compute the machine-dependent constants.
C
      XK = D1MACH(3)
      T = XK / ONEHUN
      IF ( X .LE. FOUR ) THEN
         DO 10 NTERMS = 19 , 0 , -1
            IF ( ABS(ATRAN(NTERMS)) .GT. T ) GOTO 19
 10      CONTINUE
 19      XLOW1 = SQRT( EIGHT * XK )
         XK1 = RNUMJN - ONE
         XLOW2 = ( XK1 * D1MACH(1) ) ** (ONE/XK1)
      ELSE
         XHIGH1 = - LOG(D1MACH(4))
         XHIGH2 = RNUMJN / XK
         XHIGH3 = LOG(XK)
      ENDIF
C
C   Code for x < =  4 .0
C
      IF ( X .LE. FOUR ) THEN
         IF ( X .LT. XLOW2 ) THEN
            TRAN06 = ZERO
         ELSE
            IF ( X .LT. XLOW1 ) THEN
               TRAN06 =  ( X ** ( NUMJN-1 ) ) / ( RNUMJN - ONE ) 
            ELSE
               T =  ( ( ( X * X ) / EIGHT ) - HALF ) - HALF
               TRAN06 = ( X ** ( NUMJN-1 )  ) * CHEVAL(NTERMS,ATRAN,T) 
            ENDIF
         ENDIF
      ELSE
C 
C  Code for x > 4 .0
C
         IF ( X .GT. XHIGH2 ) THEN
            SUMEXP = ONE
         ELSE
            IF ( X .LE. XHIGH1 ) THEN
               NUMEXP = INT ( XHIGH1 / X ) + 1
               T = EXP( - X ) 
            ELSE
               NUMEXP = 1
               T = ONE
            ENDIF
            RK = ZERO
            DO 100 K1 = 1 , NUMEXP
               RK = RK + ONE
  100       CONTINUE
            SUMEXP = ZERO
            DO 300 K1 = 1 , NUMEXP
               SUM2 = ONE
               XK = ONE / ( RK * X ) 
               XK1 = ONE
               DO 200 K2 = 1 , NUMJN
                  SUM2 = SUM2 * XK1 * XK + ONE
                  XK1 = XK1 + ONE
  200          CONTINUE
               SUMEXP = SUMEXP * T + SUM2
               RK = RK - ONE
  300       CONTINUE
         ENDIF
         T = RNUMJN * LOG( X ) - X + LOG( SUMEXP ) 
         IF ( T .LT. XHIGH3 ) THEN
            TRAN06 = VALINF
         ELSE
            TRAN06 = VALINF - EXP( T ) 
         ENDIF
      ENDIF
      RETURN
      END
      DOUBLE PRECISION FUNCTION TRAN07(XVALUE)
C
C  DESCRIPTION:
C
C    This program calculates the transport integral of order 7, defined as
C
C      TRAN07(X) = integral 0 to X { t**7 exp(t)/[exp(t)-1]**2 } dt
C
C    The program uses a Chebyshev series, the coefficients of which are
C    given to an accuracy of 20 decimal places.
C
C
C  ERROR RETURNS:
C
C    If XVALUE < 0.0, an error message is printed, and the program 
C    returns the value 0.0. 
C
C
C  MACHINE-DEPENDENT CONSTANTS:
C
C    NTERMS - INTEGER - The number of terms of the array ATRAN to be used.
C                       The recommended value is such that
C                             ATRAN(NTERMS) < EPS/100
C
C    XLOW2 - DOUBLE PRECISION - The value below which TRAN07 = 0.0 to machine
C                   precision. The recommended value is
C                          6th root of (6*XMIN)
C
C    XLOW1 - DOUBLE PRECISION - The value below which TRAN07 = X**6/6 to
C                   machine precision. The recommended value is
C                             sqrt(8*EPSNEG)
C
C    XHIGH1 - DOUBLE PRECISION - The value above which the exponential series for
C                    large X contains only one term. The recommended value
C                    is        - ln(EPS).
C
C    XHIGH2 - DOUBLE PRECISION - The value above which 
C                       TRAN07 = VALINF  -  X**7 exp(-X)
C                    The recommended value is 7/EPS
C
C    XHIGH3 - DOUBLE PRECISION - The value of ln(EPSNEG). Used to prevent overflow
C                    for large x.
C
C     For values of EPS, EPSNEG, and XMIN refer to the file MACHCON.TXT
C
C     The machine-dependent constants are computed internally by
C     using the D1MACH subroutine.
C
C
C  INTRINSIC FUNCTIONS USED:
C
C     EXP, INT, LOG, SQRT
C
C
C   OTHER MISCFUN SUBROUTINES USED:
C
C          CHEVAL , ERRPRN, D1MACH
C
C
C  AUTHOR:
C
C     DR. ALLAN J. MACLEOD,
C     DEPT. OF MATHEMATICS AND STATISTICS,
C     UNIVERSITY OF PAISLEY ,
C     HIGH ST.,
C     PAISLEY,
C     SCOTLAND.
C     PA1 2BE.
C
C     (e-mail: macl_ms0@paisley.ac.uk )
C
C
C  LATEST REVISION:   23 January, 1996
C
      INTEGER K1,K2,NTERMS,NUMEXP,NUMJN
      DOUBLE PRECISION ATRAN(0:19),CHEVAL,EIGHT,FOUR,HALF,ONE,ONEHUN,RK,
     &     RNUMJN,SUMEXP,SUM2,T,VALINF,X,XHIGH1,XHIGH2,
     &     XHIGH3,XK,XK1,XLOW1,XLOW2,XVALUE,ZERO
CCCCC CHARACTER FNNAME*6,ERRMSG*14
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
CCCCC DATA FNNAME/'TRAN07'/
CCCCC DATA ERRMSG/'ARGUMENT < 0.0'/
      DATA ZERO,HALF,ONE/ 0.0 D 0 , 0.5 D 0 , 1.0 D 0/
      DATA FOUR,EIGHT,ONEHUN/ 4.0 D 0 , 8.0 D 0 , 100.0 D 0 /
      DATA NUMJN,RNUMJN/ 7 , 7.0 D 0/
      DATA VALINF/0.50820 80358 00489 10473 D 4/
      DATA ATRAN/0.22189 25073 40104 04423  D    0,
     1          -0.48167 51061 17799 3694   D   -1,
     2           0.67009 24481 03153 629    D   -2,
     3          -0.76495 18344 30825 57     D   -3,
     4           0.78634 85592 34869 0      D   -4,
     5          -0.76102 51808 87504        D   -5,
     6           0.70991 69629 9917         D   -6,
     7          -0.64680 25624 903          D   -7,
     8           0.58003 92339 60           D   -8,
     9          -0.51443 37014 9            D   -9,
     X           0.45259 44183              D  -10,
     1          -0.39580 0363               D  -11,
     2           0.34453 785                D  -12,
     3          -0.29882 92                 D  -13,
     4           0.25843 4                  D  -14,
     5          -0.22297                    D  -15,
     6           0.1920                     D  -16,
     7          -0.165                      D  -17,
     8           0.14                       D  -18,
     9          -0.1                        D  -19/
C
C  Start execution
C
      X = XVALUE
C
C  Error test
C
      IF ( X .LT. ZERO ) THEN
CCCCC    CALL ERRPRN(FNNAME,ERRMSG)
         WRITE(ICOUT,999)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,101)X
         CALL DPWRST('XXX','BUG ')
         TRAN07 = ZERO
         RETURN
      ENDIF
  999 FORMAT(1X)
  101 FORMAT('***** ERROR FROM TRAN07--ARGUMENT MUST BE ',
     1       'NON-NEGATIVE, ARGUMENT = ',G15.7)
C
C   Compute the machine-dependent constants.
C
      XK = D1MACH(3)
      T = XK / ONEHUN
      IF ( X .LE. FOUR ) THEN
         DO 10 NTERMS = 19 , 0 , -1
            IF ( ABS(ATRAN(NTERMS)) .GT. T ) GOTO 19
 10      CONTINUE
 19      XLOW1 = SQRT( EIGHT * XK )
         XK1 = RNUMJN - ONE
         XLOW2 = ( XK1 * D1MACH(1) ) ** (ONE/XK1)
      ELSE
         XHIGH1 = - LOG(D1MACH(4))
         XHIGH2 = RNUMJN / XK
         XHIGH3 = LOG(XK)
      ENDIF
C
C   Code for x <= 4.0
C
      IF ( X .LE. FOUR ) THEN
         IF ( X .LT. XLOW2 ) THEN
            TRAN07 = ZERO
         ELSE
            IF ( X .LT. XLOW1 ) THEN
               TRAN07 = ( X**(NUMJN-1) ) / ( RNUMJN - ONE )
            ELSE
               T = ( ( ( X*X ) / EIGHT ) - HALF ) - HALF
               TRAN07 = ( X**(NUMJN-1) ) * CHEVAL(NTERMS,ATRAN,T)
            ENDIF
         ENDIF
      ELSE
C 
C  Code for x > 4.0
C
         IF ( X .GT. XHIGH2 ) THEN
            SUMEXP = ONE
         ELSE
            IF ( X .LE. XHIGH1 ) THEN
               NUMEXP = INT ( XHIGH1/X ) + 1
               T = EXP( -X )
            ELSE
               NUMEXP = 1
               T = ONE
            ENDIF
            RK = ZERO
            DO 100 K1 = 1 , NUMEXP
               RK = RK + ONE
  100       CONTINUE
            SUMEXP = ZERO
            DO 300 K1 = 1 , NUMEXP
               SUM2 = ONE
               XK = ONE / ( RK * X )
               XK1 = ONE
               DO 200 K2 = 1 , NUMJN
                  SUM2 = SUM2 * XK1 * XK + ONE
                  XK1 = XK1 + ONE
  200          CONTINUE
               SUMEXP = SUMEXP * T + SUM2
               RK = RK - ONE
  300       CONTINUE
         ENDIF
         T = RNUMJN * LOG(X) - X + LOG(SUMEXP)
         IF ( T .LT. XHIGH3 ) THEN
            TRAN07 = VALINF
         ELSE
            TRAN07 = VALINF - EXP(T)
         ENDIF
      ENDIF
      RETURN
      END
      DOUBLE PRECISION FUNCTION TRAN08(XVALUE)
C
C  DESCRIPTION:
C
C    This program calculates the transport integral of order 8, defined as
C
C      TRAN08(X) = integral 0 to X { t**8 exp(t)/[exp(t)-1]**2 } dt
C
C    The program uses a Chebyshev series, the coefficients of which are
C    given to an accuracy of 20 decimal places.
C
C
C  ERROR RETURNS:
C
C    If XVALUE < 0.0, an error message is printed, and the program 
C    returns the value 0.0. 
C
C
C  MACHINE-DEPENDENT CONSTANTS:
C
C    NTERMS - INTEGER - The number of terms of the array ATRAN to be used.
C                       The recommended value is such that
C                             ATRAN(NTERMS) < EPS/100
C
C    XLOW2 - DOUBLE PRECISION - The value below which TRAN08 = 0.0 to machine
C                   precision. The recommended value is
C                          7th root of (7*XMIN)
C
C    XLOW1 - DOUBLE PRECISION - The value below which TRAN08 = X**7/7 to
C                   machine precision. The recommended value is
C                             sqrt(8*EPSNEG)
C
C    XHIGH1 - DOUBLE PRECISION - The value above which the exponential series for
C                    large X contains only one term. The recommended value
C                    is        - ln(EPS).
C
C    XHIGH2 - DOUBLE PRECISION - The value above which 
C                       TRAN08 = VALINF  -  X**8 exp(-X)
C                    The recommended value is 8/EPS
C
C    XHIGH3 - DOUBLE PRECISION - The value of ln(EPSNEG). Used to prevent overflow
C                    for large x.
C
C     For values of EPS, EPSNEG, and XMIN refer to the file MACHCON.TXT
C
C
C     The machine-dependent constants are computed internally by
C     using the D1MACH subroutine.
C
C
C  INTRINSIC FUNCTIONS USED:
C
C     EXP, INT, LOG, SQRT
C
C
C   OTHER MISCFUN SUBROUTINES USED:
C
C          CHEVAL , ERRPRN, D1MACH
C
C
C  AUTHOR:
C
C     DR. ALLAN J. MACLEOD,
C     DEPT. OF MATHEMATICS AND STATISTICS,
C     UNIVERSITY OF PAISLEY ,
C     HIGH ST.,
C     PAISLEY,
C     SCOTLAND.
C     PA1 2BE.
C
C     (e-mail: macl_ms0@paisley.ac.uk )
C
C
C  LATEST REVISION:  23 January, 1996
C
      INTEGER K1,K2,NTERMS,NUMEXP,NUMJN
      DOUBLE PRECISION ATRAN(0:19),CHEVAL,EIGHT,FOUR,HALF,ONE,ONEHUN,RK,
     &     RNUMJN,SUMEXP,SUM2,T,VALINF,X,XHIGH1,XHIGH2,
     &     XHIGH3,XK,XK1,XLOW1,XLOW2,XVALUE,ZERO
CCCC  CHARACTER FNNAME*6,ERRMSG*14
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
CCCCC DATA FNNAME/'TRAN08'/
CCCCC DATA ERRMSG/'ARGUMENT < 0.0'/
      DATA ZERO,HALF,ONE/ 0.0 D 0 , 0.5 D 0 , 1.0 D 0 /
      DATA FOUR,EIGHT,ONEHUN/ 4.0 D 0 , 8.0 D 0 , 100.0 D 0 /
      DATA NUMJN,RNUMJN/ 8 , 8.0 D 0 /
      DATA VALINF/0.40484 39900 19011 15764 D 5/
      DATA ATRAN/0.18750 69577 40437 19233  D    0,
     1          -0.42295 27646 09367 3337   D   -1,
     2           0.60281 48569 29065 592    D   -2,
     3          -0.69961 05481 18147 76     D   -3,
     4           0.72784 82421 29878 9      D   -4,
     5          -0.71084 62500 50067        D   -5,
     6           0.66786 70689 0115         D   -6,
     7          -0.61201 57501 844          D   -7,
     8           0.55146 52644 74           D   -8,
     9          -0.49105 30705 2            D   -9,
     X           0.43350 00869              D  -10,
     1          -0.38021 8700               D  -11,
     2           0.33182 369                D  -12,
     3          -0.28845 12                 D  -13,
     4           0.24995 8                  D  -14,
     5          -0.21605                    D  -15,
     6           0.1863                     D  -16,
     7          -0.160                      D  -17,
     8           0.14                       D  -18,
     9          -0.1                        D  -19/
C
C  Start execution
C
      X = XVALUE
C
C  Error test
C
      IF ( X .LT. ZERO ) THEN
CCCCC    CALL ERRPRN(FNNAME,ERRMSG)
         WRITE(ICOUT,999)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,101)X
         CALL DPWRST('XXX','BUG ')
         TRAN08 = ZERO
         RETURN
      ENDIF
  999 FORMAT(1X)
  101 FORMAT('***** ERROR FROM TRAN08--ARGUMENT MUST BE ',
     1       'NON-NEGATIVE, ARGUMENT = ',G15.7)
C
C   Compute the machine-dependent constants.
C
      XK = D1MACH(3)
      T = XK / ONEHUN
      IF ( X .LE. FOUR ) THEN
         DO 10 NTERMS = 19 , 0 , -1
            IF ( ABS(ATRAN(NTERMS)) .GT. T ) GOTO 19
 10      CONTINUE
 19      XLOW1 = SQRT( EIGHT * XK )
         XK1 = RNUMJN - ONE
         XLOW2 = ( XK1 * D1MACH(1) ) ** (ONE/XK1)
      ELSE
         XHIGH1 = - LOG(D1MACH(4))
         XHIGH2 = RNUMJN / XK
         XHIGH3 = LOG(XK)
      ENDIF
C
C   Code for x < =  4.0
C
      IF ( X .LE. FOUR ) THEN
         IF ( X .LT. XLOW2 ) THEN
            TRAN08 = ZERO
         ELSE
            IF ( X .LT. XLOW1 ) THEN
               TRAN08 = ( X ** ( NUMJN - 1 ) ) / ( RNUMJN - ONE ) 
            ELSE
               T = ( ( ( X * X ) / EIGHT ) - HALF )  - HALF
               TRAN08 = ( X ** ( NUMJN - 1 ) ) * CHEVAL(NTERMS,ATRAN,T) 
            ENDIF
         ENDIF
      ELSE
C 
C  Code for x > 4.0
C
         IF ( X .GT. XHIGH2 ) THEN
            SUMEXP = ONE
         ELSE
            IF ( X .LE. XHIGH1 ) THEN
               NUMEXP = INT ( XHIGH1 / X ) + 1
               T = EXP ( - X ) 
            ELSE
               NUMEXP = 1
               T = ONE
            ENDIF
            RK = ZERO
            DO 100 K1 = 1 , NUMEXP
               RK = RK + ONE
  100       CONTINUE
            SUMEXP = ZERO
            DO 300 K1 = 1 , NUMEXP
               SUM2 = ONE
               XK = ONE / ( RK * X ) 
               XK1 = ONE
               DO 200 K2 = 1 , NUMJN
                  SUM2 = SUM2 * XK1 * XK + ONE
                  XK1 = XK1 + ONE
  200          CONTINUE
               SUMEXP = SUMEXP * T + SUM2
               RK = RK - ONE
  300       CONTINUE
         ENDIF
         T = RNUMJN * LOG( X ) - X + LOG( SUMEXP ) 
         IF ( T .LT. XHIGH3 ) THEN
            TRAN08 = VALINF
         ELSE
            TRAN08 = VALINF - EXP( T ) 
         ENDIF
      ENDIF
      RETURN
      END
      DOUBLE PRECISION FUNCTION TRAN09(XVALUE)
C
C  DESCRIPTION:
C
C    This program calculates the transport integral of order 9, defined as
C
C      TRAN09(X) = integral 0 to X { t**9 exp(t)/[exp(t)-1]**2 } dt
C
C    The program uses a Chebyshev series, the coefficients of which are
C    given to an accuracy of 20 decimal places.
C
C
C  ERROR RETURNS:
C
C    If XVALUE < 0.0, an error message is printed, and the program 
C    returns the value 0.0. 
C
C
C  MACHINE-DEPENDENT CONSTANTS:
C
C    NTERMS - INTEGER - The number of terms of the array ATRAN to be used.
C                       The recommended value is such that
C                             ATRAN(NTERMS) < EPS/100
C
C    XLOW2 - DOUBLE PRECISION - The value below which TRAN09 = 0.0 to machine
C                   precision. The recommended value is
C                          8th root of (8*XMIN)
C
C    XLOW1 - DOUBLE PRECISION - The value below which TRAN09 = X**8/8 to
C                   machine precision. The recommended value is
C                             sqrt(8*EPSNEG)
C
C    XHIGH1 - DOUBLE PRECISION - The value above which the exponential series for
C                    large X contains only one term. The recommended value
C                    is        - ln(EPS).
C
C    XHIGH2 - DOUBLE PRECISION - The value above which 
C                       TRAN09 = VALINF  -  X**9 exp(-X)
C                    The recommended value is 9/EPS
C
C    XHIGH3 - DOUBLE PRECISION - The value of ln(EPSNEG). Used to prevent overflow
C                    for large x.
C
C     For values of EPS, EPSNEG, and XMIN refer to the file MACHCON.TXT
C
C     The machine-dependent constants are computed internally by
C     using the D1MACH subroutine.
C
C
C  INTRINSIC FUNCTIONS USED:
C
C     EXP, INT, LOG, SQRT
C
C
C   OTHER MISCFUN SUBROUTINES USED:
C
C          CHEVAL , ERRPRN, D1MACH
C
C
C  AUTHOR:
C
C     DR. ALLAN J. MACLEOD,
C     DEPT. OF MATHEMATICS AND STATISTICS,
C     UNIVERSITY OF PAISLEY ,
C     HIGH ST.,
C     PAISLEY,
C     SCOTLAND.
C     PA1 2BE.
C
C     (e-mail: macl_ms0@paisley.ac.uk )
C
C
C  LATEST REVISION:   23 January, 1996
C
      INTEGER K1,K2,NTERMS,NUMEXP,NUMJN
      DOUBLE PRECISION ATRAN(0:19),CHEVAL,EIGHT,FOUR,HALF,ONE,ONEHUN,RK,
     &     RNUMJN,SUMEXP,SUM2,T,VALINF,X,XHIGH1,XHIGH2,
     &     XHIGH3,XK,XK1,XLOW1,XLOW2,XVALUE,ZERO
CCCCC CHARACTER FNNAME*6,ERRMSG*14
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
CCCCC DATA FNNAME/'TRAN09'/
CCCCC DATA ERRMSG/'ARGUMENT < 0.0'/
      DATA ZERO,HALF,ONE/ 0.0 D 0 , 0.5 D 0 , 1.0 D 0 /
      DATA FOUR,EIGHT,ONEHUN/ 4.0 D 0 , 8.0 D 0 , 100.0 D 0 /
      DATA NUMJN,RNUMJN/ 9 , 9.0 D 0 /
      DATA VALINF/0.36360 88055 88728 71397 D 6/
      DATA ATRAN/0.16224 04999 19498 46835  D    0,
     1          -0.37683 51452 19593 7773   D   -1,
     2           0.54766 97159 17719 770    D   -2,
     3          -0.64443 94500 94495 21     D   -3,
     4           0.67736 45285 28098 3      D   -4,
     5          -0.66681 34975 82042        D   -5,
     6           0.63047 56001 9047         D   -6,
     7          -0.58074 78663 611          D   -7,
     8           0.52555 13051 23           D   -8,
     9          -0.46968 86176 1            D   -9,
     X           0.41593 95065              D  -10,
     1          -0.36580 8491               D  -11,
     2           0.32000 794                D  -12,
     3          -0.27876 51                 D  -13,
     4           0.24201 7                  D  -14,
     5          -0.20953                    D  -15,
     6           0.1810                     D  -16,
     7          -0.156                      D  -17,
     8           0.13                       D  -18,
     9          -0.1                        D  -19/
C
C  Start execution
C
      X = XVALUE
C
C  Error test
C
      IF ( X .LT. ZERO ) THEN
CCCCC    CALL ERRPRN(FNNAME,ERRMSG)
         WRITE(ICOUT,999)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,101)X
         CALL DPWRST('XXX','BUG ')
         TRAN09 = ZERO
         RETURN
      ENDIF
  999 FORMAT(1X)
  101 FORMAT('***** ERROR FROM TRAN09--ARGUMENT MUST BE ',
     1       'NON-NEGATIVE, ARGUMENT = ',G15.7)
C
C   Compute the machine-dependent constants.
C
      XK = D1MACH(3)
      T = XK / ONEHUN
      IF ( X .LE. FOUR ) THEN
         DO 10 NTERMS = 19 , 0 , -1
            IF ( ABS(ATRAN(NTERMS)) .GT. T ) GOTO 19
 10      CONTINUE
 19      XLOW1 = SQRT( EIGHT * XK )
         XK1 = RNUMJN - ONE
         XLOW2 = ( XK1 * D1MACH(1) ) ** (ONE/XK1)
      ELSE
         XHIGH1 = - LOG(D1MACH(4))
         XHIGH2 = RNUMJN / XK
         XHIGH3 = LOG(XK)
      ENDIF
C
C   Code for x < =  4.0
C
      IF ( X .LE. FOUR ) THEN
         IF ( X .LT. XLOW2 ) THEN
            TRAN09 = ZERO
         ELSE
            IF ( X .LT. XLOW1 ) THEN
               TRAN09 = ( X ** ( NUMJN - 1 ) ) / ( RNUMJN - ONE ) 
            ELSE
               T = ( ( ( X * X ) / EIGHT ) - HALF ) - HALF
               TRAN09 = ( X ** ( NUMJN-1 ) ) * CHEVAL(NTERMS,ATRAN,T) 
            ENDIF
         ENDIF
      ELSE
C 
C  Code for x > 4.0
C
         IF ( X .GT. XHIGH2 ) THEN
            SUMEXP = ONE
         ELSE
            IF ( X .LE. XHIGH1 ) THEN
               NUMEXP = INT ( XHIGH1 / X ) + 1
               T = EXP( -X ) 
            ELSE
               NUMEXP = 1
               T = ONE
            ENDIF
            RK = ZERO
            DO 100 K1 = 1 , NUMEXP
               RK = RK + ONE
  100       CONTINUE
            SUMEXP = ZERO
            DO 300 K1 = 1 , NUMEXP
               SUM2 = ONE
               XK = ONE / ( RK * X ) 
               XK1 = ONE
               DO 200 K2 = 1 , NUMJN
                  SUM2 = SUM2 * XK1 * XK + ONE
                  XK1 = XK1 + ONE
  200          CONTINUE
               SUMEXP = SUMEXP * T + SUM2
               RK = RK - ONE
  300       CONTINUE
         ENDIF
         T = RNUMJN * LOG( X ) - X + LOG( SUMEXP ) 
         IF ( T.LT.XHIGH3 ) THEN
            TRAN09 = VALINF
         ELSE
            TRAN09 = VALINF - EXP( T ) 
         ENDIF
      ENDIF
      RETURN
      END
      SUBROUTINE TRAPDF(X,A,B,C,D,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE TRAPEZOID DISTRIBUTION.
C              THIS DISTRIBUTION HAS THE FOLLOWING PDF FUNCTION:
C                  f(X,A,B,C,D) = U*((X-A)/(B-A))     A <= X <  B
C                               = U                   B <= X <  C
C                               = U*((D-X)/(D-C))     C <= X <  D
C                               = 0                   X < A, X >= D
C              WHERE
C                  U = 2/(D+C-B-A), A <= B <= C <= D
C              THIS DISTRIBUTION MODELS THE SIMPLEST CASE OF 
C              A "GROWTH PHASE", A "STABLE PHASE", AND A "DECAY PHASE".
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                     --A      = THE SINGLE PRECISION SHAPE PARAMETER
C                       B      = THE SINGLE PRECISION SHAPE PARAMETER
C                       C      = THE SINGLE PRECISION SHAPE PARAMETER
C                       D      = THE SINGLE PRECISION SHAPE PARAMETER
C     OUTPUT ARGUMENTS--PDF    = THE SINGLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE PDF.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 
C     RESTRICTIONS--X SHOULD BE BETWEEN A AND D, INCLUSIVELY.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN. 
C     REFERENCES--J. RENE VAN DORP AND SAMIEL KOTZ, "GENERALIZED
C                 TRAPEZOIDAL DISTRIBUTIONS", METRIKA, VOL. 58,
C                 ISSUE 1, JULY 2003.
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--JUNE      2003. 
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(A.GE.B .OR. B.GE.C .OR. C.GE.D)THEN
        WRITE(ICOUT,12)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,13)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,14)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,16)A,B,C,D
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9000
      ENDIF
   12 FORMAT(
     1'***** FATAL ERROR--FOR THE TRAPEZOID DISTRIBUTION, THE FOUR')
   13 FORMAT(
     1'      SHAPE PARAMETERS (A, B, C, D) MUST SATISFY')
   14 FORMAT(
     1'         A < B < C < D')
   16 FORMAT(
     1'      A, B, C, D = ',4E15.7)
C
C-----START POINT-----------------------------------------------------
C
      IF(A.LE.X .AND. X.LT.B)THEN
        U=2.0/(D+C-B-A)
        PDF=U*((X-A)/(B-A))
      ELSEIF(B.LE.X .AND. X.LT.C)THEN
        U=2.0/(D+C-B-A)
        PDF=U
      ELSEIF(C.LE.X .AND. X.LT.D)THEN
        U=2.0/(D+C-B-A)
        PDF=U*((D-X)/(D-C))
      ELSE
        PDF=0.0
      ENDIF
C
 9000 CONTINUE
      RETURN
      END 
      SUBROUTINE TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,IXP,IYP)
C
C     PURPOSE--TRANSLATE AND ROTATE POINTS X AND Y
C              WHICH ARE BEING GENERATED ALONG THE X AXIS
C              TO CORRESPONDING POINTS IN WHICH THE
C              ORIGIN (0,0) HAS BEEN TRANSLATED TO (X1,Y1)
C              AND THE LINE SEQUENCE HAS BEEN ROTATED BY AN ANGLE THETA.
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--OCTOBER   1980
C     UPDATED         --FEBRUARY  1982.
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
C-----START POINT-----------------------------------------------------
C
      XROT=X*COS(THETA)-Y*SIN(THETA)
      YROT=X*SIN(THETA)+Y*COS(THETA)
C
      IF(DELX.GE.0.0)GOTO110
      GOTO120
C
  110 CONTINUE
      XP=X1+XROT
      YP=Y1+YROT
      GOTO900
C
  120 CONTINUE
      XP=X1-XROT
      YP=Y1-YROT
      GOTO900
C
  900 CONTINUE
      IXP=XP+0.5
      IYP=YP+0.5
C
      RETURN
      END
      SUBROUTINE TRAPPF(P,A,B,C,D,PPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE TRAPEZOID DISTRIBUTION.
C              THIS DISTRIBUTION HAS THE FOLLOWING CDF FUNCTION:
C              F(X,A,B,C,D) = 0                   X <  A
C                           = (B-A)/(D+C-B-A)*((X-A)/(B-A))**2   A<=X<B
C                           = ((B-A)+2*(X-B))/(D+C-B-A)          B<=X<C
C                           = 1-(D-C)/(D+C-B-A)*((D-X)/(D-C))**2 C<=X<D
C                           = 1                                  X>D
C              THE ALGORITHM FOR THE PPF IS TO COMPUTE THE CDF AT
C              X = A, X = B, X = C, AND X = D TO FIND THE APPROPRIATE
C              INTERVAL FOR P.  THEN INVERT THE APPROPRIATE EQUATION
C              ABOVE TO FIND THE PPF VALUE.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                     --A      = THE SINGLE PRECISION SHAPE PARAMETER
C                       B      = THE SINGLE PRECISION SHAPE PARAMETER
C                       C      = THE SINGLE PRECISION SHAPE PARAMETER
C                       D      = THE SINGLE PRECISION SHAPE PARAMETER
C     OUTPUT ARGUMENTS--PPF    = THE SINGLE PRECISION PERCENT POINT
C                                FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PERCENT POINT FUNCTION VALUE PPF.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 
C     RESTRICTIONS--P SHOULD BE BETWEEN 0 AND 1, INCLUSIVELY.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN. 
C     REFERENCES--J. RENE VAN DORP AND SAMIEL KOTZ, "GENERALIZED
C                 TRAPEZOIDAL DISTRIBUTIONS", METRIKA, VOL. 58,
C                 ISSUE 1, JULY 2003.
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--JUNE      2003. 
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(A.GE.B .OR. B.GE.C .OR. C.GE.D)THEN
        WRITE(ICOUT,12)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,13)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,14)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,16)A,B,C,D
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
        GOTO9000
      ENDIF
C
      IF(P.LT.0.0 .OR. P.GT.1.0)THEN
        WRITE(ICOUT,22)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,23)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,26)P
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
        GOTO9000
      ENDIF
C
   12 FORMAT(
     1'***** FATAL ERROR--FOR THE TRAPEZOID DISTRIBUTION, THE FOUR')
   13 FORMAT(
     1'      SHAPE PARAMETERS (A, B, C, D) MUST SATISFY')
   14 FORMAT(
     1'         A < B < C < D')
   16 FORMAT(
     1'      A, B, C, D = ',4E15.7)
   22 FORMAT(
     1'***** FATAL ERROR--FOR THE TRAPEZOID PERCENT POINT FUNCTION,')
   23 FORMAT(
     1'      THE VALUE OF THE INPUTR ARGUMENT IS OUTSIDE THE ',
     1'ALLOWABLE (0,1] INTERVAL.')
   26 FORMAT(
     1'      VALUE OF INPUT ARGUMENT = ',E15.7)
C
C-----START POINT-----------------------------------------------------
C
      P1=0.0
      CALL TRACDF(B,A,B,C,D,P2)
      CALL TRACDF(C,A,B,C,D,P3)
      P4=1.0
C
      IF(P.EQ.0.0)THEN
        PPF=A
        GOTO9000
      ELSEIF(P.EQ.1.0)THEN
        PPF=D
        GOTO9000
      ELSEIF(P.EQ.P2)THEN
        PPF=B
        GOTO9000
      ELSEIF(P.EQ.P3)THEN
        PPF=C
        GOTO9000
      ENDIF
C
      IF(P.GE.P1 .AND. P.LE.P2)THEN
        TERM1=(B-A)/(D+C-B-A)
        TERM2=B-A
        PPF=TERM2*SQRT(P/TERM1) + A
      ELSEIF(P.GE.P2 .AND. P.LE.P3)THEN
        TERM1=B-A
        TERM2=D+C-B-A
        PPF=0.5*(P*TERM2-TERM1) + B
      ELSEIF(P.GE.P3 .AND. P.LE.P4)THEN
        TERM1=(D-C)/(D+C-B-A)
        TERM2=D-C
        PPF=D - TERM2*SQRT((1.0-P)/TERM1)
      ENDIF
C
 9000 CONTINUE
      RETURN
      END 
      SUBROUTINE TRARAN(N,A,B,C,D,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE TRAPEZOID DISTRIBUTION
C              THIS DISTRIBUTION HAS THE FOLLOWING PDF FUNCTION:
C                  f(X,A,B,C,D) = U*((X-A)/(B-A))     A <= X <  B
C                               = U                   B <= X <  C
C                               = U*((D-X)/(D-C))     C <= X <  D
C                               = 0                   X < A, X >= D
C              WHERE
C                  U = 2/(D+C-B-A), A <= B <= C <= D
C              THIS DISTRIBUTION MODELS THE SIMPLEST CASE OF 
C              A "GROWTH PHASE", A "STABLE PHASE", AND A "DECAY PHASE".
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 TRAPEZOID 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, TRAPPF
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--J. RENE VAN DORP AND SAMIEL KOTZ, "GENERALIZED
C                 TRAPEZOIDAL DISTRIBUTIONS", METRIKA, VOL. 58,
C                 ISSUE 1, JULY 2003.
C               --TOCHER, THE ART OF SIMULATION,
C                 1963, PAGES 14-15.
C               --HAMMERSLEY AND HANDSCOMB, MONTE CARLO METHODS,
C                 1964, PAGE 36.
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--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
      ENDIF
    5 FORMAT('***** FATAL ERROR--THE FIRST INPUT ARGUMENT TO THE ',
     1'TRARAN SUBROUTINE IS NON-POSITIVE *****')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
      IF(A.GE.B .OR. B.GE.C .OR. C.GE.D)THEN
        WRITE(ICOUT,12)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,13)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,14)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,16)A,B,C,D
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9000
      ENDIF
   12 FORMAT(
     1'***** FATAL ERROR--FOR THE TRAPEZOID DISTRIBUTION, THE FOUR')
   13 FORMAT(
     1'      SHAPE PARAMETERS (A, B, C, D) MUST SATISFY')
   14 FORMAT(
     1'         A < B < C < D')
   16 FORMAT(
     1'      A, B, C, D = ',4E15.7)
C
C
C     GENERATE N UNIFORM (0,1) RANDOM NUMBERS;
C
      CALL UNIRAN(N,ISEED,X)
C
C     GENERATE N TRAPEZOID RANDOM NUMBERS
C     USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD.
C
      DO100I=1,N
      P=X(I)
      CALL TRAPPF(P,A,B,C,D,PPF)
      X(I)=PPF
  100 CONTINUE
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE TRED1(NM,N,A,D,E,E2)
C***BEGIN PROLOGUE  TRED1
C***DATE WRITTEN   760101   (YYMMDD)
C***REVISION DATE  830518   (YYMMDD)
C***CATEGORY NO.  D4C1B1
C***KEYWORDS  EIGENVALUES,EIGENVECTORS,EISPACK
C***AUTHOR  SMITH, B. T., ET AL.
C***PURPOSE  Reduce real symmetric matrix to symmetric tridiagonal
C            matrix using orthogonal similarity transformations.
C***DESCRIPTION
C
C     This subroutine is a translation of the ALGOL procedure TRED1,
C     NUM. MATH. 11, 181-195(1968) by Martin, Reinsch, and Wilkinson.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971).
C
C     This subroutine reduces a REAL SYMMETRIC matrix
C     to a symmetric tridiagonal matrix using
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        A contains the real symmetric input matrix.  Only the
C          lower triangle of the matrix need be supplied.
C
C     On Output
C
C        A contains information about the orthogonal trans-
C          formations used in the reduction in its strict lower
C          triangle.  The full upper triangle of A is unaltered.
C
C        D contains the diagonal elements of the tridiagonal matrix.
C
C        E contains the subdiagonal elements of the tridiagonal
C          matrix in its last N-1 positions.  E(1) is set to zero.
C
C        E2 contains the squares of the corresponding elements of E.
C          E2 may coincide with E if the squares are not needed.
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  TRED1
C
      INTEGER I,J,K,L,N,II,NM,JP1
      REAL A(NM,N),D(N),E(N),E2(N)
      REAL F,G,H,SCALE
C
C***FIRST EXECUTABLE STATEMENT  TRED1
      DO 100 I = 1, N
  100 D(I) = A(I,I)
C     .......... FOR I=N STEP -1 UNTIL 1 DO -- ..........
      DO 300 II = 1, N
         I = N + 1 - II
         L = I - 1
         H = 0.0E0
         SCALE = 0.0E0
         IF (L .LT. 1) GO TO 130
C     .......... SCALE ROW (ALGOL TOL THEN NOT NEEDED) ..........
         DO 120 K = 1, L
  120    SCALE = SCALE + ABS(A(I,K))
C
         IF (SCALE .NE. 0.0E0) GO TO 140
  130    E(I) = 0.0E0
         E2(I) = 0.0E0
         GO TO 290
C
  140    DO 150 K = 1, L
            A(I,K) = A(I,K) / SCALE
            H = H + A(I,K) * A(I,K)
  150    CONTINUE
C
         E2(I) = SCALE * SCALE * H
         F = A(I,L)
         G = -SIGN(SQRT(H),F)
         E(I) = SCALE * G
         H = H - F * G
         A(I,L) = F - G
         IF (L .EQ. 1) GO TO 270
         F = 0.0E0
C
         DO 240 J = 1, L
            G = 0.0E0
C     .......... FORM ELEMENT OF A*U ..........
            DO 180 K = 1, J
  180       G = G + A(J,K) * A(I,K)
C
            JP1 = J + 1
            IF (L .LT. JP1) GO TO 220
C
            DO 200 K = JP1, L
  200       G = G + A(K,J) * A(I,K)
C     .......... FORM ELEMENT OF P ..........
  220       E(J) = G / H
            F = F + E(J) * A(I,J)
  240    CONTINUE
C
         H = F / (H + H)
C     .......... FORM REDUCED A ..........
         DO 260 J = 1, L
            F = A(I,J)
            G = E(J) - H * F
            E(J) = G
C
            DO 260 K = 1, J
               A(J,K) = A(J,K) - F * E(K) - G * A(I,K)
  260    CONTINUE
C
  270    DO 280 K = 1, L
  280    A(I,K) = SCALE * A(I,K)
C
  290    H = D(I)
         D(I) = A(I,I)
         A(I,I) = H
  300 CONTINUE
C
      RETURN
      END
      SUBROUTINE TRED2(NM,N,A,D,E,Z)
C***BEGIN PROLOGUE  TRED2
C***DATE WRITTEN   760101   (YYMMDD)
C***REVISION DATE  830518   (YYMMDD)
C***CATEGORY NO.  D4C1B1
C***KEYWORDS  EIGENVALUES,EIGENVECTORS,EISPACK
C***AUTHOR  SMITH, B. T., ET AL.
C***PURPOSE  Reduce real symmetric matrix to symmetric tridiagonal
C            matrix using and accumulating orthogonal transformation
C***DESCRIPTION
C
C     This subroutine is a translation of the ALGOL procedure TRED2,
C     NUM. MATH. 11, 181-195(1968) by Martin, Reinsch, and Wilkinson.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971).
C
C     This subroutine reduces a REAL SYMMETRIC matrix to a
C     symmetric tridiagonal matrix using and accumulating
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        A contains the real symmetric input matrix.  Only the
C          lower triangle of the matrix need be supplied.
C
C     On Output
C
C        D contains the diagonal elements of the tridiagonal matrix.
C
C        E contains the subdiagonal elements of the tridiagonal
C          matrix in its last N-1 positions.  E(1) is set to zero.
C
C        Z contains the orthogonal transformation matrix
C          produced in the reduction.
C
C        A and Z may coincide.  If distinct, A is unaltered.
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  TRED2
C
      INTEGER I,J,K,L,N,II,NM,JP1
      REAL A(NM,N),D(N),E(N),Z(NM,N)
      REAL F,G,H,HH,SCALE
C
C***FIRST EXECUTABLE STATEMENT  TRED2
      DO 100 I = 1, N
C
         DO 100 J = 1, I
            Z(I,J) = A(I,J)
  100 CONTINUE
C
      IF (N .EQ. 1) GO TO 320
C     .......... FOR I=N STEP -1 UNTIL 2 DO -- ..........
      DO 300 II = 2, N
         I = N + 2 - II
         L = I - 1
         H = 0.0E0
         SCALE = 0.0E0
         IF (L .LT. 2) GO TO 130
C     .......... SCALE ROW (ALGOL TOL THEN NOT NEEDED) ..........
         DO 120 K = 1, L
  120    SCALE = SCALE + ABS(Z(I,K))
C
         IF (SCALE .NE. 0.0E0) GO TO 140
  130    E(I) = Z(I,L)
         GO TO 290
C
  140    DO 150 K = 1, L
            Z(I,K) = Z(I,K) / SCALE
            H = H + Z(I,K) * Z(I,K)
  150    CONTINUE
C
         F = Z(I,L)
         G = -SIGN(SQRT(H),F)
         E(I) = SCALE * G
         H = H - F * G
         Z(I,L) = F - G
         F = 0.0E0
C
         DO 240 J = 1, L
            Z(J,I) = Z(I,J) / H
            G = 0.0E0
C     .......... FORM ELEMENT OF A*U ..........
            DO 180 K = 1, J
  180       G = G + Z(J,K) * Z(I,K)
C
            JP1 = J + 1
            IF (L .LT. JP1) GO TO 220
C
            DO 200 K = JP1, L
  200       G = G + Z(K,J) * Z(I,K)
C     .......... FORM ELEMENT OF P ..........
  220       E(J) = G / H
            F = F + E(J) * Z(I,J)
  240    CONTINUE
C
         HH = F / (H + H)
C     .......... FORM REDUCED A ..........
         DO 260 J = 1, L
            F = Z(I,J)
            G = E(J) - HH * F
            E(J) = G
C
            DO 260 K = 1, J
               Z(J,K) = Z(J,K) - F * E(K) - G * Z(I,K)
  260    CONTINUE
C
  290    D(I) = H
  300 CONTINUE
C
  320 D(1) = 0.0E0
      E(1) = 0.0E0
C     .......... ACCUMULATION OF TRANSFORMATION MATRICES ..........
      DO 500 I = 1, N
         L = I - 1
         IF (D(I) .EQ. 0.0E0) GO TO 380
C
         DO 360 J = 1, L
            G = 0.0E0
C
            DO 340 K = 1, L
  340       G = G + Z(I,K) * Z(K,J)
C
            DO 360 K = 1, L
               Z(K,J) = Z(K,J) - G * Z(K,I)
  360    CONTINUE
C
  380    D(I) = Z(I,I)
         Z(I,I) = 1.0E0
         IF (L .LT. 1) GO TO 500
C
         DO 400 J = 1, L
            Z(I,J) = 0.0E0
            Z(J,I) = 0.0E0
  400    CONTINUE
C
  500 CONTINUE
C
      RETURN
      END
      SUBROUTINE TREGUP(NR,N,X,F,G,A,SC,SX,NWTAKE,STEPMX,
CDPLT SUBROUTINE TREGUP(NR,N,X,F,G,A,OPTFCN,SC,SX,NWTAKE,STEPMX,
     +     STEPTL,
     +     DLT,IRETCD,XPLSP,FPLSP,XPLS,FPLS,MXTAKE,IPR,METHOD,UDIAG)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C PURPOSE
C -------
C DECIDE WHETHER TO ACCEPT XPLS=X+SC AS THE NEXT ITERATE AND UPDATE THE
C TRUST REGION DLT.
C
C PARAMETERS
C ----------
C NR           --> ROW DIMENSION OF MATRIX
C N            --> DIMENSION OF PROBLEM
C X(N)         --> OLD ITERATE X[K-1]
C F            --> FUNCTION VALUE AT OLD ITERATE, F(X)
C G(N)         --> GRADIENT AT OLD ITERATE, G(X), OR APPROXIMATE
C A(N,N)       --> CHOLESKY DECOMPOSITION OF HESSIAN IN
C                  LOWER TRIANGULAR PART AND DIAGONAL.
C                  HESSIAN OR APPROX IN UPPER TRIANGULAR PART
C OPTFCN       --> NAME OF SUBROUTINE TO EVALUATE FUNCTION
C SC(N)        --> CURRENT STEP
C SX(N)        --> DIAGONAL SCALING MATRIX FOR X
C NWTAKE       --> BOOLEAN, =.TRUE. IF NEWTON STEP TAKEN
C STEPMX       --> MAXIMUM ALLOWABLE STEP SIZE
C STEPTL       --> RELATIVE STEP SIZE AT WHICH SUCCESSIVE ITERATES
C                  CONSIDERED CLOSE ENOUGH TO TERMINATE ALGORITHM
C DLT         <--> TRUST REGION RADIUS
C IRETCD      <--> RETURN CODE
C                    =0 XPLS ACCEPTED AS NEXT ITERATE;
C                       DLT TRUST REGION FOR NEXT ITERATION.
C                    =1 XPLS UNSATISFACTORY BUT ACCEPTED AS NEXT ITERATE
C                       BECAUSE XPLS-X .LT. SMALLEST ALLOWABLE
C                       STEP LENGTH.
C                    =2 F(XPLS) TOO LARGE.  CONTINUE CURRENT ITERATION
C                       WITH NEW REDUCED DLT.
C                    =3 F(XPLS) SUFFICIENTLY SMALL, BUT QUADRATIC MODEL
C                       PREDICTS F(XPLS) SUFFICIENTLY WELL TO CONTINUE
C                       CURRENT ITERATION WITH NEW DOUBLED DLT.
C XPLSP(N)    <--> WORKSPACE [VALUE NEEDS TO BE RETAINED BETWEEN
C                  SUCCESIVE CALLS OF K-TH GLOBAL STEP]
C FPLSP       <--> [RETAIN VALUE BETWEEN SUCCESSIVE CALLS]
C XPLS(N)     <--  NEW ITERATE X[K]
C FPLS        <--  FUNCTION VALUE AT NEW ITERATE, F(XPLS)
C MXTAKE      <--  BOOLEAN FLAG INDICATING STEP OF MAXIMUM LENGTH USED
C IPR          --> DEVICE TO WHICH TO SEND OUTPUT
C METHOD       --> ALGORITHM TO USE TO SOLVE MINIMIZATION PROBLEM
C                    =1 LINE SEARCH
C                    =2 DOUBLE DOGLEG
C                    =3 MORE-HEBDON
C UDIAG(N)     --> DIAGONAL OF HESSIAN IN A(.,.)
C
      DIMENSION X(N),XPLS(N),G(N)
      DIMENSION SX(N),SC(N),XPLSP(N)
      DIMENSION A(NR,1)
      LOGICAL NWTAKE,MXTAKE
      DIMENSION UDIAG(N)
C
      IPR=IPR
      MXTAKE=.FALSE.
      DO 100 I=1,N
        XPLS(I)=X(I)+SC(I)
  100 CONTINUE
      CALL OPTFCN(N,XPLS,FPLS)
      DLTF=FPLS-F
      SLP=DDOT(N,G,1,SC,1)
C
C NEXT STATEMENT ADDED FOR CASE OF COMPILERS WHICH DO NOT OPTIMIZE
C EVALUATION OF NEXT "IF" STATEMENT (IN WHICH CASE FPLSP COULD BE
C UNDEFINED).
      IF(IRETCD.EQ.4) FPLSP=0.0
C$    WRITE(IPR,961) IRETCD,FPLS,FPLSP,DLTF,SLP
      IF(IRETCD.NE.3 .OR. (FPLS.LT.FPLSP .AND. DLTF.LE. 1.E-4*SLP))
     +                                                     GO TO 130
C     IF(IRETCD.EQ.3 .AND. (FPLS.GE.FPLSP .OR. DLTF.GT. 1.E-4*SLP))
C     THEN
C
C       RESET XPLS TO XPLSP AND TERMINATE GLOBAL STEP
C
        IRETCD=0
        DO 110 I=1,N
          XPLS(I)=XPLSP(I)
  110   CONTINUE
        FPLS=FPLSP
        DLT=.5*DLT
C$      WRITE(IPR,951)
        GO TO 230
C     ELSE
C
C       FPLS TOO LARGE
C
  130   IF(DLTF.LE. 1.E-4*SLP) GO TO 170
C       IF(DLTF.GT. 1.E-4*SLP)
C       THEN
C$        WRITE(IPR,952)
          RLN=0.
          DO 140 I=1,N
            RLN=MAX(RLN,ABS(SC(I))/MAX(ABS(XPLS(I)),1./SX(I)))
  140     CONTINUE
C$        WRITE(IPR,962) RLN
          IF(RLN.GE.STEPTL) GO TO 150
C         IF(RLN.LT.STEPTL)
C         THEN
C
C           CANNOT FIND SATISFACTORY XPLS SUFFICIENTLY DISTINCT FROM X
C
            IRETCD=1
C$          WRITE(IPR,954)
            GO TO 230
C         ELSE
C
C           REDUCE TRUST REGION AND CONTINUE GLOBAL STEP
C
  150       IRETCD=2
            DLTMP=-SLP*DLT/(2.*(DLTF-SLP))
C$          WRITE(IPR,963) DLTMP
            IF(DLTMP.GE. .1*DLT) GO TO 155
C           IF(DLTMP.LT. .1*DLT)
C           THEN
              DLT=.1*DLT
              GO TO 160
C           ELSE
  155         DLT=DLTMP
C           ENDIF
  160       CONTINUE
C$          WRITE(IPR,955)
            GO TO 230
C         ENDIF
C       ELSE
C
C         FPLS SUFFICIENTLY SMALL
C
  170     CONTINUE
C$        WRITE(IPR,958)
          DLTFP=0.
          IF (METHOD .EQ. 3) GO TO 180
C
C         IF (METHOD .EQ. 2)
C         THEN
C
          DO 177 I = 1, N
             TEMP = 0.0
             DO 173 J = I, N
                TEMP = TEMP + (A(J, I)*SC(J))
  173        CONTINUE
             DLTFP = DLTFP + TEMP*TEMP
  177     CONTINUE
          GO TO 190
C
C         ELSE
C
  180     DO 187 I = 1, N
             DLTFP = DLTFP + UDIAG(I)*SC(I)*SC(I)
             IF (I .EQ. N) GO TO 187
             TEMP = 0
             IP1 = I + 1
             DO 183 J = IP1, N
                TEMP = TEMP + A(I, J)*SC(I)*SC(J)
  183        CONTINUE
             DLTFP = DLTFP + 2.0*TEMP
  187     CONTINUE
C
C         END IF
C
  190     DLTFP = SLP + DLTFP/2.0
C$        WRITE(IPR,964) DLTFP,NWTAKE
          IF(IRETCD.EQ.2 .OR. (ABS(DLTFP-DLTF).GT. .1*ABS(DLTF))
     +         .OR. NWTAKE .OR. (DLT.GT. .99*STEPMX)) GO TO 210
C         IF(IRETCD.NE.2 .AND. (ABS(DLTFP-DLTF) .LE. .1*ABS(DLTF))
C    +         .AND. (.NOT.NWTAKE) .AND. (DLT.LE. .99*STEPMX))
C         THEN
C
C           DOUBLE TRUST REGION AND CONTINUE GLOBAL STEP
C
            IRETCD=3
            DO 200 I=1,N
              XPLSP(I)=XPLS(I)
  200       CONTINUE
            FPLSP=FPLS
            DLT=MIN(2.*DLT,STEPMX)
C$          WRITE(IPR,959)
            GO TO 230
C         ELSE
C
C           ACCEPT XPLS AS NEXT ITERATE.  CHOOSE NEW TRUST REGION.
C
  210       CONTINUE
C$          WRITE(IPR,960)
            IRETCD=0
            IF(DLT.GT. .99*STEPMX) MXTAKE=.TRUE.
            IF(DLTF.LT. .1*DLTFP) GO TO 220
C           IF(DLTF.GE. .1*DLTFP)
C           THEN
C
C             DECREASE TRUST REGION FOR NEXT ITERATION
C
              DLT=.5*DLT
              GO TO 230
C           ELSE
C
C             CHECK WHETHER TO INCREASE TRUST REGION FOR NEXT ITERATION
C
  220         IF(DLTF.LE. .75*DLTFP) DLT=MIN(2.*DLT,STEPMX)
C           ENDIF
C         ENDIF
C       ENDIF
C     ENDIF
  230 CONTINUE
C$    WRITE(IPR,953)
C$    WRITE(IPR,956) IRETCD,MXTAKE,DLT,FPLS
C$    WRITE(IPR,957)
C$    WRITE(IPR,965) (XPLS(I),I=1,N)
      RETURN
C
CC951 FORMAT(55H TREGUP    RESET XPLS TO XPLSP. TERMINATION GLOBAL STEP)
CC952 FORMAT(26H TREGUP    FPLS TOO LARGE.)
CC953 FORMAT(38H0TREGUP    VALUES AFTER CALL TO TREGUP)
CC954 FORMAT(54H TREGUP    CANNOT FIND SATISFACTORY XPLS DISTINCT FROM,
CC   +       27H X.  TERMINATE GLOBAL STEP.)
CC955 FORMAT(53H TREGUP    REDUCE TRUST REGION. CONTINUE GLOBAL STEP.)
CC956 FORMAT(21H TREGUP       IRETCD=,I3/
CC   +       21H TREGUP       MXTAKE=,L1/
CC   +       21H TREGUP       DLT   =,E20.13/
CC   +       21H TREGUP       FPLS  =,E20.13)
CC957 FORMAT(32H TREGUP       NEW ITERATE (XPLS))
CC958 FORMAT(35H TREGUP    FPLS SUFFICIENTLY SMALL.)
CC959 FORMAT(54H TREGUP    DOUBLE TRUST REGION.  CONTINUE GLOBAL STEP.)
CC960 FORMAT(50H TREGUP    ACCEPT XPLS AS NEW ITERATE.  CHOOSE NEW,
CC   +       38H TRUST REGION.  TERMINATE GLOBAL STEP.)
CC961 FORMAT(18H TREGUP    IRETCD=,I5/
CC   +       18H TREGUP    FPLS  =,E20.13/
CC   +       18H TREGUP    FPLSP =,E20.13/
CC   +       18H TREGUP    DLTF  =,E20.13/
CC   +       18H TREGUP    SLP   =,E20.13)
CC962 FORMAT(18H TREGUP    RLN   =,E20.13)
CC963 FORMAT(18H TREGUP    DLTMP =,E20.13)
CC964 FORMAT(18H TREGUP    DLTFP =,E20.13/
CC   +       18H TREGUP    NWTAKE=,L1)
CC965 FORMAT(14H TREGUP       ,5(E20.13,3X))
      END
      SUBROUTINE TRESTR(POINTR, SBRGNS, PONTRS, RGNERS)
****BEGIN PROLOGUE TRESTR
****PURPOSE TRESTR maintains a heap for subregions.
****DESCRIPTION TRESTR maintains a heap for subregions.
*            The subregions are ordered according to the size of the
*            greatest error estimates of each subregion (RGNERS).
*
*   PARAMETERS
*
*     POINTR Integer.
*            The index for the subregion to be inserted in the heap.
*     SBRGNS Integer.
*            Number of subregions in the heap.
*     PONTRS Real array of dimension SBRGNS.
*            Used to store the indices for the greatest estimated errors
*            for each subregion.
*     RGNERS Real array of dimension SBRGNS.
*            Used to store the greatest estimated errors for each 
*            subregion.
*
****ROUTINES CALLED NONE
****END PROLOGUE TRESTR
*
*   Global variables.
*
      INTEGER POINTR, SBRGNS
      DOUBLE PRECISION PONTRS(*), RGNERS(*)
*
*   Local variables.
*
*   RGNERR Intermediate storage for the greatest error of a subregion.
*   SUBRGN Position of child/parent subregion in the heap.
*   SUBTMP Position of parent/child subregion in the heap.
*
      INTEGER SUBRGN, SUBTMP
      DOUBLE PRECISION RGNERR
*
****FIRST PROCESSING STATEMENT TRESTR
*     
      RGNERR = RGNERS(POINTR)
      IF ( POINTR .EQ. PONTRS(1)) THEN
*
*        Move the new subregion inserted at the top of the heap 
*        to its correct position in the heap.
*
         SUBRGN = 1
 10      SUBTMP = 2*SUBRGN
         IF ( SUBTMP .LE. SBRGNS ) THEN
            IF ( SUBTMP .NE. SBRGNS ) THEN
*     
*              Find maximum of left and right child.
*
               IF ( RGNERS(INT(PONTRS(SUBTMP))) .LT. 
     +              RGNERS(INT(PONTRS(SUBTMP+1))) ) SUBTMP = SUBTMP + 1
            ENDIF
*
*           Compare maximum child with parent.
*           If parent is maximum, then done.
*
            IF ( RGNERR .LT. RGNERS(INT(PONTRS(SUBTMP))) ) THEN
*     
*              Move the pointer at position subtmp up the heap.
*     
               PONTRS(SUBRGN) = PONTRS(SUBTMP)
               SUBRGN = SUBTMP
               GO TO 10
            ENDIF
         ENDIF
      ELSE
*
*        Insert new subregion in the heap.
*
         SUBRGN = SBRGNS
 20      SUBTMP = SUBRGN/2
         IF ( SUBTMP .GE. 1 ) THEN
*
*           Compare child with parent. If parent is maximum, then done.
*     
            IF ( RGNERR .GT. RGNERS(INT(PONTRS(SUBTMP))) ) THEN
*     
*              Move the pointer at position subtmp down the heap.
*
               PONTRS(SUBRGN) = PONTRS(SUBTMP)
               SUBRGN = SUBTMP
               GO TO 20
            ENDIF
         ENDIF
      ENDIF
      PONTRS(SUBRGN) = POINTR
*
****END TRESTR
*
      RETURN
      END
      SUBROUTINE TRIA25(X,M,N,RIGHT,X2,RIGHT2,IBUGA3)
C
C     PURPOSE--COMPUTE THE TRIANGULARIZED EQUIVALENT
C              OF THE M BY N MATRIX X.
C              THE TRIANGULARIZED EQUIVALENT
C              WILL BE FOUND IN THE UPPER RIGHT TRIANGLE
C              OF THE MATRIX X2.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION MATRIX
C                                WITH M ROWS AND N COLUMNS
C                                WHOSE TRIANGULARIZED
C                                EQUIVALENT IS DESIRED.
C                     --M      = THE INTEGER NUMBER OF
C                                ROWS IN X.
C                     --N      = THE INTEGER NUMBER OF
C                                COLUMNS IN X.
C                     --RIGHT  = THE SINGLE PRECISION VECTOR
C                                CONTAINING THE 'RIGHT-HAND
C                                SIDE' OF THE EQUATION.
C                     --IBUGA3 = A HOLLERITH BUG PARAMETER
C     OUTPUT ARGUMENTS--X2     = THE SINGLE PRECISION MATRIX
C                                WITH M ROWS AND N COLUMNS
C                                WITH THE TRIANGULARIZED
C                                EQUIVALENT OF X IN THE
C                                UPPER RIGHT TRIANGLE
C                                AND WITH ZEROS ELSEWHERE.
C                     --RIGHT2 = THE SINGLE PRECISION VECTOR
C                                CONTAINING THE ORIGINAL
C                                'RIGHT-HAND SIDE' BUT MODIFIED
C                                ACCORDING TO THE TRIANGULARIZATION
C                                THAT OCCURRED ON THE
C                                LEFT-HAND SIDE
C                                SIDE OF THE EQUATION.
C     NOTE--THE INPUT MATRIX X IS UNCHANGED
C           BY THIS SUBROUTINE.
C     NOTE--THE DIMENSIONS OF X AND X2 MUST BE THE SAME
C           IN THE CALLING ROUTINE AS IN THIS SUBROUTINE.
C           THEY HAVE BEEN SET HEREIN TO 25 BY 25,
C           AND HENCE THE 25 IN THE NAME OF THIS SUBROUTINE (TRIA25).
C     NOTE--TRIA25 IS IDENTICAL TO TRIA50 AND TRIANG
C           EXCEPT FOR THE DIMENSIONS.
C     NOTE--A CALL TO TRIA25 IS TYPICALLY
C           FOLLOWED BY A CALL TO BACK25
C           SO AS TO CARRY OUT THE
C           BACKSOLVING FOR THE COEFFICIENTS.
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--JUNE      1977.
C     UPDATED         --JULY      1981.
C     UPDATED         --AUGUST    1981.
C     UPDATED         --MARCH     1982.
C     UPDATED         --MAY       1982.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IBUGA3
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 ISTEPN
C
C---------------------------------------------------------------------
C
      DIMENSION X(25,25)
      DIMENSION RIGHT(*)
      DIMENSION X2(25,25)
      DIMENSION RIGHT2(*)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
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='TRIA'
      ISUBN2='25  '
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 TRIA25--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)M,N,IBUGA3
   52 FORMAT('M,N,IBUGA3 = ',2I8,2X,A4)
      CALL DPWRST('XXX','BUG ')
      DO55I=1,M
      WRITE(ICOUT,56)I,(X(I,J),J=1,N)
   56 FORMAT('I,X(I,.)   = ',I8,10E10.3)
      CALL DPWRST('XXX','BUG ')
   55 CONTINUE
      DO60I=1,M
      WRITE(ICOUT,61)I,RIGHT(I)
   61 FORMAT('I,RIGHT(I) = ',I8,E10.3)
      CALL DPWRST('XXX','BUG ')
   60 CONTINUE
   90 CONTINUE
C
C               *****************************************************
C               **  STEP 1--                                       **
C               **  COPY THE X MATRIX INTO THE X2 MATRIX.          **
C               **  COPY THE VECTOR RIGHT INTO THE VECTOR RIGHT2.  **
C               *****************************************************
C
      ISTEPN='1'
      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      DO100I=1,M
      DO200J=1,N
      X2(I,J)=X(I,J)
  200 CONTINUE
      RIGHT2(I)=RIGHT(I)
  100 CONTINUE
C
C               *********************************************
C               **  STEP 2--                               **
C               **  DETERMINE K = THE MINIMUM OF M AND N.  **
C               *********************************************
C
      ISTEPN='2'
      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      K=M
      IF(N.LT.M)K=N
      IF(K.EQ.1)GOTO9000
C
C               *********************************************************
C               **  STEP 3--                                           **
C               **  BEGIN GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING.  **
C               **  OPERATE ON ONE ROW (OR COLUMN) AT A TIME.          **
C               **  THE ROW (OR COLUMN) OF INTEREST IS COLUMN J.       **
C               *********************************************************
C
      ISTEPN='3'
      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      KM1=K-1
      DO400J=1,KM1
      JP1=J+1
C
C               ************************************************
C               **  STEP 3.1--                                **
C               **  FOR COLUMN J,                             **
C               **  DETERMINE THE ROW (ON OR BELOW DIAGONAL)  **
C               **  THAT HAS THE LARGEST ABSOLUTE VALUE.      **
C               **  THIS ROW WILL BE DESIGNATED AS ROW I2.    **
C               ************************************************
C
      ISTEPN='3.1'
      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      I2=J
      DO600I=JP1,M
      IF(ABS(X2(I,J)).GT.ABS(X2(I2,J)))I2=I
  600 CONTINUE
      IF(IBUGA3.EQ.'ON')WRITE(ICOUT,610)J,I2
      IF(IBUGA3.EQ.'ON')CALL DPWRST('XXX','BUG ')
      IF(IBUGA3.EQ.'ON')WRITE(ICOUT,615)X2(I2,J)
  610 FORMAT('COLUMN J = ',I2,'  MAX FOUND IN ROW I2 = ',I2)
      IF(IBUGA3.EQ.'ON')CALL DPWRST('XXX','BUG ')
  615 FORMAT('MAX VALUE = ',E12.5)
C
C               ****************************************************
C               **  STEP 3.2--                                    **
C               **  INTERCHANGE ROW I2 WITH ROW J                 **
C               **  BELOW AND TO THE RIGHT                        **
C               **  OF THE DIAGONAL ELEMENT X2(J,J) (INCLUSIVE).  **
C               ****************************************************
C
      ISTEPN='3.2'
      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(I2.EQ.J)GOTO700
      DO800J2=J,N
      HOLD=X2(J,J2)
      X2(J,J2)=X2(I2,J2)
      X2(I2,J2)=HOLD
  800 CONTINUE
      HOLD=RIGHT2(J)
      RIGHT2(J)=RIGHT2(I2)
      RIGHT2(I2)=HOLD
  700 CONTINUE
C
C               ****************************************************************
C               **  STEP 3.3--
C               **  MODIFY THE ROWS BELOW ROW J (& ONLY TO THE RIGHT OF COLUMN J
C               **  ALSO, ELIMINATE (SET TO 0) ELEMENTS IN COLUMN J
C               **  BELOW X2(J,J)
C               ****************************************************************
C
      ISTEPN='3.3'
      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      DO1100I=JP1,M
      FACTOR=X2(I,J)/X2(J,J)
      DO1200J2=JP1,N
      X2(I,J2)=X2(I,J2)-FACTOR*X2(J,J2)
 1200 CONTINUE
      RIGHT2(I)=RIGHT2(I)-FACTOR*RIGHT2(J)
 1100 CONTINUE
C
      DO1300I=JP1,M
      X2(I,J)=0.0
 1300 CONTINUE
C
      IF(IBUGA3.EQ.'OFF')GOTO1409
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1400)J
 1400 FORMAT('***** IN TRIANG, AFTER OPERATING ON COLUMN ',I6)
      CALL DPWRST('XXX','BUG ')
      DO1405I=1,M
      WRITE(ICOUT,1410)I,(X2(I,J3),J3=1,N),RIGHT2(I)
 1410 FORMAT('I,X2(I,.),RIGHT2(I) = ',I8,11E8.1)
      CALL DPWRST('XXX','BUG ')
 1405 CONTINUE
 1409 CONTINUE
C
  400 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 TRIA25--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)M,N,IBUGA3
 9012 FORMAT('M,N,IBUGA3 = ',2I8,2X,A4)
      CALL DPWRST('XXX','BUG ')
      DO9015I=1,M
      WRITE(ICOUT,9016)I,(X2(I,J),J=1,N)
 9016 FORMAT('I,X2(I,.)  = ',I8,10E10.3)
      CALL DPWRST('XXX','BUG ')
 9015 CONTINUE
      DO9020I=1,M
      WRITE(ICOUT,9021)I,RIGHT2(I)
 9021 FORMAT('I,RIGHT2(I)= ',I8,E10.3)
      CALL DPWRST('XXX','BUG ')
 9020 CONTINUE
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE TRICUB(RES,N,IWRITE,WEIGHT,IBUGA3,IERROR)
C     PURPOSE--DETERMINE THE N VERTICAL (ROBUST) WEIGHTS WEIGHT(.)
C              BASED ON A TRICUBE WEIGHTING SCHEME OF
C              THE RESIDUALS IN RES(.).
C     NOTE--IF ALL INPUT RESIDUALS ARE ZERO, THIS SUBROUTINE
C           WILL OUTPUT ALL WEIGHTS AS UNITY.
C     REFERENCE--CHAMBERS, ET AL.  GRAPHICAL METHODS FOR DATA ANALYSIS.
C                WADSWORTH, 1983, PAGES 98-101, 122-123.
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--88/2
C     ORIGINAL VERSION--FEBRUARY   1988
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DIMENSION RES(*)
      DIMENSION WEIGHT(*)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
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='TRIC'
      ISUBN2='UB  '
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 TRICUB--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)IBUGA3,IERROR
   52 FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)N
   53 FORMAT('N = ',I8)
      CALL DPWRST('XXX','BUG ')
      IF(N.LE.0)GOTO63
      DO61I=1,N
      WRITE(ICOUT,62)I,RES(I)
   62 FORMAT('I,RES(I) = ',I8,E15.7)
      CALL DPWRST('XXX','BUG ')
   61 CONTINUE
   63 CONTINUE
   90 CONTINUE
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      IF(N.GE.1)GOTO119
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,111)
  111 FORMAT('***** ERROR IN TRICUB--')
      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 TRICUBE WEIGHTS')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,114)
  114 FORMAT('      ARE TO BE COMPUTED, MUST BE 1 OR LARGER.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,115)
  115 FORMAT('      SUCH WAS NOT THE CASE HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,116)N
  116 FORMAT('      THE FULL SAMPLE SIZE N = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
  119 CONTINUE
C
C               ***********************************************
C               **  STEP 11--                                **
C               **  COMPUTE THE TRICUBE WEIGHTING           **
C               **     1) COMPUTE ABSOLUTE VALUE OF RESIDUALS
C               **     2) COMPUTE MEDIAN ABSOLUTE VALUE RESIDUAL
C               **     3) COMPUTE CUTOFF = +-6*M.A.R.
C               **     4) ASSIGN 0 WEIGHTS OUTSIDE OF REGION
C               **     5) ASSIGN TRICUBES INSIDE OF REGION
C               ***********************************************
C
      DO1100I=1,N
      WEIGHT(I)=ABS(RES(I))
 1100 CONTINUE
C
      CALL SORT(WEIGHT,N,WEIGHT)
      IEVODD=N-(N/2)*2
      NMID=N/2
      NMIDP1=NMID+1
      IF(IEVODD.EQ.0)XMEDAR=(WEIGHT(NMID)+WEIGHT(NMIDP1))/2.0
      IF(IEVODD.EQ.1)XMEDAR=WEIGHT(NMIDP1)
C
      IF(XMEDAR.EQ.0.0)GOTO1110
      GOTO1120
C
 1110 CONTINUE
      CONST=(-999.0)
      DO1111I=1,N
      WEIGHT(I)=1.0
 1111 CONTINUE
      GOTO1190
C
 1120 CONTINUE
      CONST=6.0*XMEDAR
      DO1121I=1,N
      U=RES(I)/CONST
      U2=ABS(U)
      WEIGHT(I)=0.0
      IF(-1.0.LE.U.AND.U.LE.1.0)WEIGHT(I)=(1.0-U2**3)**3
 1121 CONTINUE
      GOTO1190
C
 1190 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 TRICUB--')
      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)XMEDAR
 9014 FORMAT('XMEDAR = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      IF(N.LE.0)GOTO9023
      DO9021I=1,N
      WRITE(ICOUT,9022)I,RES(I),WEIGHT(I)
 9022 FORMAT('I,RES(I),WEIGHT(I) = ',I8,2E15.7)
      CALL DPWRST('XXX','BUG ')
 9021 CONTINUE
 9023 CONTINUE
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE TRIGD1(IHLF1,IHLF2,I1,I2,ITYPE,
     1IFUNZ1,IFUNZ2,IDERZ1,IDERZ2)
C
C     PURPOSE--COMPUTE DERIVATIVES FOR
C              THE 6 (CIRCULAR) TRIGONOMETRIC FUNCTIONS.
C
C     NOTE--LF11 = CODED SIN FUNCTION
C           LF12 = CODED COS FUNCTION
C           LF13 = CODED TAN FUNCTION
C           LF14 = CODED COT FUNCTION
C           LF15 = CODED SEC FUNCTION
C           LF16 = CODED CSC FUNCTION
C
C     ORIGINAL VERSION--JANUARY   1979.
C     UPDATED         --FEBRUARY  1979.
C     UPDATED         --JANUARY   1981.
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IHLF1
      CHARACTER*4 IHLF2
      CHARACTER*4 ITYPE
      CHARACTER*4 IFUNZ1
      CHARACTER*4 IFUNZ2
      CHARACTER*4 IDERZ1
      CHARACTER*4 IDERZ2
C
      DIMENSION IFUNZ1(*)
      DIMENSION IFUNZ2(*)
      DIMENSION IDERZ1(*)
      DIMENSION IDERZ2(*)
C
C-----COMMON VARIABLES (GENERAL)-----------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      I1P1=I1+1
      I1P2=I1+2
C
      IF(IHLF1.EQ.'SIN '.AND.IHLF2.EQ.'    ')GOTO610
      IF(IHLF1.EQ.'COS '.AND.IHLF2.EQ.'    ')GOTO620
      IF(IHLF1.EQ.'TAN '.AND.IHLF2.EQ.'    ')GOTO630
      IF(IHLF1.EQ.'COT '.AND.IHLF2.EQ.'    ')GOTO640
      IF(IHLF1.EQ.'SEC '.AND.IHLF2.EQ.'    ')GOTO650
      IF(IHLF1.EQ.'CSC '.AND.IHLF2.EQ.'    ')GOTO660
C
C     TREAT THE SINE CASE
C
  610 CONTINUE
      I2=I2+1
      IDERZ1(I2)='COS '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='(   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)=IFUNZ1(I1P1)
      IDERZ2(I2)=IFUNZ2(I1P1)
      IF(ITYPE.EQ.'EXP ')I2=I2+1
      IF(ITYPE.EQ.'EXP ')IDERZ1(I2)=IFUNZ1(I1P2)
      IF(ITYPE.EQ.'EXP ')IDERZ2(I2)=IFUNZ2(I1P2)
      I2=I2+1
      IDERZ1(I2)=')   '
      IDERZ2(I2)='    '
      IF(ITYPE.EQ.'EXP ')GOTO980
      GOTO985
C
C     TREAT THE COSINE CASE
C
  620 CONTINUE
      I2=I2+1
      IDERZ1(I2)='-   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='SIN '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='(   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)=IFUNZ1(I1P1)
      IDERZ2(I2)=IFUNZ2(I1P1)
      IF(ITYPE.EQ.'EXP ')I2=I2+1
      IF(ITYPE.EQ.'EXP ')IDERZ1(I2)=IFUNZ1(I1P2)
      IF(ITYPE.EQ.'EXP ')IDERZ2(I2)=IFUNZ2(I1P2)
      I2=I2+1
      IDERZ1(I2)=')   '
      IDERZ2(I2)='    '
      IF(ITYPE.EQ.'EXP ')GOTO980
      GOTO985
C
C     TREAT THE TANGENT CASE
C
  630 CONTINUE
      I2=I2+1
      IDERZ1(I2)='SEC '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='(   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)=IFUNZ1(I1P1)
      IDERZ2(I2)=IFUNZ2(I1P1)
      IF(ITYPE.EQ.'EXP ')I2=I2+1
      IF(ITYPE.EQ.'EXP ')IDERZ1(I2)=IFUNZ1(I1P2)
      IF(ITYPE.EQ.'EXP ')IDERZ2(I2)=IFUNZ2(I1P2)
      I2=I2+1
      IDERZ1(I2)=')   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='**  '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='2   '
      IDERZ2(I2)='    '
      IF(ITYPE.EQ.'EXP ')GOTO980
      GOTO985
C
C     TREAT THE COTANGENT CASE
C
  640 CONTINUE
      I2=I2+1
      IDERZ1(I2)='-   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='CSC '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='(   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)=IFUNZ1(I1P1)
      IDERZ2(I2)=IFUNZ2(I1P1)
      IF(ITYPE.EQ.'EXP ')I2=I2+1
      IF(ITYPE.EQ.'EXP ')IDERZ1(I2)=IFUNZ1(I1P2)
      IF(ITYPE.EQ.'EXP ')IDERZ2(I2)=IFUNZ2(I1P2)
      I2=I2+1
      IDERZ1(I2)=')   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='**  '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='2   '
      IDERZ2(I2)='    '
      IF(ITYPE.EQ.'EXP ')GOTO980
      GOTO985
C
C     TREAT THE SECANT CASE
C
  650 CONTINUE
      I2=I2+1
      IDERZ1(I2)='SEC '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='(   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)=IFUNZ1(I1P1)
      IDERZ2(I2)=IFUNZ2(I1P1)
      IF(ITYPE.EQ.'EXP ')I2=I2+1
      IF(ITYPE.EQ.'EXP ')IDERZ1(I2)=IFUNZ1(I1P2)
      IF(ITYPE.EQ.'EXP ')IDERZ2(I2)=IFUNZ2(I1P2)
      I2=I2+1
      IDERZ1(I2)=')   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='*   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='TAN '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='(   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)=IFUNZ1(I1P1)
      IDERZ2(I2)=IFUNZ2(I1P1)
      IF(ITYPE.EQ.'EXP ')I2=I2+1
      IF(ITYPE.EQ.'EXP ')IDERZ1(I2)=IFUNZ1(I1P2)
      IF(ITYPE.EQ.'EXP ')IDERZ2(I2)=IFUNZ2(I1P2)
      I2=I2+1
      IDERZ1(I2)=')   '
      IDERZ2(I2)='    '
      IF(ITYPE.EQ.'EXP ')GOTO980
      GOTO985
C
C     TREAT THE COSECANT CASE
C
  660 CONTINUE
      I2=I2+1
      IDERZ1(I2)='-   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='CSC '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='(   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)=IFUNZ1(I1P1)
      IDERZ2(I2)=IFUNZ2(I1P1)
      IF(ITYPE.EQ.'EXP ')I2=I2+1
      IF(ITYPE.EQ.'EXP ')IDERZ1(I2)=IFUNZ1(I1P2)
      IF(ITYPE.EQ.'EXP ')IDERZ2(I2)=IFUNZ2(I1P2)
      I2=I2+1
      IDERZ1(I2)=')   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='*   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='COT '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='(   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)=IFUNZ1(I1P1)
      IDERZ2(I2)=IFUNZ2(I1P1)
      IF(ITYPE.EQ.'EXP ')I2=I2+1
      IF(ITYPE.EQ.'EXP ')IDERZ1(I2)=IFUNZ1(I1P2)
      IF(ITYPE.EQ.'EXP ')IDERZ2(I2)=IFUNZ2(I1P2)
      I2=I2+1
      IDERZ1(I2)=')   '
      IDERZ2(I2)='    '
      IF(ITYPE.EQ.'EXP ')GOTO980
      GOTO985
C
  980 CONTINUE
  985 CONTINUE
C
      RETURN
      END
      SUBROUTINE TRIGD2(IHLF1,IHLF2,I1,I2,ITYPE,
     1IFUNZ1,IFUNZ2,IDERZ1,IDERZ2)
C
C     PURPOSE--COMPUTE DERIVATIVES FOR
C              THE 6 INVERSE (CIRCULAR) TRIGONOMETRIC FUNCTIONS.
C
C     ORIGINAL VERSION--JANUARY   1979.
C     UPDATED         --FEBRUARY  1979.
C     UPDATED         --JANUARY   1981.
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IHLF1
      CHARACTER*4 IHLF2
      CHARACTER*4 ITYPE
      CHARACTER*4 IFUNZ1
      CHARACTER*4 IFUNZ2
      CHARACTER*4 IDERZ1
      CHARACTER*4 IDERZ2
C
      DIMENSION IFUNZ1(*)
      DIMENSION IFUNZ2(*)
      DIMENSION IDERZ1(*)
      DIMENSION IDERZ2(*)
C
C-----COMMON VARIABLES (GENERAL)-----------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      I1P1=I1+1
      I1P2=I1+2
C
      IF(IHLF1.EQ.'ARCS'.AND.IHLF2.EQ.'IN  ')GOTO710
      IF(IHLF1.EQ.'ARCC'.AND.IHLF2.EQ.'OS  ')GOTO720
      IF(IHLF1.EQ.'ARCT'.AND.IHLF2.EQ.'AN  ')GOTO730
      IF(IHLF1.EQ.'ARCC'.AND.IHLF2.EQ.'OT  ')GOTO740
      IF(IHLF1.EQ.'ARCS'.AND.IHLF2.EQ.'EC  ')GOTO750
      IF(IHLF1.EQ.'ARCC'.AND.IHLF2.EQ.'SC  ')GOTO760
C
C     TREAT THE ARCSINE CASE
C
  710 CONTINUE
      I2=I2+1
      IDERZ1(I2)='(   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='1   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='/   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='SQRT'
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='(   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='1   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='-   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)=IFUNZ1(I1P1)
      IDERZ2(I2)=IFUNZ2(I1P1)
      IF(ITYPE.EQ.'EXP ')I2=I2+1
      IF(ITYPE.EQ.'EXP ')IDERZ1(I2)=IFUNZ1(I1P2)
      IF(ITYPE.EQ.'EXP ')IDERZ2(I2)=IFUNZ2(I1P2)
      I2=I2+1
      IDERZ1(I2)='**  '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='2   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)=')   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)=')   '
      IDERZ2(I2)='    '
      IF(ITYPE.EQ.'EXP ')GOTO980
      GOTO985
C
C     TREAT THE ARCCOSINE CASE
C
  720 CONTINUE
      I2=I2+1
      IDERZ1(I2)='(   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='-   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='1   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='/   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='SQRT'
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='(   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='1   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='-   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)=IFUNZ1(I1P1)
      IDERZ2(I2)=IFUNZ2(I1P1)
      IF(ITYPE.EQ.'EXP ')I2=I2+1
      IF(ITYPE.EQ.'EXP ')IDERZ1(I2)=IFUNZ1(I1P2)
      IF(ITYPE.EQ.'EXP ')IDERZ2(I2)=IFUNZ2(I1P2)
      I2=I2+1
      IDERZ1(I2)='**  '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='2   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)=')   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)=')   '
      IDERZ2(I2)='    '
      IF(ITYPE.EQ.'EXP ')GOTO980
      GOTO985
C
C     TREAT THE ARCTANGENT CASE
C
  730 CONTINUE
      I2=I2+1
      IDERZ1(I2)='(   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='1   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='/   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='(   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='1   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='+   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)=IFUNZ1(I1P1)
      IDERZ2(I2)=IFUNZ2(I1P1)
      IF(ITYPE.EQ.'EXP ')I2=I2+1
      IF(ITYPE.EQ.'EXP ')IDERZ1(I2)=IFUNZ1(I1P2)
      IF(ITYPE.EQ.'EXP ')IDERZ2(I2)=IFUNZ2(I1P2)
      I2=I2+1
      IDERZ1(I2)='**  '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='2   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)=')   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)=')   '
      IDERZ2(I2)='    '
      IF(ITYPE.EQ.'EXP ')GOTO980
      GOTO985
C
C     TREAT THE ARCCOTANGENT CASE
C
  740 CONTINUE
      I2=I2+1
      IDERZ1(I2)='(   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='-   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='1   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='/   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='(   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='1   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='+   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)=IFUNZ1(I1P1)
      IDERZ2(I2)=IFUNZ2(I1P1)
      IF(ITYPE.EQ.'EXP ')I2=I2+1
      IF(ITYPE.EQ.'EXP ')IDERZ1(I2)=IFUNZ1(I1P2)
      IF(ITYPE.EQ.'EXP ')IDERZ2(I2)=IFUNZ2(I1P2)
      I2=I2+1
      IDERZ1(I2)='**  '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='2   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)=')   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)=')   '
      IDERZ2(I2)='    '
      IF(ITYPE.EQ.'EXP ')GOTO980
      GOTO985
C
C     TREAT THE ARCSECANT CASE
C
  750 CONTINUE
      I2=I2+1
      IDERZ1(I2)='(   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='1   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='/   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='(   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)=IFUNZ1(I1P1)
      IDERZ2(I2)=IFUNZ2(I1P1)
      IF(ITYPE.EQ.'EXP ')I2=I2+1
      IF(ITYPE.EQ.'EXP ')IDERZ1(I2)=IFUNZ1(I1P2)
      IF(ITYPE.EQ.'EXP ')IDERZ2(I2)=IFUNZ2(I1P2)
      I2=I2+1
      IDERZ1(I2)='*   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='SQRT'
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='(   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)=IFUNZ1(I1P1)
      IDERZ2(I2)=IFUNZ2(I1P1)
      IF(ITYPE.EQ.'EXP ')I2=I2+1
      IF(ITYPE.EQ.'EXP ')IDERZ1(I2)=IFUNZ1(I1P2)
      IF(ITYPE.EQ.'EXP ')IDERZ2(I2)=IFUNZ2(I1P2)
      I2=I2+1
      IDERZ1(I2)='**  '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='2   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='-   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='1   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)=')   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)=')   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)=')   '
      IDERZ2(I2)='    '
      IF(ITYPE.EQ.'EXP ')GOTO980
      GOTO985
C
C     TREAT THE ARCCOSECANT CASE
C
  760 CONTINUE
      I2=I2+1
      IDERZ1(I2)='(   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='-   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='1   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='/   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='(   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)=IFUNZ1(I1P1)
      IDERZ2(I2)=IFUNZ2(I1P1)
      IF(ITYPE.EQ.'EXP ')I2=I2+1
      IF(ITYPE.EQ.'EXP ')IDERZ1(I2)=IFUNZ1(I1P2)
      IF(ITYPE.EQ.'EXP ')IDERZ2(I2)=IFUNZ2(I1P2)
      I2=I2+1
      IDERZ1(I2)='*   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='SQRT'
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='(   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)=IFUNZ1(I1P1)
      IDERZ2(I2)=IFUNZ2(I1P1)
      IF(ITYPE.EQ.'EXP ')I2=I2+1
      IF(ITYPE.EQ.'EXP ')IDERZ1(I2)=IFUNZ1(I1P2)
      IF(ITYPE.EQ.'EXP ')IDERZ2(I2)=IFUNZ2(I1P2)
      I2=I2+1
      IDERZ1(I2)='**  '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='2   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='-   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='1   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)=')   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)=')   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)=')   '
      IDERZ2(I2)='    '
      IF(ITYPE.EQ.'EXP ')GOTO980
      GOTO985
C
  980 CONTINUE
  985 CONTINUE
C
      RETURN
      END
      SUBROUTINE TRIGD3(IHLF1,IHLF2,I1,I2,ITYPE,
     1IFUNZ1,IFUNZ2,IDERZ1,IDERZ2)
C
C     PURPOSE--COMPUTE DERIVATIVES FOR
C              THE 6 HYPERBOLIC TRIGONOMETRIC FUNCTIONS.
C
C     ORIGINAL VERSION--JANUARY   1979.
C     UPDATED         --FEBRUARY  1979.
C     UPDATED         --JANUARY   1981.
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IHLF1
      CHARACTER*4 IHLF2
      CHARACTER*4 ITYPE
      CHARACTER*4 IFUNZ1
      CHARACTER*4 IFUNZ2
      CHARACTER*4 IDERZ1
      CHARACTER*4 IDERZ2
C
      DIMENSION IFUNZ1(*)
      DIMENSION IFUNZ2(*)
      DIMENSION IDERZ1(*)
      DIMENSION IDERZ2(*)
C
C-----COMMON VARIABLES (GENERAL)-----------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      I1P1=I1+1
      I1P2=I1+2
C
      IF(IHLF1.EQ.'SINH'.AND.IHLF2.EQ.'    ')GOTO810
      IF(IHLF1.EQ.'COSH'.AND.IHLF2.EQ.'    ')GOTO820
      IF(IHLF1.EQ.'TANH'.AND.IHLF2.EQ.'    ')GOTO830
      IF(IHLF1.EQ.'COTH'.AND.IHLF2.EQ.'    ')GOTO840
      IF(IHLF1.EQ.'SECH'.AND.IHLF2.EQ.'    ')GOTO850
      IF(IHLF1.EQ.'CSCH'.AND.IHLF2.EQ.'    ')GOTO860
C
C     TREAT THE HYPERBOLIC SINE CASE
C
  810 CONTINUE
      I2=I2+1
      IDERZ1(I2)='COSH'
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='(   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)=IFUNZ1(I1P1)
      IDERZ2(I2)=IFUNZ2(I1P1)
      IF(ITYPE.EQ.'EXP ')I2=I2+1
      IF(ITYPE.EQ.'EXP ')IDERZ1(I2)=IFUNZ1(I1P2)
      IF(ITYPE.EQ.'EXP ')IDERZ2(I2)=IFUNZ2(I1P2)
      I2=I2+1
      IDERZ1(I2)=')   '
      IDERZ2(I2)='    '
      IF(ITYPE.EQ.'EXP ')GOTO980
      GOTO985
C
C     TREAT THE HYPERBOLIC COSINE CASE
C
  820 CONTINUE
      I2=I2+1
      IDERZ1(I2)='SINH'
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='(   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)=IFUNZ1(I1P1)
      IDERZ2(I2)=IFUNZ2(I1P1)
      IF(ITYPE.EQ.'EXP ')I2=I2+1
      IF(ITYPE.EQ.'EXP ')IDERZ1(I2)=IFUNZ1(I1P2)
      IF(ITYPE.EQ.'EXP ')IDERZ2(I2)=IFUNZ2(I1P2)
      I2=I2+1
      IDERZ1(I2)=')   '
      IDERZ2(I2)='    '
      IF(ITYPE.EQ.'EXP ')GOTO980
      GOTO985
C
C     TREAT THE HYPERBOLIC TANGENT CASE
C
  830 CONTINUE
      I2=I2+1
      IDERZ1(I2)='SECH'
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='(   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)=IFUNZ1(I1P1)
      IDERZ2(I2)=IFUNZ2(I1P1)
      IF(ITYPE.EQ.'EXP ')I2=I2+1
      IF(ITYPE.EQ.'EXP ')IDERZ1(I2)=IFUNZ1(I1P2)
      IF(ITYPE.EQ.'EXP ')IDERZ2(I2)=IFUNZ2(I1P2)
      I2=I2+1
      IDERZ1(I2)=')   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='**  '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='2   '
      IDERZ2(I2)='    '
      IF(ITYPE.EQ.'EXP ')GOTO980
      GOTO985
C
C     TREAT THE HYPERBOLIC COTANGENT CASE
C
  840 CONTINUE
      I2=I2+1
      IDERZ1(I2)='-   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='CSCH'
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='(   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)=IFUNZ1(I1P1)
      IDERZ2(I2)=IFUNZ2(I1P1)
      IF(ITYPE.EQ.'EXP ')I2=I2+1
      IF(ITYPE.EQ.'EXP ')IDERZ1(I2)=IFUNZ1(I1P2)
      IF(ITYPE.EQ.'EXP ')IDERZ2(I2)=IFUNZ2(I1P2)
      I2=I2+1
      IDERZ1(I2)=')   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='**  '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='2   '
      IDERZ2(I2)='    '
      IF(ITYPE.EQ.'EXP ')GOTO980
      GOTO985
C
C     TREAT THE HYPERBOLIC SECANT CASE
C
  850 CONTINUE
      I2=I2+1
      IDERZ1(I2)='-   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='SECH'
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='(   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)=IFUNZ1(I1P1)
      IDERZ2(I2)=IFUNZ2(I1P1)
      IF(ITYPE.EQ.'EXP ')I2=I2+1
      IF(ITYPE.EQ.'EXP ')IDERZ1(I2)=IFUNZ1(I1P2)
      IF(ITYPE.EQ.'EXP ')IDERZ2(I2)=IFUNZ2(I1P2)
      I2=I2+1
      IDERZ1(I2)=')   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='*   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='TANH'
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='(   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)=IFUNZ1(I1P1)
      IDERZ2(I2)=IFUNZ2(I1P1)
      IF(ITYPE.EQ.'EXP ')I2=I2+1
      IF(ITYPE.EQ.'EXP ')IDERZ1(I2)=IFUNZ1(I1P2)
      IF(ITYPE.EQ.'EXP ')IDERZ2(I2)=IFUNZ2(I1P2)
      I2=I2+1
      IDERZ1(I2)=')   '
      IDERZ2(I2)='    '
      IF(ITYPE.EQ.'EXP ')GOTO980
      GOTO985
C
C     TREAT THE HYPERBOLIC COSECANT CASE
C
  860 CONTINUE
      I2=I2+1
      IDERZ1(I2)='-   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='CSCH'
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='(   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)=IFUNZ1(I1P1)
      IDERZ2(I2)=IFUNZ2(I1P1)
      IF(ITYPE.EQ.'EXP ')I2=I2+1
      IF(ITYPE.EQ.'EXP ')IDERZ1(I2)=IFUNZ1(I1P2)
      IF(ITYPE.EQ.'EXP ')IDERZ2(I2)=IFUNZ2(I1P2)
      I2=I2+1
      IDERZ1(I2)=')   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='*   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='COTH'
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='(   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)=IFUNZ1(I1P1)
      IDERZ2(I2)=IFUNZ2(I1P1)
      IF(ITYPE.EQ.'EXP ')I2=I2+1
      IF(ITYPE.EQ.'EXP ')IDERZ1(I2)=IFUNZ1(I1P2)
      IF(ITYPE.EQ.'EXP ')IDERZ2(I2)=IFUNZ2(I1P2)
      I2=I2+1
      IDERZ1(I2)=')   '
      IDERZ2(I2)='    '
      IF(ITYPE.EQ.'EXP ')GOTO980
      GOTO985
C
  980 CONTINUE
  985 CONTINUE
C
      RETURN
      END
      SUBROUTINE TRIGD4(IHLF1,IHLF2,I1,I2,ITYPE,
     1IFUNZ1,IFUNZ2,IDERZ1,IDERZ2)
C
C     PURPOSE--COMPUTE DERIVATIVES FOR
C              THE 6 INVERSE HYPERBOLIC TRIGONOMETRIC FUNCTIONS.
C
C     ORIGINAL VERSION--JANUARY   1979.
C     UPDATED         --FEBRUARY  1979.
C     UPDATED         --JANUARY   1981.
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IHLF1
      CHARACTER*4 IHLF2
      CHARACTER*4 ITYPE
      CHARACTER*4 IFUNZ1
      CHARACTER*4 IFUNZ2
      CHARACTER*4 IDERZ1
      CHARACTER*4 IDERZ2
C
      DIMENSION IFUNZ1(*)
      DIMENSION IFUNZ2(*)
      DIMENSION IDERZ1(*)
      DIMENSION IDERZ2(*)
C
C-----COMMON VARIABLES (GENERAL)-----------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      I1P1=I1+1
      I1P2=I1+2
C
      IF(IHLF1.EQ.'ARCS'.AND.IHLF2.EQ.'INH ')GOTO910
      IF(IHLF1.EQ.'ARCC'.AND.IHLF2.EQ.'OSH ')GOTO920
      IF(IHLF1.EQ.'ARCT'.AND.IHLF2.EQ.'ANH ')GOTO930
      IF(IHLF1.EQ.'ARCC'.AND.IHLF2.EQ.'OTH ')GOTO940
      IF(IHLF1.EQ.'ARCS'.AND.IHLF2.EQ.'ECH ')GOTO950
      IF(IHLF1.EQ.'ARCC'.AND.IHLF2.EQ.'SCH ')GOTO960
C
C     TREAT THE HYPERBOLIC ARCSINE CASE
C
  910 CONTINUE
      I2=I2+1
      IDERZ1(I2)='(   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='1   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='/   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='SQRT'
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='(   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='1   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='+   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)=IFUNZ1(I1P1)
      IDERZ2(I2)=IFUNZ2(I1P1)
      IF(ITYPE.EQ.'EXP ')I2=I2+1
      IF(ITYPE.EQ.'EXP ')IDERZ1(I2)=IFUNZ1(I1P2)
      IF(ITYPE.EQ.'EXP ')IDERZ2(I2)=IFUNZ2(I1P2)
      I2=I2+1
      IDERZ1(I2)='**  '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='2   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)=')   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)=')   '
      IDERZ2(I2)='    '
      IF(ITYPE.EQ.'EXP ')GOTO980
      GOTO985
C
C     TREAT THE HYPERBOLIC ARCCOSINE CASE
C
  920 CONTINUE
      I2=I2+1
      IDERZ1(I2)='(   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='1   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='/   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='SQRT'
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='(   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)=IFUNZ1(I1P1)
      IDERZ2(I2)=IFUNZ2(I1P1)
      IF(ITYPE.EQ.'EXP ')I2=I2+1
      IF(ITYPE.EQ.'EXP ')IDERZ1(I2)=IFUNZ1(I1P2)
      IF(ITYPE.EQ.'EXP ')IDERZ2(I2)=IFUNZ2(I1P2)
      I2=I2+1
      IDERZ1(I2)='**  '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='2   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='-   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='1   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)=')   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)=')   '
      IDERZ2(I2)='    '
      IF(ITYPE.EQ.'EXP ')GOTO980
      GOTO985
C
C     TREAT THE HYPERBOLIC ARCTANGENT CASE
C
  930 CONTINUE
      I2=I2+1
      IDERZ1(I2)='(   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='1   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='/   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='(   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='1   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='-   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)=IFUNZ1(I1P1)
      IDERZ2(I2)=IFUNZ2(I1P1)
      IF(ITYPE.EQ.'EXP ')I2=I2+1
      IF(ITYPE.EQ.'EXP ')IDERZ1(I2)=IFUNZ1(I1P2)
      IF(ITYPE.EQ.'EXP ')IDERZ2(I2)=IFUNZ2(I1P2)
      I2=I2+1
      IDERZ1(I2)='**  '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='2   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)=')   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)=')   '
      IDERZ2(I2)='    '
      IF(ITYPE.EQ.'EXP ')GOTO980
      GOTO985
C
C     TREAT THE HYPERBOLIC ARCCOTANGENT CASE
C
  940 CONTINUE
      I2=I2+1
      IDERZ1(I2)='(   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='1   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='/   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='(   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='1   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='-   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)=IFUNZ1(I1P1)
      IDERZ2(I2)=IFUNZ2(I1P1)
      IF(ITYPE.EQ.'EXP ')I2=I2+1
      IF(ITYPE.EQ.'EXP ')IDERZ1(I2)=IFUNZ1(I1P2)
      IF(ITYPE.EQ.'EXP ')IDERZ2(I2)=IFUNZ2(I1P2)
      I2=I2+1
      IDERZ1(I2)='**  '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='2   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)=')   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)=')   '
      IDERZ2(I2)='    '
      IF(ITYPE.EQ.'EXP ')GOTO980
      GOTO985
C
C     TREAT THE HYPERBOLIC ARCSECANT CASE
C
  950 CONTINUE
      I2=I2+1
      IDERZ1(I2)='(   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='-   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='1   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='/   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='(   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)=IFUNZ1(I1P1)
      IDERZ2(I2)=IFUNZ2(I1P1)
      IF(ITYPE.EQ.'EXP ')I2=I2+1
      IF(ITYPE.EQ.'EXP ')IDERZ1(I2)=IFUNZ1(I1P2)
      IF(ITYPE.EQ.'EXP ')IDERZ2(I2)=IFUNZ2(I1P2)
      I2=I2+1
      IDERZ1(I2)='*   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='SQRT'
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='(   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='1   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='-   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)=IFUNZ1(I1P1)
      IDERZ2(I2)=IFUNZ2(I1P1)
      IF(ITYPE.EQ.'EXP ')I2=I2+1
      IF(ITYPE.EQ.'EXP ')IDERZ1(I2)=IFUNZ1(I1P2)
      IF(ITYPE.EQ.'EXP ')IDERZ2(I2)=IFUNZ2(I1P2)
      I2=I2+1
      IDERZ1(I2)='**  '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='2   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(17)=')   '
      I2=I2+1
      IDERZ1(18)=')   '
      I2=I2+1
      IDERZ1(19)=')   '
      IF(ITYPE.EQ.'EXP ')GOTO980
      GOTO985
C
C     TREAT THE HYPERBOLIC ARCCOSECANT CASE
C
  960 CONTINUE
      I2=I2+1
      IDERZ1(I2)='(   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='-   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='1   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='/   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='(   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)=IFUNZ1(I1P1)
      IDERZ2(I2)=IFUNZ2(I1P1)
      IF(ITYPE.EQ.'EXP ')I2=I2+1
      IF(ITYPE.EQ.'EXP ')IDERZ1(I2)=IFUNZ1(I1P2)
      IF(ITYPE.EQ.'EXP ')IDERZ2(I2)=IFUNZ2(I1P2)
      I2=I2+1
      IDERZ1(I2)='*   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='SQRT'
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='(   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='1   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='+   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)=IFUNZ1(I1P1)
      IDERZ2(I2)=IFUNZ2(I1P1)
      IF(ITYPE.EQ.'EXP ')I2=I2+1
      IF(ITYPE.EQ.'EXP ')IDERZ1(I2)=IFUNZ1(I1P2)
      IF(ITYPE.EQ.'EXP ')IDERZ2(I2)=IFUNZ2(I1P2)
      I2=I2+1
      IDERZ1(I2)='**  '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='2   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)=')   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)=')   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)=')   '
      IDERZ2(I2)='    '
      IF(ITYPE.EQ.'EXP ')GOTO980
      GOTO985
C
  980 CONTINUE
  985 CONTINUE
C
      RETURN
      END
      SUBROUTINE TRIMME(X,N,PROP1,PROP2,IWRITE,XTEMP,IUPPER,XTRIM,
     1IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE
C              SAMPLE TRIMME = THE
C              SAMPLE (ON EACH SIDE) TRIMMED MEAN
C              OF THE DATA IN THE INPUT VECTOR X.
C      NOTE--PROP1 % OF THE DATA IS TRIMMED FROM THE LEFT SIDE;
C            PROP2 % OF THE DATA IS TRIMMED FROM THE RIGHT SIDE.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF
C                                (UNSORTED OR SORTED) OBSERVATIONS.
C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR X.
C                     --PROP1  = THE SINGLE PRECISION PROPORTION (0 TO 100)
C                                OF OBSERVATIONS TO BE TRIMMED FROM LEFT SIDE.
C                     --PROP2  = THE SINGLE PRECISION PORTION (0 TO 100)
C                                OF OBSERVATIONS TO BE TRIMMED FROM RIGHT SIDE.
C     OUTPUT ARGUMENTS--XTRIM  = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED SAMPLE TRIMMED MEAN.
C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
C             SAMPLE TRIMMED MEAN.
C     RESTRICTIONS--THE MAXIMUM ALLOWABLE VALUE OF N
C                   FOR THIS SUBROUTINE IS 15000.
C     OTHER DATAPAC   SUBROUTINES NEEDED--SORT.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--DAVID, ORDER STATISTICS, 1970, PAGES 129, 136.
C               --CROW AND SIDDIQUI, 'ROBUST ESTIMATION OF LOCATION',
C                 JOURNAL OF THE AMERICAN STATISTICAL ASSOCIATION,
C                 1967, PAGES 357, 387.
C               --FILLIBEN, SIMPLE AND ROBUST LINEAR ESTIMATION
C                 OF THE LOCATION PARAMETER OF A SYMMETRIC
C                 DISTRIBUTION (UNPUBLISHED PH.D. DISSERTATION,
C                 PRINCETON UNIVERSITY, 1969).
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 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--83.6
C     ORIGINAL VERSION--JULY      1973.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DK
      DOUBLE PRECISION DX
      DOUBLE PRECISION DSUM
C
      DIMENSION X(*)
      DIMENSION XTEMP(*)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='TRIM'
      ISUBN2='ME  '
C
      IERROR='NO'
CCCCC IUPPER=1000
C
      NPROP1=0
      NPROP2=0
      NPROP3=0
      ISTART=0
      ISTOP=0
      DSUM=0.0D0
      DK=0.0D0
      PROP3=0.0
C
      IF(IBUGA3.EQ.'OFF')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF TRIMME--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)IBUGA3
   52 FORMAT('IBUGA3 = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)N
   53 FORMAT('N = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,54)PROP1,PROP2
   54 FORMAT('PROP1,PROP2 = ',2E15.7)
      CALL DPWRST('XXX','BUG ')
      DO55I=1,N
      WRITE(ICOUT,56)I,X(I)
   56 FORMAT('I,X(I) = ',I8,E15.7)
      CALL DPWRST('XXX','BUG ')
   55 CONTINUE
   90 CONTINUE
C
C               ********************************
C               **  COMPUTE THE TRIMMED MEAN  **
C               ********************************
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      AN=N
C
      IF(1.LE.N.AND.N.LE.IUPPER)GOTO119
      IERROR='YES'
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,111)
  111 FORMAT('***** ERROR IN TRIMME--')
      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 TRIMME 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 TRIMME--',
     1'THE 2ND INPUT ARGUMENT (N) HAS THE VALUE 1')
      CALL DPWRST('XXX','BUG ')
      XTRIM=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 TRIMME--',
     1'THE FIRST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      XTRIM=HOLD
      GOTO9000
  139 CONTINUE
C
      IF(0.0.LE.PROP1.AND.PROP1.LE.100.0)GOTO149
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,141)
  141 FORMAT('***** ERROR IN TRIMME--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,142)
  142 FORMAT('PROP1 SHOULD BE BETWEEN 0 AND 100, BUT IS NOT.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,143)PROP1
  143 FORMAT('THE VALUE OF PROP1 IS ',E15.7)
      CALL DPWRST('XXX','BUG ')
  149 CONTINUE
C
      IF(0.0.LE.PROP2.AND.PROP2.LE.100.0)GOTO159
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,151)
  151 FORMAT('***** ERROR IN TRIMME--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,152)
  152 FORMAT('PROP2 SHOULD BE BETWEEN 0 AND 100, BUT IS NOT.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,153)PROP2
  153 FORMAT('THE VALUE OF PROP2 IS ',E15.7)
      CALL DPWRST('XXX','BUG ')
  159 CONTINUE
C
  190 CONTINUE
C
C               *********************************
C               **  STEP 2--                   **
C               **  COMPUTE THE TRIMMED MEAN.  **
C               *********************************
C
      CALL SORT(X,N,XTEMP)
C
      NPROP1=(PROP1/100.0)*AN+0.0001
      ISTART=NPROP1+1
C
      NPROP2=(PROP2/100.0)*AN+0.0001
      ISTOP=N-NPROP2
C
      DSUM=0.0
      K=0
      IF(ISTART.GT.ISTOP)GOTO250
      DO200I=ISTART,ISTOP
      K=K+1
      DX=XTEMP(I)
      DSUM=DSUM+DX
  200 CONTINUE
      NPROP3=K
      DK=K
      XTRIM=DSUM/DK
      GOTO290
C
  250 CONTINUE
      IERROR='YES'
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,251)
  251 FORMAT('***** INTERNAL ERROR IN TRIMME--')
      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 ')
      PROP3=100.00-PROP1-PROP2
      WRITE(ICOUT,811)PROP1,NPROP1
  811 FORMAT(8X,F10.4,' PERCENT (= ',I8,' OBSERVATIONS) ',
     1'OF THE DATA WERE TRIMMED         FROM BELOW')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,812)PROP2,NPROP2
  812 FORMAT(8X,F10.4,' PERCENT (= ',I8,' OBSERVATIONS) ',
     1'OF THE DATA WERE TRIMMED         FROM ABOVE')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,813)PROP3,NPROP3
  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,XTRIM
  821 FORMAT('THE TRIMMED 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 TRIMME--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IBUGA3,IERROR
 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)N
 9013 FORMAT('N = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9014)PROP1,PROP2,PROP3
 9014 FORMAT('PROP1,PROP2,PROP3 = ',3E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9015)NPROP1,NPROP2,NPROP3
 9015 FORMAT('NPROP1,NPROP2,NPROP3 = ',3I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9016)ISTART,ISTOP
 9016 FORMAT('ISTART,ISTOP = ',2I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9017)DSUM,DK
 9017 FORMAT('DSUM,DK = ',2D15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9018)XTRIM
 9018 FORMAT('XTRIM = ',E15.7)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE TRIMSE(X,N,PROP1,PROP2,IWRITE,XTEMP,XTEMP2,IUPPER,
     1XTRMSE,
     1IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE
C              SAMPLE STANDARD ERROR OF THE TRIMMED MEAN
C              OF THE DATA IN THE INPUT VECTOR X.
C      NOTE--PROP1 % OF THE DATA IS TRIMSED FROM THE LEFT SIDE;
C            PROP2 % OF THE DATA IS TRIMSED FROM THE RIGHT SIDE.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF
C                                (UNSORTED OR SORTED) OBSERVATIONS.
C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR X.
C                     --PROP1  = THE SINGLE PRECISION PROPORTION (0 TO 100)
C                                OF OBSERVATIONS TO BE TRIMSED FROM LEFT SIDE.
C                     --PROP2  = THE SINGLE PRECISION PORTION (0 TO 100)
C                                OF OBSERVATIONS TO BE TRIMSED FROM RIGHT SIDE.
C     OUTPUT ARGUMENTS--XTRMSE  = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED SAMPLE TRIMSED MEAN.
C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
C             SAMPLE TRIMMED MEAN STANDARD ERROR.
C     OTHER DATAPAC   SUBROUTINES NEEDED--WINSOR.
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               --RAND R. WILCOX, INTRODUCTION TO ROBUST ESTIMATION
C                 AND HYPOTHESIS TESTING, ACADEMIC PRESS, 1997.
C                 THE FORMULA FOR THE STANDARD ERROR IS TAKEN FROM
C                 PAGE 36-38 OF THIS SOURCE.
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--WE DO NOT NEED TO ACTUALLY COMPUTE THE TRIMMED MEAN
C           TO OBTAIN THE STANDARD ERROR.  THE STANDARD ERROR IS:
C               s(w)/[(1-2*LAMBDA)*SQRT(N)]
C           WHERE s(w) IS THE WINSORIZED STANDARD DEVIATION AND
C           LAMBDA IS THE AMOUNT OF TRIMMING (AS A FRACTION).
C           NOTE THAT WE USE PROP1 + PROP2 RATHER THAN LAMBDA.
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--2002.7
C     ORIGINAL VERSION--JULY      2002.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      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='TRIM'
      ISUBN2='ME  '
C
      IERROR='NO'
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      AN=N
C
      IF(2.LE.N.AND.N.LE.IUPPER)GOTO119
      IERROR='YES'
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,111)
  111 FORMAT('***** ERROR IN TRIMSE--THE INPUT NUMBER OF OBSERVATIONS ',
     1       ' IN THE VARIABLE')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,114)
  114 FORMAT('      FOR WHICH THE TRIMMED MEAN STANDARD ERROR IS TO ',
     1       'BE COMPUTED')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,115)IUPPER
  115 FORMAT('      MUST BE BETWEEN 2 AND ',I8,' (INCLUSIVELY).')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,116)
  116 FORMAT('      SUCH WAS NOT THE CASE HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,117)N
  117 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS = ',I8,'.')
      CALL DPWRST('XXX','BUG ')
      GOTO9000
  119 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 TRIMMED MEAN STANDARD ',
     1       'ERROR--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,137)HOLD
  137 FORMAT('THE RESPONSE VARIABLE HAS ALL ELEMENTS = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      XTRMSE=0.0
      GOTO9000
  139 CONTINUE
C
      IF(0.0.LE.PROP1.AND.PROP1.LE.100.0)GOTO149
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,141)
  141 FORMAT('***** ERROR IN TRIMMED MEAN STANDARD ERROR--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,142)
  142 FORMAT('PROP1 SHOULD BE BETWEEN 0 AND 100, BUT IS NOT.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,143)PROP1
  143 FORMAT('THE VALUE OF PROP1 IS ',E15.7)
      CALL DPWRST('XXX','BUG ')
  149 CONTINUE
C
      IF(0.0.LE.PROP2.AND.PROP2.LE.100.0)GOTO159
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,151)
  151 FORMAT('***** ERROR IN TRIMMED MEAN STANDARD ERROR--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,152)
  152 FORMAT('PROP2 SHOULD BE BETWEEN 0 AND 100, BUT IS NOT.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,153)PROP2
  153 FORMAT('THE VALUE OF PROP2 IS ',E15.7)
      CALL DPWRST('XXX','BUG ')
  159 CONTINUE
C
  190 CONTINUE
C
C               ***********************************
C               **  STEP 2: WINSORIZE THE DATA   **
C               ***********************************
C
      CALL WINSOR(X,N,PROP1,PROP2,IWRITE,XTEMP,IUPPER,XTEMP2,
     1IBUGA3,IERROR)
      CALL SD(XTEMP2,N,IWRITE,WINVAR,IBUGA3,IERROR)
C
      ALAM=(PROP1 + PROP2)/100.0
      AN=REAL(N)
C
      XTRMSE=WINVAR/((1.0-ALAM)*SQRT(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 ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,820)PROP1,PROP2
  820 FORMAT(F7.2,'% TRIMMED BELOW AND ',F7.2,'% TRIMMED ABOVE')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,821)N,XTRMSE
  821 FORMAT('THE STANDARD ERROR OF THE TRIMMED MEAN OF THE ',I8,
     1       ' OBSERVATIONS = ',E15.7)
      CALL DPWRST('XXX','BUG ')
  890 CONTINUE
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'OFF')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF TRIMSE--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IBUGA3,IERROR
 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)N
 9013 FORMAT('N = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9014)PROP1,PROP2
 9014 FORMAT('PROP1,PROP2 = ',2E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9018)WINVAR,XTRMSE
 9018 FORMAT('WINVAR,XTRMSE = ',2E15.7)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE TRICDF(X,C,ALOWLM,AUPPLM,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE TRIANGULAR DISTRIBUTION.
C              THIS DISTRIBUTION HAS MEAN = 0.0 ((A+B+C)/3)
C              THE TRIANGULAR DISTRIBUTION HAS LOWER LIMIT A AND
C              UPPER LIMIT B, WHICH DATAPLOT DEFINES TO BE -1 AND 1
C              RESPECTIVELY.  IT HAS SHAPE PARAMETER C.  SOME 
C              DEFINE THE STANDARD DISTRIBUTION TO BE A = 0, B = 1,
C              C = 0.5, WHEREAS DATAPLOT USES A = -1, B = 1, C = 0.
C              THIS DISTRIBUTION HAS THE PROBABILITY
C              DENSITY FUNCTION
C              F(X) = 2(X-A)/[(B-A)(C-A)]    FOR A <= X <= C
C              F(X) = 2(B-X)/[(B-A)(B-C)]    FOR C <= X <= B
C              FOR THE GIVEN VALUES OF A AND B, THIS REDUCES TO
C              F(X) = (X+1)/(C+1)            FOR -1 <= X <= C
C              F(X) = (1-X)/(1-C)            FOR  C <= X <= 1
C              AND FOR C = 0
C              F(X) = 1+X                    FOR -1 LE X LE 0
C              F(X) = 1-X                    FOR  0 LT X LE 1
C              THIS DISTRIBUTION IS IMPORTANT IN THAT IT IS
C              THE DISTRIBUTION THAT RESULTS
C              FROM THE CONVOLUTION OF 2 UNIFORM DISTRIBUTIONS.
C              (BUT NOTE THAT THE TRIANGULAR DISTRIBUTION DEFINED HEREIN
C              IS NOT DEFINED OVER 0 TO 2 AS ONE WOULD EXPECT
C              FROM CONVOLVING 2 UNIFORMS EACH DEFINED OVER 0 TO 1,
C              BUT RATHER HAS BEEN DISPLACED TO -1 TO 1
C              SO AS TO BE SYMMETRIC ABOUT 0.)
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C                     --C      = THE SINGLE PRECISION SHAPE PARAMETER
C     OUTPUT ARGUMENTS--CDF    = THE SINGLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE CDF.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 
C     RESTRICTIONS--X SHOULD BE BETWEEN 0 AND 1, INCLUSIVELY.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN. 
C     REFERENCES--EVANS, HASTINGS, PEACOCK, STATISTICAL DISTRIBUTIONS
C                 2ND ED.--CHAPTER 39.
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--2, 1970, PAGES 57-74.
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--SEPTEMBER 1994. 
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      A=MIN(ALOWLM,AUPPLM)
      B=MAX(ALOWLM,AUPPLM)
C
      IF(X.LE.A)THEN
        CDF=0.0
        GOTO9000
      ELSEIF(X.GE.B)THEN
        CDF=1.0
        GOTO9000
      ENDIF
C
      IF(C.LE.A.OR. C.GE.B)THEN
        WRITE(ICOUT,12)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,3)A,B
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)C
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9000
      ELSEIF(A.EQ.B)THEN
        WRITE(ICOUT,22)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,23)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)A
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9000
      ENDIF
    2 FORMAT(
     1'***** ERROR--THE FIRST INPUT ARGUMENT TO THE ',
     1'TRICDF SUBROUTINE')
    3 FORMAT(
     1'      IS OUTSIDE THE (',G15.7,',',G15.7,') INTERVAL.')
   12 FORMAT(
     1'***** ERROR--THE SECOND INPUT ARGUMENT TO THE TRICDF ',
     1'SUBROUTINE')
   22 FORMAT(
     1'***** ERROR--THE THIRD AND FOURTH INPUT ARGUMENTS TO THE ',
     1'TRICDF SUBROUTINE')
   23 FORMAT(
     1'      (THE LOWER AND UPPER LIMITS) ARE EQUAL.')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
C
C-----START POINT-----------------------------------------------------
C
      IF(X.LE.C)THEN
        CDF=(X-A)**2/((B-A)*(C-A))
      ELSE
        CDF=1.0 - (B-X)**2/((B-A)*(B-C))
      ENDIF
C
 9000 CONTINUE
      RETURN
      END 
      SUBROUTINE TRIPDF(X,C,ALOWLM,AUPPLM,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE TRIANGULAR DISTRIBUTION.
C              THIS DISTRIBUTION HAS MEAN = 0.0 ((A+B+C)/3)
C              AND STANDARD DEVIATION = SQRT(1/6) = 0.408248
C              THE TRIANGULAR DISTRIBUTION HAS LOWER LIMIT A AND
C              UPPER LIMIT B, WHICH DATAPLOT DEFINES TO BE -1 AND 1
C              RESPECTIVELY.  IT HAS SHAPE PARAMETER C.  SOME 
C              DEFINE THE STANDARD DISTRIBUTION TO BE A = 0, B = 1,
C              C = 0.5, WHEREAS DATAPLOT USES A = -1, B = 1, C = 0.
C              THIS DISTRIBUTION HAS THE PROBABILITY
C              DENSITY FUNCTION
C              F(X) = 2(X-A)/[(B-A)(C-A)]    FOR A <= X <= C
C              F(X) = 2(B-X)/[(B-A)(B-C)]    FOR C <= X <= B
C              FOR THE GIVEN VALUES OF A AND B, THIS REDUCES TO
C              F(X) = (X+1)/(C+1)            FOR -1 <= X <= C
C              F(X) = (1-X)/(1-C)            FOR  C <= X <= 1
C              AND FOR C = 0
C              F(X) = 1+X                    FOR -1 LE X LE 0
C              F(X) = 1-X                    FOR  0 LT X LE 1
C              THIS DISTRIBUTION IS IMPORTANT IN THAT IT IS
C              THE DISTRIBUTION THAT RESULTS
C              FROM THE CONVOLUTION OF 2 UNIFORM DISTRIBUTIONS.
C              (BUT NOTE THAT THE TRIANGULAR DISTRIBUTION DEFINED HEREIN
C              IS NOT DEFINED OVER 0 TO 2 AS ONE WOULD EXPECT
C              FROM CONVOLVING 2 UNIFORMS EACH DEFINED OVER 0 TO 1,
C              BUT RATHER HAS BEEN DISPLACED TO -1 TO 1
C              SO AS TO BE SYMMETRIC ABOUT 0.)
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                     --C      = THE SINGLE PRECISION SHAPE PARAMETER
C     OUTPUT ARGUMENTS--PDF    = THE SINGLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE PDF.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 
C     RESTRICTIONS--X SHOULD BE BETWEEN 0 AND 1, INCLUSIVELY.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN. 
C     REFERENCES--EVANS, HASTINGS, PEACOCK, STATISTICAL DISTRIBUTIONS
C                 2ND ED.--CHAPTER 39.
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--2, 1970, PAGES 57-74.
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--SEPTEMBER 1994. 
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      A=MIN(ALOWLM,AUPPLM)
      B=MAX(ALOWLM,AUPPLM)
C
      IF(X.LT.A .OR. X.GT.B)THEN
        WRITE(ICOUT,2)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,3)A,B
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9000
      ELSEIF(C.LE.A .OR. C.GE.B)THEN
        WRITE(ICOUT,12)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,3)A,B
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)C
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9000
      ELSEIF(A.EQ.B)THEN
        WRITE(ICOUT,22)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,23)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)A
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9000
      ENDIF
    2 FORMAT(
     1'***** ERROR--THE FIRST INPUT ARGUMENT TO THE ',
     1'TRIPDF SUBROUTINE')
    3 FORMAT(
     1'      IS OUTSIDE THE (',G15.7,',',G15.7,') INTERVAL.')
   12 FORMAT(
     1'***** ERROR--THE SECOND INPUT ARGUMENT TO THE TRIPDF ',
     1'SUBROUTINE')
   22 FORMAT(
     1'***** ERROR--THE THIRD AND FOURTH INPUT ARGUMENTS TO THE ',
     1'TRIPDF SUBROUTINE')
   23 FORMAT(
     1'      (THE LOWER AND UPPER LIMITS) ARE EQUAL.')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
C
C-----START POINT-----------------------------------------------------
C
      IF(X.LE.C)THEN
        PDF=2.0*(X-A)/((B-A)*(C-A))
      ELSE
        PDF=2.0*(B-X)/((B-A)*(B-C))
      ENDIF
C
 9000 CONTINUE
      RETURN
      END 
      SUBROUTiNE TRIPPF(P,C,ALOWLM,AUPPLM,PPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE TRIANGULAR
C              DISTRIBUTION ON THE INTERVAL (-1,1).
C              THIS DISTRIBUTION HAS MEAN = 0.0 ((A+B+C)/3)
C              AND STANDARD DEVIATION = SQRT(1/6) = 0.408248
C              THE TRIANGULAR DISTRIBUTION HAS LOWER LIMIT A AND
C              UPPER LIMIT B, WHICH DATAPLOT DEFINES TO BE -1 AND 1
C              RESPECTIVELY.  IT HAS SHAPE PARAMETER C.  SOME 
C              DEFINE THE STANDARD DISTRIBUTION TO BE A = 0, B = 1,
C              C = 0.5, WHEREAS DATAPLOT USES A = -1, B = 1, C = 0.
C              THIS DISTRIBUTION HAS THE PROBABILITY
C              DENSITY FUNCTION
C              F(X) = 2(X-A)/[(B-A)(C-A)]    FOR A <= X <= C
C              F(X) = 2(B-X)/[(B-A)(B-C)]    FOR C <= X <= B
C              FOR THE GIVEN VALUES OF A AND B, THIS REDUCES TO
C              F(X) = (X+1)/(C+1)            FOR -1 <= X <= C
C              F(X) = (1-X)/(1-C)            FOR  C <= X <= 1
C              AND FOR C = 0
C              F(X) = 1+X                    FOR -1 LE X LE 0
C              F(X) = 1-X                    FOR  0 LT X LE 1
C              (A TRIANGLE).
C              THIS DISTRIBUTION IS IMPORTANT IN THAT IT IS
C              THE DISTRIBUTION THAT RESULTS
C              FROM THE CONVOLUTION OF 2 UNIFORM DISTRIBUTIONS.
C              (BUT NOTE THAT THE TRIANGULAR DISTRIBUTION DEFINED HEREIN
C              IS NOT DEFINED OVER 0 TO 2 AS ONE WOULD EXPECT
C              FROM CONVOLVING 2 UNIFORMS EACH DEFINED OVER 0 TO 1,
C              BUT RATHER HAS BEEN DISPLACED TO -1 TO 1
C              SO AS TO BE SYMMETRIC ABOUT 0.)
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--SQRT.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--FILLIBEN, SIMPLE AND ROBUST LINEAR ESTIMATION
C                 OF THE LOCATION PARAMETER OF A SYMMETRIC
C                 DISTRIBUTION (UNPUBLISHED PH.D. DISSERTATION,
C                 PRINCETON UNIVERSITY), 1969, PAGES 21-44, 229-231.
C               --FILLIBEN, 'THE PERCENT POINT FUNCTION',
C                 (UNPUBLISHED MANUSCRIPT), 1970, PAGES 28-31.
C               --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--2, 1970, PAGES 57-74.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 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--82.6
C     ORIGINAL VERSION--APRIL     1978.
C     UPDATED         --DECEMBER  1981.
C     UPDATED         --MAY       1982.
C     UPDATED         --SEPTEMBER 1994.  ACCOMODATE C PARAMETER.
C     UPDATED         --JANUARY   1995.  FIX FOR C <> 0.
C     UPDATED         --JANUARY   1995.  TEST FOR C OUT OF RANGE
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
      A=MIN(ALOWLM,AUPPLM)
      B=MAX(ALOWLM,AUPPLM)
C
      IF(P.LT.0.0 .OR. P.GT.1.0)THEN
        WRITE(ICOUT,2)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,3)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)P
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
        GOTO9000
      ELSEIF(C.LE.A .OR. C.GE.B)THEN
        WRITE(ICOUT,12)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,13)A,B
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)C
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
        GOTO9000
      ELSEIF(A.EQ.B)THEN
        WRITE(ICOUT,22)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,23)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)A
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
        GOTO9000
      ENDIF
    2 FORMAT(
     1'***** ERROR--THE FIRST INPUT ARGUMENT TO THE ',
     1'TRIPPF SUBROUTINE')
    3 FORMAT(
     1'      IS OUTSIDE THE (0,1) INTERVAL.')
   12 FORMAT(
     1'***** ERROR--THE SECOND INPUT ARGUMENT TO THE TRIPDF ',
     1'SUBROUTINE')
   13 FORMAT(
     1'      IS OUTSIDE THE (',G15.7,',',G15.7,') INTERVAL.')
   22 FORMAT(
     1'***** ERROR--THE THIRD AND FOURTH INPUT ARGUMENTS TO THE ',
     1'TRIPDF SUBROUTINE')
   23 FORMAT(
     1'      (THE LOWER AND UPPER LIMITS) ARE EQUAL.')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
C
      IF(P.EQ.0)THEN
        PPF=A
      ELSEIF(P.EQ.1.0)THEN
        PPF=B
      ELSE
        CALL TRICDF(C,C,ALOWLM,AUPPLM,PCUT)
        IF(P.LE.PCUT)THEN
          C1=(B-A)*(C-A)
          PPF=A + SQRT(P*C1)
        ELSE
          C2=(B-A)*(B-C)
          PPF=B - SQRT((1.0-P)*C2)
        ENDIF
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE TRIRAN(N,C,ZLOWLM,ZUPPLM,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE TRIANGULAR DISTRIBUTION
C              WITH MEAN = 0 AND STANDARD DEVIATION = ZZ.
C              THIS DISTRIBUTION IS DEFINED FOR ALL X AND HAS
C              THE PROBABILITY DENSITY FUNCTION
C              F(X) = ZZZ
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST N)
C                                INTO WHICH THE GENERATED
C                                RANDOM SAMPLE WILL BE PLACED.
C     OUTPUT--A RANDOM SAMPLE OF SIZE N
C             FROM THE TRIANGULAR DISTRIBUTION
C             WITH MEAN = 0 AND STANDARD DEVIATION = ZZZ
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN, TRIPPF
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--TOCHER, THE ART OF SIMULATION,
C                 1963, PAGES 14-15.
C               --HAMMERSLEY AND HANDSCOMB, MONTE CARLO METHODS,
C                 1964, PAGE 36.
C               --FILLIBEN, SIMPLE AND ROBUST LINEAR ESTIMATION
C                 OF THE LOCATION PARAMETER OF A SYMMETRIC
C                 DISTRIBUTION (UNPUBLISHED PH.D. DISSERTATION,
C                 PRINCETON UNIVERSITY), 1969, PAGE 230.
C               --FILLIBEN, 'THE PERCENT POINT FUNCTION',
C                 (UNPUBLISHED MANUSCRIPT), 1970, PAGES 28-31.
C               --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--2, 1970, PAGES ZZZ.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 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--82.6
C     ORIGINAL VERSION--JUNE      1978.
C     UPDATED         --DECEMBER  1981.
C     UPDATED         --MAY       1982.
C     UPDATED         --SEPTEMBER 1994.  FIX BUG
C     UPDATED         --SEPTEMBER 2001.  SUPPORT FOR C SHAPE PARAMETER
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'TRIRAN 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 TRIANGULAR RANDOM NUMBERS
C     USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD.
C
CCCCC SEPTEMBER 1994.  FIX FOLLOWING LOOP.
CCCCC C=0.0
      A=MIN(ZLOWLM,ZUPPLM)
      B=MAX(ZLOWLM,ZUPPLM)
c
      IF(C.LE.A .OR. C .GE.B)THEN
        WRITE(ICOUT,210)A,B
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,48)C
        CALL DPWRST('XXX','BUG ')
        RETURN
      ENDIF
  210 FORMAT('*****ERROR--THE SHAPE PARAMETER IS OUTSIDE THE ',
     1'ALLOWABLE (',G15.7,',',G15.7,') INTERVAL.')
   48 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.7,' *****')
C
      DO100I=1,N
CCCCC   CALL TRIPPF(X(I),X(I))
        P=X(I)
        CALL TRIPPF(P,C,A,B,PPF)
        X(I)=PPF
  100 CONTINUE
C
      RETURN
      END
      SUBROUTINE TSPCDF(X,THETA,AN,CDF)
C
C     NOTE--STANDARD TWO-SIDED POWER DISTRIBUTION (STSP).
C           CDF IS:
C              TSPCDF(X,THETA,N)
C                  = THETA*(X/THETA)**N          0 <= X <= THETA
C                  = 1 - (1-THETA)*((1-X)/(1-THETA))**N
C                                                THETA <= X <= 1
C     REFERENCE --"THE STANDARD TWO-SIDED POWER DISTRIBUTION AND
C                 ITS PRoPERTIES WITH APPLICATIONS IN FINANCIAL
C                 ENGINEERING", J. RENE VAN DORP AND SAMUEL KOTZ,
C                 AMERICAN STATISTICIAN, VOLUME 56,
C                 NUMBER 2, MAY, 2002.
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/5
C     ORIGINAL VERSION--MAY       2002.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C
      DOUBLE PRECISION DCDF
      DOUBLE PRECISION DTHETA
      DOUBLE PRECISION DAN
      DOUBLE PRECISION DX
      DOUBLE PRECISION DTERM3
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
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
      IF(THETA.LT.0.0 .OR. THETA.GT.1.0)THEN
        WRITE(ICOUT,101)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,103)THETA
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
      IF(AN.LE.0.0)THEN
        WRITE(ICOUT,201)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,203)AN
        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(X.GT.1.0)THEN
        CDF=1.0
        WRITE(ICOUT,401)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,402)X
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
  101 FORMAT('***** FATAL DIAGNOSTIC--THETA IS OUTSIDE THE ',
     1       'ALLOWABLE (0,1) RANGE.')
  103 FORMAT('      THE VALUE OF THETA IS ',E15.7)
  201 FORMAT('***** FATAL DIAGNOSTIC--N IS NON-POSITIVE.')
  203 FORMAT('      THE VALUE OF N IS ',E15.7,'       ******')
  301 FORMAT('***** FATAL DIAGNOSTIC--THE INPUT ARGUMENT IS ')
  302 FORMAT('      NEGATIVE.  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)
C
      IF(X.EQ.0.0)GOTO9999
      IF(X.EQ.1.0)THEN
        CDF=1.0
        GOTO9999
      ENDIF
C
      DX=DBLE(X)
      DTHETA=DBLE(THETA)
      DAN=DBLE(AN)
      IF(DX.LE.DTHETA)THEN
        DTERM3=DLOG(DTHETA) + DAN*(DLOG(DX) - DLOG(DTHETA))
        DCDF=DEXP(DTERM3)
      ELSE
        DTERM3=DLOG(1.0D0-DTHETA) + 
     1         DAN*(DLOG(1.0D0-DX) - DLOG(1.0D0-DTHETA))
        DCDF=1.0D0 - DEXP(DTERM3)
      ENDIF
      CDF=REAL(DCDF)
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE TSPPDF(X,THETA,AN,PDF)
C
C     NOTE--STANDARD TWO-SIDED POWER DISTRIBUTION (STSP).
C           PDF IS:
C              TSPPDF(X,THETA,N)
C                  = N*(X/THETA)**(N-1)          0 < X <= THETA
C                  = N*((1-X)/(1-THETA))**(N-1)  THETA <= X < 1
C     REFERENCE --"THE STANDARD TWO-SIDED POWER DISTRIBUTION AND
C                 ITS PRoPERTIES WITH APPLICATIONS IN FINANCIAL
C                 ENGINEERING", J. RENE VAN DORP AND SAMUEL KOTZ,
C                 AMERICAN STATISTICIAN, VOLUME 56,
C                 NUMBER 2, MAY, 2002.
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/5
C     ORIGINAL VERSION--MAY       2002.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C
      DOUBLE PRECISION DPDF
      DOUBLE PRECISION DTHETA
      DOUBLE PRECISION DAN
      DOUBLE PRECISION DX
      DOUBLE PRECISION DTERM3
      DOUBLE PRECISION DTERM4
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
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
      IF(THETA.LT.0.0 .OR. THETA.GT.1.0)THEN
        WRITE(ICOUT,101)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,103)THETA
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
      IF(AN.LE.0.0)THEN
        WRITE(ICOUT,201)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,203)AN
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
      IF(X.LE.0.0)THEN
        WRITE(ICOUT,301)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,302)X
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
      IF(X.GE.1.0)THEN
        WRITE(ICOUT,401)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,402)X
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
  101 FORMAT('***** FATAL DIAGNOSTIC--THETA IS OUTSIDE THE ',
     1       'ALLOWABLE (0,1) RANGE.')
  103 FORMAT('      THE VALUE OF THETA IS ',E15.7)
  201 FORMAT('***** FATAL DIAGNOSTIC--N IS NON-POSITIVE.')
  203 FORMAT('      THE VALUE OF N 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 OR EQUAL TO 1.  IT HAS THE VALUE ',E15.7)
C
      DX=DBLE(X)
      DTHETA=DBLE(THETA)
      DAN=DBLE(AN)
      IF(DX.LE.DTHETA)THEN
        DTERM3=DLOG(DAN) + (DAN-1.0D0)*(DLOG(DX) - DLOG(DTHETA))
        DPDF=DEXP(DTERM3)
      ELSE
        DTERM3=DLOG(DAN)
        DTERM4=(DAN-1.0D0)*(DLOG(1.0D0-DX) - DLOG(1.0D0-DTHETA))
        DPDF=DEXP(DTERM3 + DTERM4)
      ENDIF
      PDF=REAL(DPDF)
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE TSPPPF(P,THETA,AN,PPF)
C
C     NOTE--STANDARD TWO-SIDED POWER DISTRIBUTION (STSP).
C           PPF IS:
C              TSPPPF(P,THETA,N)
C                  = THETA*(P/THETA)**(1/N)      0 < P <= THETA
C                  = 1 - (1-THETA)*((1-P)/(1-THETA))**(1/N)
C                                                P > THETA < 1
C     REFERENCE --"THE STANDARD TWO-SIDED POWER DISTRIBUTION AND
C                 ITS PRoPERTIES WITH APPLICATIONS IN FINANCIAL
C                 ENGINEERING", J. RENE VAN DORP AND SAMUEL KOTZ,
C                 AMERICAN STATISTICIAN, VOLUME 56,
C                 NUMBER 2, MAY, 2002.
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/5
C     ORIGINAL VERSION--MAY       2002.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C
      DOUBLE PRECISION DPPF
      DOUBLE PRECISION DTHETA
      DOUBLE PRECISION DAN
      DOUBLE PRECISION DP
      DOUBLE PRECISION DTERM3
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      PPF=0.0
C
      IF(THETA.LT.0.0 .OR. THETA.GT.1.0)THEN
        WRITE(ICOUT,101)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,103)THETA
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
      IF(AN.LE.0.0)THEN
        WRITE(ICOUT,201)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,203)AN
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
      IF(P.LT.0.0)THEN
        WRITE(ICOUT,301)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,302)P
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
      IF(P.GT.1.0)THEN
        PPF=1.0
        WRITE(ICOUT,401)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,402)P
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
  101 FORMAT('***** FATAL DIAGNOSTIC--THETA IS OUTSIDE THE ',
     1       'ALLOWABLE (0,1) RANGE.')
  103 FORMAT('      THE VALUE OF THETA IS ',E15.7)
  201 FORMAT('***** FATAL DIAGNOSTIC--N IS NON-POSITIVE.')
  203 FORMAT('      THE VALUE OF N IS ',E15.7,'       ******')
  301 FORMAT('***** FATAL DIAGNOSTIC--THE INPUT ARGUMENT IS ')
  302 FORMAT('      NEGATIVE.  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)
C
      IF(P.LE.0.0)THEN
        PPF=0.0
        GOTO9999
      ELSEIF(P.GE.1.0)THEN
        PPF=1.0
        GOTO9999
      ENDIF
      DP=DBLE(P)
      DTHETA=DBLE(THETA)
      DAN=DBLE(AN)
      IF(DP.LE.DTHETA)THEN
        DTERM3=DLOG(DTHETA) + (1.0D0/DAN)*(DLOG(DP) - DLOG(DTHETA))
        DPPF=DEXP(DTERM3)
      ELSE
        DTERM3=DLOG(1.0D0-DTHETA) + 
     1         (1.0D0/DAN)*(DLOG(1.0D0-DP) - DLOG(1.0D0-DTHETA))
        DPPF=1.0D0 - DEXP(DTERM3)
      ENDIF
      PPF=REAL(DPPF)
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE TSPRAN(N,THETA,AN,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE TWO-SIDED POWER DISTRIBUTION
C              WITH SHAPE PARAMETERS = THETA AND N.
C     NOTE--STANDARD TWO-SIDED POWER DISTRIBUTION (STSP).
C           PDF IS:
C              TSPPDF(X,THETA,N)
C                  = N*(X/THETA)**(N-1)          0 < X <= THETA
C                  = N*((1-X)/(1-THETA))**(N-1)  THETA <= X < 1
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --THETA  = THE SINGLE PRECISION VALUE OF THE
C                                SHAPE PARAMETER THETA.
C                                THETA SHOULD BE IN THE RANGE (0,1).
C                     --AN     = THE SINGLE PRECISION VALUE OF THE
C                                SHAPE PARAMETER N.
C                                AN 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 TWO-SIDED POWER DISTRIBUTION
C             WITH SHAPE PARAMETERS = THETA AND N.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C                 --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     REFERENCE --"THE STANDARD TWO-SIDED POWER DISTRIBUTION AND
C                 ITS PRoPERTIES WITH APPLICATIONS IN FINANCIAL
C                 ENGINEERING", J. RENE VAN DORP AND SAMUEL KOTZ,
C                 AMERICAN STATISTICIAN, VOLUME 56,
C                 NUMBER 2, MAY, 2002.
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--2002.5
C     ORIGINAL VERSION--MAY       2002.
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(THETA.LT.0.0 .OR. THETA.GT.1.0)THEN
        WRITE(ICOUT,101)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,103)THETA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
      IF(AN.LE.0.0)THEN
        WRITE(ICOUT,201)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,203)AN
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
  101 FORMAT('***** FATAL DIAGNOSTIC--THETA IS OUTSIDE THE ',
     1       'ALLOWABLE (0,1) RANGE.')
  103 FORMAT('      THE VALUE OF THETA IS ',E15.7)
  201 FORMAT('***** FATAL DIAGNOSTIC--N IS NON-POSITIVE.')
  203 FORMAT('      THE VALUE OF N IS ',E15.7,'       ******')
C
C     GENERATE N UNIFORM (0,1) RANDOM NUMBERS;
C
      CALL UNIRAN(N,ISEED,X)
C
C     GENERATE N TWO-SIDED POWER DISTRIBUTION RANDOM
C     NUMBERS USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD.
C
      DO100I=1,N
        CALL TSPPPF(X(I),THETA,AN,XTEMP)
        X(I)=XTEMP
  100 CONTINUE
C
 9000 CONTINUE
      RETURN
      END
