SUBROUTINE GALCDF(X,AK,TAU,IADEDF,CDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION C FUNCTION VALUE FOR THE GENERALIZED ASYMMETRIC LAPLACE C DISTRIBUTION WITH SHAPE PARAMETERS AK AND LAMBDA. C THIS DISTRIBUTION IS DEFINED FOR ALL X AND HAS C THE PROBABILITY DENSITY FUNCTION C GALPDF(X,K,TAU) = C1*C2*C3 X <> 0 C WITH C C1 = SQRT(2/PI)*EXP((SQRT(2)/2)*((1/K)-K)*X)/ C GAMMA(TAU) C C2 = ((SQRT(2)*ABS(X)/(K+(1/K))**(TAU-0.5) C C3 = K(TAU-0.5)((SQRT(2)/2)*((1/K)+K)*ABS(X)) C WHERE K(LAMBDA) IS THE MODIFIED BESSEL FUNCTION C OF THE THIRD KIND. C THE CUMULATIVE DISTRIBUTION IS COMPUTED BY C NUMERICALLY INTEGRATING THE PDF FUNCTION. C INPUT ARGUMENTS--X = THE DOUBLE PRECISION VALUE AT C WHICH THE CUMULATIVE DISTRIBUTION C FUNCTION IS TO BE EVALUATED. C --AK = THE FIRST SHAPE PARAMETER C --TAU = THE SECOND SHAPE PARAMETER C OUTPUT ARGUMENTS--CDF = THE DOUBLE PRECISION CUMULATIVE C DISTRIBUTION FUNCTION VALUE. C OUTPUT--THE DOUBLE PRECISION CUMULATIVE DISTRIBUTION C FUNCTION VALUE CDF FOR THE GENERALIZED ASYMMETRIC C LAPLACE DISTRIBUTION WITH SHAPE PARAMETERS DAK AND DTAU. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--NONE. C OTHER DATAPAC SUBROUTINES NEEDED--DQAGI. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--KOTZ, KOZUBOWSKI, AND PODGORSKI, "THE LAPLACE C DISTRIBUTION AND GENERALIZATIONS: A REVISIT WITH C APPLICATIONS TO COMMUNICATIONS, ECONOMICS, C ENGINEERING, AND FINANCE", BIRKHAUSER, 2001, C PP. 189. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2004.8 C ORIGINAL VERSION--AUGUST 2004. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C INTEGER LIMIT INTEGER LENW PARAMETER(LIMIT=100) PARAMETER(LENW=4*LIMIT) INTEGER INF INTEGER NEVAL INTEGER IER INTEGER LAST INTEGER IWORK(LIMIT) DOUBLE PRECISION AK DOUBLE PRECISION TAU DOUBLE PRECISION X DOUBLE PRECISION CDF DOUBLE PRECISION EPSABS DOUBLE PRECISION EPSREL DOUBLE PRECISION RESULT DOUBLE PRECISION DCDF DOUBLE PRECISION DX DOUBLE PRECISION ABSERR DOUBLE PRECISION WORK(LENW) C DOUBLE PRECISION GALFUN EXTERNAL GALFUN C CHARACTER*4 IADEDF CHARACTER*4 IADED2 C DOUBLE PRECISION DAK DOUBLE PRECISION DTAU COMMON/GALCOM/DAK,DTAU C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,AKMBPC,AKMCPW,AKMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----DATA STATEMENTS------------------------------------------------- C C-----START POINT----------------------------------------------------- C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C IF(IADEDF.EQ.'K')THEN IF(AK.LE.0.0)THEN WRITE(ICOUT,5) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,48)AK CALL DPWRST('XXX','WRIT') PDF=0.0 GOTO9000 ENDIF ELSE AK=SQRT(2.0)/(AK + SQRT(2.0 + AK*AK)) ENDIF 5 FORMAT('***** ERROR: VALUE OF FIRST SHAPE PARAMETER (K) IN ', 1 'THE GALCDF ROUTINE IS NON-POSITIVE.') IF(TAU.LE.0.0)THEN WRITE(ICOUT,15) 15 FORMAT('***** ERROR--THE SECOND SHAPE PARAMETER (TAU) IN THE ', 1 'GALCDF ROUTINE IS NON-POSITIVE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,48)TAU CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9000 ENDIF 48 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7) C C ************************************ C ** STEP 1-- ** C ** COMPUTE THE DENSITY FUNCTION ** C ************************************ C IADED2=IADEDF IADEDF='K' INF=-1 EPSABS=0.0D0 EPSREL=1.0D-7 IER=0 CDF=0.0D0 C DX=DBLE(X) DTAU=DBLE(TAU) DAK=DBLE(AK) C IFLAG=0 IF(DX.LT.0.0D0)THEN IFLAG=1 INF=1 ENDIF C CALL DQAGI(GALFUN,DX,INF,EPSABS,EPSREL,DCDF,ABSERR,NEVAL, 1 IER,LIMIT,LENW,LAST,IWORK,WORK) C IF(IFLAG.EQ.1)THEN CDF=1.0D0 - DCDF ELSE CDF=DCDF ENDIF C IF(IER.EQ.1)THEN WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,111) 111 FORMAT('***** ERROR FROM GALCDF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,113) 113 FORMAT(' MAXIMUM AKMBER OF SUBDIVISIONS EXCEEDED.') CALL DPWRST('XXX','BUG ') ELSEIF(IER.EQ.2)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,121) 121 FORMAT('***** ERROR FROM GALCDF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,123) 123 FORMAT(' ROUNDOFF ERROR PREVENTS REQUESTED TOLERANCE ', 1 'FROM BEING ACHIEVED.') CALL DPWRST('XXX','BUG ') ELSEIF(IER.EQ.3)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,131) 131 FORMAT('***** ERROR FROM GALCDF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,133) 133 FORMAT(' BAD INTEGRAND BEHAVIOUR DETECTED.') CALL DPWRST('XXX','BUG ') ELSEIF(IER.EQ.4)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,141) 141 FORMAT('***** ERROR FROM GALCDF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,143) 143 FORMAT(' INTEGRATION DID NOT CONVERGE.') CALL DPWRST('XXX','BUG ') ELSEIF(IER.EQ.5)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,151) 151 FORMAT('***** ERROR FROM GALCDF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,153) 153 FORMAT(' THE INTEGRATION IS PROBABLY DIVERGENT.') CALL DPWRST('XXX','BUG ') ELSEIF(IER.EQ.6)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,161) 161 FORMAT('***** ERROR FROM GALCDF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,163) 163 FORMAT(' INVALID INPUT TO THE INTEGRATION ROUTINE.') CALL DPWRST('XXX','BUG ') ENDIF C 9000 CONTINUE IADEDF=IADED2 RETURN END DOUBLE PRECISION FUNCTION GALFUN(DX) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY C FUNCTION VALUE FOR THE GENERALIZED ASYMMETRIC LAPLACE C DISTRIBUTION WITH SHAPE PARAMETERS AK AND TAU. C THIS DISTRIBUTION IS DEFINED C FOR ALL X AND HAS THE PROBABILITY DENSITY FUNCTION C GALPDF(X,K,TAU) = C1*C2*C3 X <> 0 C WITH C C1 = SQRT(2/PI)*EXP((SQRT(2)/2)*((1/K)-K)*X)/ C GAMMA(TAU) C C2 = ((SQRT(2)*ABS(X)/(K+(1/K))**(TAU-0.5) C C3 = K(TAU-0.5)((SQRT(2)/2)*((1/K)+K)*ABS(X)) C WHERE K(LAMBDA) IS THE MODIFIED BESSEL FUNCTION C OF THE THIRD KIND. C BUT DEFINE AS FUNCTION TO BE USED FOR INTEGRATION C CODE CALLED BY GALCDF. ALSO, THIS ROUTINE USES C DOUBLE PRECISION ARITHMETIC. C INPUT ARGUMENTS--DX = THE DOUBLE PRECISION VALUE AT C WHICH THE PROBABILITY DENSITY C FUNCTION IS TO BE EVALUATED. C OUTPUT ARGUMENTS--GALFUN = THE DOUBLE PRECISION PROBABILITY C DENSITY FUNCTION VALUE. C OUTPUT--THE DOUBLE PRECISION PROBABILITY DENSITY C FUNCTION VALUE PDF FOR THE GENERALIZED ASYMMETRIC C LAPLACE DISTRIBUTION WITH SHAPE PARAMETERS AK AND TAU. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--NONE. C OTHER DATAPAC SUBROUTINES NEEDED--GALPDF. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--KOTZ, KOZUBOWSKI, AND PODGORSKI, "THE LAPLACE C DISTRIBUTION AND GENERALIZATIONS: A REVISIT WITH C APPLICATIONS TO COMMUNICATIONS, ECONOMICS, C ENGINEERING, AND FINANCE", BIRKHAUSER, 2001, C PP. 189. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2004.7 C ORIGINAL VERSION--JULY 2004. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DTERM2 C DOUBLE PRECISION DX DOUBLE PRECISION DAK DOUBLE PRECISION DTAU COMMON/GALCOM/DAK,DTAU C INCLUDE 'DPCOST.INC' C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----DATA STATEMENTS------------------------------------------------- C C-----START POINT----------------------------------------------------- C C ************************************ C ** STEP 1-- ** C ** COMPUTE THE DENSITY FUNCTION ** C ************************************ C CALL GALPDF(DX,DAK,DTAU,IADEDF,DTERM2) GALFUN=DTERM2 C 9000 CONTINUE RETURN END DOUBLE PRECISION FUNCTION GALFU2(DX) C C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION C FUNCTION VALUE FOR THE GENERALIZED ASYMMETRIC LAPLACE C DISTRIBUTION WITH SHAPE PARAMETERS K AND TAU. C THIS DISTRIBUTION IS DEFINED FOR ALL REAL X. C INPUT ARGUMENTS--DX = THE DOUBLE PRECISION VALUE AT C WHICH THE CUMULATIVE DISTRIBUTION C FUNCTION IS TO BE EVALUATED. C OUTPUT ARGUMENTS--GALFU2 = THE DOUBLE PRECISION CUMULATIVE C DISTRIBUTION FUNCTION VALUE. C OUTPUT--THE DOUBLE PRECISION CUMULATIVE DISTRIBUTION C FUNCTION VALUE FOR THE GENERALIZED ASYMMETRIC LAPLACE C DISTRIBUTION WITH SHAPE PARAMETERS K AND TAU. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--NONE. C OTHER DATAPAC SUBROUTINES NEEDED--GALCDF. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--KOTZ, KOZUBOWSKI, AND PODGORSKI, "THE LAPLACE C DISTRIBUTION AND GENERALIZATIONS: A REVISIT WITH C APPLICATIONS TO COMMUNICATIONS, ECONOMICS, C ENGINEERING, AND FINANCE", BIRKHAUSER, 2001, C PP. 189. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2004.8 C ORIGINAL VERSION--AUGUST 2004. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C INCLUDE 'DPCOST.INC' C DOUBLE PRECISION DX DOUBLE PRECISION DCDF C DOUBLE PRECISION DP COMMON/GA2COM/DP C DOUBLE PRECISION DK DOUBLE PRECISION DTAU COMMON/GALCOM/DK,DTAU C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----DATA STATEMENTS------------------------------------------------- C C-----START POINT----------------------------------------------------- C C ************************************ C ** STEP 1-- ** C ** COMPUTE THE CDF FUNCTION ** C ************************************ C CALL GALCDF(DX,DK,DTAU,IADEDF,DCDF) GALFU2=DP - DCDF C 9000 CONTINUE RETURN END SUBROUTINE GALPDF(X,AK,TAU,IADEDF,PDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY C FUNCTION VALUE FOR THE GENERALIZED ASYMMETRIC LAPLACE C DISTRIBUTION. THIS IS ALSO KNOWN AS THE BESSEL C K-FUNCTION DISTRIBUTION. IT HAS SHAPE PARAMETERS C K AND TAU (IF TAU = 1, THIS REDUCES TO THE ASYMMETRIC C LAPLACE DISTRIBUTION, IF K = 1, THIS IS A SYMMETRIC C DISTRIBUTIONS). THIS DISTRIBUTION IS DEFINED C FOR ALL X AND HAS THE PROBABILITY DENSITY FUNCTION C GALPDF(X,K,TAU) = C1*C2*C3 X <> 0 C WITH C C1 = SQRT(2/PI)*EXP((SQRT(2)/2)*((1/K)-K)*X)/ C GAMMA(TAU) C C2 = ((SQRT(2)*ABS(X)/(K+(1/K))**(TAU-0.5) C C3 = K(TAU-0.5)((SQRT(2)/2)*((1/K)+K)*ABS(X)) C WHERE K(LAMBDA) IS THE MODIFIED BESSEL FUNCTION C OF THE THIRD KIND. C C NOTE--ARGUMENTS TO THIS ROUTINE ARE IN DOUBLE PRECISION. C INPUT ARGUMENTS--X = THE DOUBLE PRECISION VALUE AT C WHICH THE PROBABILITY DENSITY C FUNCTION IS TO BE EVALUATED. C X SHOULD BE NON-NEGATIVE. C --AK = THE FIRST SHAPE PARAMETER C --TAU = THE SECOND SHAPE PARAMETER C OUTPUT ARGUMENTS--PDF = THE DOUBLE PRECISION PROBABILITY C DENSITY FUNCTION VALUE. C OUTPUT--THE DOUBLE PRECISION PROBABILITY DENSITY FUNCTION C VALUE PDF FOR THE ASYMMETRIC LAPLACE DISTRIBUTION C WITH SHAPE PARAMETER = K. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--NONE. C OTHER DATAPAC SUBROUTINES NEEDED--DBESK. C FORTRAN LIBRARY SUBROUTINES NEEDED--DEXP, DLOG. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--KOTZ, KOZUBOWSKI, AND PODGORSKI, "THE LAPLACE C DISTRIBUTION AND GENERALIZATIONS: A REVISIT WITH C APPLICATIONS TO COMMUNICATIONS, ECONOMICS, C ENGINEERING, AND FINANCE", BIRKHAUSER, 2001, C PP. 189. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2004.6 C ORIGINAL VERSION--JUNE 2004. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION X DOUBLE PRECISION AK DOUBLE PRECISION TAU DOUBLE PRECISION DX DOUBLE PRECISION DK DOUBLE PRECISION DTAU DOUBLE PRECISION PDF DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 DOUBLE PRECISION DTERM3 DOUBLE PRECISION DTERM4 DOUBLE PRECISION DC1 DOUBLE PRECISION DC2 DOUBLE PRECISION DC3 DOUBLE PRECISION DC4 DOUBLE PRECISION DC5 DOUBLE PRECISION DC6 DOUBLE PRECISION DPI DOUBLE PRECISION DEPS DOUBLE PRECISION DSAVE DOUBLE PRECISION DGAMMA EXTERNAL DGAMMA C DOUBLE PRECISION DTEMP1(10) C CHARACTER*4 IADEDF 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 DEPS /0.00000001D0/ C C-----START POINT----------------------------------------------------- C C ***************************************** C ** STEP 1-- ** C ** CHECK FOR VALID PARAMETERS ** C ***************************************** C IF(IADEDF.EQ.'K')THEN IF(AK.LE.0.0)THEN WRITE(ICOUT,5) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,48)AK CALL DPWRST('XXX','WRIT') PDF=0.0 GOTO9000 ENDIF ELSE AK=SQRT(2.0)/(AK + SQRT(2.0 + AK*AK)) ENDIF 5 FORMAT('***** ERROR: VALUE OF FIRST SHAPE PARAMETER (K) IN ', 1 'GALPDF ROUTINE IS NON-POSITIVE.') IF(TAU.LE.0.0D0)THEN WRITE(ICOUT,6) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,48)TAU CALL DPWRST('XXX','WRIT') PDF=0.0D0 GOTO9000 ENDIF 6 FORMAT('***** ERROR: VALUE OF SHAPE PARAMETER (TAU) IN ', 1 'GALPDF ROUTINE IS NEGATIVE.') 48 FORMAT(' VALUE OF ARGUMENT IS: ',G15.7) C DX=X DK=AK DTAU=TAU C C ***************************************** C ** STEP 2-- ** C ** COMPUTE THE DENSITY FUNCTION. FOR ** C ** BETTER NUMERICAL STABILITY, ** C ** COMPUTE LOGARIGHMS. ** C ***************************************** C C IF(X.EQ.0.0D0)THEN DX=DEPS IPASS=1 ENDIF C 1000 CONTINUE C C COMPUTE BESSEL FUNCTION FIRST. IF THIS IS 0, SET PDF TO C 0 AND RETURN. C DC5=(DSQRT(2.0D0)/2.0D0)*(DK + (1.0D0/DK)) DC6=DTAU - 0.5D0 IF(DC6.LT.0.0D0)DC6=-DC6 IARG1=1 ISCALE=1 CALL DBESK(DC5*DABS(DX),DC6,ISCALE,IARG1,DTEMP1,NZERO) DTERM3=DTEMP1(IARG1) IF(DTERM3.LE.0.0D0)THEN PDF=0.0D0 GOTO9000 ENDIF DTERM3=DLOG(DTEMP1(IARG1)) C DC1=DSQRT(2.0D0/DPI)/DGAMMA(DTAU) DC2=(DSQRT(2.0D0)/2.0D0)*((1.0D0/DK) - DK) DTERM1=DLOG(DC1) + DC2*DX DC3=DSQRT(2.0D0)/(DK + (1.0D0/DK)) DC4=DTAU - 0.5D0 DTERM2=DC4*DLOG(DC3*DABS(DX)) C DTERM4=DTERM1+DTERM2+DTERM3 PDF=DEXP(DTERM4) C IF(X.EQ.0.0D0)THEN IF(IPASS.EQ.1)THEN DSAVE=PDF IPASS=2 DX=-DEPS GOTO1000 ELSEIF(IPASS.EQ.2)THEN PDF=(PDF+DSAVE)/2.0D0 ENDIF ENDIF C 9000 CONTINUE RETURN END SUBROUTINE GALPPF(P,AK,TAU,IADEDF,PPF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT C FUNCTION VALUE FOR THE GENERALIZED ASYMMETRIC LAPLACE C DISTRIBUTION. IT HAS SHAPE PARAMETERS AK AND TAU. C THIS DISTRIBUTION IS DEFINED FOR ALL REAL C X AND HAS THE PROBABILITY DENSITY FUNCTION C C GALPDF(X,K,TAU) = C1*C2*C3 X <> 0 C WITH C C1 = SQRT(2/PI)*EXP((SQRT(2)/2)*((1/K)-K)*X)/ C GAMMA(TAU) C C2 = ((SQRT(2)*ABS(X)/(K+(1/K))**(TAU-0.5) C C3 = K(TAU-0.5)((SQRT(2)/2)*((1/K)+K)*ABS(X)) C WHERE K(LAMBDA) IS THE MODIFIED BESSEL FUNCTION C OF THE THIRD KIND. C THE PERCENT POINT FUNCTION IS COMPUTED BY NUMERICALLY C INVERTING THE GENERALIZED ASYMMETRIC LAPLACE CUMULATIVE C DISTRIBUTION FUNCTION (WHICH IN TURN IS COMPUTED BY C NUMERICAL INTEGRATION OF THE PROBABILITYT DENSITY. C C INPUT ARGUMENTS--P = THE DOUBLE PRECISION VALUE AT C WHICH THE PERCENT POINT C FUNCTION IS TO BE EVALUATED. C 0 < P < 1 C --AK = THE FIRST SHAPE PARAMETER C --TAU = THE SECOND SHAPE PARAMETER C OUTPUT ARGUMENTS--PPF = THE DOUBLE PRECISION PERCENT POINT C FUNCTION VALUE. C OUTPUT--THE DOUBEL PRECISION PERCENT POINT FUNCTION C VALUE PPF FOR THE GENERALIZED ASYMMETRIC LAPLACE C DISTRIBUTION WITH SHAPE PARAMETERS = AK AND TAU. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--NONE. C OTHER DATAPAC SUBROUTINES NEEDED--DFZERO. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--KOTZ, KOZUBOWSKI, AND PODGORSKI, "THE LAPLACE C DISTRIBUTION AND GENERALIZATIONS: A REVISIT WITH C APPLICATIONS TO COMMUNICATIONS, ECONOMICS, C ENGINEERING, AND FINANCE", BIRKHAUSER, 2001, C PP. 189. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2004.8 C ORIGINAL VERSION--AUGUST 2004. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION P DOUBLE PRECISION AK DOUBLE PRECISION TAU DOUBLE PRECISION PPF C DOUBLE PRECISION DMEAN DOUBLE PRECISION DSD DOUBLE PRECISION DU DOUBLE PRECISION PTEMPL DOUBLE PRECISION PTEMPU C DOUBLE PRECISION XUP DOUBLE PRECISION XUP2 DOUBLE PRECISION XLOW DOUBLE PRECISION RE DOUBLE PRECISION AE C DOUBLE PRECISION GALFU2 EXTERNAL GALFU2 C DOUBLE PRECISION DP COMMON/GA2COM/DP C DOUBLE PRECISION DAK DOUBLE PRECISION DTAU COMMON/GALCOM/DAK,DTAU C CHARACTER*4 IADEDF CHARACTER*4 IADED2 C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C ***************************************** C ** STEP 1-- ** C ** CHECK FOR VALID PARAMETERS ** C ***************************************** C IF(P.LE.0.0D0 .OR. P.GE.1.0D0)THEN WRITE(ICOUT,4) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,48)P CALL DPWRST('XXX','WRIT') PPF=0.0D0 GOTO9000 ENDIF IF(IADEDF.EQ.'K')THEN IF(AK.LE.0.0)THEN WRITE(ICOUT,5) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,48)AK CALL DPWRST('XXX','WRIT') PDF=0.0 GOTO9000 ENDIF ELSE AK=SQRT(2.0)/(AK + SQRT(2.0 + AK*AK)) ENDIF IF(TAU.LE.0.0)THEN WRITE(ICOUT,6) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,48)TAU CALL DPWRST('XXX','WRIT') PDF=0.0 GOTO9000 ENDIF 4 FORMAT('***** ERROR: VALUE OF INPUT ARGUMENT (P) IN ', 1 'GALPPF ROUTINE') 14 FORMAT(' IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL.') 5 FORMAT('***** ERROR: VALUE OF FIRST SHAPE PARAMETER (K) IN ', 1 'GALPPF ROUTINE IS NON-POSITIVE.') 6 FORMAT('***** ERROR: VALUE OF SHAPE PARAMETER (TAU) IN ', 1 'GALPPF ROUTINE IS NON-POSITIVE.') 48 FORMAT(' VALUE OF ARGUMENT IS: ',G15.7) C C ***************************************** C ** STEP 2-- ** C ** COMPUTE THE PERCENT POINT FUNCTION.** C ***************************************** C C STEP 1: FIND BRACKETING INTERVAL. THIS DISTRIBUTION IS UNBOUNDED C IN BOTH DIRECTIONS. BASIC ALGORITHM IS: C C 1) MEAN = TAU*(1/SQRT(2))*((1/K) - K) C SD = SQRT(TAU*(U**2 + 1)) C C WHERE U = (1/SQRT(2))*((1/K) - K) C C 2) START WITH -MEAN AND +MEAN AS THE STARTING LOWER AND C UPPER BRACKETS. C C 3) INCREMENT IN INTERVALS OF 1 STANDARD DEVIATION. C IADED2=IADEDF IADEDF='K' C DAK=AK DTAU=TAU DU=(1.0D0/SQRT(2.0D0))*((1.0D0/DAK) - DAK) DMEAN=DTAU*DU DSD=DSQRT(DTAU*(DU**2 + 1.0D0)) C XLOW=-REAL(DMEAN) XUP2=REAL(DMEAN) CALL GALCDF(XLOW,AK,TAU,IADEDF,PTEMPL) CALL GALCDF(XUP2,AK,TAU,IADEDF,PTEMPU) C MAXIT=1000 NIT=0 C 200 CONTINUE IF(NIT.GT.MAXIT)THEN PPF=0.0 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,131) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,133) CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF CALL GALCDF(XLOW,AK,TAU,IADEDF,PTEMPL) CALL GALCDF(XUP2,AK,TAU,IADEDF,PTEMPU) IF(PTEMPL.LE.P .AND. P.LE.PTEMPU)THEN XUP=XUP2 GOTO300 ELSEIF(P.GT.PTEMPU)THEN XLOW=XUP2 XUP2=XUP2 + REAL(DSD) NIT=NIT+1 GOTO200 ELSEIF(P.LT.PTEMPL)THEN XUP2=XLOW XLOW=XLOW - REAL(DSD) NIT=NIT+1 GOTO200 ENDIF C 300 CONTINUE AE=1.D-7 RE=1.D-7 DP=P CALL DFZERO(GALFU2,XLOW,XUP,XUP,RE,AE,IFLAG) C PPF=XLOW C IF(IFLAG.EQ.2)THEN C C NOTE: SUPPRESS THIS MESSAGE FOR NOW. CCCCC WRITE(ICOUT,999) 999 FORMAT(1X) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,111) CC111 FORMAT('***** WARNING FROM GALPPF--') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,113) CC113 FORMAT(' PPF VALUE MAY NOT BE COMPUTED TO DESIRED ', CCCCC1 'TOLERANCE.') CCCCC CALL DPWRST('XXX','BUG ') ELSEIF(IFLAG.EQ.3)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,121) 121 FORMAT('***** WARNING FROM GALPPF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,123) 123 FORMAT(' PPF VALUE MAY BE NEAR A SINGULAR POINT.') CALL DPWRST('XXX','BUG ') ELSEIF(IFLAG.EQ.4)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,131) 131 FORMAT('***** ERROR FROM GALPPF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,133) 133 FORMAT(' APPROPRIATE BRACKETING INTERVAL NOT FOUND.') CALL DPWRST('XXX','BUG ') ELSEIF(IFLAG.EQ.5)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,141) 141 FORMAT('***** WARNING FROM GALPPF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,143) 143 FORMAT(' MAXIMUM ITERATIONS EXCEEDED.') CALL DPWRST('XXX','BUG ') ENDIF C 9000 CONTINUE IADEDF=IADED2 RETURN END SUBROUTINE GALRAN(N,AK,TAU,IADEDF,ISEED,X) C C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N C FROM THE GENERALIZED ASYMMETRIC DOUBLE EXPONENTIAL C (LAPLACE) DISTRIBUTION WITH SHAPE PARAMETERS = AK AND C TAU. THIS DISTRIBUTION IS DEFINED C FOR ALL X AND HAS THE PROBABILITY DENSITY FUNCTION C GALPDF(X,K,TAU) = C1*C2*C3 X <> 0 C WITH C C1 = SQRT(2/PI)*EXP((SQRT(2)/2)*((1/K)-K)*X)/ C GAMMA(TAU) C C2 = ((SQRT(2)*ABS(X)/(K+(1/K))**(TAU-0.5) C C3 = K(TAU-0.5)((SQRT(2)/2)*((1/K)+K)*ABS(X)) C WHERE K(LAMBDA) IS THE MODIFIED BESSEL FUNCTION C OF THE THIRD KIND. C C INPUT ARGUMENTS--N = THE DESIRED INTEGER NUMBER C OF RANDOM NUMBERS TO BE C GENERATED. C --AK = THE FIRST SHAPE (PARAMETER) FOR THE C GENERALIZED ASYMMETRIC DOUBLE C EXPONENTIAL DISTRIBUTION. C --TAU = THE SECOND SHAPE (PARAMETER) FOR THE C GENERALIZED ASYMMETRIC DOUBLE C EXPONENTIAL 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 GENERALIZED ASYMMETRIC DOUBLE EXPONENTIAL C DISTRIBUTION WITH SHAPE PARAMETERS = AK AND TAU. 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 --AK AND TAU MUST BE POSITIVE. C OTHER DATAPAC SUBROUTINES NEEDED--UNIRAN, NORRAN, GAMRAN. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--KOTZ, KOZUBOWSKI, AND PODGORSKI, "THE LAPLACE C DISTRIBUTION AND GENERALIZATIONS: A REVISIT WITH C APPLICATIONS TO COMMUNICATIONS, ECONOMICS, C ENGINEERING, AND FINANCE", BIRKHAUSR, 2001, C PP. 179-192. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATION INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2004.6 C ORIGINAL VERSION--JUNE 2004. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DIMENSION X(*) DIMENSION Y(2) C CHARACTER*4 IADEDF C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----DATA STATEMENTS------------------------------------------------- C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(N.LT.1)THEN WRITE(ICOUT,5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,6) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)N CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF IF(IADEDF.EQ.'K')THEN IF(AK.LE.0.0)THEN WRITE(ICOUT,15) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,48)AK CALL DPWRST('XXX','WRIT') GOTO9999 ENDIF ELSE AK=SQRT(2.0)/(AK + SQRT(2.0 + AK*AK)) ENDIF IF(AK.LE.0.0)THEN WRITE(ICOUT,25) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,48)TAU CALL DPWRST('XXX','WRIT') GOTO9999 ENDIF 15 FORMAT('***** ERROR: VALUE OF SHAPE PARAMETER (K) IS ', 1 'NON-POSITIVE.') 25 FORMAT('***** ERROR: VALUE OF SHAPE PARAMETER (TAU) IS ', 1 'NON-POSITIVE.') C 5 FORMAT('***** ERROR--FOR THE GENERALIZED ASYMMETRIC DOUBLE ', 1 'EXPONENTIAL DISTRIBUTION,') 6 FORMAT(' THE REQUESTED NUMBER OF RANDOM NUMBERS WAS ', 1 'NON-POSITIVE.') 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,'.') 48 FORMAT(' VALUE OF ARGUMENT IS: ',G15.7) C C ALGORITHM FROM PAGE 183 OF KOTZ, ET. AL.: C C Y = (1/SQRT(2))*((1/K)*G1 - K*G2) C C WHERE G1 AND G2 ARE INDEPENDENT GAMMA RANDOM VARIABLES WITH C SHAPE PARAMETER TAU. C NTEMP=2 C=(1.0/SQRT(2.0)) DO100I=1,N CALL GAMRAN(NTEMP,TAU,ISEED,Y) G1=Y(1) G2=Y(2) APPF=C*((1.0/AK)*G1 - AK*G2) X(I)=APPF 100 CONTINUE C 9999 CONTINUE RETURN END SUBROUTINE GAMEST(X,NOBS,SCALE,GAMMA,IERROR) C C COMPUTE MLES FOR SHAPE PARAMETER (GAMMA) AND SCALE C PARAMETER (SCALE). C DIMENSION X(*) C DOUBLE PRECISION GAMFUN EXTERNAL GAMFUN C DOUBLE PRECISION DLOGGM COMMON/GAMCOM/DLOGGM C DOUBLE PRECISION AE DOUBLE PRECISION RE DOUBLE PRECISION DXSTRT DOUBLE PRECISION DXLOW DOUBLE PRECISION DXUP DOUBLE PRECISION XLOWSV DOUBLE PRECISION XUPSV C CHARACTER*4 IBUGA3 CHARACTER*4 IWRITE CHARACTER*4 IERROR C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C FOR STARTING VALUE, USE THE METHOD OF MOMENT ESTIMATORS C C GAMMAHAT = (XBAR/XSD)**2 C SCALE = XSD**2/XBAR C IERROR='NO' IBUGA3='OFF' IWRITE='OFF' CALL MEAN(X,NOBS,IWRITE,XMEAN,IBUGA3,IERROR) CALL SD(X,NOBS,IWRITE,XSD,IBUGA3,IERROR) GAMMMO=(XMEAN/XSD)**2 SCALMO=XSD**2/XMEAN CALL GEOMEA(X,NOBS,IWRITE,XGEOM,IBUGA3,IERROR) C IERROR='NO' AN=REAL(NOBS) C C ESTIMATES FOR 2-PARAMETER MODEL. USE DFZER2 TO FIND ROOT OF C THE LIKELIHOOD EQUATION. C DLOGGM=DLOG(DBLE(XMEAN)/DBLE(XGEOM)) DXSTRT=DBLE(GAMMMO) AE=2.0*0.000001D0*DXSTRT RE=AE IFLAG=0 DXLOW=DXSTRT/2.0D0 DXUP=2.0D0*DXSTRT ITBRAC=0 4105 CONTINUE XLOWSV=DXLOW XUPSV=DXUP CALL DFZERO(GAMFUN,DXLOW,DXUP,DXSTRT,RE,AE,IFLAG) C IF(IFLAG.EQ.4 .AND. ITBRAC.LE.100)THEN DXLOW=XLOWSV/2.0D0 DXUP=2.0D0*XUPSV ITBRAC=ITBRAC+1 GOTO4105 ENDIF C 999 FORMAT(1X) IF(IFLAG.EQ.2)THEN C C NOTE: SUPPRESS THIS MESSAGE FOR NOW. CCCCC WRITE(ICOUT,999) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,111) CC111 FORMAT('***** WARNING FROM GAMMA MAXIMUM ', CCCCC1 'LIKELIHOOD--') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,113) CC113 FORMAT(' ESTIMATE OF GAMMA MAY NOT BE COMPUTED TO ', CCCCC1 'DESIRED TOLERANCE.') CCCCC CALL DPWRST('XXX','BUG ') ELSEIF(IFLAG.EQ.3)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,121) 121 FORMAT('***** WARNING FROM GAMMA MAXIMUM LIKELIHOOD--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,123) 123 FORMAT(' ESTIMATE OF GAMMA MAY BE NEAR A SINGULAR POINT.') CALL DPWRST('XXX','BUG ') ELSEIF(IFLAG.EQ.4)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,131) 131 FORMAT('***** ERROR FROM GAMMA MAXIMUM LIKELIHOOD--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,133) 133 FORMAT(' APPROPRIATE BRACKETING INTERVAL NOT FOUND.') CALL DPWRST('XXX','BUG ') ELSEIF(IFLAG.EQ.5)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,141) 141 FORMAT('***** WARNING FROM GAMMA MAXIMUM LIKELIHOOD--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,143) 143 FORMAT(' MAXIMUM ITERATIONS EXCEEDED.') CALL DPWRST('XXX','BUG ') ENDIF C GAMMA=REAL(DXLOW) SCALE=XMEAN/GAMMA C 9999 CONTINUE RETURN END double precision function gammds (y, p, ifault) c----------------------------------------------------------------------- c Name: GAMMDS c c Purpose: Cumulative distribution for the gamma distribution. c c Usage: PGAMMA (Q, ALPHA,IFAULT) c c Arguments: c Q - Value at which the distribution is desired. (Input) c ALPHA - Parameter in the gamma distribution. (Input) c IFAULT - Error indicator. (Output) c IFAULT DEFINITION c 0 No error c 1 An argument is misspecified. c 2 A numerical error has occurred. c PGAMMA - The cdf for the gamma distribution with parameter alpha c evaluated at Q. (Output) c----------------------------------------------------------------------- c c Algorithm AS 147 APPL. Statist. (1980) VOL. 29, P. 113 c c Computes the incomplete gamma integral for positive c parameters Y, P using and infinite series. c c SPECIFICATIONS FOR ARGUMENTS integer ifault double precision y, p c SPECIFICATIONS FOR LOCAL VARIABLES integer ifail double precision a, c, f c SPECIFICATIONS FOR SAVE VARIABLES double precision e, one, zero save e, one, zero c SPECIFICATIONS FOR INTRINSICS intrinsic dlog, dexp double precision dlog, dexp c SPECIFICATIONS FOR FUNCTIONS external alogam double precision alogam double precision zexp, zlog c data e, zero, one/1.0d-6, 0.0d0, 1.0d0/ c zexp(a) = dexp(a) zlog(a) = dlog(a) c c Checks for the admissibility of arguments and value of F c ifault = 1 gammds = zero if (y.le.zero .or. p.le.zero) return ifault = 2 c c ALOGAM is natural log of gamma function c no need to test ifail as an error is impossible c f = zexp(p*zlog(y)-alogam(p+one,ifail)-y) if (f .eq. zero) return ifault = 0 c c Series begins c c = one gammds = one a = p 10 a = a + one c = c*y/a gammds = gammds + c if (c/gammds .gt. e) go to 10 gammds = gammds*f return end SUBROUTINE GAMLIM(XMIN,XMAX) C***BEGIN PROLOGUE GAMLIM C***DATE WRITTEN 770401 (YYMMDD) C***REVISION DATE 820801 (YYMMDD) C***CATEGORY NO. C7A,R2 C***KEYWORDS GAMMA FUNCTION,LIMITS,SPECIAL FUNCTION C***AUTHOR FULLERTON, W., (LANL) C***PURPOSE Computes the minimum and maximum bounds for X in GAMMA(X). C***DESCRIPTION C C Calculate the minimum and maximum legal bounds for X in GAMMA(X). C XMIN and XMAX are not the only bounds, but they are the only non- C trivial ones to calculate. C C Output Arguments -- C XMIN minimum legal value of X in GAMMA(X). Any smaller value of C X might result in underflow. C XMAX maximum legal value of X in GAMMA(X). Any larger value will C cause overflow. C***REFERENCES (NONE) C***ROUTINES CALLED R1MACH,XERROR C***END PROLOGUE GAMLIM C***FIRST EXECUTABLE STATEMENT GAMLIM 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 ALNSML = ALOG(R1MACH(1)) XMIN = -ALNSML DO 10 I=1,10 XOLD = XMIN XLN = ALOG(XMIN) XMIN = XMIN - XMIN*((XMIN+0.5)*XLN - XMIN - 0.2258 + ALNSML) 1 / (XMIN*XLN + 0.5) IF (ABS(XMIN-XOLD).LT.0.005) GO TO 20 10 CONTINUE CCCCC CALL XERROR ( 'GAMLIM UNABLE TO FIND XMIN', 27, 1, 2) WRITE(ICOUT,11) CALL DPWRST('XXX','BUG ') 11 FORMAT('***** ERROR FROM GAMLIM: UNABLE TO FIND ', 1 'XMIN') C 20 XMIN = -XMIN + 0.01 C ALNBIG = ALOG(R1MACH(2)) XMAX = ALNBIG DO 30 I=1,10 XOLD = XMAX XLN = ALOG(XMAX) XMAX = XMAX - XMAX*((XMAX-0.5)*XLN - XMAX + 0.9189 - ALNBIG) 1 / (XMAX*XLN - 0.5) IF (ABS(XMAX-XOLD).LT.0.005) GO TO 40 30 CONTINUE CCCCC CALL XERROR ( 'GAMLIM UNABLE TO FIND XMAX', 27, 2, 2) WRITE(ICOUT,31) CALL DPWRST('XXX','BUG ') 31 FORMAT('***** ERROR FROM GAMLIM: UNABLE TO FIND ', 1 'XMAX') C 40 XMAX = XMAX - 0.01 XMIN = AMAX1 (XMIN, -XMAX+1.) C RETURN END SUBROUTINE GAMMAF(X,G) C C THIS PROGRAM CALCULATES THE GAMMA FUNCTION C THE INPUT IS SINGLE PRECISION X C THE OUTPUT IS SINGLE PRECISION G C ALL INTERNAL OPERATIONS ARE DONE IN DOUBLE PRECISION C THE ALGORITHM IS TO USE THE RECURSION FORMULA G(X)=G(X+1)/X C UNTIL X IS LARGE ENOUGH TO USE AN ASYMPTOTIC FORMULA FOR G(X)--THE CUT-OFF C POINT USED WAS X = 10 C THE ASYMPTOTIC FORMULA USED IS IN AMS 55, PAGE 257, 6.1.41 (THE FIRST 9 C TERMS OF THE SERIES WERE USED--I.E., OUT TO X**-17) C ALTHOUGH THE DATA STATEMENT DEFINES 10 COEFFICIENTS, THE PROGRAM MAKES USE C OF ONLY 9 COEFFICIENTS (THE ERROR BEING BOUNDED BY THE TENTH COEFFICIENT C DIVIDED BY X**19 C SUBROUTINES NEEDED--NONE C PRINTING--NONE UNLESS AN ERROR CONDITION EXISTS C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-921-3651 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--JUNE 1972. C UPDATED --FEBRUARY 1981. C UPDATED --FEBRUARY 1982. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION Y,Y2,Y3,Y4,Y5,DEN,A,B,C,D C DIMENSION D(10) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----DATA STATEMENTS------------------------------------------------- C DATA C/ .918938533204672741D0/ DATA D(1),D(2),D(3),D(4),D(5) 1 /+.833333333333333333D-1,-.277777777777777778D-2, 1+.793650793650793651D-3,-.595238095238095238D-3,+.8417508417508417 151D-3/ DATA D(6),D(7),D(8),D(9),D(10) 1 /-.191752691752691753D-2,+.641025641025641025D-2,-.2955065359 147712418D-1,+.179644372368830573D0,-.139243221690590111D1/ C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(X.LE.0.0D0)GOTO50 GOTO90 50 WRITE(ICOUT,5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,45)X CALL DPWRST('XXX','BUG ') RETURN 90 CONTINUE 5 FORMAT('***** FATAL ERROR--THE FIRST INPUT ARGUMENT ', 1'TO THE GAMMAF SUBROUTINE IS NON-POSITIVE *****') 45 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',D22.15,' *****') C Y=X DEN=1.0D0 100 IF(Y.GE.10.0D0)GOTO200 DEN=DEN*Y Y=Y+1 GOTO100 200 Y2=Y*Y Y3=Y*Y2 Y4=Y2*Y2 Y5=Y2*Y3 A=(Y-0.5D0)*DLOG(Y)-Y+C B=D(1)/Y+D(2)/Y3+D(3)/Y5+D(4)/(Y2*Y5)+D(5)/(Y4*Y5)+ 1D(6)/(Y*Y5*Y5)+D(7)/(Y3*Y5*Y5)+D(8)/(Y5*Y5*Y5)+D(9)/(Y2*Y5*Y5*Y5) G=DEXP(A+B)/DEN C RETURN END SUBROUTINE GAMCDF(X,GAMMA,CDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION C FUNCTION VALUE FOR THE GAMMA C DISTRIBUTION WITH SINGLE PRECISION C TAIL LENGTH PARAMETER = GAMMA. C THE GAMMA DISTRIBUTION USED C HEREIN HAS MEAN = GAMMA C AND STANDARD DEVIATION = SQRT(GAMMA). C THIS DISTRIBUTION IS DEFINED FOR ALL POSITIVE X, C AND HAS THE PROBABILITY DENSITY FUNCTION C F(X) = (1/CONSTANT) * (X**(GAMMA-1)) * EXP(-X) C WHERE THE CONSTANT = THE GAMMA FUNCTION EVALUATED C AT THE VALUE GAMMA. C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE C AT WHICH THE CUMULATIVE DISTRIBUTION C FUNCTION IS TO BE EVALUATED. C X SHOULD BE POSITIVE. C --GAMMA = THE SINGLE PRECISION VALUE C OF THE TAIL LENGTH PARAMETER. C GAMMA 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 GAMMA DISTRIBUTION C WITH TAIL LENGTH PARAMETER VALUE = GAMMA. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--GAMMA SHOULD BE POSITIVE. C --X SHOULD BE POSITIVE. C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--DEXP, DLOG. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN. C ACCURACY--(ON THE UNIVAC 1108, EXEC 8 SYSTEM AT NBS) C COMPARED TO THE KNOWN GAMMA = 1 (EXPONENTIAL) C RESULTS, AGREEMENT WAS HAD OUT TO 7 SIGNIFICANT C DIGITS FOR ALL TESTED X. C THE TESTED X VALUES COVERED THE ENTIRE C RANGE OF THE DISTRIBUTION--FROM THE 0.00001 C PERCENT POINT UP TO THE 99.99999 PERCENT POINT C OF THE DISTRIBUTION. C REFERENCES--WILK, GNANADESIKAN, AND HUYETT, 'PROBABILITY C PLOTS FOR THE GAMMA DISTRIBUTION', C TECHNOMETRICS, 1962, PAGES 1-15, C ESPECIALLY PAGES 3-5. C --NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY APPLIED MATHEMATICS C SERIES 55, 1964, PAGE 257, FORMULA 6.1.41. C --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE C DISTRIBUTIONS--1, 1970, PAGES 166-206. C --HASTINGS AND PEACOCK, STATISTICAL C DISTRIBUTIONS--A HANDBOOK FOR C STUDENTS AND PRACTITIONERS, 1975, C PAGES 68-73. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING LABORATORY (205.03) C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE: 301-975-2855 C ORIGINAL VERSION--APRIL 1994. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C--------------------------------------------------------------------- C DOUBLE PRECISION DX,DGAMMA,AI,TERM,SUM,CUT1,CUT2,CUTOFF,T DOUBLE PRECISION Z,Z2,Z3,Z4,Z5,DEN,A,B,C,D,G DOUBLE PRECISION DEXP,DLOG DIMENSION D(10) DATA C/ .918938533204672741D0/ DATA D(1),D(2),D(3),D(4),D(5) 1 /+.833333333333333333D-1,-.277777777777777778D-2, 1+.793650793650793651D-3,-.595238095238095238D-3,+.8417508417508417 151D-3/ DATA D(6),D(7),D(8),D(9),D(10) 1 /-.191752691752691753D-2,+.641025641025641025D-2,-.2955065359 147712418D-1,+.179644372368830573D0,-.139243221690590111D1/ C C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(X.LE.0.0)GOTO50 IF(GAMMA.LE.0.0)GOTO55 GOTO90 50 CONTINUE WRITE(ICOUT,4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') CDF=0.0 RETURN 55 CONTINUE WRITE(ICOUT,15) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)GAMMA CALL DPWRST('XXX','BUG ') CDF=0.0 RETURN 90 CONTINUE 4 FORMAT('***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT') 5 FORMAT(' TO THE GAMCDF SUBROUTINE IS NON-POSITIVE *****') 15 FORMAT('***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE') 16 FORMAT(' GAMCDF SUBROUTINE IS NON-POSITIVE *****') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,'*****') C C-----START POINT----------------------------------------------------- C DX=X DGAMMA=GAMMA MAXIT=10000 C C COMPUTE THE GAMMA FUNCTION USING THE ALGORITHM IN THE C NBS APPLIED MATHEMATICS SERIES REFERENCE. C Z=DGAMMA DEN=1.0D0 300 IF(Z.GE.10.0D0)GOTO400 DEN=DEN*Z Z=Z+1 GOTO300 400 Z2=Z*Z Z3=Z*Z2 Z4=Z2*Z2 Z5=Z2*Z3 A=(Z-0.5D0)*DLOG(Z)-Z+C B=D(1)/Z+D(2)/Z3+D(3)/Z5+D(4)/(Z2*Z5)+D(5)/(Z4*Z5)+ 1D(6)/(Z*Z5*Z5)+D(7)/(Z3*Z5*Z5)+D(8)/(Z5*Z5*Z5)+D(9)/(Z2*Z5*Z5*Z5) G=DEXP(A+B)/DEN C C COMPUTE T-SUB-Q AS DEFINED ON PAGE 4 OF THE WILK, GNANADESIKAN, C AND HUYETT REFERENCE C SUM=1.0D0/DGAMMA TERM=1.0D0/DGAMMA CUT1=DX-DGAMMA CUT2=DX*10000000000.0D0 DO200I=1,MAXIT AI=I TERM=DX*TERM/(DGAMMA+AI) SUM=SUM+TERM CUTOFF=CUT1+(CUT2*TERM/SUM) IF(AI.GT.CUTOFF)GOTO250 200 CONTINUE WRITE(ICOUT,205)MAXIT CALL DPWRST('XXX','BUG ') WRITE(ICOUT,206)X CALL DPWRST('XXX','BUG ') WRITE(ICOUT,207)GAMMA CALL DPWRST('XXX','BUG ') WRITE(ICOUT,208) CALL DPWRST('XXX','BUG ') CDF=1.0 RETURN C 250 T=SUM CDF=(DX**DGAMMA)*(DEXP(-DX))*T/G C 204 FORMAT('*****ERROR IN INTERNAL OPERATIONS IN THE GAMCDF ,') 205 FORMAT(' SUBROUTINE--THE NUMBER OF ITERATIONS EXCEEDS ',I7) 206 FORMAT(' THE INPUT VALUE OF X IS ',E15.8) 207 FORMAT(' THE INPUT VALUE OF GAMMA IS ',E15.8) 208 FORMAT(' THE OUTPUT VALUE OF CDF HAS BEEN SET TO 1.0') C RETURN END DOUBLE PRECISION FUNCTION GAMFUN (GHAT) C C PURPOSE--THIS ROUTINE IS USED IN FINDING THE MAXIMUM LIKELIHOOD C ESTIMATE OF GAMMA FOR THE 2-PARAMETER GAMMA C MODEL FOR FULL SAMPLE DATA (NO CENSORING). THIS C FUNCTION FINDS THE ROOT OF THE EQUATION: C C LOG(GHAT) - DIGAMMA(GHAT) - LOG(G) C C WITH C C G = GEOMETRIC MEAN OF THE DATA C GHAT = POINT ESTIMATE OF GAMMA (THIS IS THE C PARAMETER WE ARE ITERATING OVER) C C NOTE THAT THE LOG(G) TERM DOES NOT DEPEND ON GHAT, C SO THIS IS A CONSTANT. FOR EFFICIENCY, SAVE THIS AS C A CONSTANT IN A COMMON BLOCK. C C CALLED BY DFZERO ROUTINE FOR FINDING THE ROOT OF A C FUNCTION. C EXAMPLE--GAMMA MAXIMUM LIKELIHOOD Y C REFERENCE--KARL BURY, "STATISTICAL DISTRIBUTIONS IN C ENGINEERING", CAMBRIDGE UNIVERSITY PRESS, C 1999, CHAPTER 13. C --JOHNSON, KOTZ, AND BALAKRISNAN, "CONTINUOUS C UNIVARIATE DISTRIBUTIONS--VOLUME 1", SECOND EDITION, C WILEY, 1994, CHAPTER 17. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBUG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2004/11 C ORIGINAL VERSION--NOVEMBER 2004. C C--------------------------------------------------------------------- C DOUBLE PRECISION GHAT C DOUBLE PRECISION DLOGGM COMMON/GAMCOM/DLOGGM C DOUBLE PRECISION DPSI EXTERNAL DPSI C C--------------------------------------------------------------------- C DOUBLE PRECISION DTERM1 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 C-----START POINT----------------------------------------------------- C C COMPUTE SOME SUMS C DTERM1=DLOG(GHAT) DTERM2=DPSI(GHAT) C GAMFUN=DTERM1 - DTERM2 - DLOGGM C RETURN END DOUBLE PRECISION FUNCTION GAMFU2 (DA) C C PURPOSE--THIS ROUTINE IS USED IN FINDING THE LIKELIHOOD RATIO C BASED CONFIDECE INTERVAL FOR THE 2-PARAMETER GAMMA C MODEL (FULL SAMPLE). THIS FUNCTION FINDS THE ROOT C OF THE EQUATION: C C 2*LL(S,G) - 2*LL(xbar/a,a) - CHSPPF(alpha,1) C C WITH C C LL(S,G) = -N*LN(GAMMA(G)) - N*G*LN(S) + C N*(G-1)*LN(G) - N*XBAR/S C S = POINT ESTIMATE OF SCALE PARAMETER C G = POINT ESTIMATE OF SHAPE PARAMETER C GAMMA = GAMMA FUNCTION C A = PARAMETER WE ARE FINDING ROOT FOR C C NOTE THAT QUANTITIES THAT DO NOT DEPEND ON A ARE C COMPUTED ONCE IN DPMLG1 AND PASSED VIA COMMON BLOCK. C C CALLED BY DFZERO ROUTINE FOR FINDING THE ROOT OF A C FUNCTION. C C EXAMPLE--GAMMA MAXIMUM LIKELIHOOD Y C REFERENCE--KARL BURY, "STATISTICAL DISTRIBUTIONS IN ENGINEERING", C CAMBRIDGE UNIVERSITY PRESS, 1999, CHAPTER 13 (SEE C EXAMPLE 13.3). C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBUG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2004/11 C ORIGINAL VERSION--NOVEMBER 2004. C C--------------------------------------------------------------------- C DOUBLE PRECISION DA C DOUBLE PRECISION DK DOUBLE PRECISION DXBAR DOUBLE PRECISION DGMEAN DOUBLE PRECISION DSCALE DOUBLE PRECISION DG COMMON/GAMCO2/DK,DXBAR,DGMEAN,DSCALE,DG,N C DOUBLE PRECISION DLNGAM EXTERNAL DLNGAM C DOUBLE PRECISION DN DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C C COMPUTE LL(S,G) C DN=DBLE(N) DTERM1=-DN*DLNGAM(DG) - DN*DG*DLOG(DSCALE) + 1 DN*(DG-1.0D0)*DLOG(DGMEAN) - DN*DXBAR/DSCALE C C COMPUTE LL(XBAR/A,A) C DTERM2=-DN*DLNGAM(DA) - DN*DA*DLOG(DXBAR/DA) + 1 DN*(DA-1.0D0)*DLOG(DGMEAN) - DN*DXBAR/(DXBAR/DA) C GAMFU2=2.0*DTERM1 - 2.0D0*DTERM2 - DK C RETURN END DOUBLE PRECISION FUNCTION GAMFU3 (DB,DX) C C PURPOSE--THIS ROUTINE IS USED IN FINDING THE LIKELIHOOD RATIO C BASED CONFIDENCE INTERVAL FOR THE SCALE PARAMETER OF A C 2-PARAMETER GAMMA MODEL (FULL SAMPLE). THIS FUNCTION C FINDS THE ROOT OF THE EQUATION: C C 2*LL(S,G) - 2*LL(b,G(b)) - CHSPPF(alpha,1) C C WITH C C LL(S,G) = -N*LN(GAMMA(G)) - N*G*LN(S) + C N*(G-1)*LN(G) - N*XBAR/S C S = POINT ESTIMATE OF SCALE PARAMETER C G = POINT ESTIMATE OF SHAPE PARAMETER C B = CURRENT GUESS FOR SCALE PARAMETER C G(B) = ML ESTIMATE OF GAMMA GIVEN VALUE OF C SCALE C C NOTE THAT QUANTITIES THAT DO NOT DEPEND ON B ARE C COMPUTED ONCE IN DPMLG1 AND PASSED VIA COMMON BLOCK. C C GIVEN A VALUE FOR THE SCALE PARAMETER (DB), WE NEED C TO CALL A ROOT FINDING ROUTINE TO DETERMINE THE VALUE C OF THE SHAPE PARAMETER (A). THIS IS THE ROOT OF THE C EQUATION: C C LN(SCALEHAT) + DIGAMMA(GHAT) - LN(GEOMETRIC MEAN) C C CALLED BY DFZER2 ROUTINE FOR FINDING THE ROOT OF A C FUNCTION. DFZER2 IS MODIFIED VERSION OF DFZERO THAT C PASSES ALONG THE DATA ARRAY. C C EXAMPLE--GAMMA MAXIMUM LIKELIHOOD Y C REFERENCE--KARL BURY, "STATISTICAL DISTRIBUTIONS IN ENGINEERING", C CAMBRIDGE UNIVERSITY PRESS, 1999, CHAPTER 13 (SEE C EXAMPLE 13.3). C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBUG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2004/11 C ORIGINAL VERSION--NOVEMBER 2004. C C--------------------------------------------------------------------- C DOUBLE PRECISION DB DOUBLE PRECISION DX(*) C INTEGER N DOUBLE PRECISION DK DOUBLE PRECISION DXBAR DOUBLE PRECISION DGMEAN DOUBLE PRECISION DSCALE DOUBLE PRECISION DG COMMON/GAMCO2/DK,DXBAR,DGMEAN,DSCALE,DG,N C DOUBLE PRECISION DBTEMP DOUBLE PRECISION DGMEA2 COMMON/GAMCO4/DBTEMP,DGMEA2,N2 C DOUBLE PRECISION AE DOUBLE PRECISION RE DOUBLE PRECISION XLOW DOUBLE PRECISION XUP DOUBLE PRECISION XSTRT DOUBLE PRECISION DA DOUBLE PRECISION DN DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 C DOUBLE PRECISION DLNGAM EXTERNAL DLNGAM DOUBLE PRECISION GAMFU4 EXTERNAL GAMFU4 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 STEP 1: GIVEN VALUE OF SCALE PARAMETER (DB), NEED TO COMPUTE C THE SHAPE PARAMETER (WHICH IN TURN INVOLVES FINDING A C ROOT). N2=N DBTEMP=DB DGMEA2=DGMEAN AE=1.D-7 RE=1.D-7 XSTRT=DG XLOW=XSTRT/5.0D0 XUP=XSTRT*5.0D0 CALL DFZER3(GAMFU4,XLOW,XUP,XSTRT,RE,AE,IFLAG,DX) DA=XLOW C C COMPUTE LL(S,G) C DN=DBLE(N) DTERM1=-DN*DLNGAM(DG) - DN*DG*DLOG(DSCALE) + 1 DN*(DG-1.0D0)*DLOG(DGMEAN) - DN*DXBAR/DSCALE C C COMPUTE LL(B,A) C DTERM2=-DN*DLNGAM(DA) - DN*DA*DLOG(DB) + 1 DN*(DA-1.0D0)*DLOG(DGMEAN) - DN*DXBAR/DB C GAMFU3=2.0*DTERM1 - 2.0D0*DTERM2 - DK C RETURN END DOUBLE PRECISION FUNCTION GAMFU4 (DA,DX) C C PURPOSE--THIS ROUTINE IS USED IN FINDING THE LIKELIHOOD RATIO C BASED CONFIDENCE INTERVAL FOR THE SCALE PARAMETER OF C THE 2-PARAMETER GAMMA MODEL (FULL SAMPLE). C SPECIFICALLY, IT IS USED TO DETERMINE AN ESTIMATE C OF THE SHAPE PARAMETER GIVEN A VALUE OF THE SCALE C PARAMETER. IT FINDS THE ROOT OF THE FOLLOWING C EQUATION: C C LN(BHAT) + DIGAMMA(AHAT) - LN(GEOMETRIC MEAN) C C WITH A DENOTING THE SHAPE PARAMETER, B THE SCALE C PARAMETER, AND THE ROOT IS WITH RESPECT TO A. C C CALLED BY DFZER3 ROUTINE FOR FINDING THE ROOT OF A C FUNCTION. DFZER3 IS MODIFIED VERSION OF DFZERO THAT C PASSES ALONG THE DATA ARRAY. C C EXAMPLE--GAMMA MAXIMUM LIKELIHOOD Y C REFERENCE--KARL BURY, "STATISTICAL DISTRIBUTIONS IN ENGINEERING", C CAMBRIDGE UNIVERSITY PRESS, 1999, CHAPTER 13 (SEE C EXAMPLE 13.3). C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBUG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2004/11 C ORIGINAL VERSION--NOVEMBER 2004. C C--------------------------------------------------------------------- C DOUBLE PRECISION DA DOUBLE PRECISION DX(*) C DOUBLE PRECISION DGMEAN DOUBLE PRECISION DB COMMON/GAMCO4/DB,DGMEAN,N C DOUBLE PRECISION DPSI EXTERNAL DPSI 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 GAMFU4=DLOG(DB) + DPSI(DA) - DLOG(DGMEAN) C RETURN END REAL FUNCTION GAMFU8(GHAT) C C PURPOSE--THIS ROUTINE IS USED IN FINDING CONFIDENCE LIMITS C FOR PERCENTILES OF THE GAMMA DISTRIBUTION (BASED ON C MAXIMUM LIKELIHOOD ESTIMATION). THIS FUNCTION C COMPUTES THE DERIVATIVE OF THE GAMMA PERCENT POINT C FUNCTION WITH RESPECT TO THE SHAPE PARAMETER. C C CALLED BY DIFF ROUTINE FOR FINDING THE DERIVATIVE C OF A FUNCTION. C EXAMPLE--GAMMA MAXIMUM LIKELIHOOD Y C REFERENCE--KARL BURY, "STATISTICAL DISTRIBUTIONS IN C ENGINEERING", CAMBRIDGE UNIVERSITY PRESS, C 1999, CHAPTER 13. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBUG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2004/11 C ORIGINAL VERSION--NOVEMBER 2004. C C--------------------------------------------------------------------- C REAL GHAT C COMMON/GAMCO8/P,SCALE 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 CALL GAMPPF(P,GHAT,APPF) GAMFU8=SCALE*APPF C RETURN END REAL FUNCTION GAMFU9(SCALE) C C PURPOSE--THIS ROUTINE IS USED IN FINDING CONFIDENCE LIMITS C FOR PERCENTILES OF THE GAMMA DISTRIBUTION (BASED ON C MAXIMUM LIKELIHOOD ESTIMATION). THIS FUNCTION C COMPUTES THE DERIVATIVE OF THE GAMMA PERCENT POINT C FUNCTION WITH RESPECT TO THE SCALE PARAMETER. C C CALLED BY DIFF ROUTINE FOR FINDING THE DERIVATIVE C OF A FUNCTION. C EXAMPLE--GAMMA MAXIMUM LIKELIHOOD Y C REFERENCE--KARL BURY, "STATISTICAL DISTRIBUTIONS IN C ENGINEERING", CAMBRIDGE UNIVERSITY PRESS, C 1999, CHAPTER 13. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBUG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2004/11 C ORIGINAL VERSION--NOVEMBER 2004. C C--------------------------------------------------------------------- C COMMON/GAMCO9/P,GHAT 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 CALL GAMPPF(P,GHAT,APPF) GAMFU9=SCALE*APPF C RETURN END SUBROUTINE GAMPDF(X,GAMMA,PDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY C FUNCTION VALUE FOR THE GAMMA C DISTRIBUTION WITH SINGLE PRECISION C TAIL LENGTH PARAMETER = GAMMA. C THE GAMMA DISTRIBUTION USED C HEREIN HAS MEAN = GAMMA C AND STANDARD DEVIATION = SQRT(GAMMA). C THIS DISTRIBUTION IS DEFINED FOR ALL POSITIVE X, C AND HAS THE PROBABILITY DENSITY FUNCTION C F(X) = (1/CONSTANT) * (X**(GAMMA-1)) * EXP(-X) C WHERE THE CONSTANT = THE GAMMA FUNCTION EVALUATED C AT THE VALUE GAMMA. C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE C AT WHICH THE CUMULATIVE DISTRIBUTION C FUNCTION IS TO BE EVALUATED. C X SHOULD BE POSITIVE. C --GAMMA = THE SINGLE PRECISION VALUE C OF THE TAIL LENGTH PARAMETER. C GAMMA SHOULD BE POSITIVE. C OUTPUT ARGUMENTS--PDF = THE SINGLE PRECISION PROBABILITY C DENSITY FUNCTION VALUE. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--GAMMA SHOULD BE POSITIVE. C --X SHOULD BE POSITIVE. C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--DEXP, DLOG. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN. C REFERENCES--WILK, GNANADESIKAN, AND HUYETT, 'PROBABILITY C PLOTS FOR THE GAMMA DISTRIBUTION', C TECHNOMETRICS, 1962, PAGES 1-15, C ESPECIALLY PAGES 3-5. C --NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY APPLIED MATHEMATICS C SERIES 55, 1964, PAGE 257, FORMULA 6.1.41. C --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE C DISTRIBUTIONS--1, 1970, PAGES 166-206. C --HASTINGS AND PEACOCK, STATISTICAL C DISTRIBUTIONS--A HANDBOOK FOR C STUDENTS AND PRACTITIONERS, 1975, C PAGES 68-73. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING LABORATORY (205.03) C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE: 301-975-2855 C ORIGINAL VERSION--SEPTEMBER 1994. C UPDATED --JANUARY 1996. HANDLE X=0 AS SPECIAL CASE C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C CCCCC JANUARY 1996. ADD FOLLOWING LINE. INCLUDE 'DPCOMC.INC' C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C--------------------------------------------------------------------- C DOUBLE PRECISION DX,DGAMMA,DLNGAM,DPDF DOUBLE PRECISION DTERM1, DTERM2, DTERM3, DTERM4, DTERM5 C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(X.LT.0.0)GOTO50 IF(GAMMA.LE.0.0)GOTO55 GOTO90 50 CONTINUE WRITE(ICOUT,4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') PDF=0.0 RETURN 55 CONTINUE WRITE(ICOUT,15) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)GAMMA CALL DPWRST('XXX','BUG ') PDF=0.0 RETURN 90 CONTINUE 4 FORMAT('***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT') 5 FORMAT(' TO THE GAMPDF SUBROUTINE IS NON-POSITIVE *****') 15 FORMAT('***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE') 16 FORMAT(' GAMPDF SUBROUTINE IS NON-POSITIVE *****') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,'*****') C C-----START POINT----------------------------------------------------- C DX=DBLE(X) DGAMMA=DBLE(GAMMA) C CCCCC JANUARY 1996. TRREAT X = 0 AS SPECIAL CASE. IF(ABS(DX).LE.D1MACH(1))THEN IF(DGAMMA.EQ.1.0D0)THEN PDF=1.0 GOTO9999 ELSEIF(DGAMMA.LT.1.0D0)THEN DX=1.0D-10 ELSE DX=D1MACH(1) ENDIF ENDIF C C COMPUTE THE GAMMA FUNCTION USING THE ALGORITHM IN THE C NBS APPLIED MATHEMATICS SERIES REFERENCE. C DTERM1=(DGAMMA-1.0D0)*DLOG(DX) DTERM2=-DX DTERM3=DLOG(1.0D0) DTERM4=DLNGAM(DGAMMA) DTERM5=DTERM1+DTERM2-DTERM3-DTERM4 IF(DTERM5.LT.-80.D0)THEN PDF=0.0 ELSEIF(DTERM5.GT.65.D0)THEN WRITE(ICOUT,105) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)GAMMA CALL DPWRST('XXX','BUG ') PDF=EXP(65.0) ELSE DPDF=DEXP(DTERM5) PDF=REAL(DPDF) ENDIF 105 FORMAT('****** WARNING--OVERFLOW IN GAMPDF ROUTINE. PDF VALUE ', 1'SET TO EXP(65)') CCCCC WRITE(ICOUT,25) CCCCC CALL DPWRST('XXX','BUG ') C CCC25 FORMAT('***** WARNING--UNDERFLOW IN CALCULATION OF GAMMA PDF.', CCCCC1 ' PDF SET TO ZERO. *****') C 9999 CONTINUE RETURN END SUBROUTINE GAMPPF(P,GAMMA,PPF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT C FUNCTION VALUE FOR THE GAMMA DISTRIBUTION C WITH SINGLE PRECISION C TAIL LENGTH PARAMETER = GAMMA. C THE GAMMA DISTRIBUTION USED C HEREIN HAS MEAN = GAMMA C AND STANDARD DEVIATION = SQRT(GAMMA). C THIS DISTRIBUTION IS DEFINED FOR ALL POSITIVE X, C AND HAS THE PROBABILITY DENSITY FUNCTION C F(X) = (1/CONSTANT) * (X**(GAMMA-1)) * EXP(-X) C WHERE THE CONSTANT = THE GAMMA FUNCTION EVALUATED C AT THE VALUE GAMMA. C NOTE THAT THE PERCENT POINT FUNCTION OF A DISTRIBUTION C IS IDENTICALLY THE SAME AS THE INVERSE CUMULATIVE C DISTRIBUTION FUNCTION OF THE DISTRIBUTION. C 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 --GAMMA = THE SINGLE PRECISION VALUE OF THE C TAIL LENGTH PARAMETER. C GAMMA 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 GAMMA DISTRIBUTION C WITH TAIL LENGTH PARAMETER VALUE = GAMMA. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--GAMMA SHOULD BE POSITIVE. C --P SHOULD BE BETWEEN 0.0 (EXCLUSIVELY) C AND 1.0 (EXCLUSIVELY). C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--DEXP, DLOG. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C ACCURACY--(ON THE UNIVAC 1108, EXEC 8 SYSTEM AT NBS) C COMPARED TO THE KNOWN GAMMA = 1 (EXPONENTIAL) C RESULTS, AGREEMENT WAS HAD OUT TO 6 SIGNIFICANT C DIGITS FOR ALL TESTED P IN THE RANGE P = .001 TO C P = .999. FOR P = .95 AND SMALLER, THE AGREEMENT C WAS EVEN BETTER--7 SIGNIFICANT DIGITS. C (NOTE THAT THE TABULATED VALUES GIVEN IN THE WILK, C GNANADESIKAN, AND HUYETT REFERENCE BELOW, PAGE 20, C ARE IN ERROR FOR AT LEAST THE GAMMA = 1 CASE-- C THE WORST DETECTED ERROR WAS AGREEMENT TO ONLY 3 C SIGNIFICANT DIGITS (IN THEIR 8 SIGNIFICANT DIGIT TABLE) C FOR P = .999.) C REFERENCES--WILK, GNANADESIKAN, AND HUYETT, 'PROBABILITY C PLOTS FOR THE GAMMA DISTRIBUTION', C TECHNOMETRICS, 1962, PAGES 1-15, C ESPECIALLY PAGES 3-5. C --NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY APPLIED MATHEMATICS C SERIES 55, 1964, PAGE 257, FORMULA 6.1.41. C --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE C DISTRIBUTIONS--1, 1970, PAGES 166-206. C --HASTINGS AND PEACOCK, STATISTICAL C DISTRIBUTIONS--A HANDBOOK FOR C STUDENTS AND PRACTITIONERS, 1975, C PAGES 68-73. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-921-3651 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C 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/7 C ORIGINAL VERSION--NOVEMBER 1974. C UPDATED --SEPTEMBER 1975. C UPDATED --NOVEMBER 1975. C UPDATED --DECEMBER 1981. C UPDATED --MAY 1982. C UPDATED --JUNE 1987. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DP,DGAMMA CCCCC DOUBLE PRECISION Z,Z2,Z3,Z4,Z5,DEN,A,B,C,D,G DOUBLE PRECISION Z,Z2,DEN,A,B,C,D DOUBLE PRECISION XMIN0,XMIN,AI,XMAX,DX,PCALC,XMID DOUBLE PRECISION XLOWER,XUPPER,XDEL DOUBLE PRECISION SUM,TERM,CUT1,CUT2,AJ,CUTOFF,T DOUBLE PRECISION DLG,DLT,DLX,DLPCAL DOUBLE PRECISION DLP,DLGAMM,DLXMI0 DOUBLE PRECISION Z2INV DOUBLE PRECISION DEXP,DLOG C DIMENSION D(10) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----DATA STATEMENTS------------------------------------------------- C DATA C/ .918938533204672741D0/ DATA D(1),D(2),D(3),D(4),D(5) 1 /+.833333333333333333D-1,-.277777777777777778D-2, 1+.793650793650793651D-3,-.595238095238095238D-3,+.8417508417508417 151D-3/ DATA D(6),D(7),D(8),D(9),D(10) 1 /-.191752691752691753D-2,+.641025641025641025D-2,-.2955065359 147712418D-1,+.179644372368830573D0,-.139243221690590111D1/ C C-----START POINT----------------------------------------------------- C XMID=0.0 XLOWER=0.0 XUPPER=0.0 C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(P.LE.0.0.OR.P.GE.1.0)GOTO50 IF(GAMMA.LE.0.0)GOTO55 GOTO90 50 WRITE(ICOUT,1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)P CALL DPWRST('XXX','BUG ') PPF=0.0 RETURN 55 WRITE(ICOUT,15) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)GAMMA CALL DPWRST('XXX','BUG ') PPF=0.0 RETURN 90 CONTINUE 1 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ', 1'GAMPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL') 15 FORMAT('***** FATAL ERROR--THE 2ND INPUT ARGUMENT TO THE ', 1'GAMPPF SUBROUTINE IS NON-POSITIVE *****') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') C DP=P DGAMMA=GAMMA MAXIT=10000 C C COMPUTE THE GAMMA FUNCTION USING THE ALGORITHM IN THE C NBS APPLIED MATHEMATICS SERIES REFERENCE. C THIS GAMMA FUNCTION NEED BE CALCULATED ONLY ONCE. C IT IS USED IN THE CALCULATION OF THE CDF BASED ON C THE TENTATIVE VALUE OF THE PPF IN THE ITERATION. C Z=DGAMMA DEN=1.0D0 150 IF(Z.GE.10.0D0)GOTO160 DEN=DEN*Z Z=Z+1.0D0 GOTO150 160 Z2=Z*Z CCCCC Z3=Z*Z2 CCCCC Z4=Z2*Z2 CCCCC Z5=Z2*Z3 A=(Z-0.5D0)*DLOG(Z)-Z+C CCCCC B=D(1)/Z+D(2)/Z3+D(3)/Z5+D(4)/(Z2*Z5)+D(5)/(Z4*Z5)+ CCCCC1D(6)/(Z*Z5*Z5)+D(7)/(Z3*Z5*Z5)+D(8)/(Z5*Z5*Z5)+D(9)/(Z2*Z5*Z5*Z5) Z2INV=1.0D0/Z2 B=D(9) B=Z2INV*B+D(8) B=Z2INV*B+D(7) B=Z2INV*B+D(6) B=Z2INV*B+D(5) B=Z2INV*B+D(4) B=Z2INV*B+D(3) B=Z2INV*B+D(2) B=Z2INV*B+D(1) B=(1.0D0/Z)*B CCCCC G=DEXP(A+B)/DEN DLG=(A+B)-DLOG(DEN) CCCCC WRITE(ICOUT,277)Z,B,DEN,DLG CC277 FORMAT('Z,B,DEN,DLG = ',4E15.7) CCCCC CALL DPWRST('XXX','BUG ') C C DETERMINE LOWER AND UPPER LIMITS ON THE DESIRED 100P C PERCENT POINT. C ILOOP=1 CCCCC WRITE(ICOUT,377)DP,DGAMMA CC377 FORMAT('DP,DGAMMA = ',2D15.7) CCCCC CALL DPWRST('XXX','BUG ') CCCCC XMIN0=(DP*DGAMMA*G)**(1.0D0/DGAMMA) DLP=DLOG(DP) DLGAMM=DLOG(DGAMMA) DLXMI0=(1.0D0/DGAMMA)*(DLP+DLGAMM+DLG) XMIN0=DEXP(DLXMI0) CCCCC WRITE(ICOUT,378)XMIN0 CC378 FORMAT('XMIN0 = ',E15.7) CCCCC CALL DPWRST('XXX','BUG ') XMIN=XMIN0 ICOUNT=1 350 AI=ICOUNT XMAX=AI*XMIN0 DX=XMAX GOTO1000 360 IF(PCALC.GE.DP)GOTO370 XMIN=XMAX ICOUNT=ICOUNT+1 IF(ICOUNT.LE.30000)GOTO350 370 XMID=(XMIN+XMAX)/2.0D0 C C NOW ITERATE BY BISECTION UNTIL THE DESIRED ACCURACY IS ACHIEVED. C ILOOP=2 XLOWER=XMIN XUPPER=XMAX ICOUNT=0 550 DX=XMID GOTO1000 560 IF(PCALC.EQ.DP)GOTO570 IF(PCALC.GT.DP)GOTO580 XLOWER=XMID XMID=(XMID+XUPPER)/2.0D0 GOTO590 580 XUPPER=XMID XMID=(XMID+XLOWER)/2.0D0 590 XDEL=XMID-XLOWER IF(XDEL.LT.0.0D0)XDEL=-XDEL ICOUNT=ICOUNT+1 IF(XDEL.LT.0.0000000001D0.OR.ICOUNT.GT.100)GOTO570 GOTO550 570 PPF=XMID RETURN C C******************************************************************** C THIS SECTION BELOW IS LOGICALLY SEPARATE FROM THE ABOVE. C THIS SECTION COMPUTES A CDF VALUE FOR ANY GIVEN TENTATIVE C PERCENT POINT X VALUE AS DEFINED IN EITHER OF THE 2 C ITERATION LOOPS IN THE ABOVE CODE. C C COMPUTE T-SUB-Q AS DEFINED ON PAGE 4 OF THE WILK, GNANADESIKAN, C AND HUYETT REFERENCE C 1000 SUM=1.0D0/DGAMMA TERM=1.0D0/DGAMMA CUT1=DX-DGAMMA CUT2=DX*10000000000.0D0 DO700J=1,MAXIT AJ=J TERM=DX*TERM/(DGAMMA+AJ) SUM=SUM+TERM CUTOFF=CUT1+(CUT2*TERM/SUM) IF(AJ.GT.CUTOFF)GOTO750 700 CONTINUE WRITE(ICOUT,705)MAXIT CALL DPWRST('XXX','BUG ') WRITE(ICOUT,706)P CALL DPWRST('XXX','BUG ') WRITE(ICOUT,707)GAMMA CALL DPWRST('XXX','BUG ') WRITE(ICOUT,708) CALL DPWRST('XXX','BUG ') PPF=0.0 RETURN C 750 T=SUM CCCCC WRITE(ICOUT,777)T,DX CC777 FORMAT('T,DX = ',2E15.7) CCCCC CALL DPWRST('XXX','BUG ') DLT=DLOG(T) DLX=DLOG(DX) CCCCC WRITE(ICOUT,778)DX,DGAMMA,T,DLT,G,DLG CC778 FORMAT('DX,DGAMMA,T,DLT,G,DLG = ',6D15.7) CCCCC CALL DPWRST('XXX','BUG ') CCCCC PCALC=(DX**DGAMMA)*(DEXP(-DX))*T/G DLPCAL=DGAMMA*DLX-DX+DLT-DLG PCALC=DEXP(DLPCAL) IF(ILOOP.EQ.1)GOTO360 GOTO560 C 705 FORMAT('*****ERROR IN INTERNAL OPERATIONS IN THE GAMPPF ', 1'SUBROUTINE--THE NUMBER OF ITERATIONS EXCEEDS ',I7) 706 FORMAT(33H THE INPUT VALUE OF P IS ,E15.8) 707 FORMAT(33H THE INPUT VALUE OF GAMMA IS ,E15.8) 708 FORMAT(48H THE OUTPUT VALUE OF PPF HAS BEEN SET TO 0.0) C END SUBROUTINE GAMRAN(N,GAMMA,ISEED,X) C C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N C FROM THE GAMMA DISTRIBUTION C WITH TAIL LENGTH PARAMETER VALUE = GAMMA. C THE PROTOTYPE GAMMA DISTRIBUTION USED C HEREIN HAS MEAN = GAMMA C AND STANDARD DEVIATION = SQRT(GAMMA). C THIS DISTRIBUTION IS DEFINED FOR ALL POSITIVE X, C AND HAS THE PROBABILITY DENSITY FUNCTION C F(X) = (1/CONSTANT) * (X**(GAMMA-1)) * EXP(-X) C WHERE THE CONSTANT = THE GAMMA FUNCTION EVALUATED C AT THE VALUE GAMMA. C INPUT ARGUMENTS--N = THE DESIRED INTEGER NUMBER C OF RANDOM NUMBERS TO BE C GENERATED. C --GAMMA = THE SINGLE PRECISION VALUE OF THE C TAIL LENGTH PARAMETER. C GAMMA SHOULD BE POSITIVE. C GAMMA SHOULD BE LARGER C THAN 1/3 (ALGORITHMIC RESTRICTION). 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 GAMMA DISTRIBUTION C WITH TAIL LENGTH PARAMETER VALUE = GAMMA. 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 --GAMMA SHOULD BE LARGER C THAN 1/3 (ALGORITHMIC RESTRICTION). C OTHER DATAPAC SUBROUTINES NEEDED--UNIRAN, NORRAN. C FORTRAN LIBRARY SUBROUTINES NEEDED--SQRT, EXP. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--GREENWOOD, 'A FAST GENERATOR FOR C GAMMA-DISTRIBUTED RANDOM VARIABLES', C COMPSTAT 1974, PROCEEDINGS IN C COMPUTATIONAL STATISTICS, VIENNA, C SEPTEMBER, 1974, PAGES 19-27. C --TOCHER, THE ART OF SIMULATION, C 1963, PAGES 24-27. C --HAMMERSLEY AND HANDSCOMB, MONTE CARLO METHODS, C 1964, PAGES 36-37. C --WILK, GNANADESIKAN, AND HUYETT, 'PROBABILITY C PLOTS FOR THE GAMMA DISTRIBUTION', C TECHNOMETRICS, 1962, PAGES 1-15. C --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE C DISTRIBUTIONS--1, 1970, PAGES 166-206. C --HASTINGS AND PEACOCK, STATISTICAL C DISTRIBUTIONS--A HANDBOOK FOR C STUDENTS AND PRACTITIONERS, 1975, C PAGES 68-73. C --NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY APPLIED MATHEMATICS C SERIES 55, 1964, PAGE 952. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-921-3651 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C 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/7 C ORIGINAL VERSION--NOVEMBER 1975. C UPDATED --FEBRUARY 1976. C UPDATED --JUNE 1978. C UPDATED --DECEMBER 1981. C UPDATED --MARCH 1982. C UPDATED --MAY 1982. C UPDATED --MAY 2003. REPLACE WITH CALL TO C AHRENS-DIETER CODE C UPDATED VERSION--JANUARY 2005. BUG IF ROUTINE CALLED MORE C THAN ONCE, RESET AA AND AAA C AND STORE IN COMMON C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DIMENSION X(*) C DIMENSION XN(2) DIMENSION U(2) C COMMON/SGAMM/AA,AAA 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 ATHIRD/0.3333333/ DATA SQRT3 /1.73205081/ C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C AA=0.0 AAA=0.0 C IF(N.LT.1)GOTO50 IF(GAMMA.LE.0.0)GOTO60 CCCCC IF(GAMMA.LE.0.33333333)GOTO65 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,46)GAMMA CALL DPWRST('XXX','BUG ') RETURN CCC65 WRITE(ICOUT,16) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,17) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,46)GAMMA CCCCC CALL DPWRST('XXX','BUG ') CCCCC RETURN 90 CONTINUE 5 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ', 1'GAMRAN SUBROUTINE IS NON-POSITIVE *****') 15 FORMAT('***** FATAL ERROR--THE 2ND INPUT ARGUMENT TO THE ', 1'GAMRAN SUBROUTINE IS NON-POSITIVE *****') 16 FORMAT('***** FATAL ERROR--THE 2ND INPUT ARGUMENT TO THE ', 1'GAMRAN SUBROUTINE IS SMALLER THAN OR EQUAL TO 0.3333333') 17 FORMAT( 44H (ALGORITHMIC RESTIRCTION)) 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****') C C GENERATE N GAMMA DISTRIBUTION RANDOM NUMBERS C USING GREENWOOD'S REJECTION ALGORITHM-- C 1) GENERATE A NORMAL RANDOM NUMBER; C 2) TRANSFORM THE NORMAL VARIATE TO AN APPROXIMATE C GAMMA VARIATE USING THE WILSON-HILFERTY C APPROXIMATION (SEE THE JOHNSON AND KOTZ C REFERENCE, PAGE 176); C 3) FORM THE REJECTION FUNCTION VALUE, BASED C ON THE PROBABILITY DENSITY FUNCTION VALUE C OF THE ACTUAL DISTRIBUTION OF THE PSEUDO-GAMMA C VARIATE, AND THE PROBABILITY DENSITY FUNCTION VALUE C OF A TRUE GAMMA VARIATE. C 4) GENERATE A UNIFORM RANDOM NUMBER; C 5) IF THE UNIFORM RANDOM NUMBER IS LESS THAN C THE REJECTION FUNCTION VALUE, THEN ACCEPT C THE PSEUDO-RANDOM NUMBER AS A GAMMA VARIATE; C IF THE UNIFORM RANDOM NUMBER IS LARGER THAN C THE REJECTION FUNCTION VALUE, THEN REJECT C THE PSEUDO-RANDOM NUMBER AS A GAMMA VARIATE. C C MAY 2003: THIS ALGORITHM DOESN'T WORK FOR GAMMA < 1/3. C REPLACE WITH THE POPULAR AHRENS-DIETER CODE FOR C GAMMA RANDOM NUMBERS. C CCCCC A1=1.0/(9.0*GAMMA) CCCCC B1=SQRT(A1) CCCCC XN0=-SQRT3+B1 CCCCC XG0=GAMMA*(1.0-A1+B1*XN0)**3 CCCCC DO100I=1,N CC150 CALL NORRAN(1,ISEED,XN) CCCCC XG=GAMMA*(1.0-A1+B1*XN(1))**3 CCCCC IF(XG.LT.0.0)GOTO150 CCCCC TERM=(XG/XG0)**(GAMMA-ATHIRD) CCCCC ARG=0.5*XN(1)*XN(1)-XG-0.5*XN0*XN0+XG0 CCCCC FUNCT=TERM*EXP(ARG) CCCCC CALL UNIRAN(1,ISEED,U) CCCCC IF(U(1).LE.FUNCT)GOTO170 CCCCC GOTO150 CC170 X(I)=XG CC100 CONTINUE C DO100I=1,N ATEMP=SGAMMA(ISEED,GAMMA) X(I)=ATEMP 100 CONTINUE C RETURN END SUBROUTINE GC1FUN (NPAR, XPAR, FVEC, IFLAG, ZDATA, M) C C PURPOSE--THIS ROUTINE COMPUTES THE FUNCTIONS FOR THE C GAMMA MAXIMUM LIKELIHOOD EQUATIONS FOR THE CENSORING C CASE (FROM PP. 217-218 OF BURY). C C R*XBAR/SHAT - R*GHAT + SUM[i=1 to M] C [Z(j)**GHAT*EXP(Z(j)/(GAMMA(GHAT) - G(Z(j),GHAT))] = 0 C C R*LOG(GEOMEAN/SHAT) - N*DIGAMMA(GHAT) + SUM[i=1 to M] C [(GAMMA(GHAT)*DIGAMMA(GHAT) J(Z(j),GHAT))/ C (GAMMA(GHAT) - G(Z(j),GHAT))] = 0 C C WHERE C C C XBAR = MEAN OF FAILURE DATA C GEOMEAN = GEOMETRIC MEAN OF FAILURE DATA C R = NUMBER OF FAILURES C M = NUMBER OF CENSORING TIMES C SHAT = FVEC(1) = CURRENT ESTIMATE OF SCALE PARAMETER C GHAT = FVEC(2) = CURRENT ESTIMATE OF SHAPE PARAMETER C Z(j) = jth CENSORING TIME C GAMMA = GAMMA FUNCTION C DIGAMMA = DIGAMMA FUNCTION C G(x,a) = INCOMPLETE GAMMA FUNCTION C J(X,a) = INTEGRAL[0 to x][t**(A-1)*LOG(t)*EXP(-t)]dt C C C CALLED BY DNSQE ROUTINE FOR SOLVING SIMULTANEOUS C NONLINEAR EQUATIONS. NOTE THAT THE CALLING SEQUENCE C DID NOT ACCOMODATE A DATA ARRAY (AND ASSCIATED NUMBER OF C OBSERVATIONS), SO THESE WERE ADDED TO THE CALL LIST. C EXAMPLE--GAMMA MAXIMUM LIKELIHOOD Y X C REFERENCE--KARL BURY, (1999). "STATISTICAL DISTRIBUTIONS IN C ENGINEERING", CAMBRIDGE UNIVERSITY PRESS, C PP. 217-218. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2004/11 C ORIGINAL VERSION--NOVEMBER 2004. C C--------------------------------------------------------------------- C INTEGER M DOUBLE PRECISION XPAR(*) DOUBLE PRECISION FVEC(*) REAL ZDATA(*) C DOUBLE PRECISION DN DOUBLE PRECISION DR DOUBLE PRECISION DX DOUBLE PRECISION GHAT DOUBLE PRECISION SHAT DOUBLE PRECISION DGI DOUBLE PRECISION DP DOUBLE PRECISION DSUM1 DOUBLE PRECISION DSUM2 DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 DOUBLE PRECISION DTERM3 DOUBLE PRECISION DTERM4 DOUBLE PRECISION DTERM5 DOUBLE PRECISION DTERM6 C INTEGER LIMIT INTEGER LENW PARAMETER(LIMIT=200) PARAMETER(LENW=4*LIMIT) INTEGER INF INTEGER NEVAL INTEGER IER INTEGER LAST INTEGER IWORK(LIMIT) DOUBLE PRECISION EPSABS DOUBLE PRECISION EPSREL DOUBLE PRECISION DLOW DOUBLE PRECISION ABSERR DOUBLE PRECISION WORK(LENW) C DOUBLE PRECISION XBAR DOUBLE PRECISION GEOMEA INTEGER N INTEGER R COMMON/GC1COM/XBAR,GEOMEA,N,R C DOUBLE PRECISION DA COMMON/J1COM/DA C DOUBLE PRECISION DGAMMA DOUBLE PRECISION DGAMI DOUBLE PRECISION DPSI DOUBLE PRECISION J1FUN EXTERNAL DGAMMA EXTERNAL DGAMI EXTERNAL DPSI EXTERNAL J1FUN 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 DN=DBLE(N) DR=DBLE(R) GHAT=XPAR(1) SHAT=XPAR(2) DG=DGAMMA(GHAT) DP=DPSI(GHAT) DA=GHAT C DTERM1=DR*XBAR/SHAT - DR*GHAT DTERM2=DR*DLOG(GEOMEA/SHAT) - DN*DP DSUM1=0.0D0 DSUM2=0.0D0 C EPSABS=1.0D-7 EPSREL=1.0D-7 IER=0 IKEY=3 DLOW=0.0D0 C IF(M.GT.0)THEN DO100I=1,M DX=DBLE(ZDATA(I))/SHAT DGI=DGAMI(GHAT,DX) DTERM3=DX**GHAT*DEXP(-DX) DTERM6=0.0D0 CALL DQAG(J1FUN,DLOW,DX,EPSABS,EPSREL,IKEY,DTERM6, 1 ABSERR,NEVAL, 1 IER,LIMIT,LENW,LAST,IWORK,WORK) DTERM4=DG*DP - DTERM6 DTERM5=DG - DGI DSUM1=DSUM1 + DTERM3/DTERM5 DSUM2=DSUM2 + DTERM4/DTERM5 100 CONTINUE ENDIF C FVEC(1) = DTERM1 + DSUM1 FVEC(2) = DTERM2 + DSUM2 C RETURN END subroutine gci1(ngrp, ni, xi, obsi, conf, nrun, mean, 1 llmt, ulmt,segci, 1 esi, thold, emu, 1 ierror) c c Note: This routine performs a consensus means analysis c based on generalized confidence interval approach. c This is documented in: c c Hari K. Iyer, C. M. Wang, and Thomas Matthew, c "Models and Confidence Intervals for True Values c in Interlaboratory Trials", Journal of the c American Statistical Association, Volume 99, c No. 468, pp. 1060-1071. c c Modified for Dataplot 3/2006. c c 1) I/O modified to use DPWRST c 2) Compute standard deviation of EMU as estimate of c standard error c 3) Pass THOLD, EMU, ESI as arguments c implicit none c c parameters: c c input: c ngrp - number of groups (labs) c ni - vector of size ngrp containing the sample size of each lab c xi - vector of size ngrp containing the mean of each lab c obsi - vector of size ngrp containing the variance of each lab c conf - nominal confidence coefficient, e.g., 0.95 c nrun - number of Monte Carlo samples to be used, e.g., 10000 c c output: c mean - mean of the simulated distribution of the GPQ c llmt - lower confidence limit c ulmt - upper confidence limit c integer ngrp, nrun, ni(ngrp) double precision obsi(ngrp), xi(ngrp) double precision conf, mean, llmt, ulmt c integer iseed real thold(ngrp) double precision esi(ngrp) double precision xbar, esa, emu(nrun), sesi, zval double precision lbd, ubd, errabs, tmp, segci c double precision zeroin c integer kk double precision aa, ybar, cc, bb(100), yy(100) common /cmn1/ kk common /cmn2/ aa, ybar, cc, bb, yy c integer j, m, ilb, iub c external ff double precision ff c CHARACTER*4 IWRITE CHARACTER*4 IBUGA3 CHARACTER*4 IERROR C INTEGER IRD INTEGER IPR INTEGER NUMBPC INTEGER NUMCPW INTEGER NUMBPW INTEGER NCOUT INTEGER ILOUT REAL CPUMIN REAL CPUMAX CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C iseed = 1234579 c ilb = nrun * ((1.0d0 - conf)/2.0) + 1 iub = nrun * ((1.0d0 + conf)/2.0) c kk = ngrp errabs = 0.001d0 c ybar = 0.0 do 10 m = 1, ngrp yy(m) = xi(m) ybar = ybar + xi(m) 10 continue ybar = ybar/ngrp c c for each set of observed \bar{x}_i and S_i^2 c mean = 0.0d0 c do 20 j = 1, nrun c c generate chi-square deviates to calculate c esi(*) = \hat{\sigma}_i^2 = (n_i - 1)*S_i^2/\chi^2 c do 30 m = 1, ngrp call chsran(1, real(ni(m) - 1), iseed, thold(m)) esi(m) = (ni(m) - 1) * obsi(m)/thold(m) bb(m) = esi(m)/ni(m) 30 continue call chsran(1, real(ngrp - 1), iseed, thold(1)) cc = thold(1) c c calculate the max of quadratic form, if it is less than cc c set esa to zero, else call zeroin (bi-section method) to c find the solution of esa = \sigma_a^2 c call maxofq c ubd = 99999.9d0 if (cc .ge. aa) then esa = 0.0d0 else if (ff(ubd) .lt. 0.0d0) then lbd = 0.0d0 ierror='NO' esa = zeroin(lbd, ubd, ff, errabs,ierror) if(ierror.eq.'YES')GOTO9000 end if end if c c form emu(*) = \hat{\mu} c call norran(1, iseed, thold(1)) zval = thold(1) xbar = 0.0d0 sesi = 0.0d0 do 40 m = 1, ngrp tmp = esa + bb(m) sesi = sesi + 1.0d0/tmp xbar = xbar + xi(m)/tmp 40 continue xbar = xbar/sesi emu(j) = xbar - zval/sqrt(sesi) c mean = mean + emu(j) c 20 continue c mean = mean/nrun c c sort emu(*) to find appropriate percentiles as c the confidence limits c call ssort(emu, emu, nrun, 1) llmt = emu(ilb) ulmt = emu(iub) iwrite='OFF' ibuga3='OFF' call sddp(emu,nrun,iwrite,segci,ibuga3,ierror) c 9000 continue return end SUBROUTINE GCHAR(CHR,X,Y,SZ, 1IBUGG3,ISUBRO,IERROR) C C PURPOSE--XX C C WRITTEN BY--DAVID W. BEHRINGER NOAA/AOML (MIAMI). C AS PART OF NOAA'S CONCX V.3 MARCH 1988. C ORIGINAL VERSION (IN DATAPLOT)--AUGUST 1988. C C--------------------------------------------------------------------- C CHARACTER CHR(15)*1 C CHARACTER*4 IBUGG3 CHARACTER*4 ISUBRO CHARACTER*4 IERROR C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'CHAR')GOTO1010 GOTO1019 1010 CONTINUE WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1011)CHR,X,Y,SZ 1011 FORMAT('FROM GCHAR--CHR,X,Y,SZ = ',4F10.5) CALL DPWRST('XXX','BUG ') 1019 CONTINUE C RETURN END SUBROUTINE GDER(MEW, THETA, RL, MRL, LM, IDER, RD, PD) C C ALGORITHM AS 189.4 APPL. STATIST. (1983) VOL.32, NO.2 C C GENERAL DERIVATIVE SUBROUTINE C DOUBLE PRECISION MEW, THETA, PD(IDER), A, B, C, D INTEGER RL(MRL,3), LM(3), RD(2,IDER) C MLM = LM(3) KK = IDER-1 DO 5 I = 1,IDER 5 PD(I) = 0.0D0 DO 45 I = 1,MLM C = DBLE(I-1) A = C*THETA DO 40 J = 1,3 IF(I.GT.LM(J)) GOTO 40 GOTO (10,15,20) J 10 D = MEW+A GOTO 25 15 D = 1.0D0-MEW+A GOTO 25 20 D = 1.0D0+A 25 B = DBLE(RL(I,J))/D**KK IF(J.EQ.3) GOTO 35 DO 30 K = 1,IDER PD(K) = PD(K)+DBLE(RD(J,K))*B B = B*C 30 CONTINUE GOTO 40 35 D = -DBLE(RD(1,1))*B*C**KK PD(IDER) = PD(IDER)+D 40 CONTINUE 45 CONTINUE RETURN END SUBROUTINE GEECDF(X,GAMMA,CDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION C FUNCTION VALUE FOR THE GEOMETRIC EXTREME EXPONENTIAL C DISTRIBUTION WITH SINGLE PRECISION C TAIL LENGTH PARAMETER = GAMMA. C THE GEOMETRIC EXTREME EXPONENTIAL DISTRIBUTION USED C HEREIN IS DEFINED FOR ALL X >= 0 C AND HAS THE CUMULATIVE DISTRIBUTION FUNCTION C F(X) = 1 - GAMMA/[EXP(X) + GAMMA - 1] GAMMA > 0 C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE AT C WHICH THE CUMULATIVE DISTRIBUTION C FUNCTION IS TO BE EVALUATED. C --GAMMA = THE SHAPE PARAMETER C GAMMA 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 GEOMETRIC EXTREME C EXPONENTIAL DISTRIBUTION C WITH TAIL LENGTH PARAMETER = GAMMA. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--GAMMA SHOULD BE POSITIVE. C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--EXP, LOG. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--"CAN DATA RECOGNOZE ITS PARENT DISTRIBUTION?", C MARSHALL, MEZA, OLKIN, JOURNAL OF COMPUTATIONAL C AND GRAPHICAL STATISTICS, SEPTEMBER, 2001, C PP. 555-580. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--2001.11 C ORIGINAL VERSION--NOVEMBER 2001. C DOUBLE PRECISION DX DOUBLE PRECISION DGAMMA DOUBLE PRECISION DCDF C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(X.LT.0.0)THEN WRITE(ICOUT,5) 5 FORMAT('***** FATAL ERROR--THE FIRST INPUT ARGUMENT TO THE ', 1 'GEECDF SUBROUTINE IS NEGATIVE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9000 ENDIF C IF(GAMMA.LE.0.0)THEN WRITE(ICOUT,15) 15 FORMAT('***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE ', 1 'GEECDF SUBROUTINE IS NON-POSITIVE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)GAMMA 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8) CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9000 ENDIF C DGAMMA=DBLE(GAMMA) DX=DBLE(X) DCDF=1.0D0 - DGAMMA/(EXP(DX) + DGAMMA - 1.0D0) CDF=REAL(DCDF) C 9000 CONTINUE RETURN END SUBROUTINE GEECHA(X,GAMMA,HAZ) C C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE HAZARD C FUNCTION VALUE FOR THE GEOMETRIC EXTREME EXPONENTIAL C DISTRIBUTION WITH SINGLE PRECISION C TAIL LENGTH PARAMETER = GAMMA. C THE GEOMETRIC EXTREME EXPONENTIAL DISTRIBUTION USED C HEREIN IS DEFINED FOR ALL X >= 0 C AND HAS THE CUMULATIVE HAZARD FUNCTION C H(X) = -LOG(1-GEECDF(X)), GAMMA > 0 C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE AT C WHICH THE CUMULATIVE HAZARD C FUNCTION IS TO BE EVALUATED. C --GAMMA = THE SHAPE PARAMETER C GAMMA SHOULD BE POSITIVE. C OUTPUT ARGUMENTS--HAZ = THE SINGLE PRECISION CUMULATIVE HAZARD C FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION CUMULATIVE HAZARD C FUNCTION VALUE PDF FOR THE GEOMETRIC EXTREME C EXPONENTIAL DISTRIBUTION C WITH TAIL LENGTH PARAMETER = GAMMA. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--GAMMA SHOULD BE POSITIVE. C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--EXP, LOG. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--"CAN DATA RECOGNOZE ITS PARENT DISTRIBUTION?", C MARSHALL, MEZA, OLKIN, JOURNAL OF COMPUTATIONAL C AND GRAPHICAL STATISTICS, SEPTEMBER, 2001, C PP. 555-580. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--2001.11 C ORIGINAL VERSION--NOVEMBER 2001. C DOUBLE PRECISION DX DOUBLE PRECISION DGAMMA DOUBLE PRECISION DCDF DOUBLE PRECISION DHAZ C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(X.LT.0.0)THEN WRITE(ICOUT,5) 5 FORMAT('***** FATAL ERROR--THE FIRST INPUT ARGUMENT TO THE ', 1 'GEECHA SUBROUTINE IS NEGATIVE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') HAZ=0.0 GOTO9000 ENDIF C IF(GAMMA.LE.0.0)THEN WRITE(ICOUT,15) 15 FORMAT('***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE ', 1 'GEECHA SUBROUTINE IS NON-POSITIVE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)GAMMA 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8) CALL DPWRST('XXX','BUG ') HAZ=0.0 GOTO9000 ENDIF C DGAMMA=DBLE(GAMMA) DX=DBLE(X) DCDF=DGAMMA/(EXP(DX) + DGAMMA - 1.0D0) DHAZ=-LOG(DCDF) HAZ=REAL(DHAZ) C 9000 CONTINUE RETURN END SUBROUTINE GEEFUN (N, X, FVEC, IFLAG, XDATA, NOBS) C C PURPOSE--THIS ROUTINE COMPUTES THE FUNCTIONS FOR THE C GENERALIZED EXTREME EXPONENTIAL MAXIMUM LIKELIHOOD C EQUATIONS. C C N/G - 2*SUM[i=1 to N][EXP(-L*X(i)/(1-(1-G)*EXP(-L*X(i)))] C C N/G - SUM[i=1 to N][X(i)] - C 2*SUM[i=1 to N][EXP(-L*X(i)/(1-(1-G)*EXP(-L*X(i)))] C C WITH G AND L DENOTING THE SHAPE PARAMETER GAMMA AND C SCALE PARAMETER LAMBDA RESPECTIVELY. C C CALLED BY DNSQE ROUTINE FOR SOLVING SIMULTANEOUS C NONLINEAR EQUATIONS. NOTE THAT THE CALLING SEQUENCE C DID NOT ACCOMODATE A DATA ARRAY (AND ASSCIATED NUMBER OF C OBSERVATIONS), SO THESE WERE ADDED TO THE CALL LIST. C EXAMPLE--GENERALIZED EXTREME EXPONENTIAL MAXIMUM LIKELIHOOD Y C REFERENCE--"CAN DATA RECOGNIZE ITS PARENT DISTRIBUTION?", C MARSHALL, MEZA, AND OLKIN, JOURNAL OF COMPUTATIONAL C AND GRAPHICAL STATISTICS, SEPTEMBER, 2001, C PP. 555-580. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBUG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2004/3 C ORIGINAL VERSION--MARCH 2004. C C--------------------------------------------------------------------- C DOUBLE PRECISION X(*) DOUBLE PRECISION FVEC(*) REAL XDATA(*) C DOUBLE PRECISION DN DOUBLE PRECISION DX DOUBLE PRECISION DG DOUBLE PRECISION DGC DOUBLE PRECISION DL DOUBLE PRECISION DSUM1 DOUBLE PRECISION DSUM2 DOUBLE PRECISION DSUM3 DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 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 COMPUTE SOME SUMS C DG=X(1) DGC=1.0D0-DG DL=X(2) DN=DBLE(NOBS) C DSUM1=0.0D0 DSUM2=0.0D0 DSUM3=0.0D0 C DO200I=1,NOBS DX=DBLE(XDATA(I)) DTERM1=DEXP(-DL*DX) DTERM2=1.0D0 - DGC*DEXP(-DL*DX) DSUM1=DSUM1 + DTERM1/DTERM2 DTERM1=DGC*DX*DEXP(-DL*DX) DTERM2=1.0D0 - DGC*DEXP(-DL*DX) DSUM2=DSUM2 + DTERM1/DTERM2 DSUM3=DSUM3 + DX 200 CONTINUE C FVEC(1)=(DN/DG) - 2.0D0*DSUM1 FVEC(2)=(DN/DL) - DSUM3 - 2.0D0*DSUM2 C RETURN END SUBROUTINE GEEPDF(X,GAMMA,PDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY C FUNCTION VALUE FOR THE GEOMETRIC EXTREME EXPONENTIAL C DISTRIBUTION WITH SINGLE PRECISION C TAIL LENGTH PARAMETER = GAMMA. C THE GEOMETRIC EXTREME EXPONENTIAL DISTRIBUTION USED C HEREIN IS DEFINED FOR ALL X >= 0 C AND HAS THE PROBABILITY DENSITY FUNCTION C F(X) = GAMMA*EXP(X)/[(EXP(X)+GAMMA-1)**2] GAMMA > 0 C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE AT C WHICH THE PROBABILITY DENSITY C FUNCTION IS TO BE EVALUATED. C --GAMMA = THE SHAPE PARAMETER C GAMMA 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 GEOMETRIC EXTREME C EXPONENTIAL DISTRIBUTION C WITH TAIL LENGTH PARAMETER = GAMMA. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--GAMMA SHOULD BE POSITIVE. C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--EXP, LOG. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--"CAN DATA RECOGNOZE ITS PARENT DISTRIBUTION?", C MARSHALL, MEZA, OLKIN, JOURNAL OF COMPUTATIONAL C AND GRAPHICAL STATISTICS, SEPTEMBER, 2001, C PP. 555-580. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--2001.11 C ORIGINAL VERSION--NOVEMBER 2001. C DOUBLE PRECISION DX DOUBLE PRECISION DGAMMA DOUBLE PRECISION DPDF C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(X.LT.0.0)THEN WRITE(ICOUT,5) 5 FORMAT('***** FATAL ERROR--THE FIRST INPUT ARGUMENT TO THE ', 1 'GEEPDF SUBROUTINE IS NEGATIVE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9000 ENDIF C IF(GAMMA.LE.0.0)THEN WRITE(ICOUT,15) 15 FORMAT('***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE ', 1 'GEEPDF SUBROUTINE IS NON-POSITIVE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)GAMMA 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8) CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9000 ENDIF C DGAMMA=DBLE(GAMMA) DX=DBLE(X) DPDF=LOG(DGAMMA) + DX - 2.0D0*LOG(EXP(DX)+DGAMMA-1.0D0) IF(DPDF.LT.-36.0D0)THEN PDF=0.0 ELSEIF(DPDF.GT.36.0D0)THEN WRITE(ICOUT,25) 25 FORMAT('***** FATAL ERROR--GEEPDF ROUTINE OVERFLOWS FOR') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,26)X,GAMMA 26 FORMAT(' X = ',E15.7,' GAMMA = ',E15.7) CALL DPWRST('XXX','BUG ') PDF=0.0 ELSE DPDF=EXP(DPDF) PDF=REAL(DPDF) ENDIF C 9000 CONTINUE RETURN END SUBROUTINE GEEHAZ(X,GAMMA,HAZ) C C PURPOSE--THIS SUBROUTINE COMPUTES THE HAZARD C FUNCTION VALUE FOR THE GEOMETRIC EXTREME EXPONENTIAL C DISTRIBUTION WITH SINGLE PRECISION C TAIL LENGTH PARAMETER = GAMMA. C THE GEOMETRIC EXTREME EXPONENTIAL DISTRIBUTION USED C HEREIN IS DEFINED FOR ALL X >= 0 C AND HAS THE HAZARD FUNCTION C H(X) = GEEPDF(X)/(1-GEECDF(X)), GAMMA > 0 C = EXP(X)/[EXP(X)+GAMMA-1)] GAMMA > 0 C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE AT C WHICH THE HAZARD C FUNCTION IS TO BE EVALUATED. C --GAMMA = THE SHAPE PARAMETER C GAMMA SHOULD BE POSITIVE. C OUTPUT ARGUMENTS--HAZ = THE SINGLE PRECISION HAZARD C FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION HAZARD C FUNCTION VALUE PDF FOR THE GEOMETRIC EXTREME C EXPONENTIAL DISTRIBUTION C WITH TAIL LENGTH PARAMETER = GAMMA. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--GAMMA SHOULD BE POSITIVE. C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--EXP, LOG. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--"CAN DATA RECOGNOZE ITS PARENT DISTRIBUTION?", C MARSHALL, MEZA, OLKIN, JOURNAL OF COMPUTATIONAL C AND GRAPHICAL STATISTICS, SEPTEMBER, 2001, C PP. 555-580. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--2001.11 C ORIGINAL VERSION--NOVEMBER 2001. C DOUBLE PRECISION DX DOUBLE PRECISION DGAMMA DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 DOUBLE PRECISION DHAZ C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(X.LT.0.0)THEN WRITE(ICOUT,5) 5 FORMAT('***** FATAL ERROR--THE FIRST INPUT ARGUMENT TO THE ', 1 'GEEHAZ SUBROUTINE IS NEGATIVE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') HAZ=0.0 GOTO9000 ENDIF C IF(GAMMA.LE.0.0)THEN WRITE(ICOUT,15) 15 FORMAT('***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE ', 1 'GEEHAZ SUBROUTINE IS NON-POSITIVE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)GAMMA 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8) CALL DPWRST('XXX','BUG ') HAZ=0.0 GOTO9000 ENDIF C DGAMMA=DBLE(GAMMA) DX=DBLE(X) DTERM1=EXP(DX) DTERM2=DTERM1+DGAMMA-1.0D0 IF(DTERM2.NE.0.0D0)THEN DHAZ=DTERM1/DTERM2 HAZ=REAL(DHAZ) ELSE HAZ=0.0 ENDIF C 9000 CONTINUE RETURN END SUBROUTINE GEEPPF(P,GAMMA,PPF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT C FUNCTION VALUE FOR THE GEOMETRIC EXTREME EXPONENTIAL C DISTRIBUTION WITH SINGLE PRECISION C TAIL LENGTH PARAMETER = GAMMA. C THE GEOMETRIC EXTREME EXPONENTIAL DISTRIBUTION USED C HEREIN IS DEFINED FOR ALL 0 <= P < 1. C AND HAS THE PERCENT POINT FUNCTION C G(P) = LOG[GAMMA/(1-P) + 1 - GAMMA], GAMMA > 0 C INPUT ARGUMENTS--P = THE SINGLE PRECISION VALUE AT C WHICH THE PERCENT POINT C FUNCTION IS TO BE EVALUATED. C --GAMMA = THE SHAPE PARAMETER C GAMMA SHOULD BE POSITIVE. C OUTPUT ARGUMENTS--PPF = THE SINGLE PRECISION PERCENT C POINT FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION PERCENT POINT C FUNCTION VALUE PPF FOR THE GEOMETRIC EXTREME C EXPONENTIAL DISTRIBUTION C WITH TAIL LENGTH PARAMETER = GAMMA. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--GAMMA SHOULD BE POSITIVE. C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--LOG. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--"CAN DATA RECOGNOZE ITS PARENT DISTRIBUTION?", C MARSHALL, MEZA, OLKIN, JOURNAL OF COMPUTATIONAL C AND GRAPHICAL STATISTICS, SEPTEMBER, 2001, C PP. 555-580. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--2001.11 C ORIGINAL VERSION--NOVEMBER 2001. C DOUBLE PRECISION DP DOUBLE PRECISION DGAMMA DOUBLE PRECISION DPPF C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(P.LT.0.0.OR.P.GE.1.0)THEN WRITE(ICOUT,5) 5 FORMAT('***** FATAL ERROR--THE FIRST INPUT ARGUMENT TO THE ', 1 'GEEPPF SUBROUTINE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,6) 6 FORMAT(' OUTSIDE THE ALLOWABLE (0,1] INTERVAL.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)P CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9000 ENDIF C IF(GAMMA.LE.0.0)THEN WRITE(ICOUT,15) 15 FORMAT('***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE ', 1 'GEEPPF SUBROUTINE IS NON-POSITIVE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)GAMMA 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8) CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9000 ENDIF C DGAMMA=DBLE(GAMMA) DP=DBLE(P) DPPF=LOG(DGAMMA/(1.0D0-DP) + 1.0D0 - DGAMMA) PPF=REAL(DPPF) C 9000 CONTINUE RETURN END SUBROUTINE GEERAN(N,GAMMA,ISEED,X) C C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N C FROM THE GEOMETRIC EXTREME EXPONENTIAL DISTRIBUTION C WITH TAIL LENGTH PARAMETER VALUE = GAMMA. C INPUT ARGUMENTS--N = THE DESIRED INTEGER NUMBER C OF RANDOM NUMBERS TO BE C GENERATED. C --GAMMA = THE SINGLE PRECISION VALUE OF THE C TAIL LENGTH PARAMETER. C GAMMA SHOULD BE POSITIVE. C 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 GEOMETRIC EXTREME EXPONENTIAL DISTRIBUTION C WITH TAIL LENGTH PARAMETER VALUE = GAMMA. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C --GAMMA SHOULD BE POSITIVE. C OTHER DATAPAC SUBROUTINES NEEDED--UNIRAN. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--"CAN DATA RECOGNOZE ITS PARENT DISTRIBUTION?", C MARSHALL, MEZA, OLKIN, JOURNAL OF COMPUTATIONAL C AND GRAPHICAL STATISTICS, SEPTEMBER, 2001, C PP. 555-580. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--2001.11 C ORIGINAL VERSION--NOVEMBER 2001. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DIMENSION X(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(N.LT.1)THEN WRITE(ICOUT, 5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)N CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF IF(GAMMA.LE.0.0)THEN WRITE(ICOUT,15) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)GAMMA CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF 5 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ', 1'GEERAN SUBROUTINE IS NON-POSITIVE *****') 15 FORMAT('***** FATAL ERROR--THE 2ND INPUT ARGUMENT TO THE ', 1'GEERAN SUBROUTINE IS NON-POSITIVE *****') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****') C C GENERATE N UNIFORM (0,1) RANDOM NUMBERS; C CALL UNIRAN(N,ISEED,X) C C GENERATE N GEOMETRIC EXTREME EXPONENTIAL DISTRIBUTION RANDOM C NUMBERS USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD. C DO100I=1,N CALL GEEPPF(X(I),GAMMA,XTEMP) X(I)=XTEMP 100 CONTINUE C 9000 CONTINUE RETURN END SUBROUTINE GENARI(Y1,Y2,Y3,Y4,N1,N3,IACASE,IWRITE, 1Y5,Y6,N5,N6,SCAL3,ITYP3,IBUGA3,ISUBRO,IERROR) C C PURPOSE--CARRY OUT (DEX) GENERATOR ARITHMETIC OPERATIONS C OF THE REAL DATA IN Y1 AND Y3. C C OPERATIONS--ADDITION C SUBTRACTION C MULTIPLICATION C C INPUT ARGUMENTS--Y1 (REAL PART) Y2 (IMAGINARY PART) C --Y3 (REAL PART) Y4 (IMAGINARY PART) C OUTPUT ARGUMENTS--Y5 (REAL PART) Y6 (IMAGINARY PART) C C NOTE--IT IS NOT PERMISSIBLE TO HAVE THE OUTPUT VECTORS Y5(.) AND Y6(.) C BEING IDENTICAL TO THE INPUT VECTORS Y1(.) AND Y2(.), OR C Y3(.) AND Y4(.). C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-921-3651 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--89/12 C ORIGINAL VERSION--DECEMBER 1989. C UPDATED --JUNE 1990. TEMPORARY ARRAYS TO GARBAGE COMMON C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IACASE CHARACTER*4 IWRITE CHARACTER*4 ITYP3 CHARACTER*4 IBUGA3 CHARACTER*4 ISUBRO CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C-----DOUBLE PRECISION STATEMENTS FOR NON-COMMON VARIABLES------------------- C CCCCC DOUBLE PRECISION DY1 CCCCC DOUBLE PRECISION DY2 CCCCC DOUBLE PRECISION DY3 CCCCC DOUBLE PRECISION DY4 CCCCC DOUBLE PRECISION DY5 CCCCC DOUBLE PRECISION DY6 CCCCC DOUBLE PRECISION DSUM5 CCCCC DOUBLE PRECISION DSUM6 C DOUBLE PRECISION DTOP DOUBLE PRECISION DMID DOUBLE PRECISION DBOT CCCCC DOUBLE PRECISION DRATIO C CCCCC DOUBLE PRECISION DCUM CCCCC DOUBLE PRECISION DX CCCCC DOUBLE PRECISION DC C C--------------------------------------------------------------------- C INCLUDE 'DPCOPA.INC' C DIMENSION Y1(*) DIMENSION Y2(*) DIMENSION Y3(*) DIMENSION Y4(*) DIMENSION Y5(*) DIMENSION Y6(*) C DIMENSION DTOP(MAXOBV) DIMENSION DMID(MAXOBV) DIMENSION DBOT(MAXOBV) CCCCC FOLLOWING LINES ADDED JUNE, 1990 INCLUDE 'DPCOZD.INC' EQUIVALENCE (DGARBG(IDGAR1),DTOP(1)) EQUIVALENCE (DGARBG(IDGAR2),DMID(1)) EQUIVALENCE (DGARBG(IDGAR3),DBOT(1)) CCCCC END CHANGE C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='GENA' ISUBN2='RI ' C IERROR='NO' C SCAL3=(-999.0) ITYP3='VECT' C IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'PARI')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF GENARI--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA3,ISUBRO,IACASE,IWRITE 52 FORMAT('IBUGA3,ISUBRO,IACASE,IWRITE = ',A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)N1,N3 53 FORMAT('N1,N3 = ',2I8) CALL DPWRST('XXX','BUG ') DO55I=1,N1 WRITE(ICOUT,56)I,Y1(I),Y2(I) 56 FORMAT('I,Y1(I),Y2(I) = ',I8,2E13.5) CALL DPWRST('XXX','BUG ') 55 CONTINUE DO65I=1,N3 WRITE(ICOUT,66)I,Y3(I),Y4(I) 66 FORMAT('I,Y3(I),Y4(I) = ',I8,2E13.5) CALL DPWRST('XXX','BUG ') 65 CONTINUE 90 CONTINUE C C ************************************************** C ** CARRY OUT (DEX) GENERATOR ARITHMETIC OPERATIONS ** C ************************************************** C C ******************************************** C ** STEP 11-- ** C ** CHECK NUMBER OF INPUT OBSERVATIONS. ** C ******************************************** C IF(N1.LT.1)GOTO1100 IF(N3.LT.1)GOTO1100 GOTO1190 C 1100 CONTINUE IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1151) 1151 FORMAT('***** ERROR IN GENARI--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1152) 1152 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1153) 1153 FORMAT(' IN THE VARIABLE FOR WHICH') CALL DPWRST('XXX','BUG ') IF(IACASE.EQ.'GEAD')WRITE(ICOUT,1161) 1161 FORMAT(' THE (DEX) GENERATOR ADDITION IS TO BE ', 1'COMPUTED') IF(IACASE.EQ.'GEAD')CALL DPWRST('XXX','BUG ') IF(IACASE.EQ.'GESU')WRITE(ICOUT,1162) 1162 FORMAT(' THE (DEX) GENERATOR SUBTRACTION IS TO BE ', 1'COMPUTED') IF(IACASE.EQ.'GESU')CALL DPWRST('XXX','BUG ') IF(IACASE.EQ.'GEMU')WRITE(ICOUT,1163) 1163 FORMAT(' THE (DEX) GENERATOR MULTIPLICATION IS TO BE ', 1'COMPUTED') IF(IACASE.EQ.'GEMU')CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1181) 1181 FORMAT(' MUST BE 1 OR LARGER.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1182) 1182 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1183)N1,N3 1183 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS HERE = ',2I8, 1'.') CALL DPWRST('XXX','BUG ') GOTO9000 C 1190 CONTINUE C C ********************************* C ** STEP 12-- ** C ** BRANCH TO THE PROPER CASE ** C ********************************* C IF(IACASE.EQ.'GEAD')GOTO2100 IF(IACASE.EQ.'GESU')GOTO2200 IF(IACASE.EQ.'GEMU')GOTO2300 C WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1211) 1211 FORMAT('***** INTERNAL ERROR IN GENARI--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1212) 1212 FORMAT(' IACASE NOT EQUAL TO') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1213) 1213 FORMAT(' GEAD, GESU, OR GEMU') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1215) 1215 FORMAT(' IACASE = ',A4) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C C ********************************************* C ** STEP 21-- ** C ** TREAT THE (DEX) GENERATOR ADDITION CASE ** C ********************************************* C 2100 CONTINUE GOTO2300 C C ********************************************* C ** STEP 22-- ** C ** TREAT THE (DEX) GENERATOR SUBTRACTION CASE ** C ********************************************* C 2200 CONTINUE GOTO2300 C C ************************************************ C ** STEP 23-- ** C ** TREAT THE (DEX) GENERATOR MULTIPLICATION CASE ** C ************************************************ C 2300 CONTINUE N5TEMP=0 L=0 C IF(N1.LE.0)GOTO2319 DO2310J=1,N1 Y1J=Y1(J) IF(N3.LE.0)GOTO2329 DO2320K=1,N3 IF(Y3(K).EQ.Y1J)GOTO2310 2320 CONTINUE 2329 CONTINUE L=L+1 Y5(L)=Y1J 2310 CONTINUE 2319 CONTINUE C IF(N3.LE.0)GOTO2339 DO2330J=1,N3 Y3J=Y3(J) IF(N1.LE.0)GOTO2349 DO2340K=1,N1 IF(Y1(K).EQ.Y3J)GOTO2330 2340 CONTINUE 2349 CONTINUE L=L+1 Y5(L)=Y3J 2330 CONTINUE 2339 CONTINUE C N5TEMP=L C IF(N5TEMP.LE.0)GOTO2359 DO2350J=1,N5TEMP JP1=J+1 IF(JP1.GT.N5TEMP)GOTO2359 DO2360K=JP1,N5TEMP IF(Y5(K).GT.Y5(J))GOTO2360 HOLD=Y5(J) Y5(J)=Y5(K) Y5(K)=HOLD 2360 CONTINUE 2350 CONTINUE 2359 CONTINUE C ITYP3='VECT' N5=N5TEMP N6=N5 GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE C IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'PARI')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF GENARI--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGA3,ISUBRO,IACASE,IWRITE 9012 FORMAT('IBUGA3,ISUBRO,IACASE,IWRITE = ',A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)IERROR 9013 FORMAT('IERROR = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9017)N1,N3,N5,N6 9017 FORMAT('N1,N3,N5,N6 = ',4I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9018)SCAL3,ITYP3 9018 FORMAT('SCAL3,ITYP3 = ',E15.7,2X,A4) CALL DPWRST('XXX','BUG ') IF(ITYP3.EQ.'SCAL')GOTO9090 DO9021I=1,N1 WRITE(ICOUT,9022)I,Y1(I),Y2(I) 9022 FORMAT('I,Y1(I),Y2(I) = ',I8,2E13.5) CALL DPWRST('XXX','BUG ') 9021 CONTINUE DO9031I=1,N3 WRITE(ICOUT,9032)I,Y3(I),Y4(I) 9032 FORMAT('I,Y3(I),Y4(I) = ',I8,2E13.5) CALL DPWRST('XXX','BUG ') 9031 CONTINUE DO9041I=1,N5 WRITE(ICOUT,9042)I,Y5(I),Y6(I) 9042 FORMAT('I,Y5(I),Y6(I) = ',I8,2E13.5) CALL DPWRST('XXX','BUG ') 9041 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE GEOCDF(X,P,CDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION C FUNCTION VALUE AT THE SINGLE PRECISION VALUE X C FOR THE GEOMETRIC DISTRIBUTION C WITH SINGLE PRECISION C 'BERNOULLI PROBABILITY' PARAMETER = P. C THE GEOMETRIC DISTRIBUTION USED HEREIN C HEREIN HAS MEAN = (1-P)/P C AND STANDARD DEVIATION = SQRT((1-P)/(P*P))). C THIS DISTRIBUTION IS DEFINED FOR C ALL NON-NEGATIVE INTEGER X--X = 0, 1, 2, ... . C THIS DISTRIBUTION HAS THE PROBABILITY FUNCTION C F(X) = P * (1-P)**X. C THE GEOMETRIC DISTRIBUTION IS THE C DISTRIBUTION OF THE NUMBER OF FAILURES C BEFORE OBTAINING 1 SUCCESS IN AN C INDEFINITE SEQUENCE OF BERNOULLI (0,1) C TRIALS WHERE THE PROBABILITY OF SUCCESS C IN A SINGLE TRIAL = P. C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE C AT WHICH THE CUMULATIVE DISTRIBUTION C FUNCTION IS TO BE EVALUATED. C X SHOULD BE NON-NEGATIVE AND C INTEGRAL-VALUED. C --P = THE SINGLE PRECISION VALUE C OF THE 'BERNOULLI PROBABILITY' C PARAMETER FOR THE GEOMETRIC C DISTRIBUTION. C P SHOULD BE BETWEEN C 0.0 (EXCLUSIVELY) AND C 1.0 (EXCLUSIVELY). C OUTPUT ARGUMENTS--CDF = THE SINGLE PRECISION CUMULATIVE C DISTRIBUTION FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION C FUNCTION VALUE CDF C FOR THE GEOMETRIC DISTRIBUTION C WITH 'BERNOULLI PROBABILITY' PARAMETER = P. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--X SHOULD BE NON-NEGATIVE AND INTEGRAL-VALUED. C --P SHOULD BE BETWEEN 0.0 (EXCLUSIVELY) C AND 1.0 (EXCLUSIVELY). C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN. C COMMENT--NOTE THAT EVEN THOUGH THE INPUT C TO THIS CUMULATIVE C DISTRIBUTION FUNCTION SUBROUTINE C FOR THIS DISCRETE DISTRIBUTION C SHOULD (UNDER NORMAL CIRCUMSTANCES) BE A C DISCRETE INTEGER VALUE, C THE INPUT VARIABLE X IS SINGLE C PRECISION IN MODE. C X HAS BEEN SPECIFIED AS SINGLE C PRECISION SO AS TO CONFORM WITH THE DATAPAC C CONVENTION THAT ALL INPUT ****DATA**** C (AS OPPOSED TO SAMPLE SIZE, FOR EXAMPLE) C VARIABLES TO ALL C DATAPAC SUBROUTINES ARE SINGLE PRECISION. C THIS CONVENTION IS BASED ON THE BELIEF THAT C 1) A MIXTURE OF MODES (FLOATING POINT C VERSUS INTEGER) IS INCONSISTENT AND C AN UNNECESSARY COMPLICATION C IN A DATA ANALYSIS; AND C 2) FLOATING POINT MACHINE ARITHMETIC C (AS OPPOSED TO INTEGER ARITHMETIC) C IS THE MORE NATURAL MODE FOR DOING C DATA ANALYSIS. C REFERENCES--FELLER, AN INTRODUCTION TO PROBABILITY C THEORY AND ITS APPLICATIONS, VOLUME 1, C EDITION 2, 1957, PAGES 155-157, 210. C --NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY APPLIED MATHEMATICS C SERIES 55, 1964, PAGE 929. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING LABORATORY (205.03) C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE: 301-975-2855 C ORIGINAL VERSION--APRIL 1994. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C--------------------------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(P.LE.0.0.OR.P.GE.1.0)GOTO50 IF(X.LT.0.0)GOTO55 INTX=X+0.0001 FINTX=INTX DEL=X-FINTX IF(DEL.LT.0.0)DEL=-DEL IF(DEL.GT.0.001)GOTO60 GOTO90 50 CONTINUE WRITE(ICOUT,11) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,13) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)P CALL DPWRST('XXX','BUG ') CDF=0.0 RETURN 55 CONTINUE WRITE(ICOUT,3) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') CDF=0.0 RETURN 60 CONTINUE WRITE(ICOUT,5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,6) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') 90 CONTINUE 3 FORMAT('***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT') 4 FORMAT(' TO THE GEOCDF SUBROUTINE IS NEGATIVE *****') 5 FORMAT('***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT') 6 FORMAT(' TO THE GEOCDF SUBROUTINE IS NON-INTEGRAL *****') 11 FORMAT('***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE') 12 FORMAT(' GEOCDF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1)') 13 FORMAT(' INTERVAL *****') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') C C-----START POINT----------------------------------------------------- C CDF=1.0-(1.0-P)**(FINTX+1.0) C RETURN END SUBROUTINE GE2CDF(X,P,CDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION C FUNCTION VALUE AT THE SINGLE PRECISION VALUE X C FOR THE GEOMETRIC DISTRIBUTION C WITH SINGLE PRECISION C 'BERNOULLI PROBABILITY' PARAMETER = P. C THIS USES AN ALTERNATE DEFINITION THAN GEOPDF C (THE VERSION HERE IS USED IN THE DIGITAL LIBRARY OF C MATHEMATICAL FUNCTIONS). C THE GEOMETRIC DISTRIBUTION USED HEREIN C HEREIN HAS MEAN = 1/P C AND STANDARD DEVIATION = SQRT((1-P)/(P*P))). C THIS DISTRIBUTION IS DEFINED FOR C ALL POSITIVE INTEGER X--X = 1, 2, ... . C THIS DISTRIBUTION HAS THE PROBABILITY FUNCTION C F(X) = P * (1-P)**X. C THE GEOMETRIC DISTRIBUTION IS THE C DISTRIBUTION OF THE NUMBER OF TRIALS UP TO AND C INCLUDING THE FIRST SUCCESS IN AN C INDEFINITE SEQUENCE OF BERNOULLI (0,1) C TRIALS WHERE THE PROBABILITY OF SUCCESS C IN A SINGLE TRIAL = P. C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE C AT WHICH THE CUMULATIVE DISTRIBUTION C FUNCTION IS TO BE EVALUATED. C X SHOULD BE NON-NEGATIVE AND C INTEGRAL-VALUED. C --P = THE SINGLE PRECISION VALUE C OF THE 'BERNOULLI PROBABILITY' C PARAMETER FOR THE GEOMETRIC C DISTRIBUTION. C P SHOULD BE BETWEEN C 0.0 (EXCLUSIVELY) AND C 1.0 (EXCLUSIVELY). C OUTPUT ARGUMENTS--CDF = THE SINGLE PRECISION CUMULATIVE C DISTRIBUTION FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION C FUNCTION VALUE CDF C FOR THE GEOMETRIC DISTRIBUTION C WITH 'BERNOULLI PROBABILITY' PARAMETER = P. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--X SHOULD BE NON-NEGATIVE AND INTEGRAL-VALUED. C --P SHOULD BE BETWEEN 0.0 (EXCLUSIVELY) C AND 1.0 (EXCLUSIVELY). C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN. C COMMENT--NOTE THAT EVEN THOUGH THE INPUT C TO THIS CUMULATIVE C DISTRIBUTION FUNCTION SUBROUTINE C FOR THIS DISCRETE DISTRIBUTION C SHOULD (UNDER NORMAL CIRCUMSTANCES) BE A C DISCRETE INTEGER VALUE, C THE INPUT VARIABLE X IS SINGLE C PRECISION IN MODE. C X HAS BEEN SPECIFIED AS SINGLE C PRECISION SO AS TO CONFORM WITH THE DATAPAC C CONVENTION THAT ALL INPUT ****DATA**** C (AS OPPOSED TO SAMPLE SIZE, FOR EXAMPLE) C VARIABLES TO ALL C DATAPAC SUBROUTINES ARE SINGLE PRECISION. C THIS CONVENTION IS BASED ON THE BELIEF THAT C 1) A MIXTURE OF MODES (FLOATING POINT C VERSUS INTEGER) IS INCONSISTENT AND C AN UNNECESSARY COMPLICATION C IN A DATA ANALYSIS; AND C 2) FLOATING POINT MACHINE ARITHMETIC C (AS OPPOSED TO INTEGER ARITHMETIC) C IS THE MORE NATURAL MODE FOR DOING C DATA ANALYSIS. C REFERENCES--FELLER, AN INTRODUCTION TO PROBABILITY C THEORY AND ITS APPLICATIONS, VOLUME 1, C EDITION 2, 1957, PAGES 155-157, 210. C --NATIONAL BUREAU OF STANDARDS APPLIED MATHEMATICS C SERIES 55, 1964, PAGE 929. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE: 301-975-2899 C ORIGINAL VERSION--MARCH 2004. 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 CDF=0.0 IF(P.LE.0.0.OR.P.GE.1.0)THEN WRITE(ICOUT,11) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,13) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)P CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF IF(X.LT.0.0)THEN CDF=0.0 GOTO9000 ENDIF INTX=X+0.0001 FINTX=INTX DEL=X-FINTX IF(ABS(DEL).GT.0.001)THEN WRITE(ICOUT,5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,6) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') ENDIF 5 FORMAT('***** WARNING--THE FIRST INPUT ARGUMENT TO THE GEOCDF') 6 FORMAT(' SUBROUTINE IS NON-INTEGRAL *****') 11 FORMAT('***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE') 12 FORMAT(' GEOCDF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1)') 13 FORMAT(' INTERVAL *****') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') C C-----START POINT----------------------------------------------------- C CDF=1.0-(1.0-P)**FINTX C 9000 CONTINUE RETURN END SUBROUTINE GEOMEA(X,N,IWRITE,XGEOM,IBUGA3,IERROR) C C PURPOSE--THIS SUBROUTINE COMPUTES THE C SAMPLE GEOMETRIC MEAN, XGEOM, C OF THE DATA IN THE INPUT VECTOR X. C THE SAMPLE XGEOM = (PRODUCT OF THE OBSERVATIONS)**(1/N) C = EXP((SUM OF LOG OF OBSERVATIONS)/N) C INPUT ARGUMENTS--X = THE SINGLE PRECISION VECTOR OF C (UNSORTED OR SORTED) OBSERVATIONS. C --N = THE INTEGER NUMBER OF OBSERVATIONS C IN THE VECTOR X. C OUTPUT ARGUMENTS--XGEOM = THE SINGLE PRECISION VALUE OF THE C COMPUTED SAMPLE GEOMETRIC MEAN. C OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE C SAMPLE GEOMETRIC MEAN C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--LOG, EXP. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--99.3 C ORIGINAL VERSION--MARCH 1999. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IWRITE CHARACTER*4 IBUGA3 CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C DOUBLE PRECISION DN DOUBLE PRECISION DX DOUBLE PRECISION DSUM C DIMENSION X(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='GEOM' ISUBN2='EA ' C IERROR='NO' C IF(IBUGA3.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF GEOMEA--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA3 52 FORMAT('IBUGA3 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)N 53 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') DO55I=1,N WRITE(ICOUT,56)I,X(I) 56 FORMAT('I,X(I) = ',I8,E15.7) CALL DPWRST('XXX','BUG ') 55 CONTINUE 90 CONTINUE C C ****************************** C ** COMPUTE GEOMETRIC MEAN ** C ****************************** C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C AN=N C IF(N.GE.1)GOTO119 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,111) 111 FORMAT('***** ERROR IN GEOMEA--') 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 GEOMEA IS TO BE COMPUTED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,115) 115 FORMAT(' MUST BE 1 OR LARGER.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,116) 116 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,117)N 117 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8, 1'.') CALL DPWRST('XXX','BUG ') GOTO9000 119 CONTINUE C IF(N.EQ.1)GOTO120 GOTO129 120 CONTINUE XGEOM=X(1) GOTO9000 129 CONTINUE C 190 CONTINUE C C *********************************** C ** STEP 2-- ** C ** COMPUTE THE GEOMETRIC MEAN. ** C *********************************** C DN=N DSUM=0.0D0 DO200I=1,N IF(X(I).LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,211) 211 FORMAT('***** ERROR FROM GEOMEA') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,213) 213 FORMAT(' NON-POSITIVE NUMBER ENCOUNTERED. MEAN SET ', 1 'TO ZERO.') CALL DPWRST('XXX','BUG ') IERROR='YES' XGEOM=0.0 GOTO9000 ENDIF DX=DBLE(X(I)) DSUM=DSUM+DLOG(DX) 200 CONTINUE DSUM=DSUM/DN DSUM=DEXP(DSUM) XGEOM=REAL(DSUM) C C ******************************* C ** STEP 3-- ** C ** WRITE OUT A LINE ** C ** OF SUMMARY INFORMATION. ** C ******************************* C IF(IFEEDB.EQ.'OFF')GOTO890 IF(IWRITE.EQ.'OFF')GOTO890 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,811)N,XGEOM 811 FORMAT('THE GEOMETRIC 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 GEOMEA--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGA3,IERROR 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)N 9013 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)XGEOM 9015 FORMAT('XGEOM = ',E15.7) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE GEOSD(X,N,IWRITE,XGEOSD,IBUGA3,IERROR) C C PURPOSE--THIS SUBROUTINE COMPUTES THE C SAMPLE GEOMETRIC STANDARD DEVIATION, XGEOSD, C OF THE DATA IN THE INPUT VECTOR X. C XGSD = EXP(SD(LOG(Y))) 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--XGEOSD = THE SINGLE PRECISION VALUE OF THE C COMPUTED SAMPLE GEOMETRIC STANDARD C DEVIATION. C OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE C SAMPLE GEOMETRIC STANDARD DEVIATION C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--LOG, EXP. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--99.3 C ORIGINAL VERSION--MARCH 1999. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IWRITE CHARACTER*4 IBUGA3 CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C DOUBLE PRECISION DN DOUBLE PRECISION DX DOUBLE PRECISION DSUM1 DOUBLE PRECISION DMEAN DOUBLE PRECISION DSD C DIMENSION X(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='GEOS' ISUBN2='D ' 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 GEOSD--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA3 52 FORMAT('IBUGA3 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)N 53 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') DO55I=1,N WRITE(ICOUT,56)I,X(I) 56 FORMAT('I,X(I) = ',I8,E15.7) CALL DPWRST('XXX','BUG ') 55 CONTINUE 90 CONTINUE C C ******************************************** C ** COMPUTE GEOMETRIC STANDARD DEVIATION ** C ******************************************** C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C AN=N C IF(N.GE.1)GOTO119 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,111) 111 FORMAT('***** ERROR IN GEOSD--') 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 GEOSD IS TO BE COMPUTED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,115) 115 FORMAT(' MUST BE 1 OR LARGER.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,116) 116 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,117)N 117 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8, 1'.') CALL DPWRST('XXX','BUG ') GOTO9000 119 CONTINUE C 190 CONTINUE C C ************************************************* C ** STEP 2-- ** C ** COMPUTE THE GEOMETRIC STANDARD DEVIATION. ** C ************************************************* C DN=DBLE(N) DSUM1=0.0D0 C DO200I=1,N IF(X(I).LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,211) 211 FORMAT('***** ERROR FROM GEOSD') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,213) 213 FORMAT(' NON-POSITIVE NUMBER ENCOUNTERED. SD SET ', 1 'TO ZERO.') CALL DPWRST('XXX','BUG ') IERROR='YES' XGEOSD=0.0 GOTO9000 ENDIF DX=DBLE(X(I)) DSUM1=DSUM1+DLOG(DX) 200 CONTINUE DMEAN=DSUM1/DN DSUM1=0.0D0 DO300I=1,N DX=DLOG(DBLE(X(I))) DSUM1=DSUM1 + (DX-DMEAN)**2 300 CONTINUE DSD=DSQRT(DSUM1/(DN-1.0D0)) XGEOSD= 1 REAL(DEXP(DSD)) C C ******************************* C ** STEP 3-- ** C ** WRITE OUT A LINE ** C ** OF SUMMARY INFORMATION. ** C ******************************* C IF(IFEEDB.EQ.'OFF')GOTO890 IF(IWRITE.EQ.'OFF')GOTO890 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,811)N,XGEOSD 811 FORMAT('THE GEOMETRIC STANDARD DEVIATION 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 GEOSD--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGA3,IERROR 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)N 9013 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)XGEOSD 9015 FORMAT('XGEOSD = ',E15.7) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE GEOPDF(X,P,PDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY C FUNCTION VALUE AT THE SINGLE PRECISION VALUE X C FOR THE GEOMETRIC DISTRIBUTION C WITH SINGLE PRECISION C 'BERNOULLI PROBABILITY' PARAMETER = P. C THE GEOMETRIC DISTRIBUTION USED HEREIN C HEREIN HAS MEAN = (1-P)/P C AND STANDARD DEVIATION = SQRT((1-P)/(P*P))). C THIS DISTRIBUTION IS DEFINED FOR C ALL NON-NEGATIVE INTEGER X--X = 0, 1, 2, ... . C THIS DISTRIBUTION HAS THE PROBABILITY FUNCTION C F(X) = P * (1-P)**X. C THE GEOMETRIC DISTRIBUTION IS THE C DISTRIBUTION OF THE NUMBER OF FAILURES C BEFORE OBTAINING 1 SUCCESS IN AN C INDEFINITE SEQUENCE OF BERNOULLI (0,1) C TRIALS WHERE THE PROBABILITY OF SUCCESS C IN A SINGLE TRIAL = P. C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE C AT WHICH THE PROBABILITY DENSITY C FUNCTION IS TO BE EVALUATED. C X SHOULD BE NON-NEGATIVE AND C INTEGRAL-VALUED. C --P = THE SINGLE PRECISION VALUE C OF THE 'BERNOULLI PROBABILITY' C PARAMETER FOR THE GEOMETRIC C DISTRIBUTION. C P SHOULD BE BETWEEN C 0.0 (EXCLUSIVELY) AND C 1.0 (EXCLUSIVELY). C OUTPUT ARGUMENTS--PDF = THE SINGLE PRECISION PROBABILITY C DENSITY FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY C FUNCTION VALUE PDF C FOR THE GEOMETRIC DISTRIBUTION C WITH 'BERNOULLI PROBABILITY' PARAMETER = P. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--X SHOULD BE NON-NEGATIVE AND INTEGRAL-VALUED. C --P SHOULD BE BETWEEN 0.0 (EXCLUSIVELY) C AND 1.0 (EXCLUSIVELY). C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN. C COMMENT--NOTE THAT EVEN THOUGH THE INPUT C TO THIS PROBABILITY DENSITY FUNCTION SUBROUTINE C FOR THIS DISCRETE DISTRIBUTION C SHOULD (UNDER NORMAL CIRCUMSTANCES) BE A C DISCRETE INTEGER VALUE, C THE INPUT VARIABLE X IS SINGLE C PRECISION IN MODE. C X HAS BEEN SPECIFIED AS SINGLE C PRECISION SO AS TO CONFORM WITH THE DATAPAC C CONVENTION THAT ALL INPUT ****DATA**** C (AS OPPOSED TO SAMPLE SIZE, FOR EXAMPLE) C VARIABLES TO ALL C DATAPAC SUBROUTINES ARE SINGLE PRECISION. C THIS CONVENTION IS BASED ON THE BELIEF THAT C 1) A MIXTURE OF MODES (FLOATING POINT C VERSUS INTEGER) IS INCONSISTENT AND C AN UNNECESSARY COMPLICATION C IN A DATA ANALYSIS; AND C 2) FLOATING POINT MACHINE ARITHMETIC C (AS OPPOSED TO INTEGER ARITHMETIC) C IS THE MORE NATURAL MODE FOR DOING C DATA ANALYSIS. C REFERENCES--FELLER, AN INTRODUCTION TO PROBABILITY C THEORY AND ITS APPLICATIONS, VOLUME 1, C EDITION 2, 1957, PAGES 155-157, 210. C --NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY APPLIED MATHEMATICS C SERIES 55, 1964, PAGE 929. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING LABORATORY (205.03) C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE: 301-975-2855 C ORIGINAL VERSION--APRIL 1994. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C--------------------------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C PDF=0.0 IF(P.LE.0.0.OR.P.GE.1.0)THEN WRITE(ICOUT,11) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,13) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)P CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF IF(X.LT.0.0)THEN WRITE(ICOUT,3) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9000 ENDIF INTX=X+0.0001 FINTX=INTX DEL=X-FINTX IF(ABS(DEL).GT.0.001)THEN WRITE(ICOUT,5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,6) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') ENDIF 3 FORMAT('***** WARNING--THE FIRST INPUT ARGUMENT TO THE GEOPDF') 4 FORMAT(' SUBROUTINE IS NEGATIVE *****') 5 FORMAT('***** WARNING--THE FIRST INPUT ARGUMENT TO THE GEOPDF') 6 FORMAT(' SUBROUTINE IS NON-INTEGRAL *****') 11 FORMAT('***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE') 12 FORMAT(' GEOPDF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1)') 13 FORMAT(' INTERVAL *****') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') C C-----START POINT----------------------------------------------------- C TERM1=LOG(P) + FINTX*LOG(1.0-P) PDF=EXP(TERM1) C 9000 CONTINUE RETURN END SUBROUTINE GE2PDF(X,P,PDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY C FUNCTION VALUE AT THE SINGLE PRECISION VALUE X C FOR THE GEOMETRIC DISTRIBUTION C WITH SINGLE PRECISION C 'BERNOULLI PROBABILITY' PARAMETER = P. C THIS USES AN ALTERNATE DEFINITION THAN GEOPDF C (THE VERSION HERE IS USED IN THE DIGITAL LIBRARY OF C MATHEMATICAL FUNCTIONS). C THE GEOMETRIC DISTRIBUTION USED HEREIN C HEREIN HAS MEAN = 1/P C AND STANDARD DEVIATION = SQRT((1-P)/(P*P))). C THIS DISTRIBUTION IS DEFINED FOR C ALL POSITIVE INTEGER X--X = 1, 2, ... . C THIS DISTRIBUTION HAS THE PROBABILITY FUNCTION C F(X) = P * (1-P)**(X-1). C THE GEOMETRIC DISTRIBUTION IS THE C DISTRIBUTION OF THE NUMBER OF TRIALS UP TO AND C INCLUDING THE FIRST SUCCESS IN AN C INDEFINITE SEQUENCE OF BERNOULLI (0,1) C TRIALS WHERE THE PROBABILITY OF SUCCESS C IN A SINGLE TRIAL = P. C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE C AT WHICH THE PROBABILITY DENSITY C FUNCTION IS TO BE EVALUATED. C X SHOULD BE NON-NEGATIVE AND C INTEGRAL-VALUED. C --P = THE SINGLE PRECISION VALUE C OF THE 'BERNOULLI PROBABILITY' C PARAMETER FOR THE GEOMETRIC C DISTRIBUTION. C P SHOULD BE BETWEEN C 0.0 (EXCLUSIVELY) AND C 1.0 (EXCLUSIVELY). C OUTPUT ARGUMENTS--PDF = THE SINGLE PRECISION PROBABILITY C DENSITY FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY C FUNCTION VALUE PDF C FOR THE GEOMETRIC DISTRIBUTION C WITH 'BERNOULLI PROBABILITY' PARAMETER = P. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--X SHOULD BE NON-NEGATIVE AND INTEGRAL-VALUED. C --P SHOULD BE BETWEEN 0.0 (EXCLUSIVELY) C AND 1.0 (EXCLUSIVELY). C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN. C COMMENT--NOTE THAT EVEN THOUGH THE INPUT C TO THIS PROBABILITY DENSITY FUNCTION SUBROUTINE C FOR THIS DISCRETE DISTRIBUTION C SHOULD (UNDER NORMAL CIRCUMSTANCES) BE A C DISCRETE INTEGER VALUE, C THE INPUT VARIABLE X IS SINGLE C PRECISION IN MODE. C X HAS BEEN SPECIFIED AS SINGLE C PRECISION SO AS TO CONFORM WITH THE DATAPAC C CONVENTION THAT ALL INPUT ****DATA**** C (AS OPPOSED TO SAMPLE SIZE, FOR EXAMPLE) C VARIABLES TO ALL C DATAPAC SUBROUTINES ARE SINGLE PRECISION. C THIS CONVENTION IS BASED ON THE BELIEF THAT C 1) A MIXTURE OF MODES (FLOATING POINT C VERSUS INTEGER) IS INCONSISTENT AND C AN UNNECESSARY COMPLICATION C IN A DATA ANALYSIS; AND C 2) FLOATING POINT MACHINE ARITHMETIC C (AS OPPOSED TO INTEGER ARITHMETIC) C IS THE MORE NATURAL MODE FOR DOING C DATA ANALYSIS. C REFERENCES--FELLER, AN INTRODUCTION TO PROBABILITY C THEORY AND ITS APPLICATIONS, VOLUME 1, C EDITION 2, 1957, PAGES 155-157, 210. C --NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY APPLIED MATHEMATICS C SERIES 55, 1964, PAGE 929. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION (205.03) C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE: 301-975-2855 C ORIGINAL VERSION--MARCH 2004. 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 PDF=0.0 IF(P.LE.0.0.OR.P.GE.1.0)THEN WRITE(ICOUT,11) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,13) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)P CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF IF(X.LT.1.0)THEN WRITE(ICOUT,3) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9000 ENDIF INTX=X+0.0001 FINTX=INTX DEL=X-FINTX IF(ABS(DEL).GT.0.001)THEN WRITE(ICOUT,5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,6) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') ENDIF 3 FORMAT('***** WARNING--THE FIRST INPUT ARGUMENT TO THE GEOPDF') 4 FORMAT(' SUBROUTINE IS NEGATIVE *****') 5 FORMAT('***** WARNING--THE FIRST INPUT ARGUMENT TO THE GEOPDF') 6 FORMAT(' SUBROUTINE IS NON-INTEGRAL *****') 11 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO THE') 12 FORMAT(' GEOPDF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1)') 13 FORMAT(' INTERVAL *****') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') C C-----START POINT----------------------------------------------------- C TERM1=LOG(P) + (FINTX-1.0)*LOG(1.0-P) PDF=EXP(TERM1) C 9000 CONTINUE RETURN END SUBROUTINE GEOPPF(P,PPAR,PPF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT C FUNCTION VALUE FOR THE GEOMETRIC C DISTRIBUTION WITH SINGLE PRECISION C 'BERNOULLI PROBABILITY' PARAMETER = PPAR. C THE GEOMETRIC DISTRIBUTION USED C HEREIN HAS MEAN = (1-PPAR)/PPAR C AND STANDARD DEVIATION = SQRT((1-PPAR)/(PPAR*PPAR))). C THIS DISTRIBUTION IS DEFINED FOR C ALL NON-NEGATIVE INTEGER X--X = 0, 1, 2, ... . C THIS DISTRIBUTION HAS THE PROBABILITY FUNCTION C F(X) = PPAR * (1-PPAR)**X. C THE GEOMETRIC DISTRIBUTION IS THE C DISTRIBUTION OF THE NUMBER OF FAILURES C BEFORE OBTAINING 1 SUCCESS IN AN C INDEFINITE SEQUENCE OF BERNOULLI (0,1) C TRIALS WHERE THE PROBABILITY OF SUCCESS C IN A SINGLE TRIAL = PPAR. C NOTE THAT THE PERCENT POINT FUNCTION OF A DISTRIBUTION C IS IDENTICALLY THE SAME AS THE INVERSE CUMULATIVE C DISTRIBUTION FUNCTION OF THE DISTRIBUTION. C INPUT ARGUMENTS--P = THE SINGLE PRECISION VALUE C (BETWEEN 0.0 (INCLUSIVELY) C AND 1.0 (EXCLUSIVELY)) C AT WHICH THE PERCENT POINT C FUNCTION IS TO BE EVALUATED. C --PPAR = THE SINGLE PRECISION VALUE C OF THE 'BERNOULLI PROBABILITY' C PARAMETER FOR THE GEOMETRIC C DISTRIBUTION. C PPAR SHOULD BE BETWEEN C 0.0 (EXCLUSIVELY) AND C 1.0 (EXCLUSIVELY). 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 GEOMETRIC DISTRIBUTION C WITH 'BERNOULLI PROBABILITY' PARAMETER VALUE = PPAR. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--PPAR SHOULD BE BETWEEN 0.0 (EXCLUSIVELY) C AND 1.0 (EXCLUSIVELY). C --P SHOULD BE BETWEEN 0.0 (INCLUSIVELY) C AND 1.0 (EXCLUSIVELY). C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--ALOG. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C COMMENT--NOTE THAT EVEN THOUGH THE OUTPUT C FROM THIS DISCRETE DISTRIBUTION C PERCENT POINT FUNCTION C SUBROUTINE MUST NECESSARILY BE A C DISCRETE INTEGER VALUE, C THE OUTPUT VARIABLE PPF IS SINGLE C PRECISION IN MODE. C PPF HAS BEEN SPECIFIED AS SINGLE C PRECISION SO AS TO CONFORM WITH THE DATAPAC C CONVENTION THAT ALL OUTPUT VARIABLES FROM ALL C DATAPAC SUBROUTINES ARE SINGLE PRECISION. C THIS CONVENTION IS BASED ON THE BELIEF THAT C 1) A MIXTURE OF MODES (FLOATING POINT C VERSUS INTEGER) IS INCONSISTENT AND C AN UNNECESSARY COMPLICATION C IN A DATA ANALYSIS; AND C 2) FLOATING POINT MACHINE ARITHMETIC C (AS OPPOSED TO INTEGER ARITHMETIC) C IS THE MORE NATURAL MODE FOR DOING C DATA ANALYSIS. C REFERENCES--FELLER, AN INTRODUCTION TO PROBABILITY C THEORY AND ITS APPLICATIONS, VOLUME 1, C EDITION 2, 1957, PAGES 155-157, 210. C --NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY APPLIED MATHEMATICS C SERIES 55, 1964, PAGE 929. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-921-3651 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C 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/7 C ORIGINAL VERSION--NOVEMBER 1975. C UPDATED --DECEMBER 1981. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(P.LT.0.0.OR.P.GE.1.0)GOTO50 IF(PPAR.LE.0.0.OR.PPAR.GE.1.0)GOTO55 GOTO90 50 WRITE(ICOUT,1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)P CALL DPWRST('XXX','BUG ') PPF=0.0 RETURN 55 WRITE(ICOUT,11) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)PPAR CALL DPWRST('XXX','BUG ') PPF=0.0 RETURN 90 CONTINUE 1 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ', 1'GEOPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL') 11 FORMAT('***** FATAL ERROR--THE 2ND INPUT ARGUMENT TO THE ', 1'GEOPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') C IF(P.NE.0.0)GOTO150 PPF=0.0 RETURN 150 CONTINUE C ARG1=1.0-P ARG2=1.0-PPAR ANUM=ALOG(ARG1) ADEN=ALOG(ARG2) RATIO=ANUM/ADEN IRATIO=RATIO PPF=IRATIO ARATIO=IRATIO IF(ARATIO.EQ.RATIO)PPF=IRATIO-1 RETURN C END SUBROUTINE GEORAN(N,P,ISEED,X) C C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N C FROM THE GEOMETRIC DISTRIBUTION C WITH SINGLE PRECISION 'BERNOULLI PROBABILITY' C PARAMETER = P. C THE GEOMETRIC DISTRIBUTION USED C HEREIN HAS MEAN = (1-P)/P C AND STANDARD DEVIATION = SQRT((1-P)/(P*P))). C THIS DISTRIBUTION IS DEFINED FOR C ALL NON-NEGATIVE INTEGER X--X = 0, 1, 2, ... . C THIS DISTRIBUTION HAS THE PROBABILITY FUNCTION C F(X) = P * (1-P)**X. C THE GEOMETRIC DISTRIBUTION IS THE C DISTRIBUTION OF THE NUMBER OF FAILURES C BEFORE OBTAINING 1 SUCCESS IN AN C INDEFINITE SEQUENCE OF BERNOULLI (0,1) C TRIALS WHERE THE PROBABILITY OF SUCCESS C IN A SINGLE TRIAL = P. C INPUT ARGUMENTS--N = THE DESIRED INTEGER NUMBER C OF RANDOM NUMBERS TO BE C GENERATED. C --P = THE SINGLE PRECISION VALUE C OF THE 'BERNOULLI PROBABILITY' C PARAMETER FOR THE GEOMETRIC C DISTRIBUTION. C P SHOULD BE BETWEEN C 0.0 (EXCLUSIVELY) AND C 1.0 (EXCLUSIVELY). 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 GEOMETRIC DISTRIBUTION C WITH 'BERNOULLI PROBABILITY' PARAMETER = P. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C --P SHOULD BE BETWEEN 0.0 (EXCLUSIVELY) C AND 1.0 (EXCLUSIVELY). C OTHER DATAPAC SUBROUTINES NEEDED--UNIRAN. C FORTRAN LIBRARY SUBROUTINES NEEDED--ALOG. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C COMMENT--NOTE THAT EVEN THOUGH THE OUTPUT C FROM THIS DISCRETE RANDOM NUMBER C GENERATOR MUST NECESSARILY BE A C SEQUENCE OF ***INTEGER*** VALUES, C THE OUTPUT VECTOR X IS SINGLE C PRECISION IN MODE. C X HAS BEEN SPECIFIED AS SINGLE C PRECISION SO AS TO CONFORM WITH THE DATAPAC C CONVENTION THAT ALL OUTPUT VECTORS FROM ALL C DATAPAC SUBROUTINES ARE SINGLE PRECISION. C THIS CONVENTION IS BASED ON THE BELIEF THAT C 1) A MIXTURE OF MODES (FLOATING POINT C VERSUS INTEGER) IS INCONSISTENT AND C AN UNNECESSARY COMPLICATION C IN A DATA ANALYSIS; AND C 2) FLOATING POINT MACHINE ARITHMETIC C (AS OPPOSED TO INTEGER ARITHMETIC) C IS THE MORE NATURAL MODE FOR DOING C DATA ANALYSIS. C REFERENCES--TOCHER, THE ART OF SIMULATION, C 1963, PAGES 14-15. C --HAMMERSLEY AND HANDSCOMB, MONTE CARLO METHODS, C 1964, PAGE 36. C --FELLER, AN INTRODUCTION TO PROBABILITY C THEORY AND ITS APPLICATIONS, VOLUME 1, C EDITION 2, 1957, PAGES 155-157, 210. C --NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY APPLIED MATHEMATICS C SERIES 55, 1964, PAGE 929. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-921-3651 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C 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/7 C ORIGINAL VERSION--NOVEMBER 1975. C UPDATED --DECEMBER 1981. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DIMENSION X(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(N.LT.1)THEN WRITE(ICOUT, 5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)N CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF IF(P.LE.0.0.OR.P.GE.1.0)THEN WRITE(ICOUT,11) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,11) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)P CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF 5 FORMAT('***** ERROR--THE REQUESTED NUMBER OF GEOMETRIC ', 1'RANDOM NUMBERS IS NON-POSITIVE.') 11 FORMAT('***** ERROR--THE PROBABILITY OF SUCCESS PARAMETER ', 1'FOR THE GEOMETRIC DISTRIBUTION') 12 FORMAT(' IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8) 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8) C C GENERATE N UNIFORM (0,1) RANDOM NUMBERS; C CALL UNIRAN(N,ISEED,X) C C GENERATE N GEOMETRIC RANDOM NUMBERS C USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD. C DO100I=1,N IF(X(I).EQ.0.0)GOTO100 ARG1=1.0-X(I) ARG2=1.0-P ANUM=ALOG(ARG1) ADEN=ALOG(ARG2) RATIO=ANUM/ADEN IRATIO=RATIO X(I)=IRATIO ARATIO=IRATIO IF(ARATIO.EQ.RATIO)X(I)=IRATIO-1 100 CONTINUE C 9000 CONTINUE RETURN END SUBROUTINE GE2RAN(N,P,ISEED,X) C C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N C FROM THE GEOMETRIC DISTRIBUTION C WITH SINGLE PRECISION 'BERNOULLI PROBABILITY' C PARAMETER = P. C THIS USES AN ALTERNATE DEFINITION THAN GEOPDF C (THE VERSION HERE IS USED IN THE DIGITAL LIBRARY OF C MATHEMATICAL FUNCTIONS). C THE GEOMETRIC DISTRIBUTION USED HEREIN C HEREIN HAS MEAN = 1/P C AND STANDARD DEVIATION = SQRT((1-P)/(P*P))). C THIS DISTRIBUTION IS DEFINED FOR C ALL POSITIVE INTEGER X--X = 1, 2, ... . C THIS DISTRIBUTION HAS THE PROBABILITY FUNCTION C F(X) = P * (1-P)**(X-1). C NOTE THAT THIS ALTERNATE DEFINITION IS ESENTIALLY C THE DEFAULT DEFINITION SHIFTED 1 TO THE RIGHT. C SO FOR RANDOM NUMBERS, JUST USE THE ALGORITHM FOR C THE DEFAULT DEFINITION AND ADD 1. C INPUT ARGUMENTS--N = THE DESIRED INTEGER NUMBER C OF RANDOM NUMBERS TO BE C GENERATED. C --P = THE SINGLE PRECISION VALUE C OF THE 'BERNOULLI PROBABILITY' C PARAMETER FOR THE GEOMETRIC C DISTRIBUTION. C P SHOULD BE BETWEEN C 0.0 (EXCLUSIVELY) AND C 1.0 (EXCLUSIVELY). 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 GEOMETRIC DISTRIBUTION C WITH 'BERNOULLI PROBABILITY' PARAMETER = P. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C --P SHOULD BE BETWEEN 0.0 (EXCLUSIVELY) C AND 1.0 (EXCLUSIVELY). C OTHER DATAPAC SUBROUTINES NEEDED--UNIRAN. C FORTRAN LIBRARY SUBROUTINES NEEDED--ALOG. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C COMMENT--NOTE THAT EVEN THOUGH THE OUTPUT C FROM THIS DISCRETE RANDOM NUMBER C GENERATOR MUST NECESSARILY BE A C SEQUENCE OF ***INTEGER*** VALUES, C THE OUTPUT VECTOR X IS SINGLE C PRECISION IN MODE. C X HAS BEEN SPECIFIED AS SINGLE C PRECISION SO AS TO CONFORM WITH THE DATAPAC C CONVENTION THAT ALL OUTPUT VECTORS FROM ALL C DATAPAC SUBROUTINES ARE SINGLE PRECISION. C THIS CONVENTION IS BASED ON THE BELIEF THAT C 1) A MIXTURE OF MODES (FLOATING POINT C VERSUS INTEGER) IS INCONSISTENT AND C AN UNNECESSARY COMPLICATION C IN A DATA ANALYSIS; AND C 2) FLOATING POINT MACHINE ARITHMETIC C (AS OPPOSED TO INTEGER ARITHMETIC) C IS THE MORE NATURAL MODE FOR DOING C DATA ANALYSIS. C REFERENCES--TOCHER, THE ART OF SIMULATION, C 1963, PAGES 14-15. C --HAMMERSLEY AND HANDSCOMB, MONTE CARLO METHODS, C 1964, PAGE 36. C --FELLER, AN INTRODUCTION TO PROBABILITY C THEORY AND ITS APPLICATIONS, VOLUME 1, C EDITION 2, 1957, PAGES 155-157, 210. C --NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY APPLIED MATHEMATICS C SERIES 55, 1964, PAGE 929. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-921-3651 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C 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/7 C ORIGINAL VERSION--NOVEMBER 1975. C UPDATED --DECEMBER 1981. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DIMENSION X(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(N.LT.1)THEN WRITE(ICOUT, 5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)N CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF IF(P.LE.0.0.OR.P.GE.1.0)THEN WRITE(ICOUT,11) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,11) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)P CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF 5 FORMAT('***** ERROR--THE REQUESTED NUMBER OF GEOMETRIC ', 1'RANDOM NUMBERS IS NON-POSITIVE.') 11 FORMAT('***** ERROR--THE PROBABILITY OF SUCCESS PARAMETER ', 1'FOR THE GEOMETRIC DISTRIBUTION') 12 FORMAT(' IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8) 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8) C C GENERATE N UNIFORM (0,1) RANDOM NUMBERS; C CALL UNIRAN(N,ISEED,X) C C GENERATE N GEOMETRIC RANDOM NUMBERS C USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD. C DO100I=1,N IF(X(I).EQ.0.0)GOTO100 ARG1=1.0-X(I) ARG2=1.0-P ANUM=ALOG(ARG1) ADEN=ALOG(ARG2) RATIO=ANUM/ADEN IRATIO=RATIO X(I)=IRATIO ARATIO=IRATIO IF(ARATIO.EQ.RATIO)X(I)=IRATIO-1 X(I)=X(I)+1 100 CONTINUE C 9000 CONTINUE RETURN END SUBROUTINE GEPCDF(X,GAMMA,MINMAX,IGEPDF,CDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION C FUNCTION VALUE FOR THE GENERALIZED PARETO C DISTRIBUTION WITH SINGLE PRECISION C SHAPE LENGTH PARAMETER = GAMMA. C THE GENERALIZED PARETO DISTRIBUTION USED C HEREIN IS DEFINED FOR ALL POSITIVE X, C AND HAS THE CUMULATIVE DISTRIBUTION FUNCTION C F(X) = 1 - [1+GAMMA*X]**(-1/GAMMA) C JOHNSON, KOTZ, AND BALAKRISHNAN REVERSE THE SIGN OF C THE SHAPE PARAMETER TO YIELD: C F(X) = 1 - [1-GAMMA*X]**(1/GAMMA) C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE C AT WHICH THE CUMULATIVE DISTRIBUTION C FUNCTION IS TO BE EVALUATED. C --GAMMA = THE SINGLE PRECISION VALUE C OF THE TAIL LENGTH PARAMETER. C GAMMA CAN BE NEATIVE, 0, OR POSITIVE. C --MINMAX = INTEGER VALUE, CURRENTLY NOT USED. C OUTPUT ARGUMENTS--CDF = THE SINGLE PRECISION CUMULATIVE C DISTRIBUTION FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION FUNCTION . C VALUE CDF FOR THE GENERALIZED PARETO DISTRIBUTION C WITH TAIL LENGTH PARAMETER VALUE = GAMMA. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--GAMMA SHOULD BE POSITIVE. C --X SHOULD BE POSITIVE C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTIUOUS UNIVARIATE C DISTRIBUTIONS--VOLUME 1", SECOND EDITION, PP. 614-620. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C VERSION NUMBER--93/12 C ORIGINAL VERSION--DECEMBER 1993. C UPDATED --DECEMBER 1994 CHECK FOR NEGATIVE X C UPDATED --JANUARY 1995 CHECK FOR OUT OF RANGE X C UPDATED --JUNE 2004 ALTERNATE DEFINITION FOR C GENERAPLIZED PARETO (USES C DIFFERENT SIGN) C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C C--------------------------------------------------------------------- C CHARACTER*4 IGEPDF C DOUBLE PRECISION DX DOUBLE PRECISION DG DOUBLE PRECISION DCDF C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(X.LT.0.0)THEN WRITE(ICOUT,1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9000 ELSEIF(X.EQ.0.0)THEN CDF=0.0 GOTO9000 ENDIF C IF(IGEPDF.EQ.'JOHN')THEN IF(GAMMA.GT.0.0)THEN TEMP=1.0/GAMMA IF(X.GE.TEMP)THEN WRITE(ICOUT,3) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9000 ENDIF ENDIF ELSE IF(GAMMA.LT.0.0)THEN TEMP=-1.0/GAMMA IF(X.GE.TEMP)THEN WRITE(ICOUT,2) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9000 ENDIF ENDIF ENDIF C 1 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO GEPCDF IS ', 1 'NON-POSITIVE.') 2 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO GEPCDF IS ', 1 '>= -1/GAMMA FOR NEGATIVE GAMMA') 3 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO GEPCDF IS ', 1 '>= 1/GAMMA FOR POSITIVE GAMMA') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7) C C COMPUTE THE CDF VALUE C DX=DBLE(X) DG=DBLE(GAMMA) C IF(GAMMA.EQ.0.0)THEN DCDF=1.0D0-DEXP(-DX) IF(DCDF.LT.0.0D0)DCDF=0.0D0 ELSE IF(IGEPDF.EQ.'JOHN')THEN DCDF=1.0D0-((1.0D0-DG*DX)**(1.0D0/DG)) ELSE DCDF=1.0D0-((1.0D0+DG*DX)**(-1.0D0/DG)) ENDIF ENDIF CDF=REAL(DCDF) C 9000 CONTINUE RETURN END SUBROUTINE GEPCHA(X,GAMMA,MINMAX,IGEPDF,HAZ) C C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE HAZARD C FUNCTION VALUE FOR THE GENERALIZED PARETO C DENSITY WITH SINGLE PRECISION C SHAPE LENGTH PARAMETER = GAMMA. C THE GENERALIZED PARETO DENSITY USED C HEREIN IS DEFINED FOR ALL POSITIVE X, C AND HAS THE CUMULATIVE HAZARD FUNCTION C H(X) = -LOG[(1-GAMMA*X)**(1/GAMMA)] C JOHNSON, KOTZ, AND BALAKRISHNANA REVERSE THE SIGN OF THE C SHAPE PARAMETER: C H(X) = -LOG[(1+GAMMA*X)**(-1/GAMMA)] C INPUT ARGUMENTS--X = THE SINGLE PRECISION POSITIVE VALUE AT C WHICH THE HAZARD FUNCTION IS TO BE C EVALUATED. C --GAMMA = THE SINGLE PRECISION VALUE C OF THE TAIL LENGTH PARAMETER. C GAMMA CAN BE NEG., 0, OR POS. C --MINMAX = THE INTEGER VALUE, NOT CURRENTLY USED C --IGEPDF = CHARACTER VALUE SPECIFYING WHETHER C EMIL SIMIU OR JOHNSON AND KOTZ DEFINITION C SHOULD BE USED. C OUTPUT ARGUMENTS--HAZ = THE SINGLE PRECISION C CUMULATIVE HAZARD FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION CUMULATIVE HAZARD FUNCTION . C VALUE HAZ FOR THE GENERALIZED PARETO DENSITY C WITH TAIL LENGTH PARAMETER VALUE = GAMMA. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--GAMMA MAY BE NEGATIVE, 0, OR POSITIVE C --X SHOULD BE POSITIVE C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--ALOG. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTIUOUS UNIVARIATE C DISTRIBUTIONS--VOLUME 1", SECOND EDITION, PP. 614-620. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C VERSION NUMBER--98/4 C ORIGINAL VERSION--APRIL 1998. C UPDATED --JUNE 2004 ALTERNATE DEFINITION FOR C GENERAPLIZED PARETO (USES C DIFFERENT SIGN) C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C INCLUDE 'DPCOMC.INC' C C--------------------------------------------------------------------- C CHARACTER*4 IGEPDF C DOUBLE PRECISION DX DOUBLE PRECISION DG DOUBLE PRECISION DHAZ C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT 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(X.LE.0.0)THEN WRITE(ICOUT,1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') HAZ=0.0 GOTO9000 ENDIF C IF(IGEPDF.EQ.'JOHN')THEN IF(GAMMA.GT.0.0)THEN TEMP=1.0/GAMMA IF(X.GE.TEMP)THEN WRITE(ICOUT,3) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') HAZ=0.0 GOTO9000 ENDIF ENDIF ELSE IF(GAMMA.LT.0.0)THEN TEMP=-1.0/GAMMA IF(X.GE.TEMP)THEN WRITE(ICOUT,2) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') HAZ=0.0 GOTO9000 ENDIF ENDIF ENDIF C 1 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO GEPCHAZ IS ', 1 'NON-POSITIVE.') 2 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO GEPCHAZ IS ', 1 '>= -1/GAMMA FOR NEGATIVE GAMMA') 3 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO GEPCHAZ IS ', 1 '>= 1/GAMMA FOR POSITIVE GAMMA') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7) C C COMPUTE THE HAZ VALUE C DX=DBLE(X) DG=DBLE(GAMMA) C IF(GAMMA.EQ.0.0)THEN DHAZ=DX ELSE IF(IGEPDF.EQ.'JOHN')THEN DHAZ=-DLOG((1.0D0-DG*DX)**(1.0D0/DG)) ELSE DHAZ=-DLOG((1.0D0+DG*DX)**(-1.0D0/DG)) ENDIF ENDIF HAZ=REAL(DHAZ) C 9000 CONTINUE RETURN END SUBROUTINE GEPHAZ(X,GAMMA,MINMAX,IGEPDF,HAZ) C C PURPOSE--THIS SUBROUTINE COMPUTES THE HAZARD C FUNCTION VALUE FOR THE GENERALIZED PARETO C DENSITY WITH SINGLE PRECISION C SHAPE LENGTH PARAMETER = GAMMA. C THE GENERALIZED PARETO DENSITY USED C HEREIN IS DEFINED FOR ALL POSITIVE X, C AND HAS THE HAZARD FUNCTION C H(X) = 1/(1+GAMMA*X) C JOHNSON, KOTZ, AND BALARKRISHNAN REVERSE THE SIGN: C H(X) = 1/(1-GAMMA*X) C INPUT ARGUMENTS--X = THE SINGLE PRECISION POSITIVE VALUE C AT WHICH THE HAZARD C FUNCTION IS TO BE EVALUATED. C --GAMMA = THE SINGLE PRECISION VALUE C OF THE TAIL LENGTH PARAMETER. C GAMMA CAN BE NEG., 0, OR POS. C --MINMAX = THE INTEGER VALUE, NOT CURRENTLY USED C --IGEPDF = CHARACTER VALUE SPECIFYING WHETHER C EMIL SIMIU OR JOHNSON AND KOTZ DEFINITION C SHOULD BE USED. C OUTPUT ARGUMENTS--HAZ = THE SINGLE PRECISION C HAZARD FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION HAZARD FUNCTION . C VALUE HAZ FOR THE GENERALIZED PARETO DENSITY C WITH TAIL LENGTH PARAMETER VALUE = GAMMA. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--GAMMA MAY BE NEGATIVE, 0, OR POSITIVE C --X SHOULD BE POSITIVE C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTIUOUS UNIVARIATE C DISTRIBUTIONS--VOLUME 1", SECOND EDITION, PP. 614-620. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C VERSION NUMBER--98/4 C ORIGINAL VERSION--APRIL 1998. C UPDATED --JUNE 2004 ALTERNATE DEFINITION FOR C GENERAPLIZED PARETO (USES C DIFFERENT SIGN) C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C C--------------------------------------------------------------------- C CHARACTER*4 IGEPDF C DOUBLE PRECISION DX DOUBLE PRECISION DG DOUBLE PRECISION DHAZ C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT 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(X.LE.0.0)THEN WRITE(ICOUT,1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') HAZ=0.0 GOTO9000 ENDIF C IF(IGEPDF.EQ.'JOHN')THEN IF(GAMMA.GT.0.0)THEN TEMP=1.0/GAMMA IF(X.GE.TEMP)THEN WRITE(ICOUT,3) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') HAZ=0.0 GOTO9000 ENDIF ENDIF ELSE IF(GAMMA.LT.0.0)THEN TEMP=-1.0/GAMMA IF(X.GE.TEMP)THEN WRITE(ICOUT,2) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') HAZ=0.0 GOTO9000 ENDIF ENDIF ENDIF C 1 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO GEPHAZ IS ', 1 'NON-POSITIVE.') 2 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO GEPHAZ IS ', 1 '>= -1/GAMMA FOR NEGATIVE GAMMA') 3 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO GEPHAZ IS ', 1 '>= 1/GAMMA FOR POSITIVE GAMMA') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7) C C COMPUTE THE HAZ VALUE C DX=DBLE(X) DG=DBLE(GAMMA) IF(GAMMA.EQ.0.0)THEN DHAZ=1.0D0 ELSE IF(IGEPDF.EQ.'JOHN')THEN DHAZ=1.0D0/(1.0D0 - DG*DX) ELSE DHAZ=1.0D0/(1.0D0 + DG*DX) ENDIF ENDIF HAZ=DHAZ C 9000 CONTINUE RETURN END SUBROUTINE GEPPDF(X,GAMMA,MINMAX,IGEPDF,PDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY C FUNCTION VALUE FOR THE GENERALIZED PARETO C DENSITY WITH SINGLE PRECISION C SHAPE LENGTH PARAMETER = GAMMA. C THE GENERALIZED PARETO DENSITY USED C HEREIN IS DEFINED FOR ALL POSITIVE X, C AND HAS THE PROBABILITY DENSITY FUNCTION C F(X) = (1+GAMMA*X)**(-(1/GAMMA)-1) C JOHNSON AND KOTZ USE THE PARAMETERIZATION GAMMA=-GAMMA: C F(X) = (1-GAMMA*X)**((1/GAMMA)-1) C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE C (BETWEEN ... C AND ... (EXCLUSIVELY)) C AT WHICH THE PROBABILITY DENSITY C FUNCTION IS TO BE EVALUATED. C --GAMMA = THE SINGLE PRECISION VALUE C OF THE TAIL LENGTH PARAMETER. C GAMMA CAN BE NEGATIVE 0, OR POSITIVE. C --MINMAX = INTEGER VALUE, CURRENTLY NOT USED C --IGEPDF = CHARACTER VALUE SPECIFYING WHETHER C EMIL SIMIU OR JOHNSON AND KOTZ DEFINITION C SHOULD BE USED. C OUTPUT ARGUMENTS--PDF = THE SINGLE PRECISION PROBABILITY C DENSITY FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY FUNCTION . C VALUE PDF FOR THE GENERALIZED PARETO DENSITY C WITH TAIL LENGTH PARAMETER VALUE = GAMMA. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--GAMMA MAY BE NEGATIVE, 0, OR POSITIVE C --X SHOULD BE BETWEEN 0 (EXCLUSIVELY) C AND INFINITY OR (1/-GAMMA) (EXCLUSIVELY). C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTIUOUS UNIVARIATE C DISTRIBUTIONS--VOLUME 1", SECOND EDITION, PP. 614-620. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--93/12 C ORIGINAL VERSION--DECEMBER 1993. C UPDATED --DECEMBER 1994 CHECK FOR NEGATIVE X C UPDATED --JANUARY 1995 CHECK FOR OUT OF RANGE X C UPDATED --JUNE 2004 ALTERNATE DEFINITION FOR C GENERAPLIZED PARETO (USES C DIFFERENT SIGN) C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C CHARACTER*4 IGEPDF C DOUBLE PRECISION DX DOUBLE PRECISION DG DOUBLE PRECISION DPDF C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(X.LE.0.0)THEN WRITE(ICOUT,1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9000 ENDIF C IF(IGEPDF.EQ.'JOHN')THEN IF(GAMMA.GT.0.0)THEN TEMP=1.0/GAMMA IF(X.GE.TEMP)THEN WRITE(ICOUT,3) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9000 ENDIF ENDIF ELSE IF(GAMMA.LT.0.0)THEN TEMP=-1.0/GAMMA IF(X.GE.TEMP)THEN WRITE(ICOUT,2) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9000 ENDIF ENDIF ENDIF C 1 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO GEPPDF IS ', 1 'NON-POSITIVE.') 2 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO GEPPDF IS ', 1 '>= -1/GAMMA FOR NEGATIVE GAMMA') 3 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO GEPPDF IS ', 1 '>= 1/GAMMA FOR POSITIVE GAMMA') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7) C C COMPUTE THE PDF VALUE C DX=DBLE(X) DG=DBLE(GAMMA) C IF(GAMMA.EQ.0.0)THEN DPDF=DEXP(-DX) ELSE IF(IGEPDF.EQ.'JOHN')THEN DPDF=(1.0D0-DG*DX)**((1.0D0/DG)-1.0D0) ELSE DPDF=(1.0D0+DG*DX)**(-(1.0D0/DG)-1.0D0) ENDIF ENDIF PDF=REAL(DPDF) C 9000 CONTINUE RETURN END SUBROUTINE GEPPPF(P,GAMMA,MINMAX,IGEPDF,PPF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT C FUNCTION VALUE FOR THE GENERALIZED PARETO C DISTRIBUTION WITH SINGLE PRECISION C SHAPE LENGTH PARAMETER = GAMMA. C THE GENERALIZED PARETO DISTRIBUTION USED C HEREIN IS DEFINED FOR ALL POSITIVE X, C AND HAS THE PERCENT POINT FUNCTION C G(P) = (1/GAMMA)*(((1-P)**(-GAMMA))-1.0) C JOHNSON, KOTZ, AND BALAKRISHNAN REVERSE THE SIGN: C G(P) = (-1/GAMMA)*(((1-P)**GAMMA)-1.0) 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 --GAMMA = THE SINGLE PRECISION VALUE C OF THE TAIL LENGTH PARAMETER. C GAMMA CAN BE NEGATIVE, 0, OR POSITIVE. C --MINMAX = THE INTEGER VALUE, NOT CURRENTLY USED C --IGEPDF = CHARACTER VALUE SPECIFYING WHETHER C EMIL SIMIU OR JOHNSON AND KOTZ DEFINITION C SHOULD BE USED. 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 GENERALIZED PARETO DISTRIBUTION C WITH TAIL LENGTH PARAMETER VALUE = GAMMA. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--P SHOULD BE BETWEEN 0.0 (EXCLUSIVELY) C AND 1.0 (EXCLUSIVELY). C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--ALOG. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTIUOUS UNIVARIATE C DISTRIBUTIONS--VOLUME 1", SECOND EDITION, PP. 614-620. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C VERSION NUMBER--93/12 C ORIGINAL VERSION--DECEMBER 1993. C UPDATED --JUNE 2004 ALTERNATE DEFINITION FOR C GENERAPLIZED PARETO (USES C DIFFERENT SIGN) C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IGEPDF C DOUBLE PRECISION DP DOUBLE PRECISION DG DOUBLE PRECISION DPPF C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(P.LE.0.0.OR.P.GE.1.0)THEN WRITE(ICOUT,1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)P CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9000 ENDIF C 1 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO ', 1'GEPPPF IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL.') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7) C DP=DBLE(P) DG=DBLE(GAMMA) IF(GAMMA.EQ.0.0)THEN DPPF=(-DLOG(1.0D0-DP)) ELSE IF(IGEPDF.EQ.'JOHN')THEN DPPF=(-1.0D0/DG)*(((1.0D0-DP)**DG)-1.0D0) ELSE DPPF=(1.0D0/DG)*(((1.0D0-DP)**(-DG))-1.0D0) ENDIF ENDIF PPF=REAL(DPPF) C 9000 CONTINUE RETURN END SUBROUTINE GEDPPF(DP,DG,MINMAX,IGEPDF,DPPF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT C FUNCTION VALUE FOR THE GENERALIZED PARETO C DISTRIBUTION WITH DOUBLE PRECISION C SHAPE LENGTH PARAMETER = GAMMA. C THE GENERALIZED PARETO DISTRIBUTION USED C HEREIN IS DEFINED FOR ALL POSITIVE X, C AND HAS THE PERCENT POINT FUNCTION C G(P) = (1/GAMMA)*(((1-P)**(-GAMMA))-1.0) C JOHNSON, KOTZ, AND BALAKRISHNAN REVERSE THE SIGN: C G(P) = (-1/GAMMA)*(((1-P)**GAMMA)-1.0) C NOTE THAT THE PERCENT POINT FUNCTION OF A DISTRIBUTION C IS IDENTICALLY THE SAME AS THE INVERSE CUMULATIVE C DISTRIBUTION FUNCTION OF THE DISTRIBUTION. C C THIS VERSION IS A DOUBLE PRECISION VERSION. C C INPUT ARGUMENTS--P = THE DOUBLE 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 --GAMMA = THE DOUBLE PRECISION VALUE C OF THE TAIL LENGTH PARAMETER. C GAMMA CAN BE NEGATIVE, 0, OR POSITIVE. C --MINMAX = THE INTEGER VALUE, NOT CURRENTLY USED C --IGEPDF = CHARACTER VALUE SPECIFYING WHETHER C EMIL SIMIU OR JOHNSON AND KOTZ DEFINITION C SHOULD BE USED. C OUTPUT ARGUMENTS--PPF = THE DOUBLE PRECISION PERCENT C POINT FUNCTION VALUE. C OUTPUT--THE DOUBLE PRECISION PERCENT POINT FUNCTION . C VALUE PPF FOR THE GENERALIZED PARETO DISTRIBUTION C WITH TAIL LENGTH PARAMETER VALUE = GAMMA. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--P SHOULD BE BETWEEN 0.0 (EXCLUSIVELY) C AND 1.0 (EXCLUSIVELY). C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--ALOG. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTIUOUS UNIVARIATE C DISTRIBUTIONS--VOLUME 1", SECOND EDITION, PP. 614-620. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C VERSION NUMBER--2005/5 C ORIGINAL VERSION--MAY 2005. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IGEPDF C DOUBLE PRECISION DP DOUBLE PRECISION DG DOUBLE PRECISION DPPF C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(DP.LE.0.0D0.OR.DP.GE.1.0D0)THEN WRITE(ICOUT,1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)DP CALL DPWRST('XXX','BUG ') DPPF=0.0D0 GOTO9000 ENDIF C 1 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO ', 1'GEDPPF IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL.') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7) C IF(DG.EQ.0.0D0)THEN DPPF=(-DLOG(1.0D0-DP)) ELSE IF(IGEPDF.EQ.'JOHN')THEN DPPF=(-1.0D0/DG)*(((1.0D0-DP)**DG)-1.0D0) ELSE DPPF=(1.0D0/DG)*(((1.0D0-DP)**(-DG))-1.0D0) ENDIF ENDIF C 9000 CONTINUE RETURN END SUBROUTINE GE2PPF(P,PPAR,PPF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT C FUNCTION VALUE FOR THE GEOMETRIC C DISTRIBUTION WITH SINGLE PRECISION C 'BERNOULLI PROBABILITY' PARAMETER = PPAR. C THIS VERSION USES AN ALTERNATIVE DEFINITION C USED IN THE DIGITAL LIBRARY OF MATHEMATICAL FUNCTIONS. C THE GEOMETRIC DISTRIBUTION USED C HEREIN HAS MEAN = 1/PPAR C AND STANDARD DEVIATION = SQRT((1-PPAR)/(PPAR*PPAR))). C THIS DISTRIBUTION IS DEFINED FOR C ALL POSITIVE INTEGER X--X = 1, 2, ... . C THIS DISTRIBUTION HAS THE PROBABILITY FUNCTION C F(X) = PPAR * (1-PPAR)**(X-1). C THE GEOMETRIC DISTRIBUTION IS THE C DISTRIBUTION OF THE NUMBER OF TRIALS UP TO AND C INCLUDING THE FIRST SUCCESS IN AN C INDEFINITE SEQUENCE OF BERNOULLI (0,1) C TRIALS WHERE THE PROBABILITY OF SUCCESS C IN A SINGLE TRIAL = PPAR. C NOTE THAT THE PERCENT POINT FUNCTION OF A DISTRIBUTION C IS IDENTICALLY THE SAME AS THE INVERSE CUMULATIVE C DISTRIBUTION FUNCTION OF THE DISTRIBUTION. C INPUT ARGUMENTS--P = THE SINGLE PRECISION VALUE C (BETWEEN 0.0 (INCLUSIVELY) C AND 1.0 (EXCLUSIVELY)) C AT WHICH THE PERCENT POINT C FUNCTION IS TO BE EVALUATED. C --PPAR = THE SINGLE PRECISION VALUE C OF THE 'BERNOULLI PROBABILITY' C PARAMETER FOR THE GEOMETRIC C DISTRIBUTION. C PPAR SHOULD BE BETWEEN C 0.0 (EXCLUSIVELY) AND C 1.0 (EXCLUSIVELY). 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 GEOMETRIC DISTRIBUTION C WITH 'BERNOULLI PROBABILITY' PARAMETER VALUE = PPAR. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--PPAR SHOULD BE BETWEEN 0.0 (EXCLUSIVELY) C AND 1.0 (EXCLUSIVELY). C --P SHOULD BE BETWEEN 0.0 (INCLUSIVELY) C AND 1.0 (EXCLUSIVELY). C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--ALOG. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C COMMENT--NOTE THAT EVEN THOUGH THE OUTPUT C FROM THIS DISCRETE DISTRIBUTION C PERCENT POINT FUNCTION C SUBROUTINE MUST NECESSARILY BE A C DISCRETE INTEGER VALUE, C THE OUTPUT VARIABLE PPF IS SINGLE C PRECISION IN MODE. C PPF HAS BEEN SPECIFIED AS SINGLE C PRECISION SO AS TO CONFORM WITH THE DATAPAC C CONVENTION THAT ALL OUTPUT VARIABLES FROM ALL C DATAPAC SUBROUTINES ARE SINGLE PRECISION. C THIS CONVENTION IS BASED ON THE BELIEF THAT C 1) A MIXTURE OF MODES (FLOATING POINT C VERSUS INTEGER) IS INCONSISTENT AND C AN UNNECESSARY COMPLICATION C IN A DATA ANALYSIS; AND C 2) FLOATING POINT MACHINE ARITHMETIC C (AS OPPOSED TO INTEGER ARITHMETIC) C IS THE MORE NATURAL MODE FOR DOING C DATA ANALYSIS. C REFERENCES--FELLER, AN INTRODUCTION TO PROBABILITY C THEORY AND ITS APPLICATIONS, VOLUME 1, C EDITION 2, 1957, PAGES 155-157, 210. C --NATIONAL BUREAU OF STANDARDS APPLIED MATHEMATICS C SERIES 55, 1964, PAGE 929. C 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--2004/3 C ORIGINAL VERSION--MARCH 2004. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(P.LT.0.0.OR.P.GE.1.0)THEN WRITE(ICOUT,1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)P CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9000 ENDIF IF(PPAR.LE.0.0.OR.PPAR.GE.1.0)THEN WRITE(ICOUT,11) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)PPAR CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9000 ENDIF 1 FORMAT('***** FATAL ERROR--THE FIRST INPUT ARGUMENT TO THE ', 1'GEOPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1] INTERVAL') 11 FORMAT('***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE ', 1'GEOPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') C IF(P.NE.0.0)GOTO150 PPF=0.0 RETURN 150 CONTINUE C ARG1=1.0-P ARG2=1.0-PPAR ANUM=ALOG(ARG1) ADEN=ALOG(ARG2) RATIO=ANUM/ADEN IRATIO=RATIO+0.99999 PPF=IRATIO C 9000 CONTINUE RETURN END SUBROUTINE GEPRAN(N,GAMMA,MINMAX,IGEPDF,ISEED,X) C C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N C FROM THE GENERALIZED PARETO DISTRIBUTION C WITH TAIL LENGTH PARAMETER VALUE = GAMMA. C INPUT ARGUMENTS--N = THE DESIRED INTEGER NUMBER C OF RANDOM NUMBERS TO BE C GENERATED. C --GAMMA = THE SINGLE PRECISION VALUE OF THE C TAIL LENGTH PARAMETER. C GAMMA SHOULD BE POSITIVE. C --MINMAX = THE INTEGER VALUE C IDENTIFYING THE C CHOSEN GEN. PARETO DISTRIBUTION. C 1 = MIN, 2 = MAX. C --IGEPDF = CHARACTER VALUE SPECIFYING WHETHER C EMIL SIMIU OR JOHNSON AND KOTZ DEFINITION C SHOULD BE USED. 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 GENERALIZED PARETO DISTRIBUTION C WITH TAIL LENGTH PARAMETER VALUE = GAMMA. 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--ALOG. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTIUOUS UNIVARIATE C DISTRIBUTIONS--VOLUME 1", SECOND EDITION, PP. 614-620. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C VERSION NUMBER--93/12 C ORIGINAL VERSION--DECEMBER 1993. C UPDATED --JUNE 2004 ALTERNATE DEFINITION FOR C GENERAPLIZED PARETO (USES C DIFFERENT SIGN) C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DIMENSION X(*) C DOUBLE PRECISION DP DOUBLE PRECISION DG DOUBLE PRECISION DPPF C CHARACTER*4 IGEPDF 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 C WRITE(ICOUT,5) 5 FORMAT('***** ERROR--FOR THE GENERALIZED PARETO DISTRIBUTION, ', 1 'THE REQUESTED NUMBER OF RANDOM NUMBERS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,6) 6 FORMAT(' IS NON-POSITIVE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)N 47 FORMAT('***** THE REQUESTED NUMBER OF RANDOM NUMBERS IS ',I8) CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF C C GENERATE N UNIFORM (0,1) RANDOM NUMBERS; C C NOTE THAT GAMMA = 0 REDUCES TO AN EXPONENTIAL, SO HANDLE THAT CASE C SEPARATELY. ALSO, JOHNSON, KOTZ, AND BALAKRISHNAN PARAMETERIZE C WITH THE SIGN OF THE SHAPE PARAMETER REVERSED. HANDLE THAT CASE C SEPARATELY. C IF(GAMMA.EQ.0.0)THEN CALL EXPRAN(N,ISEED,X) ELSE CALL UNIRAN(N,ISEED,X) C C GENERATE N GENERALIZED PARETO DISTRIBUTION RANDOM NUMBERS C USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD. C DG=DBLE(GAMMA) C IF(IGEPDF.EQ.'JOHN')THEN DO100I=1,N DP=DBLE(X(I)) DPPF=(-1.0D0/DG)*(((1.0D0-DP)**DG)-1.0D0) X(I)=REAL(DPPF) 100 CONTINUE ELSE DO200I=1,N DP=DBLE(X(I)) DPPF=(1.0D0/DG)*(((1.0D0-DP)**(-DG))-1.0D0) X(I)=REAL(DPPF) 200 CONTINUE ENDIF ENDIF C 9000 CONTINUE RETURN END SUBROUTINE GETCDF(DX,DSHAPE,DBETA,IGETDF,DCDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION C FUNCTION VALUE FOR THE GEETA DISTRIBUTION WITH SHAPE C PARAMETERS THETA AND BETA. THIS DISTRIBUTION IS C DEFINED FOR ALL INTEGER X >= 1. C C THE PROBABILITY MASS FUNCTION IS: C p(X;THETA,BETA)= C (BETA*X-1 X)*THETA**(X-1)*(1-THETA)**(BETA*X-X)/ C (BETA*X-1) C X = 1, 2, 3, ,... C 0 < THETA < 1; 1 <= BETA < 1/THETA C C THE MEAN AND VARIANCE ARE: C C MU = (1-THETA)/(1-THETA*BETA) C SIGMA**2 = (BETA-1)*THETA*(1-THETA)/ C (1-THETA*BETA)**3 C C THIS DISTRIBUTION IS SOMETIMES PARAMETERIZED USING C THE MEAN (MU) INSTEAD OF THETA. THIS RESULTS IN C THE PROBABILITY MASS FUNCTION: C p(X;MU,BETA)= C (BETA*X-1 X)*((MU-1)/(BETA*MU-1))**(X-1)* C (MU*(BETA-1)/(BETA*MU-1))**(BETA*X-X)/(BETA*X-1) C X = 1, 2, 3, ,... C MU >= 1; BETA > 1 C THE PROBABILITY MASS FUNCTION IS ALSO GIVEN AS C p(X;MU,BETA)= C (BETA*X-1 X)*((MU-1)/(BETA*MU-MU))**(X-1)* C (MU*(BETA-1)/(BETA*MU-1))**(BETA*X-1)/(BETA*X-1) C C THE CUMULATIVE DISTRIBUTION IS COMPUTED USING THE C FOLLOWING RECURRENCE RELATION: C C F(1;MU,BETA) = ((BETA-1)*MU/(BETA*MU-1))**(BETA-1) C F(2;MU,BETA) = ((MU-1)/MU)* C ((BETA-1)*MU/(BETA*MU-1))**(2*BETA-1) C F(X=k+1;MU,BETA) = PROD[i=1 to k][1 + BETA/(BETA*k-1)]* C ((MU-1)/MU)* C ((BETA-1)*MU/(BETA*MU-1))**BETA* C P(X=k;MU,BETA) C C NOTE: THIS RECCURENCE RELATION DOES NOT SEEM TO C RETURN ACCURATE RESULTS. SO UNTIL THIS IS C RESOLVED, JUST USE BRUTE FORCE AND CALL THE C PDF FUNCTION. C C INPUT ARGUMENTS--DX = THE DOUBLE PRECISION VALUE AT C WHICH THE CUMULATIVE DISTRIBUTION C FUNCTION IS TO BE EVALUATED. C DX SHOULD BE A NON-NEGATIVE INTEGER. C --DSHAPE = THE FIRST SHAPE PARAMETER C (EITHER THETA OR MU) C --DBETA = THE SECOND SHAPE PARAMETER C OUTPUT ARGUMENTS--DCDF = THE DOUBLE PRECISION CUMULATIVE C DISTRIBUTION FUNCTION VALUE. C OUTPUT--THE DOUBLE PRECISION CUMULATIVE DISTRIBUTION FUNCTION C VALUE DCDF FOR THE GEETA DISTRIBUTION WITH SHAPE C PARAMETERS THETA (OR MU) AND BETA C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--DX SHOULD BE A POSITIVE INTEGER C --0 < THETA < 1; 1 < BETA < 1/THETA C --MU >= 1; BETA > 1 C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--CONSUL (1990), "GEETA DISTRIBUTION AND ITS C PROPERTIES", COMMUNICATIONS IN STATISTICS-- C THEORY AND METHODS, 19, PP. 3051-3068. C --CONSUL AND FAMOYE (2006), "LAGRANGIAN PROBABILITY C DISTRIBUTIONS", BIRKHAUSER, CHAPTER 8. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2006/7 C ORIGINAL VERSION--JULY 2006. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DX DOUBLE PRECISION DSHAPE DOUBLE PRECISION DBETA DOUBLE PRECISION DCDF C DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 DOUBLE PRECISION DTERM3 DOUBLE PRECISION DTERM4 DOUBLE PRECISION DSUM DOUBLE PRECISION DTHETA DOUBLE PRECISION DMU DOUBLE PRECISION DPDF DOUBLE PRECISION DPDFSV C CHARACTER*4 IGETDF 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(IGETDF.EQ.'THET')THEN DTHETA=DSHAPE ELSE DMU=DSHAPE ENDIF C IX=INT(DX+0.5D0) IF(IX.LT.1)THEN WRITE(ICOUT,4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)DX CALL DPWRST('XXX','BUG ') DCDF=0.0D0 GOTO9000 ENDIF 4 FORMAT('***** ERROR--THE FIRST ARGUMENT TO GETCDF IS LESS ', 1'THAN 1') C IF(IGETDF.EQ.'THET')THEN IF(DTHETA.LE.0.0D0 .OR. DTHETA.GE.1.0D0)THEN WRITE(ICOUT,15) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)DTHETA CALL DPWRST('XXX','BUG ') DCDF=0.0 GOTO9000 ENDIF 15 FORMAT('***** ERROR--THE SECOND ARGUMENT TO GETCDF IS NOT ', 1 'IN THE INTERVAL (0,1)') C IF(DBETA.LT.1.0D0 .OR. DBETA.GE.1.0D0/DTHETA)THEN WRITE(ICOUT,25)1.0D0/DTHETA CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)DBETA CALL DPWRST('XXX','BUG ') DCDF=0.0 GOTO9000 ENDIF 25 FORMAT('***** ERROR--THE THIRD ARGUMENT TO GETCDF IS NOT ', 1 'IN THE INTERVAL (1,',G15.7,')') ELSE IF(DMU.LT.1.0D0)THEN WRITE(ICOUT,35) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)DMU CALL DPWRST('XXX','BUG ') DCDF=0.0 GOTO9000 ENDIF 35 FORMAT('***** ERROR--THE SECOND ARGUMENT TO GETCDF IS ', 1 'LESS THAN 1') C IF(DBETA.LE.1.0D0)THEN WRITE(ICOUT,38) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)DBETA CALL DPWRST('XXX','BUG ') DCDF=0.0 GOTO9000 ENDIF 38 FORMAT('***** ERROR--THE THIRD ARGUMENT TO GETCDF IS ', 1 'LESS THAN OR EQUAL TO 1') ENDIF C 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7) C CCCCC USE PDF FUNCTION UNTIL WE GET RECURRENCE RELATION RESOLVED. C IF(IGETDF.EQ.'THET')THEN IF(DBETA.LE.1.0D0)THEN DCDF=1.0D0 ELSE DCDF=0.0D0 DO100I=IX,1,-1 CALL GETPDF(DBLE(I),DTHETA,DBETA,IGETDF,DPDF) DCDF=DCDF + DPDF 100 CONTINUE ENDIF ELSE IF(DMU.LE.1.0D0)THEN DCDF=1.0D0 ELSE DCDF=0.0D0 DO200I=IX,1,-1 CALL GETPDF(DBLE(I),DMU,DBETA,IGETDF,DPDF) DCDF=DCDF + DPDF 200 CONTINUE ENDIF ENDIF C CCCCC IF(IGETDF.EQ.'THET')THEN CCCCC DTHETA=DBLE(THETA) CCCCC DMU=(1.0D0 - DTHETA)/(1.0D0 - DTHETA*DBETA) CCCCC ELSE CCCCC DMU=DBLE(MU) CCCCC ENDIF C CCCCC DCDF=((DBETA-1.0D0)*DMU/(DBETA*DMU-1.0D0))**(DBETA-1.0D0) CCCCC IF(IX.LE.1)THEN CCCCC CDF=REAL(DCDF) CCCCC GOTO9000 CCCCC ENDIF CCCCC DPDF=((DMU-1.0D0)/DMU)* CCCCC1 ((DBETA-1.0D0)*DMU/(DBETA*DMU-1.0D0))**(2.0D0*DBETA-1.0D0) CCCCC DCDF=DCDF+DPDF CCCCC IF(IX.LE.2)THEN CCCCC CDF=REAL(DCDF) CCCCC GOTO9000 CCCCC ENDIF CCCCC DPDFSV=DPDF C CCCCC DTERM1=DLOG(DMU-1.0D0) - DLOG(DMU) CCCCC DTERM2=DBETA*(DLOG(DBETA-1.0D0)+DLOG(DMU)-DLOG(DBETA*DMU-1.0D0)) CCCCC DO100I=3,IX CCCCC K=I-1 CCCCC DX=DBLE(I) CCCCC DSUM=0.0D0 CCCCC DO200J=1,K CCCCC DSUM=DSUM+DLOG(1.0D0+DBETA/(DBETA*DBLE(K)-DBLE(J))) CC200 CONTINUE CCCCC IF(DPDFSV.GT.0.0D0)THEN CCCCC DTERM3=DLOG(DPDFSV) CCCCC DPDF=DEXP(DTERM3 + DSUM + DTERM1 + DTERM2) CCCCC ELSE CCCCC CDF=REAL(DCDF) CCCCC GOTO9000 CCCCC ENDIF CCCCC DCDF=DCDF + DPDF CCCCC DPDFSV=DPDF CC100 CONTINUE C 9000 CONTINUE RETURN END DOUBLE PRECISION FUNCTION GETFUN(DBETA) C C PURPOSE--THIS ROUTINE COMPUTES THE FUNCTIONS FOR THE C GEETA MEAN AND ONES FREQUENCY EQUATION. C C THE MEAN AND ONES FREQUENCY ESTIMATE OF MU IS: C C MUHAT = XBAR C C THE ESTIMATE OF BETA IS THEN THE SOLUTION OF THE C EQUATION C C ((BETA-1)*XBAR/(BETA*XBAR-1))**(BETA-1) - (N1/N) = 0 C C CALLED BY DFZERO ROUTINE FOR SOLVING A NONLINEAR C UNIVARIATE EQUATION. C EXAMPLE--GEETA MAXIMUM LIKELIHOOD Y C REFERENCES--CONSUL AND FAMOYE (2006), "LAGRANGIAN PROBABILITY C DISTRIBUTIONS", BIRKHAUSER, CHAPTER 8. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBUG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2006/7 C ORIGINAL VERSION--JULY 2006. C C--------------------------------------------------------------------- C DOUBLE PRECISION DBETA C DOUBLE PRECISION XBAR DOUBLE PRECISION S2 DOUBLE PRECISION F1FREQ COMMON/GETCOM/XBAR,S2,F1FREQ,MAXROW,N C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C GETFUN=((DBETA-1.0D0)*XBAR/(DBETA*XBAR-1.0D0))**(DBETA-1.0D0) - 1 F1FREQ C RETURN END SUBROUTINE GETFU2(N,XPAR,FVEC,IFLAG,Y,K) C C PURPOSE--THIS ROUTINE COMPUTES THE FUNCTIONS FOR THE C GEETA MAXIMUM LIKELIHOOD EQUATION. C C THE MAXIMUM LIKELIHOOD FREQUENCY ESTIMATE OF MU IS: C C MUHAT = XBAR C C THE ESTIMATE OF BETA IS THEN THE SOLUTION OF THE C EQUATION C C ((BETA-1)*XBAR/(BETA*XBAR-1))**(BETA-1) - C (1/(N*XBAR))* C SUM[X=2 to k][SUM[i=2 to k][X*N(x)/(BETA*X-1)]] = 0 C C THIS ROUTINE ASSUMES THE DATA IS IN THE FORM C C X(I) FREQ(I) C C CALLED BY DNSQE ROUTINE FOR SOLVING SIMULTANEOUS C NONLINEAR EQUATIONS. NOTE THAT THE CALLING SEQUENCE C DID NOT ACCOMODATE A DATA ARRAY (AND ASSCIATED NUMBER OF C OBSERVATIONS), SO THESE WERE ADDED TO THE CALL LIST. C SINCE DNSQE ONLY PASSES ONE ARRAY, WE SPLIT INTO C TWO PARTS: 1 - MAXNXT/2 ARE THE FREQUENCIES WHILE C (MAXNXT/2 + 1) - MAXNXT ARE THE CLASS VALUES (I.E., C THE X). C EXAMPLE--GEETA MAXIMUM LIKELIHOOD Y C REFERENCES--CONSUL AND FAMOYE (2006), "LAGRANGIAN PROBABILITY C DISTRIBUTIONS", BIRKHAUSER, CHAPTER 8. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBUG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2006/7 C ORIGINAL VERSION--JULY 2006. C C--------------------------------------------------------------------- C DOUBLE PRECISION XPAR(*) DOUBLE PRECISION FVEC(*) REAL Y(*) C DOUBLE PRECISION DBETA DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 DOUBLE PRECISION DTERM3 DOUBLE PRECISION DSUM1 DOUBLE PRECISION DN DOUBLE PRECISION DX DOUBLE PRECISION DFREQ C DOUBLE PRECISION XBAR DOUBLE PRECISION S2 DOUBLE PRECISION F1FREQ COMMON/GETCOM/XBAR,S2,F1FREQ,MAXROW,NTOT 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 DBETA=XPAR(1) DN=DBLE(NTOT) IINDX=MAXROW/2 C DTERM1=(DBETA - 1.0D0)*XBAR/(DBETA*XBAR - 1.0D0) DTERM2=1.0D0/(DN*XBAR) C DSUM1=0.0D0 DO100I=2,K DX=DBLE(Y(IINDX+I)) DFREQ=Y(I) DO200J=2,I-1 DSUM1=DSUM1 + DX*DFREQ/(DBETA*DX - DBLE(J)) 200 CONTINUE 100 CONTINUE C DTERM3=DTERM2*DSUM1 FVEC(1)=DTERM1 - DEXP(-DTERM3) C RETURN END SUBROUTINE GETPDF(DX,DSHAPE,DBETA,IGETDF,DPDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY MASS C FUNCTION VALUE FOR THE GEETA DISTRIBUTION WITH SHAPE C PARAMETERS THETA AND BETA. THIS DISTRIBUTION IS C DEFINED FOR ALL INTEGER X >= 1. C C THE PROBABILITY MASS FUNCTION IS: C p(X;THETA,BETA)= C (BETA*X-1 X)*THETA**(X-1)*(1-THETA)**(BETA*X-X)/ C (BETA*X-1) C X = 1, 2, 3, ,... C 0 < THETA < 1; 1 <= BETA < 1/THETA C C THE MEAN AND VARIANCE ARE: C C MU = (1-THETA)/(1-THETA*BETA) C SIGMA**2 = (BETA-1)*THETA*(1-THETA)/ C (1-THETA*BETA)**3 C C THIS DISTRIBUTION IS SOMETIMES PARAMETERIZED USING C THE MEAN (MU) INSTEAD OF THETA. THIS RESULTS IN C THE PROBABILITY MASS FUNCTION: C p(X;MU,BETA)= C (BETA*X-1 X)*((MU-1)/(BETA*MU-1))**(X-1)* C (MU*(BETA-1)/(BETA*MU-1))**(BETA*X-X)/(BETA*X-1) C X = 1, 2, 3, ,... C MU >= 1; BETA > 1 C THE PROBABILITY MASS FUNCTION IS ALSO GIVEN AS C p(X;MU,BETA)= C (BETA*X-1 X)*((MU-1)/(BETA*MU-MU))**(X-1)* C (MU*(BETA-1)/(BETA*MU-1))**(BETA*X-1)/(BETA*X-1) C C INPUT ARGUMENTS--DX = THE DOUBLE PRECISION VALUE AT C WHICH THE PROBABILITY MASS C FUNCTION IS TO BE EVALUATED. C X SHOULD BE A NON-NEGATIVE INTEGER. C --DSHAPE = THE FIRST SHAPE PARAMETER C (EITHER THETA OR MU) C --DBETA = THE SECOND SHAPE PARAMETER C OUTPUT ARGUMENTS--DPDF = THE DOUBLE PRECISION PROBABILITY MASS C FUNCTION VALUE. C OUTPUT--THE DOUBLE PRECISION PROBABILITY MASS FUNCTION VALUE C PDF FOR THE GEETA C DISTRIBUTION WITH SHAPE PARAMETERS THETA AND BETA C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--X SHOULD BE A POSITIVE INTEGER C --0 < THETA < 1; 1 < BETA < 1/THETA C --MU >= 1; BETA > 1 C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--CONSUL (1990), "GEETA DISTRIBUTION AND ITS C PROPERTIES", COMMUNICATIONS IN STATISTICS-- C THEORY AND METHODS, 19, PP. 3051-3068. C --CONSUL AND FAMOYE (2006), "LAGRANGIAN PROBABILITY C DISTRIBUTIONS", BIRKHAUSER, CHAPTER 8. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2006/7 C ORIGINAL VERSION--JULY 2006. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DX DOUBLE PRECISION DSHAPE DOUBLE PRECISION DBETA DOUBLE PRECISION DPDF C DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 DOUBLE PRECISION DTERM3 DOUBLE PRECISION DTERM4 DOUBLE PRECISION DTERM5 DOUBLE PRECISION DTHETA DOUBLE PRECISION DMU DOUBLE PRECISION DLNGAM C CHARACTER*4 IGETDF 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(IGETDF.EQ.'THET')THEN DTHETA=DSHAPE ELSE DMU=DSHAPE ENDIF C IX=INT(DX+0.5D0) IF(IX.LT.1)THEN WRITE(ICOUT,4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)DX CALL DPWRST('XXX','BUG ') DPDF=0.0D0 GOTO9000 ENDIF 4 FORMAT('***** ERROR--THE FIRST ARGUMENT TO GETPDF IS LESS ', 1'THAN 1') C IF(IGETDF.EQ.'THET')THEN IF(DTHETA.LE.0.0D0 .OR. DTHETA.GE.1.0D0)THEN WRITE(ICOUT,15) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)DTHETA CALL DPWRST('XXX','BUG ') DPDF=0.0 GOTO9000 ENDIF 15 FORMAT('***** ERROR--THE SECOND ARGUMENT TO GETPDF IS NOT ', 1 'IN THE INTERVAL (0,1)') C IF(DBETA.LT.1.0D0 .OR. DBETA.GE.1.0D0/DTHETA)THEN WRITE(ICOUT,25)1.0D0/DTHETA CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)DBETA CALL DPWRST('XXX','BUG ') DPDF=0.0 GOTO9000 ENDIF 25 FORMAT('***** ERROR--THE THIRD ARGUMENT TO GETPDF IS NOT ', 1 'IN THE INTERVAL (1,',G15.7,')') ELSE IF(DMU.LT.1.0D0)THEN WRITE(ICOUT,35) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)DMU CALL DPWRST('XXX','BUG ') DPDF=0.0 GOTO9000 ENDIF 35 FORMAT('***** ERROR--THE SECOND ARGUMENT TO GETPDF IS ', 1 'LESS THAN 1') C IF(DBETA.LE.1.0D0)THEN WRITE(ICOUT,38) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)DBETA CALL DPWRST('XXX','BUG ') DPDF=0.0 GOTO9000 ENDIF 38 FORMAT('***** ERROR--THE THIRD ARGUMENT TO GETPDF IS ', 1 'LESS THAN OR EQUAL TO 1') ENDIF C 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7) C DX=DBLE(IX) C IF(IGETDF.EQ.'THET')THEN IF(DBETA.LE.1.0D0)THEN IF(IX.EQ.1)THEN DPDF=1.0D0 ELSE DPDF=0.0D0 ENDIF ELSE DTERM1=DLNGAM(DBETA*DX) + (DX-1.0D0)*DLOG(DTHETA) + 1 (DBETA*DX-DX)*DLOG(1.0D0 - DTHETA) DTERM2=DLNGAM(DX+1.0D0) + DLOG(DBETA*DX-1.0D0) DTERM3=DLNGAM(DBETA*DX-DX) DTERM4=DTERM1 - DTERM2 - DTERM3 DPDF=DEXP(DTERM4) ENDIF ELSE IF(DMU.LE.1.0D0)THEN IF(IX.EQ.1)THEN DPDF=1.0D0 ELSE DPDF=0.0D0 ENDIF ELSE DTERM1=-DLOG(DBETA*DX - 1.0D0) DTERM2=DLNGAM(DBETA*DX) - DLNGAM(DX+1.0D0) - 1 DLNGAM(DBETA*DX-DX) DTERM3=(DX-1.0D0)*(DLOG(DMU-1.0D0) - DLOG(DMU) - 1 DLOG(DBETA-1.0D0)) DTERM4=(DBETA*DX-1.0D0)*(DLOG(DBETA*DMU - DMU) - 1 DLOG(DBETA*DMU - 1.0D0)) DTERM5=DTERM1 + DTERM2 + DTERM3+ DTERM4 DPDF=DEXP(DTERM5) ENDIF ENDIF C 9000 CONTINUE RETURN END SUBROUTINE GETPPF(DP,DSHAPE,DBETA,IGETDF,DPPF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT C FUNCTION VALUE FOR THE GEETA DISTRIBUTION WITH SHAPE C PARAMETERS THETA AND BETA. THIS DISTRIBUTION IS C DEFINED FOR ALL INTEGER X >= 1. C C THE PROBABILITY MASS FUNCTION IS: C p(X;THETA,BETA)= C (BETA*X-1 X)*THETA**(X-1)*(1-THETA)**(BETA*X-X)/ C (BETA*X-1) C X = 1, 2, 3, ,... C 0 < THETA < 1; 1 <= BETA < 1/THETA C C THE MEAN AND VARIANCE ARE: C C MU = (1-THETA)/(1-THETA*BETA) C SIGMA**2 = (BETA-1)*THETA*(1-THETA)/ C (1-THETA*BETA)**3 C C THIS DISTRIBUTION IS SOMETIMES PARAMETERIZED USING C THE MEAN (MU) INSTEAD OF THETA. THIS RESULTS IN C THE PROBABILITY MASS FUNCTION: C p(X;MU,BETA)= C (BETA*X-1 X)*((MU-1)/(BETA*MU-1))**(X-1)* C (MU*(BETA-1)/(BETA*MU-1))**(BETA*X-X)/(BETA*X-1) C X = 1, 2, 3, ,... C MU >= 1; BETA > 1 C THE PROBABILITY MASS FUNCTION IS ALSO GIVEN AS C p(X;MU,BETA)= C (BETA*X-1 X)*((MU-1)/(BETA*MU-MU))**(X-1)* C (MU*(BETA-1)/(BETA*MU-1))**(BETA*X-1)/(BETA*X-1) C C C THE CUMULATIVE DISTRIBUTION FUNCTION IS COMPUTED C BY SUMMING THE PROBABILITY MASS FUNCTION. THE C PERCENT POINT FUNCTION IS COMPUTED BY COMPUTING THE C CUMULATIVE DISTRIBUTION UNTIL THE APPROPRIATE C PROBABILITY IS REACHED. C C INPUT ARGUMENTS--DP = THE DOUBLE PRECISION VALUE AT C WHICH THE PERCENT POINT C FUNCTION IS TO BE EVALUATED. C --DSHAPE = THE FIRST SHAPE PARAMETER C (EITHER THETA OR MU) C --DBETA = THE SECOND SHAPE PARAMETER C OUTPUT ARGUMENTS--DPPF = THE DOUBLE PRECISION PERCENT POINT C FUNCTION VALUE. C OUTPUT--THE DOUBLE PRECISION PERCENT POINT FUNCTION C VALUE DCDF FOR THE GEETA DISTRIBUTION WITH SHAPE C PARAMETERS THETA (OR MU) AND BETA C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--0 <= DP < 1 C --0 < THETA < 1; 1 < BETA < 1/THETA C --MU >= 1; BETA > 1 C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--CONSUL (1990), "GEETA DISTRIBUTION AND ITS C PROPERTIES", COMMUNICATIONS IN STATISTICS-- C THEORY AND METHODS, 19, PP. 3051-3068. C --CONSUL AND FAMOYE (2006), "LAGRANGIAN PROBABILITY C DISTRIBUTIONS", BIRKHAUSER, CHAPTER 8. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2006/7 C ORIGINAL VERSION--JULY 2006. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DP DOUBLE PRECISION DSHAPE DOUBLE PRECISION DBETA DOUBLE PRECISION DPPF C DOUBLE PRECISION DX DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 DOUBLE PRECISION DTERM3 DOUBLE PRECISION DTERM4 DOUBLE PRECISION DSUM DOUBLE PRECISION DTHETA DOUBLE PRECISION DMU DOUBLE PRECISION DCDF DOUBLE PRECISION DPDF DOUBLE PRECISION DPDFSV C CHARACTER*4 IGETDF C C--------------------------------------------------------------------- C INCLUDE 'DPCOMC.INC' C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(IGETDF.EQ.'THET')THEN DTHETA=DSHAPE ELSE DMU=DSHAPE ENDIF C IF(DP.LT.0.0D0 .OR. DP.GE.1.0D0)THEN WRITE(ICOUT,4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)DP CALL DPWRST('XXX','BUG ') DPPF=0.0D0 GOTO9000 ENDIF 4 FORMAT('***** ERROR--THE FIRST ARGUMENT TO GETPPF IS OUTSIDE ', 1'THE (0,1] INTERVAL') C IF(IGETDF.EQ.'THET')THEN IF(DTHETA.LE.0.0D0 .OR. DTHETA.GE.1.0D0)THEN WRITE(ICOUT,15) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)DTHETA CALL DPWRST('XXX','BUG ') DPPF=0.0 GOTO9000 ENDIF 15 FORMAT('***** ERROR--THE SECOND ARGUMENT TO GETPPF IS NOT ', 1 'IN THE INTERVAL (0,1)') C IF(DBETA.LT.1.0D0 .OR. DBETA.GE.1.0D0/DTHETA)THEN WRITE(ICOUT,25)1.0D0/DTHETA CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)DBETA CALL DPWRST('XXX','BUG ') DPPF=0.0 GOTO9000 ENDIF 25 FORMAT('***** ERROR--THE THIRD ARGUMENT TO GETPPF IS NOT ', 1 'IN THE INTERVAL (1,',G15.7,')') ELSE IF(DMU.LT.1.0D0)THEN WRITE(ICOUT,35) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)DMU CALL DPWRST('XXX','BUG ') DPPF=0.0 GOTO9000 ENDIF 35 FORMAT('***** ERROR--THE SECOND ARGUMENT TO GETPPF IS ', 1 'LESS THAN 1') C IF(DBETA.LE.1.0D0)THEN WRITE(ICOUT,38) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)DBETA CALL DPWRST('XXX','BUG ') DPPF=0.0 GOTO9000 ENDIF 38 FORMAT('***** ERROR--THE THIRD ARGUMENT TO GETPPF IS ', 1 'LESS THAN OR EQUAL TO 1') ENDIF C 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7) C CCCCC USE PDF FUNCTION UNTIL WE GET RECURRENCE RELATION RESOLVED. C IF(IGETDF.EQ.'THET')THEN IF(DBETA.LE.1.0D0)THEN DPPF=1.0D0 ELSE I=0 DCDF=0.0D0 100 CONTINUE I=I+1 IF(DBLE(I).GE.DBLE(I1MACH(9)))THEN WRITE(ICOUT,55) 55 FORMAT('***** ERROR--THE COMPUTED PERCENT POINT VALUE ', 1 'EXCEEDS THE LARGEST MACHINE INTEGER.') CALL DPWRST('XXX','BUG ') DPPF=0.0D0 GOTO9000 ENDIF DX=DBLE(I) CALL GETPDF(DX,DTHETA,DBETA,IGETDF,DPDF) DCDF=DCDF + DPDF IF(DCDF.GE.DP)THEN DPPF=DX GOTO9000 ENDIF GOTO100 ENDIF ELSE IF(DMU.LE.1.0D0)THEN DPPF=1.0D0 ELSE I=0 DCDF=0.0D0 200 CONTINUE I=I+1 IF(DBLE(I).GE.DBLE(I1MACH(9)))THEN WRITE(ICOUT,55) CALL DPWRST('XXX','BUG ') DPPF=0.0D0 GOTO9000 ENDIF DX=DBLE(I) CALL GETPDF(DX,DMU,DBETA,IGETDF,DPDF) DCDF=DCDF + DPDF IF(DCDF.GE.DP)THEN DPPF=DX GOTO9000 ENDIF GOTO200 ENDIF ENDIF C 9000 CONTINUE RETURN END SUBROUTINE GETRAN(N,SHAPE,BETA,IGETDF,ISEED,X) C C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N C FROM THE GEETA DISTRIBUTION WITH SHAPE PARAMETERS C THETA OR MU AND BETA. C C THE PROBABILITY MASS FUNCTION IS: C p(X;THETA,BETA)= C (BETA*X-1 X)*THETA**(X-1)*(1-THETA)**(BETA*X-X)/ C (BETA*X-1) C X = 1, 2, 3, ,... C 0 < THETA < 1; 1 <= BETA < 1/THETA C C THE MEAN AND VARIANCE ARE: C C MU = (1-THETA)/(1-THETA*BETA) C SIGMA**2 = (BETA-1)*THETA*(1-THETA)/ C (1-THETA*BETA)**3 C C THIS DISTRIBUTION IS SOMETIMES PARAMETERIZED USING C THE MEAN (MU) INSTEAD OF THETA. THIS RESULTS IN C THE PROBABILITY MASS FUNCTION: C p(X;MU,BETA)= C (BETA*X-1 X)*((MU-1)/(BETA*MU-1))**(X-1)* C (MU*(BETA-1)/(BETA*MU-1))**(BETA*X-X)/(BETA*X-1) C X = 1, 2, 3, ,... C MU >= 1; BETA > 1 C THE PROBABILITY MASS FUNCTION IS ALSO GIVEN AS C p(X;MU,BETA)= C (BETA*X-1 X)*((MU-1)/(BETA*MU-MU))**(X-1)* C (MU*(BETA-1)/(BETA*MU-1))**(BETA*X-1)/(BETA*X-1) C C INPUT ARGUMENTS--N = THE DESIRED INTEGER NUMBER C OF RANDOM NUMBERS TO BE C GENERATED. C --SHAPE = THE SINGLE PRECISION VALUE C OF THE FIRST SHAPE PARAMETER. C --BETA = THE SINGLE PRECISION VALUE C OF THE SECOND SHAPE PARAMETER. C OUTPUT ARGUMENTS--X = A SINGLE PRECISION VECTOR C (OF DIMENSION AT LEAST N) C INTO WHICH THE GENERATED C RANDOM SAMPLE WILL BE PLACED. C OUTPUT--A RANDOM SAMPLE OF SIZE N C FROM THE GEETA DISTRIBUTION C WITH SHAPE PARAMETERS THETA (OR MU) AND BETA. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C --0 < THETA < 1, 1 < BETA < 1/THETA C MU >= 1; BETA > 1 C OTHER DATAPAC SUBROUTINES NEEDED--UNIRAN, GETPPF C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--CONSUL (1990), "GEETA DISTRIBUTION AND ITS C PROPERTIES", COMMUNICATIONS IN STATISTICS-- C THEORY AND METHODS, 19, PP. 3051-3068. C --CONSUL AND FAMOYE (2006), "LAGRANGIAN PROBABILITY C DISTRIBUTIONS", BIRKHAUSER, CHAPTER 8. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2006/7 C ORIGINAL VERSION--JULY 2006. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DIMENSION X(*) C CHARACTER*4 IGETDF C DOUBLE PRECISION DPPF C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(N.LT.1)THEN WRITE(ICOUT,5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)N CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF 5 FORMAT('***** ERROR--THE REQUESTED NUMBER OF GEETA RANDOM ', 1 'NUMBERS IS NON-POSITIVE') C IF(IGETDF.EQ.'THET')THEN THETA=SHAPE IF(THETA.LE.0.0 .OR. THETA.GE.1.0)THEN WRITE(ICOUT,15) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,16) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)THETA CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF 15 FORMAT('***** ERROR--THE THETA PARAMETER FOR THE GEETA') 16 FORMAT(' RANDOM NUMBERS IS OUTSIDE THE (0,1) INTERVAL') C IF(BETA.LE.1.0 .OR. BETA.GE.1.0/THETA)THEN WRITE(ICOUT,25) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,26)1.0/THETA CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)BETA CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF 25 FORMAT('***** ERROR--THE BETA PARAMETER FOR THE GEETA') 26 FORMAT(' RANDOM NUMBERS IS OUTSIDE THE (1,',G15.7,') ', 1 'INTERVAL') ELSE AMU=SHAPE IF(AMU.LT.1.0)THEN WRITE(ICOUT,35) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,36) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)AMU CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF 35 FORMAT('***** ERROR--THE MU PARAMETER FOR THE GEETA') 36 FORMAT(' RANDOM NUMBERS IS LESS THAN 1') C IF(BETA.LE.1.0)THEN WRITE(ICOUT,38) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,39) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)BETA CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF 38 FORMAT('***** ERROR--THE BETA PARAMETER FOR THE GEETA') 39 FORMAT(' RANDOM NUMBERS IS LESS THAN OR EQUAL TO 1') ENDIF C 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7) 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8) C C GENERATE N GEETA DISTRIBUTION RANDOM NUMBERS USING THE C INVERSION METHOD. C CALL UNIRAN(N,ISEED,X) DO100I=1,N XTEMP=X(I) CALL GETPPF(DBLE(XTEMP),DBLE(SHAPE),DBLE(BETA),IGETDF,DPPF) X(I)=REAL(DPPF) 100 CONTINUE C 9000 CONTINUE C RETURN END SUBROUTINE GEVCDF(X,GAMMA,MINMAX,CDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION C FUNCTION VALUE FOR THE GENERALIZED EXTREME VALUE C DISTRIBUTION WITH SINGLE PRECISION C SHAPE PARAMETER = GAMMA. C THERE ARE TWO GENERALIZED EXTREME VALUE FAMALIES: C ONE BASED ON THE MAXIMUM ORDER STATISTIC (THE MOST C COMMONLY USED, SPECIFIED BY MINMAX=2) AND THE OTHER C BASED ON THE MINIMUM ORDER STATISTIC (SPECIFIED BY C SET MINMAX = 1). C C THE CUMUALTIVE DISTRIBUTION FUNCTION FOR THE MAXIMUM C CASE OF THE GENERALIZED EXTREME VALUE DISTRIBUTION IS: C F(X,G) = EXP(-EXP(-X)) G = 0 C = EXP(-(1 - GAMMA*X)**(1/GAMMA)] G <> 0 C 1 - GAMMA*X >= 0 C C THE CUMULATIVE DISTRIBUTION FUNCTION FOR THE MINIMUM CASE C OF THE GENERALIZED EXTREME VALUE DISTRIBUTION IS: C F(X,G) = 1 - EXP(-EXP(X)) G = 0 C = 1 - EXP(-(1 + GAMMA*X)**(1/GAMMA)] G <> 0 C 1 + GAMMA*X >= 0 C C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE C AT WHICH THE CUMULATIVE DISTRIBUTION C FUNCTION IS TO BE EVALUATED. C --GAMMA = THE SINGLE PRECISION VALUE C OF THE 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 FOR THE GENERALIZED EXTREME VALUE C DISTRIBUTION WITH SHAPE PARAMETER VALUE = GAMMA. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--RANGE OF X DEPENDS ON SIGN OF GAMMA 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--2, 1994, PAGES 75-76 C --CASTILLO, HADI, BALAKRISHNAN, AND SARABIA, C "EXTREME VALUE AND RELATED MODELS WITH APPLICATIONS C IN ENGINEERING AND SCIENCE", WILEY, 2005, PP. 64-65. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING LABORATORY (205.03) C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE: 301-975-2855 C ORIGINAL VERSION--OCTOBER 1995. C UPDATED --MAY 2005. SUPPORT FOR MINIMUM CASE C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DX, DG 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 MAY 2005. HANDLE MIN AND MAX CASES SEPARATELY. C C MAXIMUM CASE C IF(MINMAX.EQ.2 .OR. MINMAX.EQ.0)THEN C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(GAMMA.GT.0.0)THEN IF(X.GE.(1.0/GAMMA))THEN CDF=1.0 GOTO9999 ENDIF ELSEIF(GAMMA.LT.0.0)THEN IF(X.LE.(1.0/GAMMA))THEN CDF=0.0 GOTO9999 ENDIF ENDIF C DX=DBLE(X) DG=DBLE(GAMMA) DCDF=0.0D0 C IF(GAMMA.EQ.0.0)THEN IF(DX.GE.40.D0)THEN DCDF=1.0D0 ELSEIF(DX.LE.-40.D0)THEN DCDF=0.0D0 ELSE DTERM1=-DEXP(-DX) IF(DTERM1.GE.0.0D0)THEN DCDF=1.0D0 ELSE DCDF=DEXP(DTERM1) ENDIF ENDIF ELSE IF(GAMMA.GT.0.0.AND.X.EQ.1.0/GAMMA)THEN DCDF=1.0D0 ELSEIF(GAMMA.LT.0.0.AND.X.EQ.1.0/GAMMA)THEN DCDF=0.0D0 ELSE DTERM1=-(1.D0-DX*DG)**(1.D0/DG) IF(DTERM1.LT.-40.0D0)THEN DCDF=0.0D0 ELSEIF(DTERM1.GE.0.0D0)THEN DCDF=1.0D0 ELSE DCDF=DEXP(DTERM1) ENDIF END IF END IF CDF=REAL(DCDF) ELSE C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(GAMMA.GT.0.0)THEN IF(X.LE.(-1.0/GAMMA))THEN CDF=0.0 GOTO9999 ENDIF ELSEIF(GAMMA.LT.0.0)THEN IF(X.GE.(-1.0/GAMMA))THEN CDF=1.0 GOTO9999 ENDIF ENDIF C DX=DBLE(X) DG=DBLE(GAMMA) DCDF=0.D0 C IF(GAMMA.EQ.0.0)THEN DTERM1=DEXP(DX) DCDF=1.0D0 - DEXP(-DTERM1) ELSE IF(GAMMA.GT.0.0.AND.X.EQ.-1.0/GAMMA)THEN DCDF=0.0D0 ELSEIF(GAMMA.LT.0.0.AND.X.EQ.-1.0/GAMMA)THEN DCDF=1.0D0 ELSE DTERM1=-(1.D0+DX*DG)**(1.D0/DG) DCDF=1.0D0 - DEXP(DTERM1) END IF END IF CDF=REAL(DCDF) ENDIF C 9999 CONTINUE RETURN END SUBROUTINE GEVCHA(X,GAMMA,MINMAX,CHAZ) C C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE HAZARD C FUNCTION VALUE FOR THE GENERALIZED EXTREME VALUE C DISTRIBUTION WITH SINGLE PRECISION C SHAPE PARAMETER = GAMMA. C THERE ARE TWO GENERALIZED EXTREME VALUE FAMALIES: C ONE BASED ON THE MAXIMUM ORDER STATISTIC (THE MOST C COMMONLY USED, SPECIFIED BY MINMAX=2) AND THE OTHER C BASED ON THE MINIMUM ORDER STATISTIC (SPECIFIED BY C SET MINMAX = 1). C C THE CUMUALTIVE DISTRIBUTION FUNCTION FOR THE MAXIMUM C CASE OF THE GENERALIZED EXTREME VALUE DISTRIBUTION IS: C F(X,G) = EXP(-EXP(-X)) G = 0 C = EXP(-(1 - GAMMA*X)**(1/GAMMA)] G <> 0 C 1 - GAMMA*X >= 0 C C THE CUMULATIVE DISTRIBUTION FUNCTION FOR THE MINIMUM CASE C OF THE GENERALIZED EXTREME VALUE DISTRIBUTION IS: C F(X,G) = 1 - EXP(-EXP(X)) G = 0 C = 1 - EXP(-(1 + GAMMA*X)**(1/GAMMA)] G <> 0 C 1 + GAMMA*X >= 0 C C THE CUMULATIVE HAZARD IS THEN C C H(X,G) = -LOG(1 - F(X,G)) C C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE C AT WHICH THE CUMULATIVE HAZARD C FUNCTION IS TO BE EVALUATED. C --GAMMA = THE SINGLE PRECISION VALUE C OF THE SHAPE PARAMETER. C --MINMAX = THE INTEGER VALUE THAT SPECIES C THE MINIMUM/MAXIMUM CASE. C OUTPUT ARGUMENTS--CHAZ = THE SINGLE PRECISION CUMULATIVE C HAZARD FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION CUMULATIVE HAZARD C FUNCTION VALUE CDF FOR THE GENERALIZED EXTREME VALUE C DISTRIBUTION WITH SHAPE PARAMETER VALUE = GAMMA. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--RANGE OF X DEPENDS ON SIGN OF GAMMA 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--2, 1994, PAGES 75-76 C --CASTILLO, HADI, BALAKRISHNAN, AND SARABIA, C "EXTREME VALUE AND RELATED MODELS WITH APPLICATIONS C IN ENGINEERING AND SCIENCE", WILEY, 2005, PP. 64-65. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING LABORATORY (205.03) C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE: 301-975-2855 C ORIGINAL VERSION--MAY 2005. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DX DOUBLE PRECISION DG DOUBLE PRECISION DCDF DOUBLE PRECISION DCHAZ 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 MAY 2005. HANDLE MIN AND MAX CASES SEPARATELY. C 4 FORMAT('****** ERROR FROM GEVCHAZ--THE CDF VALUE IS 1 WHICH ', 1 'RESULTS IN AN UNDEFINED CUMULATIVE HAZARD.') 46 FORMAT('****** THE VALUE OF THE INPUT ARGUMENT IS ',G15.7) 47 FORMAT('****** THE VALUE OF THE SHAPE PARAMETER IS ',G15.7) C C MAXIMUM CASE C IF(MINMAX.EQ.2 .OR. MINMAX.EQ.0)THEN C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(GAMMA.GT.0.0)THEN IF(X.GE.(1.0/GAMMA))THEN CHAZ=0.0 WRITE(ICOUT,4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)GAMMA CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF ELSEIF(GAMMA.LT.0.0)THEN IF(X.LE.(1.0/GAMMA))THEN CHAZ=0.0 GOTO9999 ENDIF ENDIF C DX=DBLE(X) DG=DBLE(GAMMA) DCDF=0.0D0 DCHAZ=0.0D0 C IF(GAMMA.EQ.0.0)THEN DTERM1=-DEXP(-DX) DCDF=DEXP(DTERM1) IF(DCDF.GE.1.0D0)THEN CHAZ=0.0 WRITE(ICOUT,4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)GAMMA CALL DPWRST('XXX','BUG ') GOTO9999 ELSE DCHAZ=-DLOG(1.0D0 - DCDF) ENDIF ELSE DTERM1=-(1.D0-DX*DG)**(1.D0/DG) DCDF=DEXP(DTERM1) IF(DCDF.GE.1.0D0)THEN CHAZ=0.0 WRITE(ICOUT,4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)GAMMA CALL DPWRST('XXX','BUG ') GOTO9999 ELSE DCHAZ=-DLOG(1.0D0 - DCDF) ENDIF ENDIF ELSE C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(GAMMA.GT.0.0)THEN IF(X.LE.(-1.0/GAMMA))THEN CHAZ=0.0 GOTO9999 ENDIF ELSEIF(GAMMA.LT.0.0)THEN IF(X.GE.(-1.0/GAMMA))THEN CHAZ=0.0 WRITE(ICOUT,4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)GAMMA CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF ENDIF C DX=DBLE(X) DG=DBLE(GAMMA) DCHAZ=0.D0 C IF(GAMMA.EQ.0.0)THEN DCHAZ=DEXP(DX) ELSE DCHAZ=(1.D0+DX*DG)**(1.D0/DG) END IF ENDIF CHAZ=REAL(DCHAZ) C 9999 CONTINUE RETURN END SUBROUTINE GEVHAZ(X,GAMMA,MINMAX,HAZ) C C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE HAZARD C FUNCTION VALUE FOR THE GENERALIZED EXTREME VALUE C DISTRIBUTION WITH SINGLE PRECISION C SHAPE PARAMETER = GAMMA. C THERE ARE TWO GENERALIZED EXTREME VALUE FAMALIES: C ONE BASED ON THE MAXIMUM ORDER STATISTIC (THE MOST C COMMONLY USED, SPECIFIED BY MINMAX=2) AND THE OTHER C BASED ON THE MINIMUM ORDER STATISTIC (SPECIFIED BY C SET MINMAX = 1). C C THE HAZARD IS DEFINED AS C C H(X,G) = f(X,G)/(1 - F(X,G)) C C WHERE f AND F ARE THE PROBABILITY DENSITY AND C CUMULATIVE DISTRIBUTION FUNCTIONS, RESPECTIVELY. C C FOR THE MAXIMUM CASE, THIS ROUTINE CALLS GEVPDF AND C GEVCDF AND THEN USES THE ABOVE FORMULA. FOR THE C MINIMUM CASE, THE HAZARD FUNCTION REDUCES TO: C C H(X,G) = (1 + G*X)**((1/G)-1) G <> 0 C H(X,G) = EXP(X) G = 0 C C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE C AT WHICH THE HAZARD FUNCTION IS TO C BE EVALUATED. C --GAMMA = THE SINGLE PRECISION VALUE C OF THE SHAPE PARAMETER. C --MINMAX = THE INTEGER VALUE THAT SPECIFIES C THE MINIMUM/MAXIMUM CASE C OUTPUT ARGUMENTS--HAZ = THE SINGLE PRECISION HAZARD C FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION HAZARD FUNCTION VALUE HAZ FOR THE C GENERALIZED EXTREME VALUE DISTRIBUTION WITH C SHAPE PARAMETER VALUE = GAMMA. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--RANGE OF X DEPENDS ON SIGN OF GAMMA 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--2, 1994, PAGES 75-76 C --CASTILLO, HADI, BALAKRISHNAN, AND SARABIA, C "EXTREME VALUE AND RELATED MODELS WITH APPLICATIONS C IN ENGINEERING AND SCIENCE", WILEY, 2005, PP. 64-65. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING LABORATORY (205.03) C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE: 301-975-2855 C ORIGINAL VERSION--MAY 2005. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DX DOUBLE PRECISION DG DOUBLE PRECISION DHAZ 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 MAY 2005. HANDLE MIN AND MAX CASES SEPARATELY. C C MAXIMUM CASE C IF(MINMAX.EQ.2 .OR. MINMAX.EQ.0)THEN C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(GAMMA.GT.0.0)THEN IF(X.GT.(1.0/GAMMA))THEN WRITE(ICOUT,4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)GAMMA CALL DPWRST('XXX','BUG ') HAZ=0.0 GOTO9999 ENDIF ELSEIF(GAMMA.LT.0.0)THEN IF(X.LT.(1.0/GAMMA))THEN WRITE(ICOUT,14) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)GAMMA CALL DPWRST('XXX','BUG ') HAZ=0.0 GOTO9999 ENDIF ENDIF 4 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO GEVHAZ ', 1 'IS GREATER THAN 1/GAMMA.') 14 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO GEVHAZ ', 1 'IS LESS THAN 1/GAMMA.') 16 FORMAT('***** ERROR--FOR THE GEVHAZ FUNCTION, THE ', 1 'CDF IS EQUAL TO 1.') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7) 47 FORMAT('***** THE VALUE OF GAMMA IS ',G15.7) C CALL GEVCDF(X,GAMMA,MINMAX,CDF) IF(CDF.GE.1.0)THEN WRITE(ICOUT,16) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)GAMMA CALL DPWRST('XXX','BUG ') HAZ=0.0 GOTO9999 ENDIF CALL GEVPDF(X,GAMMA,MINMAX,PDF) HAZ=PDF/(1.0 - CDF) ELSE C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(GAMMA.GT.0.0)THEN IF(X.LE.(-1.0/GAMMA))THEN WRITE(ICOUT,24) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)GAMMA CALL DPWRST('XXX','BUG ') HAZ=0.0 GOTO9999 ENDIF ELSEIF(GAMMA.LT.0.0)THEN IF(X.GE.(-1.0/GAMMA))THEN WRITE(ICOUT,34) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)GAMMA CALL DPWRST('XXX','BUG ') HAZ=0.0 GOTO9999 ENDIF ENDIF 24 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO GEVHAZ ', 1 'IS LESS THAN -1/GAMMA.') 34 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO GEVHAZ ', 1 'IS GREATER THAN -1/GAMMA.') C DX=DBLE(X) DG=DBLE(GAMMA) DHAZ=0.D0 C IF(GAMMA.EQ.0.0)THEN DHAZ=DEXP(DX) ELSE DHAZ=(1.0D0+DX*DG)**((1.D0/DG)-1.0) END IF HAZ=REAL(DHAZ) ENDIF C 9999 CONTINUE RETURN END SUBROUTINE GEVPDF(X,GAMMA,MINMAX,PDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY C FUNCTION VALUE FOR THE GENERALIZED EXTREME VALUE C DISTRIBUTION WITH SINGLE PRECISION C SHAPE PARAMETER = GAMMA. C THERE ARE TWO GENERALIZED EXTREME VALUE FAMALIES: C ONE BASED ON THE MAXIMUM ORDER STATISTIC (THE MOST C COMMONLY USED, SPECIFIED BY MINMAX=2) AND THE OTHER C BASED ON THE MINIMUM ORDER STATISTIC (SPECIFIED BY C SET MINMAX = 1). C C THE PROBABILITY DENSITY FUNCTION FOR THE MAXIMUM CASE C OF THE GENERALIZED EXTREME VALUE DISTRIBUTION IS: C F(X,G) = EXP(-EXP(-X))*EXP(-X) G = 0 C = EXP(-(1-G*X)**(1/G))*(1-G*X)**((1/G)-1) G<>0 C X<=1/G FOR G > 0 C X>=1/G FOR G < 0 C C THE PROBABILITY DENSITY FUNCTION FOR THE MINIMUM CASE C OF THE GENERALIZED EXTREME VALUE DISTRIBUTION IS: C F(X,G) = EXP(-EXP(X))*EXP(X) G = 0 C = EXP(-(1+G*X)**(1/G))*(1+G*X)**((1/G)-1) G<>0 C X>=1/G FOR G > 0 C X<=1/G FOR G < 0 C C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE C AT WHICH THE PROBABILITY DENSITY C FUNCTION IS TO BE EVALUATED. C --GAMMA = THE SINGLE PRECISION VALUE C OF THE SHAPE PARAMETER. C OUTPUT ARGUMENTS--PDF = THE SINGLE PRECISION PROBABILITY C DENSITY FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY C FUNCTION VALUE PDF FOR THE GENERALIZED EXTREME VALUE C DISTRIBUTION WITH SHAPE PARAMETER VALUE = GAMMA. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--RANGE OF X DEPENDS ON SIGN OF GAMMA 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--2, 1994, PAGES 75-76 C --CASTILLO, HADI, BALAKRISHNAN, AND SARABIA, C "EXTREME VALUE AND RELATED MODELS WITH APPLICATIONS C IN ENGINEERING AND SCIENCE", WILEY, 2005, PP. 64-65. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING LABORATORY (205.03) C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE: 301-975-2855 C ORIGINAL VERSION--APRIL 1994. C UPDATED --MAY 2005. SUPPORT FOR MINIMUM CASE C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DX, DG DOUBLE PRECISION DPDF DOUBLE PRECISION DTERM1, DTERM2, DTERM3 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 C MAY 2005. HANDLE MIN AND MAX CASES SEPARATELY. C C MAXIMUM CASE C IF(MINMAX.EQ.2 .OR. MINMAX.EQ.0)THEN C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(GAMMA.GT.0.0)THEN IF(X.GT.(1.0/GAMMA))THEN WRITE(ICOUT,4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)GAMMA CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ENDIF ELSEIF(GAMMA.LT.0.0)THEN IF(X.LT.(1.0/GAMMA))THEN WRITE(ICOUT,14) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)GAMMA CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ENDIF ENDIF 4 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO GEVPDF ', 1 'IS GREATER THAN 1/GAMMA.') 14 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO GEVPDF ', 1 'IS LESS THAN 1/GAMMA.') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7) 47 FORMAT('***** THE VALUE OF GAMMA IS ',G15.7) C DX=DBLE(X) DG=DBLE(GAMMA) C IF(GAMMA.EQ.0.0)THEN DTERM1=-DX IF(ABS(DTERM1).GE.500.D0)THEN PDF=0.0 ELSE DTERM2=-DEXP(-DX) - DX DPDF=0.D0 IF(DABS(DTERM2).LE.500.D0)DPDF=DEXP(DTERM2) PDF=REAL(DPDF) ENDIF ELSE DTERM1=-(1.D0-DX*DG)**(1.D0/DG) DTERM2=((1.D0/DG)-1.D0)*DLOG(1.D0-DX*DG) DTERM3=DTERM1+DTERM2 DPDF=0.D0 IF(DABS(DTERM3).LE.500.D0)DPDF=DEXP(DTERM3) PDF=REAL(DPDF) END IF C C MINIMUM CASE C ELSE C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(GAMMA.GT.0.0)THEN IF(X.LT.(-1.0/GAMMA))THEN WRITE(ICOUT,24) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)GAMMA CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ENDIF ELSEIF(GAMMA.LT.0.0)THEN IF(X.GT.(-1.0/GAMMA))THEN WRITE(ICOUT,34) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)GAMMA CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ENDIF ENDIF 24 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO GEVPDF ', 1 'IS LESS THAN -1/GAMMA.') 34 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO GEVPDF ', 1 'IS GREATER THAN -1/GAMMA.') C DX=DBLE(X) DG=DBLE(GAMMA) C IF(GAMMA.EQ.0.0)THEN DTERM1=-DX IF(ABS(DTERM1).GE.500.D0)THEN PDF=0.0 ELSE DTERM2=-DEXP(DX) + DX DPDF=0.D0 IF(DABS(DTERM2).LE.500.D0)DPDF=DEXP(DTERM2) PDF=REAL(DPDF) ENDIF ELSE DTERM1=-(1.D0+DX*DG)**(1.D0/DG) DTERM2=((1.D0/DG)-1.D0)*DLOG(1.D0+DX*DG) DTERM3=DTERM1+DTERM2 DPDF=0.D0 IF(DABS(DTERM3).LE.500.D0)DPDF=DEXP(DTERM3) PDF=REAL(DPDF) END IF ENDIF C 9999 CONTINUE RETURN END C===================================================== PELGEV.FOR SUBROUTINE GEVPEL(XMOM,PARA) C*********************************************************************** C* * C* FORTRAN CODE WRITTEN FOR INCLUSION IN IBM RESEARCH REPORT RC20525, * C* 'FORTRAN ROUTINES FOR USE WITH THE METHOD OF L-MOMENTS, VERSION 3' * C* * C* J. R. M. HOSKING * C* IBM RESEARCH DIVISION * C* T. J. WATSON RESEARCH CENTER * C* YORKTOWN HEIGHTS * C* NEW YORK 10598, U.S.A. * C* * C* VERSION 3 AUGUST 1996 * C* * C*********************************************************************** C C PARAMETER ESTIMATION VIA L-MOMENTS FOR THE GENERALIZED EXTREME-VALUE C DISTRIBUTION C C PARAMETERS OF ROUTINE: C XMOM * INPUT* ARRAY OF LENGTH 3. CONTAINS THE L-MOMENTS LAMBDA-1, C LAMBDA-2, TAU-3. C PARA *OUTPUT* ARRAY OF LENGTH 3. ON EXIT, CONTAINS THE PARAMETERS C IN THE ORDER XI, ALPHA, K (LOCATION, SCALE, SHAPE). C C OTHER ROUTINES USED: DLGAMA C C METHOD: FOR -0.8 LE TAU3 LT 1, K IS APPROXIMATED BY RATIONAL C FUNCTIONS AS IN DONALDSON (1996, COMMUN. STATIST. SIMUL. COMPUT.). C IF TAU3 IS OUTSIDE THIS RANGE, NEWTON-RAPHSON ITERATION IS USED. C IMPLICIT DOUBLE PRECISION (A-H,O-Z) DOUBLE PRECISION XMOM(3),PARA(3) DOUBLE PRECISION DLNGAM EXTERNAL DLNGAM C REAL CPUMIN REAL CPUMAX CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C DATA ZERO/0D0/,HALF/0.5D0/,ONE/1D0/,TWO/2D0/,THREE/3D0/ DATA P8/0.8D0/,P97/0.97D0/ C C SMALL IS USED TO TEST WHETHER K IS EFFECTIVELY ZERO C EPS,MAXIT CONTROL THE TEST FOR CONVERGENCE OF N-R ITERATION C DATA SMALL/1D-5/,EPS/1D-6/,MAXIT/20/ C C EU IS EULER'S CONSTANT C DL2 IS LOG(2), DL3 IS LOG(3) C DATA EU/0.57721566D0/,DL2/0.69314718D0/,DL3/1.0986123D0/ C C COEFFICIENTS OF RATIONAL-FUNCTION APPROXIMATIONS FOR K C DATA A0,A1,A2/ 0.28377530D0,-1.21096399D0,-2.50728214D0/ DATA A3,A4 /-1.13455566D0,-0.07138022D0/ DATA B1,B2,B3/ 2.06189696D0, 1.31912239D0, 0.25077104D0/ DATA C1,C2,C3/ 1.59921491D0,-0.48832213D0, 0.01573152D0/ DATA D1,D2 /-0.64363929D0, 0.08985247D0/ C T3=XMOM(3) IF(XMOM(2).LE.ZERO)THEN WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7000) 7000 FORMAT('****** ERROR IN GENERALIZED EXTREME VALUE L-MOMENTS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7003) 7003 FORMAT(' L-MOMENTS INVALID.') CALL DPWRST('XXX','BUG ') PARA(1)=CPUMIN PARA(2)=CPUMIN PARA(3)=CPUMIN GOTO9000 ELSEIF(DABS(T3).GE.ONE)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7000) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7003) CALL DPWRST('XXX','BUG ') PARA(1)=CPUMIN PARA(2)=CPUMIN PARA(3)=CPUMIN GOTO9000 ENDIF C C PARA(1)=0.0D0 PARA(2)=1.0D0 PARA(3)=0.0D0 IF(T3.LE.ZERO)GOTO 10 C C RATIONAL-FUNCTION APPROXIMATION FOR TAU3 BETWEEN 0 AND 1 C Z=ONE-T3 G=(-ONE+Z*(C1+Z*(C2+Z*C3)))/(ONE+Z*(D1+Z*D2)) IF(DABS(G).LT.SMALL)GOTO 50 GOTO 40 C C RATIONAL-FUNCTION APPROXIMATION FOR TAU3 BETWEEN -0.8 AND 0 C 10 CONTINUE G=(A0+T3*(A1+T3*(A2+T3*(A3+T3*A4))))/(ONE+T3*(B1+T3*(B2+T3*B3))) IF(T3.GE.-P8)GOTO 40 C C NEWTON-RAPHSON ITERATION FOR TAU3 LESS THAN -0.8 C IF(T3.LE.-P97)G=ONE-DLOG(ONE+T3)/DL2 T0=(T3+THREE)*HALF DO 20 IT=1,MAXIT X2=TWO**(-G) X3=THREE**(-G) XX2=ONE-X2 XX3=ONE-X3 T=XX3/XX2 DERIV=(XX2*X3*DL3-XX3*X2*DL2)/(XX2*XX2) GOLD=G G=G-(T-T0)/DERIV IF(DABS(G-GOLD).LE.EPS*G)GOTO 30 20 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7000) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7010) 7010 FORMAT('****** WARNING FROM GENERALIZED EXTREME VALUE ', 1 'L-MOMENTS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7013) 7013 FORMAT(' ITERATION HAS NOT CONVERGED. RESULTS MAY ', 1 'BE UNRELIABLE.') CALL DPWRST('XXX','BUG ') 30 CONTINUE C C ESTIMATE ALPHA,XI C 40 CONTINUE PARA(3)=G CCCCC GAM=DEXP(DLGAMA(ONE+G)) GAM=DEXP(DLNGAM(ONE+G)) PARA(2)=XMOM(2)*G/(GAM*(ONE-TWO**(-G))) PARA(1)=XMOM(1)-PARA(2)*(ONE-GAM)/G GOTO9000 C C ESTIMATED K EFFECTIVELY ZERO C 50 CONTINUE PARA(3)=ZERO PARA(2)=XMOM(2)/DL2 PARA(1)=XMOM(1)-EU*PARA(2) C 9000 CONTINUE RETURN END SUBROUTINE GEVPPF(P,GAMMA,MINMAX,PPF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT C FUNCTION VALUE FOR THE GENERALIZED EXTREME VALUE C DISTRIBUTION WITH SINGLE PRECISION C SHAPE PARAMETER = GAMMA. C THERE ARE TWO GENERALIZED EXTREME VALUE FAMALIES: C ONE BASED ON THE MAXIMUM ORDER STATISTIC (THE MOST C COMMONLY USED, SPECIFIED BY MINMAX=2) AND THE OTHER C BASED ON THE MINIMUM ORDER STATISTIC (SPECIFIED BY C SET MINMAX = 1). C C THE PERCENT POINT FUNCTION FOR THE MAXIMUM CASE C OF THE GENERALIZED EXTREME VALUE DISTRIBUTION IS: C G(P,G) = -LOG(-(LOG(P))) G = 0 C = (1 - (-LOG(P)**G)/G G <> 0 C C THE PERCENT POINT FUNCTION FOR THE MINIMUM CASE C OF THE GENERALIZED EXTREME VALUE DISTRIBUTION IS: C G(P,G) = LOG(-(LOG(1-P))) G = 0 C = -(1 - (-LOG(1-P)**G)/G G <> 0 C 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 --GAMMA = THE SINGLE PRECISION VALUE C OF THE TAIL LENGTH PARAMETER. 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 GENERALIZED EXTREME VALUE DISTRIBUTION C WITH TAIL LENGTH PARAMETER VALUE = GAMMA. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--GAMMA CAN HAVE ANY VALUE C --P SHOULD BE BETWEEN 0.0 AND 1.0. C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--ALOG. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE C DISTRIBUTIONS--2, 1994, PAGES 75-76 C --CASTILLO, HADI, BALAKRISHNAN, AND SARABIA, C "EXTREME VALUE AND RELATED MODELS WITH APPLICATIONS C IN ENGINEERING AND SCIENCE", WILEY, 2005, PP. 64-65. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--95/10 C ORIGINAL VERSION--OCTOBER 1995. C UPDATED --MAY 2005. SUPPORT FOR MINIMUM CASE C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C C--------------------------------------------------------------------- C DOUBLE PRECISION DPPF DOUBLE PRECISION DP DOUBLE PRECISION DG C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(GAMMA.EQ.0.0)THEN IF(P.LE.0.0.OR.P.GE.1.0)THEN WRITE(ICOUT,1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)P CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9999 ENDIF ENDIF C IF(MINMAX.EQ.2 .OR. MINMAX.EQ.0)THEN IF(GAMMA.GT.0.0)THEN IF(P.LE.0.0.OR.P.GT.1.0)THEN WRITE(ICOUT,1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)P CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9999 ENDIF ELSE IF(P.LT.0.0.OR.P.GE.1.0)THEN WRITE(ICOUT,1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)P CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9999 ENDIF ENDIF ELSE IF(GAMMA.GT.0.0)THEN IF(P.LT.0.0.OR.P.GE.1.0)THEN WRITE(ICOUT,1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)P CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9999 ENDIF ELSE IF(P.LE.0.0.OR.P.GT.1.0)THEN WRITE(ICOUT,1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)P CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9999 ENDIF ENDIF ENDIF C 1 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO GEVPPF ', 1'IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7) C DP=DBLE(P) DG=DBLE(GAMMA) DPPF=0.0D0 C IF(MINMAX.EQ.2 .OR. MINMAX.EQ.0)THEN IF(GAMMA.EQ.0.0)THEN DPPF=-DLOG(-DLOG(DP)) ELSE IF(GAMMA.GT.0.0.AND.P.EQ.1.0)THEN DPPF=1.0D0/DG ELSE IF(GAMMA.LT.0.0.AND.P.EQ.0.0)THEN DPPF=1.0D0/DG ELSE DPPF=(1.0D0 - (-DLOG(DP))**DG)/DG ENDIF ELSE IF(GAMMA.EQ.0.0)THEN DPPF=DLOG(-DLOG(1.0D0 - DP)) ELSE IF(GAMMA.GT.0.0.AND.P.EQ.0.0)THEN DPPF=-1.0D0/DG ELSE IF(GAMMA.LT.0.0.AND.P.EQ.1.0)THEN DPPF=-1.0D0/DG ELSE DPPF=-(1.0D0 - (-DLOG(1.0D0 - DP))**DG)/DG ENDIF ENDIF C PPF=REAL(DPPF) C 9999 CONTINUE RETURN END SUBROUTINE GEVRAN(N,GAMMA,MINMAX,ISEED,X) C C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N C FROM THE GENERALIZED EXTREME VALUE DISTRIBUTION C WITH TAIL LENGTH PARAMETER VALUE = GAMMA. C THERE ARE TWO GENERALIZED EXTREME VALUE FAMALIES: C ONE BASED ON THE MAXIMUM ORDER STATISTIC (THE MOST C COMMONLY USED, SPECIFIED BY MINMAX=2) AND THE OTHER C BASED ON THE MINIMUM ORDER STATISTIC (SPECIFIED BY C SET MINMAX = 1). C INPUT ARGUMENTS--N = THE DESIRED INTEGER NUMBER C OF RANDOM NUMBERS TO BE C GENERATED. C --GAMMA = THE SINGLE PRECISION VALUE OF THE C TAIL LENGTH PARAMETER. C GAMMA SHOULD BE POSITIVE. C --MINMAX = THE INTEGER VALUE WHICH SPECIFIES C WHETHER THE MAXIMUM OR THE MINIMUM C FAMILY IS BEING 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 GENERALIZED EXTREME VALUE DISTRIBUTION C WITH TAIL LENGTH PARAMETER VALUE = GAMMA. 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 REFERENCES--CASTILLO, HADI, BALAKRISHNAN, AND SARABIA, C "EXTREME VALUE AND RELATED MODELS WITH APPLICATIONS C IN ENGINEERING AND SCIENCE", WILEY, 2005, PP. 64-65. C --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE C DISTRIBUTIONS--2, 2ND. ED., 1994. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2001.10 C ORIGINAL VERSION--OCTOBER 2001. C UPDATED --MAY 2005. SUPPORT FOR MINIMUM CASE 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,6) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)N CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF 5 FORMAT('***** ERROR--THE NUMBER OF REQUESTED GENERALIZED ', 1 'EXTREME VALUE') 6 FORMAT(' RANDOM NUMBERS WAS NOT 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 GENERALIZED EXTREME VALUE DISTRIBUTION RANDOM NUMBERS C USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD. C DO100I=1,N CALL GEVPPF(X(I),GAMMA,MINMAX,XTEMP) X(I)=XTEMP 100 CONTINUE C 9000 CONTINUE RETURN END SUBROUTINE GEXCDF(X,ALAM1,ALAM12,S,CDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION C FUNCTION VALUE FOR THE GENERALIZED EXPONENTIAL C DISTRIBUTION C THIS DISTRIBUTION IS DEFINED FOR ALL NON-NEGATIVE X, C AND HAS THE PROBABILITY DENSITY FUNCTION C F(X) = (L1+L12*(1-EXP(-S*X)))* C EXP[-L1*X-L12*X+(L12/S)*(1-EXP(-S*X))] C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE AT C WHICH THE CUMULATIVE DISTRIBUTION C FUNCTION IS TO BE EVALUATED. C --ALAM1 = POSITIVE SHAPE PARAMETER C --ALAM12 = POSITIVE SHAPE PARAMETER C --S = POSITIVE SHAPE PARAMETER C OUTPUT ARGUMENTS--CDF = THE SINGLE PRECISION PROBABILITY C DENSITY FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION C FUNCTION VALUE CDF. 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--DEXP, DLOG. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN. C REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE C DISTRIBUTIONS--1, 2ND. ED., 1994, PAGES 555. C --RYU, "AN EXTENSION OF MARSHALL AND OLKIN'S BIVARIATE C EXPONENTIAL DISTRIBUTION", JOURNAL OF THE AMERICAN C STATISTICAL ASSOCIATION, 1993, PP. 1458-1465. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE: 301-975-2855 C ORIGINAL VERSION--FEBRUARY 1996. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DX, DLAM1, DLAM12, DS, 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.0.0)THEN WRITE(ICOUT,4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9999 ENDIF IF(ALAM1.LE.0.0)THEN WRITE(ICOUT,14) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9999 ENDIF IF(ALAM12.LE.0.0)THEN WRITE(ICOUT,24) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9999 ENDIF IF(S.LE.0.0)THEN WRITE(ICOUT,34) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9999 ENDIF 4 FORMAT('***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT ', 1'TO THE GEXCDF SUBROUTINE IS NEGATIVE') 14 FORMAT('***** FATAL DIAGNOSTIC--THE SECOND INPUT ARGUMENT ', 1'TO THE GEXCDF SUBROUTINE IS NON-POSITIVE') 24 FORMAT('***** FATAL DIAGNOSTIC--THE THIRD INPUT ARGUMENT ', 1'TO THE GEXCDF SUBROUTINE IS NON-POSITIVE') 34 FORMAT('***** FATAL DIAGNOSTIC--THE FOURTH INPUT ARGUMENT ', 1'TO THE GEXCDF SUBROUTINE IS NON-POSITIVE') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') C C-----START POINT----------------------------------------------------- C DX=DBLE(X) DLAM1=DBLE(ALAM1) DLAM12=DBLE(ALAM12) DS=DBLE(S) C IF(X.LE.0.0)THEN CDF=0.0 GOTO9999 ENDIF C DTERM1=-DLAM1*X - DLAM12*DX + (DLAM12/DS)*(1.0D0-DEXP(-DS*DX)) IF(DTERM1.LE.-65.0D0)THEN CDF=1.0 ELSEIF(DTERM1.GE.65.D0)THEN CDF=1.0 WRITE(ICOUT,101)X CALL DPWRST('XXX','BUG ') ELSE DCDF=1.0D0-DEXP(DTERM1) CDF=SNGL(DCDF) ENDIF 101 FORMAT('***** FATAL DIAGNOSTIC--OVERFLOW IN GEXCDF ROUTINE ', 1'FOR X = ',E15.7) C 9999 CONTINUE RETURN END SUBROUTINE GEXPDF(X,ALAM1,ALAM12,S,PDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY C FUNCTION VALUE FOR THE GENERALIZED EXPONENTIAL C DISTRIBUTION C THIS DISTRIBUTION IS DEFINED FOR ALL NON-NEGATIVE X, C AND HAS THE PROBABILITY DENSITY FUNCTION C F(X) = (L1+L12*(1-EXP(-S*X)))* C EXP[-L1*X-L12*X+(L12/S)*(1-EXP(-S*X))] C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE AT C WHICH THE PROBABILITY DENSITY C FUNCTION IS TO BE EVALUATED. C --ALAM1 = POSITIVE SHAPE PARAMETER C --ALAM12 = POSITIVE SHAPE PARAMETER C --S = POSITIVE 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 NON-NEGATIVE. C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--DEXP, DLOG. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN. C REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE C DISTRIBUTIONS--1, 2ND. ED., 1994, PAGES 555. C --RYU, "AN EXTENSION OF MARSHALL AND OLKIN'S BIVARIATE C EXPONENTIAL DISTRIBUTION", JOURNAL OF THE AMERICAN C STATISTICAL ASSOCIATION, 1993, PP. 1458-1465. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE: 301-975-2855 C ORIGINAL VERSION--FEBRUARY 1996. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DX, DLAM1, DLAM12, DS, DPDF DOUBLE PRECISION DTERM1, DTERM2, DTERM3 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.0.0)THEN WRITE(ICOUT,4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ENDIF IF(ALAM1.LE.0.0)THEN WRITE(ICOUT,14) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ENDIF IF(ALAM12.LE.0.0)THEN WRITE(ICOUT,24) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ENDIF IF(S.LE.0.0)THEN WRITE(ICOUT,34) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ENDIF 4 FORMAT('***** FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT ', 1'TO THE GEXPDF SUBROUTINE IS NEGATIVE') 14 FORMAT('***** FATAL DIAGNOSTIC--THE SECOND INPUT ARGUMENT ', 1'TO THE GEXPDF SUBROUTINE IS NON-POSITIVE') 24 FORMAT('***** FATAL DIAGNOSTIC--THE THIRD INPUT ARGUMENT ', 1'TO THE GEXPDF SUBROUTINE IS NON-POSITIVE') 34 FORMAT('***** FATAL DIAGNOSTIC--THE FOURTH INPUT ARGUMENT ', 1'TO THE GEXPDF SUBROUTINE IS NON-POSITIVE') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') C C-----START POINT----------------------------------------------------- C DX=DBLE(X) DLAM1=DBLE(ALAM1) DLAM12=DBLE(ALAM12) DS=DBLE(S) C DTERM1=DLOG(DLAM1 + DLAM12*(1.0D0-DEXP(-DS*DX))) DTERM2=-DLAM1*X - DLAM12*DX + (DLAM12/DS)*(1.0D0-DEXP(-DS*DX)) DTERM3=DTERM1+DTERM2 IF(DTERM3.LE.-80.0D0)THEN PDF=0.0 GOTO9999 ELSEIF(DTERM3.GE.80.D0)THEN PDF=0.0 WRITE(ICOUT,101)X CALL DPWRST('XXX','BUG ') ELSE DPDF=DEXP(DTERM3) PDF=SNGL(DPDF) ENDIF 101 FORMAT('***** FATAL DIAGNOSTIC--OVERFLOW IN GEXPDF ROUTINE ', 1'FOR X = ',E15.7) C 9999 CONTINUE RETURN END SUBROUTINE GEXPPF(P,ALAM1,ALAM2,S,PPF) C C PURPOSE --PERCENT POINT FUNCTION FOR THE GENERALIZED C EXPONENTIAL DISTRIBUTION. USES A BISECTION C METHOD. C INPUT ARGUMENTS--P = THE SINGLE PRECISION VALUE AT C WHICH THE PERCENT POINT C FUNCTION IS TO BE EVALUATED. C --ALAM1 = POSITIVE SHAPE PARAMETER C --ALAM12 = POSITIVE SHAPE PARAMETER C --S = POSITIVE 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--X SHOULD BE NON-NEGATIVE. C OTHER DATAPAC SUBROUTINES NEEDED--GEXCDF. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN. C REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE C DISTRIBUTIONS--1, 2ND. ED., 1994, PAGES 555. C --RYU, "AN EXTENSION OF MARSHALL AND OLKIN'S BIVARIATE C EXPONENTIAL DISTRIBUTION", JOURNAL OF THE AMERICAN C STATISTICAL ASSOCIATION, 1993, PP. 1458-1465. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--96/2 C ORIGINAL VERSION--FEBRUARY 1996. 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 DATA EPS /0.0001/ DATA SIG /1.0E-5/ DATA ZERO /0./ DATA MAXIT /50000/ C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(P.LT.0.0.OR.P.GE.1.0)THEN WRITE(ICOUT,1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)P CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9999 ENDIF IF(ALAM1.LE.0.0)THEN WRITE(ICOUT,11) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)ALAM1 CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9999 ENDIF IF(ALAM2.LE.0.0)THEN WRITE(ICOUT,12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)ALAM2 CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9999 ENDIF IF(S.LE.0.0)THEN WRITE(ICOUT,35) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)S CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9999 ENDIF C 1 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ', 1' GEXPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL') 11 FORMAT('***** FATAL ERROR--THE 2ND INPUT ARGUMENT TO THE ', 1' GEXPPF SUBROUTINE IS NON-POSITIVE.') 12 FORMAT('***** FATAL ERROR--THE THIRD INPUT ARGUMENT TO THE ', 1' GEXPPF SUBROUTINE IS NON-POSITIVE.') 35 FORMAT('***** FATAL ERROR--THE FOURTH INPUT ARGUMENT TO THE ', 1' GEXPPF SUBROUTINE IS NEGATIVE *****') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') C C FIND BRACKETING INTERVAL. USE 0. C AS INITIAL GUESS, INCREMENTS OF 10 AROUND IT. C AFTER SUCCESSFULLY FIND BRACKETING INTERVAL, THEN SWITCH TO C MORE EFFICIENT BISECTION METHOD. C XINC=10.0 XL=0.0 ICOUNT=0 MAXCNT=100000 C 91 CONTINUE XR=XL+XINC IF(XL.LE.0.0)XL=0.0 IF(XR.LE.0.0)XR=XL+1.0 CALL GEXCDF(XL,ALAM1,ALAM2,S,CDFL) CALL GEXCDF(XR,ALAM1,ALAM2,S,CDFR) IF(CDFL.LT.P .AND. CDFR.LT.P)THEN XL=XR ELSEIF(CDFL.GT.P .AND. CDFR.GT.P)THEN XL=XL-XINC ELSE GOTO99 ENDIF ICOUNT=ICOUNT+1 IF(ICOUNT.GT.MAXCNT)THEN WRITE(ICOUT,96) CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9999 ENDIF 96 FORMAT('***** FATAL ERROR--GEXPPF 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 GEXCDF(X,ALAM1,ALAM2,S,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 IF(ABS(FCS).GT.EPS)THEN WRITE(ICOUT,130) CALL DPWRST('XXX','BUG ') ENDIF 130 FORMAT('***** FATAL ERROR--GEXPPF ROUTINE DID NOT CONVERGE. ***') GOTO9999 C 9999 CONTINUE RETURN END SUBROUTINE GEXRAN(N,ALAM1,ALAM12,S,ISEED,X) C C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N C FROM THE GENERALIZED EXPONENTIAL DISTRIBUTION C WITH SHAPE PARAMETERS = LAMBDA1, LAMBDA12, S. C THIS DISTRIBUTION IS DEFINED FOR ALL NON-NEGATIVE X, C AND HAS THE PROBABILITY DENSITY FUNCTION C F(X) = (L1+L12*(1-EXP(-S*X)))* C EXP[-L1*X-L12*X+(L12/S)*(1-EXP(-S*X))] C INPUT ARGUMENTS--N = THE DESIRED INTEGER NUMBER C OF RANDOM NUMBERS TO BE C GENERATED. C --ALAM1 = THE SINGLE PRECISION VALUE OF THE C LAMBDA1 SHAPE PARAMETER. C ANU SHOULD BE A POSITIVE INTEGER. C --ALAM12 = THE SINGLE PRECISION VALUE OF THE C LAMBDA12 SHAPE PARAMETER. C --S = THE SINGLE PRECISION VALUE OF THE C S SHAPE PARAMETER. C OUTPUT ARGUMENTS--X = A SINGLE PRECISION VECTOR C (OF DIMENSION AT LEAST N) C INTO WHICH THE GENERATED C RANDOM SAMPLE WILL BE PLACED. C OUTPUT--A RANDOM SAMPLE OF SIZE N C FROM THE GENERALIZED EXPONENTIAL DISTRIBUTION C WITH SHAPE PARAMETER VALUES = ALAM1, ALAM12, AND S. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C --ANU SHOULD BE POSITIVE. C OTHER DATAPAC SUBROUTINES NEEDED--UNIRAN. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (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-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(N.LT.1)THEN WRITE(ICOUT, 5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)N CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF 5 FORMAT('***** FATAL ERROR--THE REQUESTED NUMBER OF GENERALIZED ', 1 'EXPONENTIAL RANDOM NUMBERS IS NON-POSITIVE.') 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8) C IF(ALAM1.LE.0)THEN WRITE(ICOUT,15) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,16) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)ALAM1 CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ENDIF 15 FORMAT('***** FATAL ERROR--THE FIRST SHAPE PARAMETER (LAMBDA1)') 16 FORMAT(' FOR THE GENERALIZED EXPONENTIAL RANDOM NUMBERS ', 1 'IS NON-POSITIVE') IF(ALAM12.LE.0)THEN WRITE(ICOUT,25) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,26) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)ALAM12 CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ENDIF 25 FORMAT('***** FATAL ERROR--THE SECOND SHAPE PARAMETER ', 1 '(LAMBDA12) ') 26 FORMAT(' FOR THE GENERALIZED EXPONENTIAL RANDOM NUMBERS ', 1 'IS NON-POSITIVE') IF(S.LE.0)THEN WRITE(ICOUT,35) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,36) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)S CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ENDIF 35 FORMAT('***** FATAL ERROR--THE THIRD SHAPE PARAMETER (S) ') 36 FORMAT(' FOR THE GENERALIZED EXPONENTIAL RANDOM NUMBERS ', 1 'IS NON-POSITIVE') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') C C GENERATE N UNIFORM (0,1) RANDOM NUMBERS; C CALL UNIRAN(N,ISEED,X) C C GENERATE N GENERALIZED EXPONENTIAL DISTRIBUTION RANDOM C NUMBERS USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD. C DO100I=1,N CALL GEXPPF(X(I),ALAM1,ALAM12,S,XTEMP) X(I)=XTEMP 100 CONTINUE C 9999 CONTINUE RETURN END SUBROUTINE GGDCDF(X,ALPHA,C,CDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION C FUNCTION VALUE FOR THE GENERALIZED GAMMA DISTRIBUTION C WITH POSITIVE SHAPE PARAMETERS ALPHA AND C. C THIS DISTRIBUTION IS DEFINED FOR ALL NON-NEGATIVE X. C THE PROBABILITY DENSITY FUNCTION IS GIVEN C IN THE REFERENCES BELOW. C THE CDF FOR THE STANDARD FORM OF THE DISTRIBUTION IS C F(X,ALPAH,C) = GAMMAIP(X**C,ALPHA) C WHERE GAMMAIP = GAMMAI(ALPHA,X)/GAMMA(ALPHA). C THE CDF IS CAN BE COMPUTED WITH THE SLATEC ROUTINE C DGAMIC. 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 --ALPHA = A POSITIVE SHAPE PARAMETER C --C = A POSITIVE 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 FOR THE GENERALIZED GAMMA DISTRIBUTION C WITH DEGREES OF FREEDOM PARAMETER = ANU. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--X SHOULD BE NON-NEGATIVE. C --NU SHOULD BE A POSITIVE INTEGER VARIABLE. C OTHER DATAPAC SUBROUTINES NEEDED--NORCDF. C FORTRAN LIBRARY SUBROUTINES NEEDED--DSQRT, DEXP. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE C DISTRIBUTIONS--1, 1994, PAGE 417. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--95/4 C ORIGINAL VERSION--APRIL 1995. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DX, DALPHA, DC DOUBLE PRECISION DTERM1 DOUBLE PRECISION DCDF DOUBLE PRECISION DGAMIP C C--------------------------------------------------------------------- C INCLUDE 'DPCOMC.INC' C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----DATA STATEMENTS------------------------------------------------- C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(X.LT.0.0)THEN WRITE(ICOUT,4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9999 ENDIF IF(ALPHA.LE.0)THEN WRITE(ICOUT,15) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)ALPHA CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9999 ENDIF IF(C.EQ.0)THEN WRITE(ICOUT,16) CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9999 ENDIF 4 FORMAT('***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT ', 1'TO THE GGDCDF SUBROUTINE IS NEGATIVE *****') 15 FORMAT('***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE ', 1'GGDCDF SUBROUTINE IS NON-POSITIVE *****') 16 FORMAT('***** FATAL ERROR--THE THIRD INPUT ARGUMENT TO THE ', 1'GGDCDF SUBROUTINE IS ZERO *****') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') C IF(X.LE.R1MACH(1))THEN CDF=0.0 RETURN ENDIF C DX=DBLE(X) DALPHA=DBLE(ALPHA) DC=DBLE(C) C DTERM1=DX**DC DCDF=DGAMIP(DALPHA,DTERM1) IF(C.LT.0)DCDF=1.0D0-DCDF CDF=REAL(DCDF) C 9999 CONTINUE RETURN END SUBROUTINE GG2CDF(DX,DALPHA,DC,DCDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION C FUNCTION VALUE FOR THE GENERALIZED GAMMA DISTRIBUTION C WITH POSITIVE SHAPE PARAMETERS ALPHA AND C. C THIS DISTRIBUTION IS DEFINED FOR ALL NON-NEGATIVE X. C THE PROBABILITY DENSITY FUNCTION IS GIVEN C IN THE REFERENCES BELOW. C THE CDF FOR THE STANDARD FORM OF THE DISTRIBUTION IS C F(X,ALPAH,C) = GAMMAIP(X**C,ALPHA) C WHERE GAMMAIP = GAMMAI(ALPHA,X)/GAMMA(ALPHA). C THE CDF IS CAN BE COMPUTED WITH THE SLATEC ROUTINE C DGAMIC. 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 --ALPHA = A POSITIVE SHAPE PARAMETER C --C = A POSITIVE 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 FOR THE GENERALIZED GAMMA DISTRIBUTION C WITH DEGREES OF FREEDOM PARAMETER = ANU. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--X SHOULD BE NON-NEGATIVE. C --NU SHOULD BE A POSITIVE INTEGER VARIABLE. C OTHER DATAPAC SUBROUTINES NEEDED--NORCDF. C FORTRAN LIBRARY SUBROUTINES NEEDED--DSQRT, DEXP. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE C DISTRIBUTIONS--1, 1994, PAGE 417. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--95/4 C ORIGINAL VERSION--APRIL 1995. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DX, DALPHA, DC DOUBLE PRECISION DTERM1 DOUBLE PRECISION DCDF DOUBLE PRECISION DGAMIP C C--------------------------------------------------------------------- C INCLUDE 'DPCOMC.INC' C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----DATA STATEMENTS------------------------------------------------- C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(DX.LT.0.0D0)THEN WRITE(ICOUT,4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)DX CALL DPWRST('XXX','BUG ') DCDF=0.0 GOTO9999 ENDIF IF(DALPHA.LE.0.0D0)THEN WRITE(ICOUT,15) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)DALPHA CALL DPWRST('XXX','BUG ') DCDF=0.0D0 GOTO9999 ENDIF IF(DC.EQ.0.0D0)THEN WRITE(ICOUT,16) CALL DPWRST('XXX','BUG ') DCDF=0.0D0 GOTO9999 ENDIF 4 FORMAT('***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT ', 1'TO THE GGDCDF SUBROUTINE IS NEGATIVE *****') 15 FORMAT('***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE ', 1'GGDCDF SUBROUTINE IS NON-POSITIVE *****') 16 FORMAT('***** FATAL ERROR--THE THIRD INPUT ARGUMENT TO THE ', 1'GGDCDF SUBROUTINE IS ZERO *****') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',D15.8,' *****') C IF(DX.LE.D1MACH(1))THEN DCDF=0.0D0 RETURN ENDIF C DTERM1=DX**DC DCDF=DGAMIP(DALPHA,DTERM1) IF(DC.LT.0.0D0)DCDF=1.0D0-DCDF C 9999 CONTINUE RETURN END SUBROUTINE GGDCHA(X,ALPHA,C,HAZ) C C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE HAZARD C FUNCTION VALUE FOR THE GENERALIZED GAMMA DISTRIBUTION C WITH POSITIVE SHAPE PARAMETERS ALPHA AND C. C THIS DISTRIBUTION IS DEFINED FOR ALL NON-NEGATIVE X. C THE PDF FOR THE STANDARD FORM OF THE DISTRIBUTION IS C F(X,ALPAH,C) = C*X**(C*ALPHA-1)*EXP(-(X**C))/ C GAMMA(ALPHA) C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE AT C WHICH THE CUMULATIVE HAZARD C FUNCTION IS TO BE EVALUATED. C X SHOULD BE NON-NEGATIVE. C --ALPHA = A POSITIVE SHAPE PARAMETER C --C = A SHAPE PARAMETER C OUTPUT ARGUMENTS--PDF = THE SINGLE PRECISION CUMULATIVE HAZARD C FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION HAZARD C FUNCTION VALUE PDF FOR THE GENERALIZED GAMMA DISTRIBUTION C WITH SHAPE PARAMETERS C AND ALPHA. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--X SHOULD BE NON-NEGATIVE. C --ALPHA AND C SHOULD BE POSITIVE NUMBERS. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE C DISTRIBUTIONS--1, 1994, PAGE 388. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--98/4 C ORIGINAL VERSION--APRIL 1998. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DX, DALPHA, DC DOUBLE PRECISION DTERM1 DOUBLE PRECISION DCDF DOUBLE PRECISION DGAMIP C INCLUDE 'DPCOMC.INC' C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----DATA STATEMENTS------------------------------------------------- C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(X.LT.0.0)THEN WRITE(ICOUT,4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') HAZ=0.0 GOTO9999 ENDIF IF(ALPHA.LE.0)THEN WRITE(ICOUT,15) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)ALPHA CALL DPWRST('XXX','BUG ') HAZ=0.0 GOTO9999 ENDIF IF(C.EQ.0)THEN WRITE(ICOUT,16) CALL DPWRST('XXX','BUG ') HAZ=0.0 GOTO9999 ENDIF 4 FORMAT('***** FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT ', 1'TO THE GGDHAZ SUBROUTINE IS NEGATIVE *****') 15 FORMAT('***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE ', 1'GGDHAZ SUBROUTINE IS NON-POSITIVE *****') 16 FORMAT('***** FATAL ERROR--THE THIRD INPUT ARGUMENT TO THE ', 1'GGDHAZ SUBROUTINE IS ZERO *****') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') C IF(X.LE.R1MACH(1))THEN DCDF=0.0D0 ELSE C DX=DBLE(X) DALPHA=DBLE(ALPHA) DC=DBLE(C) DTERM1=DX**DC DCDF=DGAMIP(DALPHA,DTERM1) IF(C.LT.0)DCDF=1.0D0-DCDF ENDIF DCDF=1.0D0-DCDF IF(DCDF.NE.0.0D0)THEN HAZ=REAL(-DLOG(DCDF)) ELSE WRITE(ICOUT,9969)X CALL DPWRST('XXX','BUG ') HAZ=0.0 ENDIF 9969 FORMAT('*****WARNING: FOR ARGUMENT = ',F15.7,' CDF TERM ', 1'ESSENTIALLY 1, VALUE SET TO 0') C 9999 CONTINUE RETURN END SUBROUTINE GGDHAZ(X,ALPHA,C,HAZ) C C PURPOSE--THIS SUBROUTINE COMPUTES THE HAZARD C FUNCTION VALUE FOR THE GENERALIZED GAMMA DISTRIBUTION C WITH POSITIVE SHAPE PARAMETERS ALPHA AND C. C THIS DISTRIBUTION IS DEFINED FOR ALL NON-NEGATIVE X. C THE PDF FOR THE STANDARD FORM OF THE DISTRIBUTION IS C F(X,ALPAH,C) = C*X**(C*ALPHA-1)*EXP(-(X**C))/ C GAMMA(ALPHA) C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE AT C WHICH THE HAZARD C FUNCTION IS TO BE EVALUATED. C X SHOULD BE NON-NEGATIVE. C --ALPHA = A POSITIVE SHAPE PARAMETER C --C = A SHAPE PARAMETER C OUTPUT ARGUMENTS--PDF = THE SINGLE PRECISION HAZARD C FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION HAZARD C FUNCTION VALUE PDF FOR THE GENERALIZED GAMMA DISTRIBUTION C WITH SHAPE PARAMETERS C AND ALPHA. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--X SHOULD BE NON-NEGATIVE. C --ALPHA AND C SHOULD BE POSITIVE NUMBERS. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE C DISTRIBUTIONS--1, 1994, PAGE 388. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--98/4 C ORIGINAL VERSION--APRIL 1998. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DX, DALPHA, DC DOUBLE PRECISION DCDF DOUBLE PRECISION DGAMIP DOUBLE PRECISION DTERM1, DTERM2, DTERM3, DTERM4, DTERM5 DOUBLE PRECISION DPDF DOUBLE PRECISION DLNGAM DOUBLE PRECISION DUL C INCLUDE 'DPCOMC.INC' C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----DATA STATEMENTS------------------------------------------------- C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(X.LT.0.0)THEN WRITE(ICOUT,4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') HAZ=0.0 GOTO9999 ENDIF IF(ALPHA.LE.0)THEN WRITE(ICOUT,15) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)ALPHA CALL DPWRST('XXX','BUG ') HAZ=0.0 GOTO9999 ENDIF IF(C.EQ.0)THEN WRITE(ICOUT,16) CALL DPWRST('XXX','BUG ') HAZ=0.0 GOTO9999 ENDIF 4 FORMAT('***** FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT ', 1'TO THE GGDHAZ SUBROUTINE IS NEGATIVE *****') 15 FORMAT('***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE ', 1'GGDHAZ SUBROUTINE IS NON-POSITIVE *****') 16 FORMAT('***** FATAL ERROR--THE THIRD INPUT ARGUMENT TO THE ', 1'GGDHAZ SUBROUTINE IS ZERO *****') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') C IF(X.LE.R1MACH(1))THEN DCDF=0.0D0 ELSE C DX=DBLE(X) DALPHA=DBLE(ALPHA) DC=DBLE(C) DTERM1=DX**DC DCDF=DGAMIP(DALPHA,DTERM1) IF(C.LT.0)DCDF=1.0D0-DCDF ENDIF DCDF=1.0D0-DCDF IF(DCDF.NE.0.0D0)THEN IF(X.LE.R1MACH(1))THEN DPDF=0.0D0 ELSE C DX=DBLE(X) DALPHA=DBLE(ALPHA) DC=DBLE(C) C DUL=D1MACH(2) IF(C.GE.1.0)THEN IF(DX.GT.DUL**(1.0D0/DC))THEN WRITE(ICOUT,106) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') DPDF=0.0 ENDIF ELSEIF(C.GT.0.0.AND.C.LT.1.0)THEN IF(DX.GT.DUL**DC)THEN WRITE(ICOUT,106) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') DPDF=0.0 ENDIF ELSE CONTINUE ENDIF 106 FORMAT('***** FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT ', 1'TO THE GGDPDF SUBROUTINE GENERATES AN INVALID VALUE *****') C DTERM1=DLOG(DABS(DC)) DTERM2=(DC*DALPHA-1.0D0)*DLOG(DX) DTERM3=-(DX**DC) DTERM4=DLNGAM(DALPHA) DTERM5=DTERM1+DTERM2+DTERM3-DTERM4 DPDF=0.0D0 IF(DTERM5.GE.-80.0D0)DPDF=DEXP(DTERM5) ENDIF HAZ=REAL(DPDF/DCDF) ELSE WRITE(ICOUT,9969)X CALL DPWRST('XXX','BUG ') HAZ=0.0 ENDIF 9969 FORMAT('*****WARNING: FOR ARGUMENT = ',F15.7,' CDF TERM ', 1'ESSENTIALLY 1, VALUE SET TO 0') C 9999 CONTINUE RETURN END SUBROUTINE GGDPDF(X,ALPHA,C,PDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY C FUNCTION VALUE FOR THE GENERALIZED GAMMA DISTRIBUTION C WITH POSITIVE SHAPE PARAMETERS ALPHA AND C. C THIS DISTRIBUTION IS DEFINED FOR ALL NON-NEGATIVE X. C THE PDF FOR THE STANDARD FORM OF THE DISTRIBUTION IS C F(X,ALPAH,C) = C*X**(C*ALPHA-1)*EXP(-(X**C))/ C GAMMA(ALPHA) 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 --ALPHA = A POSITIVE SHAPE PARAMETER C --C = A POSITIVE SHAPE PARAMETER C OUTPUT ARGUMENTS--PDF = THE SINGLE PRECISION PROBABILITY C DENSITY FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY C FUNCTION VALUE PDF FOR THE GENERALIZED GAMMA DISTRIBUTION C WITH SHAPE PARAMETERS C AND ALPHA. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--X SHOULD BE NON-NEGATIVE. C --ALPHA AND C SHOULD BE POSITIVE NUMBERS. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE C DISTRIBUTIONS--1, 1994, PAGE 388. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--95/4 C ORIGINAL VERSION--APRIL 1995. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DX, DALPHA, DC DOUBLE PRECISION DTERM1, DTERM2, DTERM3, DTERM4, DTERM5 DOUBLE PRECISION DPDF DOUBLE PRECISION DLNGAM DOUBLE PRECISION DUL C C--------------------------------------------------------------------- C INCLUDE 'DPCOMC.INC' C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----DATA STATEMENTS------------------------------------------------- C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(X.LT.0.0)THEN WRITE(ICOUT,4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ENDIF IF(ALPHA.LE.0)THEN WRITE(ICOUT,15) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)ALPHA CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ENDIF IF(C.EQ.0)THEN WRITE(ICOUT,16) CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ENDIF 4 FORMAT('***** FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT ', 1'TO THE GGDPDF SUBROUTINE IS NEGATIVE *****') 15 FORMAT('***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE ', 1'GGDPDF SUBROUTINE IS NON-POSITIVE *****') 16 FORMAT('***** FATAL ERROR--THE THIRD INPUT ARGUMENT TO THE ', 1'GGDPDF SUBROUTINE IS ZERO *****') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') C IF(X.LE.R1MACH(1))THEN PDF=0.0 RETURN ENDIF C DX=DBLE(X) DALPHA=DBLE(ALPHA) DC=DBLE(C) C DUL=D1MACH(2) IF(C.GE.1.0)THEN IF(DX.GT.DUL**(1.0D0/DC))THEN WRITE(ICOUT,106) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ENDIF ELSEIF(C.GT.0.0.AND.C.LT.1.0)THEN IF(DX.GT.DUL**DC)THEN WRITE(ICOUT,106) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ENDIF ELSE CONTINUE ENDIF 106 FORMAT('***** FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT ', 1'TO THE GGDPDF SUBROUTINE GENERATES AN INVALID VALUE *****') C DTERM1=DLOG(DABS(DC)) DTERM2=(DC*DALPHA-1.0D0)*DLOG(DX) DTERM3=-(DX**DC) DTERM4=DLNGAM(DALPHA) DTERM5=DTERM1+DTERM2+DTERM3-DTERM4 DPDF=0.0D0 IF(DTERM5.GE.-80.0D0)DPDF=DEXP(DTERM5) PDF=REAL(DPDF) C 9999 CONTINUE RETURN END SUBROUTINE GGDPPF(P,ALPHA,C,PPF) C C PURPOSE --PERCENT POINT FUNCTION FOR THE GENERALIZED GAMMA C DISTRIBUTION. USES A BISECTION METHOD. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--95/4 C ORIGINAL VERSION--APRIL 1995. C UPDATED --MARCH 2004. MAKE DOUBLE PRECISION C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DP DOUBLE PRECISION DC DOUBLE PRECISION DALPHA DOUBLE PRECISION EPS DOUBLE PRECISION SIG DOUBLE PRECISION ZERO DOUBLE PRECISION DMEAN DOUBLE PRECISION DSD DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 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 DLNGAM C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C DATA EPS /0.0001D0/ DATA SIG /1.0D-5/ DATA ZERO /0.0D0/ DATA MAXIT /3000/ C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(P.LT.0.0.OR.P.GE.1.0)THEN WRITE(ICOUT,1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)P CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9999 ENDIF IF(ALPHA.LE.0)THEN WRITE(ICOUT,15) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)ALPHA CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9999 ENDIF IF(C.EQ.0)THEN WRITE(ICOUT,16) CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9999 ENDIF C 1 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ', 1' GGDPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL.') 15 FORMAT('***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE ', 1'GGDPPF SUBROUTINE IS NON-POSITIVE *****') 16 FORMAT('***** FATAL ERROR--THE THIRD INPUT ARGUMENT TO THE ', 1'GGDPPF SUBROUTINE IS ZERO *****') 11 FORMAT('***** FATAL ERROR--THE 2ND INPUT ARGUMENT TO THE ', 1' GGDPPF SUBROUTINE IS LESS THAN OR EQUAL TO 0.') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') C 90 CONTINUE C IF(P.EQ.0.)THEN PPF=0. GOTO9999 ENDIF C C FIND BRACKETING INTERVAL. C DP=DBLE(P) DALPHA=DBLE(ALPHA) DC=DBLE(C) C XL=0.0D0 IF(DC.LE.0.0D0)THEN XINC=5.0 XR=XL+XINC ELSE DMEAN=DEXP(DLNGAM(DALPHA+1.0D0/DC) - DLNGAM(DALPHA)) XR=DMEAN DTERM1=DEXP(DLNGAM(DALPHA+2.0D0/DC) - DLNGAM(DALPHA)) DTERM2=2.0D0*(DLNGAM(DALPHA+1.0D0/DC) - DLNGAM(DALPHA)) DSD=DTERM1 - DEXP(DTERM2) DSD=DSQRT(DSD) XINC=DSD ENDIF ICOUNT=0 MAXCNT=10000 C 91 CONTINUE IF(XL.LE.0.0D0)XL=0.0D0 IF(XR.LE.0.0D0)XR=XL+DMEAN CALL GG2CDF(XL,DALPHA,DC,CDFL) CALL GG2CDF(XR,DALPHA,DC,CDFR) IF(CDFL.LT.DP .AND. CDFR.LT.DP)THEN XL=XR XR=XL+XINC ELSEIF(CDFL.GT.DP .AND. CDFR.GT.DP)THEN XL=XL-XINC IF(XL.LT.0.0D0)XL=0.0D0 ELSE GOTO99 ENDIF ICOUNT=ICOUNT+1 IF(ICOUNT.GT.MAXCNT)THEN WRITE(ICOUT,96) CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9999 ENDIF 96 FORMAT('***** FATAL ERROR--GGDPPF UNABLE TO FIND BRACKETING ', * 'INTERVAL. *****') GOTO91 C C BISECTION METHOD C 99 CONTINUE IC = 0 FXL = -DP FXR = 1.0D0 - DP 105 CONTINUE X = (XL+XR)*0.5D0 CALL GG2CDF(X,DALPHA,DC,DCDF) P1=DCDF PPF=REAL(X) FCS = P1 - DP IF(FCS*FXL.GT.ZERO)GOTO110 XR = X FXR = FCS GOTO115 110 CONTINUE XL = X FXL = FCS 115 CONTINUE XRML = XR - XL IF(XRML.LE.SIG .AND. ABS(FCS).LE.EPS)GOTO9999 IC = IC + 1 IF(IC.LE.MAXIT)GOTO105 WRITE(ICOUT,130) CALL DPWRST('XXX','BUG ') 130 FORMAT('***** FATAL ERROR--GGDPPF ROUTINE DID NOT CONVERGE. ***') GOTO9999 C 9999 CONTINUE RETURN END SUBROUTINE GGDRAN(N,ALPHA,C,ISEED,X) C C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N C FROM THE GENERALIZED GAMMA DISTRIBUTION C WITH SHAPE PARAMETERS GAMMA AND C. C THIS DISTRIBUTION IS DEFINED FOR ALL POSITIVE X, C AND HAS THE PROBABILITY DENSITY FUNCTION C F(X) = C*X**(ALPHA*C-1)*EXP((-X)**C)/GAMMA(ALPHA) C INPUT ARGUMENTS--N = THE DESIRED INTEGER NUMBER C OF RANDOM NUMBERS TO BE C GENERATED. C --ALPHA = THE SINGLE PRECISION VALUE OF THE C FIRST SHAPE PARAMETER. C ALPHA SHOULD BE POSITIVE. C --C = THE SINGLE PRECISION VALUE OF THE C SECOND SHAPE PARAMETER. C OUTPUT ARGUMENTS--X = A SINGLE PRECISION VECTOR C (OF DIMENSION AT LEAST N) C INTO WHICH THE GENERATED C RANDOM SAMPLE WILL BE PLACED. C OUTPUT--A RANDOM SAMPLE OF SIZE N C FROM THE GAMMA DISTRIBUTION C WITH TAIL LENGTH PARAMETER VALUE = GAMMA. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C --ALPHA SHOULD BE POSITIVE. C --C NOT EQUAL TO 0. C OTHER DATAPAC SUBROUTINES NEEDED--UNIRAN C FORTRAN LIBRARY SUBROUTINES NEEDED--EXP. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--JAMES E. GENTLE (2003). 'RANDOM NUMBER GENERATION C AND MONTE CARLO METHODS', SPRINGER-VERLANG. C USE HIS SUGGESTED METHOD OF OBTANING A GAMMA C RANDOM VARIABLE AND EXPONENTIATING. C --"NON-UNIFORM RANDOM VARIATE GENERATION", C LUC DEVROYE, SPRINGER-VERLAG, 1986, P. 423. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2003/9 C ORIGINAL VERSION--SEPTEMBER 2003. C FIXED --APRIL 2004. EXPONENTIATE BY (1/C), NOT C. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DIMENSION X(*) C DIMENSION XN(2) DIMENSION U(2) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----DATA STATEMENTS------------------------------------------------- C DATA ATHIRD/0.3333333/ DATA SQRT3 /1.73205081/ C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(N.LT.1)THEN WRITE(ICOUT, 5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)N CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF IF(ALPHA.LE.0)THEN WRITE(ICOUT,15) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)ALPHA CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ENDIF IF(C.EQ.0)THEN WRITE(ICOUT,16) CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ENDIF 5 FORMAT('***** FATAL ERROR--THE REQUESTED NUMBER OF GENERALIZED', 1' GAMMA RANDOM NUMBERS IS NON-POSITIVE') 15 FORMAT('***** FATAL ERROR--THE ALPHA SHAPE PARAMETER FOR THE ', 1'GENERALIZED GAMMA RANDOM NUMBERS IS NON-POSITIVE') 16 FORMAT('***** FATAL ERROR--THE C SHAPE PARAMETER FOR THE ', 1'GENERALIZED GAMMA RANDOM NUMBERS IS NON-POSITIVE') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****') C C GENERATE N GAMMA DISTRIBUTION RANDOM NUMBERS C USING AHRENS-DIETER METHOD AND THEN EXPONENTIATE BY (1/C). C CALL UNIRAN(N,ISEED,X) DO100I=1,N ATEMP=SGAMMA(ISEED,ALPHA) X(I)=ATEMP**(1.0/C) CCCCC ATEMP=X(I) CCCCC CALL GGDPPF(ATEMP,ALPHA,C,APPF) CCCCC X(I)=APPF 100 CONTINUE C 9999 CONTINUE C RETURN END FUNCTION GFUNCT(X,NOBS,BETA,XGM) C C COMPUTE G FUNCTION USED IN ESTIMATING THE SHAPE PARAMETER (BETA) C XGM IS THE GEOMETRIC MEAN OF THE X'S USED IN ESTIMATING ALPHA C DIMENSION X(*) C RN=FLOAT(NOBS) C ALPHA=FNALPH(X,NOBS,BETA,XGM) SUMYZ=0.0 DO 10 I=1,NOBS SUMYZ=SUMYZ+ALOG(X(I))*((X(I)/ALPHA)**BETA-1.) 10 CONTINUE C GFUNCT=(SUMYZ/RN)-1.0/BETA C RETURN END SUBROUTINE GHCDF(X,G,H,CDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION C FUNCTION VALUE FOR THE G-H DISTRIBUTION C WITH SHAPE PARAMETERS G AND H. C THIS DISTRIBUTION IS DEFINED FOR ALL X AND THE C CUMULATIVE DISTRIBUTION FUNCTION IS COMPUTED BY C NUMERICALLY INVERTING THE PPF FUNCTION. C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE AT C WHICH THE CUMULATIVE DISTRIBUTION C FUNCTION IS TO BE EVALUATED. C --G = THE SKEWNESS SHAPE PARAMETER C --H = THE KURTOSIS 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. C RESTRICTIONS--NONE. C OTHER DATAPAC SUBROUTINES NEEDED--FZERO. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--HOAGLIN, 'SUMMARIZING SHAPES NUMERICALLY: THE C G-AND-H DISTRIBUTION", IN "EXPLORING DATA TABLES, C TRENDS AND SHAPES", HOAGLIN, MOSTELLER, TUKEY, C WILEY, 1985. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATION INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2003.12 C ORIGINAL VERSION--DECEMBER 2003. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C REAL CDF REAL G REAL H REAL PLOW REAL PUP REAL XLOW REAL XUP C REAL GHFU2 EXTERNAL GHFU2 C REAL X2 COMMON/GH2COM/X2 C REAL G2 REAL H2 COMMON/GHCOM/G2,H2 C DOUBLE PRECISION DP DOUBLE PRECISION DPPF C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C CDF=0.0 IF(H.LT.0.0)THEN WRITE(ICOUT, 7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,48)H CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF 7 FORMAT('***** ERROR--THE THIRD (H) INPUT ARGUMENT TO THE ', 1'GHCDF SUBROUTINE IS NEGATIVE *****') 48 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',F15.7,' *****') C C IF G AND H BOTH ZERO, USE NORCDF. C IF(G.EQ.0.0 .AND. H.EQ.0.0)THEN CALL NORCDF(X,CDF) GOTO9000 ENDIF C C STEP 1: FIND BRACKETING INTERVAL. C C DP=-1.0D0 CALL GHPPF(0.01,G,H,XCDF01,DP,DPPF) IF(X.LT.XCDF01)THEN PLOW=0.0000001 DP=-1.0D0 CALL GHPPF(PLOW,G,H,XLOW,DP,DPPF) IF(X.LT.XLOW)THEN CDF=0.0 GOTO9000 ENDIF PUP=0.015 GOTO1000 ENDIF DP=-1.0D0 CALL GHPPF(0.1,G,H,XCDF1,DP,DPPF) IF(X.GE.XCDF01 .AND. X.LE.XCDF1)THEN PLOW=0.005 PUP=0.15 GOTO1000 ENDIF DP=-1.0D0 CALL GHPPF(0.9,G,H,XCDF9,DP,DPPF) IF(X.GE.XCDF1 .AND. X.LE.XCDF9)THEN PLOW=0.05 PUP=0.95 GOTO1000 ENDIF DP=-1.0D0 CALL GHPPF(0.95,G,H,XCDF95,DP,DPPF) IF(X.GE.XCDF95)THEN PUP=0.9999999 DP=-1.0D0 CALL GHPPF(PUP,G,H,XUP,DP,DPPF) IF(X.GT.XUP)THEN CDF=1.0 GOTO9000 ENDIF PLOW=0.945 GOTO1000 ELSE PLOW=0.89 PUP=0.96 ENDIF C 1000 CONTINUE AE=1.E-6 RE=1.E-6 G2=G H2=H X2=X IFLAG=0 CALL FZERO(GHFU2,PLOW,PUP,PUP,RE,AE,IFLAG) C CDF=PLOW C IF(IFLAG.EQ.2)THEN C C NOTE: SUPPRESS THIS MESSAGE FOR NOW. CCCCC WRITE(ICOUT,999) 999 FORMAT(1X) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,111) CC111 FORMAT('***** WARNING FROM GHCDF--') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,113) CC113 FORMAT(' CDF VALUE MAY NOT BE COMPUTED TO DESIRED ', CCCCC1 'TOLERANCE.') CCCCC CALL DPWRST('XXX','BUG ') ELSEIF(IFLAG.EQ.3)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,121) 121 FORMAT('***** WARNING FROM GHCDF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,123) 123 FORMAT(' CDF VALUE MAY BE NEAR A SINGULAR POINT.') CALL DPWRST('XXX','BUG ') ELSEIF(IFLAG.EQ.4)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,131) 131 FORMAT('***** ERROR FROM GHCDF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,133) 133 FORMAT(' APPROPRIATE BRACKETING INTERVAL NOT FOUND.') CALL DPWRST('XXX','BUG ') ELSEIF(IFLAG.EQ.5)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,141) 141 FORMAT('***** WARNING FROM GHCDF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,143) 143 FORMAT(' MAXIMUM ITERATIONS EXCEEDED.') CALL DPWRST('XXX','BUG ') ENDIF C 9000 CONTINUE RETURN END SUBROUTINE GFUNC2(X,N,IR,ALPHA,GAMMA,WEIVAL) C C COMPUTE FUNCTION USED IN ESTIMATING THE SHAPE C PARAMETERS FOR A CENSORED WEIBULL DISTRIBUTION. C DOUBLE PRECISION DN, DG, DIR, DX, DALPHA DOUBLE PRECISION DSUM1, DSUM2, DSUM3 DOUBLE PRECISION DTERM1, DTERM2, DTERM3, DTERM4 DIMENSION X(*) C C CALCULATE SOME INTERMEDIATE VALUES C DN=DBLE(N) DIR=DBLE(IR) DG=DBLE(GAMMA) DALPHA=DBLE(ALPHA) C DSUM1=0.0 DSUM2=0.0 DSUM3=0.0 C DO100I=1,IR DX=DBLE(X(I)) DSUM1=DSUM1 + DX**DG DSUM2=DSUM2 + (DX**DG)*DLOG(DX) DSUM3=DSUM3 + DLOG(DX) 100 CONTINUE C DX=DBLE(X(IR)) DTERM1=DSUM2 + DBLE(N-IR)*(DX**DG)*DLOG(DX) DTERM2=1.0D0/(DSUM1 + DBLE(N-IR)*DX**DG) DTERM3=DSUM3/DIR DTERM4=1.0D0/(DTERM1 + DTERM2 - DTERM3) C WEIVAL=GAMMA - REAL(DTERM4) ALPHA=FNALP2(X,N,IR,GAMMA) C RETURN END REAL FUNCTION GHFU2(P) C C PURPOSE--GHCDF CALLS FZERO TO FIND A ROOT FOR THE G-H C CUMULATIVE DISTRIBUTION FUNCTION. GHFU2 IS THE C FUNCTION FOR WHICH THE ZERO IS FOUND. IT IS: C X - GHPPF(P,G,H) C WHERE X IS THE DESIRED CUMULATIVE DISTRIBUTION POINT. C INPUT ARGUMENTS--P = THE SINGLE PRECISION VALUE AT C WHICH THE PERCENT POINT C FUNCTION IS TO BE EVALUATED. C OUTPUT--THE SINGLE PRECISION FUNCTION VALUE GHFU2. C PRINTING--NONE. C RESTRICTIONS--NONE. C OTHER DATAPAC SUBROUTINES NEEDED--GHPPF. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--HOAGLIN, 'SUMMARIZING SHAPES NUMERICALLY: THE C G-AND-H DISTRIBUTION", IN "EXPLORING DATA TABLES, C TRENDS AND SHAPES", HOAGLIN, MOSTELLER, TUKEY, C WILEY, 1985. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATION INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2003.12 C ORIGINAL VERSION--DECEMBER 2003. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C REAL P C REAL X COMMON/GH2COM/X C DOUBLE PRECISION DP DOUBLE PRECISION DPPF C REAL G REAL H COMMON/GHCOM/G,H 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 DP=-1.0D0 CALL GHPPF(P,G,H,PPF,DP,DPPF) GHFU2=X - PPF C 9999 CONTINUE RETURN END REAL FUNCTION GHFU3(X) C C PURPOSE--GHPDF CALLS DIFF TO FIND A NUMERICAL DERIVATIVE C FOR THE G-H CUMULATIVE DISTRIBUTION FUNCTION. GHFU3 C IS A FUNCTION THAT CALL GHCDF. C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE AT C WHICH THE DERIVATIVE C IS TO BE EVALUATED. C OUTPUT--THE SINGLE PRECISION FUNCTION VALUE GHFU3. C PRINTING--NONE. C RESTRICTIONS--NONE. C OTHER DATAPAC SUBROUTINES NEEDED--GHCDF. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--HOAGLIN, 'SUMMARIZING SHAPES NUMERICALLY: THE C G-AND-H DISTRIBUTION", IN "EXPLORING DATA TABLES, C TRENDS AND SHAPES", HOAGLIN, MOSTELLER, TUKEY, C WILEY, 1985. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATION INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2004.3 C ORIGINAL VERSION--MARCH 2004. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C REAL G REAL H COMMON/GHCOM/G,H C C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C CALL GHCDF(X,G,H,CDF) GHFU3=CDF C 9999 CONTINUE RETURN END SUBROUTINE GHPDF(X,G,H,PDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY C FUNCTION VALUE FOR THE G-H DISTRIBUTION C WITH SHAPE PARAMETERS G AND H. C THIS DISTRIBUTION IS DEFINED FOR ALL X AND THE C PROBABILITY DENSITY FUNCTION IS COMPUTED BY COMPUTING C THE NUMERICAL DERIVATIVE OF THE CUMULATIVE DISTRIBUTION C FUNCTION. C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE AT C WHICH THE PROBABILITY DENSITY C FUNCTION IS TO BE EVALUATED. C --G = THE SKEWNESS SHAPE PARAMETER C --H = THE KURTOSIS 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. C RESTRICTIONS--NONE. C OTHER DATAPAC SUBROUTINES NEEDED--FZERO. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--HOAGLIN, 'SUMMARIZING SHAPES NUMERICALLY: THE C G-AND-H DISTRIBUTION", IN "EXPLORING DATA TABLES, C TRENDS AND SHAPES", HOAGLIN, MOSTELLER, TUKEY, C WILEY, 1985. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATION INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2004.3 C ORIGINAL VERSION--MARCH 2004. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C REAL PDF REAL G REAL H C REAL GHFU3 EXTERNAL GHFU3 C REAL G2 REAL H2 COMMON/GHCOM/G2,H2 C CHARACTER*4 IERROR C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C IERROR='OFF' PDF=0.0 IF(H.LT.0.0)THEN WRITE(ICOUT, 7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,48)H CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF 7 FORMAT('***** ERROR--THE THIRD (H) INPUT ARGUMENT TO THE ', 1'GHPDF SUBROUTINE IS NEGATIVE *****') 48 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',F15.7,' *****') C C IF G AND H BOTH ZERO, USE NORPDF. C IF(G.EQ.0.0 .AND. H.EQ.0.0)THEN CALL NORPDF(X,PDF) GOTO9000 ENDIF C C FIND NUMERIC DERIVATIVE OF CDF ROUTINE C IORD=1 EPS=0.0001 ACCUR=0.0 IFAIL=0 X0 = X XMIN=CPUMIN XMAX=CPUMAX G2=G H2=H C CALL DIFF(IORD,X0,XMIN,XMAX,GHFU3,EPS,ACCUR,PDF,ERROR,IFAIL) C IF(IFAIL.EQ.1)THEN 999 FORMAT(1X) WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,301) 301 FORMAT('***** WARNING IN NUMERICAL DERIVATIVE FOR GHPDF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,303) 303 FORMAT(' THE ESTIMATED ERROR IN THE RESULT EXCEEDS THE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,305) 305 FORMAT(' REQUESTED ERROR, BUT THE MOST ACCURATE RESULT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,307) 307 FORMAT(' POSSIBLE HAS BEEN RETURNED.') CALL DPWRST('XXX','BUG ') ELSEIF(IFAIL.EQ.2)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,311) 311 FORMAT('***** ERROR IN NUMERICAL DERIVATIVE FOR GHPDF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,313) 313 FORMAT(' ERROR IN THE INPUT TO THE DIFF ROUTINE.') CALL DPWRST('XXX','BUG ') PDF=0.0 ERROR=0.0 IERROR='YES' GOTO9000 ELSEIF(IFAIL.EQ.3)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,321) 321 FORMAT('***** ERROR IN NUMERICAL DERIVATIVE FOR GHPDF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,323) 323 FORMAT(' THE INTERVAL FOR DIFFERENTIATION, (',G15.7, 1 ',',G15.7,')') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,325) 325 FORMAT(' IS TOO SMALL.') CALL DPWRST('XXX','BUG ') PDF=0.0 ERROR=0.0 IERROR='YES' GOTO9000 ENDIF C 9000 CONTINUE RETURN END SUBROUTINE GHPPF(P,G,H,PPF,DP,DPPF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY C FUNCTION FROM THE THE G AND H DISTIBUTION WITH C LOCATION = 0 AND SCALE = 1. THE PERCENT POINT C FUNCTION IS DEFINED AS: C G(P,G,H) = [(EXP(G*Zp)-1)/G]*EXP(H*Zp**2/2) C WHERE Zp IS THE PERCENT POINT FUNCTION OF THE STANDARD C NORMAL DISTRIBUTION AND C G AND H ARE SHAPE PARAMETERS (G CONTROLS SKEWNESS C (0 = SYMMETRIC) AND H CONTROLS HOW HEAVY THE TAILS C ARE. G=H=0 IMPLIES A STANDARD NORMAL DISTRIBUTION. C WHEN G=0, THE PERCENT POINT FUNCTION IS DEFINED AS: C F(X) = Z*EXP(H*Z**2/2) C INPUT ARGUMENTS--P = THE SINGLE PRECISION VALUE AT C WHICH THE PERCENT POINT C FUNCTION IS TO BE EVALUATED. C --G = FIRST SHAPE PARAMETER (DETERMINES C SKEWNESS WITH G=0 BEING SYMMETRIC) C --H = SECOND SHAPE PARAMETER (DETERMINES C "HEAVY TAILEDNESS" C OUTPUT ARGUMENTS--PPF = THE SINGLE PRECISION PERCENT POINT C FUNCTION VALUE. C NOTE--SAVE DOUBLE PRECISION VALUES FOR P AND PPF (DP, DPPF) C FOR USE BY THE GHCDF FUNCTION C OUTPUT--THE SINGLE PRECISION PERCENT POINT FUNCTION VALUE PPF. C PRINTING--NONE. C RESTRICTIONS--NONE. C OTHER DATAPAC SUBROUTINES NEEDED--NODPPF. C FORTRAN LIBRARY SUBROUTINES NEEDED--EXP. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--HOAGLIN, 'SUMMARIZING SHAPES NUMERICALLY: THE C G-AND-H DISTRIBUTION", IN "EXPLORING DATA TABLES, C TRENDS AND SHAPES", HOAGLIN, MOSTELLER, TUKEY, C WILEY, 1985. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2003.1 C ORIGINAL VERSION--JANUARY 2003. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C REAL H DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 DOUBLE PRECISION DTERM3 DOUBLE PRECISION DP DOUBLE PRECISION DG DOUBLE PRECISION DH DOUBLE PRECISION DPPF C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(P.LE.0.0 .OR. P.GE.1.0)THEN WRITE(ICOUT,5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,48)P CALL DPWRST('XXX','BUG ') GOTO9999 CCCCC ELSEIF(G.LT.0.0)THEN CCCCC WRITE(ICOUT, 6) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,48)G CCCCC CALL DPWRST('XXX','BUG ') CCCCC GOTO9999 ELSEIF(H.LT.0.0)THEN WRITE(ICOUT, 7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,48)H CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF 5 FORMAT('***** FATAL ERROR--THE FIRST (P) INPUT ARGUMENT TO THE ', 1'GHPPF SUBROUTINE IS OUTSIDE THE (0,1) INTERVAL *****') CCCC6 FORMAT('***** FATAL ERROR--THE SECOND (G) INPUT ARGUMENT TO THE ', CCCC 1'GHPPF SUBROUTINE IS NEGATIVE *****') 7 FORMAT('***** FATAL ERROR--THE THIRD (H) INPUT ARGUMENT TO THE ', 1'GHPPF SUBROUTINE IS NEGATIVE *****') 48 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',F15.7,' *****') C C TRANSFORM THE NORMAL PPF C IF(DP.LT.0.0D0)THEN DP=DBLE(P) ENDIF DG=DBLE(G) DH=DBLE(H) C CALL NODPPF(DP,DTERM3) IF(G.EQ.0.0 .AND. H.EQ.0.0)THEN PPF=REAL(DTERM3) ELSEIF(G.EQ.0.0)THEN DPPF=DTERM3*DEXP(DH*DTERM3*DTERM3/2.0D0) PPF=REAL(DPPF) ELSEIF(H.EQ.0.0)THEN DPPF=(DEXP(DG*DTERM3)-1.0D0)/DG PPF=REAL(DPPF) ELSE DTERM1=(DEXP(DG*DTERM3)-1.0D0)/DG DTERM2=DEXP(DH*DTERM3*DTERM3/2.0D0) DPPF=DTERM1*DTERM2 PPF=REAL(DPPF) ENDIF C C 9999 CONTINUE RETURN END SUBROUTINE GHRAN(N,G,H,ISEED,X) C C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N C FROM THE THE G AND H DISTIBUTION WITH LOCATION = 0 C AND SCALE = 1. THIS DISTRIBUTION IS DEFINED FOR ALL C X AND HAS THE PROBABILITY DENSITY FUNCTION C F(X) = [(EXP(G*Z)-1)/g]*EXP(H*Z**2/2) C WHERE Z IS A STANDARD NORMAL DISTRIBUTION AND C G AND H ARE SHAPE PARAMETERS (G CONTROLS SKEWNESS C (0 = SYMMETRIC) AND H CONTROLS HOW HEAVY THE TAILS C ARE. G=H=0 IMPLIES A STANDARD NORMAL DISTRIBUTION. C WHEN G = 0, THE FUNCTION IS: C F(X) = Z*EXP(H*Z**2/2) C INPUT ARGUMENTS--N = THE DESIRED INTEGER NUMBER C OF RANDOM NUMBERS TO BE C GENERATED. C OUTPUT ARGUMENTS--X = A SINGLE PRECISION VECTOR C (OF DIMENSION AT LEAST N) C INTO WHICH THE GENERATED C RANDOM SAMPLE WILL BE PLACED. C --G = A SINGLE PRECISON SCALAR THAT DEFINES C THE SKEWNESS SHAPE PARAMETER. C --H = A SINGLE PRECISON SCALAR THAT DEFINES C THE "HEAVY-TAILEDNESS" SHAPE C PARAMETER. C OUTPUT--A RANDOM SAMPLE OF SIZE N FROM THE G-AND-H DISTRIBUTION C WITH LOCATION = 0 AND SCALE = 1. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C OTHER DATAPAC SUBROUTINES NEEDED--UNIRAN. C FORTRAN LIBRARY SUBROUTINES NEEDED--ALOG, SQRT, SIN, COS. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C METHOD--TRANSFORM NORMAL RANDOM NUMBERS C REFERENCES--HOAGLIN, 'SUMMARIZING SHAPES NUMERICALLY: THE C G-AND-H DISTRIBUTION", IN "EXPLORING DATA TABLES, C TRENDS AND SHAPES", HOAGLIN, MOSTELLER, TUKEY, C WILEY, 1985. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--2003.1 C ORIGINAL VERSION--JANUARY 2003. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DIMENSION X(*) REAL G REAL H DOUBLE PRECISION DQ DOUBLE PRECISION DPPF C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(N.LT.1)THEN WRITE(ICOUT, 5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)N CALL DPWRST('XXX','BUG ') GOTO9999 CCCCC ELSEIF(G.LT.0.0)THEN CCCCC WRITE(ICOUT, 6) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,48)G CCCCC CALL DPWRST('XXX','BUG ') CCCCC GOTO9999 ELSEIF(H.LT.0.0)THEN WRITE(ICOUT, 7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,48)H CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF 5 FORMAT('***** FATAL ERROR--THE FIRST (N) INPUT ARGUMENT TO THE ', 1'GHRAN SUBROUTINE IS NON-POSITIVE *****') 6 FORMAT('***** FATAL ERROR--THE SECOND (G) INPUT ARGUMENT TO THE ', 1'GHRAN SUBROUTINE IS NEGATIVE *****') 7 FORMAT('***** FATAL ERROR--THE THIRD (H) INPUT ARGUMENT TO THE ', 1'GHRAN SUBROUTINE IS NEGATIVE *****') 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****') 48 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',F15.7,' *****') C C GENERATE N UNIFORM NUMBERS; C CALL UNIRAN(N,ISEED,X) C C GENERATE N G-AND-H RANDON NUMBERS USING THE PERCENT POINT C FUNCTION TRANSFORMATION. C DO100I=1,N Q=X(I) DQ=DBLE(-1.0D0) CALL GHPPF(Q,G,H,PPF,DQ,DPPF) X(I)=PPF 100 CONTINUE C 9999 CONTINUE RETURN END SUBROUTINE GIGCDF(DX,CHI,LAMBDA,THETA,DCDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION C FUNCTION VALUE FOR THE GENERALIZED INVERSE GAUSSIAN C DISTRIBUTION WITH SHAPE PARAMETERS CHI, LAMBDA, AND C THETA. THE CUMULATIVE DISTRIBUTION IS COMPUTED BY C NUMERICALLY INTEGRATING THE PDF FUNCTION. C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE AT C WHICH THE CUMULATIVE DISTRIBUTION C FUNCTION IS TO BE EVALUATED. C --CHI = THE FIRST SHAPE PARAMETER C --LAMBDA = THE THIRD SHAPE PARAMETER C --THETA = THE THIRD SHAPE PARAMETER C OUTPUT ARGUMENTS--CDF = THE SINGLE PRECISION PROBABILITY C DENSITY FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION C FUNCTION VALUE CDF FOR THE GENERALIZED INVERSE C GAUSSIAN DISTRIBUTION WITH SHAPE PARAMETERS CHI, C LAMBDA, AND THETA. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--NONE. C OTHER DATAPAC SUBROUTINES NEEDED--DQAGI. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, (1994), "CONTINUOUS C UNIVARIATE DISTRIBUTIONS--VOLUME 1", SECOND EDITION, C WILEY, PP. pp. 284-285. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2004.8 C ORIGINAL VERSION--AUGUST 2004. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C INTEGER LIMIT INTEGER LENW PARAMETER(LIMIT=100) PARAMETER(LENW=4*LIMIT) INTEGER INF INTEGER NEVAL INTEGER IER INTEGER LAST INTEGER IWORK(LIMIT) DOUBLE PRECISION CHI DOUBLE PRECISION LAMBDA DOUBLE PRECISION THETA DOUBLE PRECISION EPSABS DOUBLE PRECISION EPSREL DOUBLE PRECISION RESULT DOUBLE PRECISION DCDF DOUBLE PRECISION DX DOUBLE PRECISION ABSERR DOUBLE PRECISION WORK(LENW) C DOUBLE PRECISION GIGFUN EXTERNAL GIGFUN C DOUBLE PRECISION DCHI DOUBLE PRECISION DLMBDA DOUBLE PRECISION DTHETA COMMON/GIGCOM/DCHI,DLMBDA,DTHETA C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,AKMBPC,AKMCPW,AKMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----DATA STATEMENTS------------------------------------------------- C C-----START POINT----------------------------------------------------- C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C IF(DX.LE.0.0D0)THEN WRITE(ICOUT,4) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,48)DX CALL DPWRST('XXX','WRIT') DCDF=0.0 GOTO9000 ENDIF IF(CHI.LT.0.0D0)THEN WRITE(ICOUT,5) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,48)CHI CALL DPWRST('XXX','WRIT') DCDF=0.0 GOTO9000 ENDIF IF(LAMBDA.LT.0.0D0)THEN WRITE(ICOUT,6) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,48)THETA CALL DPWRST('XXX','WRIT') DCDF=0.0 GOTO9000 ENDIF C IF(CHI.EQ.0.0D0)THEN IF(LAMBDA.EQ.0.0D0 .OR. THETA.LE.0.0D0)THEN WRITE(ICOUT,7) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,49)LAMBDA CALL DPWRST('XXX','WRIT') WRITE(ICOUT,50)THETA CALL DPWRST('XXX','WRIT') CDF=0.0 GOTO9000 ENDIF IFLAG=1 ENDIF C IF(LAMBDA.EQ.0.0D0)THEN IF(CHI.EQ.0.0D0 .OR. THETA.GT.0.0D0)THEN WRITE(ICOUT,9) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,10) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,11) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,51)CHI CALL DPWRST('XXX','WRIT') WRITE(ICOUT,50)THETA CALL DPWRST('XXX','WRIT') CDF=0.0 GOTO9000 ENDIF IFLAG=2 ENDIF C 4 FORMAT('***** ERROR: VALUE OF INPUT ARGUMENT (X) IN ', 1 'GIGCDF ROUTINE IS NON-POSITIVE.') 5 FORMAT('***** ERROR: VALUE OF FIRST SHAPE PARAMETER (CHI) IN ', 1 'GIGCDF ROUTINE IS NEGATIVE.') 6 FORMAT('***** ERROR: VALUE OF SECOND SHAPE PARAMETER (LAMBDA) ', 1 'IN GIGCDF ROUTINE IS NEGATIVE.') 7 FORMAT('***** ERROR: IF VALUE OF FIRST SHAPE PARAMETER (CHI) ', 1 'IN GIGCDF ROUTINE IS EQUAL ZERO,') 8 FORMAT(' THEN SECOND (LAMBDA) AND THIRD (THETA) SHAPE ', 1 'PARAMETERS MUST BE POSITIVE.') 9 FORMAT('***** ERROR: IF VALUE OF SECOND SHAPE PARAMETER ', 1 '(LAMBDA) IN GIGCDF ROUTINE IS EQUAL ZERO,') 10 FORMAT(' THEN FIRST SHAPE PARAMETER (LAMBDA) PARAMETER ', 1 'MUST BE POSITIVE AND') 11 FORMAT(' THE THIRD SHAPE PARAMETER (THETA) MUST BE ', 1 'NEGATIVE.') 48 FORMAT(' VALUE OF ARGUMENT IS: ',G15.7) 49 FORMAT(' VALUE OF SECOND SHAPE PARAMETER IS: ',G15.7) 50 FORMAT(' VALUE OF THIRD SHAPE PARAMETER IS: ',G15.7) 51 FORMAT(' VALUE OF FIRST SHAPE PARAMETER IS: ',G15.7) C C ************************************ C ** STEP 1-- ** C ** COMPUTE THE DENSITY FUNCTION ** C ************************************ C EPSABS=0.0D0 EPSREL=1.0D-7 IER=0 DCDF=0.0D0 C DCHI=CHI DLMBDA=LAMBDA DTHETA=THETA DCDF=0.0D0 C INF=1 C CALL DQAGI(GIGFUN,DX,INF,EPSABS,EPSREL,DCDF,ABSERR,NEVAL, 1 IER,LIMIT,LENW,LAST,IWORK,WORK) DCDF=1.0D0 - DCDF C IF(IER.EQ.1)THEN WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,111) 111 FORMAT('***** ERROR FROM GIGCDF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,113) 113 FORMAT(' MAXIMUM NUMBER OF SUBDIVISIONS EXCEEDED.') CALL DPWRST('XXX','BUG ') ELSEIF(IER.EQ.2)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,121) 121 FORMAT('***** ERROR FROM GIGCDF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,123) 123 FORMAT(' ROUNDOFF ERROR PREVENTS REQUESTED TOLERANCE ', 1 'FROM BEING ACHIEVED.') CALL DPWRST('XXX','BUG ') ELSEIF(IER.EQ.3)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,131) 131 FORMAT('***** ERROR FROM GIGCDF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,133) 133 FORMAT(' BAD INTEGRAND BEHAVIOUR DETECTED.') CALL DPWRST('XXX','BUG ') ELSEIF(IER.EQ.4)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,141) 141 FORMAT('***** ERROR FROM GIGCDF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,143) 143 FORMAT(' INTEGRATION DID NOT CONVERGE.') CALL DPWRST('XXX','BUG ') ELSEIF(IER.EQ.5)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,151) 151 FORMAT('***** ERROR FROM GIGCDF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,153) 153 FORMAT(' THE INTEGRATION IS PROBABLY DIVERGENT.') CALL DPWRST('XXX','BUG ') ELSEIF(IER.EQ.6)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,161) 161 FORMAT('***** ERROR FROM GIGCDF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,163) 163 FORMAT(' INVALID INPUT TO THE INTEGRATION ROUTINE.') CALL DPWRST('XXX','BUG ') ENDIF C 9000 CONTINUE RETURN END DOUBLE PRECISION FUNCTION GIGFUN(DX) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY C FUNCTION VALUE FOR THE GENERALIZED INVERSE GAUSIAN C DISTRIBUTION WITH SHAPE PARAMETERS CHI, LAMBDA, AND C TAU. THIS DISTRIBUTION IS DEFINED FOR POSITIVE X. C FOR ALL X AND HAS THE PROBABILITY DENSITY FUNCTION C THE GIGPDF ROUTINE IS CALLED TO COMPUTE THE C PROBABILITY DENSITY (CHECK FOR THE FORMULA IN THAT C ROUTINE). DEFINE AS FUNCTION TO BE USED FOR INTEGRATION C CODE CALLED BY GIGCDF. THIS ROUTINE USES C DOUBLE PRECISION ARITHMETIC. C INPUT ARGUMENTS--DX = THE DOUBLE PRECISION VALUE AT C WHICH THE PROBABILITY DENSITY C FUNCTION IS TO BE EVALUATED. C OUTPUT ARGUMENTS--GIGFUN = THE DOUBLE PRECISION PROBABILITY C DENSITY FUNCTION VALUE. C OUTPUT--THE DOUBLE PRECISION PROBABILITY DENSITY C FUNCTION VALUE PDF FOR THE GENERALIZED INVERSE C GAUSSIAN DISTRIBUTION WITH SHAPE PARAMETERS CHI, LAMBDA, C AND THETA. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--NONE. C OTHER DATAPAC SUBROUTINES NEEDED--GIGPDF. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, (1994), "CONTINUOUS C UNIVARIATE DISTRIBUTIONS--VOLUME 1", SECOND EDITION, C WILEY, PP. 284-285. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2004.8 C ORIGINAL VERSION--AUGUST 2004. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DTERM C DOUBLE PRECISION DX DOUBLE PRECISION DCHI DOUBLE PRECISION DLMBDA DOUBLE PRECISION DTHETA COMMON/GIGCOM/DCHI,DLMBDA,DTHETA C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----DATA STATEMENTS------------------------------------------------- C C-----START POINT----------------------------------------------------- C C ************************************ C ** STEP 1-- ** C ** COMPUTE THE DENSITY FUNCTION ** C ************************************ C CALL GIGPDF(DX,DCHI,DLMBDA,DTHETA,DTERM) GIGFUN=DTERM C 9000 CONTINUE RETURN END DOUBLE PRECISION FUNCTION GIGFU2(DX) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY C FUNCTION VALUE FOR THE GENERALIZED INVERSE GAUSIAN C DISTRIBUTION WITH SHAPE PARAMETERS CHI, LAMBDA, AND C TAU. THIS DISTRIBUTION IS DEFINED FOR POSITIVE X. C FOR ALL X AND HAS THE PROBABILITY DENSITY FUNCTION C THE GIGPDF ROUTINE IS CALLED TO COMPUTE THE C PROBABILITY DENSITY (CHECK FOR THE FORMULA IN THAT C ROUTINE). DEFINE AS FUNCTION TO BE USED FOR INTEGRATION C CODE CALLED BY GIGCDF. THIS ROUTINE USES C DOUBLE PRECISION ARITHMETIC. C INPUT ARGUMENTS--DX = THE DOUBLE PRECISION VALUE AT C WHICH THE PROBABILITY DENSITY C FUNCTION IS TO BE EVALUATED. C OUTPUT ARGUMENTS--GIGFU2 = THE DOUBLE PRECISION PROBABILITY C DENSITY FUNCTION VALUE. C OUTPUT--THE DOUBLE PRECISION PROBABILITY DENSITY C FUNCTION VALUE PDF FOR THE GENERALIZED INVERSE C GAUSSIAN DISTRIBUTION WITH SHAPE PARAMETERS CHI, LAMBDA, C AND THETA. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--NONE. C OTHER DATAPAC SUBROUTINES NEEDED--GIGPDF. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, (1994), "CONTINUOUS C UNIVARIATE DISTRIBUTIONS--VOLUME 1", SECOND EDITION, C WILEY, PP. 284-285. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2004.8 C ORIGINAL VERSION--AUGUST 2004. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DX DOUBLE PRECISION DCDF C DOUBLE PRECISION DP COMMON/GI2COM/DP C DOUBLE PRECISION DCHI DOUBLE PRECISION DLMBDA DOUBLE PRECISION DTHETA COMMON/GIGCOM/DCHI,DLMBDA,DTHETA C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----DATA STATEMENTS------------------------------------------------- C C-----START POINT----------------------------------------------------- C C ************************************ C ** STEP 1-- ** C ** COMPUTE THE CDF FUNCTION ** C ************************************ C CALL GIGCDF(DX,DCHI,DLMBDA,DTHETA,DCDF) GIGFU2=DP - DCDF C 9000 CONTINUE RETURN END SUBROUTINE GIGPDF(X,CHI,LAMBDA,THETA,PDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY C FUNCTION VALUE FOR THE GENERALIZED INVERSE GAUSSIAN C DISTRIBUTION. IT HAS SHAPE PARAMETERS CHI, LAMBDA, C AND THETA. THIS DISTRIBUTION IS DEFINED FOR POSITIVE C X AND HAS THE PROBABILITY DENSITY FUNCTION C f(X,CHI,LAMBDA,THETA) = C*X**(THETA-1)* C EXP(-(1/2)*(LAMBDA*X+CHI/X)) C X > 0; CHI, LAMBDA > 0; C -INF < THETA < INF C C WITH C C C = (LAMBDA/X)**(THETA/2)/[2*K(0)(SQRT(CHI*LAMBDA))] C CHI, LAMBDA > 0 C C = LAMBDA**THETA/[2**THETA*GAMMA(THETA)] C CHI = 0; LAMBDA, THETA > 0 C C = 2**THETA/[X**THETA*GAMMA(-THETA)] C CHI > 0; LAMBDA=0; THETA < 0 C C WHERE K(LAMBDA) IS THE MODIFIED BESSEL FUNCTION C OF THE THIRD KIND. C C INPUT ARGUMENTS--X = THE DOUBLE PRECISION VALUE AT C WHICH THE PROBABILITY DENSITY C FUNCTION IS TO BE EVALUATED. C X SHOULD BE POSITIVE. C --CHI = THE FIRST SHAPE PARAMETER C --LAMBDA = THE THIRD SHAPE PARAMETER C --THETA = THE THIRD SHAPE PARAMETER C OUTPUT ARGUMENTS--PDF = THE SINGLE PRECISION PROBABILITY C DENSITY FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY FUNCTION C VALUE PDF FOR THE GENERALIZED INVERSE GAUSSIAN C DISTRIBUTION WITH SHAPE PARAMETERS = CHI, LAMBDA, THETA. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--NONE. C OTHER DATAPAC SUBROUTINES NEEDED--DBESK. C FORTRAN LIBRARY SUBROUTINES NEEDED--DEXP, DLOG. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, (1994), "CONTINUOUS C UNIVARIATE DISTRIBUTIONS--VOLUME 1", SECOND EDITION, C WILEY, PP. 284-285. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2004.8 C ORIGINAL VERSION--AUGUST 2004. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION X DOUBLE PRECISION CHI DOUBLE PRECISION LAMBDA DOUBLE PRECISION THETA DOUBLE PRECISION PDF DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 DOUBLE PRECISION DTERM3 DOUBLE PRECISION DTERM4 DOUBLE PRECISION DC1 DOUBLE PRECISION DC2 DOUBLE PRECISION DC3 DOUBLE PRECISION DLNGAM EXTERNAL DLNGAM C DOUBLE PRECISION DTEMP1(10) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C ***************************************** C ** STEP 1-- ** C ** CHECK FOR VALID PARAMETERS ** C ***************************************** C IF(X.LE.0.0D0)THEN WRITE(ICOUT,4) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,48)X CALL DPWRST('XXX','WRIT') PDF=0.0 GOTO9000 ENDIF IF(CHI.LT.0.0D0)THEN WRITE(ICOUT,5) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,48)CHI CALL DPWRST('XXX','WRIT') PDF=0.0 GOTO9000 ENDIF IF(LAMBDA.LT.0.0D0)THEN WRITE(ICOUT,6) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,48)THETA CALL DPWRST('XXX','WRIT') PDF=0.0 GOTO9000 ENDIF C IFLAG=0 C IF(CHI.EQ.0.0D0)THEN IF(LAMBDA.EQ.0.0D0 .OR. THETA.LE.0.0D0)THEN WRITE(ICOUT,7) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,49)LAMBDA CALL DPWRST('XXX','WRIT') WRITE(ICOUT,50)THETA CALL DPWRST('XXX','WRIT') PDF=0.0 GOTO9000 ENDIF IFLAG=1 ENDIF C IF(LAMBDA.EQ.0.0D0)THEN IF(CHI.EQ.0.0D0 .OR. THETA.GT.0.0D0)THEN WRITE(ICOUT,9) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,10) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,11) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,51)CHI CALL DPWRST('XXX','WRIT') WRITE(ICOUT,50)THETA CALL DPWRST('XXX','WRIT') PDF=0.0 GOTO9000 ENDIF IFLAG=2 ENDIF C 4 FORMAT('***** ERROR: VALUE OF INPUT ARGUMENT (X) IN ', 1 'GIGPDF ROUTINE IS NON-POSITIVE.') 5 FORMAT('***** ERROR: VALUE OF FIRST SHAPE PARAMETER (CHI) IN ', 1 'GIGPDF ROUTINE IS NEGATIVE.') 6 FORMAT('***** ERROR: VALUE OF SECOND SHAPE PARAMETER (LAMBDA) ', 1 'IN GIGPDF ROUTINE IS NEGATIVE.') 7 FORMAT('***** ERROR: IF VALUE OF FIRST SHAPE PARAMETER (CHI) ', 1 'IN GIGPDF ROUTINE IS EQUAL ZERO,') 8 FORMAT(' THEN SECOND (LAMBDA) AND THIRD (THETA) SHAPE ', 1 'PARAMETERS MUST BE POSITIVE.') 9 FORMAT('***** ERROR: IF VALUE OF SECOND SHAPE PARAMETER ', 1 '(LAMBDA) IN GIGPDF ROUTINE IS EQUAL ZERO,') 10 FORMAT(' THEN FIRST SHAPE PARAMETER (LAMBDA) PARAMETER ', 1 'MUST BE POSITIVE AND') 11 FORMAT(' THE THIRD SHAPE PARAMETER (THETA) MUST BE ', 1 'NEGATIVE.') 48 FORMAT(' VALUE OF ARGUMENT IS: ',G15.7) 49 FORMAT(' VALUE OF SECOND SHAPE PARAMETER IS: ',G15.7) 50 FORMAT(' VALUE OF THIRD SHAPE PARAMETER IS: ',G15.7) 51 FORMAT(' VALUE OF FIRST SHAPE PARAMETER IS: ',G15.7) C C ***************************************** C ** STEP 2-- ** C ** COMPUTE THE DENSITY FUNCTION. FOR ** C ** BETTER NUMERICAL STABILITY, ** C ** COMPUTE LOGARIGHMS. ** C ***************************************** C C C IF(IFLAG.EQ.0)THEN DC1=(THETA/2.0D0)*DLOG(LAMBDA/CHI) - DLOG(2.0D0) DC2=DSQRT(LAMBDA*CHI) DC3=DABS(THETA) CCCCC IF(DC3.EQ.0.0D0)THEN CCCCC TERM3=BESK0(REAL(DC2)) CCCCC DTERM2=DLOG(DBLE(TERM3)) CCCCC ELSEIF(DC3.EQ.1.0D0)THEN CCCCC TERM3=BESK1(REAL(DC2)) CCCCC DTERM2=DLOG(DBLE(TERM3)) CCCCC ELSE IARG1=1 ISCALE=1 CALL DBESK(DC2,THETA,ISCALE,IARG1,DTEMP1,NZERO) DTERM2=DLOG(DTEMP1(IARG1)) CCCCC ENDIF DTERM1=DC1 - DTERM2 ELSEIF(IFLAG.EQ.1)THEN DTERM2=THETA*DLOG(LAMBDA) - THETA*DLOG(2.0D0) - DLNGAM(THETA) DTERM1=DEXP(DTERM1) ELSEIF(IFLAG.EQ.2)THEN DTERM2=THETA*DLOG(2.0D0) - THETA*DLOG(CHI) - DLNGAM(-THETA) DTERM1=DEXP(DTERM1) ENDIF C DTERM2=(THETA-1.0D0)*DLOG(X) DTERM3=-0.5*(LAMBDA*X + (CHI/X)) DTERM4=DTERM1 + DTERM2 + DTERM3 C IF(DTERM4.LE.-80.0D0)THEN PDF=0.0D0 ELSEIF(DTERM4.GE.80.0D0)THEN PDF=0.0D0 WRITE(ICOUT,1005)X CALL DPWRST('XXX','WRIT') ELSE PDF=DEXP(DTERM4) ENDIF 1005 FORMAT('***** ERROR: COMPUTATION FOR GIGPDF RESULTS IN ', 1 'OVERFLOW FOR INPUT ARGUMENT = ',G15.7) C 9000 CONTINUE RETURN END SUBROUTINE GIGPPF(P,CHI,LAMBDA,THETA,PPF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT C FUNCTION VALUE FOR THE GENERALIZED INVERSE GAUSSIAN C DISTRIBUTION. IT HAS SHAPE PARAMETERS CHI, LAMBDA, C AND THETA. THIS DISTRIBUTION IS DEFINED FOR POSITIVE C X AND HAS THE PROBABILITY DENSITY FUNCTION C f(X,CHI,LAMBDA,THETA) = C*X**(THETA-1)* C EXP(-(1/2)*(LAMBDA*X+CHI/X)) C X > 0; CHI, LAMBDA > 0; C -INF < THETA < INF C C WITH C C C = (LAMBDA/X)**(THETA/2)/[2*K(0)(SQRT(CHI*LAMBDA))] C CHI, LAMBDA > 0 C C = LAMBDA**THETA/[2**THETA*GAMMA(THETA)] C CHI = 0; LAMBDA, THETA > 0 C C = 2**THETA/[X**THETA*GAMMA(-THETA)] C CHI > 0; LAMBDA=0; THETA < 0 C C WHERE K(LAMBDA) IS THE MODIFIED BESSEL FUNCTION C OF THE THIRD KIND. C C THE PERCENT POINT FUNCTION IS COMPUTED BY NUMERICALLY C INVERTING THE GENERALIZED INVERSE GAUSSIAN CUMULATIVE C DISTRIBUTION FUNCTION (WHICH IN TURN IS COMPUTED BY C NUMERICAL INTEGRATION OF THE PROBABILITYT DENSITY. C C INPUT ARGUMENTS--P = THE DOUBLE PRECISION VALUE AT C WHICH THE PERCENT POINT C FUNCTION IS TO BE EVALUATED. C 0 < P < 1 C --CHI = THE FIRST SHAPE PARAMETER C --LAMBDA = THE THIRD SHAPE PARAMETER C --THETA = THE THIRD SHAPE PARAMETER C OUTPUT ARGUMENTS--PPF = THE SINGLE PRECISION PERCENT POINT C FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION PERCENT POINT FUNCTION C VALUE PPF FOR THE GENERALIZED INVERSE GAUSSIAN C DISTRIBUTION WITH SHAPE PARAMETERS = CHI, LAMBDA, THETA. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--NONE. C OTHER DATAPAC SUBROUTINES NEEDED--DFZERO. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, (1994), "CONTINUOUS C UNIVARIATE DISTRIBUTIONS--VOLUME 1", SECOND EDITION, C WILEY, PP. 284-285. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2004.8 C ORIGINAL VERSION--AUGUST 2004. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION P DOUBLE PRECISION PTEMP DOUBLE PRECISION CHI DOUBLE PRECISION LAMBDA DOUBLE PRECISION THETA DOUBLE PRECISION PPF DOUBLE PRECISION DMEAN DOUBLE PRECISION DSD DOUBLE PRECISION DR DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 DOUBLE PRECISION DTERM3 C DOUBLE PRECISION DTEMP1(10) C DOUBLE PRECISION XUP DOUBLE PRECISION XUP2 DOUBLE PRECISION XLOW DOUBLE PRECISION RE DOUBLE PRECISION AE C DOUBLE PRECISION GIGFU2 EXTERNAL GIGFU2 C DOUBLE PRECISION DP COMMON/GI2COM/DP C DOUBLE PRECISION DCHI DOUBLE PRECISION DLMBDA DOUBLE PRECISION DTHETA COMMON/GIGCOM/DCHI,DLMBDA,DTHETA C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C ***************************************** C ** STEP 1-- ** C ** CHECK FOR VALID PARAMETERS ** C ***************************************** C IF(P.LE.0.0D0 .OR. P.GE.1.0D0)THEN WRITE(ICOUT,4) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,48)P CALL DPWRST('XXX','WRIT') PPF=0.0D0 GOTO9000 ENDIF IF(CHI.LT.0.0D0)THEN WRITE(ICOUT,5) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,48)CHI CALL DPWRST('XXX','WRIT') PPF=0.0D0 GOTO9000 ENDIF IF(LAMBDA.LT.0.0D0)THEN WRITE(ICOUT,6) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,48)THETA CALL DPWRST('XXX','WRIT') PPF=0.0D0 GOTO9000 ENDIF C IFLAG=0 C IF(CHI.EQ.0.0D0)THEN IF(LAMBDA.EQ.0.0D0 .OR. THETA.LE.0.0D0)THEN WRITE(ICOUT,7) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,49)LAMBDA CALL DPWRST('XXX','WRIT') WRITE(ICOUT,50)THETA CALL DPWRST('XXX','WRIT') PPF=0.0D0 GOTO9000 ENDIF IFLAG=1 ENDIF C IF(LAMBDA.EQ.0.0D0)THEN IF(CHI.EQ.0.0D0 .OR. THETA.GT.0.0D0)THEN WRITE(ICOUT,9) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,10) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,11) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,51)CHI CALL DPWRST('XXX','WRIT') WRITE(ICOUT,50)THETA CALL DPWRST('XXX','WRIT') PPF=0.0D0 GOTO9000 ENDIF IFLAG=2 ENDIF C 4 FORMAT('***** ERROR: VALUE OF INPUT ARGUMENT (P) IN ', 1 'GIGPPF ROUTINE') 14 FORMAT(' IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL.') 5 FORMAT('***** ERROR: VALUE OF FIRST SHAPE PARAMETER (CHI) IN ', 1 'GIGPPF ROUTINE IS NEGATIVE.') 6 FORMAT('***** ERROR: VALUE OF SECOND SHAPE PARAMETER (LAMBDA) ', 1 'IN GIGPPF ROUTINE IS NEGATIVE.') 7 FORMAT('***** ERROR: IF VALUE OF FIRST SHAPE PARAMETER (CHI) ', 1 'IN GIGPPF ROUTINE IS EQUAL ZERO,') 8 FORMAT(' THEN SECOND (LAMBDA) AND THIRD (THETA) SHAPE ', 1 'PARAMETERS MUST BE POSITIVE.') 9 FORMAT('***** ERROR: IF VALUE OF SECOND SHAPE PARAMETER ', 1 '(LAMBDA) IN GIGPPF ROUTINE IS EQUAL ZERO,') 10 FORMAT(' THEN FIRST SHAPE PARAMETER (LAMBDA) PARAMETER ', 1 'MUST BE POSITIVE AND') 11 FORMAT(' THE THIRD SHAPE PARAMETER (THETA) MUST BE ', 1 'NEGATIVE.') 48 FORMAT(' VALUE OF ARGUMENT IS: ',G15.7) 49 FORMAT(' VALUE OF SECOND SHAPE PARAMETER IS: ',G15.7) 50 FORMAT(' VALUE OF THIRD SHAPE PARAMETER IS: ',G15.7) 51 FORMAT(' VALUE OF FIRST SHAPE PARAMETER IS: ',G15.7) C C ***************************************** C ** STEP 2-- ** C ** COMPUTE THE PERCENT POINT FUNCTION.** C ***************************************** C C STEP 1: FIND BRACKETING INTERVAL. LOWER BOUND IS ZERO. START C WITH UPPER BOUND = MEAN: C MEAN=K(THETA+1)(SQRT(LAMBDA*CHI))*SQRT(CHI/LAMBDA)/ C K(THETA)(SQRT(LAMBDA*CHI)) C INCREMENT IN INTERVALS OF 1 STANDARD DEVIATION: C VARIANCE=K(THETA+2)(SQRT(LAMBDA*CHI))*(CHI/LAMBDA)/ C K(THETA)(SQRT(LAMBDA*CHI)) C XLOW=0.000000001D0 CALL GIGCDF(XLOW,CHI,LAMBDA,THETA,PTEMP) IF(P.LE.PTEMP)THEN PPF=XLOW GOTO9000 ENDIF C IARG1=1 ISCALE=1 DR=DABS(THETA) CALL DBESK(DSQRT(LAMBDA*CHI),DR,ISCALE,IARG1,DTEMP1,NZERO) DTERM1=DTEMP1(1) DR=DABS(THETA+1.0D0) CALL DBESK(DSQRT(LAMBDA*CHI),DR,ISCALE,IARG1,DTEMP1,NZERO) DTERM2=DTEMP1(1) DR=DABS(THETA+2.0D0) CALL DBESK(DSQRT(LAMBDA*CHI),DR,ISCALE,IARG1,DTEMP1,NZERO) DTERM3=DTEMP1(1) DMEAN=(DTERM2/DTERM1)*DSQRT(CHI/LAMBDA) DSD=DSQRT((DTERM3/DTERM1)*(CHI/LAMBDA)) C MAXIT=1000 NIT=0 C XUP2=DMEAN 200 CONTINUE IF(NIT.GT.MAXIT)THEN PPF=0.0D0 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,131) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,133) CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF CALL GIGCDF(XUP2,CHI,LAMBDA,THETA,PTEMP) IF(PTEMP.GT.P)THEN XUP=XUP2 ELSE XLOW=XUP2 XUP2=XUP2 + DSD NIT=NIT+1 GOTO200 ENDIF C 300 CONTINUE AE=1.D-7 RE=1.D-7 DCHI=CHI DLMBDA=LAMBDA DTHETA=THETA DP=P CALL DFZERO(GIGFU2,XLOW,XUP,XUP,RE,AE,IFLAG) C PPF=XLOW C IF(IFLAG.EQ.2)THEN C C NOTE: SUPPRESS THIS MESSAGE FOR NOW. CCCCC WRITE(ICOUT,999) 999 FORMAT(1X) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,111) CC111 FORMAT('***** WARNING FROM GIGPPF--') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,113) CC113 FORMAT(' PPF VALUE MAY NOT BE COMPUTED TO DESIRED ', CCCCC1 'TOLERANCE.') CCCCC CALL DPWRST('XXX','BUG ') ELSEIF(IFLAG.EQ.3)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,121) 121 FORMAT('***** WARNING FROM GIGPPF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,123) 123 FORMAT(' PPF VALUE MAY BE NEAR A SINGULAR POINT.') CALL DPWRST('XXX','BUG ') ELSEIF(IFLAG.EQ.4)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,131) 131 FORMAT('***** ERROR FROM GIGPPF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,133) 133 FORMAT(' APPROPRIATE BRACKETING INTERVAL NOT FOUND.') CALL DPWRST('XXX','BUG ') ELSEIF(IFLAG.EQ.5)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,141) 141 FORMAT('***** WARNING FROM GIGPPF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,143) 143 FORMAT(' MAXIMUM ITERATIONS EXCEEDED.') CALL DPWRST('XXX','BUG ') ENDIF C C 9000 CONTINUE RETURN END SUBROUTINE GIGRAN(N,CHI,LAMBDA,THETA,ISEED,X) C C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N C FROM THE THE GENERALIZED INVERSE GAUSSIAN DISTIBUTION C WITH LOCATION = 0 AND SCALE = 1. THIS DISTRIBUTION IS C DEFINED FOR POSITIVE X AND HAS THE PROBABILITY DENSITY C FUNCTION: C f(X,CHI,LAMBDA,THETA) = C*X**(THETA-1)* C EXP(-(1/2)*(LAMBDA*X+CHI/X)) C X > 0; CHI, LAMBDA > 0; C -INF < THETA < INF C C WITH C C C = (LAMBDA/X)**(THETA/2)/[2*K(0)(SQRT(CHI*LAMBDA))] C CHI, LAMBDA > 0 C C = LAMBDA**THETA/[2**THETA*GAMMA(THETA)] C CHI = 0; LAMBDA, THETA > 0 C C = 2**THETA/[X**THETA*GAMMA(-THETA)] C CHI > 0; LAMBDA=0; THETA < 0 C C WHERE K(LAMBDA) IS THE MODIFIED BESSEL FUNCTION C OF THE THIRD KIND. C C INPUT ARGUMENTS--N = THE DESIRED INTEGER NUMBER C OF RANDOM NUMBERS TO BE 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 --CHI = A SINGLE PRECISON SCALAR THAT DEFINES C THE FIRST SHAPE PARAMETER. C --LAMBDA = A SINGLE PRECISON SCALAR THAT DEFINES C THE SECOND SHAPE PARAMETER. C --THETA = A SINGLE PRECISON SCALAR THAT DEFINES C THE THIRD SHAPE PARAMETER. C OUTPUT--A RANDOM SAMPLE OF SIZE N FROM THE COMPERTZ-MAKEHAM C DISTRIBUTION WITH LOCATION = 0 AND SCALE = 1. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C OTHER DATAPAC SUBROUTINES NEEDED--UNIRAN, GIGPPF. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C METHOD--TRANSFORM NORMAL RANDOM NUMBERS C REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, (1994), "CONTINUOUS C UNIVARIATE DISTRIBUTIONS--VOLUME 1", SECOND EDITION, C WILEY, PP. 284-285. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--2004.8 C ORIGINAL VERSION--OCTOBER 2004. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DIMENSION X(*) REAL CHI REAL THETA REAL LAMBDA C DOUBLE PRECISION DCHI DOUBLE PRECISION DTHETA DOUBLE PRECISION DLMBDA DOUBLE PRECISION DPPF DOUBLE PRECISION DXTEMP 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, 3) CALL DPWRST('XXX','BUG ') WRITE(ICOUT, 4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)N CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF 3 FORMAT('***** ERROR--THE REQUESTED NUMBER OF GENERALIZED ', 1'INVERSE GAUSIAN') 4 FORMAT(' RANDOM NUMBERS IS NON-POSITIVE.') 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7) C IF(CHI.LT.0.0)THEN WRITE(ICOUT,5) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,48)CHI CALL DPWRST('XXX','WRIT') GOTO9000 ENDIF IF(LAMBDA.LT.0.0)THEN WRITE(ICOUT,6) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,48)THETA CALL DPWRST('XXX','WRIT') GOTO9000 ENDIF C IFLAG=0 C IF(CHI.EQ.0.0)THEN IF(LAMBDA.EQ.0.0 .OR. THETA.LE.0.0)THEN WRITE(ICOUT,7) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,49)LAMBDA CALL DPWRST('XXX','WRIT') WRITE(ICOUT,50)THETA CALL DPWRST('XXX','WRIT') GOTO9000 ENDIF IFLAG=1 ENDIF C IF(LAMBDA.EQ.0.0)THEN IF(CHI.EQ.0.0 .OR. THETA.GT.0.0)THEN WRITE(ICOUT,9) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,10) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,11) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,51)CHI CALL DPWRST('XXX','WRIT') WRITE(ICOUT,50)THETA CALL DPWRST('XXX','WRIT') GOTO9000 ENDIF IFLAG=2 ENDIF C 5 FORMAT('***** ERROR: VALUE OF FIRST SHAPE PARAMETER (CHI) IN ', 1 'GIGRAN ROUTINE IS NEGATIVE.') 6 FORMAT('***** ERROR: VALUE OF SECOND SHAPE PARAMETER (LAMBDA) ', 1 'IN GIGRAN ROUTINE IS NEGATIVE.') 7 FORMAT('***** ERROR: IF VALUE OF FIRST SHAPE PARAMETER (CHI) ', 1 'IN GIGRAN ROUTINE IS EQUAL ZERO,') 8 FORMAT(' THEN SECOND (LAMBDA) AND THIRD (THETA) SHAPE ', 1 'PARAMETERS MUST BE POSITIVE.') 9 FORMAT('***** ERROR: IF VALUE OF SECOND SHAPE PARAMETER ', 1 '(LAMBDA) IN GIGRAN ROUTINE IS EQUAL ZERO,') 10 FORMAT(' THEN FIRST SHAPE PARAMETER (LAMBDA) PARAMETER ', 1 'MUST BE POSITIVE AND') 11 FORMAT(' THE THIRD SHAPE PARAMETER (THETA) MUST BE ', 1 'NEGATIVE.') 48 FORMAT(' VALUE OF ARGUMENT IS: ',G15.7) 49 FORMAT(' VALUE OF SECOND SHAPE PARAMETER IS: ',G15.7) 50 FORMAT(' VALUE OF THIRD SHAPE PARAMETER IS: ',G15.7) 51 FORMAT(' VALUE OF FIRST SHAPE PARAMETER IS: ',G15.7) C C GENERATE N UNIFORM NUMBERS; C CALL UNIRAN(N,ISEED,X) C C GENERATE N GENERALIZED INVERSE GAUSSIAN RANDON NUMBERS USING C THE PERCENT POINT FUNCTION TRANSFORMATION. C DCHI=DBLE(CHI) DLMBDA=DBLE(LAMBDA) DTHETA=DBLE(THETA) DO100I=1,N DXTEMP=DBLE(X(I)) CALL GIGPPF(DXTEMP,DCHI,DLMBDA,DTHETA,DPPF) X(I)=REAL(DPPF) 100 CONTINUE C 9000 CONTINUE RETURN END SUBROUTINE GLDCDF(DX,DL3,DL4,DCDF,IGLDDF,IWRITE) C C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION C FUNCTION VALUE FOR THE GENERALIZED LAMBDA DISTRIBUTION C WITH SHAPE PARAMETER VALUES = ALAMB3 AND ALAMB4. C C NOTE THAT THERE ARE TWO COMMON PARAMETERIZATIONS C OF THIS PPF. C C THE ORIGINAL RAMBERG AND SCHMEISER PARAMETERIZATION: C C G(P) = P**LAMBDA3 - (1-P)**LAMBDA4 C C THE FREIMER, MUDHOLKAR, KOLLIA, AND LIN (FMKL) C PARAMETERIZATION: C C G(P) = (P**LAMBDA3 - 1)/LAMBDA3 - C ((1-P)**LAMBDA4 -1)/LAMBDA4 C C THE IDEF VARIABLE IDENTIFIES THE APPROPRIATE C DEFINITION TO USE. THE FMKL DEFINITION IS C BECOMING THE PREFERRED PARAMETERIZATION) SINCE IT C DEFINES A VALID PROBABILITY DISTRIBUTION FOR ALL C VALUES OF LAMBDA3 AND LAMBDA4 (THE RAMBERG C PARAMETERIZATION HAS REGIONS OF LAMBDA3 AND LAMBDA4 C WHERE A VALID PROBABILITY DISTRIBUTION IS NOT C DEFINED). C C INPUT ARGUMENTS--DX = THE DOUBLE PRECISION VALUE AT C WHICH THE CUMULATIVE DISTRIBUTION C FUNCTION IS TO BE EVALUATED. C --DL3 = THE DOUBLE PRECISION VALUE OF LAMBDA3 C (THE FIRST SHAPE PARAMETER). C --DL4 = THE DOUBLE PRECISION VALUE OF LAMBDA4 C (THE SECOND SHAPE PARAMETER). C OUTPUT ARGUMENTS--DCDF = THE DOUBLE PRECISION CUMULATIVE C DISTRIBUTION FUNCTION VALUE. C OUTPUT--THE DOUBLE PRECISION CUMULATIVE DISTRIBUTION C FUNCTION VALUE DCDF FOR THE GENERALIZED TUKEY LAMBDA C DISTRIBUTION WITH SHAPE PARAMETERS = ALAMB3 AND ALAMB4. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--CALL GLDCHK TO CHECK FOR VALID VALUES OF THE C SHAPE PARAMETERS. C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN. C REFERENCES--KARIAN AND DUDEWICZ, 'FITTING STATISTICAL C DISTRIBUTIONS: THE GENERALIZED LAMBDA DISTRIBUTION C AND GENERALIZED BOOTSTRAP METHODS', CRC, 2000. C --STEVE SU, "A DISCRETIZED APPROACH TO FLEXIBLY FIT C GENRALIZED LAMBDA DISTRIBUTIONS TO DATA", C JOURNAL OF MODERN APPLIED STATISTICAL METHODS, C NOVEMBER, 2005,, VOL. 4, NO. 2, 408-424. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE: 301-975-2855 C ORIGINAL VERSION--AUGUST 2001. C UPDATED --MARCH 2006. FLMK PARAMETERIZATION C MAKE DOUBLE PRECISION C BOUNDS ON CDF FOR CASE C WHERE EITHER LAMBDA3 OR C LAMBDA4 <= 0 C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DX DOUBLE PRECISION DL3 DOUBLE PRECISION DL4 DOUBLE PRECISION DCDF DOUBLE PRECISION DPPF DOUBLE PRECISION DZERO DOUBLE PRECISION DONE DOUBLE PRECISION DLOWER DOUBLE PRECISION DUPPER DOUBLE PRECISION DEPS DOUBLE PRECISION PDEL DOUBLE PRECISION PMIN DOUBLE PRECISION PMAX DOUBLE PRECISION PMAXIN DOUBLE PRECISION PMID DOUBLE PRECISION PMIDZ DOUBLE PRECISION XCALC DOUBLE PRECISION XTEMP1 DOUBLE PRECISION XTEMP2 C CHARACTER*4 IWRITE CHARACTER*4 IGLDDF C CHARACTER*4 IFEEDB CHARACTER*4 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 DZERO /0.0D0/ DATA DONE /1.0D0/ DATA DEPS /1.0D-8/ C C--------------------------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C DZERO=0.0D0 DONE=1.0D0 C C RAMBERG PARAMETERIZATION NOT CURRENTLY SUPPORTED. MAY C ADD LATER. C CCCCC IF(IGLDDF.EQ.'RAMB')THEN CCCCC CALL GLDCHK(REAL(DL3),REAL(DL4),ALOWER,AUPPER,IFLAG, CCCCC1 ISIGN,IWRITE) CCCCC DLOWER=DBLE(ALOWER) CCCCC DUPPER=DBLE(AUPPER) CCCCC IF(IFLAG.EQ.1)GOTO9000 C CCCCC IF(DX.LE.DLOWER)THEN CCCCC DCDF=0.0D0 CCCCC GOTO9000 CCCCC ENDIF CCCCC IF(DX.GE.DUPPER)THEN CCCCC DCDF=1.0D0 CCCCC GOTO9000 CCCCC ENDIF CCCCC ELSE C C FOR THE FMKL PARAMETERIZATION: C C 1) IF LAMBDA3 <= 0, THE LOWER TAIL IS UNBOUNDED. C IF LAMDA3 > 0, THE LOWER TAIL IS BOUNDED AT -1/LAMBDA3 C C 2) IF LAMBDA4 <= 0, THE UPPER TAIL IS UNBOUNDED. C IF LAMDA4 > 0, THE UPPER TAIL IS BOUNDED AT 1/LAMBDA4 C IF(DL3.LE.0.0D0 .AND. DL4.LE.0.0D0)THEN DLOWER=DBLE(CPUMIN) DUPPER=DBLE(CPUMAX) PMIN=0.00001D0 PMAX=0.99999D0 ELSEIF(DL3.LE.0.0D0)THEN DLOWER=DBLE(CPUMIN) CALL GLDPPF(DONE,DL3,DL4,DUPPER,IGLDDF,IWRITE) PMIN=0.00001D0 PMAX=1.0D0 ELSEIF(DL4.LE.0.0D0)THEN CALL GLDPPF(DZERO,DL3,DL4,DLOWER,IGLDDF,IWRITE) DUPPER=DBLE(CPUMAX) PMIN=0.0D0 PMAX=0.99999D0 ELSE CALL GLDPPF(DZERO,DL3,DL4,DLOWER,IGLDDF,IWRITE) CALL GLDPPF(DONE,DL3,DL4,DUPPER,IGLDDF,IWRITE) PMIN=0.0D0 PMAX=1.0D0 ENDIF CCCCC ENDIF C DCDF=0.0D0 C C STEP 1: DETERMINE IF X IS OUTSIDE BOUNDS C IF(DX.LE.DLOWER)THEN DCDF=0.0D0 GOTO9000 ELSEIF(DX.GE.DUPPER)THEN DCDF=1.0D0 GOTO9000 ENDIF C C STEP 2: DETERMINE AN APPROPRIATE BRACKETING INTERVAL. C NOTE THAT THIS IS ONLY AN ISSUE IF ONE OR BOTH OF C THE SHAPE PARAMETERS IS ZERO. C ITER=0 PMAXIN=0.000009 100 CONTINUE CALL GLDPPF(PMIN,DL3,DL4,XTEMP1,IGLDDF,IWRITE) CALL GLDPPF(PMAX,DL3,DL4,XTEMP2,IGLDDF,IWRITE) IF((DX.GE.XTEMP1) .AND. DX.LE.XTEMP2)THEN GOTO200 PMAX=XUP2 ELSEIF(DX.LT.XTEMP1)THEN PMIN=PMIN/10.0D0 ELSEIF(DX.GT.XTEMP2)THEN PMAXIN=PMAXIN/10.0D0 PMAX=PMAX + PMAXIN ENDIF C ITER=ITER+1 IF(ITER.GT.20)THEN WRITE(ICOUT,201) 201 FORMAT('***** ERROR FROM GLDCDF--UNABLE TO FIND A ', 1 'BRACKETING INTERVAL') CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF C GOTO100 C C ITERATION LOOP (BISECTION SEARCH OF PPF FUNCTION) C 200 CONTINUE PLOWER=PMIN PUPPER=PMAX PMID=0.5D0 ICOUNT=0 C IWRITE='OFF' 210 CONTINUE PMIDZ=PMID CALL GLDPPF(PMIDZ,DL3,DL4,XCALC,IGLDDF,IWRITE) IF(XCALC.EQ.DX)THEN DCDF=PMID GOTO9000 ELSEIF(XCALC.GT.DX)THEN PMAX=PMID PMID=(PMID+PMIN)/2.0D0 PDEL=DABS(PMID-PMIN) ICOUNT=ICOUNT+1 IF(PDEL.LT.0.00000001D0.OR.ICOUNT.GT.1000)THEN DCDF=PMID GOTO9000 ENDIF GOTO210 ELSE PMIN=PMID PMID=(PMID+PMAX)/2.0D0 PDEL=DABS(PMID-PMIN) ICOUNT=ICOUNT+1 IF(PDEL.LT.0.00000001D0.OR.ICOUNT.GT.1000)THEN DCDF=PMID GOTO9000 ENDIF GOTO210 ENDIF C 9000 CONTINUE RETURN END SUBROUTINE GLDCHK(ALAMB3,ALAMB4,ALOWER,AUPPER,IFLAG,ISIGN, 1IWRITE) C C PURPOSE--THIS SUBROUTINE DETERMINES IF THE SPECIFIED PARAMETERS C FOR THE GENERALIZD LAMBDA DISTRIBUTION RESULT IN C A VALID PROBABILITY DISTRIBUTION. IF SO, IT ALSO C RETURNS THE LOWER AND UPPER RANGES OF THE PDF FOR C THE SPECIFIED VALUES. IN PARTICULAR: C 1) ALAMB3 >= 0, ALAMB4 >= 0: C VALID, (-1,1) C 2) ALAMB3 <= 0, ALAMB4 <= 0: C VALID, (-1,1) C 3) ALAMB3 <= -1, ALAMB4 >= 1: C VALID, (-1,1) C 4) ALAMB3 >= 1, ALAMB4 <= -1: C VALID C 5) 0 < ALAMB3 < 1, ALAMB4 < 0: C NOT VALID C 6) ALAMB3 < 0, 0 < ALAMB4 < 1: C NOT VALID C 7) -1 < ALAMB3 < 0, ALAMB4 > 0: C VALID IF C [(1-ALAMB3)**(1-ALAMB3)]/ C [(ALAMB4-ALAMB3)**(ALAMB4-ALAMB3)]* C (ALAMB4-1)**(ALAMB4-1) < -ALAMB3/ALAMB4 C 8) ALAMB3 > 1, -1 < ALAMB4 < 0: C VALID IF C [(1-ALAMB4)**(1-ALAMB4)]/ C [(ALAMB3-ALAMB4)**(ALAMB3-ALAMB4)]* C (ALAMB3-1)**(ALAMB3-1) < -ALAMB4/ALAMB3 C C --THE SUPPORT REGIONS ARE C 1) ALAMB3 > 0, ALAMB4 > 0: [-1,1] C 2) ALAMB3 > 0, ALAMB4 = 0: [0,1] C 3) ALAMB3 = 0, ALAMB4 > 0: [-1,0] C 4) ALAMB3 < 0, ALAMB4 < 0: (CPUMIN,CPUMAX) C 5) ALAMB3 < 0, ALAMB4 = 0: (CPUMIN,1] C 6) ALAMB3 = 0, ALAMB4 < 0: [-1,CPUMAX) C C --NOTE: SIGN OF SHAPE PARAMETER MUST BE THE SAME AS C SIGN RETURNED BY GLDPPF FUNCTION. RETURN C ISIGN AS +1 IF SHAPE MUST BE POSITIVE AND C -1 IF SHAPE PARAMETER MUST BE NEGATIVE. C C --THE ABOVE REGIONS FOR VALID PDFS AND SUPPORT REGIONS C ARE FROM KARIAN AND DUDEWIZC C (SEE REFERENCE BELOW) C INPUT ARGUMENTS--ALAMB3 = THE SINGLE PRECISION VALUE OF LAMBDA3 C (THE FIRST SHAPE PARAMETER). C --ALAMB4 = THE SINGLE PRECISION VALUE OF LAMBDA3 C (THE SECOND SHAPE PARAMETER). C OUTPUT ARGUMENTS--ALOWER = THE SINGLE PRECISION VALUE THAT IS C THE MINIMUM OF THE ACCEPTABLE RANGE. C --AUPPER = THE SINGLE PRECISION VALUE THAT IS C THE MAXIMUM OF THE ACCEPTABLE RANGE. C --IFLAG = THE INTEGER FLAG THAT IS SET TO 0 C FOR A VALID DISTRIBUTION AND TO 1 C FOR AN INVALID DISTRIBUTION. C OUTPUT--THE SINGLE PRECISION PERCENT POINT C FUNCTION VALUE PPF FOR THE TUKEY LAMBDA DISTRIBUTION C WITH TAIL LENGTH PARAMETERS = ALAMB3 AND ALAMB4. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--TO BE ADDED. C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--ALOG. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISIONS. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--KARIAN AND DUDEWICZ, 'FITTING STATISTICAL C DISTRIBUTIONS: THE GENERALIZED LAMBDA DISTRIBUTION C AND GENERALIZED BOOTSTRAP METHODS', CRC, 2000. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2001.8 C ORIGINAL VERSION--AUGUST 2001. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 DOUBLE PRECISION DTERM3 DOUBLE PRECISION DTERM4 DOUBLE PRECISION DTERM5 DOUBLE PRECISION DLAM3 DOUBLE PRECISION DLAM4 DOUBLE PRECISION DP C CHARACTER*4 IWRITE 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 FOR VALID PDF FIRST. ASSUME VALID, THEN CHECK FOR C INVALID REGIONS AND THEN FOR AMBIGUOUS REGION. NO NEED C TO EXPLICITLY CHECK THE FOUR VALID REGIONS. C IFLAG=0 IF(ALAMB3.GT.0.0 .AND. ALAMB4.GT.0.0)THEN ISIGN=+1 ELSEIF(ALAMB3.LT.0.0 .AND. ALAMB4.LT.0.0)THEN ISIGN=-1 ELSE DLAM3=ALAMB3 DLAM4=ALAMB4 DP=0.5D0 DTERM1=DLAM3*DP**(DLAM3-1.0D0) + 1 DLAM4*(1.0D0-DP)**(DLAM4-1.0D0) ISIGN=+1 IF(DTERM1.LT.0.0D0)ISIGN=-1 ENDIF ALOWER=CPUMIN AUPPER=CPUMAX C IF(ALAMB3.LT.0.0 .AND. (0.0.LT.ALAMB4 .AND. ALAMB4.LT.1.0))THEN IFLAG=1 GOTO9000 ENDIF IF(ALAMB4.LT.0.0 .AND. (0.0.LT.ALAMB3 .AND. ALAMB3.LT.1.0))THEN IFLAG=1 GOTO9000 ENDIF C IF(ALAMB4.GT.1.0 .AND. (-1.0.LT.ALAMB3 .AND. ALAMB3.LT.0.0))THEN DLAM3=DBLE(ALAMB3) DLAM4=DBLE(ALAMB4) DTERM1=(1.0D0-DLAM3)**(1.0D0-DLAM3) DTERM2=(DLAM4-DLAM3)**(DLAM4-DLAM3) DTERM3=(DLAM4-1.0D0)**(DLAM4-1.0D0) DTERM4=(DTERM1/DTERM2)*DTERM3 DTERM5=-DLAM3/DLAM4 IF(DTERM4.GE.DTERM5)THEN IFLAG=1 GOTO9000 ENDIF ENDIF IF(ALAMB3.GT.1.0 .AND. (-1.0.LT.ALAMB4 .AND. ALAMB4.LT.0.0))THEN DLAM3=DBLE(ALAMB3) DLAM4=DBLE(ALAMB4) DTERM1=(1.0D0-DLAM4)**(1.0D0-DLAM4) DTERM2=(DLAM3-DLAM4)**(DLAM3-DLAM4) DTERM3=(DLAM3-1.0D0)**(DLAM3-1.0D0) DTERM4=(DTERM1/DTERM2)*DTERM3 DTERM5=-DLAM4/DLAM3 IF(DTERM4.GE.DTERM5)THEN IFLAG=1 GOTO9000 ENDIF ENDIF C C DETERMINE THE VALID SUPPORT REGION C ALOWER=-1.0 AUPPER=1.0 IF(ALAMB3.GT.0.0 .AND. ALAMB4.EQ.0.0)THEN ALOWER=0.0 AUPPER=1.0 ELSEIF(ALAMB3.EQ.0.0 .AND. ALAMB4.GT.0.0)THEN ALOWER=-1.0 AUPPER=0.0 ELSEIF(ALAMB3.LT.0.0 .AND. ALAMB4.LT.0.0)THEN ALOWER=CPUMIN AUPPER=CPUMAX ELSEIF(ALAMB3.LT.0.0 .AND. ALAMB4.EQ.0.0)THEN ALOWER=CPUMIN AUPPER=1.0 ELSEIF(ALAMB3.EQ.0.0 .AND. ALAMB4.LT.0.0)THEN ALOWER=-1.0 AUPPER=CPUMAX ENDIF C 9000 CONTINUE IF(IFLAG.EQ.0 .AND. IWRITE.EQ.'ON')THEN WRITE(ICOUT,9001) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9003)ALAMB3 CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9005)ALAMB4 CALL DPWRST('XXX','BUG ') ELSEIF(IFLAG.EQ.1 .AND. IWRITE.EQ.'ON')THEN WRITE(ICOUT,9011) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9003)ALAMB3 CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9005)ALAMB4 CALL DPWRST('XXX','BUG ') ENDIF 9001 FORMAT('***** GIVEN SHAPE PARAMETERS RESULT IN A VALID ', 1 'GENERALIZED LAMBDA DISTRIBUTION.') 9003 FORMAT(' FIRST SHAPE PARAMETER (LAMBDA3) = ',G15.7) 9005 FORMAT(' SECOND SHAPE PARAMETER (LAMBDA4) = ',G15.7) 9011 FORMAT('***** GIVEN SHAPE PARAMETERS DO NOT RESULT IN A VALID ', 1 'GENERALIZED LAMBDA DISTRIBUTION.') RETURN END SUBROUTINE GLDPDF(DX,DL3,DL4,DPDF,IGLDDF,IWRITE) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY C FUNCTION VALUE FOR THE GENERALIZED LAMBDA DISTRIBUTION C WITH SHAPE PARAMETER VALUES = DL3 (LAMBDA3) AND C DL4 (LAMBDA4). C C NOTE THAT THERE ARE TWO COMMON PARAMETERIZATIONS C OF THIS PPF. C C THE ORIGINAL RAMBERG AND SCHMEISER PARAMETERIZATION: C C G(P) = P**LAMBDA3 - (1-P)**LAMBDA4 C C THE FREIMER, MUDHOLKAR, KOLLIA, AND LIN (FMKL) C PARAMETERIZATION: C C G(P) = (P**LAMBDA3 - 1)/LAMBDA3 - C ((1-P)**LAMBDA4 -1)/LAMBDA4 C C THE IDEF VARIABLE IDENTIFIES THE APPROPRIATE C DEFINITION TO USE. THE FMKL DEFINITION IS C BECOMING THE PREFERRED PARAMETERIZATION) SINCE IT C DEFINES A VALID PROBABILITY DISTRIBUTION FOR ALL C VALUES OF LAMBDA3 AND LAMBDA4 (THE RAMBERG C PARAMETERIZATION HAS REGIONS OF LAMBDA3 AND LAMBDA4 C WHERE A VALID PROBABILITY DISTRIBUTION IS NOT C DEFINED). C C INPUT ARGUMENTS--DX = THE DOUBLE PRECISION VALUE AT C WHICH THE CUMULATIVE DISTRIBUTION C FUNCTION IS TO BE EVALUATED. C --DL3 = THE DOUBLE PRECISION VALUE OF LAMBDA3 C (THE FIRST SHAPE PARAMETER). C --DL4 = THE DOUBLE PRECISION VALUE OF LAMBDA4 C (THE SECOND SHAPE PARAMETER). C OUTPUT ARGUMENTS--DPDF = THE DOUBLE PRECISION PROBABILITY C DENSITY FUNCTION VALUE. C OUTPUT--THE DOUBLE PRECISION PROBABILITY DENSITY FUNCTION C VALUE PDF FOR THE GENERALIZED TUKEY LAMBDA DISTRIBUTION C WITH SHAPE PARAMETERS = DL3 AND DL4. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--CALL GLDCHK TO CHECK FOR VALID VALUES OF THE C SHAPE PARAMETERS. 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--KARIAN AND DUDEWICZ, 'FITTING STATISTICAL C DISTRIBUTIONS: THE GENERALIZED LAMBDA DISTRIBUTION C AND GENERALIZED BOOTSTRAP METHODS', CRC, 2000. C --STEVE SU, "A DISCRETIZED APPROACH TO FLEXIBLY FIT C GENRALIZED LAMBDA DISTRIBUTIONS TO DATA", C JOURNAL OF MODERN APPLIED STATISTICAL METHODS, C NOVEMBER, 2005,, VOL. 4, NO. 2, 408-424. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE: 301-975-2855 C ORIGINAL VERSION--MARCH 2006. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 DOUBLE PRECISION DSF DOUBLE PRECISION DCDF DOUBLE PRECISION DX DOUBLE PRECISION DL3 DOUBLE PRECISION DL4 DOUBLE PRECISION DPDF DOUBLE PRECISION DLOWER DOUBLE PRECISION DUPPER DOUBLE PRECISION DZERO DOUBLE PRECISION DONE C CHARACTER*4 IGLDDF CHARACTER*4 IWRITE C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT 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 DPDF=0.0D0 DZERO=0.0D0 DONE=1.0D0 C CCCCC IF(IGLDDF.EQ.'RAMB')THEN CCCCC CALL GLDCHK(REAL(DL3),REAL(DL4),ALOWER,AUPPER,IFLAG, CCCCC1 ISIGN,IWRITE) CCCCC IF(IFLAG.EQ.1)GOTO9000 CCCCC DLOWER=DBLE(ALOWER) CCCCC DUPPER=DBLE(AUPPER) CCCCC ELSE C C FOR THE FMKL PARAMETERIZATION: C C 1) IF LAMBDA3 <= 0, THE LOWER TAIL IS UNBOUNDED. C IF LAMDA3 > 0, THE LOWER TAIL IS BOUNDED AT -1/LAMBDA3 C C 2) IF LAMBDA4 <= 0, THE UPPER TAIL IS UNBOUNDED. C IF LAMDA4 > 0, THE UPPER TAIL IS BOUNDED AT 1/LAMBDA4 C IF(DL3.LE.0.0D0 .AND. DL4.LE.0.0D0)THEN DLOWER=DBLE(CPUMIN) DUPPER=DBLE(CPUMAX) ELSEIF(DL3.LE.0.0D0)THEN DLOWER=DBLE(CPUMIN) CALL GLDPPF(DONE,DL3,DL4,DUPPER,IGLDDF,IWRITE) ELSEIF(DL4.LE.0.0D0)THEN CALL GLDPPF(DZERO,DL3,DL4,DLOWER,IGLDDF,IWRITE) DUPPER=DBLE(CPUMAX) ELSE CALL GLDPPF(DZERO,DL3,DL4,DLOWER,IGLDDF,IWRITE) CALL GLDPPF(DONE,DL3,DL4,DUPPER,IGLDDF,IWRITE) ENDIF CCCCC ENDIF C IF(DX.LT.DLOWER .OR. DX.GT.DUPPER)THEN WRITE(ICOUT,2) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3)DLOWER,DUPPER CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)DX CALL DPWRST('XXX','BUG ') DPDF=0.0D0 GOTO9000 ENDIF 2 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO GLDPDF', 1 'IS OUTSIDE') 3 FORMAT(' THE ALLOWABLE INTERVAL (',G15.7,',',G15.7,')') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7) C C-----START POINT----------------------------------------------------- C C IWRITE='OFF' C CCCCC IF(IGLDDF.EQ.'RAMB')THEN CCCCC CALL GLDCDF(DX,DL3,DL4,DCDF,IGLDDF,IWRITE) C CCCCC DTERM1=0.0D0 CCCCC DTERM2=0.0D0 CCCCC DSF=0.0D0 CCCCC IF(DCDF.GT.0.0D0)THEN CCCCC DTERM1=DL3*DCDF**DL3-1.0D0 CCCCC ENDIF CCCCC IF((1.0D0-DCDF).GT.0.0D0)THEN CCCCC DTERM2=DL4*(1.0D0-DCDF)**(DL4-1.0D0) CCCCC ENDIF CCCCC DSF=DTERM1 + DTERM2 CCCCC IF(DSF.NE.0.0D0)THEN CCCCC DPDF=1.0D0/DSF CCCCC ENDIF CCCCC ELSE CALL GLDCDF(DX,DL3,DL4,DCDF,IGLDDF,IWRITE) DSF=DCDF**(DL3-1.0D0) + (1.0D0 - DCDF)**(DL4-1.0D0) IF(DSF.NE.0.0D0)THEN DPDF=1.0D0/DSF ELSE DPDF=0.0D0 ENDIF CCCCC ENDIF C 9000 CONTINUE RETURN END SUBROUTINE GLDPPF(DP,DL3,DL4,DPPF,IGLDDF,IWRITE) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT C FUNCTION VALUE FOR THE GENERALIZD LAMBDA DISTRIBUTION C WITH SHAPE PARAMETERS ALAMB3 AND ALAMB4. C THIS DISTRIBUTION IS DEFINED IN TERMS OF ITS C PERCENT POINT FUNCTION. C C NOTE THAT THERE ARE TWO COMMON PARAMETERIZATIONS C OF THIS PPF. C C THE ORIGINAL RAMBERG AND SCHMEISER PARAMETERIZATION: C C G(P) = P**LAMBDA3 - (1-P)**LAMBDA4 C C THE FREIMER, MUDHOLKAR, KOLLIA, AND LIN (FMKL) C PARAMETERIZATION: C C G(P) = (P**LAMBDA3 - 1)/LAMBDA3 - C ((1-P)**LAMBDA4 -1)/LAMBDA4 C C THE CASES WHERE LAMBDA3 AND LAMBDA4 EQUAL ZERO C HAVE TO BE HANDLED SEPARATELY. SPECIFICALLY, C IF LAMBDA3 = 0, THEN C C (P**LAMBDA3 - 1)/LAMBDA3 = LOG(P) C C IF LAMBDA4 = 0, THEN C C ((1-P)**LAMBDA4 - 1)/LAMBDA4 = LOG(1-P) C C THE IDEF VARIABLE IDENTIFIES THE APPROPRIATE C DEFINITION TO USE. THE FMKL DEFINITION IS C BECOMING THE PREFERRED PARAMETERIZATION) SINCE IT C DEFINES A VALID PROBABILITY DISTRIBUTION FOR ALL C VALUES OF LAMBDA3 AND LAMBDA4 (THE RAMBERG C PARAMETERIZATION HAS REGIONS OF LAMBDA3 AND LAMBDA4 C WHERE A VALID PROBABILITY DISTRIBUTION IS NOT C DEFINED). C C CURRENTLY, ONLY THE FMKL PARAMETERIZATION IS C SUPPORTED. C 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 DOUBLE PRECISION VALUE C (BETWEEN 0.0 AND 1.0) C AT WHICH THE PERCENT POINT C FUNCTION IS TO BE EVALUATED. C --DL3 = THE DOUBLE PRECISION VALUE OF LAMBDA3 C (THE FIRST SHAPE PARAMETER). C --DL4 = THE DOUBLE PRECISION VALUE OF LAMBDA3 C (THE SECOND SHAPE PARAMETER). C OUTPUT ARGUMENTS--DPPF = THE DOUBLE PRECISION PERCENT C POINT FUNCTION VALUE. C OUTPUT--THE DOUBLE PRECISION PERCENT POINT C FUNCTION VALUE PPF FOR THE TUKEY LAMBDA DISTRIBUTION C WITH TAIL LENGTH PARAMETERS = DL3 AND DL4. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--TO BE ADDED. C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISIONS. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--KARIAN AND DUDEWICZ, "FITTING STATISTICAL C DISTRIBUTIONS: THE GENERALIZED LAMBDA DISTRIBUTION C AND GENERALIZED BOOTSTRAP METHODS", CRC, 2000. C --STEVE SU, "A DISCRETIZED APPROACH TO FLEXIBLY FIT C GENRALIZED LAMBDA DISTRIBUTIONS TO DATA", C JOURNAL OF MODERN APPLIED STATISTICAL METHODS, C NOVEMBER, 2005,, VOL. 4, NO. 2, 408-424. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2001.8 C ORIGINAL VERSION--AUGUST 2001. C UPDATED --FEBRUARY 2006. SUPPORT FOR FMKL DEFINITION C AND MAKE ROUTINE DOUBLE C PRECISION C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DP DOUBLE PRECISION DPPF DOUBLE PRECISION DEPS DOUBLE PRECISION DL3 DOUBLE PRECISION DL4 DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 C CHARACTER*4 IGLDDF CHARACTER*4 IWRITE C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT 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 CCCCC IF(IGLDDF.EQ.'RAMB')THEN CCCCC IWRITE='ERRO' CCCCC CALL GLDCHK(ALAMB3,ALAMB4,ALOWER,AUPPER,IFLAG,ISIGN,IWRITE) CCCCC DPPF=0.0 CCCCC DEPS=1.0D-12 CCCCC IF(IFLAG.EQ.1)GOTO9000 CCCCC GOTO9000 CCCCC ELSE CCCCC ALOWER=0.0 CCCCC AUPPER=0.0 CCCCC ENDIF C C FOR THE FMKL PARAMETERIZATION: C C 1) IF LAMBDA3 <= 0, THE LOWER TAIL IS UNBOUNDED. C IF LAMDA3 > 0, THE LOWER TAIL IS BOUNDED AT -1/LAMBDA3 C C 2) IF LAMBDA4 <= 0, THE UPPER TAIL IS UNBOUNDED. C IF LAMDA4 > 0, THE UPPER TAIL IS BOUNDED AT 1/LAMBDA4 C IF(DL3.LE.0.0D0 .AND. DL4.LE.0.0D0)THEN IF(DP.LE.0.0D0 .OR. DP.GE.1.0D0)THEN WRITE(ICOUT,1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)DP CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF ELSEIF(DL3.LE.0.0D0)THEN IF(DP.LE.0.0D0 .OR. DP.GT.1.0D0)THEN WRITE(ICOUT,1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)DP CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF ELSEIF(DL4.LE.0.0D0)THEN IF(DP.LT.0.0D0 .OR. DP.GE.1.0D0)THEN WRITE(ICOUT,1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)DP CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF ELSE IF(DP.LT.0.0D0 .OR. DP.GT.1.0D0)THEN WRITE(ICOUT,1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)DP CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF ENDIF 1 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO GLDPPF ', 1'IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7) C C CALCULATE THE PPF FUNCTION C CCCCC IF(IGLDDF.EQ.'RAMB')THEN CCCCC IF(DP.LE.DEPS)THEN CCCCC DPPF=DBLE(ALOWER) CCCCC ELSEIF(DP.GE.1.0D0-DEPS)THEN CCCCC DPPF=DBLE(AUPPER) CCCCC ELSEIF(DL3.EQ.0.0D0 .AND. DL4.EQ.0.0D0)THEN CCCCC DPPF=DLOG(DP) - DLOG(1.0D0 - DP) CCCCC ELSEIF(DL3.EQ.0.0D0)THEN CCCCC DPPF=DLOG(DP) - (1.0D0-DP)**DL4 CCCCC ELSEIF(DL4.EQ.0.0D0)THEN CCCCC DPPF=DP**DL3 - DLOG(1.0D0 - DP) CCCCC ELSE CCCCC DPPF= DP**DL3 - (1.0D0-DP)**DL4 CCCCC ENDIF CCCCC ELSE IF(DL3.EQ.0.0D0 .AND. DL4.EQ.0.0D0)THEN DPPF=DLOG(DP) - DLOG(1.0D0 - DP) ELSEIF(DL3.EQ.0.0D0)THEN DPPF=DLOG(DP) - ((1.0D0-DP)**DL4 - 1.0D0)/DL4 ELSEIF(DL4.EQ.0.0D0)THEN DPPF=(DP**DL3-1.0D0)/DL3 - DLOG(1.0D0 - DP) ELSE DTERM1=(DP**DL3-1.0D0)/DL3 DTERM2=((1.0D0-DP)**DL4 - 1.0D0)/DL4 DPPF=DTERM1 - DTERM2 ENDIF CCCCC ENDIF C 9000 CONTINUE RETURN END SUBROUTINE GLDRAN(N,ALAMB3,ALAMB4,ISEED,IGLDDF,X) C C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N C FOR THE GENERALIZD LAMBDA DISTRIBUTION C WITH SHAPE PARAMETERS ALAMB3 AND ALAMB4. C THE PERCENT POINT FUNCTION FOR THIS DISTRIBUTION IS C G(P) = P**LAMBDA3 - (1-Y)**LAMBDA4 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--N = THE DESIRED INTEGER NUMBER C OF RANDOM NUMBERS TO BE C GENERATED. C --ALAMB3 = THE SINGLE PRECISION VALUE OF LAMBDA C (THE FIRST SHAPE PARAMETER). C --ALAMB4 = THE SINGLE PRECISION VALUE OF LAMBDA C (THE FIRST SHAPE PARAMETER). C OUTPUT ARGUMENTS--X = A SINGLE PRECISION VECTOR C (OF DIMENSION AT LEAST N) C INTO WHICH THE GENERATED C RANDOM SAMPLE WILL BE PLACED. C OUTPUT--A RANDOM SAMPLE OF SIZE N C FROM THE GENERALIZED LAMBDA DISTRIBUTION C WITH SHAPE PARAMETER VALUES = ALAMB3 AND ALAMB4. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C OTHER DATAPAC SUBROUTINES NEEDED--UNIRAN. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C 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, PAGES 21-44, 53-58. C --FILLIBEN, 'THE PERCENT POINT FUNCTION', C (UNPUBLISHED MANUSCRIPT), 1970, PAGES 28-31. C --KARIAN AND DUDEWICZ, 'FITTING STATISTICAL C DISTRIBUTIONS: THE GENERALIZED LAMBDA DISTRIBUTION C AND GENERALIZED BOOTSTRAP METHODS', CRC, 2000. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--2001.8 C ORIGINAL VERSION--AUGUST 2001. C UPDATED --FEBRUARY 2006. SUPPORT FOR FMKL C PARAMETERIZATION C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DIMENSION X(*) C DOUBLE PRECISION DPPF C CHARACTER*4 IWRITE CHARACTER*4 IGLDDF 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(IGLDDF.EQ.'RAMB')THEN IWRITE='ERRO' CALL GLDCHK(ALAMB3,ALAMB4,ALOWER,AUPPER,IFLAG,ISIGN,IWRITE) ZSCALE=1.0 IF(ISIGN.LT.0)ZSCALE=-1.0 IF(IFLAG.EQ.1)THEN DO10I=1,N X(I)=0.0 10 CONTINUE GOTO9000 ENDIF ENDIF C IF(N.LT.1)THEN WRITE(ICOUT,5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,6) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)N CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF 5 FORMAT('***** ERROR--A NON-POSITIVE NUMBER OF RANDOM NUMBERS ', 1 'WAS REQUESTED FOR ') 6 FORMAT(' THE GENERALIZED TUKEY-LAMBDA DISTRIBUTION.') 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 GENERALIZED TUKEY-LAMBDA DISTRIBUTION RANDOM NUMBERS C USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD. C IWRITE='OFF' DO100I=1,N Q=X(I) CALL GLDPPF(DBLE(Q),DBLE(ALAMB3),DBLE(ALAMB4),DPPF, 1 IGLDDF,IWRITE) X(I)=REAL(DPPF) 100 CONTINUE C 9000 CONTINUE RETURN END SUBROUTINE GLGCDF(X,P,J,A,CDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION C FUNCTION VALUE AT THE SINGLE PRECISION VALUE X C FOR THE GENERALIZED LOST GAMES DISTRIBUTION C WITH SINGLE PRECISION SHAPE PARAMETERS P, A, AND C J. THIS DISTRIBUTION IS DEFINED FOR ALL C NON-NEGATIVE INTEGER X >= J. C C THE CUMULATIVE DISTRIBUTION FUNCTION IS COMPUTED FROM THE C RECURRENCE RELATION: C C p(X;P,J,A) =(2*X+A-2*J-1)*(2*X+A-2*J-2)*P*(1-P)*p(X;P,J,A)/ C {(X-J)*(X+A-J)} C C P(0;P,J,A)=P**A C C THIS DISTRIBUTION IS USED TO MODEL THE "GAMBLER'S C RUIN" PROBLEM. C C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE C AT WHICH THE CUMULATIVE DISTRIBUTION C FUNCTION IS TO BE EVALUATED. C X SHOULD BE AN INTEGR >= J. C --P = THE SINGLE PRECISION VALUE C OF THE FIRST SHAPE PARAMETER (PROBABILITY OF C LOSING AN INDIVIDUAL GAME). C --J = THE INTEGER VALUE OF THE SECOND SHAPE C PARAMETER. C --A = THE SINGLE PRECISION VALUE OF THE THIRD SHAPE C PARAMETER. C OUTPUT ARGUMENTS--CDF = THE SINGLE PRECISION CUMULATIVE C DISTRIBUTION FUNCTION VALUE C OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION C FUNCTION VALUE CDF FOR THE GENERALIZED LOST GAMES DISTRIBUTION C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--X SHOULD BE AN INTEGER >= J C --0.5 < P < 1, AND J >= 0 C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--DEXP, DLOG C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--JOHNSON, KEMP, AND KOTZ (2005). "UNIVARIATE C DISCRETE DISTRIBUTIONS", THIRD EDITION, C WILEY, PP. 503-505. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2006/11 C ORIGINAL VERSION--NOVEMBER 2006. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DX DOUBLE PRECISION DP DOUBLE PRECISION DJ DOUBLE PRECISION DA DOUBLE PRECISION DPDF DOUBLE PRECISION DPDFSV DOUBLE PRECISION DCDF DOUBLE PRECISION DC1 DOUBLE PRECISION DC2 DOUBLE PRECISION DC3 DOUBLE PRECISION DC4 C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/JD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C CDF=0.0 C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(P.LE.0.5 .OR. P.GE.1.0)THEN WRITE(ICOUT,11) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)P CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9999 ENDIF 11 FORMAT('***** ERROR--THE SECOND ARGUMENT TO GLGCDF ', 1' IS OUTSIDE THE ALLOWABLE (0.5,1) INTERVAL') C IF(J.LT.0)THEN WRITE(ICOUT,12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)J CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9999 ENDIF 12 FORMAT('***** ERROR--THE THIRD ARGUMENT TO GLGCDF IS ', 1' NEGATIVE') C IF(A.LE.0.0)THEN WRITE(ICOUT,13) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)A CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9999 ENDIF 13 FORMAT('***** ERROR--THE FOURTH ARGUMENT TO GLGCDF IS ', 1' NEGATIVE') C INTX=INT(X+0.5) IF(INTX.LT.J)THEN WRITE(ICOUT,5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)INTX CALL DPWRST('XXX','BUG ') WRITE(ICOUT,48)INTX CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9999 ENDIF 5 FORMAT('***** ERROR--THE FIRST ARGUMENT TO GLGCDF IS LESS ', 1'THAN THE THIRD ARUGMENT') C 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7) 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8) 48 FORMAT('***** THE VALUE OF THE THIRD ARGUMENT IS ',I8) C DP=DBLE(P) DJ=DBLE(J) DA=DBLE(A) DCDF=0.0D0 C C USE THE RECURRENCE RELATION DESCRIBED ABOVE. C DPDF=DA*DLOG(DP) DPDFSV=DPDF DCDF=DEXP(DPDF) C IF(INTX.GT.J)THEN DO200I=J+1,INTX DX=DBLE(I) DC1=DLOG(2.0D0*DX+DA-2.0D0*DJ-1.0D0) DC2=DLOG(2.0D0*DX+DA-2.0D0*DJ-2.0D0) DC3=DLOG(DP) + DLOG(1.0D0-DP) DC4=DLOG(DX-DJ) + DLOG(DX+DA-DJ) DPDF=DC1 + DC2 + DC3 + DPDFSV - DC4 DCDF=DCDF + DEXP(DPDF) DPDFSV=DPDF 200 CONTINUE ENDIF C CDF=REAL(DCDF) C 9999 CONTINUE RETURN END SUBROUTINE GLGFUN(N,X,FVEC,IFLAG,Y,K) C C PURPOSE--THIS ROUTINE COMPUTES THE FUNCTIONS FOR THE C GENERALIZED LOST GAMES MAXIMUM LIKELIHOOD EQUATIONS. C C N*SUM[x>=0][f(x)*{(a+x)/p - x/(1-p)} = 0 C C N*SUM[x >= 0][f(x)*{LOG(p) + 1/a + PSI(a+2*x) - C PS(a+x-1)}] = 0 C C WITH P AND A DENOTING THE SHAPE PARAMETERS. C C THIS ROUTINE ASSUMES THE DATA IS IN THE FORM C C X(I) FREQ(I) C C CALLED BY DNSQE ROUTINE FOR SOLVING SIMULTANEOUS C NONLINEAR EQUATIONS. NOTE THAT THE CALLING SEQUENCE C DID NOT ACCOMODATE A DATA ARRAY (AND ASSCIATED NUMBER OF C OBSERVATIONS), SO THESE WERE ADDED TO THE CALL LIST. C SINCE DNSQE ONLY PASSES ONE ARRAY, WE SPLIT INTO C TWO PARTS: 1 - MAXNXT/2 ARE THE FREQUENCIES WHILE C (MAXNXT/2 + 1) - MAXNXT ARE THE CLASS VALUES (I.E., C THE X). C EXAMPLE--GENERALIZED LOST GAMES MAXIMUM LIKELIHOOD Y C REFERENCES--JOHNSON, KOTZ, AND KEMP (2006). "UNIVARIATE C DISCRETE DISTRIBUTIONS", THIRD EDITION, C WILEY, PP. 503-505. C --KEMP AND KEMP (1992), "A GROUP-DYNAMIC MODEL AND C THE LOST-GAMES DISTRIBUTION", COMMUNICATIONS IN C STATISTICS--THEORY AND METHODS, 21(3), C PP. 791-798. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBUG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2006/12 C ORIGINAL VERSION--DECEMBER 2006. C C--------------------------------------------------------------------- C DOUBLE PRECISION X(*) DOUBLE PRECISION FVEC(*) REAL Y(*) C EXTERNAL DPSI C DOUBLE PRECISION DN DOUBLE PRECISION DX DOUBLE PRECISION DP DOUBLE PRECISION DA DOUBLE PRECISION DSUM1 DOUBLE PRECISION DSUM2 DOUBLE PRECISION DTERM1 DOUBLE PRECISION DPSI C DOUBLE PRECISION XBAR,S2 COMMON/GLGCOM/XBAR,S2,MAXNXT,IINDX,NTOT 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 COMPUTE SOME SUMS C DP=X(1) DA=X(2) DN=DBLE(NTOT) C DSUM1=0.0D0 DSUM2=0.0D0 C DO200I=1,K C DX=DBLE(Y(IINDX+I)) DFREQ=Y(I) IF(DFREQ.LE.0.0D0)GOTO200 C DTERM1=DFREQ*((DA+DX)/DP - DX/(1.0D0-DP)) DSUM1=DSUM1 + DTERM1 DTERM1=DLOG(DP) + 1.0D0/DA + DPSI(DA+2.0D0*DX) - 1 DPSI(DA+DX-1.0D0) DSUM2=DSUM2 + DFREQ*DTERM1 C 200 CONTINUE C FVEC(1)=DN*DSUM1 FVEC(2)=DN*DSUM2 C RETURN END SUBROUTINE GLGPDF(X,P,J,A,PDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY C FUNCTION VALUE AT THE SINGLE PRECISION VALUE X C FOR THE GENERALIZED LOST GAMES DISTRIBUTION C WITH SINGLE PRECISION SHAPE PARAMETERS P, A, AND C J. THIS DISTRIBUTION IS DEFINED FOR ALL C NON-NEGATIVE INTEGER X >= J AND HAS THE PROBABILITY C MASS FUNCTION: C C p(X;P,J,A) = (2*X+A-2*J-1)!A*P**(A+X-J)* C (1-P)**(X-J)/{(X+A-J)!*(X-J)!} C X = J, J+1, ... C A > 0; 0 < P < 1 C C THE PROBABILITIES CAN BE COMPUTED FROM THE FOLLOWING C RECURRENCE RELATION: C C p(X;P,J,A) =(2*X+A-2*J-1)*(2*X+A-2*J-2)*P*(1-P)*p(X;P,J,A)/ C {(X-J)*(X+A-J)} C C P(0;P,J,A)=P**A C C THIS DISTRIBUTION IS USED TO MODEL THE "GAMBLER'S C RUIN" PROBLEM. C C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE C AT WHICH THE PROBABILITY DENSITY C FUNCTION IS TO BE EVALUATED. C X SHOULD BE AN INTEGR >= J. C --P = THE SINGLE PRECISION VALUE C OF THE FIRST SHAPE PARAMETER (PROBABILITY OF C LOSING AN INDIVIDUAL GAME). C --J = THE INTEGER VALUE OF THE SECOND SHAPE C PARAMETER. C --A = THE SINGLE PRECISION VALUE OF THE THIRD SHAPE C PARAMETER. C OUTPUT ARGUMENTS--CDF = THE SINGLE PRECISION PROBABILITY C DENSITY FUNCTION VALUE C OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY C FUNCTION VALUE PDF FOR THE GENERALIZED LOST GAMES C DISTRIBUTION C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--X SHOULD BE AN INTEGER >= J C --0.5 < P < 1, AND J >= 0, A > 0 C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--DEXP, DLOG C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--JOHNSON, KEMP, AND KOTZ (2005). "UNIVARIATE C DISCRETE DISTRIBUTIONS", THIRD EDITION, C WILEY, PP. 503-505. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2006/11 C ORIGINAL VERSION--NOVEMBER 2006. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DX DOUBLE PRECISION DP DOUBLE PRECISION DJ DOUBLE PRECISION DA DOUBLE PRECISION DPDF DOUBLE PRECISION DPDFSV DOUBLE PRECISION DCDF DOUBLE PRECISION DC1 DOUBLE PRECISION DC2 DOUBLE PRECISION DC3 DOUBLE PRECISION DC4 C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/JD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C SAVE DPDFSV SAVE PSV SAVE ASV SAVE XSV SAVE JSV C DATA DPDFSV /-99.0/ DATA PSV /-99.0/ DATA ASV /-99.0/ DATA JSV /-99/ DATA XSV /-99.0/ C C-----START POINT----------------------------------------------------- C PDF=0.0 C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(P.LE.0.5 .OR. P.GE.1.0)THEN WRITE(ICOUT,11) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)P CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ENDIF 11 FORMAT('***** ERROR--THE SECOND ARGUMENT TO GLGPDF ', 1' IS OUTSIDE THE ALLOWABLE (0.5,1) INTERVAL') C IF(J.LT.0)THEN WRITE(ICOUT,12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)J CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ENDIF 12 FORMAT('***** ERROR--THE THIRD ARGUMENT TO GLGPDF IS ', 1' NEGATIVE') C IF(A.LE.0.0)THEN WRITE(ICOUT,13) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)A CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ENDIF 13 FORMAT('***** ERROR--THE FOURTH ARGUMENT TO GLGPDF IS ', 1' NEGATIVE') C INTX=INT(X+0.5) IF(INTX.LT.J)THEN WRITE(ICOUT,5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)INTX CALL DPWRST('XXX','BUG ') WRITE(ICOUT,48)INTX CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ENDIF 5 FORMAT('***** ERROR--THE FIRST ARGUMENT TO GLGPDF IS LESS ', 1'THAN THE THIRD ARUGMENT') C 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7) 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8) 48 FORMAT('***** THE VALUE OF THE THIRD ARGUMENT IS ',I8) C C NOTE: FOR EFFICIENCY, CHECK IF THE CURRENT VALUES OF THE C PARAMETERS ARE THE SAME AS THE SAVED VALUES AND IF C THE CURRENT X IS GREATER THAN OR EQUAL THE SAVED X. C DP=DBLE(P) DJ=DBLE(J) DA=DBLE(A) C IF(P.EQ.PSV .AND. A.EQ.ASV .AND. J.EQ.JSV .AND. 1 X.GE.XSV)THEN C C USE PARAMETERS FROM PREVIOUS CALL C IF(X.EQ.XSV)THEN DPDF=DEXP(DPDFSV) PDF=REAL(DPDF) GOTO10000 ELSE ISTRT=INT(XSV+0.5) DO100I=ISTRT+1,INTX DX=DBLE(I) DC1=DLOG(2.0D0*DX+DA-2.0D0*DJ-1.0D0) DC2=DLOG(2.0D0*DX+DA-2.0D0*DJ-2.0D0) DC3=DLOG(DP) + DLOG(1.0D0-DP) DC4=DLOG(DX-DJ) + DLOG(DX+DA-DJ) DPDF=DC1 + DC2 + DC3 + DPDFSV - DC4 DPDFSV=DPDF 100 CONTINUE DPDF=DEXP(DPDF) PDF=REAL(DPDF) ENDIF ELSE C C NEW PARAMETERS C DPDF=DA*DLOG(DP) DPDFSV=DPDF C IF(INTX.GT.J)THEN DO200I=J+1,INTX DX=DBLE(I) DC1=DLOG(2.0D0*DX+DA-2.0D0*DJ-1.0D0) DC2=DLOG(2.0D0*DX+DA-2.0D0*DJ-2.0D0) DC3=DLOG(DP) + DLOG(1.0D0-DP) DC4=DLOG(DX-DJ) + DLOG(DX+DA-DJ) DPDF=DC1 + DC2 + DC3 + DPDFSV - DC4 DPDFSV=DPDF 200 CONTINUE ENDIF DPDF=DEXP(DPDF) PDF=REAL(DPDF) ENDIF GOTO9000 C 9000 CONTINUE PSV=P ASV=A JSV=J XSV=X GOTO10000 C 9999 CONTINUE PSV=-99.0 ASV=-99.0 JSV=-99 XSV=-99.0 C 10000 CONTINUE RETURN END SUBROUTINE GLGPPF(P,PPAR,J,A,PPF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT C FUNCTION VALUE AT THE SINGLE PRECISION VALUE P C FOR THE GENERALIZED LOST GAMES DISTRIBUTION C WITH SINGLE PRECISION SHAPE PARAMETERS P, A, AND C J. THIS DISTRIBUTION IS DEFINED FOR ALL C NON-NEGATIVE INTEGER X >= J. C C THE CUMULATIVE DISTRIBUTION FUNCTION IS COMPUTED FROM C THE RECURRENCE RELATION: C C p(X;P,J,A) =(2*X+A-2*J-1)*(2*X+A-2*J-2)*P*(1-P)*p(X;P,J,A)/ C {(X-J)*(X+A-J)} C C P(0;P,J,A)=P**A C C THE PERCENT POINT FUNCTION IS COMPUTED BY GENERATING C THE CDF FUNCTION UNTIL THE APPROPRIATE PROBABILITY C IS REACHED. C C THIS DISTRIBUTION IS USED TO MODEL THE "GAMBLER'S C RUIN" PROBLEM. IT ADDS THE ADDITIONAL PARAMETER, A, C TO THE LOST GAMES DISTRIBUTION. C C INPUT ARGUMENTS--P = THE SINGLE PRECISION VALUE C AT WHICH THE PERCENT POINT C FUNCTION IS TO BE EVALUATED. C 0 <= P < 1. C --PPAR = THE SINGLE PRECISION VALUE C OF THE FIRST SHAPE PARAMETER (PROBABILITY OF C LOSING AN INDIVIDUAL GAME). C --J = THE INTEGER VALUE OF THE SECOND SHAPE C PARAMETER. C --A = THE SINGLE PRECISION VALUE OF THE THIRD SHAPE C PARAMETER. C OUTPUT ARGUMENTS--PPF = THE SINGLE PRECISION PERCENT POINT C FUNCTION VALUE C OUTPUT--THE SINGLE PRECISION PERCENT POINT FUNCTION VALUE C PPF FOR THE GENERALIZED LOST GAMES DISTRIBUTION C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--0 <= P < 1. C --0.5 < P < 1, AND J >= 0 C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--DEXP, DLOG C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--JOHNSON, KEMP, AND KOTZ (2005). "UNIVARIATE C DISCRETE DISTRIBUTIONS", THIRD EDITION, C WILEY, PP. 503-505. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2006/11 C ORIGINAL VERSION--NOVEMBER 2006. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DPPF DOUBLE PRECISION DX DOUBLE PRECISION DP DOUBLE PRECISION DPPAR DOUBLE PRECISION DJ DOUBLE PRECISION DA DOUBLE PRECISION DPDF DOUBLE PRECISION DPDFSV DOUBLE PRECISION DCDF DOUBLE PRECISION DC1 DOUBLE PRECISION DC2 DOUBLE PRECISION DC3 DOUBLE PRECISION DC4 C INCLUDE 'DPCOMC.INC' C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/JD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C PPF=0.0 C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(P.LT.0.0 .OR. P.GE.1.0)THEN WRITE(ICOUT,15) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)P CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9999 ENDIF 15 FORMAT('***** ERROR--THE FIRST ARGUMENT TO GLGPPF ', 1' IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL') C IF(PPAR.LE.0.5 .OR. PPAR.GE.1.0)THEN WRITE(ICOUT,11) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)PPAR CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9999 ENDIF 11 FORMAT('***** ERROR--THE SECOND ARGUMENT TO GLGPPF ', 1' IS OUTSIDE THE ALLOWABLE (0.5,1) INTERVAL') C IF(J.LT.0)THEN WRITE(ICOUT,12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)J CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9999 ENDIF 12 FORMAT('***** ERROR--THE THIRD ARGUMENT TO GLGPPF IS ', 1' NEGATIVE') C IF(A.LE.0.0)THEN WRITE(ICOUT,13) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)A CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9999 ENDIF 13 FORMAT('***** ERROR--THE FOURTH ARGUMENT TO GLGPPF IS ', 1' NEGATIVE') C 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7) 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8) 48 FORMAT('***** THE VALUE OF THE THIRD ARGUMENT IS ',I8) C DP=DBLE(P) DPPAR=DBLE(PPAR) DJ=DBLE(J) DA=DBLE(A) DCDF=0.0D0 C C USE THE RECURRENCE RELATION DESCRIBED ABOVE. C I=J DPDF=DA*DLOG(DPPAR) DPDFSV=DPDF DCDF=DEXP(DPDF) IF(DCDF.GE.DP)THEN PPF=REAL(J) GOTO9999 ENDIF C 100 CONTINUE I=I+1 IF(DBLE(I).GE.DBLE(I1MACH(9)))THEN WRITE(ICOUT,55) 55 FORMAT('***** ERROR--THE COMPUTED PERCENT POINT VALUE ', 1 'EXCEEDS THE LARGEST MACHINE INTEGER.') CALL DPWRST('XXX','BUG ') PPF=REAL(I) GOTO9999 ENDIF DX=DBLE(I) DC1=DLOG(2.0D0*DX+DA-2.0D0*DJ-1.0D0) DC2=DLOG(2.0D0*DX+DA-2.0D0*DJ-2.0D0) DC3=DLOG(DPPAR) + DLOG(1.0D0-DPPAR) DC4=DLOG(DX-DJ) + DLOG(DX+DA-DJ) DPDF=DC1 + DC2 + DC3 + DPDFSV - DC4 DCDF=DCDF + DEXP(DPDF) DPDFSV=DPDF IF(DCDF.GE.DP)THEN PPF=REAL(I) GOTO9999 ENDIF GOTO100 C 9999 CONTINUE RETURN END SUBROUTINE GLGRAN(N,P,J,A,ISEED,X) C C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF C SIZE N FROM THE GENERALIZED LOST GAMES DISTRIBUTION C WITH SHAPE PARAMETERS P AND IR. C IR. THIS DISTRIBUTION IS DEFINED FOR ALL C NON-NEGATIVE INTEGER X >= J. C THIS DISTRIBUTION HAS THE PROBABILITY FUNCTION C p(X;P,J,A) = ... C X = J, J+ 1, ... C A > 0, 0.5 < P < 1 C C INPUT ARGUMENTS--N = THE DESIRED INTEGER NUMBER C OF RANDOM NUMBERS TO BE C GENERATED. C --P = THE SINGLE PRECISION VALUE C OF THE FIRST SHAPE PARAMETER. C --J = THE INTEGER VALUE C OF THE SECOND SHAPE PARAMETER. C --A = THE SINGLE PRECISION VALUE C OF THE THIRD SHAPE PARAMETER. C OUTPUT ARGUMENTS--X = A SINGLE PRECISION VECTOR C (OF DIMENSION AT LEAST N) C INTO WHICH THE GENERATED C RANDOM SAMPLE WILL BE PLACED. C OUTPUT--A RANDOM SAMPLE OF SIZE N FROM THE GENERALIZED C LOST GAMES DISTRIBUTION WITH SHAPE PARAMETERS C P, J, AND A. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C --0.5 < P < 1, J A NON-NEGATIVE INTEGER, A > 0 C OTHER DATAPAC SUBROUTINES NEEDED--UNIRAN, LOSPPF C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--JOHNSON, KEMP, AND KOTZ (2005). "UNIVARIATE C DISCRETE DISTRIBUTIONS", THIRD EDITION, C WILEY, PP. 503-505. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2006/11 C ORIGINAL VERSION--NOVEMBER 2006. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C INTEGER N INTEGER J DIMENSION X(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----DATA STATEMENTS------------------------------------------------- C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(N.LT.1)THEN WRITE(ICOUT, 5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)N CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF 5 FORMAT('***** ERROR--THE REQUESTED NUMBER OF ', 1'GENERALIZED LOST GAMES RANDOM NUMBERS IS NON-POSITIVE') C IF(P.LE.0.5 .OR. P.GE.1.0)THEN WRITE(ICOUT,11) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)P CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF 11 FORMAT('***** ERROR--THE P PARAMETER FOR THE GENERALIZED ', 1 'LOST GAMES') 12 FORMAT(' RANDOM NUMBERS IS OUTSIDE THE ALLOWABLE (0.5,1) ', 1 'INTERVAL') C IF(J.LT.0)THEN WRITE(ICOUT,21) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)J CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF 21 FORMAT('***** ERROR--THE J PARAMETER FOR THE GENERALIZED ', 1 'LOST GAMES RANDOM NUMBERS IS NON-POSITIVE') C IF(A.LE.0.0)THEN WRITE(ICOUT,31) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,32) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)A CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF 31 FORMAT('***** ERROR--THE A PARAMETER FOR THE GENERALIZED ', 1 'LOST GAMES') 32 FORMAT(' RANDOM NUMBERS IS NON-POSITIVE') C 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7) 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8) C CALL UNIRAN(N,ISEED,X) DO100I=1,N XTEMP=X(I) CALL GLGPPF(XTEMP,P,J,A,PPF) X(I)=PPF 100 CONTINUE C 9999 CONTINUE C RETURN END SUBROUTINE GLOCDF(X,ALPHA,CDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION C FUNCTION VALUE FOR THE TYPE 1 GENERALIZED LOGISTIC C DISTRIBUTION WITH SHAPE PARAMETER ALPHA. C THIS DISTRIBUTION IS DEFINED FOR ALL X C AND HAS THE CUMULATIVE DISTRIBUTION FUNCTION C F(X) = 1/(1+EXP(-X))**ALPHA C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE C AT WHICH THE PROBABILITY DENSITY C FUNCTION IS TO BE EVALUATED. C OUTPUT ARGUMENTS--CDF = THE SINGLE PRECISION PROBABILITY C DENSITY FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY C FUNCTION VALUE CDF FOR THE HALF-LOGISTIC C DISTRIBUTION C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--X SHOULD BE NON-NEGATIVE. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN. C REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN CONTINUOUS UNIVARIATE C DISTRIBUTIONS--2, 1994, PAGES 140-142 C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE: 301-975-2855 C ORIGINAL VERSION--DECEMBER 1995. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DX, DA, DCDF DOUBLE PRECISION DTERM1 C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C--------------------------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(ALPHA.LE.0.0)THEN WRITE(ICOUT,4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)ALPHA CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9999 ENDIF 4 FORMAT('***** NON-FATAL DIAGNOSTIC--THE SECOND INPUT ARGUMENT ', * 'TO THE GLOCDF SUBROUTINE') 5 FORMAT(' IS NON-POSITIVE. *****') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') C C-----START POINT----------------------------------------------------- C DX=DBLE(X) DA=DBLE(ALPHA) DTERM1=-DA*DLOG(1.D0+DEXP(-DX)) IF(DTERM1.LE.-500.D0)THEN CDF=0.0 ELSEIF(DTERM1.GE.500.D0)THEN CDF=1.0 ELSE DCDF=DEXP(DTERM1) CDF=SNGL(DCDF) ENDIF C 9999 CONTINUE RETURN END SUBROUTINE GLOPDF(X,ALPHA,PDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY C FUNCTION VALUE FOR THE TYPE 1 GENERALIZED LOGISTIC C DISTRIBUTION WITH SHAPE PARAMETER ALPHA. C THIS DISTRIBUTION IS DEFINED FOR ALL X C AND HAS THE PROBABILITY DENSITY FUNCTION C F(X) = ALPHA*EXP(-X)/(1+EXP(-X))**(ALPHA+1) C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE C AT WHICH THE PROBABILITY DENSITY C FUNCTION IS TO BE EVALUATED. C OUTPUT ARGUMENTS--PDF = THE SINGLE PRECISION PROBABILITY C DENSITY FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY C FUNCTION VALUE PDF FOR THE GENERALIZED LOGISTIC C DISTRIBUTION C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--X SHOULD BE NON-NEGATIVE. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN. C REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN CONTINUOUS UNIVARIATE C DISTRIBUTIONS--2, 1994, PAGES 140-142 C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE: 301-975-2855 C ORIGINAL VERSION--DECEMBER 1995. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DX, DA, DPDF DOUBLE PRECISION DTERM1, DTERM2, DTERM3 C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C--------------------------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(ALPHA.LE.0.0)THEN WRITE(ICOUT,4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)ALPHA CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ENDIF 4 FORMAT('***** NON-FATAL DIAGNOSTIC--THE SECOND INPUT ARGUMENT ', * 'TO THE GLOPDF SUBROUTINE') 5 FORMAT(' IS NON-POSITIVE. *****') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') C C-----START POINT----------------------------------------------------- C DX=DBLE(X) DA=DBLE(ALPHA) DTERM1=DLOG(DA) DTERM2=DX + (DA+1.0D0)*DLOG(1.0+DEXP(-DX)) DTERM3=DTERM1-DTERM2 IF(DTERM3.LE.-500.D0)THEN PDF=0.0 ELSE DPDF=DEXP(DTERM3) PDF=SNGL(DPDF) ENDIF C 9999 CONTINUE RETURN END SUBROUTINE GLOPPF(P,ALPHA,PPF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT C FUNCTION VALUE FOR THE TYPE 1 GENERALIZED LOGISTIC C DISTRIBUTION WITH SHAPE PARAMETER ALPHA. C THIS DISTRIBUTION IS DEFINED FOR ALL X C AND HAS THE PROBABILITY DENSITY FUNCTION C F(X) = ALPHA/(EXP(X)*(1+EXP(-X))**(ALPHA+1)) C 0<=X<=1/K C INPUT ARGUMENTS--P = THE SINGLE PRECISION VALUE C (BETWEEN 0.0 (INCLUSIVELY) C AND 1.0 (EXCLUSIVELY)) C AT WHICH THE PERCENT POINT C FUNCTION IS TO BE EVALUATED. C OUTPUT ARGUMENTS--PPF = THE SINGLE PRECISION PERCENT C POINT FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION PERCENT POINT FUNCTION . C VALUE PPF FOR THE HALF-LOGISTIC DISTRIBUTION C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--P SHOULD BE BETWEEN 0.0 AND 1.0 (EXCLUSIVELY) C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN CONTINUOUS UNIVARIATE C DISTRIBUTIONS--2, 1994, PAGES 140-142 C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--95/12 C ORIGINAL VERSION--DECEMBER 1995. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DP, DA, DPPF DOUBLE PRECISION DTERM1 C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(P.LE.0.0.OR.P.GE.1.0)THEN WRITE(ICOUT,1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)P CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9999 ENDIF 1 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ', 1'GLOPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') C DP=DBLE(P) DA=DBLE(ALPHA) DTERM1=DP**(-1.0D0/DA) - 1.0D0 DPPF=-DLOG(DTERM1) PPF=SNGL(DPPF) C 9999 CONTINUE RETURN END SUBROUTINE GLORAN(N,ALPHA,ISEED,X) C C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N C FROM THE GENERALIZED LOGISTIC DISTRIBUTION C INPUT ARGUMENTS--N = THE DESIRED INTEGER NUMBER C OF RANDOM NUMBERS TO BE C GENERATED. C OUTPUT ARGUMENTS--X = A SINGLE PRECISION VECTOR C (OF DIMENSION AT LEAST N) C INTO WHICH THE GENERATED C RANDOM SAMPLE WILL BE PLACED. C OUTPUT--A RANDOM SAMPLE OF SIZE N C FROM THE GENERALIZED LOGISTIC DISTRIBUTION C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C OTHER DATAPAC SUBROUTINES NEEDED--UNIRAN. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2004/3 C ORIGINAL VERSION--MARCH 2004. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DIMENSION X(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----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 ') RETURN ENDIF 5 FORMAT('***** ERROR--THE REQUESTED NUMBER OF GENERALIZED ', 1 'LOGISTIC RANDOM NUMBERS 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 GENERALIZED LOGISTIC RANDOM NUMBERS C USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD C DO100I=1,N CALL GLOPPF(X(I),ALPHA,XTEMP) X(I)=XTEMP 100 CONTINUE C RETURN END SUBROUTINE GL2CDF(DX,DALPHA,DCDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION C FUNCTION VALUE FOR THE TYPE 2 GENERALIZED LOGISTIC C DISTRIBUTION WITH SHAPE PARAMETER ALPHA. C THIS DISTRIBUTION IS DEFINED FOR ALL X C AND HAS THE CUMULATIVE DISTRIBUTION FUNCTION C F(X) = 1 - EXP(-ALPHA*X)/(1+EXP(-X))**ALPHA C INPUT ARGUMENTS--DX = THE DOUBLE PRECISION VALUE C AT WHICH THE PROBABILITY DENSITY C FUNCTION IS TO BE EVALUATED. C --DALPHA = THE DOUBLE PRECISION SHAPE C PARAMETER. C OUTPUT ARGUMENTS--DCDF = THE DOUBLE PRECISION CUMULATIVE C DISTRIBUTION FUNCTION VALUE. C OUTPUT--THE DOUBLE PRECISION CUMULATIVE DISTRIBUTION FUNCTION C VALUE FOR THE TYPE 2 GENERALIZED LOGISTIC DISTRIBUTION C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--ALPHA SHOULD BE POSITIVE. C FORTRAN LIBRARY SUBROUTINES NEEDED--DLOG, DEXP. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN. C REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN CONTINUOUS UNIVARIATE C DISTRIBUTIONS--2, 1994, PAGES 140-142 C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE: 301-975-2855 C ORIGINAL VERSION--MARCH 2006. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DX DOUBLE PRECISION DALPHA DOUBLE PRECISION DCDF DOUBLE PRECISION DTERM1 C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C--------------------------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(DALPHA.LE.0.0D0)THEN WRITE(ICOUT,4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)DALPHA CALL DPWRST('XXX','BUG ') DCDF=0.0D0 GOTO9999 ENDIF 4 FORMAT('***** ERROR--THE SHAPE PARAMETER FOR THE GL2CDF ', 1 'SUBROUTINE IS NON-POSITIVE.') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7) C C-----START POINT----------------------------------------------------- C DTERM1=-DALPHA*DX - DALPHA*DLOG(1.0D0 + DEXP(-DX)) DCDF=1.0D0 - DEXP(DTERM1) C 9999 CONTINUE RETURN END DOUBLE PRECISION FUNCTION GL2FU2(DX) C C PURPOSE--GL2PPF CALLS DFZERO TO FIND A ROOT FOR THE PERCENT C POINT FUNCTION. GL2FU2 IS THE FUNCTION FOR WHICH C THE ZERO IS FOUND. IT IS: C P - GL2CDF(X,ALPHA) C WHERE P IS THE DESIRED PERCENT POINT. C INPUT ARGUMENTS--DX = THE DOUBLE PRECISION VALUE AT C WHICH THE CUMULATIVE DISTRIBUTION C FUNCTION IS TO BE EVALUATED. C OUTPUT--THE DOUBLE PRECISION CUMULATIVE DISTRIBUTION C FUNCTION VALUE GL2FU2. C PRINTING--NONE. C RESTRICTIONS--NONE. C OTHER DATAPAC SUBROUTINES NEEDED--GL2CDF. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN CONTINUOUS UNIVARIATE C DISTRIBUTIONS--2, 1994, PAGES 140-142 C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATION INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2006.3 C ORIGINAL VERSION--MARCH 2006. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DX DOUBLE PRECISION DCDF C DOUBLE PRECISION DP DOUBLE PRECISION DALPHA COMMON/GL2COM/DP,DALPHA C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C CALL GL2CDF(DX,DALPHA,DCDF) GL2FU2=DP - DCDF C RETURN END SUBROUTINE GL2PDF(DX,DALPHA,DPDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY C FUNCTION VALUE FOR THE TYPE 2 GENERALIZED LOGISTIC C DISTRIBUTION WITH SHAPE PARAMETER ALPHA. C THIS DISTRIBUTION IS DEFINED FOR ALL X C AND HAS THE PROBABILITY DENSITY FUNCTION C F(X,ALPHA) = ALPHA*EXP(X)/(1+EXP(X))**(ALPHA+1) C ALPHA > 0 C C INPUT ARGUMENTS--DX = THE DOUBLE PRECISION VALUE C AT WHICH THE PROBABILITY DENSITY C FUNCTION IS TO BE EVALUATED. C --DALPHA = THE DOUBLE PRECISION SHAPE C PARAMETER. C OUTPUT ARGUMENTS--DPDF = THE DOUBLE PRECISION PROBABILITY C DENSITY FUNCTION VALUE. C OUTPUT--THE DOUBLE PRECISION PROBABILITY DENSITY FUNCTION C VALUE FOR THE TYPE 2 GENERALIZED LOGISTIC DISTRIBUTION C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--ALPHA SHOULD BE POSITIVE. C FORTRAN LIBRARY SUBROUTINES NEEDED--EXP, LOG. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN. C REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN CONTINUOUS UNIVARIATE C DISTRIBUTIONS--2, 1994, PAGES 140-142 C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE: 301-975-2855 C ORIGINAL VERSION--MARCH 2006. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DX DOUBLE PRECISION DALPHA DOUBLE PRECISION DPDF DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 DOUBLE PRECISION DTERM3 C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C--------------------------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(DALPHA.LE.0.0D0)THEN WRITE(ICOUT,4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)DALPHA CALL DPWRST('XXX','BUG ') DPDF=0.0D0 GOTO9999 ENDIF 4 FORMAT('***** ERROR--THE SHAPE PARAMETER FOR THE GL2PDF ', 1 'SUBROUTINE IS NON-POSITIVE.') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7) C C-----START POINT----------------------------------------------------- C C COMPUTE FIRST COMPONENT C DX=-DX DTERM1=DLOG(DALPHA) DTERM2=DX + (DALPHA+1.0D0)*DLOG(1.0+DEXP(-DX)) DTERM3=DTERM1-DTERM2 DPDF=DEXP(DTERM3) C 9999 CONTINUE RETURN END SUBROUTINE GL2PPF(DP,DALPHA,DPPF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT C FUNCTION VALUE FOR THE GENERALIZED LOGISTIC TYPE 2 C DISTRIBUTION WITH SHAPE PARAMETER ALPHA. C THIS DISTRIBUTION IS DEFINED FOR REAL X AND THE C PERCENT POINT FUNCTION IS COMPUTED BY C NUMERICALLY INVERTING THE CDF FUNCTION. C INPUT ARGUMENTS--DP = THE DOUBLE PRECISION VALUE AT C WHICH THE PERCENT POINT C FUNCTION IS TO BE EVALUATED. C --DALPHA = THE FIRST SHAPE PARAMETER C OUTPUT ARGUMENTS--DPPF = THE DOUBLE PRECISION CUMULATIVE C DISTRIBUTION FUNCTION VALUE. C OUTPUT--THE DOUBLE PRECISION PERCENT POINT FUNCTION VALUE DPPF. C PRINTING--NONE. C RESTRICTIONS--NONE. C OTHER DATAPAC SUBROUTINES NEEDED--DFZERO. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN CONTINUOUS UNIVARIATE C DISTRIBUTIONS--2, 1994, PAGES 140-142 C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATION INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C ORIGINAL VERSION--MARCH 2006. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DP DOUBLE PRECISION DALPHA DOUBLE PRECISION DPPF C DOUBLE PRECISION GL2FU2 EXTERNAL GL2FU2 C DOUBLE PRECISION DP2 DOUBLE PRECISION DALPH2 COMMON/GL2COM/DP2,DALPH2 C DOUBLE PRECISION XLOW DOUBLE PRECISION XLOW2 DOUBLE PRECISION XUP DOUBLE PRECISION XUP2 DOUBLE PRECISION PTEMPL DOUBLE PRECISION PTEMPU DOUBLE PRECISION AE DOUBLE PRECISION RE C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,ALPHAMBPC,ALPHAMCPW,ALPHAMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C DPPF=0.0D0 IF(DALPHA.LE.0.0D0)THEN WRITE(ICOUT,101) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,102) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,104)DALPHA CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF 101 FORMAT('***** ERROR--THE FIRST SHAPE PARAMETER, ALPHA, TO THE') 102 FORMAT(' GL2PPF ROUTINE IS NON-POSITIVE.') 104 FORMAT(' THE VALUE OF THE ARGUMENT IS ',G15.7) C IF(DP.LE.0.0D0.OR.DP.GE.1.0D0)THEN WRITE(ICOUT,61) 61 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT ', 1 'TO THE GL2PPF SUBROUTINE ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,62) 62 FORMAT(' IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,63)DP 63 FORMAT(' VALUE OF ARGUMENT = ',G15.7) CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF C C STEP 1: FIND BRACKETING INTERVAL. START WITH (-5,5) AND C INCREMENT UNITL A BRACKETING INTERVAL IS FOUND. C MAXIT=2000 XLOW2=-10.0D0 XUP2=10.0D0 200 CONTINUE CALL GL2CDF(XLOW2,DALPHA,PTEMPL) CALL GL2CDF(XUP2,DALPHA,PTEMPU) IF(PTEMPL.LT.DP .AND. PTEMPU.GT.DP)THEN XUP=XUP2 XLOW=XLOW2 GOTO300 ELSEIF(PTEMPL.LT.DP .AND. PTEMPU.LT.DP)THEN NIT=NIT+1 XUP2=10.0D0*XUP2 IF(NIT.LE.MAXIT)GOTO200 ELSEIF(PTEMPL.GT.DP .AND. PTEMPU.GT.DP)THEN NIT=NIT+1 XLOW2=10.0D0*XLOW2 IF(NIT.LE.MAXIT)GOTO200 ENDIF C WRITE(ICOUT,201) 201 FORMAT('***** ERROR FROM GL2PPF--UNABLE TO FIND A ', 1 'BRACKETING INTERVAL') CALL DPWRST('XXX','BUG ') GOTO9000 C 300 CONTINUE AE=1.0D-8 RE=1.0D-8 DP2=DP DALPH2=DALPHA CALL DFZERO(GL2FU2,XLOW,XUP,XUP,RE,AE,IFLAG) C DPPF=XLOW C IF(IFLAG.EQ.2)THEN C C NOTE: SUPPRESS THIS MESSAGE FOR NOW. CCCCC WRITE(ICOUT,999) 999 FORMAT(1X) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,121) CC111 FORMAT('***** WARNING FROM GL2PPF--') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,113) CC113 FORMAT(' PPF VALUE MAY NOT BE COMPUTED TO DESIRED ', CCCCC1 'TOLERANCE.') CCCCC CALL DPWRST('XXX','BUG ') ELSEIF(IFLAG.EQ.3)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,121) 121 FORMAT('***** WARNING FROM GL2PPF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,123) 123 FORMAT(' PPF VALUE MAY BE NEAR A SINGULAR POINT.') CALL DPWRST('XXX','BUG ') ELSEIF(IFLAG.EQ.4)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,131) 131 FORMAT('***** ERROR FROM GL2PPF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,133) 133 FORMAT(' APPROPRIATE BRACKETING INTERVAL NOT FOUND.') CALL DPWRST('XXX','BUG ') ELSEIF(IFLAG.EQ.5)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,121) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,143) 143 FORMAT(' MAXIMUM ITERATIONS EXCEEDED.') CALL DPWRST('XXX','BUG ') ENDIF C 9000 CONTINUE RETURN END SUBROUTINE GL2RAN(N,ALPHA,ISEED,X) C C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N C FROM THE GENERALIZED LOGISTIC TYPE 2 DISTRIBUTION C INPUT ARGUMENTS--N = THE DESIRED INTEGER NUMBER C OF RANDOM NUMBERS TO BE C GENERATED. C --ALPHA = THE SHAPE PARAMETER C --SEED = THE SEED FOR THE 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 GENERALIZED LOGISTIC TYPE 2 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, GL2PPF. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2006/3 C ORIGINAL VERSION--MARCH 2006. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DIMENSION X(*) C DOUBLE PRECISION DX DOUBLE PRECISION DPPF C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C 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 ') RETURN ENDIF 5 FORMAT('***** ERROR--THE REQUESTED NUMBER OF GENERALIZED ', 1 'LOGISTIC TYPE 2') 6 FORMAT(' RANDOM NUMBERS 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 GENERALIZED LOGISTIC TYPE 2 RANDOM NUMBERS C USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD C DO100I=1,N DX=DBLE(X(I)) CALL GL2PPF(DX,DBLE(ALPHA),DPPF) X(I)=REAL(DPPF) 100 CONTINUE C RETURN END SUBROUTINE GL3CDF(DX,DALPHA,DCDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION C FUNCTION VALUE FOR THE GENERALIZED LOGISTIC TYPE 3 C DISTRIBUTION WITH SHAPE PARAMETER ALPHA. C THE CUMULATIVE DISTRIBUTION IS COMPUTED BY C NUMERICALLY INTEGRATING THE PDF FUNCTION. C INPUT ARGUMENTS--DX = THE DOUBLE PRECISION VALUE AT C WHICH THE CUMULATIVE DISTRIBUTION C FUNCTION IS TO BE EVALUATED. C --DALPHA = THE DOUBLE PRECISION SHAPE PARAMETER. C OUTPUT ARGUMENTS--DCDF = THE DOUBLE PRECISION CUMULATIVE C DISTRIBUTION FUNCTION VALUE. C OUTPUT--THE DOUBLE PRECISION CUMULATIVE DISTRIBUTION C FUNCTION VALUE FOR THE GENERALIZED LOGISTIC TYPE 3 C DISTRIBUTION WITH SHAPE PARAMETER ALPHA. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--NONE. C OTHER DATAPAC SUBROUTINES NEEDED--DQAGI. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS C UNIVARIATE DISTRIBUTIONS--VOLUME II", SECOND EDITION, C JOHN WILEY, PP. 140-142, 1994. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION ALPHAMBER--2006/3 C ORIGINAL VERSION--MARCH 2006. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C INTEGER LIMIT INTEGER LENW PARAMETER(LIMIT=200) PARAMETER(LENW=4*LIMIT) INTEGER INF INTEGER NEVAL INTEGER IER INTEGER LAST INTEGER IWORK(LIMIT) DOUBLE PRECISION DX DOUBLE PRECISION DALPHA DOUBLE PRECISION DCDF DOUBLE PRECISION DA DOUBLE PRECISION EPSABS DOUBLE PRECISION EPSREL DOUBLE PRECISION RESULT DOUBLE PRECISION ABSERR DOUBLE PRECISION WORK(LENW) C DOUBLE PRECISION GL3FUN EXTERNAL GL3FUN C DOUBLE PRECISION DALPH2 COMMON/GL3COM/DALPH2 C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,ALPHAMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----DATA STATEMENTS------------------------------------------------- C C-----START POINT----------------------------------------------------- C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C DCDF=0.0D0 IF(DALPHA.LE.0.0D0)THEN WRITE(ICOUT,101) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,102) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,104)DALPHA CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF 101 FORMAT('***** ERROR--THE SHAPE PARAMETER, ALPHA, TO THE') 102 FORMAT(' GL3CDF ROUTINE IS NON-POSITIVE.') 104 FORMAT('***** VALUE OF THE ARGUMENT = ',G15.7) C C C ************************************ C ** STEP 1-- ** C ** COMPUTE THE DENSITY FUNCTION ** C ************************************ C EPSABS=1.0D-8 EPSREL=1.0D-8 IER=0 IKEY=3 DCDF=0.0D0 C DA=1.0D-7 DALPH2=DALPHA C IF(DX.LE.0.0D0)THEN INF=-1 CALL DQAGI(GL3FUN,DX,INF,EPSABS,EPSREL,DCDF,ABSERR,NEVAL, 1 IER,LIMIT,LENW,LAST,IWORK,WORK) ELSE C INF=+1 CALL DQAGI(GL3FUN,DX,INF,EPSABS,EPSREL,DCDF,ABSERR,NEVAL, 1 IER,LIMIT,LENW,LAST,IWORK,WORK) DCDF=1.0D0 - DCDF ENDIF C IF(IER.EQ.1)THEN WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,111) 111 FORMAT('***** ERROR FROM GL3CDF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,113) 113 FORMAT(' MAXIMUM NUMBER OF SUBDIVISIONS EXCEEDED.') CALL DPWRST('XXX','BUG ') ELSEIF(IER.EQ.2)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,121) 121 FORMAT('***** ERROR FROM GL3CDF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,123) 123 FORMAT(' ROUNDOFF ERROR PREVENTS REQUESTED TOLERANCE ', 1 'FROM BEING ACHIEVED.') CALL DPWRST('XXX','BUG ') ELSEIF(IER.EQ.3)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,131) 131 FORMAT('***** ERROR FROM GL3CDF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,133) 133 FORMAT(' BAD INTEGRAND BEHAVIOUR DETECTED.') CALL DPWRST('XXX','BUG ') ELSEIF(IER.EQ.4)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,141) 141 FORMAT('***** ERROR FROM GL3CDF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,143) 143 FORMAT(' INTEGRATION DID NOT CONVERGE.') CALL DPWRST('XXX','BUG ') ELSEIF(IER.EQ.5)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,151) 151 FORMAT('***** ERROR FROM GL3CDF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,153) 153 FORMAT(' THE INTEGRATION IS PROBABLY DIVERGENT.') CALL DPWRST('XXX','BUG ') ELSEIF(IER.EQ.6)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,161) 161 FORMAT('***** ERROR FROM GL3CDF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,163) 163 FORMAT(' INVALID INPUT TO THE INTEGRATION ROUTINE.') CALL DPWRST('XXX','BUG ') ENDIF C 9000 CONTINUE RETURN END DOUBLE PRECISION FUNCTION GL3FUN(DX) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY C FUNCTION VALUE FOR THE GENERALIZED LOGISTIC TYPE 3 C DISTRIBUTION WITH SHAPE PARAMETER ALPHA. C THIS DISTRIBUTION IS DEFINED FOR X > 0 AND HAS C THE PROBABILITY DENSITY FUNCTION C f(X;ALPHA) = (1/BETA(ALPHA,ALPHA)*EXP(-ALPHA*X)/ C (1+EXP(-X))**(2*ALPHA) ALPHA > 0 C THIS FUNCTION IS USED FOR INTEGRATION BY THE C GL3CDF ROUTINE. C INPUT ARGUMENTS--DX = THE DOUBLE PRECISION VALUE AT C WHICH THE PROBABILITY DENSITY C FUNCTION IS TO BE EVALUATED. C OUTPUT ARGUMENTS--GL3FUN = THE DOUBLE PRECISION PROBABILITY C DENSITY FUNCTION VALUE. C OUTPUT--THE DOUBLE PRECISION PROBABILITY DENSITY C FUNCTION VALUE PDF FOR THE GENERALIZED LOGISTIC C TYPE 3 DISTRIBUTION WITH SHAPE PARAMETER ALPHA. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--NONE. C OTHER DATAPAC SUBROUTINES NEEDED--GL3PDF. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN CONTINUOUS UNIVARIATE C DISTRIBUTIONS--2, 1994, PAGES 140-142 C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2006.3 C ORIGINAL VERSION--MARCH 2006. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DX DOUBLE PRECISION DPDF C DOUBLE PRECISION DALPHA COMMON/GL3COM/DALPHA C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----DATA STATEMENTS------------------------------------------------- C C-----START POINT----------------------------------------------------- C C ************************************ C ** STEP 1-- ** C ** COMPUTE THE DENSITY FUNCTION ** C ************************************ C CALL GL3PDF(DX,DALPHA,DPDF) GL3FUN=DPDF C RETURN END DOUBLE PRECISION FUNCTION GL3FU2(DX) C C PURPOSE--GL3PPF CALLS DFZERO TO FIND A ROOT FOR THE PERCENT C POINT FUNCTION. GL3FU2 IS THE FUNCTION FOR WHICH C THE ZERO IS FOUND. IT IS: C P - GL3CDF(X,P,Q) C WHERE P IS THE DESIRED PERCENT POINT. C INPUT ARGUMENTS--DX = THE DOUBLE PRECISION VALUE AT C WHICH THE CUMULATIVE DISTRIBUTION C FUNCTION IS TO BE EVALUATED. C OUTPUT--THE DOUBLE PRECISION CUMULATIVE DISTRIBUTION C FUNCTION VALUE GL3FU2. C PRINTING--NONE. C RESTRICTIONS--NONE. C OTHER DATAPAC SUBROUTINES NEEDED--GL3CDF. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN CONTINUOUS UNIVARIATE C DISTRIBUTIONS--2, 1994, PAGES 140-143 C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATION INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2006.3 C ORIGINAL VERSION--MARCH 2006. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DX DOUBLE PRECISION DCDF C DOUBLE PRECISION DP DOUBLE PRECISION DALPHA COMMON/GL3CO2/DP,DALPHA C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C CALL GL3CDF(DX,DALPHA,DCDF) GL3FU2=DP - DCDF C RETURN END SUBROUTINE GL3RAN(N,ALPHA,ISEED,X) C C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N C FROM THE GENERALIZED LOGISTIC TYPE 3 DISTRIBUTION C INPUT ARGUMENTS--N = THE DESIRED INTEGER NUMBER C OF RANDOM NUMBERS TO BE C GENERATED. C --ALPHA = THE SHAPE PARAMETER C --SEED = THE SEED FOR THE 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 GENERALIZED LOGISTIC TYPE 3 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, GL3PPF. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2006/3 C ORIGINAL VERSION--MARCH 2006. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DIMENSION X(*) C DOUBLE PRECISION DX DOUBLE PRECISION DPPF C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C 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 ') RETURN ENDIF 5 FORMAT('***** ERROR--THE REQUESTED NUMBER OF GENERALIZED ', 1 'LOGISTIC TYPE 3') 6 FORMAT(' RANDOM NUMBERS 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 GENERALIZED LOGISTIC TYPE 3 RANDOM NUMBERS C USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD C DO100I=1,N DX=DBLE(X(I)) CALL GL3PPF(DX,DBLE(ALPHA),DPPF) X(I)=REAL(DPPF) 100 CONTINUE C RETURN END SUBROUTINE GL3PDF(DX,DALPHA,DPDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY C FUNCTION VALUE FOR THE TYPE 3 GENERALIZED LOGISTIC C DISTRIBUTION WITH SHAPE PARAMETER ALPHA. C THIS DISTRIBUTION IS DEFINED FOR ALL X C AND HAS THE PROBABILITY DENSITY FUNCTION C f(X;ALPHA) = (1/BETA(ALPHA,ALPHA)*EXP(-ALPHA*X)/ C (1+EXP(-X))**(2*ALPHA) C INPUT ARGUMENTS--DX = THE DOUBLE PRECISION VALUE C AT WHICH THE PROBABILITY DENSITY C FUNCTION IS TO BE EVALUATED. C --DALPHA = THE DOUBLE PRECISION SHAPE C PARAMETER. C OUTPUT ARGUMENTS--DPDF = THE DOUBLE PRECISION PROBABILITY C DENSITY FUNCTION VALUE. C OUTPUT--THE DOUBLE PRECISION PROBABILITY DENSITY FUNCTION C VALUE FOR THE TYPE 3 GENERALIZED LOGISTIC DISTRIBUTION C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--ALPHA SHOULD BE POSITIVE. C FORTRAN LIBRARY SUBROUTINES NEEDED--DLOG, DEXP,DLBETA. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN. C REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN CONTINUOUS UNIVARIATE C DISTRIBUTIONS--2, 1994, PAGES 140-142 C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE: 301-975-2855 C ORIGINAL VERSION--MARCH 2006. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DX DOUBLE PRECISION DALPHA DOUBLE PRECISION DPDF DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 DOUBLE PRECISION DLBETA C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT 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(DALPHA.LE.0.0D0)THEN WRITE(ICOUT,4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)DALPHA CALL DPWRST('XXX','BUG ') DPDF=0.0D0 GOTO9999 ENDIF 4 FORMAT('***** ERROR--THE SHAPE PARAMETER FOR THE GL3PDF ', 1 'SUBROUTINE IS NON-POSITIVE.') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7) C C-----START POINT----------------------------------------------------- C DTERM1=DLBETA(DALPHA,DALPHA) DTERM2=-DALPHA*DX - 2.0D0*DALPHA*DLOG(1.0D0 + DEXP(-DX)) DPDF=DEXP(DTERM2 - DTERM1) C 9999 CONTINUE RETURN END SUBROUTINE GL3PPF(DP,DALPHA,DPPF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT C FUNCTION VALUE FOR THE GENERALIZED LOGISTIC TYPE 3 C DISTRIBUTION WITH SHAPE PARAMETER ALPHA. C THIS DISTRIBUTION IS DEFINED FOR REAL X AND THE C PERCENT POINT FUNCTION IS COMPUTED BY C NUMERICALLY INVERTING THE CDF FUNCTION. C INPUT ARGUMENTS--DP = THE DOUBLE PRECISION VALUE AT C WHICH THE PERCENT POINT C FUNCTION IS TO BE EVALUATED. C --DALPHA = THE SHAPE PARAMETER C OUTPUT ARGUMENTS--DPPF = THE DOUBLE PRECISION PERCENT POINT C FUNCTION VALUE. C OUTPUT--THE DOUBLE PRECISION PERCENT POINT FUNCTION VALUE DPPF. C PRINTING--NONE. C RESTRICTIONS--NONE. C OTHER DATAPAC SUBROUTINES NEEDED--DFZERO. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN CONTINUOUS UNIVARIATE C DISTRIBUTIONS--2, 1994, PAGES 140-143 C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATION INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C ORIGINAL VERSION--MARCH 2006. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DP DOUBLE PRECISION DALPHA DOUBLE PRECISION DPPF C DOUBLE PRECISION GL3FU2 EXTERNAL GL3FU2 C DOUBLE PRECISION DP2 DOUBLE PRECISION DALPH2 COMMON/GL3CO2/DP2,DALPH2 C DOUBLE PRECISION XLOW DOUBLE PRECISION XLOW2 DOUBLE PRECISION XUP DOUBLE PRECISION XUP2 DOUBLE PRECISION PTEMPL DOUBLE PRECISION PTEMPU DOUBLE PRECISION AE DOUBLE PRECISION RE C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,ALPHAMBPC,ALPHAMCPW,ALPHAMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C DPPF=0.0D0 IF(DALPHA.LE.0.0D0)THEN WRITE(ICOUT,101) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,102) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,104)DALPHA CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF 101 FORMAT('***** ERROR--THE FIRST SHAPE PARAMETER, ALPHA, TO THE') 102 FORMAT(' GL3PPF ROUTINE IS NON-POSITIVE.') 104 FORMAT(' THE VALUE OF THE ARGUMENT IS ',E15.7,' ******') C IF(DP.LE.0.0D0.OR.DP.GE.1.0D0)THEN WRITE(ICOUT,61) 61 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT ', 1 'TO THE GL3PPF SUBROUTINE ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,62) 62 FORMAT(' IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,63)DP 63 FORMAT(' THE VALUE OF ARGUMENT = ',G15.7) CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF C C STEP 1: FIND BRACKETING INTERVAL. START WITH (-5,5) AND C INCREMENT UNITL A BRACKETING INTERVAL IS FOUND. C C TAKE ADVANTAGE OF FACT THAT GL3 IS SYMMETRIC C (P = 0.5 IMPLIES PPF = 0). C C ALSO, MEAN = 0 AND SD = SQRT(2*PSI'(ALPHA)) C MAXIT=1000 NIT=1 IF(DP.EQ.0.5D0)THEN DPPF=0.0D0 GOTO9000 ELSEIF(DP.LT.0.5D0)THEN XLOW2=-10.0D0 XUP2=0.0D0 ELSE XLOW2=0.0D0 XUP2=10.0D0 ENDIF C 200 CONTINUE CALL GL3CDF(XLOW2,DALPHA,PTEMPL) CALL GL3CDF(XUP2,DALPHA,PTEMPU) IF(PTEMPL.LT.DP .AND. PTEMPU.GT.DP)THEN XUP=XUP2 XLOW=XLOW2 GOTO300 ELSEIF(PTEMPL.LT.DP .AND. PTEMPU.LT.DP)THEN NIT=NIT+1 XUP2=10.0D0*XUP2 IF(NIT.LE.MAXIT)GOTO200 ELSEIF(PTEMPL.GT.DP .AND. PTEMPU.GT.DP)THEN NIT=NIT+1 XLOW2=10.0D0*XLOW2 IF(NIT.LE.MAXIT)GOTO200 ENDIF C WRITE(ICOUT,201) 201 FORMAT('***** ERROR FROM GL3PPF--UNABLE TO FIND A ', 1 'BRACKETING INTERVAL') CALL DPWRST('XXX','BUG ') GOTO9000 C 300 CONTINUE AE=1.0D-6 RE=1.0D-6 DP2=DP DALPH2=DALPHA CALL DFZERO(GL3FU2,XLOW,XUP,XUP,RE,AE,IFLAG) C DPPF=XLOW C IF(IFLAG.EQ.2)THEN C C NOTE: SUPPRESS THIS MESSAGE FOR NOW. CCCCC WRITE(ICOUT,999) 999 FORMAT(1X) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,121) CC111 FORMAT('***** WARNING FROM GL3PPF--') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,113) CC113 FORMAT(' PPF VALUE MAY NOT BE COMPUTED TO DESIRED ', CCCCC1 'TOLERANCE.') CCCCC CALL DPWRST('XXX','BUG ') ELSEIF(IFLAG.EQ.3)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,121) 121 FORMAT('***** WARNING FROM GL3PPF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,123) 123 FORMAT(' PPF VALUE MAY BE NEAR A SINGULAR POINT.') CALL DPWRST('XXX','BUG ') ELSEIF(IFLAG.EQ.4)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,131) 131 FORMAT('***** ERROR FROM GL3PPF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,133) 133 FORMAT(' APPROPRIATE BRACKETING INTERVAL NOT FOUND.') CALL DPWRST('XXX','BUG ') ELSEIF(IFLAG.EQ.5)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,121) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,143) 143 FORMAT(' MAXIMUM ITERATIONS EXCEEDED.') CALL DPWRST('XXX','BUG ') ENDIF C 9000 CONTINUE RETURN END SUBROUTINE GL4CDF(DX,DP,DQ,DCDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION C FUNCTION VALUE FOR THE GENERALIZED LOGISTIC TYPE 4 C DISTRIBUTION WITH SHAPE PARAMETER P AND Q. C THE CUMULATIVE DISTRIBUTION IS COMPUTED BY C NUMERICALLY INTEGRATING THE PDF FUNCTION. C INPUT ARGUMENTS--DX = THE DOUBLE PRECISION VALUE AT C WHICH THE CUMULATIVE DISTRIBUTION C FUNCTION IS TO BE EVALUATED. C --DALPHA = THE DOUBLE PRECISION SHAPE PARAMETER. C OUTPUT ARGUMENTS--DCDF = THE DOUBLE PRECISION CUMULATIVE C DISTRIBUTION FUNCTION VALUE. C OUTPUT--THE DOUBLE PRECISION CUMULATIVE DISTRIBUTION C FUNCTION VALUE FOR THE GENERALIZED LOGISTIC TYPE 4 C DISTRIBUTION WITH SHAPE PARAMETER P AND Q. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--NONE. C OTHER DATAPAC SUBROUTINES NEEDED--DQAGI. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS C UNIVARIATE DISTRIBUTIONS--VOLUME II", SECOND EDITION, C JOHN WILEY, PP. 140-142, 1994. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION ALPHAMBER--2006/3 C ORIGINAL VERSION--MARCH 2006. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C INTEGER LIMIT INTEGER LENW PARAMETER(LIMIT=200) PARAMETER(LENW=4*LIMIT) INTEGER INF INTEGER NEVAL INTEGER IER INTEGER LAST INTEGER IWORK(LIMIT) DOUBLE PRECISION DX DOUBLE PRECISION DP DOUBLE PRECISION DQ DOUBLE PRECISION DCDF DOUBLE PRECISION EPSABS DOUBLE PRECISION EPSREL DOUBLE PRECISION RESULT DOUBLE PRECISION ABSERR DOUBLE PRECISION WORK(LENW) C DOUBLE PRECISION GL4FUN EXTERNAL GL4FUN C DOUBLE PRECISION DP2,DQ2 COMMON/GL4COM/DP2,DQ2 C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,ALPHAMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----DATA STATEMENTS------------------------------------------------- C C-----START POINT----------------------------------------------------- C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C DCDF=0.0D0 IF(DP.LE.0.0D0)THEN WRITE(ICOUT,101) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,102) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,104)DP CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF IF(DQ.LE.0.0D0)THEN WRITE(ICOUT,105) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,106) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,104)DQ CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF 101 FORMAT('***** ERROR--THE FIRST SHAPE PARAMETER, P, TO THE') 102 FORMAT(' GL4CDF ROUTINE IS NON-POSITIVE.') 105 FORMAT('***** ERROR--THE SECOND SHAPE PARAMETER, Q, TO THE') 106 FORMAT(' GL4CDF ROUTINE IS NON-POSITIVE.') 104 FORMAT('***** VALUE OF THE ARGUMENT = ',G15.7) C C C ************************************ C ** STEP 1-- ** C ** COMPUTE THE DENSITY FUNCTION ** C ************************************ C EPSABS=1.0D-10 EPSREL=1.0D-10 IER=0 IKEY=3 DCDF=0.0D0 C DP2=DP DQ2=DQ C IF(DX.LE.0.0D0)THEN INF=-1 CALL DQAGI(GL4FUN,DX,INF,EPSABS,EPSREL,DCDF,ABSERR,NEVAL, 1 IER,LIMIT,LENW,LAST,IWORK,WORK) ELSE C INF=+1 CALL DQAGI(GL4FUN,DX,INF,EPSABS,EPSREL,DCDF,ABSERR,NEVAL, 1 IER,LIMIT,LENW,LAST,IWORK,WORK) DCDF=1.0D0 - DCDF ENDIF C IF(IER.EQ.1)THEN WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,111) 111 FORMAT('***** ERROR FROM GL4CDF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,113) 113 FORMAT(' MAXIMUM NUMBER OF SUBDIVISIONS EXCEEDED.') CALL DPWRST('XXX','BUG ') ELSEIF(IER.EQ.2)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,121) 121 FORMAT('***** ERROR FROM GL4CDF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,123) 123 FORMAT(' ROUNDOFF ERROR PREVENTS REQUESTED TOLERANCE ', 1 'FROM BEING ACHIEVED.') CALL DPWRST('XXX','BUG ') ELSEIF(IER.EQ.3)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,131) 131 FORMAT('***** ERROR FROM GL4CDF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,133) 133 FORMAT(' BAD INTEGRAND BEHAVIOUR DETECTED.') CALL DPWRST('XXX','BUG ') ELSEIF(IER.EQ.4)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,141) 141 FORMAT('***** ERROR FROM GL4CDF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,143) 143 FORMAT(' INTEGRATION DID NOT CONVERGE.') CALL DPWRST('XXX','BUG ') ELSEIF(IER.EQ.5)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,151) 151 FORMAT('***** ERROR FROM GL4CDF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,153) 153 FORMAT(' THE INTEGRATION IS PROBABLY DIVERGENT.') CALL DPWRST('XXX','BUG ') ELSEIF(IER.EQ.6)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,161) 161 FORMAT('***** ERROR FROM GL4CDF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,163) 163 FORMAT(' INVALID INPUT TO THE INTEGRATION ROUTINE.') CALL DPWRST('XXX','BUG ') ENDIF C 9000 CONTINUE RETURN END DOUBLE PRECISION FUNCTION GL4FUN(DX) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY C FUNCTION VALUE FOR THE GENERALIZED LOGISTIC TYPE 4 C DISTRIBUTION WITH SHAPE PARAMETER ALPHA. C THIS DISTRIBUTION IS DEFINED FOR X > 0 AND HAS C THE PROBABILITY DENSITY FUNCTION C f(X;P,Q) = (1/BETA(P,Q)*EXP(-Q*X)/ C (1+EXP(-X))**(P+Q) C P, Q > 0 C THIS FUNCTION IS USED FOR INTEGRATION BY THE C GL4CDF ROUTINE. C INPUT ARGUMENTS--DX = THE DOUBLE PRECISION VALUE AT C WHICH THE PROBABILITY DENSITY C FUNCTION IS TO BE EVALUATED. C OUTPUT ARGUMENTS--GL4FUN = THE DOUBLE PRECISION PROBABILITY C DENSITY FUNCTION VALUE. C OUTPUT--THE DOUBLE PRECISION PROBABILITY DENSITY C FUNCTION VALUE PDF FOR THE GENERALIZED LOGISTIC C TYPE 4 DISTRIBUTION WITH SHAPE PARAMETER ALPHA. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--NONE. C OTHER DATAPAC SUBROUTINES NEEDED--GL4PDF. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN CONTINUOUS UNIVARIATE C DISTRIBUTIONS--2, 1994, PAGES 140-142 C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2006.3 C ORIGINAL VERSION--MARCH 2006. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DX DOUBLE PRECISION DPDF C DOUBLE PRECISION DP DOUBLE PRECISION DQ COMMON/GL4COM/DP,DQ C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----DATA STATEMENTS------------------------------------------------- C C-----START POINT----------------------------------------------------- C C ************************************ C ** STEP 1-- ** C ** COMPUTE THE DENSITY FUNCTION ** C ************************************ C CALL GL4PDF(DX,DP,DQ,DPDF) GL4FUN=DPDF C RETURN END DOUBLE PRECISION FUNCTION GL4FU2(DX) C C PURPOSE--GL4PPF CALLS DFZERO TO FIND A ROOT FOR THE PERCENT C POINT FUNCTION. GL4FU2 IS THE FUNCTION FOR WHICH C THE ZERO IS FOUND. IT IS: C P - GL4CDF(X,P,Q) C WHERE P IS THE DESIRED PERCENT POINT. C INPUT ARGUMENTS--DX = THE DOUBLE PRECISION VALUE AT C WHICH THE CUMULATIVE DISTRIBUTION C FUNCTION IS TO BE EVALUATED. C OUTPUT--THE DOUBLE PRECISION CUMULATIVE DISTRIBUTION C FUNCTION VALUE GL4FU2. C PRINTING--NONE. C RESTRICTIONS--NONE. C OTHER DATAPAC SUBROUTINES NEEDED--GL4CDF. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN CONTINUOUS UNIVARIATE C DISTRIBUTIONS--2, 1994, PAGES 140-143 C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATION INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2006.3 C ORIGINAL VERSION--MARCH 2006. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DX DOUBLE PRECISION DCDF C DOUBLE PRECISION DP DOUBLE PRECISION DPPAR DOUBLE PRECISION DQPAR COMMON/GL4CO2/DP,DPPAR,DQPAR C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C CALL GL4CDF(DX,DPPAR,DQPAR,DCDF) GL4FU2=DP - DCDF C RETURN END SUBROUTINE GL4PDF(DX,DP,DQ,DPDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY C FUNCTION VALUE FOR THE TYPE 4 GENERALIZED LOGISTIC C DISTRIBUTION WITH SHAPE PARAMETERS P AND Q. C THIS DISTRIBUTION IS DEFINED FOR ALL X C AND HAS THE PROBABILITY DENSITY FUNCTION C f(X;P,Q) = (1/BETA(P,Q)*EXP(-Q*X)/ C (1+EXP(-X))**(P+Q) C P, Q > 0 C INPUT ARGUMENTS--DX = THE DOUBLE PRECISION VALUE C AT WHICH THE PROBABILITY DENSITY C FUNCTION IS TO BE EVALUATED. C --DP = THE DOUBLE PRECISION FIRST SHAPE C PARAMETER. C --DQ = THE DOUBLE PRECISION SECOND SHAPE C PARAMETER. C OUTPUT ARGUMENTS--DPDF = THE DOUBLE PRECISION PROBABILITY C DENSITY FUNCTION VALUE. C OUTPUT--THE DOUBLE PRECISION PROBABILITY DENSITY FUNCTION C VALUE FOR THE TYPE 3 GENERALIZED LOGISTIC DISTRIBUTION C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--ALPHA SHOULD BE POSITIVE. C FORTRAN LIBRARY SUBROUTINES NEEDED--DLOG, DEXP,DLBETA. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN. C REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN CONTINUOUS UNIVARIATE C DISTRIBUTIONS--2, 1994, PAGES 140-143 C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE: 301-975-2855 C ORIGINAL VERSION--MARCH 2006. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DX DOUBLE PRECISION DP DOUBLE PRECISION DQ DOUBLE PRECISION DPDF DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 DOUBLE PRECISION DLBETA C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT 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(DP.LE.0.0D0)THEN WRITE(ICOUT,4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)DP CALL DPWRST('XXX','BUG ') DPDF=0.0D0 GOTO9999 ENDIF IF(DQ.LE.0.0D0)THEN WRITE(ICOUT,4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)DQ CALL DPWRST('XXX','BUG ') DPDF=0.0D0 GOTO9999 ENDIF 4 FORMAT('***** ERROR--THE FIRST SHAPE PARAMETER FOR THE GL4PDF ', 1 'SUBROUTINE IS NON-POSITIVE.') 5 FORMAT('***** ERROR--THE SECOND SHAPE PARAMETER FOR THE GL4PDF ', 1 'SUBROUTINE IS NON-POSITIVE.') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7) C C-----START POINT----------------------------------------------------- C DTERM1=DLBETA(DP,DQ) DTERM2=-DQ*DX - (DP+DQ)*DLOG(1.0D0 + DEXP(-DX)) DPDF=DEXP(DTERM2 - DTERM1) C 9999 CONTINUE RETURN END SUBROUTINE GL4PPF(DP,DPPAR,DQPAR,DPPF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT C FUNCTION VALUE FOR THE GENERALIZED LOGISTIC TYPE 4 C DISTRIBUTION WITH SHAPE PARAMETERS P AND Q. C THIS DISTRIBUTION IS DEFINED FOR REAL X AND THE C PERCENT POINT FUNCTION IS COMPUTED BY C NUMERICALLY INVERTING THE CDF FUNCTION. C INPUT ARGUMENTS--DP = THE DOUBLE PRECISION VALUE AT C WHICH THE PERCENT POINT C FUNCTION IS TO BE EVALUATED. C --DPPAR = THE FIRST SHAPE PARAMETER C --DQPAR = THE SECOND SHAPE PARAMETER C OUTPUT ARGUMENTS--DPPF = THE DOUBLE PRECISION PERCENT POINT C FUNCTION VALUE. C OUTPUT--THE DOUBLE PRECISION PERCENT POINT FUNCTION VALUE DPPF. C PRINTING--NONE. C RESTRICTIONS--NONE. C OTHER DATAPAC SUBROUTINES NEEDED--DFZERO. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN CONTINUOUS UNIVARIATE C DISTRIBUTIONS--2, 1994, PAGES 140-143 C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATION INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C ORIGINAL VERSION--MARCH 2006. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DP DOUBLE PRECISION DPPAR DOUBLE PRECISION DQPAR DOUBLE PRECISION DPPF C DOUBLE PRECISION GL4FU2 EXTERNAL GL4FU2 C DOUBLE PRECISION DP2 DOUBLE PRECISION DPPAR2 DOUBLE PRECISION DQPAR2 COMMON/GL4CO2/DP2,DPPAR2,DQPAR2 C DOUBLE PRECISION XLOW DOUBLE PRECISION XLOW2 DOUBLE PRECISION XUP DOUBLE PRECISION XUP2 DOUBLE PRECISION PTEMPL DOUBLE PRECISION PTEMPU DOUBLE PRECISION AE DOUBLE PRECISION RE C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,ALPHAMBPC,ALPHAMCPW,ALPHAMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C DPPF=0.0D0 IF(DPPAR.LE.0.0D0)THEN WRITE(ICOUT,101) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,102) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,104)DPPAR CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF IF(DQPAR.LE.0.0D0)THEN WRITE(ICOUT,103) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,102) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,104)DQPAR CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF 101 FORMAT('***** ERROR--THE FIRST SHAPE PARAMETER, P, TO THE') 102 FORMAT(' GL4PPF ROUTINE IS NON-POSITIVE.') 103 FORMAT('***** ERROR--THE SECOND SHAPE PARAMETER, Q, TO THE') 104 FORMAT(' THE VALUE OF THE ARGUMENT IS ',E15.7,' ******') C IF(DP.LE.0.0D0.OR.DP.GE.1.0D0)THEN WRITE(ICOUT,61) 61 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT ', 1 'TO THE GL4PPF SUBROUTINE ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,62) 62 FORMAT(' IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,63)DP 63 FORMAT(' THE VALUE OF ARGUMENT = ',G15.7) CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF C C STEP 1: FIND BRACKETING INTERVAL. START WITH (-5,5) AND C INCREMENT UNITL A BRACKETING INTERVAL IS FOUND. C MAXIT=1000 XLOW2=-5.0D0 XUP2=5.0D0 C 200 CONTINUE CALL GL4CDF(XLOW2,DPPAR,DQPAR,PTEMPL) CALL GL4CDF(XUP2,DPPAR,DQPAR,PTEMPU) IF(PTEMPL.LT.DP .AND. PTEMPU.GT.DP)THEN XUP=XUP2 XLOW=XLOW2 GOTO300 ELSEIF(PTEMPL.LT.DP .AND. PTEMPU.LT.DP)THEN MAXIT=MAXIT+1 XUP2=5.0D0*XUP2 IF(MAXIT.LE.MAXIT)GOTO200 ELSEIF(PTEMPL.GT.DP .AND. PTEMPU.GT.DP)THEN MAXIT=MAXIT+1 XLOW2=5.0D0*XLOW2 IF(MAXIT.LE.MAXIT)GOTO200 ENDIF C WRITE(ICOUT,201) 201 FORMAT('***** ERROR FROM GL4PPF--UNABLE TO FIND A ', 1 'BRACKETING INTERVAL') CALL DPWRST('XXX','BUG ') GOTO9000 C 300 CONTINUE AE=1.0D-8 RE=1.0D-8 DP2=DP DPPAR2=DPPAR DQPAR2=DQPAR CALL DFZERO(GL4FU2,XLOW,XUP,XUP,RE,AE,IFLAG) C DPPF=XLOW C IF(IFLAG.EQ.2)THEN C C NOTE: SUPPRESS THIS MESSAGE FOR NOW. CCCCC WRITE(ICOUT,999) 999 FORMAT(1X) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,121) CC111 FORMAT('***** WARNING FROM GL4PPF--') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,113) CC113 FORMAT(' PPF VALUE MAY NOT BE COMPUTED TO DESIRED ', CCCCC1 'TOLERANCE.') CCCCC CALL DPWRST('XXX','BUG ') ELSEIF(IFLAG.EQ.3)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,121) 121 FORMAT('***** WARNING FROM GL4PPF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,123) 123 FORMAT(' PPF VALUE MAY BE NEAR A SINGULAR POINT.') CALL DPWRST('XXX','BUG ') ELSEIF(IFLAG.EQ.4)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,131) 131 FORMAT('***** ERROR FROM GL4PPF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,133) 133 FORMAT(' APPROPRIATE BRACKETING INTERVAL NOT FOUND.') CALL DPWRST('XXX','BUG ') ELSEIF(IFLAG.EQ.5)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,121) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,143) 143 FORMAT(' MAXIMUM ITERATIONS EXCEEDED.') CALL DPWRST('XXX','BUG ') ENDIF C 9000 CONTINUE RETURN END SUBROUTINE GL4RAN(N,P,Q,ISEED,X) C C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N C FROM THE GENERALIZED LOGISTIC TYPE 4 DISTRIBUTION C INPUT ARGUMENTS--N = THE DESIRED INTEGER NUMBER C OF RANDOM NUMBERS TO BE C GENERATED. C --P = THE FIRST SHAPE PARAMETER C --Q = THE SECOND SHAPE PARAMETER C --SEED = THE SEED FOR THE 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 GENERALIZED LOGISTIC TYPE 4 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, GL4PPF. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2006/3 C ORIGINAL VERSION--MARCH 2006. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DIMENSION X(*) C DOUBLE PRECISION DX DOUBLE PRECISION DPPF C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C 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 ') RETURN ENDIF 5 FORMAT('***** ERROR--THE REQUESTED NUMBER OF GENERALIZED ', 1 'LOGISTIC TYPE 4') 6 FORMAT(' RANDOM NUMBERS 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 GENERALIZED LOGISTIC TYPE 4 RANDOM NUMBERS C USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD C DO100I=1,N DX=DBLE(X(I)) CALL GL4PPF(DX,DBLE(P),DBLE(Q),DPPF) X(I)=REAL(DPPF) 100 CONTINUE C RETURN END SUBROUTINE GL5PDF(X,GAMMA,PDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY C FUNCTION VALUE FOR THE TYPE 5 GENERALIZED LOGISTIC C DISTRIBUTION WITH SHAPE PARAMETER GAMMA. C THIS DISTRIBUTION IS DEFINED FOR ALL X C THIS DEFINITION IS DUE TO HOSKINGS AND HAS THE C FOLLOWING DEFINITION: C C F(X,GAMMA) = (1-GAMMA*X)**((1/GAMMA)-1)/ C {1+(1-GAMMA*X)**(1/GAMMA}**2 C X <= 1/GAMMA FOR GAMMA > 0 C X >= 1/GAMMA FOR GAMMA < 0 C FOR GAMMA = 0, JUST COMPUTE THE STANDARD C LOGISTIC DISTRIBUTION. C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE C AT WHICH THE PROBABILITY DENSITY C FUNCTION IS TO BE EVALUATED. C --GAMMA = 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 FOR THE GENERALIZED LOGISTIC TYPE 5 C DISTRIBUTION C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--X SHOULD BE NON-NEGATIVE. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN. C REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN CONTINUOUS UNIVARIATE C DISTRIBUTIONS--2, 1994, PAGE 145 C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING LABORATORY C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE: 301-975-2855 C ORIGINAL VERSION--FEBRUARY 2006. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION X DOUBLE PRECISION GAMMA DOUBLE PRECISION PDF DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 DOUBLE PRECISION DTERM3 C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C--------------------------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(GAMMA.EQ.0.0D0)THEN CALL LOGPDF(REAL(X),PDF2) PDF=DBLE(PDF2) GOTO9999 ELSEIF(GAMMA.GT.0.0D0)THEN IF(X.GT.1.0D0/GAMMA)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)GAMMA CALL DPWRST('XXX','BUG ') PDF=0.0D0 GOTO9999 ENDIF 4 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO THE ', 1 'GL5PDF SUBROUTINE') 5 FORMAT(' IS GREATER THAN 1/GAMMA') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.8) 47 FORMAT('***** THE VALUE OF GAMMA IS ',G15.8) C IF(X.EQ.1.0/GAMMA)THEN PDF=0.0D0 ELSE DTERM1=(1.0D0/GAMMA) DTERM2=(DTERM1 - 1.0D0)*DLOG(1.0D0 - X*GAMMA) DTERM3=2.0D0*DLOG(1.0D0 + (1.0D0 - GAMMA*X)**DTERM1) PDF=DEXP(DTERM2 - DTERM3) ENDIF C ELSEIF(GAMMA.LT.0.0)THEN IF(X.LT.1.0/GAMMA)THEN WRITE(ICOUT,4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,15) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)GAMMA CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ENDIF 15 FORMAT(' IS LESS THAN 1/GAMMA') C IF(X.EQ.1.0/GAMMA)THEN PDF=0.0D0 ELSE DTERM1=(1.0D0/GAMMA) DTERM2=(DTERM1 - 1.0D0)*DLOG(1.0D0 - X*GAMMA) DTERM3=2.0D0*DLOG(1.0D0 + (1.0D0 - GAMMA*X)**DTERM1) PDF=DEXP(DTERM2 - DTERM3) ENDIF C ENDIF C 9999 CONTINUE RETURN END SUBROUTINE GL5RAN(N,ALPHA,ISEED,X) C C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N C FROM THE GENERALIZED LOGISTIC TYPE 5 (HOSKING) C DISTRIBUTION C INPUT ARGUMENTS--N = THE DESIRED INTEGER NUMBER C OF RANDOM NUMBERS TO BE C GENERATED. C --ALPHA = THE SHAPE PARAMETER C --SEED = THE SEED FOR THE 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 GENERALIZED LOGISTIC TYPE 5 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, QUAGLO. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2006/2 C ORIGINAL VERSION--FEBRUARY 2006. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DIMENSION X(*) C DOUBLE PRECISION XPAR(3) DOUBLE PRECISION QUAGLO DOUBLE PRECISION DX DOUBLE PRECISION DPPF C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C 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 ') RETURN ENDIF 5 FORMAT('***** ERROR--THE REQUESTED NUMBER OF GENERALIZED ', 1 'LOGISTIC TYPE 5 (HOSKING)') 6 FORMAT(' RANDOM NUMBERS 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 GENERALIZED LOGISTIC TYPE 5 RANDOM NUMBERS C USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD C XPAR(1)=0.0D0 XPAR(2)=1.0D0 XPAR(3)=DBLE(ALPHA) C DO100I=1,N DX=DBLE(X(I)) DPPF=QUAGLO(DX,XPAR) X(I)=REAL(DPPF) 100 CONTINUE C RETURN END SUBROUTINE GLSCDF(X,THETA,BETA,CDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION C FUNCTION VALUE FOR THE GENERALIZED LOGARITHMIC SERIES C DISTRIBUTION WITH SHAPE PARAMETERS THETA AND BETA. C THIS DISTRIBUTION IS DEFINED FOR ALL INTEGER X >= 1. C THE PROBABILITY MASS FUNCTION IS: C p(X;THETA,BETA)= C Gamma(BETA*X+1)*THETA**X*(1-THETA)**(BETA*X-X)/ C X!*(BETA*X)*Gamma(BETA*X-X+1)*[-LOG(1-THETA)] C X = 1, 2, 3, ,... C 0 < THETA < 1; 1 <= BETA < 1/THETA C C THE CUMULATIVE DISTRIBUTION FUNCTION IS COMPUTED C BY SUMMING THE PROBABILITY MASS FUNCTION. C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE AT C WHICH THE CUMULATIVE DISTRIBUTION C FUNCTION IS TO BE EVALUATED. C X SHOULD BE A NON-NEGATIVE INTEGER. C --THETA = THE FIRST SHAPE PARAMETER C --BETA = THE SECOND SHAPE PARAMETER C OUTPUT ARGUMENTS--CDF = THE SINGLE PRECISION CUMULATIVE C DISTRIBUTION FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION FUNCTION C VALUE CDF FOR THE GENERALIZED LOGARITHMIC SERIES C DISTRIBUTION WITH SHAPE PARAMETERS THETA AND BETA C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--X SHOULD BE A POSITIVE INTEGER C --0 < THETA < 1; 1 < BETA < 1/THETA C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--FAMOYE (1997), "SAMPLING FROM A GENERALIZED C LOGARITHMIC SERIES DISTRIBUTION", COMPUTING, C 58(4), PP. 365-376. C --CONSUL AND FAMOYE (2006), "LAGRANGIAN PROBABILITY C DISTRIBUTIONS", BIRKHAUSER, CHAPTER 11. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2006/6 C ORIGINAL VERSION--JUNE 2006. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 DOUBLE PRECISION DTERM3 DOUBLE PRECISION DSUM DOUBLE PRECISION DX DOUBLE PRECISION DTHETA DOUBLE PRECISION DBETA DOUBLE PRECISION DPDF DOUBLE PRECISION DPDFSV DOUBLE PRECISION DCDF C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IX=INT(X+0.5) IF(IX.LT.1)THEN WRITE(ICOUT,4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9000 ENDIF 4 FORMAT('***** ERROR--THE FIRST ARGUMENT TO GLSCDF IS LESS ', 1'THAN 1') C IF(THETA.LE.0.0 .OR. THETA.GE.1.0)THEN WRITE(ICOUT,15) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)THETA CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9000 ENDIF 15 FORMAT('***** ERROR--THE SECOND ARGUMENT TO GLSCDF IS NOT IN ', 1'THE INTERVAL (0,1)') C IF(BETA.LT.1.0 .OR. BETA.GE.1.0/THETA)THEN WRITE(ICOUT,25)1.0/THETA CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)THETA CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9000 ENDIF 25 FORMAT('***** ERROR--THE THIRD ARGUMENT TO GLSCDF IS NOT IN ', 1'THE INTERVAL (1,',G15.7,')') C 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7) C DTHETA=DBLE(THETA) DBETA=DBLE(BETA) C C USE THE RECURRENCE RELATION (PAGE 228 OF CONSUL AND FAMOYE): C C P(X+1;THETA,BETA) = (BETA - X/(X+1))*THETA*(1-THETA)**(BETA-1)* C PROD[j=1 to X-1][1 + BETA/(BETA*X-j)]* C P(X;THETA,BETA) C C COMPUTE BY TAKING LOG OF THIS FORMULA WHEN X >= 3. C DCDF=DTHETA*(1.0D0 - DTHETA)**(DBETA - 1.0D0)/ 1 (-DLOG(1.0D0 - DTHETA)) IF(IX.EQ.1)GOTO1000 C DPDF=(DBETA-0.5D0)*DTHETA*(1.0D0-DTHETA)**(DBETA-1.0D0)*DCDF DCDF=DCDF + DPDF IF(IX.EQ.2)GOTO1000 DPDFSV=DPDF DTERM2=DLOG(DTHETA) + (DBETA - 1.0D0)*DLOG(1.0D0 - DTHETA) C DO100I=3,IX DX=DBLE(I) DTERM1=DLOG(DBETA - (DX-1.0D0)/DX) IF(DPDFSV.LE.0.0D0)THEN GOTO1000 ELSE DTERM3=DLOG(DPDFSV) ENDIF DSUM=0.0D0 DO200J=1,I-2 DSUM=DSUM + DLOG(1.0D0 + DBETA/(DBETA*(DX-1.0D0)-DBLE(J))) 200 CONTINUE DPDF=DEXP(DTERM1 + DTERM2 + DTERM3 + DSUM) DCDF=DCDF + DPDF DPDFSV=DPDF 100 CONTINUE C 1000 CONTINUE CDF=REAL(DCDF) C 9000 CONTINUE RETURN END DOUBLE PRECISION FUNCTION GLSFUN(DTHETA) C C PURPOSE--THIS ROUTINE COMPUTES THE FUNCTIONS FOR THE C GENERALIZED LOGARITHMIC SERIES METHOD OF MOMENT C EQUATIONS. C C (1-THETA)*XBAR**3/ALPHA**2 - C THETA**2*(s**2+XBAR**2) 0 C C WITH THETA DENOTING THE SHAPE PARAMETER AND C ALPHA = 1/-LOG(1-THETA). THIS C ROUTINE ASSUMES THE DATA IS IN THE FORM C C X(I) FREQ(I) C C CALLED BY DNSQE ROUTINE FOR SOLVING SIMULTANEOUS C NONLINEAR EQUATIONS. NOTE THAT THE CALLING SEQUENCE C DID NOT ACCOMODATE A DATA ARRAY (AND ASSCIATED NUMBER OF C OBSERVATIONS), SO THESE WERE ADDED TO THE CALL LIST. C SINCE DNSQE ONLY PASSES ONE ARRAY, WE SPLIT INTO C TWO PARTS: 1 - MAXNXT/2 ARE THE FREQUENCIES WHILE C (MAXNXT/2 + 1) - MAXNXT ARE THE CLASS VALUES (I.E., C THE X). C EXAMPLE--GENERALIZED LOGARITHMIC SERIES MAXIMUM LIKELIHOOD Y C REFERENCES--CONSUL AND FAMOYE (2006), "LAGRANGIAN PROBABILITY C DISTRIBUTIONS", BIRKHAUSER, CHAPTER 11. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBUG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2006/7 C ORIGINAL VERSION--JULY 2006. C C--------------------------------------------------------------------- C DOUBLE PRECISION DTHETA DOUBLE PRECISION DALPHA C DOUBLE PRECISION XBAR DOUBLE PRECISION S2 DOUBLE PRECISION F1FREQ COMMON/GLSCOM/XBAR,S2,F1FREQ,MAXROW,N C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C COMPUTE SOME SUMS C DALPHA=-1.0D0/DLOG(1.0D0 - DTHETA) GLSFUN=(1.0D0-DTHETA)*XBAR**3/(DALPHA**2) - 1 DTHETA**2*(S2+XBAR**2) C RETURN END SUBROUTINE GLSFU2(N,XPAR,FVEC,IFLAG,Y,K) C C PURPOSE--THIS ROUTINE COMPUTES THE FUNCTIONS FOR THE C GENERALIZED LOGARITHMIC SERIES MAXIMUM LIKELIHOOD C EQUATIONS. C C THE MAXIMUM LIKELIHOOD ESTIMATES ARE THE SOLUTIONS C TO THE EQUATIONS: C C (N*XBAR/THETA) - (BETA-1)*N*XBAR/(1-THETA) + C N/((1-THETA)*LOG(1-THETA)) = 0 C C N*XBAR*LOG(1-THETA) + C SUM[X=2 to K][SUM[i=1 to x-1][X*N(X)/(BETA*X-i)]] C = 0 C C WITH THETA DENOTING THE SHAPE PARAMETER AND C ALPHA = 1/-LOG(1-THETA). THIS C ROUTINE ASSUMES THE DATA IS IN THE FORM C C X(I) FREQ(I) C C CALLED BY DNSQE ROUTINE FOR SOLVING SIMULTANEOUS C NONLINEAR EQUATIONS. NOTE THAT THE CALLING SEQUENCE C DID NOT ACCOMODATE A DATA ARRAY (AND ASSCIATED NUMBER OF C OBSERVATIONS), SO THESE WERE ADDED TO THE CALL LIST. C SINCE DNSQE ONLY PASSES ONE ARRAY, WE SPLIT INTO C TWO PARTS: 1 - MAXNXT/2 ARE THE FREQUENCIES WHILE C (MAXNXT/2 + 1) - MAXNXT ARE THE CLASS VALUES (I.E., C THE X). C EXAMPLE--GENERALIZED LOGARITHMIC SERIES MAXIMUM LIKELIHOOD Y C REFERENCES--CONSUL AND FAMOYE (2006), "LAGRANGIAN PROBABILITY C DISTRIBUTIONS", BIRKHAUSER, CHAPTER 11. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBUG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2006/7 C ORIGINAL VERSION--JULY 2006. C C--------------------------------------------------------------------- C DOUBLE PRECISION XPAR(*) DOUBLE PRECISION FVEC(*) REAL Y(*) C DOUBLE PRECISION DX DOUBLE PRECISION DFREQ DOUBLE PRECISION DTHETA DOUBLE PRECISION DBETA DOUBLE PRECISION DALPHA DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 DOUBLE PRECISION DTERM3 DOUBLE PRECISION DSUM1 DOUBLE PRECISION DN C DOUBLE PRECISION XBAR DOUBLE PRECISION S2 DOUBLE PRECISION F1FREQ COMMON/GLSCOM/XBAR,S2,F1FREQ,MAXROW,NTOT 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 COMPUTE SOME SUMS C DTHETA=XPAR(1) DBETA=XPAR(2) DALPHA=-1.0D0/DLOG(1.0D0 - DTHETA) DN=DBLE(NTOT) C IINDX=MAXROW/2 C DTERM1=DN*XBAR/DTHETA DTERM2=(DBETA-1.0D0)*DN*XBAR/(1.0D0-DTHETA) DTERM3=DN/((1.0D0-DTHETA)*DLOG(1.0D0-DTHETA)) FVEC(1)=DTERM1 - DTERM2 + DTERM3 C DSUM1=0.0D0 DTERM1=DN*XBAR*DLOG(1.0D0-DTHETA) C DO100I=2,K DX=DBLE(Y(IINDX+I)) DFREQ=Y(I) DO200J=1,I-1 DSUM1=DSUM1 + DX*DFREQ/(DBETA*DX - DBLE(J)) 200 CONTINUE 100 CONTINUE C FVEC(2)=DTERM1 + DSUM1 C RETURN END DOUBLE PRECISION FUNCTION GLSFU3(DTHETA) C C PURPOSE--THIS ROUTINE COMPUTES THE FUNCTIONS FOR THE C GENERALIZED LOGARITHMIC SERIES METHOD OF ONES C FREQUENCY AND SAMPLE MEAN EQUATIONS. C C LOG(THETA) + ((1/THETA) - C (1/XBAR)*(-1/LOG(1-THETA) - 1)*LOG(1-THETA) - C LOG(-LOG(1-THETA)) - LOG(F1/N) = 0 C C WITH THETA DENOTING THE SHAPE PARAMETER. C C CALLED BY DFZERO ROUTINE. C EXAMPLE--GENERALIZED LOGARITHMIC SERIES MAXIMUM LIKELIHOOD Y C REFERENCES--CONSUL AND FAMOYE (2006), "LAGRANGIAN PROBABILITY C DISTRIBUTIONS", BIRKHAUSER, CHAPTER 11. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBUG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2006/7 C ORIGINAL VERSION--JULY 2006. C C--------------------------------------------------------------------- C DOUBLE PRECISION DTHETA DOUBLE PRECISION DALPHA DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 DOUBLE PRECISION DTERM3 DOUBLE PRECISION DTERM4 C DOUBLE PRECISION XBAR DOUBLE PRECISION S2 DOUBLE PRECISION F1 COMMON/GLSCOM/XBAR,S2,F1,MAXROW,N C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C COMPUTE SOME SUMS C DN=DBLE(N) DTERM1=DLOG(DTHETA) DALPHA=-1.0D0/DLOG(1.0D0 - DTHETA) DTERM2=((1.0D0/DTHETA) - DALPHA/XBAR - 1.0D0)* 1 DLOG(1.0D0 - DTHETA) DTERM3=DLOG(-DLOG(1.0D0-DTHETA)) DTERM4=DLOG(F1) GLSFU3=DTERM1 + DTERM2 - DTERM3 - DTERM4 C RETURN END SUBROUTINE GLSPDF(X,THETA,BETA,PDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY MASS C FUNCTION VALUE FOR THE GENERALIZED LOGARITHMIC SERIES C DISTRIBUTION WITH SHAPE PARAMETERS THETA AND BETA. C THIS DISTRIBUTION IS DEFINED FOR ALL INTEGER X >= 1. C THE PROBABILITY MASS FUNCTION IS: C p(X;THETA,BETA)= C Gamma(BETA*X+1)*THETA**X*(1-THETA)**(BETA*X-X)/ C X!*(BETA*X)*Gamma(BETA*X-X+1)*[-LOG(1-THETA)] C X = 1, 2, 3, ,... C 0 < THETA < 1; 1 <= BETA < 1/THETA C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE AT C WHICH THE PROBABILITY MASS C FUNCTION IS TO BE EVALUATED. C X SHOULD BE A NON-NEGATIVE INTEGER. C --THETA = THE FIRST SHAPE PARAMETER C --BETA = THE SECOND SHAPE PARAMETER C OUTPUT ARGUMENTS--PDF = THE SINGLE PRECISION PROBABILITY MASS C FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION PROBABILITY MASS FUNCTION VALUE C PDF FOR THE GENERALIZED LOGARITHMIC SERIES C DISTRIBUTION WITH SHAPE PARAMETERS THETA AND BETA C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--X SHOULD BE A POSITIVE INTEGER C --0 < THETA < 1; 1 < BETA < 1/THETA C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--FAMOYE (1997), "SAMPLING FROM A GENERALIZED C LOGARITHMIC SERIES DISTRIBUTION", COMPUTING, C 58(4), PP. 365-376. C --CONSUL AND FAMOYE (2006), "LAGRANGIAN PROBABILITY C DISTRIBUTIONS", BIRKHAUSER, CHAPTER 11. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2006/6 C ORIGINAL VERSION--JUNE 2006. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 DOUBLE PRECISION DTERM3 DOUBLE PRECISION DTERM4 DOUBLE PRECISION DX DOUBLE PRECISION DTHETA DOUBLE PRECISION DBETA DOUBLE PRECISION DPDF DOUBLE PRECISION DLNGAM C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IX=INT(X+0.5) IF(IX.LT.1)THEN WRITE(ICOUT,4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9000 ENDIF 4 FORMAT('***** ERROR--THE FIRST ARGUMENT TO GLSPDF IS LESS ', 1'THAN 1') C IF(THETA.LE.0.0 .OR. THETA.GE.1.0)THEN WRITE(ICOUT,15) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)THETA CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9000 ENDIF 15 FORMAT('***** ERROR--THE SECOND ARGUMENT TO GLSPDF IS NOT IN ', 1'THE INTERVAL (0,1)') C IF(BETA.LT.1.0 .OR. BETA.GE.1.0/THETA)THEN WRITE(ICOUT,25)1.0/THETA CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)THETA CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9000 ENDIF 25 FORMAT('***** ERROR--THE THIRD ARGUMENT TO GLSPDF IS NOT IN ', 1'THE INTERVAL (1,',G15.7,')') C 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7) C DX=DBLE(IX) DTHETA=DBLE(THETA) DBETA=DBLE(BETA) C DTERM1=DLNGAM(DBETA*DX+1.0D0) + DX*DLOG(DTHETA) + 1 (DBETA*DX-DX)*DLOG(1.0D0 - DTHETA) DTERM2=DLNGAM(DX+1.0D0) + DLOG(DBETA) + DLOG(DX) DTERM3=DLNGAM(DBETA*DX-DX+1.0D0) + DLOG(-DLOG(1.0D0-DTHETA)) DTERM4=DTERM1 - DTERM2 - DTERM3 DPDF=DEXP(DTERM4) PDF=REAL(DPDF) C 9000 CONTINUE RETURN END SUBROUTINE GLSPPF(P,THETA,BETA,PPF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT C FUNCTION VALUE FOR THE GENERALIZED LOGARITHMIC SERIES C DISTRIBUTION WITH SHAPE PARAMETERS THETA AND BETA. C THIS DISTRIBUTION IS DEFINED FOR ALL INTEGER X >= 1. C THE PROBABILITY MASS FUNCTION IS: C p(X;THETA,BETA)= C Gamma(BETA*X+1)*THETA**X*(1-THETA)**(BETA*X-X)/ C X!*(BETA*X)*Gamma(BETA*X-X+1)*[-LOG(1-THETA)] C X = 1, 2, 3, ,... C 0 < THETA < 1; 1 <= BETA < 1/THETA C C THE CUMULATIVE DISTRIBUTION FUNCTION IS COMPUTED C BY SUMMING THE PROBABILITY MASS FUNCTION. THE C PERCENT POINT FUNCTION IS COMPUTED BY COMPUTING THE C CUMULATIVE DISTRIBUTION UNTIL THE APPROPRIATE C PROBABILITY IS REACHED. C INPUT ARGUMENTS--P = THE SINGLE PRECISION VALUE AT C WHICH THE PERCENT POINT C FUNCTION IS TO BE EVALUATED. C 0 <= P < 1. C --THETA = THE FIRST SHAPE PARAMETER C --BETA = THE SECOND SHAPE PARAMETER C OUTPUT ARGUMENTS--PPF = THE SINGLE PRECISION PERCENT POINT C FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION PERCENT POINT FUNCTION C VALUE PPF FOR THE GENERALIZED LOGARITHMIC SERIES C DISTRIBUTION WITH SHAPE PARAMETERS THETA AND BETA C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--0 <= P < 1 C --0 < THETA < 1; 1 < BETA < 1/THETA C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--FAMOYE (1997), "SAMPLING FROM A GENERALIZED C LOGARITHMIC SERIES DISTRIBUTION", COMPUTING, C 58(4), PP. 365-376. C --CONSUL AND FAMOYE (2006), "LAGRANGIAN PROBABILITY C DISTRIBUTIONS", BIRKHAUSER, CHAPTER 11. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2006/6 C ORIGINAL VERSION--JUNE 2006. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 DOUBLE PRECISION DTERM3 DOUBLE PRECISION DSUM DOUBLE PRECISION DX DOUBLE PRECISION DTHETA DOUBLE PRECISION DBETA DOUBLE PRECISION DPDF DOUBLE PRECISION DPDFSV DOUBLE PRECISION DCDF DOUBLE PRECISION DPPF C C--------------------------------------------------------------------- C INCLUDE 'DPCOMC.INC' C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(P.LT.0.0 .OR. P.GE.1.0)THEN WRITE(ICOUT,4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)P CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9000 ENDIF 4 FORMAT('***** ERROR--THE FIRST ARGUMENT TO GLSPPF IS OUTSIDE ', 1'THE (0,1] INTERVAL') C IF(THETA.LE.0.0 .OR. THETA.GE.1.0)THEN WRITE(ICOUT,15) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)THETA CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9000 ENDIF 15 FORMAT('***** ERROR--THE SECOND ARGUMENT TO GLSPPF IS NOT IN ', 1'THE INTERVAL (0,1)') C IF(BETA.LT.1.0 .OR. BETA.GE.1.0/THETA)THEN WRITE(ICOUT,25)1.0/THETA CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)THETA CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9000 ENDIF 25 FORMAT('***** ERROR--THE THIRD ARGUMENT TO GLSPPF IS NOT IN ', 1'THE INTERVAL (1,',G15.7,')') C 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7) C DTHETA=DBLE(THETA) DBETA=DBLE(BETA) DP=DBLE(P) DCDF=DTHETA*(1.0D0 - DTHETA)**(DBETA - 1.0D0)/ 1 (-DLOG(1.0D0 - DTHETA)) IF(DCDF.GE.DP)THEN PPF=1.0 GOTO9000 ENDIF C DPDF=(DBETA-0.5D0)*DTHETA*(1.0D0-DTHETA)**(DBETA-1.0D0)*DCDF DCDF=DCDF + DPDF IF(DCDF.GE.DP)THEN PPF=2.0 GOTO9000 ENDIF DPDFSV=DPDF DTERM2=DLOG(DTHETA) + (DBETA - 1.0D0)*DLOG(1.0D0 - DTHETA) C I=2 100 CONTINUE I=I+1 IF(DBLE(I).GE.DBLE(I1MACH(9)))THEN WRITE(ICOUT,55) 55 FORMAT('***** ERROR--THE COMPUTED PERCENT POINT VALUE ', 1 'EXCEEDS THE LARGEST MACHINE INTEGER.') CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9000 ENDIF DX=DBLE(I) DTERM1=DLOG(DBETA - (DX-1.0D0)/DX) IF(DPDFSV.LE.0.0D0)THEN DPDF=0.0D0 GOTO1000 ELSE DTERM3=DLOG(DPDFSV) ENDIF DSUM=0.0D0 DO200J=1,I-2 DSUM=DSUM + DLOG(1.0D0 + DBETA/(DBETA*(DX-1.0D0)-DBLE(J))) 200 CONTINUE DPDF=DEXP(DTERM1 + DTERM2 + DTERM3 + DSUM) 1000 CONTINUE DCDF=DCDF + DPDF DPDFSV=DPDF IF(DCDF.GE.DP)THEN PPF=REAL(I) GOTO9000 ENDIF GOTO100 C 9000 CONTINUE RETURN END SUBROUTINE GLSRAN(N,THETA,BETA,ISEED,X) C C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N C FROM THE GENERALIZED LOGARITHMIC SERIES DISTRIBUTION C WITH SHAPE PARAMETERS THETA AND BETA. C THIS DISTRIBUTION IS DEFINED FOR ALL C NON-NEGATIVE INTEGER X >= 1. C p(X;THETA,BETA)= C Gamma(BETA*X+1)*THETA**X*(1-THETA)**(BETA*X-X)/ C X!*(BETA*X)*Gamma(BETA*X-X+1)*[-LOG(1-THETA)] C X = 1, 2, 3, ,... C 0 < THETA < 1; 1 < BETA < 1/THETA C INPUT ARGUMENTS--N = THE DESIRED INTEGER NUMBER C OF RANDOM NUMBERS TO BE C GENERATED. C --THETA = THE SINGLE PRECISION VALUE C OF THE FIRST SHAPE PARAMETER. C --BETA = THE SINGLE PRECISION VALUE C OF THE SECOND SHAPE PARAMETER. C OUTPUT ARGUMENTS--X = A SINGLE PRECISION VECTOR C (OF DIMENSION AT LEAST N) C INTO WHICH THE GENERATED C RANDOM SAMPLE WILL BE PLACED. C OUTPUT--A RANDOM SAMPLE OF SIZE N C FROM THE GENERALIZED LOGARITHMIC SERIES DISTRIBUTION C WITH SHAPE PARAMETERS THETA AND BETA. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C --0 < THETA < 1, 1 < BETA < 1/THETA C OTHER DATAPAC SUBROUTINES NEEDED--UNIRAN, GLSPPF C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--FAMOYE (1997), "SAMPLING FROM A GENERALIZED C LOGARITHMIC SERIES DISTRIBUTION", COMPUTING, C 58(4), PP. 365-376. C --CONSUL AND FAMOYE (2006), "LAGRANGIAN PROBABILITY C DISTRIBUTIONS", BIRKHAUSER, CHAPTER 11. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2006/6 C ORIGINAL VERSION--JUNE 2006. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C REAL THETA REAL BETA DIMENSION X(*) DIMENSION XTEMP(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.1415926535 8979323846 E0 / C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(N.LT.1)THEN WRITE(ICOUT,5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,6) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)N CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF 5 FORMAT('***** ERROR--THE REQUESTED NUMBER OF ', 1'GENERALIZED LOGARITHMIC SERIES') 6 FORMAT(' RANDOM NUMBERS IS NON-POSITIVE') IF(THETA.LE.0.0 .OR. THETA.GE.1.0)THEN WRITE(ICOUT,11) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)THETA CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF 11 FORMAT('***** ERROR--THE THETA PARAMETER FOR THE ', 1'GENERALIZED LOGARITHMIC SERIES') 12 FORMAT(' RANDOM NUMBERS IS OUTSIDE THE (0,1) INTERVAL') C IF(BETA.LE.1.0 .OR. BETA.GE.1.0/THETA)THEN WRITE(ICOUT,21) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,22) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)BETA CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF 21 FORMAT('***** ERROR--THE BETA PARAMETER FOR THE ', 1'GENERALIZED LOGARITHMIC SERIES') 22 FORMAT(' RANDOM NUMBERS IS OUTSIDE THE (0,',G15.7, 1 ') INTERVAL') C 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7) 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8) C C GENERATE N GENERALIZED LOGARITHMIC SERIES DISTRIBUTION C RANDOM NUMBERS. FOLLOWING RECOMMENDATION OF CONSUL AND C FAYMOE, USE INVERSION METHOD FOR THETA*BETA <= 0.45 AND C BRANCHING METHOD OTHERWISE. C C BRANCHING ALGORITHM DOESN'T SEEM TO RETURN REASONABLE C RESULTS (MAYBE USING A SLIGHTLY DIFFERENT DEFINITION C FOR NEGATIVE BINOMIAL?), SO USE REJECTION ALGORITHM C INSTEAD. C CCCCC IF(THETA*BETA.LE.0.45)THEN CALL UNIRAN(N,ISEED,X) DO100I=1,N ZTEMP=X(I) CALL GLSPPF(ZTEMP,THETA,BETA,PPF) X(I)=PPF 100 CONTINUE CCCCC ELSE C C BRANCHING ALGORITHM C CCCCC NTEMP=1 CCCCC DO200I=1,N CCCCC CALL DLGRAN(NTEMP,THETA,ISEED,XTEMP) CCCCC Y=XTEMP(1) CCCCC XX=Y CC210 CONTINUE CCCCC AK=(BETA-1.0)*Y CCCCC CALL NBRAN(NTEMP,1.0-THETA,AK,ISEED,XTEMP) CCCCC Z=XTEMP(1) CCCCC XX=XX+Z CCCCC Y=Z CCCCC IF(Y.GT.0)GOTO210 CCCCC X(I)=XX CC200 CONTINUE C C REJECTION ALGORITHM C CCCCC NTEMP=2 CCCCC C=(1.0+SQRT(2.0))/((-LOG(1.0-THETA))*SQRT(PI*BETA*(BETA-1.0))) CCCCC DO300I=1,N CC310 CONTINUE CCCCC CALL UNIRAN(NTEMP,ISEED,XTEMP) CCCCC U=XTEMP(1) CCCCC V=XTEMP(2) CCCCC IXX=INT(1.0/V**2) CCCCC XX=IXX CCCCC CALL GLSPDF(XX,THETA,BETA,PDF) CCCCC TERM1=U*C*(1.0/SQRT(XX) - 1.0/SQRT(XX+1.0)) CCCCC IF(TERM1.LE.PDF)THEN CCCCC X(I)=XX CCCCC ELSE CCCCC GOTO310 CCCCC ENDIF CC300 CONTINUE CCCCC ENDIF C 9999 CONTINUE C RETURN END SUBROUTINE GMCCDF(X,ALPHA,A,CDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION C FUNCTION VALUE FOR THE GENERALIZED MCLEISH C DISTRIBUTION WITH SHAPE PARAMETERS ALPHA AND A. C THE CUMULATIVE DISTRIBUTION IS COMPUTED BY C NUMERICALLY INTEGRATING THE PDF FUNCTION. C INPUT ARGUMENTS--X = THE DOUBLE PRECISION VALUE AT C WHICH THE CUMULATIVE DISTRIBUTION C FUNCTION IS TO BE EVALUATED. C --ALPHA = THE FIRST SHAPE PARAMETER C --A = THE SECOND SHAPE PARAMETER C OUTPUT ARGUMENTS--CDF = THE DOUBLE PRECISION CUMULATIVE C DISTRIBUTION FUNCTION VALUE. C OUTPUT--THE DOUBLE PRECISION CUMULATIVE DISTRIBUTION C FUNCTION VALUE FOR THE GENERALIZED MCLEISH C DISTRIBUTION WITH SHAPE PARAMETERS ALPHA AND A. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--NONE. C OTHER DATAPAC SUBROUTINES NEEDED--DQAGI. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, (1994), "CONTINUOUS C UNIVARIATE DISTRIBUTIONS--VOLUME 1", SECOND EDITION, C WILEY, PP. 50-53. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2004.9 C ORIGINAL VERSION--SEPTEMBER 2004. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C INTEGER LIMIT INTEGER LENW PARAMETER(LIMIT=100) PARAMETER(LENW=4*LIMIT) INTEGER INF INTEGER NEVAL INTEGER IER INTEGER LAST INTEGER IWORK(LIMIT) DOUBLE PRECISION ALPHA DOUBLE PRECISION A DOUBLE PRECISION EPSABS DOUBLE PRECISION EPSREL DOUBLE PRECISION RESULT DOUBLE PRECISION DCDF DOUBLE PRECISION CDF DOUBLE PRECISION X DOUBLE PRECISION DX DOUBLE PRECISION DB DOUBLE PRECISION DC DOUBLE PRECISION DM DOUBLE PRECISION ABSERR DOUBLE PRECISION WORK(LENW) C DOUBLE PRECISION GMCFUN EXTERNAL GMCFUN C DOUBLE PRECISION DALPHA DOUBLE PRECISION DA COMMON/GMCCOM/DALPHA,DA C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,AKMBPC,AKMCPW,AKMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----DATA STATEMENTS------------------------------------------------- C C-----START POINT----------------------------------------------------- C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C IF(ALPHA.LE.0.0D0)THEN WRITE(ICOUT,5) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,48)ALPHA CALL DPWRST('XXX','WRIT') CDF=0.0D0 GOTO9000 ENDIF 5 FORMAT('***** ERROR: VALUE OF SHAPE PARAMETER (ALPHA)', 1 ' IN GMCCDF ROUTINE IS NON-POSITIVE.') IF(ABS(A).GE.1.0D0)THEN WRITE(ICOUT,8) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,48)A CALL DPWRST('XXX','WRIT') CDF=0.0D0 GOTO9000 ENDIF 8 FORMAT('***** ERROR: ABSOLUTE VALUE OF SECOND SHAPE PARAMETER ', 1 '(A) IN GMCCDF ROUTINE IS >= 1.') 48 FORMAT(' VALUE OF ARGUMENT IS: ',G15.7) C C ************************************ C ** STEP 1-- ** C ** COMPUTE THE DENSITY FUNCTION ** C ************************************ C INF=-1 EPSABS=0.0D0 EPSREL=1.0D-7 IER=0 DCDF=0.0D0 IFLAG=0 IF(DX.LT.0.0D0)THEN IFLAG=1 INF=1 ENDIF C DX=X DA=A DALPHA=ALPHA C CALL DQAGI(GMCFUN,DX,INF,EPSABS,EPSREL,DCDF,ABSERR,NEVAL, 1 IER,LIMIT,LENW,LAST,IWORK,WORK) C IF(IFLAG.EQ.1)THEN CDF=1.0D0 - DCDF ELSE CDF=DCDF ENDIF C IF(IER.EQ.1)THEN WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,111) 111 FORMAT('***** ERROR FROM GMCCDF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,113) 113 FORMAT(' MAXIMUM NUMBER OF SUBDIVISIONS EXCEEDED.') CALL DPWRST('XXX','BUG ') ELSEIF(IER.EQ.2)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,121) 121 FORMAT('***** ERROR FROM GMCCDF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,123) 123 FORMAT(' ROUNDOFF ERROR PREVENTS REQUESTED TOLERANCE ', 1 'FROM BEING ACHIEVED.') CALL DPWRST('XXX','BUG ') ELSEIF(IER.EQ.3)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,131) 131 FORMAT('***** ERROR FROM GMCCDF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,133) 133 FORMAT(' BAD INTEGRAND BEHAVIOUR DETECTED.') CALL DPWRST('XXX','BUG ') ELSEIF(IER.EQ.4)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,141) 141 FORMAT('***** ERROR FROM GMCCDF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,143) 143 FORMAT(' INTEGRATION DID NOT CONVERGE.') CALL DPWRST('XXX','BUG ') ELSEIF(IER.EQ.5)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,151) 151 FORMAT('***** ERROR FROM GMCCDF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,153) 153 FORMAT(' THE INTEGRATION IS PROBABLY DIVERGENT.') CALL DPWRST('XXX','BUG ') ELSEIF(IER.EQ.6)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,161) 161 FORMAT('***** ERROR FROM GMCCDF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,163) 163 FORMAT(' INVALID INPUT TO THE INTEGRATION ROUTINE.') CALL DPWRST('XXX','BUG ') ENDIF C 9000 CONTINUE RETURN END DOUBLE PRECISION FUNCTION GMCFUN(DX) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY C FUNCTION VALUE FOR THE GENERALIZED MCLEISH C DISTRIBUTION WITH SHAPE PARAMETERS ALPHA AND A. C THIS DISTRIBUTION IS DEFINED FOR ALL REAL X C AND HAS THE PROBABILITY DENSITY FUNCTION C C f(X;ALPHA,A) = [1/(SQRT(PI)*GAMMA(ALPHA))]* C (ABS(X)/2)**(ALPHA-1/2)*K(X,ALPHA-1/2) C *(1-A**2)**ALPHA*EXP(A*X) C WHERE C K(X,N) IS THE MODIFIED BESSEL FUNCTION OF THE C SECOND KIND C GAMMA IS THE GAMMA FUNCTION C C THE GMCPDF ROUTINE IS CALLED TO COMPUTE THE C PROBABILITY DENSITY. DEFINE AS FUNCTION TO BE USED FOR C INTEGRATION CODE CALLED BY GMCCDF. THIS ROUTINE USES C DOUBLE PRECISION ARITHMETIC. C INPUT ARGUMENTS--DX = THE DOUBLE PRECISION VALUE AT C WHICH THE PROBABILITY DENSITY C FUNCTION IS TO BE EVALUATED. C OUTPUT ARGUMENTS--GMCFUN = THE DOUBLE PRECISION PROBABILITY C DENSITY FUNCTION VALUE. C OUTPUT--THE DOUBLE PRECISION PROBABILITY DENSITY C FUNCTION VALUE PDF FOR THE GENERALIZED MCLEISH C DISTRIBUTION WITH SHAPE PARAMETER ALPHA. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--NONE. C OTHER DATAPAC SUBROUTINES NEEDED--GMCPDF. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, (1994), "CONTINUOUS C UNIVARIATE DISTRIBUTIONS--VOLUME 1", SECOND EDITION, C WILEY, PP. 50-53. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2004.9 C ORIGINAL VERSION--SEPTEMBER 2004. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DTERM C DOUBLE PRECISION DX DOUBLE PRECISION DALPHA DOUBLE PRECISION DA COMMON/GMCCOM/DALPHA,DA C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----DATA STATEMENTS------------------------------------------------- C C-----START POINT----------------------------------------------------- C C ************************************ C ** STEP 1-- ** C ** COMPUTE THE DENSITY FUNCTION ** C ************************************ C CALL GMCPDF(DX,DALPHA,DA,DTERM) GMCFUN=DTERM C 9000 CONTINUE RETURN END DOUBLE PRECISION FUNCTION GMCFU2(DX) C C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION C FUNCTION VALUE FOR THE GENERALIZED MCLEISH C DISTRIBUTION WITH SHAPE PARAMETERS ALPHA AND A. C THIS DISTRIBUTION IS DEFINED FOR ALL REAL X C AND HAS THE PROBABILITY DENSITY FUNCTION C C f(X;ALPHA,A) = [1/(SQRT(PI)*GAMMA(ALPHA))]* C (ABS(X)/2)**(ALPHA-1/2)*K(X,ALPHA-1/2) C *(1-A**2)**ALPHA*EXP(A*X) C WHERE C K(X,N) IS THE MODIFIED BESSEL FUNCTION OF THE C SECOND KIND C GAMMA IS THE GAMMA FUNCTION C C THE GMCCDF ROUTINE IS CALLED TO COMPUTE THE C PROBABILITY DENSITY. DEFINE AS FUNCTION TO BE USED FOR C INTEGRATION CODE CALLED BY GMCCDF. THIS ROUTINE USES C DOUBLE PRECISION ARITHMETIC. C INPUT ARGUMENTS--DX = THE DOUBLE PRECISION VALUE AT C WHICH THE PROBABILITY DENSITY C FUNCTION IS TO BE EVALUATED. C OUTPUT ARGUMENTS--GMCFU2 = THE DOUBLE PRECISION CUMULATIVE C DISTRIBUTION FUNCTION VALUE. C OUTPUT--THE DOUBLE PRECISION CUMULATIVE DISTRIBUTION C FUNCTION VALUE CDF FOR THE GENERALIZED MCLEISH C DISTRIBUTION WITH SHAPE PARAMETERS ALPHA AND A. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--NONE. C OTHER DATAPAC SUBROUTINES NEEDED--GMCCDF. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, (1994), "CONTINUOUS C UNIVARIATE DISTRIBUTIONS--VOLUME 1", SECOND EDITION, C WILEY, PP. 50-53. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2004.9 C ORIGINAL VERSION--SEPTEMBER 2004. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DCDF DOUBLE PRECISION DX C DOUBLE PRECISION DP COMMON/GM2COM/DP C DOUBLE PRECISION DALPHA DOUBLE PRECISION DA COMMON/GMCCOM/DALPHA,DA C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----DATA STATEMENTS------------------------------------------------- C C-----START POINT----------------------------------------------------- C C ************************************ C ** STEP 1-- ** C ** COMPUTE THE DENSITY FUNCTION ** C ************************************ C CALL GMCCDF(DX,DALPHA,DA,DCDF) GMCFU2=DP - DCDF C 9000 CONTINUE RETURN END SUBROUTINE GMCPDF(X,ALPHA,A,PDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY C FUNCTION VALUE FOR THE GENERALIZED MCLEISH BESSEL C K-FUNCTION DISTRIBUTION. IT HAS SHAPE PARAMETERS C ALPHA. THIS DISTRIBUTION IS ASYMMETRIC AND IS DEFINED C FOR ALL REAL X AND HAS THE PROBABILITY DENSITY FUNCTION C C f(X;ALPHA,A) = [1/(SQRT(PI)*GAMMA(ALPHA))]* C (ABS(X)/2)**(ALPHA-1/2)*K(X,ALPHA-1/2) C *(1-A**2)**ALPHA*EXP(A*X) C WHERE C K(X,N) IS THE MODIFIED BESSEL FUNCTION OF THE C SECOND KIND C GAMMA IS THE GAMMA FUNCTION C C NOTE--ARGUMENTS TO THIS ROUTINE ARE IN DOUBLE PRECISION. C INPUT ARGUMENTS--X = THE DOUBLE PRECISION VALUE AT C WHICH THE PROBABILITY DENSITY C FUNCTION IS TO BE EVALUATED. C X SHOULD BE POSITIVE C --ALPHA = THE FIRST SHAPE PARAMETER C --A = THE SECOND SHAPE PARAMETER C OUTPUT ARGUMENTS--PDF = THE DOUBLE PRECISION PROBABILITY C DENSITY FUNCTION VALUE. C OUTPUT--THE DOUBLE PRECISION PROBABILITY DENSITY FUNCTION C VALUE PDF FOR THE GENERALIZED MCLEISH DISTRIBUTION C WITH SHAPE PARAMETERS ALPHA AND NU. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--NONE. C OTHER DATAPAC SUBROUTINES NEEDED--DBESI. C FORTRAN LIBRARY SUBROUTINES NEEDED--DEXP, DLOG, DLNGAM. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--JOHNSON, KOTZ, AND BALAKRISNAN, "CONTINUOUS C UNIVARIATE DISTRIBUTIONS--VOLUME I", SECOND EDITION, C WILEY, 1994, PP. 50-53. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2004.9 C ORIGINAL VERSION--SEPTEMBER 2004. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION X DOUBLE PRECISION DX DOUBLE PRECISION ALPHA DOUBLE PRECISION A DOUBLE PRECISION PDF DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 DOUBLE PRECISION DTERM3 DOUBLE PRECISION DTERM4 DOUBLE PRECISION DTERM5 DOUBLE PRECISION DTERM6 DOUBLE PRECISION DORD DOUBLE PRECISION DPI DOUBLE PRECISION DEPS DOUBLE PRECISION DLNGAM EXTERNAL DLNGAM C DOUBLE PRECISION DTEMP1(10) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----DATA STATEMENTS------------------------------------------------- C DATA DPI / 3.14159265358979D+00/ C C-----START POINT----------------------------------------------------- C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C IF(ALPHA.LE.0.0D0)THEN WRITE(ICOUT,5) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,48)ALPHA CALL DPWRST('XXX','WRIT') PDF=0.0D0 GOTO9000 ENDIF 5 FORMAT('***** ERROR: VALUE OF FIRST SHAPE PARAMETER (ALPHA)', 1 ' IN GMCPDF ROUTINE IS NON-POSITIVE.') IF(ABS(A).GE.1.0D0)THEN WRITE(ICOUT,8) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,48)A CALL DPWRST('XXX','WRIT') PDF=0.0D0 GOTO9000 ENDIF 8 FORMAT('***** ERROR: ABSOLUTE VALUE OF SECOND SHAPE PARAMETER ', 1 '(A) IN GMCPDF ROUTINE IS >= 1.') 48 FORMAT(' VALUE OF ARGUMENT IS: ',G15.7) C C ***************************************** C ** STEP 2-- ** C ** COMPUTE THE DENSITY FUNCTION. FOR ** C ** BETTER NUMERICAL STABILITY, ** C ** COMPUTE LOGARIGHMS. ** C ***************************************** C C C COMPUTE BESSEL FUNCTION FIRST. IF THIS IS 0, SET PDF TO C 0 AND RETURN. C DEPS=1.0D-12 IF(ALPHA.GT.25.0)DEPS=1.0D-10 DX=X DX=DABS(DX) IF(DX.EQ.0.0D0)DX=DEPS DORD=DABS(ALPHA-0.5D0) IARG1=1 ISCALE=1 CALL DBESK(DX,DORD,ISCALE,IARG1,DTEMP1,NZERO) DTERM3=DTEMP1(IARG1) IF(DTERM3.LE.0.0D0)THEN PDF=0.0D0 GOTO9000 ENDIF DTERM3=DLOG(DTERM3) C DTERM1=0.5D0*DLOG(DPI) + DLNGAM(ALPHA) DTERM2=(ALPHA-0.5D0)*DLOG(DX/2.0D0) DTERM4=ALPHA*DLOG(1.0D0 - A**2) DTERM5=A*X DTERM6 = -DTERM1+DTERM2+DTERM3+DTERM4+DTERM5 PDF=DEXP(DTERM6) C 9000 CONTINUE RETURN END SUBROUTINE GMCPPF(P,ALPHA,A,PPF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT FUNCTION C VALUE FOR THE GENERALIZED MCLEISH DISTRIBUTION. IT HAS C SHAPE PARAMETERS ALPHA AND A. THIS DISTRIBUTION IS C DEFINED FOR ALL REAL X AND HAS THE PROBABILITY DENSITY C FUNCTION C C f(X;ALPHA,A) = [1/(SQRT(PI)*GAMMA(ALPHA))]* C (ABS(X)/2)**(ALPHA-1/2)*K(X,ALPHA-1/2) C *(1-A**2)**ALPHA*EXP(A*X) C WHERE C K(X,N) IS THE MODIFIED BESSEL FUNCTION OF THE C SECOND KIND C GAMMA IS THE GAMMA FUNCTION C C THE PERCENT POINT FUNCTION IS COMPUTED BY NUMERICALLY C INVERTING THE GENERALIZED MCLEISH CUMULATIVE C DISTRIBUTION FUNCTION (WHICH IN TURN IS COMPUTED BY C NUMERICAL INTEGRATION OF THE PROBABILITYT DENSITY). C C INPUT ARGUMENTS--P = THE DOUBLE PRECISION VALUE AT C WHICH THE PERCENT POINT C FUNCTION IS TO BE EVALUATED. C 0 < P < 1 C --ALPHA = THE FIRST SHAPE PARAMETER C --A = THE SECOND SHAPE PARAMETER C OUTPUT ARGUMENTS--PPF = THE DOUBLE PRECISION PERCENT POINT C FUNCTION VALUE. C OUTPUT--THE DOUBLE PRECISION PERCENT POINT FUNCTION C VALUE PPF FOR THE GENERALIZED MCLEISH C DISTRIBUTION WITH SHAPE PARAMETERS ALPHA AND A. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--NONE. C OTHER DATAPAC SUBROUTINES NEEDED--DFZERO. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, (1994), "CONTINUOUS C UNIVARIATE DISTRIBUTIONS--VOLUME 1", SECOND EDITION, C WILEY, PP. 50-53. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2004.9 C ORIGINAL VERSION--SEPTEMBER 2004. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION P DOUBLE PRECISION PTEMPL DOUBLE PRECISION PTEMPU DOUBLE PRECISION ALPHA DOUBLE PRECISION A DOUBLE PRECISION PPF DOUBLE PRECISION DINC DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 DOUBLE PRECISION DTERM3 C DOUBLE PRECISION DTEMP1(10) C DOUBLE PRECISION XUP DOUBLE PRECISION XUP2 DOUBLE PRECISION XLOW DOUBLE PRECISION RE DOUBLE PRECISION AE C DOUBLE PRECISION GMCFU2 EXTERNAL GMCFU2 C DOUBLE PRECISION DP COMMON/GM2COM/DP C DOUBLE PRECISION DALPHA DOUBLE PRECISION DA COMMON/GMCCOM/DALPHA,DA C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C ***************************************** C ** STEP 1-- ** C ** CHECK FOR VALID PARAMETERS ** C ***************************************** C IF(P.LE.0.0D0 .OR. P.GE.1.0D0)THEN WRITE(ICOUT,4) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,14) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,48)P CALL DPWRST('XXX','WRIT') PPF=0.0D0 GOTO9000 ENDIF 4 FORMAT('***** ERROR: VALUE OF INPUT ARGUMENT (P) IN ', 1 'GMCPPF ROUTINE') 14 FORMAT(' IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL.') IF(ALPHA.LE.0.0D0)THEN WRITE(ICOUT,5) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,48)ALPHA CALL DPWRST('XXX','WRIT') PPF=0.0D0 GOTO9000 ENDIF 5 FORMAT('***** ERROR: VALUE OF FIRST SHAPE PARAMETER (ALPHA)', 1 ' IN GMCPPF ROUTINE IS NON-POSITIVE.') IF(ABS(A).GE.1.0D0)THEN WRITE(ICOUT,8) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,48)A CALL DPWRST('XXX','WRIT') PPF=0.0D0 GOTO9000 ENDIF 8 FORMAT('***** ERROR: ABSOLUTE VALUE OF SECOND SHAPE PARAMETER ', 1 '(A) IN GMCPPF ROUTINE IS >= 1.') 48 FORMAT(' VALUE OF ARGUMENT IS: ',G15.7) C C ***************************************** C ** STEP 2-- ** C ** COMPUTE THE PERCENT POINT FUNCTION.** C ***************************************** C C STEP 1: FIND BRACKETING INTERVAL. START WITH -10 AND +10, C INCREMENT BY 10. C XLOW=-10.0D0 XUP2=10.0D0 CALL GMCCDF(XLOW,ALPHA,A,PTEMPL) CALL GMCCDF(XUP2,ALPHA,A,PTEMPU) DINC=10.0D0 IF(ALPHA.GT.20.0D0)THEN DINC=ALPHA ENDIF C MAXIT=1000 NIT=0 C 200 CONTINUE IF(NIT.GT.MAXIT)THEN PPF=0.0D0 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,131) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,133) CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF CALL GMCCDF(XLOW,ALPHA,A,PTEMPL) CALL GMCCDF(XUP2,ALPHA,A,PTEMPU) IF(PTEMPL.LE.P .AND. P.LE.PTEMPU)THEN XUP=XUP2 GOTO300 ELSEIF(P.GT.PTEMPU)THEN XLOW=XUP2 XUP2=XUP2 + DINC NIT=NIT+1 GOTO200 ELSEIF(P.LT.PTEMPL)THEN XUP2=XLOW XLOW=XLOW - DINC NIT=NIT+1 GOTO200 ENDIF C 300 CONTINUE AE=1.D-7 RE=1.D-7 DALPHA=ALPHA DP=P CALL DFZERO(GMCFU2,XLOW,XUP,XUP,RE,AE,IFLAG) C PPF=XLOW C IF(IFLAG.EQ.2)THEN C C NOTE: SUPPRESS THIS MESSAGE FOR NOW. CCCCC WRITE(ICOUT,999) 999 FORMAT(1X) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,111) CC111 FORMAT('***** WARNING FROM GMCPPF--') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,113) CC113 FORMAT(' PPF VALUE MAY NOT BE COMPUTED TO DESIRED ', CCCCC1 'TOLERANCE.') CCCCC CALL DPWRST('XXX','BUG ') ELSEIF(IFLAG.EQ.3)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,121) 121 FORMAT('***** WARNING FROM GMCPPF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,123) 123 FORMAT(' PPF VALUE MAY BE NEAR A SINGULAR POINT.') CALL DPWRST('XXX','BUG ') ELSEIF(IFLAG.EQ.4)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,131) 131 FORMAT('***** ERROR FROM GMCPPF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,133) 133 FORMAT(' APPROPRIATE BRACKETING INTERVAL NOT FOUND.') CALL DPWRST('XXX','BUG ') ELSEIF(IFLAG.EQ.5)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,141) 141 FORMAT('***** WARNING FROM GMCPPF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,143) 143 FORMAT(' MAXIMUM ITERATIONS EXCEEDED.') CALL DPWRST('XXX','BUG ') ENDIF C C 9000 CONTINUE RETURN END SUBROUTINE GMCRAN(N,ALPHA,A,ISEED,X) C C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N C FROM THE GENERALIZED MCLEISH DISTRIBUTION WITH SHAPE C PARAMETERS ALPHA AND A. THIS DISTRIBUTION IS DEFINED C FOR ALL X AND HAS THE PROBABILITY DENSITY FUNCTION C C f(X;ALPHA,A) = [1/(SQRT(PI)*GAMMA(ALPHA))]* C (ABS(X)/2)**(ALPHA-1/2)*K(X,ALPHA-1/2) C *(1-A**2)**ALPHA*EXP(A*X) C WHERE C K(X,N) IS THE MODIFIED BESSEL FUNCTION OF THE C SECOND KIND C GAMMA IS THE GAMMA FUNCTION C C INPUT ARGUMENTS--N = THE DESIRED INTEGER NUMBER C OF RANDOM NUMBERS TO BE C GENERATED. C --ALPHA = THE FIRST SHAPE PARAMETER FOR THE C GENERALIZED MCLEISH DISTRIBUTION C --A = THE SECOND SHAPE PARAMETER FOR THE C GENERALIZED MCLEISH DISTRIBUTION C OUTPUT ARGUMENTS--X = A SINGLE PRECISION VECTOR C (OF DIMENSION AT LEAST N) C INTO WHICH THE GENERATED C RANDOM SAMPLE WILL BE PLACED. C OUTPUT--A RANDOM SAMPLE OF SIZE N FROM THE GENERALIZED MCLEISH C DISTRIBUTION WITH SHAPE PARAMETERS ALPHA AND A. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C OTHER DATAPAC SUBROUTINES NEEDED--UNIRAN. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--JOHNSON, KOTZ, AND BALAKRISNAN, "CONTINUOUS C UNIVARIATE DISTRIBUTIONS--VOLUME I", SECOND EDITION, C WILEY, 1994, PP. 50-53. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATION INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2004.9 C ORIGINAL VERSION--SEPTEMBER 2004. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DPPF DIMENSION X(*) CCCCC DIMENSION Y(2) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----DATA STATEMENTS------------------------------------------------- C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(N.LT.1)THEN WRITE(ICOUT,5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,6) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)N CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF C 5 FORMAT('***** ERROR--FOR THE GENERALIZED MCLEISH DISTRIBUTION, ', 1 'THE REQUESTED') 6 FORMAT(' NUMBER OF RANDOM NUMBERS WAS NON-POSITIVE.') 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,'.') IF(ALPHA.LE.0.0D0)THEN WRITE(ICOUT,7) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,17) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,48)ALPHA CALL DPWRST('XXX','WRIT') GOTO9000 ENDIF 7 FORMAT('***** ERROR: VALUE OF FIRST SHAPE PARAMETER (ALPHA)', 1 ' FOR GENERALIZED MCLEISH') 17 FORMAT(' RANDOM NUMBERS IS NON-POSITIVE.') IF(ABS(A).GE.1.0D0)THEN WRITE(ICOUT,8) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,18) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,48)A CALL DPWRST('XXX','WRIT') GOTO9000 ENDIF 8 FORMAT('***** ERROR: VALUE OF SECOND SHAPE PARAMETER (A)', 1 ' FOR GENERALIZED MCLEISH') 18 FORMAT(' RANDOM NUMBERS HAS ABSOLUTE VALUE >= 1') 48 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7,'.') C C MCLEISH IS DISTRIBUTION OF SQRT(G)*Z WHERE G IS A GAMMA C DISTRIBUTION WITH SHAPE PARAMETER ALPHA AND SCALE PARAMETER 2. C Z IS A STANDARD NORMAL DISTRIBUTION. C C FOR THE GENERALIZED MCLEISH, ... C CALL UNIRAN(N,ISEED,X) NTEMP=1 DO100I=1,N CCCCC CALL GAMRAN(NTEMP,ALPHA,ISEED,Y) CCCCC G1=SQRT(2.0*Y(1)) CCCCC CALL NORRAN(NTEMP,ISEED,Y) CCCCC G2=Y(1) CCCCC APPF=G1*G2 CCCCC X(I)=APPF ATEMP=X(I) CALL GMCPPF(DBLE(ATEMP),DBLE(ALPHA),DBLE(A),DPPF) X(I)=REAL(DPPF) 100 CONTINUE C 9000 CONTINUE RETURN END SUBROUTINE GNBCDF(X,THETA,BETA,M,CDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION C FUNCTION VALUE FOR THE GENERALIZED NEGATIVE BINOMIAL C DISTRIBUTION WITH SHAPE PARAMETERS THETA, BETA, AND C M. THIS DISTRIBUTION IS DEFINED FOR ALL INTEGER C X >= 1. C C THE PROBABILITY MASS FUNCTION IS: C p(X;THETA,BETA,M)= C (M/(M+BETA*X)* C (M+BETA*X X)*THETA**X*(1-THETA)**(M+BETA*X-X) C X = 0, 1, 2, 3, ,... C 0 < THETA < 1; BETA = 0 OR 1 <= BETA <= 1/THETA; C M > 0 (M A POSITIVE INTEGER IF BETA = 0) C C THE CUMULATIVE DISTRIBUTION FUNCTION IS COMPUTED C FROM THE FOLLOWING RECURRENCE RELATION: C C P(X+1) = (M+(BETA-1)*X+BETA)/(X+1)* C THETA*(1-THETA)**(BETA-1)* C PROD[J=1 TO X-1][1 + BETA/(M+BETA*X-J)]*P(X) C C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE AT C WHICH THE CUMULATIVE DISTRIBUTION C FUNCTION IS TO BE EVALUATED. C X SHOULD BE A NON-NEGATIVE INTEGER. C --THETA = THE FIRST SHAPE PARAMETER C --BETA = THE SECOND SHAPE PARAMETER C --M = THE THIRD SHAPE PARAMETER C OUTPUT ARGUMENTS--CDF = THE SINGLE PRECISION CUMULATIVE C DISTRIBUTION FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION FUNCTION C VALUE CDF FOR THE GENERALIZED NEGATIVE BINOMIAL C DISTRIBUTION WITH SHAPE PARAMETERS THETA AND BETA C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--X SHOULD BE A NON-NEGATIVE INTEGER C --0 < THETA < 1; 1 <= BETA <= 1/THETA C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--CONSUL AND FAMOYE (2006), "LAGRANGIAN PROBABILITY C DISTRIBUTIONS", BIRKHAUSER, CHAPTER 10. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2006/7 C ORIGINAL VERSION--JULY 2006. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C REAL M C DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 DOUBLE PRECISION DTERM3 DOUBLE PRECISION DSUM DOUBLE PRECISION DX DOUBLE PRECISION DTHETA DOUBLE PRECISION DBETA DOUBLE PRECISION DM DOUBLE PRECISION DPDF DOUBLE PRECISION DPDFSV DOUBLE PRECISION DCDF C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IX=INT(X+0.5) IF(IX.LT.0)THEN WRITE(ICOUT,4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9000 ENDIF 4 FORMAT('***** ERROR--THE FIRST ARGUMENT TO GNBCDF IS LESS ', 1'THAN 0') C IF(THETA.LE.0.0 .OR. THETA.GE.1.0)THEN WRITE(ICOUT,15) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)THETA CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9000 ENDIF 15 FORMAT('***** ERROR--THE SECOND ARGUMENT TO GNBCDF IS NOT IN ', 1'THE INTERVAL (0,1)') C IF(BETA.LE.1.0 .OR. BETA.GE.1.0/THETA .AND. BETA.NE.0.0)THEN WRITE(ICOUT,25)1.0/THETA CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)THETA CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9000 ENDIF 25 FORMAT('***** ERROR--THE THIRD ARGUMENT TO GNBCDF IS NOT IN ', 1'THE INTERVAL (1,',G15.7,')') C IF(M.LE.0.0)THEN WRITE(ICOUT,35) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)M CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9000 ENDIF 35 FORMAT('***** ERROR--THE FOURTH ARGUMENT TO GNBCDF IS ', 1'NON-POSITIVE') IF(BETA.EQ.0.0)THEN IM=INT(M+0.5) IF(IM.EQ.0)IM=1 M=REAL(IM) ENDIF C 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7) C DTHETA=DBLE(THETA) DBETA=DBLE(BETA) DM=DBLE(M) C C USE THE RECURRENCE RELATION (PAGE 199 OF CONSUL AND FAMOYE): C DCDF=(1.0D0 - DTHETA)**DM IF(IX.EQ.0)GOTO1000 C DPDF=DM*DTHETA*(1.0D0 - DTHETA)**(DM+DBETA-1.0D0) DCDF=DCDF + DPDF IF(IX.EQ.1)GOTO1000 C DPDFSV=DPDF DTERM2=DLOG(DTHETA) + (DBETA - 1.0D0)*DLOG(1.0D0 - DTHETA) C DO100I=2,IX DX=DBLE(I) DTERM1=DLOG(DM + (DBETA-1.0D0)*(DX-1.0D0) + DBETA) - 1 DLOG(DX) IF(DPDFSV.LE.0.0D0)THEN GOTO1000 ELSE DTERM3=DLOG(DPDFSV) ENDIF IF(I-2.GE.1)THEN DSUM=0.0D0 DO200J=1,I-2 DSUM=DSUM + DLOG(1.0D0 + DBETA/ 1 (DM + DBETA*(DX-1.0D0)-DBLE(J))) 200 CONTINUE ELSE DSUM=0.0D0 ENDIF DPDF=DEXP(DTERM1 + DTERM2 + DTERM3 + DSUM) DCDF=DCDF + DPDF DPDFSV=DPDF 100 CONTINUE C 1000 CONTINUE CDF=REAL(DCDF) C 9000 CONTINUE RETURN END DOUBLE PRECISION FUNCTION GNBFUN(DTHETA) C C PURPOSE--THIS ROUTINE COMPUTES THE FUNCTION FOR FINDING C THE ESTIMATE OF THETA FOR THE C GENERALIZED NEGATIVE BINOMIAL METHOD OF MOMENT C EQUATIONS. C C THETAHAT = 1 - 0.5*A + (A**2/4 - 1)**(0.5) C A = -2 + (XBAR*S3 - 3*S2**2)**2/(XBAR*S2**3) C C CALLED BY DFZERO ROUTINE FOR FINDING THE ROOT OF C A NONLINEAR EQUATIONS. C EXAMPLE--GENERALIZED NEGATIVE BINOMIAL MAXIMUM LIKELIHOOD Y C REFERENCES--CONSUL AND FAMOYE (2006), "LAGRANGIAN PROBABILITY C DISTRIBUTIONS", BIRKHAUSER, CHAPTER 10. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBUG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2006/7 C ORIGINAL VERSION--JULY 2006. C C--------------------------------------------------------------------- C DOUBLE PRECISION DTHETA DOUBLE PRECISION DA C DOUBLE PRECISION XBAR DOUBLE PRECISION S2 DOUBLE PRECISION S3 DOUBLE PRECISION F0FREQ DOUBLE PRECISION F1FREQ DOUBLE PRECISION F10FRE DOUBLE PRECISION DC1 COMMON/GNBCOM/XBAR,S2,S3,F0FREQ,F1FREQ,F10FRE,DC1, 1 MAXROW,NTOT2 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 COMPUTE SOME SUMS C DA=-2.0D0 + (XBAR*S3 - 3.0D0*S2**2)**2/(XBAR*S2**3) GNBFUN=1.0D0 - 0.5D0*DA + DSQRT(DA**2/4.0D0 - 1.0D0) C RETURN END SUBROUTINE GNBFU2(N,XPAR,FVEC,IFLAG,Y,K) C C PURPOSE--THIS ROUTINE COMPUTES THE FUNCTIONS FOR THE C GENERALIZED NEGATIVE BINOMIAL MAXIMUM LIKELIHOOD C EQUATIONS. C C THE MAXIMUM LIKELIHOOD ESTIMATES ARE THE SOLUTIONS C TO THE EQUATIONS: C C M*(XBAR - THETA*(M + BETA*XBAR))/ C (THETA*(1 - THETA)) C C N*XBAR*LOG(1-THETA) + C SUM[X=2 to k][SUM[i=1 to x-1] C [X*N(x)/(M+BETA*X-i]] = 0 C C (N-N0)*XBAR/M + N*LOG(1 - THETA) + C SUM[X=2 to k][SUM[i=1 to x-1] C [(X-XBAR)*N(x)/(M+BETA*X-i]] = 0 C C ROUTINE ASSUMES THE DATA IS IN THE FORM C C X(I) FREQ(I) C C CALLED BY DNSQE ROUTINE FOR SOLVING SIMULTANEOUS C NONLINEAR EQUATIONS. NOTE THAT THE CALLING SEQUENCE C DID NOT ACCOMODATE A DATA ARRAY (AND ASSCIATED NUMBER OF C OBSERVATIONS), SO THESE WERE ADDED TO THE CALL LIST. C SINCE DNSQE ONLY PASSES ONE ARRAY, WE SPLIT INTO C TWO PARTS: 1 - MAXNXT/2 ARE THE FREQUENCIES WHILE C (MAXNXT/2 + 1) - MAXNXT ARE THE CLASS VALUES (I.E., C THE X). C EXAMPLE--GENERALIZED NEGATIVE BINOMIAL MAXIMUM LIKELIHOOD Y C REFERENCES--CONSUL AND FAMOYE (2006), "LAGRANGIAN PROBABILITY C DISTRIBUTIONS", BIRKHAUSER, CHAPTER 10. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBUG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2006/7 C ORIGINAL VERSION--JULY 2006. C C--------------------------------------------------------------------- C DOUBLE PRECISION XPAR(*) DOUBLE PRECISION FVEC(*) REAL Y(*) C DOUBLE PRECISION DX DOUBLE PRECISION DM DOUBLE PRECISION DBETA DOUBLE PRECISION DTHETA DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 DOUBLE PRECISION DSUM1 DOUBLE PRECISION DSUM2 DOUBLE PRECISION DN DOUBLE PRECISION DJ DOUBLE PRECISION DN0 DOUBLE PRECISION DFREQ DOUBLE PRECISION DNUM1 DOUBLE PRECISION DNUM2 DOUBLE PRECISION DENOM C DOUBLE PRECISION XBAR DOUBLE PRECISION S2 DOUBLE PRECISION S3 DOUBLE PRECISION F0FREQ DOUBLE PRECISION F1FREQ DOUBLE PRECISION F10FRE DOUBLE PRECISION DC1 COMMON/GNBCOM/XBAR,S2,S3,F0FREQ,F1FREQ,F10FRE,DC1, 1 MAXROW,NTOT2 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 COMPUTE SOME SUMS C DBETA=XPAR(1) DM=XPAR(2) DTHETA=XPAR(3) DN=DBLE(NTOT2) C IINDX=MAXROW/2 C DN0=DN*F0FREQ DTERM1=DN*XBAR*DLOG(1.0D0 - DTHETA) DTERM2=(DN - DN0)/DM + DN*DLOG(1.0D0 - DTHETA) C DSUM1=0.0D0 DSUM2=0.0D0 C C NOTE: CONSUL AND FAMOYE DEFINE CLASSES FOR I = 0 TO K, C SO ADJUST FOR FACT THAT FORTRAN ARRAYS START AT 1. C DO100I=1,K DX=DBLE(Y(IINDX+I)) IX=INT(DX + 0.5D0) IF(IX.LT.2)GOTO100 DFREQ=DBLE(Y(I)) IF(DFREQ.LE.0.0D0)GOTO100 DNUM1=DX*DFREQ DNUM2=DFREQ DO200J=1,K DJ=DBLE(Y(IINDX+J)) IJ=INT(DJ + 0.5D0) IF(IJ.LT.1 .OR. IJ.GT.IX-1)GOTO200 DENOM=DM + DBETA*DX - DJ DSUM1=DSUM1 + DNUM1/DENOM DSUM2=DSUM2 + DNUM2/DENOM 200 CONTINUE 100 CONTINUE C FVEC(1)=DM*(XBAR - DTHETA*(DM + DBETA*XBAR))/ 1 (DTHETA*(1.0D0 - DTHETA)) FVEC(2)=DTERM1 + DSUM1 FVEC(3)=DTERM2 + DSUM2 C RETURN END DOUBLE PRECISION FUNCTION GNBFU3(DTHETA) C C PURPOSE--THIS ROUTINE COMPUTES THE FUNCTION FOR FINDING C THE ESTIMATE OF THETA FOR THE C GENERALIZED NEGATIVE BINOMIAL METHOD OF MOMENTS C AND ZERO-CLASS FREQUENCY EQUATION. C C S2*(LOG(F0)**2/XBAR**3 - C (1-THETA)*(LOG(1-THETA))**2/THETA**2 = 0 C C CALLED BY DFZERO ROUTINE FOR FINDING THE ROOT OF C A NONLINEAR EQUATIONS. C EXAMPLE--GENERALIZED NEGATIVE BINOMIAL MAXIMUM LIKELIHOOD Y C REFERENCES--CONSUL AND FAMOYE (2006), "LAGRANGIAN PROBABILITY C DISTRIBUTIONS", BIRKHAUSER, CHAPTER 10. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBUG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2006/7 C ORIGINAL VERSION--JULY 2006. C C--------------------------------------------------------------------- C DOUBLE PRECISION DTHETA C DOUBLE PRECISION XBAR DOUBLE PRECISION S2 DOUBLE PRECISION S3 DOUBLE PRECISION F0FREQ DOUBLE PRECISION F1FREQ DOUBLE PRECISION F10FRE DOUBLE PRECISION DC1 COMMON/GNBCOM/XBAR,S2,S3,F0FREQ,F1FREQ,F10FRE,DC1, 1 MAXROW,NTOT2 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 COMPUTE SOME SUMS C GNBFU3=DC1 - (1.0D0 - DTHETA)*DLOG(1.0D0 - DTHETA)**2/DTHETA**2 C RETURN END DOUBLE PRECISION FUNCTION GNBFU4(DTHETA) C C PURPOSE--THIS ROUTINE COMPUTES THE FUNCTION FOR FINDING C THE ESTIMATE OF THETA FOR THE C GENERALIZED NEGATIVE BINOMIAL METHOD OF MOMENTS C AND RATIO OF FREQUENCIES EQUATION C C {(2/THETA) - (2/THETA)*SQRT(XBAR*(1-THETA)/S2)-1}* C LOG(1-THETA) - LOG(S2*F10**2/XBAR**3) = 0 C C CALLED BY DFZERO ROUTINE FOR FINDING THE ROOT OF C A NONLINEAR EQUATIONS. C EXAMPLE--GENERALIZED NEGATIVE BINOMIAL MAXIMUM LIKELIHOOD Y C REFERENCES--CONSUL AND FAMOYE (2006), "LAGRANGIAN PROBABILITY C DISTRIBUTIONS", BIRKHAUSER, CHAPTER 10. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBUG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2006/7 C ORIGINAL VERSION--JULY 2006. C C--------------------------------------------------------------------- C DOUBLE PRECISION DTHETA C DOUBLE PRECISION XBAR DOUBLE PRECISION S2 DOUBLE PRECISION S3 DOUBLE PRECISION F0FREQ DOUBLE PRECISION F1FREQ DOUBLE PRECISION F10FRE DOUBLE PRECISION DC1 COMMON/GNBCOM/XBAR,S2,S3,F0FREQ,F1FREQ,F10FRE,DC1, 1 MAXROW,NTOT2 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 COMPUTE SOME SUMS C GNBFU4=((2.0D0/DTHETA) - 1 (2.0D0/DTHETA)*DSQRT(XBAR*(1.0D0-DTHETA)/S2)-1.0D0)* 1 DLOG(1.0D0-DTHETA) - DLOG(S2*F10FRE**2/XBAR**3) write(19,*)'DTHETA,GNBFU4=',DTHETA,GNBFU4 C RETURN END SUBROUTINE GNBPDF(X,THETA,BETA,M,PDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY MASS C FUNCTION VALUE FOR THE GENERALIZED NEGATIVE BINOMIAL C DISTRIBUTION WITH SHAPE PARAMETERS THETA, BETA, AND C M. THIS DISTRIBUTION IS DEFINED FOR ALL INTEGER C X >= 1. C C THE PROBABILITY MASS FUNCTION IS: C p(X;THETA,BETA,M)= C (M/(M+BETA*X)* C (M+BETA*X X)*THETA**X*(1-THETA)**(M+BETA*X-X) C X = 0, 1, 2, 3, ,... C 0 < THETA < 1; BETA = 0 OR 1 <= BETA <= 1/THETA; C M > 0 (M A POSITIVE INTEGER IF BETA = 0) C C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE AT C WHICH THE PROBABILITY MASS C FUNCTION IS TO BE EVALUATED. C X SHOULD BE A NON-NEGATIVE INTEGER. C --THETA = THE FIRST SHAPE PARAMETER C --BETA = THE SECOND SHAPE PARAMETER C --M = THE THIRD SHAPE PARAMETER C OUTPUT ARGUMENTS--PDF = THE SINGLE PRECISION PROBABILITY C MASS FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION PROBABILITY MASS FUNCTION C VALUE PDF FOR THE GENERALIZED NEGATIVE BINOMIAL C DISTRIBUTION WITH SHAPE PARAMETERS THETA, BETA AND M. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--X SHOULD BE A NON-NEGATIVE INTEGER C --0 < THETA < 1; 1 <= BETA <= 1/THETA C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--CONSUL AND FAMOYE (2006), "LAGRANGIAN PROBABILITY C DISTRIBUTIONS", BIRKHAUSER, CHAPTER 10. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2006/7 C ORIGINAL VERSION--JULY 2006. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C REAL M C DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 DOUBLE PRECISION DTERM3 DOUBLE PRECISION DSUM DOUBLE PRECISION DX DOUBLE PRECISION DTHETA DOUBLE PRECISION DBETA DOUBLE PRECISION DM DOUBLE PRECISION DPDF DOUBLE PRECISION DLNGAM 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-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IX=INT(X+0.5) IF(IX.LT.0)THEN WRITE(ICOUT,4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9000 ENDIF 4 FORMAT('***** ERROR--THE FIRST ARGUMENT TO GNBPDF IS LESS ', 1'THAN 0') C IF(THETA.LE.0.0 .OR. THETA.GE.1.0)THEN WRITE(ICOUT,15) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)THETA CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9000 ENDIF 15 FORMAT('***** ERROR--THE SECOND ARGUMENT TO GNBPDF IS NOT IN ', 1'THE INTERVAL (0,1)') C IF(BETA.LE.1.0 .OR. BETA.GE.1.0/THETA .AND. BETA.NE.0.0)THEN WRITE(ICOUT,25)1.0/THETA CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)THETA CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9000 ENDIF 25 FORMAT('***** ERROR--THE THIRD ARGUMENT TO GNBPDF IS NOT IN ', 1'THE INTERVAL (1,',G15.7,')') C IF(M.LE.0.0)THEN WRITE(ICOUT,35) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)M CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9000 ENDIF 35 FORMAT('***** ERROR--THE FOURTH ARGUMENT TO GNBPDF IS ', 1'NON-POSITIVE') IF(BETA.EQ.0.0)THEN IM=INT(M+0.5) IF(IM.EQ.0)IM=1 M=REAL(IM) ENDIF C 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7) C DTHETA=DBLE(THETA) DBETA=DBLE(BETA) DM=DBLE(M) DX=DBLE(IX) C IF(IX.EQ.0)THEN DPDF=(1.0D0 - DTHETA)**DM ELSEIF(IX.EQ.1)THEN DPDF=DM*DTHETA*(1.0D0 - DTHETA)**(DM+DBETA-1.0D0) ELSE DTERM1=DLOG(DM) - DLOG(DM + DBETA*DX) DTERM2=DX*DLOG(DTHETA) DTERM3=(DM+DBETA*DX-DX)*DLOG(1.0D0 - DTHETA) DTERM4=DLNGAM(DM+DBETA*DX+1.0D0) - DLNGAM(DX+1.0D0) - 1 DLNGAM(DM+DBETA*DX-DX+1.0D0) DPDF=DEXP(DTERM1+DTERM2+DTERM3+DTERM4) ENDIF C PDF=REAL(DPDF) C 9000 CONTINUE RETURN END SUBROUTINE GNBPPF(P,THETA,BETA,M,PPF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT C FUNCTION VALUE FOR THE GENERALIZED NEGATIVE BINOMIAL C DISTRIBUTION WITH SHAPE PARAMETERS THETA, BETA, AND C M. THIS DISTRIBUTION IS DEFINED FOR ALL INTEGER C X >= 1. C C THE PROBABILITY MASS FUNCTION IS: C p(X;THETA,BETA,M)= C (M/(M+BETA*X)* C (M+BETA*X X)*THETA**X*(1-THETA)**(M+BETA*X-X) C X = 0, 1, 2, 3, ,... C 0 < THETA < 1; BETA = 0 OR 1 <= BETA <= 1/THETA; C M > 0 (M A POSITIVE INTEGER IF BETA = 0) C C THE CUMULATIVE DISTRIBUTION FUNCTION IS COMPUTED C FROM THE FOLLOWING RECURRENCE RELATION: C C P(X+1) = (M+(BETA-1)*X+BETA)/(X+1)* C THETA*(1-THETA)**(BETA-1)* C PROD[J=1 TO X-1][1 + BETA/(M+BETA*X-J)]*P(X) C C THE PERCENT POINT FUNCTION IS COMPUTED BY COMPUTING C THE CUMULATIVE DISTRIBUTION FUNCTION UNTIL THE C THE SPECIFIED PROBABILITY IS REACHED. C INPUT ARGUMENTS--P = THE SINGLE PRECISION VALUE AT C WHICH THE PERCENT POINT C FUNCTION IS TO BE EVALUATED. C 0 <= P < 1 C --THETA = THE FIRST SHAPE PARAMETER C --BETA = THE SECOND SHAPE PARAMETER C --M = THE THIRD SHAPE PARAMETER C OUTPUT ARGUMENTS--PPF = THE SINGLE PRECISION PERCENT POINT C FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION PERCENT POINT FUNCTION C VALUE PPF FOR THE GENERALIZED NEGATIVE BINOMIAL C DISTRIBUTION WITH SHAPE PARAMETERS THETA, BETA AND M. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--0 <= P < 1 C --0 < THETA < 1; 1 <= BETA <= 1/THETA; M > 0 C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--CONSUL AND FAMOYE (2006), "LAGRANGIAN PROBABILITY C DISTRIBUTIONS", BIRKHAUSER, CHAPTER 10. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2006/7 C ORIGINAL VERSION--JULY 2006. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C REAL M C DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 DOUBLE PRECISION DTERM3 DOUBLE PRECISION DSUM DOUBLE PRECISION DX DOUBLE PRECISION DTHETA DOUBLE PRECISION DBETA DOUBLE PRECISION DM DOUBLE PRECISION DPDF DOUBLE PRECISION DPDFSV DOUBLE PRECISION DPPF DOUBLE PRECISION DP C C--------------------------------------------------------------------- C INCLUDE 'DPCOMC.INC' C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(P.LT.0.0 .OR. P.GE.1.0)THEN WRITE(ICOUT,4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)P CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9000 ENDIF 4 FORMAT('***** ERROR--THE FIRST ARGUMENT TO GNBPPF IS OUTSIDE ', 1'THE (0,1] INTERVAL') C IF(THETA.LE.0.0 .OR. THETA.GE.1.0)THEN WRITE(ICOUT,15) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)THETA CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9000 ENDIF 15 FORMAT('***** ERROR--THE SECOND ARGUMENT TO GNBPPF IS NOT IN ', 1'THE INTERVAL (0,1)') C IF(BETA.LE.1.0 .OR. BETA.GE.1.0/THETA .AND. BETA.NE.0.0)THEN WRITE(ICOUT,25)1.0/THETA CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)THETA CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9000 ENDIF 25 FORMAT('***** ERROR--THE THIRD ARGUMENT TO GNBPPF IS NOT IN ', 1'THE INTERVAL (1,',G15.7,')') C IF(M.LE.0.0)THEN WRITE(ICOUT,35) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)M CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9000 ENDIF 35 FORMAT('***** ERROR--THE FOURTH ARGUMENT TO GNBPPF IS ', 1'NON-POSITIVE') IF(BETA.EQ.0.0)THEN IM=INT(M+0.5) IF(IM.EQ.0)IM=1 M=REAL(IM) ENDIF C 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7) C DTHETA=DBLE(THETA) DBETA=DBLE(BETA) DM=DBLE(M) DP=DBLE(P) C C USE THE RECURRENCE RELATION (PAGE 199 OF CONSUL AND FAMOYE): C DCDF=(1.0D0 - DTHETA)**DM IF(DCDF.GE.DP)THEN PPF=0.0 GOTO9000 ENDIF C DPDF=DM*DTHETA*(1.0D0 - DTHETA)**(DM+DBETA-1.0D0) DCDF=DCDF + DPDF IF(DCDF.GE.DP)THEN PPF=1.0 GOTO9000 ENDIF C DPDFSV=DPDF DTERM2=DLOG(DTHETA) + (DBETA - 1.0D0)*DLOG(1.0D0 - DTHETA) I=1 C 100 CONTINUE I=I+1 IF(DBLE(I).GE.DBLE(I1MACH(9)))THEN WRITE(ICOUT,55) 55 FORMAT('***** ERROR--THE COMPUTED PERCENT POINT VALUE ', 1 'EXCEEDS THE LARGEST MACHINE INTEGER.') CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9000 ENDIF DX=DBLE(I) C DTERM1=DLOG(DM + (DBETA-1.0D0)*(DX-1.0D0) + DBETA) - 1 DLOG(DX) IF(DPDFSV.LE.0.0D0)THEN GOTO1000 ELSE DTERM3=DLOG(DPDFSV) ENDIF IF(I-2.GE.1)THEN DSUM=0.0D0 DO200J=1,I-2 DSUM=DSUM + DLOG(1.0D0 + DBETA/ 1 (DM + DBETA*(DX-1.0D0)-DBLE(J))) 200 CONTINUE ELSE DSUM=0.0D0 ENDIF DPDF=DEXP(DTERM1 + DTERM2 + DTERM3 + DSUM) DCDF=DCDF + DPDF DPDFSV=DPDF IF(DCDF.GE.DP)THEN PPF=REAL(I) GOTO9000 ENDIF GOTO100 C 1000 CONTINUE PPF=REAL(DPPF) C 9000 CONTINUE RETURN END SUBROUTINE GNBRAN(N,THETA,BETA,AM,ISEED,X) C C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N C FROM THE GENERALIZED NEGATIVE BINOMIAL DISTRIBUTION C WITH SHAPE PARAMETERS THETA, BETA, AND M. C THE PROBABILITY MASS FUNCTION IS: C p(X;THETA,BETA,M)= C (M/(M+BETA*X)* C (M+BETA*X X)*THETA**X*(1-THETA)**(M+BETA*X-X) C X = 0, 1, 2, 3, ,... C 0 < THETA < 1; BETA = 0 OR 1 <= BETA <= 1/THETA; C M > 0 (M A POSITIVE INTEGER IF BETA = 0) C C INPUT ARGUMENTS--N = THE DESIRED INTEGER NUMBER C OF RANDOM NUMBERS TO BE C GENERATED. C --THETA = THE SINGLE PRECISION VALUE C OF THE FIRST SHAPE PARAMETER. C --BETA = THE SINGLE PRECISION VALUE C OF THE SECOND SHAPE PARAMETER. C --AM = THE SINGLE PRECISION VALUE C OF THE THIRD SHAPE PARAMETER. C OUTPUT ARGUMENTS--X = A SINGLE PRECISION VECTOR C (OF DIMENSION AT LEAST N) C INTO WHICH THE GENERATED C RANDOM SAMPLE WILL BE PLACED. C OUTPUT--A RANDOM SAMPLE OF SIZE N C FROM THE GENERALIZED NEGATIVE BINOMIAL DISTRIBUTION C WITH SHAPE PARAMETERS THETA, BETA, AND M. 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 --0 < THETA < 1, 1 < BETA < 1/THETA, M > 0 C OTHER DATAPAC SUBROUTINES NEEDED--UNIRAN, GNBPPF C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--FAMOYE (1997), "SAMPLING FROM A GENERALIZED C NEGATIVE BINOMIAL DISTRIBUTION", COMPUTING, C 58(4), PP. 365-376. C --CONSUL AND FAMOYE (2006), "LAGRANGIAN PROBABILITY C DISTRIBUTIONS", BIRKHAUSER, CHAPTERS 11 AND 16. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2006/7 C ORIGINAL VERSION--JULY 2006. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C REAL THETA REAL BETA DIMENSION X(*) DIMENSION XTEMP(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.1415926535 8979323846 E0 / C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(N.LT.1)THEN WRITE(ICOUT,5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,6) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)N CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF 5 FORMAT('***** ERROR--THE REQUESTED NUMBER OF ', 1'GENERALIZED NEGATIVE BINOMIAL') 6 FORMAT(' RANDOM NUMBERS IS NON-POSITIVE') IF(THETA.LE.0.0 .OR. THETA.GE.1.0)THEN WRITE(ICOUT,11) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)THETA CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF 11 FORMAT('***** ERROR--THE THETA PARAMETER FOR THE ', 1'GENERALIZED NEGATIVE BINOMIAL') 12 FORMAT(' RANDOM NUMBERS IS OUTSIDE THE (0,1) INTERVAL') C IF(BETA.LE.1.0 .OR. BETA.GE.1.0/THETA)THEN WRITE(ICOUT,21) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,22) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)BETA CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF 21 FORMAT('***** ERROR--THE BETA PARAMETER FOR THE ', 1'GENERALIZED NEGATIVE BINOMIAL') 22 FORMAT(' RANDOM NUMBERS IS OUTSIDE THE (0,',G15.7, 1 ') INTERVAL') C IF(AM.LE.0.0)THEN WRITE(ICOUT,31) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,32) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)AM CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF 31 FORMAT('***** ERROR--THE M PARAMETER FOR THE ', 1'GENERALIZED NEGATIVE BINOMIAL') 32 FORMAT(' RANDOM NUMBERS IS NON-POSITIVE.') C 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7) 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8) C C GENERATE N GENERALIZED NEGATIVE BINOMIAL DISTRIBUTION C RANDOM NUMBERS. FOLLOWING RECOMMENDATION OF CONSUL AND C FAYMOE, USE INVERSION METHOD FOR THETA*BETA <= 0.60 AND C BRANCHING METHOD OTHERWISE. C C BRANCHING ALGORITHM DOESN'T SEEM TO RETURN AS ACCURATE C A RESULT AS THE INVERSION METHOD, SO USE THE INVERSION C METHOD EVEN IF SOMEWHAT SLOWER. C IFLAG=0 IF(THETA*BETA.LE.0.6 .OR. IFLAG.EQ.0)THEN CALL UNIRAN(N,ISEED,X) DO100I=1,N ZTEMP=X(I) CALL GNBPPF(ZTEMP,THETA,BETA,AM,PPF) X(I)=PPF 100 CONTINUE ELSE C C BRANCHING ALGORITHM C NTEMP=1 DO200I=1,N CALL NBRAN(NTEMP,1.0-THETA,AM,ISEED,XTEMP) Y=XTEMP(1) IF(Y.LE.0.0)THEN X(I)=Y GOTO200 ENDIF XX=0.0 220 CONTINUE AK=(BETA-1.0)*Y CALL NBRAN(NTEMP,1.0-THETA,AK,ISEED,XTEMP) Z=XTEMP(1) XX=XX+Y+Z Y=Z IF(Y.GT.0.0)GOTO220 X(I)=XX 200 CONTINUE ENDIF C 9999 CONTINUE C RETURN END SUBROUTINE GOMCDF(X,C,B,CDF) C C THIS SUBROUTINE COMPUTES THE GOMPERTZ CUMULATIVE DISTRIBUTION C FUNCTION. THIS IS A TRUNCATED FORM OF THE TYPE 1 EXTREME C VALUE DISTRIBUTION. IT HAS THE FOLLOWING CDF: C F(X,C,B) = 1 - EXP(-B*(C**X-1)/LOG(C)) X>=0, B>0, C>=1 C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C REFERENCE--"CONTINUOUS UNIVARIATE DISTRIBUTIONS - VOL. 2", 2ND ED C JOHNSON, KOTZ, AND BALAKRISHNAN, WILEY, 1994, PP. 25-26 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--95/10 C ORIGINAL VERSION--OCTOBER 1995. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C DOUBLE PRECISION DCDF DOUBLE PRECISION DC DOUBLE PRECISION DB DOUBLE PRECISION DX DOUBLE PRECISION DTERM1 C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IF(C.LE.1.0 .OR. B.LE.0.0)THEN WRITE(ICOUT,101) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,103)C CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF IF(B.LE.0.0)THEN WRITE(ICOUT,102) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,103)B 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 101 FORMAT('***** FATAL DIAGNOSTIC FROM GOMCDF--THE SECOND INPUT ', *'ARGUMENT IS LESS THAN 1.') 102 FORMAT('***** FATAL DIAGNOSTIC FROM GOMCDF--THE THIRD INPUT ', *'ARGUMENT IS NON-POSITIVE.') 103 FORMAT(' THE VALUE OF THE ARGUMENT IS ',E15.7) 104 FORMAT(' THE VALUE OF THE THIRD ARGUMENT IS ',E15.7) 301 FORMAT('***** FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT IS ') 302 FORMAT(' NEGATIVE. IT HAS THE VALUE ',E15.7) C IF(X.LE.0.)THEN CDF=0.0 GOTO9999 ENDIF C DX=DBLE(X) DC=DBLE(C) DB=DBLE(B) DTERM1=-DB*(DC**DX - 1.D0)/DLOG(DC) IF(DTERM1.GE.80.D0)THEN CDF=1.0 GOTO9999 ENDIF DCDF=1.0D0-DEXP(DTERM1) CDF=SNGL(DCDF) C 9999 CONTINUE RETURN END SUBROUTINE GOMPDF(X,C,B,PDF) C C THIS SUBROUTINE COMPUTES THE GOMPERTZ CUMULATIVE DISTRIBUTION C FUNCTION. THIS IS A TRUNCATED FORM OF THE TYPE 1 EXTREME C VALUE DISTRIBUTION. IT HAS THE FOLLOWING PDF: C F(X,C,B) = B*C**X/EXP(B*(C**X-1)/LOG(C)) X>=0, B>0, C>=1 C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C REFERENCE--"CONTINUOUS UNIVARIATE DISTRIBUTIONS - VOL. 2", 2ND ED C JOHNSON, KOTZ, AND BALAKRISHNAN, WILEY, 1994, PP. 25-26 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--95/10 C ORIGINAL VERSION--OCTOBER 1995. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C DOUBLE PRECISION DPDF DOUBLE PRECISION DC DOUBLE PRECISION DB DOUBLE PRECISION DX DOUBLE PRECISION DTERM1, DTERM2, DTERM3 C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IF(C.LE.1.0 .OR. B.LE.0.0)THEN WRITE(ICOUT,101) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,103)C CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF IF(B.LE.0.0)THEN WRITE(ICOUT,102) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,103)B 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 101 FORMAT('***** FATAL DIAGNOSTIC FROM GOMPDF--THE SECOND INPUT ', *'ARGUMENT IS LESS THAN 1.') 102 FORMAT('***** FATAL DIAGNOSTIC FROM GOMPDF--THE THIRD INPUT ', *'ARGUMENT IS NON-POSITIVE.') 103 FORMAT(' THE VALUE OF THE ARGUMENT IS ',E15.7) 104 FORMAT(' THE VALUE OF THE THIRD ARGUMENT IS ',E15.7) 301 FORMAT('***** FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT IS ') 302 FORMAT(' NEGATIVE. IT HAS THE VALUE ',E15.7) C DX=DBLE(X) DC=DBLE(C) DB=DBLE(B) DTERM1=DLOG(DB) + DX*DLOG(DC) DTERM2=(DB/DLOG(DC))*(DC**DX-1.0D0) DTERM3=DTERM1-DTERM2 IF(DTERM3.LE.-80.D0)THEN PDF=0.0 GOTO9999 ELSEIF(DTERM3.GE.80.D0)THEN PDF=0.0 WRITE(ICOUT,401) CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF 401 FORMAT('***** NON-FATAL DIAGNOSTIC FROM GOMPDF. THE COMPUTED ', 1'PDF VALUE EXCEEDS MACHINE PRECISION.') C DPDF=DEXP(DTERM3) PDF=SNGL(DPDF) C 9999 CONTINUE RETURN END SUBROUTINE GOMPPF(P,C,B,PPF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE GOMPERTZ PERCENT POINT C FUNCTION. THIS IS A TRUNCATED FORM OF THE TYPE 1 C EXTREME VALUE DISTRIBUTION. IT HAS THE FOLLOWING PDF: C F(X,C,B) = B*C**X/EXP(B*(C**X-1)/LOG(C)) C X>=0, B>0, C>=1 C NOTE THAT THE PERCENT POINT FUNCTION OF A DISTRIBUTION C IS IDENTICALLY THE SAME AS THE INVERSE CUMULATIVE C DISTRIBUTION FUNCTION OF THE DISTRIBUTION. C INPUT ARGUMENTS--P = THE SINGLE PRECISION VALUE C (BETWEEN 0.0 (EXCLUSIVELY) C AND 1.0 (EXCLUSIVELY)) C AT WHICH THE PERCENT POINT C FUNCTION IS TO BE EVALUATED. C --C = THE SINGLE PRECISION VALUE C OF THE FIRST SHAPE PARAMETER. C C SHOULD BE > 1. C --B = THE SINGLE PRECISION VALUE C OF THE SECOND SHAPE PARAMETER. 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 GOMPERTZ DISTRIBUTION C WITH SHAPE PARAMETERS C AND B. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--C SHOULD BE > 1. C --B SHOULD BE POSITIVE. C --P SHOULD BE BETWEEN 0.0 (EXCLUSIVELY) C AND 1.0 (EXCLUSIVELY). C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--ALOG. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCE --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE C DISTRIBUTIONS--2, 1994, PAGES 25-26. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--95/10 C ORIGINAL VERSION--OCTOBER 1995. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C C--------------------------------------------------------------------- C DOUBLE PRECISION DPPF DOUBLE PRECISION DC DOUBLE PRECISION DB DOUBLE PRECISION DP DOUBLE PRECISION DTERM1 C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(P.LT.0.0.OR.P.GE.1.0)THEN WRITE(ICOUT,1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)P CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9999 ENDIF IF(C.LE.1.0)THEN WRITE(ICOUT,101) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)C CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF IF(B.LE.0.0)THEN WRITE(ICOUT,102) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)B CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF 101 FORMAT('***** FATAL DIAGNOSTIC FROM GOMPPF--THE SECOND INPUT ', *'ARGUMENT IS LESS THAN 1.') 102 FORMAT('***** FATAL DIAGNOSTIC FROM GOMPPF--THE THIRD INPUT ', *'ARGUMENT IS NON-POSITIVE.') C 1 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ', 1'GOMPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') C IF(P.EQ.0.0)THEN PPF=0.0 GOTO9999 ENDIF C DP=DBLE(P) DC=DBLE(C) DB=DBLE(B) C DTERM1=1.0D0 - DLOG(1.0D0-DP)*DLOG(DC)/DB DPPF=DLOG(DTERM1)/DLOG(DC) PPF=SNGL(DPPF) C 9999 CONTINUE RETURN END SUBROUTINE GOMRAN(N,C,B,ISEED,X) C C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N C FROM THE GOMPERTZ DISTRIBUTION C WITH SHAPE PARAMETER VALUES = C, B. C INPUT ARGUMENTS--N = THE DESIRED INTEGER NUMBER C OF RANDOM NUMBERS TO BE C GENERATED. C --C = THE SINGLE PRECISION VALUE OF THE C FIRST SHAPE PARAMETER. C C SHOULD BE > 1. C --B = THE SINGLE PRECISION VALUE OF THE C SECOND SHAPE PARAMETER. C B SHOULD BE POSITIVE. C OUTPUT ARGUMENTS--X = A SINGLE PRECISION VECTOR C (OF DIMENSION AT LEAST N) C INTO WHICH THE GENERATED C RANDOM SAMPLE WILL BE PLACED. C OUTPUT--A RANDOM SAMPLE OF SIZE N C FROM THE GOMPERTZ DISTRIBUTION C WITH SHAPE PARAMETER VALUES = C AND B. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C --C SHOULD BE POSITIVE. C OTHER DATAPAC SUBROUTINES NEEDED--UNIRAN. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2001.9 C ORIGINAL VERSION--SEPTEMBER 2001. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DIMENSION X(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(N.LT.1)THEN WRITE(ICOUT, 5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)N CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF 5 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ', 1'GOMRAN 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 GOMPERTZ DISTRIBUTION RANDOM NUMBERS C USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD. C DO100I=1,N CALL GOMPPF(X(I),C,B,XTEMP) X(I)=XTEMP 100 CONTINUE C 9000 CONTINUE RETURN END DOUBLE PRECISION FUNCTION GOODST(XVALUE) C C DESCRIPTION: C C This function calculates the function defined as C C GOODST(x) = {integral 0 to inf} ( exp(-u*u)/(u+x) ) du C C The code uses Chebyshev expansions whose coefficients are C given to 20 decimal places. C C C ERROR RETURNS: C C If XVALUE <= 0.0, an error message is printed, and the C code returns the value 0.0. C C C MACHINE-DEPENDENT CONSTANTS: C C NTERM1 - The no. of terms to be used in the array AGOST. C The recommended value is such that C AGOST(NTERM1) < EPS/100, C C NTERM2 - The no. of terms to be used in the array AGOSTA. C The recommended value is such that C AGOSTA(NTERM2) < EPS/100, C C XLOW - The value below which f(x) = -(gamma/2) - ln(x) C to machine precision. The recommended value is C EPSNEG C C XHIGH - The value above which f(x) = sqrt(pi)/(2x) to C machine precision. The recommended value is C 2 / EPSNEG C C For values of EPS and EPSNEG refer to the file MACHCON.TXT C C The machine-dependent constants are computed internally by C using the D1MACH subroutine. C C C INTRINSIC FUNCTIONS USED: C C EXP , LOG 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 C (e-mail: macl_ms0@paisley.ac.uk ) C C C LATEST REVISION: C 23 January, 1996 C C INTEGER NTERM1,NTERM2 DOUBLE PRECISION AGOST(0:28),AGOSTA(0:23), 1 CHEVAL,FVAL,GAMBY2,HALF,ONE,ONEHUN,RTPIB2,SIX, 2 T,TWO,X,XHIGH,XLOW,XVALUE,ZERO CCCCC CHARACTER FNNAME*6,ERRMSG*15 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/'GOODST'/ CCCCC DATA ERRMSG/'ARGUMENT <= 0.0'/ DATA ZERO,HALF,ONE/ 0.0 D 0 , 0.5 D 0 , 1.0 D 0 / DATA TWO,SIX/ 2.0 D 0 , 6.0 D 0 / DATA ONEHUN/100.0 D 0/ DATA GAMBY2/0.28860 78324 50766 43030 D 0/ DATA RTPIB2/0.88622 69254 52758 01365 D 0/ DATA AGOST(0)/ 0.63106 56056 03984 46247 D 0/ DATA AGOST(1)/ 0.25051 73779 32167 08827 D 0/ DATA AGOST(2)/ -0.28466 20597 90189 40757 D 0/ DATA AGOST(3)/ 0.87615 87523 94862 3552 D -1/ DATA AGOST(4)/ 0.68260 22672 21252 724 D -2/ DATA AGOST(5)/ -0.10811 29544 19225 4677 D -1/ DATA AGOST(6)/ 0.16910 12441 17152 176 D -2/ DATA AGOST(7)/ 0.50272 98462 26151 86 D -3/ DATA AGOST(8)/ -0.18576 68720 41000 84 D -3/ DATA AGOST(9)/ -0.42870 36741 68474 D -5/ DATA AGOST(10)/ 0.10095 98903 20290 5 D -4/ DATA AGOST(11)/-0.86529 91351 7382 D -6/ DATA AGOST(12)/-0.34983 87432 0734 D -6/ DATA AGOST(13)/ 0.64832 78683 494 D -7/ DATA AGOST(14)/ 0.75759 24985 83 D -8/ DATA AGOST(15)/-0.27793 54243 62 D -8/ DATA AGOST(16)/-0.48302 35135 D -10/ DATA AGOST(17)/ 0.86632 21283 D -10/ DATA AGOST(18)/-0.39433 9687 D -11/ DATA AGOST(19)/-0.20952 9625 D -11/ DATA AGOST(20)/ 0.21501 759 D -12/ DATA AGOST(21)/ 0.39590 15 D -13/ DATA AGOST(22)/-0.69227 9 D -14/ DATA AGOST(23)/-0.54829 D -15/ DATA AGOST(24)/ 0.17108 D -15/ DATA AGOST(25)/ 0.376 D -17/ DATA AGOST(26)/-0.349 D -17/ DATA AGOST(27)/ 0.7 D -19/ DATA AGOST(28)/ 0.6 D -19/ DATA AGOSTA(0)/ 1.81775 46798 47187 58767 D 0/ DATA AGOSTA(1)/ -0.99211 46570 74409 7467 D -1/ DATA AGOSTA(2)/ -0.89405 86452 54819 243 D -2/ DATA AGOSTA(3)/ -0.94955 33127 77267 85 D -3/ DATA AGOSTA(4)/ -0.10971 37996 67596 65 D -3/ DATA AGOSTA(5)/ -0.13466 94539 57859 0 D -4/ DATA AGOSTA(6)/ -0.17274 92743 08265 D -5/ DATA AGOSTA(7)/ -0.22931 38019 9498 D -6/ DATA AGOSTA(8)/ -0.31278 44178 918 D -7/ DATA AGOSTA(9)/ -0.43619 79736 71 D -8/ DATA AGOSTA(10)/-0.61958 46474 3 D -9/ DATA AGOSTA(11)/-0.89379 91276 D -10/ DATA AGOSTA(12)/-0.13065 11094 D -10/ DATA AGOSTA(13)/-0.19316 6876 D -11/ DATA AGOSTA(14)/-0.28844 270 D -12/ DATA AGOSTA(15)/-0.43447 96 D -13/ DATA AGOSTA(16)/-0.65951 8 D -14/ DATA AGOSTA(17)/-0.10080 1 D -14/ DATA AGOSTA(18)/-0.15502 D -15/ DATA AGOSTA(19)/-0.2397 D -16/ DATA AGOSTA(20)/-0.373 D -17/ DATA AGOSTA(21)/-0.58 D -18/ DATA AGOSTA(22)/-0.9 D -19/ DATA AGOSTA(23)/-0.1 D -19/ C C Start computation C X = XVALUE C C Error test C IF ( X .LE. ZERO ) THEN CCCCC CALL ERRPRN(FNNAME,ERRMSG) WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,101)X CALL DPWRST('XXX','BUG ') GOODST = ZERO RETURN ENDIF 999 FORMAT(1X) 101 FORMAT('***** ERROR FROM GOODST--ARGUMENT MUST BE ', 1 'POSITIVE, ARGUMENT = ',G15.7) C C Compute the machine-dependent constants. C FVAL = D1MACH(3) T = FVAL / ONEHUN IF ( X .LE. TWO ) THEN DO 10 NTERM1 = 28 , 0 , -1 IF ( ABS(AGOST(NTERM1)) .GT. T ) GOTO 19 10 CONTINUE 19 XLOW = FVAL ELSE DO 40 NTERM2 = 23 , 0 , -1 IF ( ABS(AGOSTA(NTERM2)) .GT. T ) GOTO 49 40 CONTINUE 49 XHIGH = TWO / FVAL ENDIF C C Computation for 0 < x <= 2 C IF ( X .LE. TWO ) THEN IF ( X .LT. XLOW ) THEN GOODST = - GAMBY2 - LOG(X) ELSE T = ( X - HALF ) - HALF GOODST = CHEVAL(NTERM1,AGOST,T) - EXP(-X*X) * LOG(X) ENDIF ELSE C C Computation for x > 2 C FVAL = RTPIB2 / X IF ( X .GT. XHIGH ) THEN GOODST = FVAL ELSE T = ( SIX - X ) / ( TWO + X ) GOODST = FVAL * CHEVAL(NTERM2,AGOSTA,T) ENDIF ENDIF RETURN END SUBROUTINE GRDEP2(X1,Y1,X2,Y2,DEL,X3,Y3,X4,Y4) C C PURPOSE--GIVEN THE LINE SEGMENT FROM (X1,Y1) TO (X2,Y2) C DETERMINE THE COORDINATES (X3,Y3) AND X4,Y4) C OF A PARALLEL LINE SEGMENT AT A DISTANCE OF DEL UNITS C AWAY (ORTHOGONALLY) IN A COUNTER-CLOCKWISE ANGLE. C DELX=X2-X1 DELY=Y2-Y1 RSQ=DELX**2+DELY**2 C R=0.0 IF(RSQ.GT.0.0)R=SQRT(RSQ) C FACTOR=0.0 IF(R.GT.0.0)FACTOR=DEL/R C DELX2=FACTOR*DELY DELY2=FACTOR*DELX C X3=X1-DELX2 Y3=Y1+DELY2 C X4=X2-DELX2 Y4=Y2+DELY2 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE RETURN END SUBROUTINE GRDEPL(PX,PY,NP,DEL,PX3,PY3,NP3) C C PURPOSE--DETERMINE COORDINATES OF TRACE PARALLEL C TO TRACE IN (PX(.),PY(.)) AT AN C ORTHOGONAL DISTANCE OF DEL UNITS (0.0 TO 100.0) C C UPDATED--MAY 1989 INCREASE THE DIMENSION CHECK FOR ARRAYS C UPDATED --JUNE 1990. TEMPORARY ARRAYS TO GARBAGE COMMON C UPDATED --SEPTEMBER 1993. DO DEGENERATE (NP = 1) CASE C C--------------------------------------------------------------------- C INCLUDE 'DPCOPA.INC' C DIMENSION PX(*) DIMENSION PY(*) DIMENSION PX3(*) DIMENSION PY3(*) C DIMENSION PXPRE(MAXPOP) DIMENSION PYPRE(MAXPOP) C DIMENSION PXPOST(MAXPOP) DIMENSION PYPOST(MAXPOP) CCCCC FOLLOWING LINES ADDED JUNE, 1990 INCLUDE 'DPCOZ2.INC' EQUIVALENCE (G2RBAG(IGRG15),PXPRE(1)) EQUIVALENCE (G2RBAG(IGRG16),PYPRE(1)) EQUIVALENCE (G2RBAG(IGRG17),PXPOST(1)) EQUIVALENCE (G2RBAG(IGRG18),PYPOST(1)) CCCCC END CHANGE C C-----COMMON---------------------------------------------------------- C 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 IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DEPL')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF GRDEPL--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)DEL 52 FORMAT('DEL = ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)NP 54 FORMAT('NP = ',I8) CALL DPWRST('XXX','BUG ') DO55I=1,NP WRITE(ICOUT,56)I,PX(I),PY(I) 56 FORMAT('I,PX(I),PY(I) = ', 1I8,2E15.7) CALL DPWRST('XXX','BUG ') 55 CONTINUE WRITE(ICOUT,59)IBUGG4,ISUBG4,IERRG4 59 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 90 CONTINUE C CCCCC THE FOLLOWING 6 LINES WERE ADDED SEPTEMBER 1993 CCCCC TO HANDLE THE DEGENERATE NP = 1 CASE SEPTEMBER 1993 IF(NP.LE.1)THEN PX3(1)=PX(1) PY3(1)=PY(1) NP3=NP GOTO9000 ENDIF C CCCCC THE FOLLOWING LINE WAS REPLACED MAY 1989 CCCCC BY THE SUCCEEDING LINE MAY 1989 CCCCC IF(NP.LE.1000)GOTO1090 IF(NP.LE.MAXPOP)GOTO1090 WRITE(ICOUT,1011) 1011 FORMAT('***** ERROR IN GRDEPL--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1012) 1012 FORMAT(' NP HAS JUST EXCEEDED ARRAY DIMENSION') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1013)NP 1013 FORMAT(' NP = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1014) 1014 FORMAT(' FIX DIMENSION OF ARRAYS IN GRDEPL') CALL DPWRST('XXX','BUG ') IERRG4='YES' GOTO9000 1090 CONTINUE C NPM1=NP-1 DO1100I=1,NPM1 IP1=I+1 X1=PX(I) Y1=PY(I) X2=PX(IP1) Y2=PY(IP1) CALL GRDEP2(X1,Y1,X2,Y2,DEL,X3,Y3,X4,Y4) PXPOST(I)=X3 PYPOST(I)=Y3 PXPRE(IP1)=X4 PYPRE(IP1)=Y4 1100 CONTINUE PXPOST(NP)=PXPRE(NP) PYPOST(NP)=PYPRE(NP) PXPRE(1)=PXPOST(1) PYPRE(1)=PYPOST(1) C C ****************************************** C ** STEP XX-- ** C ** TREAT THE INTERMEDIATE POINTS CASE ** C ****************************************** C DO1200I=2,NPM1 IM1=I-1 IP1=I+1 C DELX1=PX(I)-PX(IM1) DELY1=PY(I)-PY(IM1) IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'DEPL') 1WRITE(ICOUT,1111)I,IM1,PX(IM1),PX(I) 1111 FORMAT('I,IM1,PX(IM1),PX(I) = ',2I8,2E15.7) IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'DEPL') 1CALL DPWRST('XXX','BUG ') SLOPE1=CPUMAX IF(ABS(DELX1).GE.0.000001)SLOPE1=DELY1/DELX1 IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'DEPL') 1WRITE(ICOUT,1112)DELX1,SLOPE1 1112 FORMAT('DELX1,SLOPE1 = ',2E15.7) IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'DEPL') 1CALL DPWRST('XXX','BUG ') C DELX2=PX(IP1)-PX(I) DELY2=PY(IP1)-PY(I) IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'DEPL') 1WRITE(ICOUT,1121)I,IP1,PX(I),PX(IP1) 1121 FORMAT('I,IP1,PX(I),PX(IP1) = ',2I8,2E15.7) IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'DEPL') 1CALL DPWRST('XXX','BUG ') SLOPE2=CPUMAX IF(ABS(DELX2).GE.0.000001)SLOPE2=DELY2/DELX2 IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'DEPL') 1WRITE(ICOUT,1122)DELX2,SLOPE2 1122 FORMAT('DELX2,SLOPE2 = ',2E15.7) IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'DEPL') 1CALL DPWRST('XXX','BUG ') C IF(SLOPE1.EQ.SLOPE2)GOTO1210 GOTO1220 C 1210 CONTINUE PX3(I)=PXPRE(I) PY3(I)=PYPRE(I) GOTO1200 C 1220 CONTINUE IF(SLOPE1.EQ.CPUMAX)GOTO1221 IF(SLOPE2.EQ.CPUMAX)GOTO1222 GOTO1223 1221 CONTINUE PX3(I)=PXPRE(I) PY3(I)=PYPOST(I) GOTO1229 1222 CONTINUE PX3(I)=PXPOST(I) PY3(I)=PYPRE(I) GOTO1229 1223 CONTINUE DENOM=SLOPE2-SLOPE1 ANUM=PYPRE(I)-PYPOST(I)-SLOPE1*PXPRE(I)+SLOPE2*PXPOST(I) IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'DEPL') 1WRITE(ICOUT,1224)SLOPE1,SLOPE2,DENOM 1224 FORMAT('SLOPE1,SLOPE2,DENOM = ',3E15.7) IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'DEPL') 1CALL DPWRST('XXX','BUG ') PX3(I)=ANUM/DENOM PY3(I)=PYPRE(I)+SLOPE1*(PX3(I)-PXPRE(I)) 1229 CONTINUE C 1200 CONTINUE C C ******************************************* C ** STEP XX-- ** C ** TREAT THE FIRST AND LAST POINT CASE ** C ******************************************* C IF(PX(1).EQ.PX(NP).AND.PY(1).EQ.PY(NP))GOTO2100 PX3(1)=PXPOST(1) PY3(1)=PYPOST(1) PX3(NP)=PXPRE(NP) PY3(NP)=PYPRE(NP) GOTO2900 C 2100 CONTINUE NPM1=NP-1 DELX1=PX(NP)-PX(NPM1) DELY1=PY(NP)-PY(NPM1) IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'DEPL') 1WRITE(ICOUT,2111)NPM1,NP,PX(NPM1),PX(NP) 2111 FORMAT('NPM1,NP,PX(NPM1),PX(NP) = ',2I8,2E15.7) IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'DEPL') 1CALL DPWRST('XXX','BUG ') SLOPE1=CPUMAX IF(ABS(DELX1).GE.0.000001)SLOPE1=DELY1/DELX1 IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'DEPL') 1WRITE(ICOUT,2112)DELX1,SLOPE1 2112 FORMAT('DELX1,SLOPE1 = ',2E15.7) IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'DEPL') 1CALL DPWRST('XXX','BUG ') C I=1 IP1=I+1 DELX2=PX(IP1)-PX(I) DELY2=PY(IP1)-PY(I) IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'DEPL') 1WRITE(ICOUT,2121)I,IP1,PX(I),PX(IP1) 2121 FORMAT('I,IP1,PX(I),PX(IP1) = ',2I8,2E15.7) IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'DEPL') 1CALL DPWRST('XXX','BUG ') SLOPE2=CPUMAX IF(ABS(DELX2).GE.0.000001)SLOPE2=DELY2/DELX2 IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'DEPL') 1WRITE(ICOUT,2122)DELX2,SLOPE2 2122 FORMAT('DELX2,SLOPE2 = ',2E15.7) IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'DEPL') 1CALL DPWRST('XXX','BUG ') C IF(SLOPE1.EQ.SLOPE2)GOTO2210 GOTO2220 C 2210 CONTINUE PX3(1)=PXPRE(NP) PY3(1)=PYPRE(NP) PX3(NP)=PX3(1) PY3(NP)=PY3(1) GOTO2200 C 2220 CONTINUE IF(SLOPE1.EQ.CPUMAX)GOTO2221 IF(SLOPE2.EQ.CPUMAX)GOTO2222 GOTO2223 2221 CONTINUE PX3(1)=PXPRE(NP) PY3(1)=PYPOST(1) PX3(NP)=PX3(1) PY3(NP)=PY3(1) GOTO2229 2222 CONTINUE PX3(1)=PXPOST(1) PY3(1)=PYPRE(NP) PX3(NP)=PX3(1) PY3(NP)=PY3(1) GOTO2229 2223 CONTINUE DENOM=SLOPE2-SLOPE1 ANUM=PYPRE(1)-PYPOST(1)-SLOPE1*PXPRE(1)+SLOPE2*PXPOST(1) IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'DEPL') 1WRITE(ICOUT,2224)SLOPE1,SLOPE2,DENOM 2224 FORMAT('SLOPE1,SLOPE2,DENOM = ',3E15.7) IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'DEPL') 1CALL DPWRST('XXX','BUG ') PX3(1)=ANUM/DENOM PY3(1)=PYPRE(1)+SLOPE1*(PX3(1)-PXPRE(1)) PX3(NP)=PX3(1) PY3(NP)=PY3(1) 2229 CONTINUE C 2200 CONTINUE C 2900 CONTINUE NP3=NP C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DEPL')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF GRDEPL--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)DEL 9012 FORMAT('DEL = ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)NP 9014 FORMAT('NP = ',I8) CALL DPWRST('XXX','BUG ') DO9015I=1,NP WRITE(ICOUT,9016)I,PXPRE(I),PYPRE(I),PXPOST(I),PYPOST(I) 9016 FORMAT('I,PXPRE(I),PYPRE(I),PXPOST(I),PYPOST(I) = ', 1I8,4E15.7) CALL DPWRST('XXX','BUG ') 9015 CONTINUE DO9025I=1,NP WRITE(ICOUT,9026)I,PX(I),PY(I),PX3(I),PY3(I) 9026 FORMAT('I,PX(I),PY(I),PX3(I),PY3(I) = ', 1I8,4E15.7) CALL DPWRST('XXX','BUG ') 9025 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 GRDETL(ICTEXT,NCTEXT, 1IFONT,IDIR,ANGLE, 1JFONT,JDIR,ANGLE2, 1PHEIGH,PWIDTH,PVEGAP,PHOGAP, 1JSIZE, 1JHEIG2,JWIDT2,JVEGA2,JHOGA2, 1PHEIG2,PWIDT2,PVEGA2,PHOGA2, 1PXLEC,PXLECG,PYLEC,PYLECG) C C PURPOSE--FOR A SPECIFIC GRAPHICS DEVICE, C AND FOR A GIVEN FONT AND DIRECTION, C DETERMINE THE LENGTH OF THE TEXT STRING IN THE C CHARACTER VECTOR ICTEXT(.), C WHICH CONSISTS OF NCTEXT CHARACTERS. C NOTE--THE LEGNTH IS IN STANDARDIZED COORDINATES C THAT IS, 0.0 TO 100.0. C C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-921-3651 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONCTEXT 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 C CHARACTER*4 ICTEXT CHARACTER*4 IFONT CHARACTER*4 IDIR C DIMENSION ICTEXT(*) 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 IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DETL')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF GRDETL--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)NCTEXT 54 FORMAT('NCTEXT = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,55)(ICTEXT(I),I=1,NCTEXT) 55 FORMAT('(ICTEXT(I),I=1,NCTEXT) = ',25A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,61)IFONT,JFONT 61 FORMAT('IFONT,JFONT= ',A4,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,62)IDIR,JDIR 62 FORMAT('IDIR,JDIR= ',A4,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,64)ANGLE,ANGLE2 64 FORMAT('ANGLE,ANGLE2= ',E15.7,E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,67)PHEIGH,JHEIG2,PHEIG2 67 FORMAT('PHEIGH,JHEIG2,PHEIG2= ',E15.7,I8,E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,68)PWIDTH,JWIDT2,PWIDT2 68 FORMAT('PWIDTH,JWIDT2,PWIDT2= ',E15.7,I8,E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,69)PVEGAP,JVEGA2,PVEGA2 69 FORMAT('PVEGAP,JVEGA2,PVEGA2= ',E15.7,I8,E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,70)PHOGAP,JHOGA2,PHOGA2 70 FORMAT('PHOGAP,JHOGA2,PHOGA2= ',E15.7,I8,E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,71)JSIZE 71 FORMAT('JSIZE= ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,73)PXLEC,PXLECG 73 FORMAT('PXLEC,PXLECG= ',E15.7,E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,74)PYLEC,PYLECG 74 FORMAT('PYLEC,PYLECG= ',E15.7,E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,79)IBUGG4,ISUBG4,IERRG4 79 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C ********************************* C ** STEP 1-- ** C ** CALL THE APPROPRIATE CASE ** C ** AS DICTATED BY THE ** C ** FONT AND DIRECTION ** C ********************************* C IF(IFONT.EQ.'TEKT')GOTO1100 GOTO1200 C C **************************************** C ** STEP 2-- ** C ** TREAT THE DEFAULT FONT ** C ** (= TEKTRONIX HARDWARE-GENERATED) ** C **************************************** C 1100 CONTINUE IF(IDIR.EQ.'HORI')GOTO1110 IF(IDIR.EQ.'VERT')GOTO1120 GOTO1130 C C ************************************** C ** STEP 2.1-- ** C ** TREAT THE HORIZONTAL DIRECTION ** C ************************************** C 1110 CONTINUE CALL GRDETH(ICTEXT,NCTEXT, 1IFONT,IDIR,ANGLE, 1JFONT,JDIR,ANGLE2, 1PHEIGH,PWIDTH,PVEGAP,PHOGAP, 1JSIZE, 1JHEIG2,JWIDT2,JVEGA2,JHOGA2, 1PHEIG2,PWIDT2,PVEGA2,PHOGA2, 1PXLEC,PXLECG,PYLEC,PYLECG) GOTO9000 C C ************************************ C ** STEP 2.2-- ** C ** TREAT THE VERTICAL DIRECTION ** C ************************************ C 1120 CONTINUE CALL GRDETV(ICTEXT,NCTEXT, 1IFONT,IDIR,ANGLE, 1JFONT,JDIR,ANGLE2, 1PHEIGH,PWIDTH,PVEGAP,PHOGAP, 1JSIZE, 1JHEIG2,JWIDT2,JVEGA2,JHOGA2, 1PHEIG2,PWIDT2,PVEGA2,PHOGA2, 1PXLEC,PXLECG,PYLEC,PYLECG) GOTO9000 C C *********************************** C ** STEP 2.3-- ** C ** TREAT THE GENERAL DIRECTION ** C *********************************** C 1130 CONTINUE GOTO9000 C C ****************************** C ** STEP 3-- ** C ** TREAT THE GENERAL FONT ** C ** (SOFTWARE-GENERATED) ** C ****************************** C 1200 CONTINUE IF(IDIR.EQ.'HORI')GOTO1210 IF(IDIR.EQ.'VERT')GOTO1220 GOTO1230 C C ************************************** C ** STEP 3.1-- ** C ** TREAT THE HORIZONTAL DIRECTION ** C ************************************** C 1210 CONTINUE CCCCC CALL GRDETG(ICTEXT,NCTEXT, CCCCC1IFONT,IDIR,ANGLE, CCCCC1JFONT,JDIR,ANGLE2, CCCCC1PHEIGH,PWIDTH,PVEGAP,PHOGAP, CCCCC1JSIZE, CCCCC1JHEIG2,JWIDT2,JVEGA2,JHOGA2, CCCCC1PHEIG2,PWIDT2,PVEGA2,PHOGA2, CCCCC1PXLEC,PXLECG,PYLEC,PYLECG) GOTO9000 C C ************************************ C ** STEP 3.2-- ** C ** TREAT THE VERTICAL DIRECTION ** C ************************************ C 1220 CONTINUE CCCCC CALL GRDETG(ICTEXT,NCTEXT, CCCCC1IFONT,IDIR,ANGLE, CCCCC1JFONT,JDIR,ANGLE2, CCCCC1PHEIGH,PWIDTH,PVEGAP,PHOGAP, CCCCC1JSIZE, CCCCC1JHEIG2,JWIDT2,JVEGA2,JHOGA2, CCCCC1PHEIG2,PWIDT2,PVEGA2,PHOGA2, CCCCC1PXLEC,PXLECG,PYLEC,PYLECG) GOTO9000 C C *********************************** C ** STEP 3.3-- ** C ** TREAT THE GENERAL DIRECTION ** C *********************************** C 1230 CONTINUE CCCCC CALL GRDETG(ICTEXT,NCTEXT, CCCCC1IFONT,IDIR,ANGLE, CCCCC1JFONT,JDIR,ANGLE2, CCCCC1PHEIGH,PWIDTH,PVEGAP,PHOGAP, CCCCC1JSIZE, CCCCC1JHEIG2,JWIDT2,JVEGA2,JHOGA2, CCCCC1PHEIG2,PWIDT2,PVEGA2,PHOGA2, CCCCC1PXLEC,PXLECG,PYLEC,PYLECG) GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DETL')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF GRDETL--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)NCTEXT 9014 FORMAT('NCTEXT = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)(ICTEXT(I),I=1,NCTEXT) 9015 FORMAT('(ICTEXT(I),I=1,NCTEXT) = ',25A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9021)IFONT,JFONT 9021 FORMAT('IFONT,JFONT= ',A4,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9022)IDIR,JDIR 9022 FORMAT('IDIR,JDIR= ',A4,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9024)ANGLE,ANGLE2 9024 FORMAT('ANGLE,ANGLE2= ',E15.7,E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9027)PHEIGH,JHEIG2,PHEIG2 9027 FORMAT('PHEIGH,JHEIG2,PHEIG2= ',E15.7,I8,E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9028)PWIDTH,JWIDT2,PWIDT2 9028 FORMAT('PWIDTH,JWIDT2,PWIDT2= ',E15.7,I8,E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9029)PVEGAP,JVEGA2,PVEGA2 9029 FORMAT('PVEGAP,JVEGA2,PVEGA2= ',E15.7,I8,E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9030)PHOGAP,JHOGA2,PHOGA2 9030 FORMAT('PHOGAP,JHOGA2,PHOGA2= ',E15.7,I8,E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9031)JSIZE 9031 FORMAT('JSIZE= ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9033)PXLEC,PXLECG 9033 FORMAT('PXLEC,PXLECG= ',E15.7,E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9034)PYLEC,PYLECG 9034 FORMAT('PYLEC,PYLECG= ',E15.7,E15.7) 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 GRDRBP(PX,PY,NP,PXSPA,PYSPA,IFACTO, 1IHORPA,IVERPA,IDUPPA,IDDOPA, 1IPATT2,PTHICK,ICOL) C ABOVE LINE ADDED SEPTEMBER, 1987 C C C PURPOSE--FOR A GENERAL GRAPHICS DEVICE, C DRAW A PATTERN WITHIN A BOX C THE PATTERN MAY BE ANY EVENLY-SPACED COMBINATION OF C HORIZONTAL, VERTICAL, AND/OR DIAGONAL PATTERNS C NOTE--THE COORDINATES IN (PX(.),PY(.)) ARE IN C STANDARDIZED (0.0 TO 100.0) UNITS. C NOTE--THERE ARE NP SUCH COORDINATE PAIRS. C C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-921-3651 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--83.6 C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MAY 1983. C UPDATED-- MARCH 1988 (TO FIX PROBLEM DEALING WITH C HOR., DU, DD, DDDU IN NEGATIVE BOXES) C UPDATED --JANUARY 1989. SUN (BY BILL ANDERSON) C UPDATED --JANUARY 1989. POSTSCRIPT (BY ALAN HECKERT) C UPDATED --JANUARY 1989. CGM (BY ALAN HECKERT) C UPDATED --JANUARY 1989. QMS QUIC (BY ALAN HECKERT) C UPDATED --JANUARY 1989. CALCOMP (BY ALAN HECKERT) C UPDATED --JANUARY 1989. ZETA (BY ALAN HECKERT) C UPDATED --OCTOBER 1993. COMMENT OUT CALLS TO GRTRSD C C-----NON-COMMON VARIABLES (GRAPHICS)------------------------------------------- C CHARACTER*4 IHORPA CHARACTER*4 IVERPA CHARACTER*4 IDUPPA CHARACTER*4 IDDOPA C CHARACTER*4 ISUBN0 C CHARACTER*4 IFLAG CHARACTER*4 IPATT2 CHARACTER*4 IFIG CHARACTER*4 ICOL C DIMENSION PX(*) DIMENSION PY(*) C DIMENSION PX2(2) DIMENSION PY2(2) 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 ISUBN0='DRBP' C IFIG='LINE' C IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DRBP')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF GRDRBP--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)NP 52 FORMAT('NP = ',I8) CALL DPWRST('XXX','BUG ') DO55I=1,NP WRITE(ICOUT,56)I,PX(I),PY(I) 56 FORMAT('I,PX(I),PY(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 55 CONTINUE WRITE(ICOUT,57)PXSPA,PYSPA 57 FORMAT('PXSPA,PYSPA = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,58)IFACTO 58 FORMAT('IFACTO = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,61)IHORPA,IVERPA,IDUPPA,IDDOPA 61 FORMAT('IHORPA,IVERPA,IDUPPA,IDDOPA = ',A4,2X,A4,2X,A4,2X,A4) 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 C *************************************************** C ** STEP 1-- ** C ** DRAW THE HORIZONTAL STRIPES (IF CALLED FOR) ** C *************************************************** C IF(IHORPA.EQ.'ON')GOTO1100 GOTO1190 1100 CONTINUE CCCCC THE FOLLOWING 2 LINES WERE INSERTED MARCH 1988 ASIGN=1.0 IF(PY(3).LT.PY(1))ASIGN=(-1.0) PX2(1)=PX(1) PX2(2)=PX(3) YCOMP=PY(1) C SEPTEMBER,1987 IFLAG='ON' NP2=2 C 1120 CONTINUE CCCCC YCOMP=YCOMP+PYSPA MARCH 1988 CCCCC IF(YCOMP.GE.PY(3))GOTO1190 MARCH 1988 CCCCC THE FOLLOWING 3 LINES WERE INSERTED MARCH 1988 YCOMP=YCOMP+ASIGN*PYSPA IF(ASIGN.GE.0.0.AND.YCOMP.GE.PY(3))GOTO1190 IF(ASIGN.LT.0.0.AND.YCOMP.LE.PY(3))GOTO1190 PY2(1)=YCOMP PY2(2)=YCOMP IF(IBUGG4.EQ.'ON')WRITE(ICOUT,1122)PX2(1),PY2(1),PX2(2),PY2(2) 1122 FORMAT('PX2(1),PY2(1), PX2(2),PY2(2) = ',2E15.7,4X,2E15.7) IF(IBUGG4.EQ.'ON')CALL DPWRST('XXX','BUG ') CCCCC CALL GRTRSD(PX2(1),PY2(1),IX1,IY1,ISUBN0) CCCCC CALL GRTRSD(PX2(2),PY2(2),IX2,IY2,ISUBN0) CCCCC CALL GRDRLI(IX1,IY1,IX2,IY2,PX2(1),PY2(1),PX2(2),PY2(2),IFACTO) CALL DPDRPL(PX2,PY2,NP2, 1IFIG,IPATT2,PTHICK,ICOL, 1JPATT,JTHICK,PTHIC2,JCOL,IFLAG) IFLAG='OFF' GOTO1120 1190 CONTINUE C C *************************************************** C ** STEP 2-- ** C ** DRAW THE VERTICAL STRIPES (IF CALLED FOR) ** C *************************************************** C IF(IVERPA.EQ.'ON')GOTO1200 GOTO1290 1200 CONTINUE CCCCC THE FOLLOWING 2 LINES WERE INSERTED MARCH 1988 ASIGN=1.0 IF(PX(3).LT.PX(1))ASIGN=(-1.0) PY2(1)=PY(1) PY2(2)=PY(3) XCOMP=PX(1) C SEPTEMBER, 1987 IFLAG='ON' NP2=2 C 1220 CONTINUE CCCCC XCOMP=XCOMP+PXSPA MARCH 1988 CCCCC IF(XCOMP.GE.PX(3))GOTO1290 MARCH 1988 CCCCC THE FOLLOWING 3 LINES WERE INSERTED MARCH 1988 XCOMP=XCOMP+ASIGN*PXSPA IF(ASIGN.GE.0.0.AND.XCOMP.GE.PX(3))GOTO1290 IF(ASIGN.LT.0.0.AND.XCOMP.LE.PX(3))GOTO1290 PX2(1)=XCOMP PX2(2)=XCOMP IF(IBUGG4.EQ.'ON')WRITE(ICOUT,1222)PX2(1),PY2(1),PX2(2),PY2(2) 1222 FORMAT('PX2(1),PY2(1), PX2(2),PY2(2) = ',2E15.7,4X,2E15.7) IF(IBUGG4.EQ.'ON')CALL DPWRST('XXX','BUG ') CCCCC CALL GRTRSD(PX2(1),PY2(1),IX1,IY1,ISUBN0) CCCCC CALL GRTRSD(PX2(2),PY2(2),IX2,IY2,ISUBN0) CCCCC CALL GRDRLI(IX1,IY1,IX2,IY2,PX2(1),PY2(1),PX2(2),PY2(2),IFACTO) CALL DPDRPL(PX2,PY2,NP2, 1IFIG,IPATT2,PTHICK,ICOL, 1JPATT,JTHICK,PTHIC2,JCOL,IFLAG) IFLAG='OFF' GOTO1220 1290 CONTINUE C C ****************************************************** C ** STEP 3-- ** C ** DRAW THE UP-DIAGONAL STRIPES (IF CALLED FOR) ** C ****************************************************** C IF(IDUPPA.EQ.'ON')GOTO1300 GOTO1390 1300 CONTINUE C SEPTEMBER, 1987 NP2=2 IFLAG='ON' C CCCCC THE FOLLOWING 2 LINES WERE INSERTED MARCH 1988 CCCCC PLUS OTHER SUBSTITUTIONS IN THIS SECTION WERE ALSO MADE. MARCH 1988 PSTART=PY(1) PSTOP=PY(3) IF(PY(3).LT.PY(1))PSTART=PY(3) IF(PY(3).LT.PY(1))PSTOP=PY(1) YCOMP=PSTART-(PX(3)-PX(1))*(PYSPA/PXSPA)-PYSPA 1320 CONTINUE YCOMP=YCOMP+PYSPA IF(YCOMP.GT.PSTOP)GOTO1390 C YCOMPT=YCOMP YCOMP1=YCOMP IF(YCOMPT.LT.PSTART)YCOMP1=PSTART XCOMP1=PX(1) IF(YCOMPT.LT.PSTART)XCOMP1=PX(1)+(PSTART-YCOMPT)*(PXSPA/PYSPA) C YCOMPT=YCOMP+(PX(3)-PX(1))*(PYSPA/PXSPA) YCOMP2=YCOMP+(PX(3)-PX(1))*(PYSPA/PXSPA) IF(YCOMPT.GT.PSTOP)YCOMP2=PSTOP XCOMP2=PX(3) IF(YCOMPT.GT.PSTOP)XCOMP2=PX(3)-(YCOMPT-PSTOP)*(PXSPA/PYSPA) C PX2(1)=XCOMP1 PX2(2)=XCOMP2 PY2(1)=YCOMP1 PY2(2)=YCOMP2 C IF(IBUGG4.EQ.'ON')WRITE(ICOUT,1322)PX2(1),PY2(1),PX2(2),PY2(2) 1322 FORMAT('PX2(1),PY2(1), PX2(2),PY2(2) = ',2E15.7,4X,2E15.7) IF(IBUGG4.EQ.'ON')CALL DPWRST('XXX','BUG ') CCCCC CALL GRTRSD(PX2(1),PY2(1),IX1,IY1,ISUBN0) CCCCC CALL GRTRSD(PX2(2),PY2(2),IX2,IY2,ISUBN0) CCCCC CALL GRDRLI(IX1,IY1,IX2,IY2,PX2(1),PY2(1),PX2(2),PY2(2),IFACTO) CALL DPDRPL(PX2,PY2,NP2, 1IFIG,IPATT2,PTHICK,ICOL, 1JPATT,JTHICK,PTHIC2,JCOL,IFLAG) IFLAG='OFF' GOTO1320 C 1390 CONTINUE C C ****************************************************** C ** STEP 4-- ** C ** DRAW THE DOWN-DIAGONAL STRIPES (IF CALLED FOR) ** C ****************************************************** C IF(IDDOPA.EQ.'ON')GOTO1400 GOTO1490 1400 CONTINUE C SEPTEMBER,1987 NP2=2 IFLAG='ON' C CCCCC THE FOLLOWING 4 LINES WERE INSERTED MARCH 1988 CCCCC PLUS OTHER SUBSTITUTIONS IN THIS SECTION WERE ALSO MADE. MARCH 1988 PSTART=PY(1) PSTOP=PY(3) IF(PY(3).LT.PY(1))PSTART=PY(3) IF(PY(3).LT.PY(1))PSTOP=PY(1) YCOMP=PSTART-(PX(3)-PX(1))*(PYSPA/PXSPA)-PYSPA 1420 CONTINUE YCOMP=YCOMP+PYSPA IF(YCOMP.GT.PSTOP)GOTO1490 C YCOMPT=YCOMP YCOMP2=YCOMP IF(YCOMPT.LT.PSTART)YCOMP2=PSTART XCOMP2=PX(3) IF(YCOMPT.LT.PSTART)XCOMP2=PX(3)-(PSTART-YCOMPT)*(PXSPA/PYSPA) C YCOMPT=YCOMP+(PX(3)-PX(1))*(PYSPA/PXSPA) YCOMP1=YCOMP+(PX(3)-PX(1))*(PYSPA/PXSPA) IF(YCOMPT.GT.PSTOP)YCOMP1=PSTOP XCOMP1=PX(1) IF(YCOMPT.GT.PSTOP)XCOMP1=PX(1)+(YCOMPT-PSTOP)*(PXSPA/PYSPA) C PX2(1)=XCOMP1 PX2(2)=XCOMP2 PY2(1)=YCOMP1 PY2(2)=YCOMP2 C IF(IBUGG4.EQ.'ON')WRITE(ICOUT,1422)PX2(1),PY2(1),PX2(2),PY2(2) 1422 FORMAT('PX2(1),PY2(1), PX2(2),PY2(2) = ',2E15.7,4X,2E15.7) IF(IBUGG4.EQ.'ON')CALL DPWRST('XXX','BUG ') CCCCC CALL GRTRSD(PX2(1),PY2(1),IX1,IY1,ISUBN0) CCCCC CALL GRTRSD(PX2(2),PY2(2),IX2,IY2,ISUBN0) CCCCC CALL GRDRLI(IX1,IY1,IX2,IY2,PX2(1),PY2(1),PX2(2),PY2(2),IFACTO) CALL DPDRPL(PX2,PY2,NP2, 1IFIG,IPATT2,PTHICK,ICOL, 1JPATT,JTHICK,PTHIC2,JCOL,IFLAG) IFLAG='OFF' GOTO1420 C 1490 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DRBP')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF GRDRBP--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)NP 9012 FORMAT('NP = ',I8) CALL DPWRST('XXX','BUG ') DO9015I=1,NP WRITE(ICOUT,9016)I,PX(I),PY(I) 9016 FORMAT('I,PX(I),PY(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 9015 CONTINUE WRITE(ICOUT,9017)PXSPA,PYSPA 9017 FORMAT('PXSPA,PYSPA = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9018)IFACTO 9018 FORMAT('IFACTO = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9021)IHORPA,IVERPA,IDUPPA,IDDOPA 9021 FORMAT('IHORPA,IVERPA,IDUPPA,IDDOPA = ',A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 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 GRDRPG(PX,PY,NP,ISTRIN,NCSTRI, 1IFIG,IPATT,IFONT,ICASE,IJUST,IDIR,ANGLE,IFILL,ICOL, 1JPATT,JFONT,JCASE,JJUST,JDIR,ANGLE2,JFILL,JCOL, 1PTHICK,JTHICK,PTHIC2, 1PHEIGH,PWIDTH,PVEGAP,PHOGAP, 1PHEIG2,PWIDT2,PVEGA2,PHOGA2, 1ISYMBL,ISPAC) C C PURPOSE--FOR A SPECIFIC GRAPHICS DEVICE, C DRAW THE GENERAL (GENERAL FONT AND GENERAL DIRECTION) C POLYMARKER WHOSE COORDINATES C ARE GIVEN IN (PX(.),PY(.)). C NOTE--THE COORDINATES IN (PX(.),PY(.)) ARE IN C STANDARDIZED (0.0 TO 100.0) UNITS. C NOTE--THERE ARE NP SUCH COORDINATE PAIRS. C C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-921-3651 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--83.6 C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MAY 1983. C UPDATED --SEPTEMBER 1999. SUPPORT FOR MULTIPLOT SCALE C FACTOR C C-----NON-COMMON VARIABLES (GRAPHICS)------------------------------------------- C CHARACTER*4 IFIG CHARACTER*4 IPATT CHARACTER*4 IPATTZ CHARACTER*4 IFONT CHARACTER*4 ICASE CHARACTER*4 IJUST CHARACTER*4 IDIR CHARACTER*4 IFILL CHARACTER*4 ICOL C CHARACTER*4 ISYMBL CHARACTER*4 ISPAC C CHARACTER*4 IBUGD2 C CHARACTER*4 ISTRIN C CHARACTER*4 IFOUND CHARACTER*4 IERROR C DIMENSION PX(*) DIMENSION PY(*) DIMENSION ISTRIN(*) C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOGR.INC' INCLUDE 'DPCOBE.INC' CHARACTER*4 IMPSW2 COMMON/CMISC3/ 1IMPSW2 COMMON /RMISC2/ 1AMPSCH, AMPSCW 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' IFOUND='-999' IERROR='-999' C IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DRPG')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF GRDRPG--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)NP 52 FORMAT('NP = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)IMANUF 53 FORMAT('IMANUF = ',A4) CALL DPWRST('XXX','BUG ') DO55I=1,NP WRITE(ICOUT,56)PX(I),PY(I) 56 FORMAT('PX(I),PY(I) = ',E15.7,E15.7) CALL DPWRST('XXX','BUG ') 55 CONTINUE WRITE(ICOUT,58)IFIG 58 FORMAT('IFIG = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,59)IPATT,JPATT 59 FORMAT('IPATT,JPATT = ',A4,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,60)IFONT,JFONT 60 FORMAT('IFONT,JFONT = ',A4,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,61)ICASE,JCASE 61 FORMAT('ICASE,JCASE = ',A4,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,62)IJUST,JJUST 62 FORMAT('IJUST,JJUST = ',A4,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,63)IDIR,ANGLE,JDIR 63 FORMAT('IDIR,ANGLE,JDIR = ',A4,2X,E15.7,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,64)ICOL,JCOL 64 FORMAT('ICOL,JCOL = ',A4,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,66)PTHICK,JTHICK,PTHIC2 66 FORMAT('PTHICK,JTHICK,PTHIC2 = ',E15.7,I8,E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,67)PHEIGH,PWIDTH,PVEGAP,PHOGAP 67 FORMAT('PHEIGH,PWIDTH,PVEGAP,PHOGAP = ',4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,68)PHEIG2,PWIDT2,PVEGA2,PHOGA2 68 FORMAT('PHEIG2,PWIDT2,PVEGA2,PHOGA2 = ',4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,71)ISYMBL,ISPAC 71 FORMAT('ISYMBL,ISPAC = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,72)IFILL 72 FORMAT('IFILL = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,78)IFOUND,IBUGD2,IERROR 78 FORMAT('IFOUND,IBUGD2,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,79)IBUGG4,ISUBG4,IERRG4 79 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 90 CONTINUE C CALL GRTRPG(IPATT,ISTRIN,NCSTRI) C HEIGHT=PHEIGH+PVEGAP WIDTH=PWIDTH+PHOGAP C IBUGD2=IBUGG4 HMAX=100.0 VMAX=100.0 AMAX=360.0 IPATTZ='SOLI' JPATTZ=96 C DO1100I=1,NP X0=PX(I) Y0=PY(I) CALL DPSCR7(ISTRIN,NCSTRI,X0,Y0, 1IFONT,ICASE,IJUST,ANGLE,HMAX,VMAX,AMAX,WIDTH,HEIGHT, 1PHEIGH,PWIDTH,PVEGAP,PHOGAP, 1PHEIG2,PWIDT2,PVEGA2,PHOGA2, 1ANUMHP,ANUMVP, 1IPATTZ,PTHICK,ICOL, 1JPATTZ,JTHICK,PTHIC2,JCOL, 1ISYMBL,ISPAC, 1IFILL, 1IMPSW2,AMPSCH,AMPSCW, 1XEND,YEND,IFOUND,IBUGD2,IERROR) 1100 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DRPG')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF GRDRPG--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)NP 9012 FORMAT('NP = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)IMANUF 9013 FORMAT('IMANUF = ',A4) CALL DPWRST('XXX','BUG ') DO9015I=1,NP WRITE(ICOUT,9016)PX(I),PY(I) 9016 FORMAT('PX(I),PY(I) = ',E15.7,E15.7) CALL DPWRST('XXX','BUG ') 9015 CONTINUE WRITE(ICOUT,9018)IFIG 9018 FORMAT('IFIG = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9019)IPATT,JPATT 9019 FORMAT('IPATT,JPATT = ',A4,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9020)IFONT,JFONT 9020 FORMAT('IFONT,JFONT = ',A4,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9021)ICASE,JCASE 9021 FORMAT('ICASE,JCASE = ',A4,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9022)IJUST,JJUST 9022 FORMAT('IJUST,JJUST = ',A4,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9023)IDIR,ANGLE,JDIR 9023 FORMAT('IDIR,ANGLE,JDIR = ',A4,2X,E15.7,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9024)ICOL,JCOL 9024 FORMAT('ICOL,JCOL = ',A4,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9026)PTHICK,JTHICK,PTHIC2 9026 FORMAT('PTHICK,JTHICK,PTHIC2 = ',E15.7,I8,E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9027)PHEIGH,PWIDTH,PVEGAP,PHOGAP 9027 FORMAT('PHEIGH,PWIDTH,PVEGAP,PHOGAP = ',4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9028)PHEIG2,PWIDT2,PVEGA2,PHOGA2 9028 FORMAT('PHEIG2,PWIDT2,PVEGA2,PHOGA2 = ',4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9031)ISYMBL,ISPAC 9031 FORMAT('ISYMBL,ISPAC = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9032)IFILL 9032 FORMAT('IFILL = ',A4) 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 GRDRPM(PX,PY,NP, 1IFIG,IPATT,IFONT,ICASE,IJUST,IDIR,ANGLE,IFILL,ICOL, 1JPATT,JFONT,JCASE,JJUST,JDIR,ANGLE2,JFILL,JCOL, 1PTHICK,JTHICK,PTHIC2, 1PHEIGH,PWIDTH,PVEGAP,PHOGAP, 1PHEIG2,PWIDT2,PVEGA2,PHOGA2, 1IMPSW2,AMPSCH,AMPSCW, 1ISYMBL,ISPAC) C C PURPOSE--FOR A SPECIFIC GRAPHICS DEVICE, C DRAW THE POLYMARKER WHOSE COORDINATES C ARE GIVEN IN (PX(.),PY(.)). C NOTE--THE COORDINATES IN (PX(.),PY(.)) ARE IN C STANDARDIZED (0.0 TO 100.0) UNITS. C NOTE--THERE ARE NP SUCH COORDINATE PAIRS. C C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-921-3651 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--83.6 C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MAY 1983. C UPDATED --MARCH 1992. USE GRWRTH FOR STRINGS LONGER THAN C ONE CHARACTER. HOWEVER NEED TO TEST C FOR SPECIAL PLOT CHARACTERS (ALAN) C UPDATED --AUGUST 1992. UPDATED SYMBOL LIST C HANDLE ARROW, VECTORS DIFFERENTLY C UPDATED --AUGUST 1993. HARDWARE TEXT-HANDLE CASE C UPDATED --FEBRUARY 1994. VECTOR CASE FOR SOFTWARE FONT C UPDATED --NOVEMBER 1995. CASE CONVERSION IN DPDRPM C UPDATED --DECEMBER 1995. BUG WITH LOWER CASE "BLANK" C UPDATED --AUGUST 1996. DEVICE FONT COMMAND C UPDATED --MARCH 1997. BUG WITH LOWER CASE "BLANK" C FIXED FOR SOFTWARE FONT C UPDATED --SEPTEMBER1999. ARGUMENT LIST TO DPWRTE C C-----NON-COMMON VARIABLES (GRAPHICS)------------------------------------------- C CHARACTER*4 IFONT CHARACTER*4 ICASE CHARACTER*4 IJUST CHARACTER*4 IDIR CHARACTER*4 IFILL CHARACTER*4 ICOL CHARACTER*4 IFIG CHARACTER*4 IPATT C CHARACTER*4 ISYMBL CHARACTER*4 ISPAC CHARACTER*4 IMPSW2 C CHARACTER*4 ISTRIN C CHARACTER*4 ITRCSW CCCCC AUGUST 1993. ADD FOLLOWING LINE CHARACTER*1 ICTEMP C DIMENSION PX(*) DIMENSION PY(*) C DIMENSION ISTRIN(10) C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOGR.INC' INCLUDE 'DPCOBE.INC' CCCCC THE FOLLOWING COMMON BLOCK WAS ADDED AUGUST 1992. COMMON /RWIND/ 1PWXMIN,PWXMAX,PWYMIN,PWYMAX,PWZMIN,PWZMAX, 1WWXMIN,WWXMAX,WWYMIN,WWYMAX,WWZMIN,WWZMAX 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.'DRPM')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF GRDRPM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)NP 52 FORMAT('NP = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)IMANUF 53 FORMAT('IMANUF = ',A4) CALL DPWRST('XXX','BUG ') DO55I=1,NP WRITE(ICOUT,56)PX(I),PY(I) 56 FORMAT('PX(I),PY(I) = ',E15.7,E15.7) CALL DPWRST('XXX','BUG ') 55 CONTINUE WRITE(ICOUT,58)IFIG 58 FORMAT('IFIG = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,59)IPATT,JPATT 59 FORMAT('IPATT,JPATT = ',A4,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,60)IFONT,JFONT 60 FORMAT('IFONT,JFONT = ',A4,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,61)ICASE,JCASE 61 FORMAT('ICASE,JCASE = ',A4,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,62)IJUST,JJUST 62 FORMAT('IJUST,JJUST = ',A4,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,63)IDIR,ANGLE,JDIR 63 FORMAT('IDIR,ANGLE,JDIR = ',A4,2X,E15.7,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,64)ICOL,JCOL 64 FORMAT('ICOL,JCOL = ',A4,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,66)PTHICK,JTHICK,PTHIC2 66 FORMAT('PTHICK,JTHICK,PTHIC2 = ',E15.7,I8,E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,67)PHEIGH,PWIDTH,PVEGAP,PHOGAP 67 FORMAT('PHEIGH,PWIDTH,PVEGAP,PHOGAP = ',4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,68)PHEIG2,PWIDT2,PVEGA2,PHOGA2 68 FORMAT('PHEIG2,PWIDT2,PVEGA2,PHOGA2 = ',4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,71)ISYMBL,ISPAC 71 FORMAT('ISYMBL,ISPAC = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,79)IBUGG4,ISUBG4,IERRG4 79 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C ************************************************ C ** STEP 1-- ** C ** CALL THE APPROPRIATE SUBROUTINE ** C ** DEPENDING ON WHETHER HAVE TEKTRONIX FONT ** C ** OR A GENERAL FONT. ** C ************************************************ C C MARCH 1992. FOLLOWING 3 LINES ADDED TO BLANK OUT ISTRIN. DO100I=1,10 ISTRIN(I)=' ' 100 CONTINUE C CCCCC NOVEMBER 1995. MODIFY FOLLOWING LINE. CCCCC CALL GRTRPG(IPATT,ISTRIN,NCSTRI) CALL GRTRPG(ISYMBL,ISTRIN,NCSTRI) C C MARCH 1997. PUT FOLLOWING LINES FROM BELOW HERE TO FIX C BUG WITH CHARACTER BLANK WHEN SOFTWARE FONT USED. IF(IPATT.EQ.'BLAN')GOTO200 IF(IPATT.EQ.'BL ')GOTO200 IF(IPATT.EQ.'NONE')GOTO200 IF(IPATT.EQ.'NO ')GOTO200 C IF(IFONT.EQ.'TEKT'.AND.NCSTRI.LE.1)GOTO200 IF(IFONT.NE.'TEKT')GOTO300 C C CHECK FOR SPECIAL PLOT CHARACTERS C IF(IPATT.EQ.'TRIA')GOTO300 IF(IPATT.EQ.'TR ')GOTO300 IF(IPATT.EQ.'SQUA')GOTO300 IF(IPATT.EQ.'SQ ')GOTO300 IF(IPATT.EQ.'DIAM')GOTO300 IF(IPATT.EQ.'DI ')GOTO300 CCCCC IF(IPATT.EQ.'HEXA')GOTO300 IF(IPATT.EQ.'CIRC')GOTO300 IF(IPATT.EQ.'CI ')GOTO300 IF(IPATT.EQ.'CUBE')GOTO300 IF(IPATT.EQ.'PYRA')GOTO300 C AUGUST 1992. UNCOMMENTED FOLLOWING 2 LINES IF(IPATT.EQ.'REVT')GOTO300 IF(IPATT.EQ.'RT ')GOTO300 IF(IPATT.EQ.'TRIR')GOTO300 C AUGUST 1992. FOLLOWING LINE ADDED. IF(IPATT.EQ.'TRII')GOTO300 CCCCC DECEMBER 1995. BLANK SHOULD GO TO GRDRPH, NOT GRDRPG CCCCC MARCH 1997. MOVE FOLLOWING CODE (SAME BUG FOR SOFTWARE FONT) CCCCC IF(IPATT.EQ.'BLAN')GOTO300 CCCCC IF(IPATT.EQ.'BL ')GOTO300 CCCCC IF(IPATT.EQ.'NONE')GOTO300 CCCCC IF(IPATT.EQ.'NO ')GOTO300 CCCCC IF(IPATT.EQ.'BLAN')GOTO200 CCCCC IF(IPATT.EQ.'BL ')GOTO200 CCCCC IF(IPATT.EQ.'NONE')GOTO200 CCCCC IF(IPATT.EQ.'NO ')GOTO200 IF(IPATT.EQ.'BOX ')GOTO300 IF(IPATT.EQ.'STAR')GOTO300 IF(IPATT.EQ.'ST ')GOTO300 IF(IPATT.EQ.'AU ')GOTO300 IF(IPATT.EQ.'AD ')GOTO300 CCCCC IF(IPATT.EQ.'VB ')GOTO300 IF(IPATT.EQ.'POIN')GOTO300 IF(IPATT.EQ.'PT ')GOTO300 IF(IPATT.EQ.'PO ')GOTO300 C AUGUST 1992. ADD ARROW CASE. C THIS CASE HANDLED SEPARATELY. IF(IPATT.EQ.'ARRO')GOTO500 IF(IPATT.EQ.'ARRH')GOTO500 IF(IPATT.EQ.'VECT')GOTO500 C IF(IPATT.EQ.'DEGR')GOTO300 C C CHECK FOR GREEK CHARACTERS C IF(IPATT.EQ.'ALPH')GOTO300 IF(IPATT.EQ.'BETA')GOTO300 IF(IPATT.EQ.'GAMM')GOTO300 IF(IPATT.EQ.'DELT')GOTO300 IF(IPATT.EQ.'EPSI')GOTO300 IF(IPATT.EQ.'ZETA')GOTO300 IF(IPATT.EQ.'ETA ')GOTO300 IF(IPATT.EQ.'THET')GOTO300 IF(IPATT.EQ.'IOTA')GOTO300 IF(IPATT.EQ.'KAPP')GOTO300 IF(IPATT.EQ.'LAMB')GOTO300 IF(IPATT.EQ.'MU ')GOTO300 IF(IPATT.EQ.'NU ')GOTO300 IF(IPATT.EQ.'XI ')GOTO300 IF(IPATT.EQ.'OMIC')GOTO300 IF(IPATT.EQ.'PI ')GOTO300 IF(IPATT.EQ.'RHO ')GOTO300 IF(IPATT.EQ.'SIGM')GOTO300 IF(IPATT.EQ.'TAU ')GOTO300 IF(IPATT.EQ.'UPSI')GOTO300 IF(IPATT.EQ.'PHI ')GOTO300 IF(IPATT.EQ.'CHI ')GOTO300 IF(IPATT.EQ.'PSI ')GOTO300 IF(IPATT.EQ.'OMEG')GOTO300 C C CHECK FOR MATH SYMBOLS C IF(IPATT.EQ.'PART')GOTO300 IF(IPATT.EQ.'INTE')GOTO300 IF(IPATT.EQ.'CINT')GOTO300 IF(IPATT.EQ.'SUMM')GOTO300 IF(IPATT.EQ.'PROD')GOTO300 IF(IPATT.EQ.'INFI')GOTO300 IF(IPATT.EQ.'+- ')GOTO300 IF(IPATT.EQ.'-+ ')GOTO300 IF(IPATT.EQ.'TIME')GOTO300 IF(IPATT.EQ.'DOTP')GOTO300 IF(IPATT.EQ.'DEL ')GOTO300 IF(IPATT.EQ.'DIVI')GOTO300 IF(IPATT.EQ.'LT ')GOTO300 IF(IPATT.EQ.'GT ')GOTO300 IF(IPATT.EQ.'LTEQ')GOTO300 IF(IPATT.EQ.'GTEQ')GOTO300 IF(IPATT.EQ.'NOT=')GOTO300 IF(IPATT.EQ.'APPR')GOTO300 IF(IPATT.EQ.'EQUI')GOTO300 IF(IPATT.EQ.'VARI')GOTO300 IF(IPATT.EQ.'TILD')GOTO300 IF(IPATT.EQ.'CARA')GOTO300 IF(IPATT.EQ.'PRIM')GOTO300 IF(IPATT.EQ.'RADI')GOTO300 IF(IPATT.EQ.'LRAD')GOTO300 IF(IPATT.EQ.'BRAD')GOTO300 IF(IPATT.EQ.'SUBS')GOTO300 IF(IPATT.EQ.'SUPE')GOTO300 IF(IPATT.EQ.'UNSB')GOTO300 IF(IPATT.EQ.'UNSP')GOTO300 IF(IPATT.EQ.'UNIO')GOTO300 IF(IPATT.EQ.'INTR')GOTO300 IF(IPATT.EQ.'ELEM')GOTO300 IF(IPATT.EQ.'THEX')GOTO300 IF(IPATT.EQ.'THFO')GOTO300 C C CHECK FOR MISCELLANEOUS SYMBOLS C IF(IPATT.EQ.'LAPO')GOTO300 IF(IPATT.EQ.'RAPO')GOTO300 IF(IPATT.EQ.'LBRA')GOTO300 IF(IPATT.EQ.'RBRA')GOTO300 IF(IPATT.EQ.'LCBR')GOTO300 IF(IPATT.EQ.'RCBR')GOTO300 IF(IPATT.EQ.'LELB')GOTO300 IF(IPATT.EQ.'RELB')GOTO300 IF(IPATT.EQ.'RACC')GOTO300 IF(IPATT.EQ.'LACC')GOTO300 IF(IPATT.EQ.'BREV')GOTO300 IF(IPATT.EQ.'LQUO')GOTO300 IF(IPATT.EQ.'NASP')GOTO300 IF(IPATT.EQ.'IASP')GOTO300 IF(IPATT.EQ.'RARR')GOTO300 IF(IPATT.EQ.'LARR')GOTO300 IF(IPATT.EQ.'UARR')GOTO300 IF(IPATT.EQ.'DARR')GOTO300 IF(IPATT.EQ.'PARA')GOTO300 IF(IPATT.EQ.'DAGG')GOTO300 IF(IPATT.EQ.'DDAG')GOTO300 IF(IPATT.EQ.'VBAR')GOTO300 IF(IPATT.EQ.'DVBA')GOTO300 IF(IPATT.EQ.'LVBA')GOTO300 IF(IPATT.EQ.'LHBA')GOTO300 IF(IPATT.EQ.'BAR ')GOTO300 IF(IPATT.EQ.'DEL ')GOTO300 CCCCC SEPTEMBER 1995. PIXEL IS SPECIAL CASE (TURN A SINGLE POINT ON). CCCCC IMPLEMENTED IN THE GRDRPH ROUTINE. IF(IPATT.EQ.'PIXE')GOTO200 IF(IPATT.EQ.'DEL ')GOTO300 C IF(IFONT.EQ.'TEKT'.AND.NCSTRI.GE.2)GOTO400 GOTO300 C C ONE CHARACTER, HARDWARE TEXT C 200 CONTINUE CCCCC AUGUST 1993. SET CASE CORRECTLY. NOTE THAT NO ACTION REQUIRED CCCCC IF CASE IS UPPER SINCE PLOT SYMBOL STORED IN UPPER CASE. CCCCC NOVEMBER 1995. CASE CONVERSION PERFORMED IN DPDRPM. CCCCC IF(ICASE.EQ.'LOWE')THEN CCCCC ICTEMP=ISYMBL(1:1) CCCCC CALL DPCOAN(ICTEMP,IVALT) CCCCC IF(IVALT.GE.65.AND.IVALT.LE.90)IVALT=IVALT+32 CCCCC CALL DPCONA(IVALT,ICTEMP) CCCCC ISYMBL(1:1)=ICTEMP CCCCC END IF CCCCC END CHANGE CCCCC FOLLOWING SECTION MODIFIED AUGUST 1996. IF(IGFONT.EQ.'OFF')THEN ELSE IF(IPATT.EQ.'BLAN')GOTO299 IF(IPATT.EQ.'BL ')GOTO299 IF(IPATT.EQ.'NONE')GOTO299 IF(IPATT.EQ.'NO ')GOTO299 IF(IGFONT.NE.'TEKT')GOTO300 299 CONTINUE ENDIF C CALL GRDRPH(PX,PY,NP, 1IFIG,IPATT,IFONT,ICASE,IJUST,IDIR,ANGLE,IFILL,ICOL, 1JPATT,JFONT,JCASE,JJUST,JDIR,ANGLE2,JFILL,JCOL, 1PTHICK,JTHICK,PTHIC2, 1PHEIGH,PWIDTH,PVEGAP,PHOGAP, 1PHEIG2,PWIDT2,PVEGA2,PHOGA2, 1ISYMBL,ISPAC) GOTO9000 C C MARCH 1992. FOLLOWING LINE MODOIFIED. CCCCC IF(IFONT.NE.'TEKT'.OR.NCSTRI.GE.2) C SOFTWARE TEXT (OR SPECIAL SYMBOL DRAWN WITH SOFTWARE TEXT) C 300 CONTINUE C FEBRUARY 1994. ARROW CASE HANDLED SEPARATELY. IF(IPATT.EQ.'ARRO')GOTO500 IF(IPATT.EQ.'ARRH')GOTO500 IF(IPATT.EQ.'VECT')GOTO500 C CALL GRDRPG(PX,PY,NP,ISTRIN,NCSTRI, 1IFIG,IPATT,IFONT,ICASE,IJUST,IDIR,ANGLE,IFILL,ICOL, 1JPATT,JFONT,JCASE,JJUST,JDIR,ANGLE2,JFILL,JCOL, 1PTHICK,JTHICK,PTHIC2, 1PHEIGH,PWIDTH,PVEGAP,PHOGAP, 1PHEIG2,PWIDT2,PVEGA2,PHOGA2, 1ISYMBL,ISPAC) GOTO9000 C C MARCH 1992. FOLLOWING BLOCK OF CODE ADDED. C MORE THAN ONE CHARACTER, HARDWARE TEXT (BUT NOT SPECIAL CHARACTER) C 400 CONTINUE IF(ISTRIN(NCSTRI-1).EQ.'('.AND.ISTRIN(NCSTRI).EQ.')') 1NCSTRI=NCSTRI-2 CCCCC AUGUST 1993. SET CASE CORRECTLY. NOTE THAT NO ACTION REQUIRED CCCCC IF CASE IS UPPER SINCE PLOT SYMBOL STORED IN UPPER CASE. CCCCC NOVEMBER 1995. PLOT SYMBOL CAN BE STORED WITH CASE ASIS IF(ICASE.EQ.'LOWE')THEN DO410I=1,NCSTRI ICTEMP=ISTRIN(I)(1:1) CALL DPCOAN(ICTEMP,IVALT) IF(IVALT.GE.65.AND.IVALT.LE.90)IVALT=IVALT+32 CALL DPCONA(IVALT,ICTEMP) ISTRIN(I)(1:1)=ICTEMP 410 CONTINUE DO420I=1,4 ISYMBL(I:I)=ISTRIN(I)(1:1) 420 CONTINUE ELSEIF(ICASE.EQ.'UPPE')THEN DO430I=1,NCSTRI ICTEMP=ISTRIN(I)(1:1) CALL DPCOAN(ICTEMP,IVALT) IF(IVALT.GE.97.AND.IVALT.LE.122)IVALT=IVALT-32 CALL DPCONA(IVALT,ICTEMP) ISTRIN(I)(1:1)=ICTEMP 430 CONTINUE DO440I=1,4 ISYMBL(I:I)=ISTRIN(I)(1:1) 440 CONTINUE END IF CCCCC END CHANGE DO1000I=1,NP PX1=PX(I) PY1=PY(I) CALL DPWRTE(PX1,PY1,ISTRIN,NCSTRI, 1IFONT,ICASE,IJUST,IDIR,ANGLE,IFILL,ICOL, 1PHEIGH,PWIDTH,PVEGAP,PHOGAP,PTHICK, 1ISYMBL,ISPAC, 1IMPSW2,AMPSCH,AMPSCW, 1PX99,PY99) 1000 CONTINUE GOTO9000 C C AUGUST 1992. HANDLE ARROW AND VECTOR CASE SEPARATELY. THIS C CASE WILL USE THE DPARR3 ROUTINE (I COULDN'T GET IT TO WORK C RIGHT THROUGH THE FONT DRAWING ROUTINES). SINCE THE ARROW IS C DRAWN AT THE ANGLE DETERMINED BY TWO POINTS, THIS CASE WILL BE C HANDLED SEPARATELY. IF THE PLOT SYMBOL IS "VECTOR", NO POINT IS C DRAWN AT THE FIRST POINT. IF THE PLOT SYMBOL IS "ARROW" OR "ARRH", C DRAW THE ARROW HOIRZONTALLY (I.E., 0 DEGREES). C C SINCE WANT THE ARROW HEAD TO BE AT THE POINT, ADJUST THE COORDINATES C TO BE CENTER JUSTIFIED. C 500 CONTINUE ITRCSW='OFF' PREPSP=0.1 ISTART=2 IF(NP.LT.ISTART)GOTO9000 PXINC=PWIDT2/2.0 PYINC=PHEIG2/2.0 PXINC=PXINC*(100.0/(PWXMAX-PWXMIN)) PYINC=PYINC*(100.0/(PWYMAX-PWYMIN)) PXINC=0.0 PYINC=0.0 IF(IPATT.NE.'VECT')THEN PX2=PX(1)+PXINC PY2=PY(1)+PYINC PX1=PX2-1.0 PY1=PY2 CALL DPARR3( 1 PX1,PY1,PX2,PY2, 1 IFIG, 1 ITRCSW, 1 IPATT,ICOL,PTHICK, 1 IFILL,ICOL, 1 ICOL,PTHICK,PREPSP, 1 PHEIGH,PWIDTH,PVEGAP,PHOGAP) ENDIF DO510I=ISTART,NP PX1=PX(I-1)+PXINC PX2=PX(I)+PXINC PY1=PY(I-1)+PYINC PY2=PY(I)+PYINC CALL DPARR3( 1PX1,PY1,PX2,PY2, 1IFIG, 1ITRCSW, 1IPATT,ICOL,PTHICK, 1IFILL,ICOL, 1ICOL,PTHICK,PREPSP, 1PHEIGH,PWIDTH,PVEGAP,PHOGAP) 510 CONTINUE GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DRPM')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF GRDRPM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)NP 9012 FORMAT('NP = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)IMANUF 9013 FORMAT('IMANUF = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)IFONT,NCSTRI 9014 FORMAT('IFONT,NCSTRI = ',A4,I8) CALL DPWRST('XXX','BUG ') DO9015I=1,NP WRITE(ICOUT,9016)PX(I),PY(I) 9016 FORMAT('PX(I),PY(I) = ',E15.7,E15.7) CALL DPWRST('XXX','BUG ') 9015 CONTINUE WRITE(ICOUT,9018)IFIG 9018 FORMAT('IFIG = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9019)IPATT,JPATT 9019 FORMAT('IPATT,JPATT = ',A4,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9020)IFONT,JFONT 9020 FORMAT('IFONT,JFONT = ',A4,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9021)ICASE,JCASE 9021 FORMAT('ICASE,JCASE = ',A4,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9022)IJUST,JJUST 9022 FORMAT('IJUST,JJUST = ',A4,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9023)IDIR,ANGLE,JDIR 9023 FORMAT('IDIR,ANGLE,JDIR = ',A4,2X,E15.7,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9024)ICOL,JCOL 9024 FORMAT('ICOL,JCOL = ',A4,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9026)PTHICK,JTHICK,PTHIC2 9026 FORMAT('PTHICK,JTHICK,PTHIC2 = ',E15.7,I8,E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9027)PHEIGH,PWIDTH,PVEGAP,PHOGAP 9027 FORMAT('PHEIGH,PWIDTH,PVEGAP,PHOGAP = ',4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9028)PHEIG2,PWIDT2,PVEGA2,PHOGA2 9028 FORMAT('PHEIG2,PWIDT2,PVEGA2,PHOGA2 = ',4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9031)ISYMBL,ISPAC 9031 FORMAT('ISYMBL,ISPAC = ',A4,2X,A4) 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 GRFIR2(PX,PY,NP,PXSPA2,PYSPA2,IFACTO, 1IHORPA,IVERPA,IDUPPA,IDDOPA, 1JCOL) C C PURPOSE--FOR A GENERAL GRAPHICS DEVICE, C DRAW A SOLID VERTICAL PATTERN C WITHIN A GENERAL POLYLINE C WITH THE ONLY CONSTRAINT THAT A GIVEN X VALUE C HAVE AT MOST 2 Y VALUES. C NOTE--THE COORDINATES IN (PX(.),PY(.)) ARE IN C STANDARDIZED (0.0 TO 100.0) UNITS. C NOTE--THERE ARE NP SUCH COORDINATE PAIRS. 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 UPDATED --JUNE 1990. TEMPORARY ARRAYS TO GARBAGE COMMON C UPDATED --JULY 2001. ADD COLOR INDEX (FOR GD DEVICE) C C-----NON-COMMON VARIABLES (GRAPHICS)------------------------------------------- C CHARACTER*4 IHORPA CHARACTER*4 IVERPA CHARACTER*4 IDUPPA CHARACTER*4 IDDOPA C CHARACTER*4 ISUBN0 C C--------------------------------------------------------------------- C INCLUDE 'DPCOPA.INC' C DIMENSION PX(*) DIMENSION PY(*) C DIMENSION PXS(MAXPOP) DIMENSION PYS(MAXPOP) CCCCC FOLLOWING LINES ADDED JUNE, 1990 INCLUDE 'DPCOZ2.INC' EQUIVALENCE (G2RBAG(IGRG13),PXS(1)) EQUIVALENCE (G2RBAG(IGRG14),PYS(1)) CCCCC END CHANGE 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 ISUBN0='FIR2' C IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'FIR2')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF GRFIR2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)NP 52 FORMAT('NP = ',I8) CALL DPWRST('XXX','BUG ') DO55I=1,NP WRITE(ICOUT,56)I,PX(I),PY(I) 56 FORMAT('I,PX(I),PY(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 55 CONTINUE WRITE(ICOUT,57)PXSPA2,PYSPA2 57 FORMAT('PXSPA2,PYSPA2 = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,58)IFACTO 58 FORMAT('IFACTO = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,61)IHORPA,IVERPA,IDUPPA,IDDOPA 61 FORMAT('IHORPA,IVERPA,IDUPPA,IDDOPA = ',A4,2X,A4,2X,A4,2X,A4) 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 C ************************************ C ** STEP 1-- ** C ** SORT THE X COORDINATES ** C ** AND CARRY ALONG THE Y VALUES ** C ************************************ C IF(NP.LE.1000)GOTO1010 GOTO1090 1010 CONTINUE CALL SORTC2(PX,PY,NP,PXS,PYS) 1090 CONTINUE C C ************************************** C ** STEP 2-- ** C ** ITERATE WITHIN EACH X INTERVAL ** C ************************************** C NPM1=NP-1 DO1100I=1,NPM1 IP1=I+1 C C **************************************** C ** STEP 2.1-- ** C ** FIND THE MIDPOINT OF THE INTERVAL ** C **************************************** C IF(NP.LE.1000)GOTO1110 GOTO1120 C 1110 CONTINUE XI=PXS(I) YI=PYS(I) XIP1=PXS(IP1) YIP1=PYS(IP1) GOTO1180 C 1120 CONTINUE XI=PX(I) YI=PY(I) XIP1=PX(IP1) YIP1=PY(IP1) GOTO1180 C 1180 CONTINUE XMID=(XI+XIP1)/2.0 YMID=(YI+YIP1)/2.0 C IF(IBUGG4.EQ.'ON')WRITE(ICOUT,1181)XI,YI,XIP1,YIP1,XMID,YMID 1181 FORMAT('XI,YI,XIP1,YIP1,XMID,YMID = ',6E15.7) IF(IBUGG4.EQ.'ON')CALL DPWRST('XXX','BUG ') C C ************************************* C ** STEP 2.2-- ** C ** FIND THE ENDPOINT COORDINATES ** C ** OF ONE BOUNDING LINE SEGMENT. ** C ************************************* C DO1200J=1,NPM1 JP1=J+1 J1=J J2=J1+1 IF(PX(J).LE.XMID.AND.XMID.LE.PX(JP1))GOTO1250 IF(PX(JP1).LE.XMID.AND.XMID.LE.PX(J))GOTO1250 1200 CONTINUE J1=NP J2=1 1250 CONTINUE PX1=PX(J1) PY1=PY(J1) PX2=PX(J2) PY2=PY(J2) J2SAVE=J2 C IF(IBUGG4.EQ.'ON')WRITE(ICOUT,1221)J1,J2,J2SAVE 1221 FORMAT('J1,J2,J2SAVE = ',3I8) IF(IBUGG4.EQ.'ON')CALL DPWRST('XXX','BUG ') IF(IBUGG4.EQ.'ON')WRITE(ICOUT,1222)PX1,PY1,PX2,PY2 1222 FORMAT('PX1,PY1,PX2,PY2 = ',4E15.7) IF(IBUGG4.EQ.'ON')CALL DPWRST('XXX','BUG ') C C ******************************************* C ** STEP 2.3-- ** C ** FIND THE ENDPOINT COORDINATES ** C ** OF THE OTHER BOUNDING LINE SEGMENT. ** C ******************************************* C J3=J2SAVE J4=J3+1 IF(J4.GT.NP)J4=1 JMIN=J2SAVE IF(JMIN.GE.NP)GOTO1350 DO1300J=JMIN,NPM1 JP1=J+1 J3=J J4=J3+1 IF(PX(J).LE.XMID.AND.XMID.LE.PX(JP1))GOTO1350 IF(PX(JP1).LE.XMID.AND.XMID.LE.PX(J))GOTO1350 1300 CONTINUE J3=NP J4=1 1350 CONTINUE PX3=PX(J3) PY3=PY(J3) PX4=PX(J4) PY4=PY(J4) C IF(IBUGG4.EQ.'ON')WRITE(ICOUT,1321)J1,J2,J2SAVE,JMIN,J3,J4 1321 FORMAT('J1,J2,J2SAVE,JMIN,J3,J4 = ',6I8) IF(IBUGG4.EQ.'ON')CALL DPWRST('XXX','BUG ') IF(IBUGG4.EQ.'ON')WRITE(ICOUT,1322)PX3,PY3,PX4,PY4 1322 FORMAT('PX3,PY3,PX4,PY4 = ',4E15.7) IF(IBUGG4.EQ.'ON')CALL DPWRST('XXX','BUG ') C C ***************************************** C ** STEP 2.4-- ** C ** DETERMINE THE INTERCEPT AND SLOPE ** C ** OF ONE BOUNDING LINE SEGMENT. ** C ***************************************** C IF(PX1.EQ.PX2)GOTO1411 IF(PY1.EQ.PY2)GOTO1412 GOTO1413 C 1411 CONTINUE AM12=CPUMAX B12=CPUMAX GOTO1419 C 1412 CONTINUE AM12=0.0 B12=PY1 GOTO1419 C 1413 CONTINUE AM12=(PY2-PY1)/(PX2-PX1) B12=PY1-AM12*PX1 GOTO1419 C 1419 CONTINUE C IF(IBUGG4.EQ.'ON')WRITE(ICOUT,1421)AM12,B12 1421 FORMAT('AM12,B12 = ',2E15.7) IF(IBUGG4.EQ.'ON')CALL DPWRST('XXX','BUG ') C C ******************************************* C ** STEP 2.5-- ** C ** DETERMINE THE INTERCEPT AND SLOPE ** C ** OF THE OTHER BOUNDING LINE SEGMENT. ** C ******************************************* C IF(PX3.EQ.PX4)GOTO1511 IF(PY3.EQ.PY4)GOTO1512 GOTO1513 C 1511 CONTINUE AM34=CPUMAX B34=CPUMAX GOTO1519 C 1512 CONTINUE AM34=0.0 B34=PY3 GOTO1519 C 1513 CONTINUE AM34=(PY4-PY3)/(PX4-PX3) B34=PY3-AM34*PX3 GOTO1519 C 1519 CONTINUE C IF(IBUGG4.EQ.'ON')WRITE(ICOUT,1521)AM34,B34 1521 FORMAT('AM34,B34 = ',2E15.7) IF(IBUGG4.EQ.'ON')CALL DPWRST('XXX','BUG ') C C ********************************* C ** STEP 2.6-- ** C ** FILL THE LOCAL SUB-REGION ** C ********************************* C XDEL=PXSPA2 X=XI-XDEL 1600 CONTINUE X=X+XDEL IF(X.GT.XIP1)GOTO1690 PX5=X PY5=PY1 IF(AM12.NE.CPUMAX.AND.B12.NE.CPUMAX)PY5=AM12*X+B12 PX6=X PY6=PY3 IF(AM34.NE.CPUMAX.AND.B34.NE.CPUMAX)PY6=AM34*X+B34 IF(IBUGG4.EQ.'ON')WRITE(ICOUT,1611)X,PX5,PY5,PX6,PY6 1611 FORMAT('X,PX5,PY5,PX6,PY6 = ',5E15.7) IF(IBUGG4.EQ.'ON')CALL DPWRST('XXX','BUG ') CALL GRTRSD(PX5,PY5,IX5,IY5,ISUBN0) CALL GRTRSD(PX6,PY6,IX6,IY6,ISUBN0) CCCCC JULY 2001. ADD COLOR INDEX (NEEDED FOR GD DEVICE) CCCCC CALL GRDRLI(IX5,IY5,IX6,IY6,PX5,PY5,PX6,PY6,IFACTO) CALL GRDRLI(IX5,IY5,IX6,IY6,PX5,PY5,PX6,PY6,IFACTO,JCOL) 1610 CONTINUE GOTO1600 1690 CONTINUE C 1100 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'FIR2')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF GRFIR2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)NP 9012 FORMAT('NP = ',I8) CALL DPWRST('XXX','BUG ') DO9015I=1,NP WRITE(ICOUT,9016)I,PX(I),PY(I) 9016 FORMAT('I,PX(I),PY(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 9015 CONTINUE WRITE(ICOUT,9017)PXSPA2,PYSPA2 9017 FORMAT('PXSPA2,PYSPA2 = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9018)IFACTO 9018 FORMAT('IFACTO = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9021)IHORPA,IVERPA,IDUPPA,IDDOPA 9021 FORMAT('IHORPA,IVERPA,IDUPPA,IDDOPA = ',A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 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 GRFIR3(PX,PY,NP,PXSPA,PYSPA,IFACTO, 1IHORPA,IVERPA,IDUPPA,IDDOPA, 1IPATT2,PTHICK,ICOL) C C PURPOSE--FOR A GENERAL GRAPHICS DEVICE, C FILL A POLYGON (CONVEX OR CONCAVE) WITH A HATCH C PATTERN. THE ROUTINE GRHTCH ACTUALLY DOES THE C FILL. THIS ROUTINE IS THE DRIVER FOR THE 4 CASES OF C VERTICAL, HORIZONTAL, UP DIAGONAL, DOWN DIAGONAL. C SOLID FILLS ARE HANDLED VIA THE VERTICAL WITH A C SMALL SPACING. C NOTE--THE COORDINATES IN (PX(.),PY(.)) ARE IN C STANDARDIZED (0.0 TO 100.0) UNITS. C NOTE--THERE ARE NP SUCH COORDINATE PAIRS. 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--93.10 C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--OCTOBER 1993. C C-----NON-COMMON VARIABLES (GRAPHICS)--------------------------------- C CHARACTER*4 IHORPA CHARACTER*4 IVERPA CHARACTER*4 IDUPPA CHARACTER*4 IDDOPA C CHARACTER*4 ISUBN0 C CHARACTER*4 IPATT2 CHARACTER*4 IFIG CHARACTER*4 ICOL CHARACTER*4 IDIR C DIMENSION PX(*) DIMENSION PY(*) C INCLUDE 'DPCOPA.INC' DIMENSION PXS(MAXPOP) DIMENSION PYS(MAXPOP) INCLUDE 'DPCOZ2.INC' EQUIVALENCE (G2RBAG(IGRG13),PXS(1)) EQUIVALENCE (G2RBAG(IGRG14),PYS(1)) C C 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 ISUBN0='FIR3' C IFIG='LINE' C IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'FIR3')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF GRFIR3--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)NP 52 FORMAT('NP = ',I8) CALL DPWRST('XXX','BUG ') DO55I=1,NP WRITE(ICOUT,56)I,PX(I),PY(I) 56 FORMAT('I,PX(I),PY(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 55 CONTINUE WRITE(ICOUT,57)PXSPA,PYSPA 57 FORMAT('PXSPA,PYSPA = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,58)IFACTO 58 FORMAT('IFACTO = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,61)IHORPA,IVERPA,IDUPPA,IDDOPA 61 FORMAT('IHORPA,IVERPA,IDUPPA,IDDOPA = ',A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,69)IBUGG4,ISUBG4,IERRG4 69 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,70)IPATT2,PTHICK,ICOL 70 FORMAT('IPATT2,PTHICK,ICOL = ',A4,2X,E15.7,2X,A4) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C ************************************ C ** STEP 0-- ** C ** SORT THE X COORDINATES ** C ** AND CARRY ALONG THE Y VALUES ** C ** FILTER OUT POINTS IF NOT ENOUGH* C ** CHANGE. ** C ************************************ C EPSX=0.001 EPSY=0.001 C BXMIN=PX(1) BYMIN=PY(1) BXMAX=BXMIN BYMAX=BYMIN PXS(1)=PX(1) PYS(1)=PY(1) J=1 DO10I=2,NP IF(ABS(PX(I)-PXS(J)).LE.EPSX .AND. ABS(PY(I)-PYS(J)).LE.EPSY) 1 GOTO10 J=J+1 PXS(J)=PX(I) IF(PXS(J).LT.BXMIN)BXMIN=PXS(J) IF(PXS(J).GT.BXMAX)BXMAX=PXS(J) PYS(J)=PY(I) IF(PYS(J).LT.BYMIN)BYMIN=PYS(J) IF(PYS(J).GT.BYMAX)BYMAX=PYS(J) 10 CONTINUE NP2=J CCCCC IF(PXS(1).EQ.PXS(NP).AND.PYS(1).EQ.PYS(NP))NP2=NP-1 BX=(BXMIN + BXMAX)/2.0 BY=(BYMIN + BYMAX)/2.0 IF(NP2.LT.3)GOTO9000 C C *************************************************** C ** STEP 1-- ** C ** DRAW THE HORIZONTAL STRIPES (IF CALLED FOR) ** C *************************************************** C IF(IHORPA.EQ.'ON')GOTO1100 GOTO1190 1100 CONTINUE IDIR='HORI' DIST=PXSPA CALL GRPLPX(PXS,PYS,NP2,IDIR,DIST,IPATT2,PTHICK,ICOL) 1190 CONTINUE C C *************************************************** C ** STEP 2-- ** C ** DRAW THE VERTICAL STRIPES (IF CALLED FOR) ** C *************************************************** C IF(IVERPA.EQ.'ON')GOTO1200 GOTO1290 1200 CONTINUE IDIR='VERT' DIST=PYSPA CALL GRPLPX(PXS,PYS,NP2,IDIR,DIST,IPATT2,PTHICK,ICOL) 1290 CONTINUE C C ****************************************************** C ** STEP 3-- ** C ** DRAW THE UP-DIAGONAL STRIPES (IF CALLED FOR) ** C ****************************************************** C IF(IDUPPA.EQ.'ON')GOTO1300 GOTO1390 1300 CONTINUE DX=1.0 DY=1.0 DIST=PXSPA CALL GRHTCH(PXS,PYS,NP2,BX,BY,DX,DY,DIST,IPATT2,PTHICK,ICOL) C 1390 CONTINUE C C ****************************************************** C ** STEP 4-- ** C ** DRAW THE DOWN-DIAGONAL STRIPES (IF CALLED FOR) ** C ****************************************************** C IF(IDDOPA.EQ.'ON')GOTO1400 GOTO1490 1400 CONTINUE DX=1.0 DY=-1.0 DIST=PXSPA CALL GRHTCH(PXS,PYS,NP2,BX,BY,DX,DY,DIST,IPATT2,PTHICK,ICOL) 1490 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'FIR3')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF GRFIR3--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)NP2 9012 FORMAT('NP = ',I8) CALL DPWRST('XXX','BUG ') DO9015I=1,NP2 WRITE(ICOUT,9016)I,PXS(I),PYS(I) 9016 FORMAT('I,PXS(I),PYS(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 9015 CONTINUE WRITE(ICOUT,9017)PXSPA,PYSPA 9017 FORMAT('PXSPA,PYSPA = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9018)IFACTO 9018 FORMAT('IFACTO = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9021)IHORPA,IVERPA,IDUPPA,IDDOPA 9021 FORMAT('IHORPA,IVERPA,IDUPPA,IDDOPA = ',A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 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 GRHTCH(X,Y,N,BX,BY,DX,DY,DIST, 1IPATT2,PTHICK,ICOL) C C PURPOSE--ROUTINE TO FILL A POLYGON WITH A HATCHING PATTERN. C ASSUME EQUI-SPACED PARRALLEL LINES (DIST = DISTANCE C BETWEEN PARRALLEL LINES). EACH LINE HAS A DIRECTION C VECTOR DX,DY AND A BASE VECTOR BX,BY). C MAXP IS THE LIMIT ON THE FACET SIZE (SHOULD BE C ADEQUATE FOR DATAPLOT PURPOSES). C ALGORITHM--CODE IS FROM "HIGH-RESOLUTION COMPUTER GRAPHICS USING C FORTRAN 77" BY ANGEL AND GRIFFITH (PP 93-94). C VERSION NUMBER--93.10 C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--OCTOBER 1993. C PARAMETER(MAXP=1000) REAL X(*) REAL Y(*) C REAL PX(2) REAL PY(2) REAL PX2(MAXP) REAL PY2(MAXP) C CHARACTER*4 IFIG CHARACTER*4 IFLAG CHARACTER*4 IPATT2 CHARACTER*4 ICOL 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 IF(N.LE.3)GOTO9000 EPS=0.000001 CCCCC FIND CMID, CMIN, CMAX C CMID=DX*BY - DY*BX CMIN=DX*Y(1) - DY*X(1) CMAX=CMIN DO101I=2,N C=DX*Y(I)-DY*X(I) IF(C.LT.CMIN)THEN CMIN=C ELSEIF(C.GT.CMAX)THEN CMAX=C ENDIF 101 CONTINUE C CCCCC CONSTRUCT VECTOR (SX,SY) C DMOD=SQRT(DX**2+DY**2) SX=-DIST/DMOD*DY SY=DIST/DMOD*DX C CCCCC CALCULATE NMIN AND NMAX C NMIN=IFIX((CMIN-CMID)/(DIST*DMOD)+0.9999) NMAX=IFIX((CMAX-CMID)/(DIST*DMOD)) C CCCCC HATCH THE POLYGON C DO401J=NMIN,NMAX C CCCCC FIND THE BASE VECTOR OF THE HATCHING LINE C QX=BX+REAL(J)*SX QY=BY+REAL(J)*SY C CCCCC FIND THE INTERSECTIONS OF THE HATCHING LINE WITH THE CCCCC EDGES OF THE POLYGON. CCCCC EX = 0 (X(I)=X(NI)) AND EY = 0 (Y(I)=Y(NI)) ARE SPECIAL CASES. C NINT=0 NI=N DO201I=1,N EX=X(I)-X(NI) EY=Y(I)-Y(NI) CALL GRILL2(X(NI),Y(NI),EX,EY,QX,QY,DX,DY,XI,YI,ISEC) IF(ISEC.EQ.1)THEN NINT=NINT+1 PX2(NINT)=XI PY2(NINT)=YI ENDIF NI=I 201 CONTINUE IF(NINT.EQ.0)GOTO401 C CCCCC SORT RMU VALUES INTO ORDER C CALL SORTC2(PX2,PY2,NINT,PX2,PY2) C CCCCC JOIN CORRESPONDING PAIRS OF INTERSECTIONS C IFLAG='ON' IFIG='LINE' NP2=2 NI=1 399 CONTINUE IF(NI+1.LE.NINT)THEN PX(1)=PX2(NI) PY(1)=PY2(NI) PX(2)=PX2(NI+1) PY(2)=PY2(NI+1) CALL DPDRPL(PX,PY,NP2, 1 IFIG,IPATT2,PTHICK,ICOL, 1 JPATT,JTHICK,PTHIC2,JCOL,IFLAG) IFLAG='OFF' NI=NI+2 GOTO399 ENDIF C 401 CONTINUE C 9000 CONTINUE RETURN END SUBROUTINE GRID(NI,NJ,FC,GC,BFI,BFJ,POI,POJ,XX,YY,EPS3,CDFX, * IFLAG) C C--- COMPUTE DOUBLE SUMMATION OF COMPONENTS OF THE T" C.D.F. OVER THE C--- GRID I=IMIN TO IMAX AND J=JMIN TO JMAX C DIMENSION BFI(*),BFJ(*),POI(*),POJ(*) C C--- COMPUTE BETA C.D.F. BY RECURRENCE WHEN I=IMIN, J=JMIN TO JMAX C CALL EDGET (NJ,GC,FC,YY,XX,BFJ,CDFX,POJ,POI,EPS3,IFLAG,1) IF (NI.LE.1.OR.IFLAG.NE.0) RETURN C C--- COMPUTE BETA C.D.F. BY RECURRENCE WHEN J=JMIN, I=IMIN TO IMAX C BFI(1) = BFJ(1) CALL EDGET (NI,FC,GC,XX,YY,BFI,CDFX,POI,POJ,EPS3,IFLAG,2) IF (NJ.LE.1.OR.IFLAG.NE.0) RETURN C C--- COMPUTE BETA C.D.F. BY RECURRENCE WHEN I>IMIN, J>JMIN C DO 20 I = 2, NI BFJ(1) = BFI(I) DO 10 J = 2, NJ BFJ(J) = XX*BFJ(J)+YY*BFJ(J-1) CDFX = CDFX+POI(I)*POJ(J)*BFJ(J) 10 CONTINUE 20 CONTINUE RETURN END SUBROUTINE GRIDD(NI,NJ,FC,GC,BFI,BFJ,POI,POJ,XX,YY,EPS3,CDFX, * IFLAG) CCCCC DOUBLE PRECISION VERSION OF GRID. THE DOUBLY NON-CENTRAL T CCCCC CDF FUNCTION SEEMS TO REQUIRE DOUBLE PRECISION (THE DOUBLY CCCCC NON-CENTRAL F SEEMS TO WORK FINE IN SINGLE PRECISION). C C--- COMPUTE DOUBLE SUMMATION OF COMPONENTS OF THE T" C.D.F. OVER THE C--- GRID I=IMIN TO IMAX AND J=JMIN TO JMAX C IMPLICIT DOUBLE PRECISION (A-H,O-Z) C DIMENSION BFI(*),BFJ(*),POI(*),POJ(*) C C--- COMPUTE BETA C.D.F. BY RECURRENCE WHEN I=IMIN, J=JMIN TO JMAX C CALL EDGET(NJ,GC,FC,YY,XX,BFJ,CDFX,POJ,POI,EPS3,IFLAG,1) IF (NI.LE.1.OR.IFLAG.NE.0) RETURN C C--- COMPUTE BETA C.D.F. BY RECURRENCE WHEN J=JMIN, I=IMIN TO IMAX C BFI(1) = BFJ(1) CALL EDGET (NI,FC,GC,XX,YY,BFI,CDFX,POI,POJ,EPS3,IFLAG,2) IF (NJ.LE.1.OR.IFLAG.NE.0) RETURN C C--- COMPUTE BETA C.D.F. BY RECURRENCE WHEN I>IMIN, J>JMIN C DO 20 I = 2, NI BFJ(1) = BFI(I) DO 10 J = 2, NJ BFJ(J) = XX*BFJ(J)+YY*BFJ(J-1) CDFX = CDFX+POI(I)*POJ(J)*BFJ(J) 10 CONTINUE 20 CONTINUE RETURN END SUBROUTINE GRILL2(X1,Y1,X2,Y2,X3,Y3,X4,Y4,X,Y,ISEC) C C PURPOSE--UTILITY ROUTINE USED BY GRHTCH C FIND THE POINT OF INTERSECTION (X,Y) OF 2 LINES C IN THE FORM (X1,Y1)+RMU*(X2,Y2) AND C (X2,Y3)*RLAM(X4,Y4). C ISEC IS 1 IF INTERSECTION EXISTS, 0 IF NOT. C ALGORITHM--CODE IS FROM "HIGH-RESOLUTION COMPUTER GRAPHICS USING C FORTRAN 77" BY ANGEL AND GRIFFITH (PP 44-45). C VERSION NUMBER--93.10 C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--OCTOBER 1993. 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 DATA EPS/0.0000001/ C C-----START POINT----------------------------------------------------- C DELTA=X2*Y4-Y2*X4 C C IF DELTA IS ZERO, PARALLEL LINES C IF RMU > 1 OR RMU < 0, THEN POINT LIES OFF LINE. C ISEC=0 IF(ABS(DELTA).GE.EPS)THEN RMU=((X3-X1)*Y4 - (Y3-Y1)*X4)/DELTA IF(RMU.GE.0.0 .AND.RMU.LE.1.0)THEN ISEC=1 X=X1+RMU*X2 Y=Y1+RMU*Y2 ENDIF ENDIF C RETURN END SUBROUTINE GRPLPX(X,Y,N,IDIR,DIST,IPATT2,PTHICK,ICOL) C C PURPOSE--ROUTINE TO FILL A POLYGON WITH A HORIZONTAL OR VERTICAL C HATCHING PATTERN. C ASSUME EQUI-SPACED PARRALLEL LINES (DIST = DISTANCE C BETWEEN PARALLEL LINES). C ALGORITHM--CODE IS FROM "HIGH-RESOLUTION COMPUTER GRAPHICS USING C FORTRAN 77" BY ANGEL AND GRIFFITH (PP 95-96). C MODIFIED THEIR INTEGER VERSION TO ONE WITH REAL NUMBERS. C VERSION NUMBER--93.11 C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--NOVEMBER 1993. C PARAMETER(MAXP=1000) REAL X(*) REAL Y(*) C PARAMETER (MAXINT=100) REAL PX(MAXINT) REAL PY(MAXINT) REAL PX2(2) REAL PY2(2) C CHARACTER*4 IDIR CHARACTER*4 IFIG CHARACTER*4 IFLAG CHARACTER*4 IPATT2 CHARACTER*4 ICOL C C-----COMMON VARIABLES (GENERAL)-------------------------------------- C INCLUDE 'DPCOBE.INC' C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'PLPX')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG') WRITE(ICOUT,51) 51 FORMAT('****** AT THE BEGINING OF GRPLPX ---') CALL DPWRST(ICOUT,'BUG') WRITE(ICOUT,52)N,IDIR,DIST 52 FORMAT('N,IDIR,DIST = ',I8,2X,A4,2X,E15.7) CALL DPWRST(ICOUT,'BUG') WRITE(ICOUT,53)IPATT2,PTHICK,ICOL 53 FORMAT('IPATT2,PTHICK,ICOL = ',A4,2X,E15.7,2X,A4) CALL DPWRST(ICOUT,'BUG') DO54I=1,N WRITE(ICOUT,55)I,X(I),Y(I) CALL DPWRST(ICOUT,'BUG') 54 CONTINUE 55 FORMAT('I,X(I),Y(I)=',I8,2X,E15.7,2X,E15.7) C 90 CONTINUE C IF(N.LE.3)GOTO9000 IF(X(1).NE.X(N).OR.Y(1).NE.Y(N))THEN N=N+1 X(N)=X(1) Y(N)=Y(1) ENDIF IF(IDIR.EQ.'HORI')THEN AMAXY=Y(1) AMINY=Y(1) DO100I=2,N IF(Y(I).GT.AMAXY)AMAXY=Y(I) IF(Y(I).LT.AMINY)AMINY=Y(I) 100 CONTINUE IF(AMAXY.GE.100.0)AMAXY=100.0 IF(AMINY.LE.0.0)AMINY=0.0 C AY=AMINY 300 CONTINUE IV=N NINT=0 DO200NV=1,N IF(AMAX1(Y(IV),Y(NV)).GE.AY .AND. + AMIN1(Y(IV),Y(NV)).LE.AY .AND. Y(IV).NE.Y(NV)) THEN RMU=(AY-Y(IV))/(Y(NV)-Y(IV)) NINT=NINT+1 XI=(1.0-RMU)*X(IV) + RMU*X(NV) PX(NINT)=XI C IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'PLPX')GOTO390 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG') WRITE(ICOUT,351) 351 FORMAT('****** IN THE 200 LOOP ---') CALL DPWRST('XXX','BUG') WRITE(ICOUT,352)AY,IV,NV 352 FORMAT('AY,IV,NV=',E15.7,2X,I8,2X,I8) CALL DPWRST('XXX','BUG') WRITE(ICOUT,353)RMU,XI,X(IV),X(NV) 353 FORMAT('RMU,XI,X(IV),X(NV)=',4(E15.7,2X)) CALL DPWRST('XXX','BUG') WRITE(ICOUT,354)Y(IV),Y(NV) 354 FORMAT('Y(IV),Y(NV)=',2(E15.7,2X)) CALL DPWRST('XXX','BUG') 390 CONTINUE C ENDIF IV=NV 200 CONTINUE IF(NINT.LE.1)GOTO299 CALL SORT(PX,NINT,PX) IFLAG='ON' IFIG='LINE' NP2=2 DO250I=1,NINT,2 IF(I+1.GT.NINT)GOTO299 PX2(1)=PX(I) PX2(2)=PX(I+1) PY2(1)=AY PY2(2)=AY CALL DPDRPL(PX2,PY2,NP2, 1 IFIG,IPATT2,PTHICK,ICOL, 1 JPATT,JTHICK,PTHIC2,JCOL,IFLAG) IFLAG='OFF' 250 CONTINUE 299 CONTINUE AY=AY+DIST IF(AY.GT.AMAXY)GOTO9000 GOTO300 ELSEIF(IDIR.EQ.'VERT')THEN AMAXX=X(1) AMINX=X(1) DO400I=2,N IF(X(I).GT.AMAXX)AMAXX=X(I) IF(X(I).LT.AMINX)AMINX=X(I) 400 CONTINUE IF(AMAXX.GE.100.0)AMAXX=100.0 IF(AMINX.LE.0.0)AMINX=0.0 C AX=AMINX 600 CONTINUE IV=N NINT=0 DO500NV=1,N IF(AMAX1(X(IV),X(NV)).GE.AX .AND. + AMIN1(X(IV),X(NV)).LE.AX .AND. X(IV).NE.X(NV)) THEN RMU=(AX-X(IV))/(X(NV)-X(IV)) NINT=NINT+1 YI=(1.0-RMU)*Y(IV) + RMU*Y(NV) PY(NINT)=YI ENDIF IV=NV 500 CONTINUE IF(NINT.LE.1)GOTO599 CALL SORT(PY,NINT,PY) IFLAG='ON' IFIG='LINE' NP2=2 DO550I=1,NINT,2 IF(I+1.GT.NINT)GOTO599 PY2(1)=PY(I) PY2(2)=PY(I+1) PX2(1)=AX PX2(2)=AX CALL DPDRPL(PX2,PY2,NP2, 1 IFIG,IPATT2,PTHICK,ICOL, 1 JPATT,JTHICK,PTHIC2,JCOL,IFLAG) IFLAG='OFF' 550 CONTINUE 599 CONTINUE AX=AX+DIST IF(AX.GT.AMAXX)GOTO9000 GOTO600 ENDIF C 9000 CONTINUE RETURN END SUBROUTINE GRPMEA(AMAT1,AMAT2,MAXROM,MAXCOM,NR1,NC1, 1TAG,TAGDIS,NIJUNK,N2,NK,TEMP,IBUGA3,IERROR) C C PURPOSE--THIS SUBROUTINE COMPUTES THE C GROUP MEANS OF A MATRIX. THAT IS, A TAG VARIABLE C DIVIDES THE ROWS OF A MATRIX INTO DISTINCT GROUPS. C THE COMPUTED GROUP MEANS ARE RETURNED AS A MATRIX C (WHERE THE NUMBER OF ROWS EQUALS THE NUMBER OF GROUPS). C OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE C GROUP MEANS. C NOTE--THE TAG VARIABLE IS A GROUP IDENTIFIER THAT DEFINES C WHAT MATRIX A GIVEN ROW BELONGS TO. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C LANGUAGE--ANSI FORTRAN (1977) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--98.9 C ORIGINAL VERSION--SEPTEMBER 1998. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IBUGA3 CHARACTER*4 IERROR C CHARACTER*4 IWRITE CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C DIMENSION AMAT1(MAXROM,MAXCOM) DIMENSION AMAT2(MAXROM,MAXCOM) DIMENSION TAG(*) DIMENSION TAGDIS(*) DIMENSION TEMP(*) DIMENSION NIJUNK(*) 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='GRPM' ISUBN2='EA ' C IERROR='NO' C IF(IBUGA3.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF GRPMEA--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA3 52 FORMAT('IBUGA3 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)NR1,NC1 53 FORMAT('NR1, NC1 = ',3I8) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C ************************************************* C ** COMPUTE NUMBER OF DISTINCT ELEMENTS OF TAG ** C ************************************************* C IWRITE='OFF' CALL DISTIN(TAG,NR1,IWRITE,TAGDIS,NK,IBUGA3,IERROR) C C ************************************************* C ** COMPUTE GROUP MEANS ** C ************************************************* C DO95J=1,MAXCOM DO98I=1,MAXROM AMAT2(I,J)=0.0 98 CONTINUE 95 CONTINUE NSUM=0 C DO100IGROUP=1,NK C ATEMP=TAGDIS(IGROUP) DO200J=1,NC1 ICOUNT=0 DO300I=1,NR1 IF(TAG(I).EQ.ATEMP)THEN ICOUNT=ICOUNT+1 TEMP(ICOUNT)=AMAT1(I,J) ENDIF 300 CONTINUE IF(J.EQ.1)THEN NI=ICOUNT NIJUNK(IGROUP)=NI ENDIF CALL MEAN(TEMP,NI,IWRITE,XMEAN,IBUGA3,IERROR) AMAT2(IGROUP,J)=XMEAN 200 CONTINUE 100 CONTINUE C DO400J=1,NC1 CALL MEAN(AMAT2(1,J),NK,IWRITE,XMEAN,IBUGA3,IERROR) TEMP(J)=XMEAN 400 CONTINUE C 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 GRPMEA--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGA3,IERROR 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)NR1,NC1 9013 FORMAT('NR1,NC1 = ',2I8) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE GRPSD(AMAT1,AMAT2,MAXROM,MAXCOM,NR1,NC1, 1TAG,TAGDIS,NIJUNK,N2,NK,TEMP,IBUGA3,IERROR) C C PURPOSE--THIS SUBROUTINE COMPUTES THE C GROUP STANDARD DEVIATIONS OF A MATRIX. THAT IS, C A TAG VARIABLE C DIVIDES THE ROWS OF A MATRIX INTO DISTINCT GROUPS. C THE COMPUTED GROUP SD'S ARE RETURNED AS A MATRIX C (WHERE THE NUMBER OF ROWS EQUALS THE NUMBER OF GROUPS). C OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE C GROUP STANDARD DEVIATIONS. C NOTE--THE TAG VARIABLE IS A GROUP IDENTIFIER THAT DEFINES C WHAT MATRIX A GIVEN ROW BELONGS TO. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C LANGUAGE--ANSI FORTRAN (1977) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--98.9 C ORIGINAL VERSION--SEPTEMBER 1998. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IBUGA3 CHARACTER*4 IERROR C CHARACTER*4 IWRITE CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C DIMENSION AMAT1(MAXROM,MAXCOM) DIMENSION AMAT2(MAXROM,MAXCOM) DIMENSION TAG(*) DIMENSION TAGDIS(*) DIMENSION TEMP(*) DIMENSION NIJUNK(*) 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='GRPM' ISUBN2='EA ' C IERROR='NO' C IF(IBUGA3.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF GRPSD--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA3 52 FORMAT('IBUGA3 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)NR1,N2,NC1 53 FORMAT('NR1, N2, NC1 = ',3I8) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C ************************************************* C ** COMPUTE NUMBER OF DISTINCT ELEMENTS OF TAG ** C ************************************************* C IWRITE='OFF' CALL DISTIN(TAG,NR1,IWRITE,TAGDIS,NK,IBUGA3,IERROR) C C ************************************************* C ** COMPUTE GROUP MEANS ** C ************************************************* C DO95J=1,MAXCOM DO98I=1,MAXROM AMAT2(I,J)=0.0 98 CONTINUE 95 CONTINUE NSUM=0 C DO100IGROUP=1,NK C ATEMP=TAGDIS(IGROUP) DO200J=1,NC1 ICOUNT=0 DO300I=1,NR1 IF(TAG(I).EQ.ATEMP)THEN ICOUNT=ICOUNT+1 TEMP(ICOUNT)=AMAT1(I,J) ENDIF 300 CONTINUE IF(J.EQ.1)THEN NI=ICOUNT NIJUNK(IGROUP)=NI ENDIF CALL SD(TEMP,NI,IWRITE,XSD,IBUGA3,IERROR) AMAT2(IGROUP,J)=XSD 200 CONTINUE 100 CONTINUE C DO400J=1,NC1 CALL SD(AMAT2(1,J),NK,IWRITE,XSD,IBUGA3,IERROR) TEMP(J)=XSD 400 CONTINUE C 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 GRPSD--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGA3,IERROR 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)NR1,NC1 9013 FORMAT('NR1,NC1 = ',2I8) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE GRPSTA(Y,XH1,XH2,N,NUMV2,ICASCT,ICASC2,ICASS7, 1MAXNXT, 1XH1DIS,XH2DIS,TEMP,TEMP2,TEMP3,TEMP4,TEMP5, 1Y2, 1ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6, 1ISUBRO,IBUGA3,IERROR) C C PURPOSE--STANDARDIZE A VARIABLE: C 1) Z-SCORE (I.E., SUBTRACT MEAN, DIVIDE BY STANDARD C DEVIATION) OR BY SUBTRACTING MEAN ONLY. C 2) CAN HAVE 0, 1, OR 2 GROUP ID VARIABLES. NOTE C THAT THE STANDARDIZATION IS BY GROUP CELL (I.E., C IF TWO GROUP VARIABLES, CROSS TABULATE AND C DO THE STANDARDIZATION WITHIN EACH CELL). C 3) SUPPORT VARIOUS LOCATION AND SCALE STATISTICS C (DEFAULT WILL BE MEAN AND STANDARD DEVIATION). C WRITTEN BY--ALAN HECKERT C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2001/3 C ORIGINAL VERSION--MARCH 2001. C UPDATED --SEPTEMBER 2001. ADD SUPORT FOR MINIMUM C AS LOCATION STAT AND RANGE C AND INTERQUARTILE RANGE AS C SCALE STATISTIC. C ALSO, ADD SUPPORT FOR C SCALE ONLY OPTION. C UPDATED --SEPTEMBER 2001. ADD A "CROSS-TAB" OPTION. C THIS PUTS THE VALUE OF C THE REQUESTED STATISTIC C IN THE OUTPUT VECTOR. C UPDATED --NOVEMBER 2001. BIWEIGHT LOCATION C UPDATED --NOVEMBER 2001. BIWEIGHT SCALE C UPDATED --AUGUST 2002. USE "CMPSTA" TO COMPUTE C STATISTIC FOR CROSS C TABULATE CASE C UPDATED --APRIL 2003. ADD SN AND QN, REQUIRED C ADDITIONAL SCRATCH ARRAYS C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C EXTERNAL SUM EXTERNAL RANGE C CHARACTER*4 ICASCT CHARACTER*4 ICASC2 CHARACTER*4 ICASS7 CHARACTER*4 ILOC CHARACTER*4 ISCALE CHARACTER*4 ISUBRO CHARACTER*4 IBUGA3 CHARACTER*4 IERROR C CHARACTER*4 IWRITE C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C--------------------------------------------------------------------- C DIMENSION Y(*) DIMENSION XH1(*) DIMENSION XH2(*) DIMENSION Y2(*) C DIMENSION XH1DIS(*) DIMENSION XH2DIS(*) DIMENSION TEMP(*) DIMENSION TEMP2(*) DIMENSION TEMP3(*) DIMENSION TEMP4(*) DIMENSION TEMP5(*) INTEGER ITEMP1(*) INTEGER ITEMP2(*) INTEGER ITEMP3(*) INTEGER ITEMP4(*) INTEGER ITEMP5(*) INTEGER ITEMP6(*) C INCLUDE 'DPCOPA.INC' INCLUDE 'DPCOST.INC' INCLUDE 'DPCOHK.INC' C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='GRPS' ISUBN2='TA ' C ILOC=ISTALO ISCALE=ISTASC IF(ICASCT.EQ.'ZSCO')THEN ILOC='MEAN' ISCALE='SD' ELSEIF(ICASCT.EQ.'USCO')THEN ILOC='MINI' ISCALE='RANG' ENDIF C I2=0 AN=0.0 C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(N.GT.1)GOTO39 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,31) 31 FORMAT('***** ERROR IN GRPSTA--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,32) 32 FORMAT(' THE NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,33) 33 FORMAT(' MUST BE AT LEAST 2;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,34)N 34 FORMAT(' THE ENTERED NUMBER OF OBSERVATIONS HERE = ',I6) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 39 CONTINUE C IF(IBUGA3.EQ.'OFF')GOTO90 WRITE(ICOUT,70) 70 FORMAT('AT THE BEGINNING OF GRPSTA--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,71)N,ICASCT,NUMV2 71 FORMAT('N,ICASCT,NUMV2 = ',I8,2X,A4,I8) CALL DPWRST('XXX','BUG ') DO72I=1,N WRITE(ICOUT,73)I,Y(I),XH1(I),XH2(I) 73 FORMAT('I, Y(I), XH1(I),XH2(I) = ',I8,3F15.7) CALL DPWRST('XXX','BUG ') 72 CONTINUE 90 CONTINUE C C ******************************************************** C ** STEP 1-- ** C ** 1-VARIABLE CASE, I.E. NO GROUP ID VARIABLES. ** C ******************************************************** C ISTEPN='1' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) IWRITE='OFF' IF(NUMV2.EQ.1)THEN IF(ICASCT.EQ.'CRTA')THEN NUMV=1 CALL CMPSTA( 1 Y,TEMP,TEMP2,TEMP3,TEMP4,MAXNXT,N,N,NUMV,ICASS7, 1 ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6, 1 IQUAME,IQUASE, 1 STAT1, 1 ISUBRO,IBUGA3,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ELSE IF(ICASCT.EQ.'SCAL')THEN STAT1=0.0 ELSE NUMV=1 CALL CMPSTA( 1 Y,TEMP,TEMP2,TEMP3,TEMP4,MAXOBV,N,N,NUMV,ILOC, 1 ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6, 1 IQUAME,IQUASE, 1 STAT1, 1 ISUBRO,IBUGA3,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ENDIF C IF(ICASCT.EQ.'LOCA')THEN STAT2=1.0 ELSE NUMV=1 CALL CMPSTA( 1 Y,TEMP,TEMP2,TEMP3,TEMP4,MAXOBV,N,N,NUMV,ISCALE, 1 ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6, 1 IQUAME,IQUASE, 1 STAT2, 1 ISUBRO,IBUGA3,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ENDIF ENDIF C IF(ICASCT.EQ.'CRTA')THEN DO112I=1,N Y2(I)=STAT1 112 CONTINUE GOTO9000 ELSE DO110I=1,N Y2(I)=(Y(I)-STAT1)/STAT2 110 CONTINUE GOTO9000 ENDIF ENDIF C C ******************************************************** C ** STEP 2-- ** C ** DETERMINE THE NUMBER OF DISTINCT VALUES ** C ** FOR VARIABLE 2 (ONE OF THE GROUP VARIABLES). ** C ******************************************************** C ISTEPN='2' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMV2.EQ.2)THEN C NUMSE1=0 DO260I=1,N IF(NUMSE1.EQ.0)GOTO265 DO270J=1,NUMSE1 IF(XH1(I).EQ.XH1DIS(J))GOTO260 270 CONTINUE 265 CONTINUE NUMSE1=NUMSE1+1 XH1DIS(NUMSE1)=XH1(I) 260 CONTINUE CALL SORT(XH1DIS,NUMSE1,XH1DIS) C 290 CONTINUE C AN=N ANUMS1=NUMSE1 C DO310I=1,NUMSE1 NTEMP=0 DO320J=1,N IF(XH1(J).EQ.XH1DIS(I))THEN NTEMP=NTEMP+1 TEMP2(NTEMP)=Y(J) ENDIF 320 CONTINUE IWRITE='OFF' IF(NTEMP.GT.0)THEN IF(ICASCT.EQ.'CRTA')THEN NUMV=1 CALL CMPSTA( 1 TEMP2,TEMP,TEMP3,TEMP4,TEMP5, 1 MAXNXT,NTEMP,NTEMP,NUMV,ICASS7, 1 ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6, 1 IQUAME,IQUASE, 1 STAT1, 1 ISUBRO,IBUGA3,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ELSE IF(ICASCT.EQ.'SCAL')THEN STAT1=0.0 ELSE NUMV=1 CALL CMPSTA( 1 TEMP2,TEMP,TEMP3,TEMP4,TEMP5, 1 MAXNXT,NTEMP,NTEMP,NUMV,ILOC, 1 ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6, 1 IQUAME,IQUASE, 1 STAT1, 1 ISUBRO,IBUGA3,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ENDIF C IF(ICASCT.EQ.'LOCA')THEN STAT2=1.0 ELSE NUMV=1 CALL CMPSTA( 1 TEMP2,TEMP,TEMP3,TEMP4,TEMP5, 1 MAXNXT,NTEMP,NTEMP,NUMV,ISCALE, 1 ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6, 1 IQUAME,IQUASE, 1 STAT2, 1 ISUBRO,IBUGA3,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ENDIF ENDIF ENDIF C IF(ICASCT.EQ.'CRTA')THEN DO420J=1,N IF(XH1(J).EQ.XH1DIS(I))THEN Y2(J)=STAT1 ENDIF 420 CONTINUE ELSE DO410J=1,N IF(XH1(J).EQ.XH1DIS(I))THEN Y2(J)=(Y(J)-STAT1)/STAT2 ENDIF 410 CONTINUE ENDIF 310 CONTINUE GOTO9000 ENDIF C C ******************************************************** C ** STEP 3-- ** C ** DETERMINE THE NUMBER OF DISTINCT VALUES ** C ** FOR VARIABLE 2 (ONE OF THE GROUP VARIABLES). ** C ** IF ALL VALUES ARE DISTINCT, THEN THIS ** C ** IMPLIES WE HAVE THE NO REPLICATION CASE ** C ** WHICH IS AN ERROR CONDITION FOR A CROSS-TABULATION** C ******************************************************** C ISTEPN='3' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMV2.EQ.3)THEN C NUMSE1=0 DO560I=1,N IF(NUMSE1.EQ.0)GOTO565 DO570J=1,NUMSE1 IF(XH1(I).EQ.XH1DIS(J))GOTO560 570 CONTINUE 565 CONTINUE NUMSE1=NUMSE1+1 XH1DIS(NUMSE1)=XH1(I) 560 CONTINUE CALL SORT(XH1DIS,NUMSE1,XH1DIS) C 590 CONTINUE C AN=N ANUMS1=NUMSE1 C ISTEPN='3B' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NUMSE2=0 DO760I=1,N IF(NUMSE2.EQ.0)GOTO765 DO770J=1,NUMSE2 IF(XH2(I).EQ.XH2DIS(J))GOTO760 770 CONTINUE 765 CONTINUE NUMSE2=NUMSE2+1 XH2DIS(NUMSE2)=XH2(I) 760 CONTINUE CALL SORT(XH2DIS,NUMSE2,XH2DIS) C 790 CONTINUE C AN=N ANUMS2=NUMSE2 ISTEPN='3.C' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) IWRITE='OFF' J=0 C DO1110ISET1=1,NUMSE1 DO1120ISET2=1,NUMSE2 C NTEMP=0 DO1130I=1,N IF(XH1(I).EQ.XH1DIS(ISET1).AND. 1 XH2(I).EQ.XH2DIS(ISET2))THEN NTEMP=NTEMP+1 TEMP2(NTEMP)=Y(I) ENDIF 1130 CONTINUE IWRITE='OFF' IF(NTEMP.GT.0)THEN IF(ICASCT.EQ.'CRTA')THEN NUMV=1 CALL CMPSTA( 1 TEMP2,TEMP,TEMP3,TEMP4,TEMP5, 1 MAXNXT,NTEMP,NTEMP,NUMV,ICASS7, 1 ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6, 1 IQUAME,IQUASE, 1 STAT1, 1 ISUBRO,IBUGA3,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ELSE IF(ICASCT.EQ.'SCAL')THEN STAT1=0.0 ELSE NUMV=1 CALL CMPSTA( 1 TEMP2,TEMP,TEMP3,TEMP4,TEMP5, 1 MAXNXT,NTEMP,NTEMP,NUMV,ILOC, 1 ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6, 1 IQUAME,IQUASE, 1 STAT1, 1 ISUBRO,IBUGA3,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ENDIF C IF(ICASCT.EQ.'LOCA')THEN STAT2=1.0 ELSE NUMV=1 CALL CMPSTA( 1 TEMP2,TEMP,TEMP3,TEMP4,TEMP5, 1 MAXNXT,NTEMP,NTEMP, 1 NUMV,ISCALE, 1 ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6, 1 IQUAME,IQUASE, 1 STAT2, 1 ISUBRO,IBUGA3,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ENDIF ENDIF C IF(ICASCT.EQ.'CRTA')THEN DO1160J=1,N IF(XH1(J).EQ.XH1DIS(ISET1).AND. 1 XH2(J).EQ.XH2DIS(ISET2))THEN Y2(J)=STAT1 ENDIF 1160 CONTINUE ELSE DO1150J=1,N IF(XH1(J).EQ.XH1DIS(ISET1).AND. 1 XH2(J).EQ.XH2DIS(ISET2))THEN Y2(J)=(Y(J)-STAT1)/STAT2 ENDIF 1150 CONTINUE ENDIF ENDIF 1120 CONTINUE 1110 CONTINUE GOTO9000 ENDIF 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 GRPSTA--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)NUMV2 9013 FORMAT('NUMV2 = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)NUMSE1,NUMSE2 9015 FORMAT('NUMSE1,NUMSE2 = ',2I8) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE GRPST2(Y,YTEMP,XH1,XH2,N,NUMV2, 1ICASCT,ICASC2,ICASS7, 1MAXNXT, 1XH1DIS,XH2DIS,TEMP,TEMP2,TEMP3,TEMP4,TEMP5, 1Y2, 1ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6, 1ISUBRO,IBUGA3,IERROR) C C PURPOSE--STANDARDIZE A VARIABLE: C 1) Z-SCORE (I.E., SUBTRACT MEAN, DIVIDE BY STANDARD C DEVIATION) OR BY SUBTRACTING MEAN ONLY. C 2) CAN HAVE 0, 1, OR 2 GROUP ID VARIABLES. NOTE C THAT THE STANDARDIZATION IS BY GROUP CELL (I.E., C IF TWO GROUP VARIABLES, CROSS TABULATE AND C DO THE STANDARDIZATION WITHIN EACH CELL). C 3) SUPPORT VARIOUS LOCATION AND SCALE STATISTICS C (DEFAULT WILL BE MEAN AND STANDARD DEVIATION). C WRITTEN BY--ALAN HECKERT C STATISTICAL ENGINEERING DIVISION 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 NOTE--THIS IS A MODIFIED VERSION OF GRPSTA. GRPSTA IS C USED FOR STATISTICS WITH ONE RESPONSE VARIABLE, C GRPST2 IS USED FOR THE CASE WITH TWO RESPONSE VARIABLES. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2003/3 C ORIGINAL VERSION--MARCH 2003. C UPDATED --APRIL 2003. ARGUMENT LIST TO CMPSTA C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C EXTERNAL SUM EXTERNAL RANGE C CHARACTER*4 ICASCT CHARACTER*4 ICASC2 CHARACTER*4 ICASS7 CHARACTER*4 ILOC CHARACTER*4 ISCALE CHARACTER*4 ISUBRO CHARACTER*4 IBUGA3 CHARACTER*4 IERROR C CHARACTER*4 IWRITE C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C--------------------------------------------------------------------- C DIMENSION Y(*) DIMENSION YTEMP(*) DIMENSION XH1(*) DIMENSION XH2(*) DIMENSION Y2(*) C DIMENSION XH1DIS(*) DIMENSION XH2DIS(*) DIMENSION TEMP(*) DIMENSION TEMP2(*) DIMENSION TEMP3(*) DIMENSION TEMP4(*) DIMENSION TEMP5(*) INTEGER ITEMP1(*) INTEGER ITEMP2(*) INTEGER ITEMP3(*) INTEGER ITEMP4(*) INTEGER ITEMP5(*) INTEGER ITEMP6(*) C INCLUDE 'DPCOPA.INC' INCLUDE 'DPCOST.INC' INCLUDE 'DPCOHK.INC' C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='GRPS' ISUBN2='T2 ' C ILOC=ISTALO ISCALE=ISTASC IF(ICASCT.EQ.'ZSCO')THEN ILOC='MEAN' ISCALE='SD' ELSEIF(ICASCT.EQ.'USCO')THEN ILOC='MINI' ISCALE='RANG' ENDIF C I2=0 AN=0.0 C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(N.GT.1)GOTO39 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,31) 31 FORMAT('***** ERROR IN GRPSTA--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,32) 32 FORMAT(' THE NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,33) 33 FORMAT(' MUST BE AT LEAST 2;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,34)N 34 FORMAT(' THE ENTERED NUMBER OF OBSERVATIONS HERE = ',I6) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 39 CONTINUE C IF(IBUGA3.EQ.'OFF')GOTO90 WRITE(ICOUT,70) 70 FORMAT('AT THE BEGINNING OF GRPSTA--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,71)N,ICASCT,NUMV2 71 FORMAT('N,ICASCT,NUMV2 = ',I8,2X,A4,I8) CALL DPWRST('XXX','BUG ') DO72I=1,N WRITE(ICOUT,73)I,Y(I),XH1(I),XH2(I) 73 FORMAT('I, Y(I), XH1(I),XH2(I) = ',I8,3F15.7) CALL DPWRST('XXX','BUG ') 72 CONTINUE 90 CONTINUE C C ******************************************************** C ** STEP 1-- ** C ** 1-VARIABLE CASE, I.E. NO GROUP ID VARIABLES. ** C ******************************************************** C ISTEPN='1' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) IWRITE='OFF' IF(NUMV2.EQ.1)THEN IF(ICASCT.EQ.'CRTA')THEN NUMV=1 CALL CMPSTA( 1 Y,YTEMP,TEMP2,TEMP3,TEMP5,MAXNXT,N,N,NUMV,ICASS7, 1 ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6, 1 IQUAME,IQUASE, 1 STAT1, 1 ISUBRO,IBUGA3,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ELSE IF(ICASCT.EQ.'SCAL')THEN STAT1=0.0 ELSE NUMV=1 CALL CMPSTA( 1 Y,YTEMP,TEMP2,TEMP3,TEMP5,MAXOBV,N,N,NUMV,ILOC, 1 ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6, 1 IQUAME,IQUASE, 1 STAT1, 1 ISUBRO,IBUGA3,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ENDIF C IF(ICASCT.EQ.'LOCA')THEN STAT2=1.0 ELSE NUMV=1 CALL CMPSTA( 1 Y,YTEMP,TEMP2,TEMP3,TEMP5,MAXOBV,N,N,NUMV,ISCALE, 1 ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6, 1 IQUAME,IQUASE, 1 STAT2, 1 ISUBRO,IBUGA3,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ENDIF ENDIF C IF(ICASCT.EQ.'CRTA')THEN DO112I=1,N Y2(I)=STAT1 112 CONTINUE GOTO9000 ELSE DO110I=1,N Y2(I)=(Y(I)-STAT1)/STAT2 110 CONTINUE GOTO9000 ENDIF ENDIF C C ******************************************************** C ** STEP 2-- ** C ** DETERMINE THE NUMBER OF DISTINCT VALUES ** C ** FOR VARIABLE 2 (ONE OF THE GROUP VARIABLES). ** C ******************************************************** C ISTEPN='2' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMV2.EQ.2)THEN C NUMSE1=0 DO260I=1,N IF(NUMSE1.EQ.0)GOTO265 DO270J=1,NUMSE1 IF(XH1(I).EQ.XH1DIS(J))GOTO260 270 CONTINUE 265 CONTINUE NUMSE1=NUMSE1+1 XH1DIS(NUMSE1)=XH1(I) 260 CONTINUE CALL SORT(XH1DIS,NUMSE1,XH1DIS) C 290 CONTINUE C AN=N ANUMS1=NUMSE1 C DO310I=1,NUMSE1 NTEMP=0 DO320J=1,N IF(XH1(J).EQ.XH1DIS(I))THEN NTEMP=NTEMP+1 TEMP2(NTEMP)=Y(J) TEMP(NTEMP)=YTEMP(J) ENDIF 320 CONTINUE IWRITE='OFF' IF(NTEMP.GT.0)THEN IF(ICASCT.EQ.'CRTA')THEN NUMV=1 CALL CMPSTA( 1 TEMP2,TEMP,TEMP3,TEMP4,TEMP5, 1 MAXNXT,NTEMP,NTEMP,NUMV,ICASS7, 1 ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6, 1 IQUAME,IQUASE, 1 STAT1, 1 ISUBRO,IBUGA3,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ELSE IF(ICASCT.EQ.'SCAL')THEN STAT1=0.0 ELSE NUMV=1 CALL CMPSTA( 1 TEMP2,TEMP,TEMP3,TEMP4,TEMP5, 1 MAXNXT,NTEMP,NTEMP,NUMV,ILOC, 1 ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6, 1 IQUAME,IQUASE, 1 STAT1, 1 ISUBRO,IBUGA3,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ENDIF C IF(ICASCT.EQ.'LOCA')THEN STAT2=1.0 ELSE NUMV=1 CALL CMPSTA( 1 TEMP2,TEMP,TEMP3,TEMP4,TEMP5, 1 MAXNXT,NTEMP,NTEMP,NUMV,ISCALE, 1 ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6, 1 IQUAME,IQUASE, 1 STAT2, 1 ISUBRO,IBUGA3,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ENDIF ENDIF ENDIF C IF(ICASCT.EQ.'CRTA')THEN DO420J=1,N IF(XH1(J).EQ.XH1DIS(I))THEN Y2(J)=STAT1 ENDIF 420 CONTINUE ELSE DO410J=1,N IF(XH1(J).EQ.XH1DIS(I))THEN Y2(J)=(Y(J)-STAT1)/STAT2 ENDIF 410 CONTINUE ENDIF 310 CONTINUE GOTO9000 ENDIF C C ******************************************************** C ** STEP 3-- ** C ** DETERMINE THE NUMBER OF DISTINCT VALUES ** C ** FOR VARIABLE 2 (ONE OF THE GROUP VARIABLES). ** C ** IF ALL VALUES ARE DISTINCT, THEN THIS ** C ** IMPLIES WE HAVE THE NO REPLICATION CASE ** C ** WHICH IS AN ERROR CONDITION FOR A CROSS-TABULATION** C ******************************************************** C ISTEPN='3' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMV2.EQ.3)THEN C NUMSE1=0 DO560I=1,N IF(NUMSE1.EQ.0)GOTO565 DO570J=1,NUMSE1 IF(XH1(I).EQ.XH1DIS(J))GOTO560 570 CONTINUE 565 CONTINUE NUMSE1=NUMSE1+1 XH1DIS(NUMSE1)=XH1(I) 560 CONTINUE CALL SORT(XH1DIS,NUMSE1,XH1DIS) C 590 CONTINUE C AN=N ANUMS1=NUMSE1 C ISTEPN='3B' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NUMSE2=0 DO760I=1,N IF(NUMSE2.EQ.0)GOTO765 DO770J=1,NUMSE2 IF(XH2(I).EQ.XH2DIS(J))GOTO760 770 CONTINUE 765 CONTINUE NUMSE2=NUMSE2+1 XH2DIS(NUMSE2)=XH2(I) 760 CONTINUE CALL SORT(XH2DIS,NUMSE2,XH2DIS) C 790 CONTINUE C AN=N ANUMS2=NUMSE2 ISTEPN='3.C' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) IWRITE='OFF' J=0 C DO1110ISET1=1,NUMSE1 DO1120ISET2=1,NUMSE2 C NTEMP=0 DO1130I=1,N IF(XH1(I).EQ.XH1DIS(ISET1).AND. 1 XH2(I).EQ.XH2DIS(ISET2))THEN NTEMP=NTEMP+1 TEMP2(NTEMP)=Y(I) TEMP(NTEMP)=YTEMP(I) ENDIF 1130 CONTINUE IWRITE='OFF' IF(NTEMP.GT.0)THEN IF(ICASCT.EQ.'CRTA')THEN NUMV=1 CALL CMPSTA( 1 TEMP2,TEMP,TEMP3,TEMP4,TEMP5, 1 MAXNXT,NTEMP,NTEMP,NUMV,ICASS7, 1 ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6, 1 IQUAME,IQUASE, 1 STAT1, 1 ISUBRO,IBUGA3,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ELSE IF(ICASCT.EQ.'SCAL')THEN STAT1=0.0 ELSE NUMV=1 CALL CMPSTA( 1 TEMP2,TEMP,TEMP3,TEMP4,TEMP5, 1 MAXNXT,NTEMP,NTEMP,NUMV,ILOC, 1 ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6, 1 IQUAME,IQUASE, 1 STAT1, 1 ISUBRO,IBUGA3,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ENDIF C IF(ICASCT.EQ.'LOCA')THEN STAT2=1.0 ELSE NUMV=1 CALL CMPSTA( 1 TEMP2,TEMP,TEMP3,TEMP4,TEMP5,MAXNXT,NTEMP,NTEMP, 1 NUMV,ISCALE, 1 ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6, 1 IQUAME,IQUASE, 1 STAT2, 1 ISUBRO,IBUGA3,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ENDIF ENDIF C IF(ICASCT.EQ.'CRTA')THEN DO1160J=1,N IF(XH1(J).EQ.XH1DIS(ISET1).AND. 1 XH2(J).EQ.XH2DIS(ISET2))THEN Y2(J)=STAT1 ENDIF 1160 CONTINUE ELSE DO1150J=1,N IF(XH1(J).EQ.XH1DIS(ISET1).AND. 1 XH2(J).EQ.XH2DIS(ISET2))THEN Y2(J)=(Y(J)-STAT1)/STAT2 ENDIF 1150 CONTINUE ENDIF ENDIF 1120 CONTINUE 1110 CONTINUE GOTO9000 ENDIF 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 GRPSTA--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)NUMV2 9013 FORMAT('NUMV2 = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)NUMSE1,NUMSE2 9015 FORMAT('NUMSE1,NUMSE2 = ',2I8) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE GRSTRI(ICTEXT,NCTEXT) C C PURPOSE--CHANGE LC() AND UC() IN CHARACTER STRINGS TO C ASCII UPPER AND LOWER CASE. ALSO, CONVERT SP() C TO AN ASCII SPACE. THIS IS DONE FOR HARDWARE GENERATED C TEXT ONLY (SOFTWARE GENERATED TEXT ALREADY HANDLES C IT AT A LOWER LEVEL). C INPUT ARGUMENTS--ICTEXT (CHARACTER) C NCTEXT (INTEGER) C OUTPUT ARGUMENTS--ICSTRING C NCTEXT C WRITTEN BY - C ALAN HECKERT C CENTER FOR APPLIED MATHEMATICS, C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C WASHINGTON, DC 20234 C TELEPHONE 301-975-2899 C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--93/3 C ORIGINAL VERSION--MARCH 1993. (ALAN) C UPDATED --OCTOBER 1993. TEXT NO LONGER GARUNTEED TO C COME IN AS UPPER CASE (ALAN) C UPDATED --FEBRUARY 2006. FOR SP(), CHECK THAT WE C DON'T HABE UNSP() CASE C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IFLAG CHARACTER*4 ICTEXT(*) CHARACTER*1 ICTEMP CCCCC ADD FOLLOWING 4 LINES. OCTOBER 1993 CHARACTER*1 IA1 CHARACTER*1 IA2 CHARACTER*1 IA3 CHARACTER*1 IA4 C C-----COMMON---------------------------------------------------------- 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 IF(NCTEXT.LT.4)GOTO9000 C J=0 ISKIP=0 IFLAG='UC' CCCCC OCTOBER 1993. FOLLOWING LOOP RECODED TO ACCOUNT FOR THE FACT CCCCC TEXT COMING IN IS NO LONGER NECCESSARILY UPPER CASE!!! DO100I=1,NCTEXT IF(ISKIP.LE.0)GOTO110 ISKIP=ISKIP-1 GOTO100 110 CONTINUE IF(I+3.GT.NCTEXT)GOTO150 C C CONVERT TO UPPER CASE (FIRST 2 CHARACTERS ONLY SINCE 3 AND 4 CHECKING C FOR (). C IA1=ICTEXT(I)(1:1) CALL DPCOAN(IA1,IVAL) IF(IVAL.GE.97.AND.IVAL.LE.122)IVAL=IVAL-32 CALL DPCONA(IVAL,IA1) IA2=ICTEXT(I+1)(1:1) CALL DPCOAN(IA2,IVAL) IF(IVAL.GE.97.AND.IVAL.LE.122)IVAL=IVAL-32 CALL DPCONA(IVAL,IA2) IA3=ICTEXT(I+2)(1:1) IA4=ICTEXT(I+3)(1:1) C IF(IA1.NE.'S'.OR.IA2.NE.'P'.OR.IA3.NE.'('.OR.IA4.NE.')')GOTO115 C IF(I.GE.3)THEN IF( 1 (ICTEXT(I-2)(1:1).EQ.'U'.OR.ICTEXT(I-2)(1:1).EQ.'u').AND. 1 (ICTEXT(I-1)(1:1).EQ.'N'.OR.ICTEXT(I-1)(1:1).EQ.'n'))THEN GOTO115 ENDIF ENDIF C J=J+1 ICTEXT(J)=' ' ISKIP=3 GOTO100 115 CONTINUE IF(IA1.NE.'U'.OR.IA2.NE.'C'.OR.IA3.NE.'('.OR.IA4.NE.')')GOTO120 IFLAG='UC' ISKIP=3 GOTO100 120 CONTINUE IF(IA1.NE.'L'.OR.IA2.NE.'C'.OR.IA3.NE.'('.OR.IA4.NE.')')GOTO150 IFLAG='LC' ISKIP=3 GOTO100 150 CONTINUE ICTEMP=ICTEXT(I)(1:1) CALL DPCOAN(ICTEMP,IVALT) IF(IFLAG.EQ.'LC'.AND.IVALT.GE.65.AND.IVALT.LE.90)GOTO160 J=J+1 ICTEXT(J)=ICTEMP GOTO100 160 CONTINUE J=J+1 IVALT=IVALT+32 CALL DPCONA(IVALT,ICTEMP) ICTEXT(J)=ICTEMP 100 CONTINUE NCTEXT=J C 9000 CONTINUE RETURN END