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,ANU,CDF) CCCCC 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 UPDATED --OCTOBER 2006. SUPPORT FOR FRACTIONAL C DEGREES OF FREEDOM 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 DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 DOUBLE PRECISION DTERM3 DOUBLE PRECISION DTERM4 DOUBLE PRECISION DBETAI C EXTERNAL DBETAI C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----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 NU=INT(ANU) IF(ABS(ANU-REAL(NU)).GT.0.000001)GOTO8000 C IF(NU.LE.0)THEN WRITE(ICOUT,115) 115 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT ', 1 'TO TCDF IS NON-POSITIVE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,147)NU 147 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8) CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9000 ENDIF C C **************************************************** C ** STEP 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 GOTO9000 C CCCCC OCTOBER 2006: FRACTIONAL DEGREES OF FREEDOM CASE. C 8000 CONTINUE IF(ANU.LE.0.0)THEN WRITE(ICOUT,8115) 8115 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT ', 1 'TO TCDF IS NON-POSITIVE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8147)ANU 8147 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7) CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9000 ENDIF C DX=DBLE(X) DNU=DBLE(ANU) C DTERM1=1.0D0/(1.0D0 + DX*DX/DNU) DTERM2=DNU/2.0D0 DTERM3=0.5D0 DTERM4=DBETAI(DTERM1,DTERM2,DTERM3) IF(DX.EQ.0.0D0)THEN DCDF=0.5D0 ELSEIF(DX.LE.0.0D0)THEN DCDF=0.5D0*DTERM4 ELSE DCDF=1.0D0 - 0.5D0*DTERM4 ENDIF CDF=REAL(DCDF) C GOTO9000 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,ANU,PDF) CCCCC 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 UPDATED --OCTOBER 2006. SUPPORT FOR FRACTIONAL C DEGREES OF FREEDOM 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 DOUBLE PRECISION DPI DOUBLE PRECISION DNUM DOUBLE PRECISION DDENOM DOUBLE PRECISION DPDF DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 DOUBLE PRECISION DTERM3 DOUBLE PRECISION DTERM4 DOUBLE PRECISION DLNGAM C EXTERNAL DLNGAM C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----DATA STATEMENTS------------------------------------------------- C DATA DPI / 3.14159265358979D+00/ DATA DSQTPI/1.77245385090552D0/ C C-----START POINT----------------------------------------------------- C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C NU=INT(ANU) IF(ABS(ANU-REAL(NU)).GT.0.000001)GOTO8000 C IF(NU.LE.0)THEN WRITE(ICOUT,115) 115 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT ', 1 'TO TPDF IS NON-POSITIVE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,147)NU 147 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8) CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9000 ENDIF C C **************************************************************** C ** STEP 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 CCCCC OCTOBER 2006: FRACTIONAL DEGREES OF FREEDOM CASE. C 8000 CONTINUE IF(ANU.LE.0.0)THEN WRITE(ICOUT,8115) 8115 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT ', 1 'TO TPDF IS NON-POSITIVE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8147)ANU 8147 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7) CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9000 ENDIF C DX=DBLE(X) DNU=DBLE(ANU) C DTERM1=(DNU+1.0D0)/2.0D0 DNUM=DLNGAM(DTERM1) C DTERM2=0.5D0*(DLOG(DNU) + DLOG(DPI)) DTERM3=DLNGAM(DNU/2.0D0) DTERM4=((DNU+1.0D0)/2.0D0)*DLOG(1.0D0 + DX**2/DNU) DDENOM=DTERM2 + DTERM3 + DTERM4 + DTERM5 DPDF=DNUM - DDENOM DPDF=DEXP(DPDF) PDF=REAL(DPDF) C GOTO9000 C 9000 CONTINUE RETURN END SUBROUTINE TPPF(P,ANU,PPF) CCCCC 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 UPDATED --OCTOBER 2006. SUPPORT FOR FRACTIONAL C DEGREES OF FREEDOM 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 DOUBLE PRECISION DC DOUBLE PRECISION DALPHA DOUBLE PRECISION EPS DOUBLE PRECISION SIG DOUBLE PRECISION ZERO DOUBLE PRECISION DMEAN DOUBLE PRECISION DSD DOUBLE PRECISION XL DOUBLE PRECISION XR DOUBLE PRECISION XINC DOUBLE PRECISION X DOUBLE PRECISION FXL DOUBLE PRECISION FXR DOUBLE PRECISION P1 DOUBLE PRECISION FCS DOUBLE PRECISION XRML DOUBLE PRECISION DCDF DOUBLE PRECISION CDFL DOUBLE PRECISION CDFR DOUBLE PRECISION DBETAI C EXTERNAL DBETAI C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----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 DATA EPS /0.00001D0/ DATA SIG /1.0D-8/ DATA ZERO /0.0D0/ C 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)THEN WRITE(ICOUT,1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)P CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF 1 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO ', 1'TPPF IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7) C IF(ANU.LT.1.0)THEN WRITE(ICOUT,11) 11 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT ', 1 'TO TPPF IS LESS THAN 1') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)ANU PPF=0.0 GOTO9000 ENDIF C IF(P.EQ.0.5)THEN PPF=0.0 GOTO9000 ENDIF C NU=INT(ANU) IF(ABS(ANU-REAL(NU)).GT.0.000001)GOTO8000 C DNU=NU DP=P MAXIT=5 C IF(NU.EQ.1)THEN C C TREAT THE NU = 1 (CAUCHY) CASE C DARG=PI*DP PPF=-DCOS(DARG)/DSIN(DARG) GOTO9000 ELSEIF(NU.EQ.2)THEN C C TREAT THE NU = 2 CASE C TERM1=SQRT2/2.0D0 TERM2=2.0D0*DP-1.0D0 TERM3=DSQRT(DP*(1.0D0-DP)) PPF=TERM1*TERM2/TERM3 GOTO9000 ELSE C C TREAT THE NU GREATER THAN OR EQUAL TO 3 CASE C 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)GOTO9000 IF(NU.EQ.3)THEN C C AUGMENT THE RESULTS FOR THE NU = 3 CASE C 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 ELSEIF(NU.EQ.4)THEN C C AUGMENT THE RESULTS FOR THE NU = 4 CASE C 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 ELSEIF(NU.EQ.5)THEN C C AUGMENT THE RESULTS FOR THE NU = 5 CASE C 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)/ 1 ((8.0D0/3.0D0)*C**4) 550 CONTINUE PPF=DSQRT(DNU)*S/C ELSEIF(NU.EQ.6)THEN C C AUGMENT THE RESULTS FOR THE NU = 6 CASE C 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)/ 1 ((15.0D0/8.0D0)*C**5) 650 CONTINUE PPF=DSQRT(DNU)*S/C ENDIF GOTO9000 ENDIF C C CASE FOR FRACTIONAL DEGREES OF FREEDOM. USE BISECTION C METHOD TO NUMERICALLY INVERT CDF FUNCTION. C 8000 CONTINUE C C STEP 1: DETERMINE A BRACKETING INTERVAL. USE 0 AS C EITHER THE LOWER OR UPPER LIMIT. C IF(P.GT.0.5)THEN CALL NORPPF(P,XLTEMP) CALL CAUPPF(P,XRTEMP) ELSEIF(P.LT.0.5)THEN CALL NORPPF(P,XRTEMP) CALL CAUPPF(P,XLTEMP) ENDIF XL=DBLE(XLTEMP) XR=DBLE(XRTEMP) DNU=DBLE(ANU) C C BISECTION METHOD C DP=DBLE(P) IC = 0 MAXIT=3000 FXL = -DP FXR = 1.0D0 - DP C 105 CONTINUE X = (XL+XR)*0.5D0 TERM1=1.0D0/(1.0D0 + X*X/DNU) TERM2=DNU/2.0D0 TERM3=0.5D0 TERM4=DBETAI(TERM1,TERM2,TERM3) IF(X.EQ.0.0D0)THEN DCDF=0.5D0 ELSEIF(X.LE.0.0D0)THEN DCDF=0.5D0*TERM4 ELSE DCDF=1.0D0 - 0.5D0*TERM4 ENDIF P1=DCDF PPF=REAL(X) FCS = P1 - DP IF(FCS*FXL.GT.ZERO)THEN XL = X FXL = FCS ELSE XR = X FXR = FCS ENDIF XRML = XR - XL IF(XRML.LE.SIG .AND. ABS(FCS).LE.EPS)GOTO9000 IC = IC + 1 IF(IC.LE.MAXIT)THEN GOTO105 ELSE WRITE(ICOUT,130) CALL DPWRST('XXX','BUG ') 130 FORMAT('***** ERROR--TPPF ROUTINE DID NOT CONVERGE') ENDIF GOTO9000 C 9000 CONTINUE RETURN 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<=XD 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<=XD 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