module M_datapac__s ! build real32 version use,intrinsic :: iso_fortran_env, only : wp=>real32 use,intrinsic :: iso_fortran_env, only : stdin=>input_unit, stdout=>output_unit, stderr=>error_unit implicit none private integer, save :: G_IO=stdout ! IO LUN for all write statements real(kind=wp),parameter :: G_pi = 3.14159265358979_wp real(kind=wp),parameter :: G_pi_dp = 3.14159265358979d0 private invxwx public :: & autoco , betran , bincdf , binppf , binran , caucdf , caupdf , cauplt , cauppf , cauran , & causf , chscdf , chsplt , chsppf , chsran , code , copy , corr , count , decomp , & define , delete , demod , dexcdf , dexpdf , dexplt , dexppf , dexran , dexsf , discr2 , & discr3 , discre , dot , ev1cdf , ev1plt , ev1ppf , ev1ran , ev2cdf , ev2plt , ev2ppf , & ev2ran , expcdf , exppdf , expplt , expppf , expran , expsf , extrem , fcdf , fourie , & fran , freq , gamcdf , gamplt , gamppf , gamran , geocdf , geoplt , geoppf , georan , & hfncdf , hfnplt , hfnppf , hfnran , hist , lamcdf , lampdf , lamplt , lamppf , & lamran , lamsf , lgncdf , lgnplt , lgnppf , lgnran , loc , logcdf , logpdf , logplt , & logppf , logran , logsf , max , mean , median , midm , midr , min , move , & nbcdf , nbppf , nbran , norcdf , norout , norpdf , norplt , norppf , norran , norsf , & parcdf , parplt , parppf , parran , plot10 , plot6 , plot7 , plot8 , plot9 , plotc , & plotco , plotct , plot , plotsc , plots , plotsp , plotst , plott , plotu , plotx , & plotxt , plotxx , pltsct , pltxxt , poicdf , poiplt , poippf , poiran , propor , & range , rank , ranper , relsd , replac , retain , runs , sampp , & scale , sd , sortc , sort , sortp , spcorr , stmom3 , stmom4 , subse1 , & subse2 , subset , tail , tcdf , time , tol , tplt , tppf , tran , trim , & unicdf , unimed , unipdf , uniplt , unippf , uniran , unisf , var , weib , weicdf , & weiplt , weippf , weiran , wind interface autoco; module procedure autoco ; end interface interface betran; module procedure betran ; end interface interface bincdf; module procedure bincdf ; end interface interface binppf; module procedure binppf ; end interface interface binran; module procedure binran ; end interface interface caucdf; module procedure caucdf ; end interface interface caupdf; module procedure caupdf ; end interface interface cauplt; module procedure cauplt ; end interface interface cauppf; module procedure cauppf ; end interface interface cauran; module procedure cauran ; end interface interface causf; module procedure causf ; end interface interface chscdf; module procedure chscdf ; end interface interface chsplt; module procedure chsplt ; end interface interface chsppf; module procedure chsppf ; end interface interface chsran; module procedure chsran ; end interface interface code; module procedure code ; end interface interface copy; module procedure copy ; end interface interface corr; module procedure corr ; end interface interface count; module procedure count ; end interface interface decomp; module procedure decomp ; end interface interface define; module procedure define ; end interface interface delete; module procedure delete ; end interface interface demod; module procedure demod ; end interface interface dexcdf; module procedure dexcdf ; end interface interface dexpdf; module procedure dexpdf ; end interface interface dexplt; module procedure dexplt ; end interface interface dexppf; module procedure dexppf ; end interface interface dexran; module procedure dexran ; end interface interface dexsf; module procedure dexsf ; end interface interface discr2; module procedure discr2 ; end interface interface discr3; module procedure discr3 ; end interface interface discre; module procedure discre ; end interface interface dot; module procedure dot ; end interface interface ev1cdf; module procedure ev1cdf ; end interface interface ev1plt; module procedure ev1plt ; end interface interface ev1ppf; module procedure ev1ppf ; end interface interface ev1ran; module procedure ev1ran ; end interface interface ev2cdf; module procedure ev2cdf ; end interface interface ev2plt; module procedure ev2plt ; end interface interface ev2ppf; module procedure ev2ppf ; end interface interface ev2ran; module procedure ev2ran ; end interface interface expcdf; module procedure expcdf ; end interface interface exppdf; module procedure exppdf ; end interface interface expplt; module procedure expplt ; end interface interface expppf; module procedure expppf ; end interface interface expran; module procedure expran ; end interface interface expsf; module procedure expsf ; end interface interface extrem; module procedure extrem ; end interface interface fcdf; module procedure fcdf ; end interface interface fourie; module procedure fourie ; end interface interface fran; module procedure fran ; end interface interface freq; module procedure freq ; end interface interface gamcdf; module procedure gamcdf ; end interface interface gamplt; module procedure gamplt ; end interface interface gamppf; module procedure gamppf ; end interface interface gamran; module procedure gamran ; end interface interface geocdf; module procedure geocdf ; end interface interface geoplt; module procedure geoplt ; end interface interface geoppf; module procedure geoppf ; end interface interface georan; module procedure georan ; end interface interface hfncdf; module procedure hfncdf ; end interface interface hfnplt; module procedure hfnplt ; end interface interface hfnppf; module procedure hfnppf ; end interface interface hfnran; module procedure hfnran ; end interface interface hist; module procedure hist ; end interface interface lamcdf; module procedure lamcdf ; end interface interface lampdf; module procedure lampdf ; end interface interface lamplt; module procedure lamplt ; end interface interface lamppf; module procedure lamppf ; end interface interface lamran; module procedure lamran ; end interface interface lamsf; module procedure lamsf ; end interface interface lgncdf; module procedure lgncdf ; end interface interface lgnplt; module procedure lgnplt ; end interface interface lgnppf; module procedure lgnppf ; end interface interface lgnran; module procedure lgnran ; end interface interface loc; module procedure loc ; end interface interface logcdf; module procedure logcdf ; end interface interface logpdf; module procedure logpdf ; end interface interface logplt; module procedure logplt ; end interface interface logppf; module procedure logppf ; end interface interface logran; module procedure logran ; end interface interface logsf; module procedure logsf ; end interface interface max; module procedure max ; end interface interface mean; module procedure mean ; end interface interface median; module procedure median ; end interface interface midm; module procedure midm ; end interface interface midr; module procedure midr ; end interface interface min; module procedure min ; end interface interface move; module procedure move ; end interface interface nbcdf; module procedure nbcdf ; end interface interface nbppf; module procedure nbppf ; end interface interface nbran; module procedure nbran ; end interface interface norcdf; module procedure norcdf ; end interface interface norout; module procedure norout ; end interface interface norpdf; module procedure norpdf ; end interface interface norplt; module procedure norplt ; end interface interface norppf; module procedure norppf ; end interface interface norran; module procedure norran ; end interface interface norsf; module procedure norsf ; end interface interface parcdf; module procedure parcdf ; end interface interface parplt; module procedure parplt ; end interface interface parppf; module procedure parppf ; end interface interface parran; module procedure parran ; end interface interface plot; module procedure plot ; end interface interface plot10; module procedure plot10 ; end interface interface plot6; module procedure plot6 ; end interface interface plot7; module procedure plot7 ; end interface interface plot8; module procedure plot8 ; end interface interface plot9; module procedure plot9 ; end interface interface plotc; module procedure plotc ; end interface interface plotco; module procedure plotco ; end interface interface plotct; module procedure plotct ; end interface interface plots; module procedure plots ; end interface interface plotsc; module procedure plotsc ; end interface interface plotsp; module procedure plotsp ; end interface interface plotst; module procedure plotst ; end interface interface plott; module procedure plott ; end interface interface plotu; module procedure plotu ; end interface interface plotx; module procedure plotx ; end interface interface plotxt; module procedure plotxt ; end interface interface plotxx; module procedure plotxx ; end interface interface pltsct; module procedure pltsct ; end interface interface pltxxt; module procedure pltxxt ; end interface interface poicdf; module procedure poicdf ; end interface interface poiplt; module procedure poiplt ; end interface interface poippf; module procedure poippf ; end interface interface poiran; module procedure poiran ; end interface interface propor; module procedure propor ; end interface interface range; module procedure range ; end interface interface rank; module procedure rank ; end interface interface ranper; module procedure ranper ; end interface interface relsd; module procedure relsd ; end interface interface replac; module procedure replac ; end interface interface retain; module procedure retain ; end interface interface runs; module procedure runs ; end interface interface sampp; module procedure sampp ; end interface interface scale; module procedure scale ; end interface interface sd; module procedure sd ; end interface interface sort; module procedure sort ; end interface interface sortc; module procedure sortc ; end interface interface sortp; module procedure sortp ; end interface interface spcorr; module procedure spcorr ; end interface interface stmom3; module procedure stmom3 ; end interface interface stmom4; module procedure stmom4 ; end interface interface subse1; module procedure subse1 ; end interface interface subse2; module procedure subse2 ; end interface interface subset; module procedure subset ; end interface interface tail; module procedure tail ; end interface interface tcdf; module procedure tcdf ; end interface interface time; module procedure time ; end interface interface tol; module procedure tol ; end interface interface tplt; module procedure tplt ; end interface interface tppf; module procedure tppf ; end interface interface tran; module procedure tran ; end interface interface trim; module procedure trim ; end interface interface unicdf; module procedure unicdf ; end interface interface unimed; module procedure unimed ; end interface interface unipdf; module procedure unipdf ; end interface interface uniplt; module procedure uniplt ; end interface interface unippf; module procedure unippf ; end interface interface uniran; module procedure uniran ; end interface interface unisf; module procedure unisf ; end interface interface var; module procedure var ; end interface interface weib; module procedure weib ; end interface interface weicdf; module procedure weicdf ; end interface interface weiplt; module procedure weiplt ; end interface interface weippf; module procedure weippf ; end interface interface weiran; module procedure weiran ; end interface interface wind; module procedure wind ; end interface contains !> !!##NAME !! autoco(3f) - [M_datapac:STATISTICS] compute the sample autocorrelation !! coefficient !! !!##SYNOPSIS !! !! SUBROUTINE AUTOCO(X,N,Iwrite,Xautoc) !! !! Real(kind=wp), Intent (InOut) :: X(:) !! Integer, Intent (In) :: Iwrite !! Real(kind=wp), Intent (In) :: Xautoc !! !!##DESCRIPTION !! !! AUTOCO(3f) computes the sample autocorrelation coefficient of the !! data in the input vector X. The sample autocorrelation coefficient !! equals the correlation between X(I) and X(I+1) over the entire sample. !! The autocorrelation coefficient coefficient will be a REAL !! value between -1.0 and 1.0 (inclusively). !! !!##INPUT ARGUMENTS !! X The REAL vector of (unsorted) observations. !! N The integer number of observations in the vector x. !! IWRITE An integer flag code which (if set to 0) will suppress !! the printing of the sample autocorrelation coefficient !! as it is computed; or (if set to some integer value not !! equal to 0), like, say, 1) will cause the printing of the !! sample autocorrelation coefficient at the time it is computed. !! !!##OUTPUT ARGUMENTS !! !! XAUTOC The REAL value of the computed sample autocorrelation coefficient. !! This REAL value will be between -1.0 and 1.0 (inclusively). !! !!##EXAMPLES !! !! Sample program: !! !! program demo_autoco !! use M_datapac, only : autoco, label !! implicit none !! real :: x(100) !! call label('autoco') !! !call call autoco(x,size(x),1,xautoc) !! end program demo_autoco !! !! Results: !!##REFERENCES !! Jenkins and Watts, Spectral Analysis and its Applications, 1968, pages 5, 182. !! !!##AUTHOR !! The original DATAPAC library was written by James J. Filliben of the Statistical !! Engineering Division, National Institute of Standards and Technology. !!##MAINTAINER !! John Urban, 2022.05.31 !!##LICENSE !! CC0-1.0 ! ORIGINAL VERSION--JUNE 1972. ! UPDATED --SEPTEMBER 1975. ! UPDATED --NOVEMBER 1975. ! UPDATED --MAY 2022. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 subroutine autoco(x,n,iwrite,xautoc) real(kind=wp) :: an, hold , sum1 , sum2 , sum3 , x(:) , xautoc , xbar , xbar1 , xbar2 integer i , ip1 , iwrite , n , nm1 ! CHECK THE INPUT ARGUMENTS FOR ERRORS an = n if ( n<1 ) then write (G_IO,99001) 99001 format (' ', '***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE AUTOCO SUBROUTINE IS NON-POSITIVE *****') write (G_IO,99002) n 99002 format (' ','***** THE VALUE OF THE ARGUMENT IS ',i0,' *****') return else if ( n==1 ) then write (G_IO,99003) 99003 format (' ***** NON-FATAL DIAGNOSTIC--THE SECOND INPUT ARGUMENT TO THE AUTOCO SUBROUTINE HAS THE VALUE 1 *****') xautoc = 0.0_wp else hold = x(1) do i = 2 , n if ( x(i)/=hold ) goto 50 enddo write (G_IO,99004) hold 99004 format (' ',& & '***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT (A VECTOR) TO THE AUTOCO SUBROUTINE HAS ALL ELEMENTS = ', & & e15.8, & & ' *****') xautoc = 0.0_wp endif goto 100 ! !-----START POINT----------------------------------------------------- ! 50 continue xbar = 0.0_wp do i = 1 , n xbar = xbar + x(i) enddo xbar1 = xbar - x(n) xbar1 = xbar1/(an-1.0_wp) xbar2 = xbar - x(1) xbar2 = xbar2/(an-1.0_wp) sum1 = 0.0_wp sum2 = 0.0_wp sum3 = 0.0_wp nm1 = n - 1 do i = 1 , nm1 ip1 = i + 1 sum1 = sum1 + (x(i)-xbar1)*(x(ip1)-xbar2) sum2 = sum2 + (x(i)-xbar1)**2 sum3 = sum3 + (x(ip1)-xbar2)**2 enddo xautoc = sum1/(sqrt(sum2*sum3)) endif ! 100 continue if ( iwrite==0 ) return write (G_IO,99005) 99005 format (' ') write (G_IO,99006) n , xautoc 99006 format (' ', 'THE LINEAR AUTOCORRELATION COEFFICIENT OF THE SET OF ',i0,' OBSERVATIONS IS ',f14.6) end subroutine autoco !> !!##NAME !! betran(3f) - [M_datapac:RANDOM] generate beta random numbers !! !!##SYNOPSIS !! !! subroutine BETRAN (N,Alpha,Beta,Iseed,X) !! !! INTEGER,intent(in) :: N !! REAL(kind=wp),intent(in) :: Alpha !! REAL(kind=wp),intent(in) :: Beta !! INTEGER,intent(inout) :: Iseed !! REAL(kind=wp),intent(out) :: X(:) !! !!##DESCRIPTION !! !! BETRAN(3f) generates a random sample of size N from the beta !! distribution with shape parameters ALPHA and BETA. !! !! The prototype beta distribution used herein has !! !! mean = ALPHA/(ALPHA+BETA) !! !! and !! !! standard_deviation=sqrt((ALPHA*BETA)/((ALPHA+BETA)**2)*(ALPHA+BETA+1)) !! !! This distribution is defined for all X between 0.0 (inclusively) !! and 1.0 (inclusively) and has the probability density function !! !! f(x) = (1/constant) * x**(alpha-1) * (1.0-x)**(beta-1) !! !! where the constant = the beta function evaluated at the values ALPHA !! and BETA. !! !!##OPTIONS !! !! N The desired integer number of random numbers to be generated. !! !! ALPHA The value of the first shape parameter. !! ALPHA should be greater than or equal to 1.0. !! !! BETA The value of the second shape parameter. !! BETA should be greater than or equal to 1.0. !! !! ISEED An integer iseed value. Should be set to a non-negative value !! to start a new sequence of values. Will be set to -1 on return !! to indicate the next call should continue the current random !! sequence walk. !! !!##OUTPUT !! !! X A random sample of size N from the beta distribution !! with shape parameter values ALPHA and BETA. !! !! A vector (of dimension at least N) into which !! the generated random sample will be placed. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_betran !! use M_datapac, only : betran !! implicit none !! ! call betran(x,y) !! end program demo_betran !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !! !!##REFERENCES !! !! * Greenwood, 'A Fast Generator for Beta-distributed Random Variables', !! Compstat 1974, Proceedings in Computational Statistics, Vienna, !! September, 1974, pages 19-27. !! !! * Tocher, The Art of Simulation, 1963, pages 24-27. !! !! * Hammersley and Handscomb, Monte Carlo Methods, 1964, pages 36-37. !! !! * Johnson and Kotz, Continuous Univariate Distributions --2, 1970, !! pages 37-56. !! !! * Hastings and Peacock, Statistical Distributions--A Handbook For !! Students and Practitioners, 1975, pages 30-35. !! !! * National Bureau of Standards Applied Mathematics Series 55, 1964, !! page 952. ! VERSION NUMBER--82.3 ! ORIGINAL VERSION--NOVEMBER 1975. ! UPDATED --FEBRUARY 1976. ! UPDATED --JUNE 1978. ! UPDATED --DECEMBER 1981. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE BETRAN(N,Alpha,Beta,Iseed,X) INTEGER,intent(in) :: N REAL(kind=wp),intent(in) :: Alpha REAL(kind=wp),intent(in) :: Beta INTEGER,intent(inout) :: Iseed REAL(kind=wp),intent(out) :: X(:) REAL(kind=wp) :: a1, a2, arg, b1, b2, funct, term, u(10), xg, xg01, xg02, xg1, xg2 REAL(kind=wp) :: xn01, xn02, xn(1) INTEGER :: i real(kind=wp),parameter :: athird = 0.33333333_wp real(kind=wp),parameter :: sqrt3= 1.73205081_wp ! ! ***** STILL NEEDS ALGORITHM WORK ****** ! !-----START POINT----------------------------------------------------- ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( N<1 ) THEN WRITE (G_IO,99001) 99001 FORMAT (' ','***** FATAL ERROR--THE FIRST INPUT ARGUMENT TO THE BETRAN SUBROUTINE IS NON-POSITIVE *****') WRITE (G_IO,99002) N 99002 FORMAT (' ','***** THE VALUE OF THE ARGUMENT IS ',I0,' *****') RETURN ELSEIF ( Alpha<1.0_wp ) THEN WRITE (G_IO,99003) 99003 FORMAT (' ','***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE BETRAN SUBROUTINE IS SMALLER THAN 1.0 *****') WRITE (G_IO,99005) Alpha RETURN ELSEIF ( Beta<1.0_wp ) THEN WRITE (G_IO,99004) 99004 FORMAT (' ','***** FATAL ERROR--THE THIRD INPUT ARGUMENT TO THE BETRAN SUBROUTINE IS SMALLER THAN 1.0 *****') WRITE (G_IO,99005) Beta RETURN ELSE ! ! GENERATE N BETA RANDOM NUMBERS ! BY USING THE FACT THAT IF X1 IS A GAMMA VARIATE WITH PARAMETER ALPHA ! AND IF X2 IS A GAMMA VARIATE WITH PARAMETER BETA, ! THEN THE RATIO X1/(X1+X2) IS A BETA VARIATE WITH PARAMETERS ALPHA AND BETA. ! ! TO GENERATE N GAMMA DISTRIBUTION RANDOM NUMBERS, ! USE GREENWOOD'S REJECTION ALGORITHM-- ! 1) GENERATE A NORMAL RANDOM NUMBER; ! 2) TRANSFORM THE NORMAL VARIATE TO AN APPROXIMATE ! GAMMA VARIATE USING THE WILSON-HILFERTY ! APPROXIMATION (SEE THE JOHNSON AND KOTZ ! REFERENCE, page 176); ! 3) FORM THE REJECTION FUNCTION VALUE, BASED ! ON THE PROBABILITY DENSITY FUNCTION VALUE ! OF THE ACTUAL DISTRIBUTION OF THE PSEUDO-GAMMA ! VARIATE, AND THE PROBABILITY DENSITY FUNCTION VALUE ! OF A TRUE GAMMA VARIATE. ! 4) GENERATE A UNIFORM RANDOM NUMBER; ! 5) IF THE UNIFORM RANDOM NUMBER IS LESS THAN ! THE REJECTION FUNCTION VALUE, THEN ACCEPT ! THE PSEUDO-RANDOM NUMBER AS A GAMMA VARIATE; ! IF THE UNIFORM RANDOM NUMBER IS LARGER THAN ! THE REJECTION FUNCTION VALUE, THEN REJECT ! THE PSEUDO-RANDOM NUMBER AS A GAMMA VARIATE. ! a1 = 1.0_wp/(9.0_wp*Alpha) b1 = SQRT(a1) xn01 = -sqrt3 + b1 xg01 = Alpha*(1.0_wp-a1+b1*xn01)**3 a2 = 1.0_wp/(9.0_wp*Beta) b2 = SQRT(a2) xn02 = -sqrt3 + b2 xg02 = Beta*(1.0_wp-a2+b2*xn02)**3 ! DO i = 1 , N DO ! CALL NORRAN(1,Iseed,xn(1:1)) xg = Alpha*(1.0_wp-a1+b1*xn(1))**3 IF ( xg>=0.0_wp ) THEN term = (xg/xg01)**(Alpha-athird) arg = 0.5_wp*xn(1)*xn(1) - xg - 0.5_wp*xn01*xn01 + xg01 funct = term*EXP(arg) CALL UNIRAN(1,Iseed,u) IF ( u(1)<=funct ) THEN xg1 = xg DO ! CALL NORRAN(1,Iseed,xn(1:1)) xg = Beta*(1.0_wp-a2+b2*xn(1))**3 IF ( xg>=0.0_wp ) THEN term = (xg/xg02)**(Beta-athird) arg = 0.5_wp*xn(1)*xn(1) - xg - 0.5_wp*xn02*xn02 + xg02 funct = term*EXP(arg) CALL UNIRAN(1,Iseed,u) IF ( u(1)<=funct ) THEN xg2 = xg ! X(i) = xg1/(xg1+xg2) GOTO 50 ENDIF ENDIF ENDDO ENDIF ENDIF ENDDO ! 50 ENDDO ENDIF 99005 FORMAT (' ','***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') ! END SUBROUTINE BETRAN !> !!##NAME !! bincdf(3f) - [M_datapac:CUMULATIVE_DISTRIBUTION] compute the binomial !! cumulative distribution function !! !!##SYNOPSIS !! !! SUBROUTINE BINCDF(X,P,N,Cdf) !! !! REAL(kind=wp) :: X !! REAL(kind=wp) :: P !! INTEGER :: N !! REAL(kind=wp) :: Cdf !! !!##DESCRIPTION !! BINCDF(3f) computes the cumulative distribution function value at the !! double precision value X for the binomial distribution with double !! precision 'Bernoulli probability' parameter = P, and integer 'number !! of Bernoulli trials' parameter = N. !! !! The binomial distribution used herein has mean = N*P and standard !! deviation = sqrt(N*P*(1-P)). !! !! This distribution is defined for all discrete integer X between 0 !! (inclusively) and N (inclusively). !! !! This distribution has the probability function !! !! f(X) = c(N,X) * P**X * (1-P)**(N-X) !! !! where c(N,X) is the combinatorial function equaling the number of !! combinations of N items taken X at a time. !! !! The binomial distribution is the distribution of the number of !! successes in N Bernoulli (0,1) trials where the probability of success !! in a precision trial = P. !! !!##INPUT ARGUMENTS !! !! X The value at which the cumulative distribution !! function is to be evaluated. X should be integral-valued, !! and between 0.0 (inclusively) and N (inclusively). !! !! P The value of the 'Bernoulli probability' !! parameter for the binomial distribution. !! P should be between 0.0 (exclusively) and 1.0 (exclusively). !! !! N The integer value of the 'number of Bernoulli trials' !! parameter. N should be a positive integer. !! !!##OUTPUT ARGUMENTS !! !! CDF The cumulative distribution function value for the binomial !! distribution. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_bincdf !! use M_datapac, only : bincdf !! implicit none !! !call BINCDF(X,P,N,Cdf) !! end program demo_bincdf !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !! !!##REFERENCES !! * Hastings and Peacock, Statistical !! Distributions--A Handbook for Students and Practitioners, 1975, !! page 38. !! * National Bureau of Standards Applied Mathematics !! Series 55, 1964, page 945, Formulae 26.5.24 and 26.5.28, and !! page 929. !! * Johnson and Kotz, Discrete !! Distributions, 1969, pages 50-86, especially pages 63-64. !! * Feller, An Introduction to Probability !! Theory and its Applications, Volume 1, Edition 2, 1957, pages !! 135-142. !! * Kendall and Stuart, The Advanced Theory of !! Statistics, Volume 1, Edition 2, 1963, pages 120-125. !! * Mood and Grable, Introduction to the Theory !! of Statistics, Edition 2, 1963, pages 64-69. !! * Owen, Handbook of Statistical Tables, 1962, pages 264-272. ! ORIGINAL VERSION--NOVEMBER 1975. ! UPDATED --MAY 1977. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE BINCDF(X,P,N,Cdf) REAL(kind=wp) :: X REAL(kind=wp) :: P INTEGER :: N REAL(kind=wp) :: Cdf REAL(kind=wp) :: an, del, fintx INTEGER :: i, ievodd, iflag1, iflag2, imax, imin, intx, nu1, nu2 DOUBLE PRECISION :: dx , anu1 , anu2 , z , sum , term , ai , coef1 , coef2 , arg DOUBLE PRECISION :: coef DOUBLE PRECISION :: theta , sinth , costh , a , b DOUBLE PRECISION :: DSQRT , DATAN ! COMMENT--NOTE THAT EVEN THOUGH THE INPUT ! TO THIS CUMULATIVE ! DISTRIBUTION FUNCTION SUBROUTINE ! FOR THIS DISCRETE DISTRIBUTION ! SHOULD (UNDER NORMAL CIRCUMSTANCES) BE A ! DISCRETE INTEGER VALUE, ! THE INPUT VARIABLE X IS SINGLE ! PRECISION IN MODE. ! X HAS BEEN SPECIFIED AS SINGLE ! PRECISION SO AS TO CONFORM WITH THE DATAPAC ! CONVENTION THAT ALL INPUT ****DATA**** ! (AS OPPOSED TO SAMPLE SIZE, FOR EXAMPLE) ! VARIABLES TO ALL ! DATAPAC SUBROUTINES ARE . ! THIS CONVENTION IS BASED ON THE BELIEF THAT ! 1) A MIXTURE OF MODES (FLOATING POINT ! VERSUS INTEGER) IS INCONSISTENT AND ! AN UNNECESSARY COMPLICATION ! IN A DATA ANALYSIS; AND ! 2) FLOATING POINT MACHINE ARITHMETIC ! (AS OPPOSED TO INTEGER ARITHMETIC) ! IS THE MORE NATURAL MODE FOR DOING ! DATA ANALYSIS. !--------------------------------------------------------------------- ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! an = N IF ( P<0.0_wp .OR. P>1.0_wp ) THEN WRITE (G_IO,99001) 99001 FORMAT (' ', & &'***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE BINCDF SUBROU& &TINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL *****') WRITE (G_IO,99006) P Cdf = 0.0_wp RETURN ELSEIF ( N<1 ) THEN WRITE (G_IO,99002) 99002 FORMAT (' ', & &'***** FATAL ERROR--THE THIRD INPUT ARGUMENT TO THE BINCDF SUBROU& &TINE IS NON-POSITIVE *****') WRITE (G_IO,99003) N 99003 FORMAT (' ','***** THE VALUE OF THE ARGUMENT IS ',I0,' *****') Cdf = 0.0_wp RETURN ELSEIF ( X<0.0_wp .OR. X>an ) THEN WRITE (G_IO,99004) N 99004 FORMAT (' ', & &'***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT TO THE BINC& &DF SUBROUTINE IS OUTSIDE THE USUAL (0,N) = (0,',I0,',INTERVAL *') WRITE (G_IO,99006) X IF ( X<0.0_wp ) Cdf = 0.0_wp IF ( X>an ) Cdf = 1.0_wp RETURN ELSE intx = X + 0.0001_wp fintx = intx del = X - fintx IF ( del<0.0_wp ) del = -del IF ( del>0.001_wp ) THEN WRITE (G_IO,99005) 99005 FORMAT (' ', & &'***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT TO THE BINC& &DF SUBROUTINE IS NON-INTEGRAL *****') WRITE (G_IO,99006) X ENDIF ! !-----START POINT----------------------------------------------------- ! ! TREAT IMMEDIATELY THE SPECIAL CASE OF X = N, ! IN WHICH CASE CDF = 1.0. ! ALSO TREAT IMMEDIATELY THE SPECIAL CASE OF P = 0.0_wp ! IN WHICH CASE CDF = 1.0 FOR ALL X. ! THIRDLY, TREAT THE SPECIAL CASE IN WHICH P = 1.0 ! IN WHICH CASE CDF = 0.0 FOR ALL X SMALLER THAN N ! AND CDF = 1.0 FOR ALL X EQUAL TO OR LARGER ! THAN N. ! intx = X + 0.0001_wp Cdf = 1.0_wp IF ( intx==N ) RETURN IF ( P==0.0_wp ) RETURN IF ( P==1.0_wp .AND. intx>=N ) RETURN IF ( P==1.0_wp .AND. intx<N ) Cdf = 0.0_wp IF ( P==1.0_wp .AND. intx<N ) RETURN ! ! EXPRESS THE BINOMIAL CUMULATIVE DISTRIBUTION ! FUNCTION IN TERMS OF THE EQUIVALENT F ! CUMULATIVE DISTRIBUTION FUNCTION, ! AND THEN EVALUATE THE LATTER. ! an = N dx = (P/(1.0_wp-P))*((an-X)/(X+1.0_wp)) nu1 = 2.0_wp*(X+1.0_wp) + 0.1_wp nu2 = 2.0_wp*(an-X) + 0.1_wp anu1 = nu1 anu2 = nu2 z = anu2/(anu2+anu1*dx) ! ! DETERMINE IF NU1 AND NU2 ARE EVEN OR ODD ! iflag1 = nu1 - 2*(nu1/2) iflag2 = nu2 - 2*(nu2/2) IF ( iflag1==0 ) THEN ! ! DO THE NU1 EVEN AND NU2 EVEN OR ODD CASE ! sum = 0.0D0 term = 1.0D0 imax = (nu1-2)/2 IF ( imax>0 ) THEN DO i = 1 , imax ai = i coef1 = 2.0D0*(ai-1.0D0) coef2 = 2.0D0*ai term = term*((anu2+coef1)/coef2)*(1.0D0-z) sum = sum + term ENDDO ENDIF ! sum = sum + 1.0D0 sum = (z**(anu2/2.0D0))*sum Cdf = sum RETURN ELSEIF ( iflag2==0 ) THEN ! ! DO THE NU1 ODD AND NU2 EVEN CASE ! sum = 0.0D0 term = 1.0D0 imax = (nu2-2)/2 IF ( imax>0 ) THEN DO i = 1 , imax ai = i coef1 = 2.0D0*(ai-1.0D0) coef2 = 2.0D0*ai term = term*((anu1+coef1)/coef2)*z sum = sum + term ENDDO ENDIF ! sum = sum + 1.0D0 Cdf = 1.0D0 - ((1.0D0-z)**(anu1/2.0D0))*sum RETURN ELSE ! ! DO THE NU1 ODD AND NU2 ODD CASE ! sum = 0.0D0 term = 1.0D0 arg = DSQRT((anu1/anu2)*dx) theta = DATAN(arg) sinth = arg/DSQRT(1.0D0+arg*arg) costh = 1.0D0/DSQRT(1.0D0+arg*arg) IF ( nu2/=1 ) THEN IF ( nu2/=3 ) THEN imax = nu2 - 2 DO i = 3 , imax , 2 ai = i coef1 = ai - 1.0D0 coef2 = ai term = term*(coef1/coef2)*(costh*costh) sum = sum + term ENDDO ENDIF ! sum = sum + 1.0D0 sum = sum*sinth*costh ENDIF ! a = (2.0D0/G_pi_dp)*(theta+sum) sum = 0.0D0 term = 1.0D0 IF ( nu1==1 ) b = 0.0D0 IF ( nu1/=1 ) THEN IF ( nu1/=3 ) THEN imax = nu1 - 3 DO i = 1 , imax , 2 ai = i coef1 = ai coef2 = ai + 2.0D0 term = term*((anu2+coef1)/coef2)*(sinth*sinth) sum = sum + term ENDDO ENDIF ! sum = sum + 1.0D0 sum = sum*sinth*(costh**N) coef = 1.0D0 ievodd = nu2 - 2*(nu2/2) imin = 3 IF ( ievodd==0 ) imin = 2 IF ( imin<=nu2 ) THEN DO i = imin , nu2 , 2 ai = i coef = ((ai-1.0D0)/ai)*coef ENDDO ENDIF ! coef = coef*anu2 IF ( ievodd /= 0 ) coef = coef*(2.0D0/G_pi_dp) ! b = coef*sum ENDIF ! Cdf = 1.0D0 - (a-b) ENDIF ENDIF 99006 FORMAT (' ','***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') ! END SUBROUTINE BINCDF !> !!##NAME !! binppf(3f) - [M_datapac:PERCENT_POINT] compute the binomial percent !! point function !! !!##SYNOPSIS !! !! SUBROUTINE BINPPF(P,Ppar,N,Ppf) !! !! REAL(kind=wp) :: P !! REAL(kind=wp) :: Ppar !! REAL(kind=wp) :: Ppf !! INTEGER :: N !! !!##DESCRIPTION !! BINPPF(3f) computes the percent point function value at the precision !! precision value P for the binomial distribution with REAL !! 'Bernoulli probability' parameter = PPAR, and integer 'number of !! Bernoulli trials' parameter = N. !! !! The binomial distribution used herein has mean = N*PPAR and standard !! deviation = sqrt(N*PPAR*(1-PPAR)). !! !! This distribution is defined for all discrete integer X between 0 !! (inclusively) and N (inclusively). !! !! This distribution has the probability function !! !! f(X) = c(N,X) * PPAR**X * (1-PPAR)**(N-X). !! !! where c(N,X) is the combinatorial function equaling the number of !! combinations of N items taken X at a time. !! !! The binomial distribution is the distribution of the number of !! successes in N Bernoulli (0,1) trials where the probability of success !! in a precision trial = PPAR. !! !! Note that the percent point function of a distribution is identically !! the same as the inverse cumulative distribution function of the !! distribution. !! !!##INPUT ARGUMENTS !! P The value (between 0.0 (inclusively) and 1.0 (inclusively)) !! at which the percent point function is to be evaluated. !! PPAR The value of the 'Bernoulli probability' parameter for the binomial !! distribution. PPAR should be between 0.0 (exclusively) and !! 1.0 (exclusively). !! N The integer value of the 'number of Bernoulli trials' parameter. !! N should be a positive integer. !! !!##OUTPUT ARGUMENTS !! PPF The percent point function value. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_binppf !! use M_datapac, only : binppf !! implicit none !! ! call binppf(x,y) !! end program demo_binppf !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the Statistical !! Engineering Division, National Institute of Standards and Technology. !!##MAINTAINER !! John Urban, 2022.05.31 !!##LICENSE !! CC0-1.0 !!##REFERENCES !! * Johnson and Kotz, Discrete !! Distributions, 1969, pages 50-86, !! especially page 64, Formula 36. !! * Hastings and Peacock, Statistical !! Distributions--A Handbook for !! Students and Practitioners, 1975, !! pages 36-41. !! * National Bureau of Standards Applied Mathematics !! Series 55, 1964, page 929. !! * Feller, An Introduction to Probability !! Theory and Its Applications, Volume 1, !! Edition 2, 1957, pages 135-142. !! * Kendall and Stuart, The Advanced Theory of !! Statistics, Volume 1, Edition 2, 1963, pages 120-125. !! * Mood and Grable, Introduction to the Theory !! of Statistics, Edition 2, 1963, pages 64-69. !! * Owen, Handbook of Statistical Tables, 1962, pages 264-272. ! ORIGINAL VERSION--NOVEMBER 1975. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE BINPPF(P,Ppar,N,Ppf) REAL(kind=wp) :: P REAL(kind=wp) :: Ppar REAL(kind=wp) :: Ppf INTEGER :: N REAL(kind=wp) :: amean , an, p0 , p1 , p2 , pf0 , qfn , sd , x0 , x1 , x2 , zppf INTEGER :: i , isd , ix0 , ix0p1 , ix1 , ix2 DOUBLE PRECISION :: dppar ! MODE OF INTERNAL OPERATIONS -- SINGLE AND DOUBLE PRECISION. ! COMMENT--NOTE THAT EVEN THOUGH THE OUTPUT ! FROM THIS DISCRETE DISTRIBUTION ! PERCENT POINT FUNCTION ! SUBROUTINE MUST NECESSARILY BE A ! DISCRETE INTEGER VALUE, ! THE OUTPUT VARIABLE PPF IS SINGLE ! PRECISION IN MODE. ! PPF HAS BEEN SPECIFIED AS SINGLE ! PRECISION SO AS TO CONFORM WITH THE DATAPAC ! CONVENTION THAT ALL OUTPUT VARIABLES FROM ALL ! DATAPAC SUBROUTINES ARE . ! THIS CONVENTION IS BASED ON THE BELIEF THAT ! 1) A MIXTURE OF MODES (FLOATING POINT ! VERSUS INTEGER) IS INCONSISTENT AND ! AN UNNECESSARY COMPLICATION ! IN A DATA ANALYSIS; AND ! 2) FLOATING POINT MACHINE ARITHMETIC ! (AS OPPOSED TO INTEGER ARITHMETIC) ! IS THE MORE NATURAL MODE FOR DOING ! DATA ANALYSIS. !--------------------------------------------------------------------- ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( P<0.0_wp .OR. P>1.0_wp ) THEN WRITE (G_IO,99001) 99001 FORMAT (' ***** FATAL ERROR--THE FIRST INPUT ARGUMENT TO BINPPF(3f) IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL *****') WRITE (G_IO,99019) P Ppf = 0.0_wp RETURN ELSE IF ( Ppar<=0.0_wp .OR. Ppar>=1.0_wp ) THEN WRITE (G_IO,99002) 99002 FORMAT (' ***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO BINPPF(3f) IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL *****') WRITE (G_IO,99019) Ppar Ppf = 0.0_wp RETURN ELSE IF ( N<1 ) THEN WRITE (G_IO,99003) 99003 FORMAT (' ***** FATAL ERROR--THE THIRD INPUT ARGUMENT TO BINPPF(3f) IS NON-POSITIVE *****') WRITE (G_IO,99004) N 99004 FORMAT (' ***** THE VALUE OF THE ARGUMENT IS ',I0,' *****') Ppf = 0.0_wp RETURN ELSE ! !-----START POINT----------------------------------------------------- ! an = N dppar = Ppar Ppf = 0.0_wp ix0 = 0 ix1 = 0 ix2 = 0 p0 = 0.0_wp p1 = 0.0_wp p2 = 0.0_wp ! ! TREAT CERTAIN SPECIAL CASES IMMEDIATELY-- ! 1) P = 0.0 OR 1.0 ! 2) P = 0.5 AND PPAR = 0.5 ! 3) PPF = 0 OR N ! IF ( P/=0.0_wp ) THEN IF ( P==1.0_wp ) GOTO 20 IF ( P==0.5_wp .AND. Ppar==0.5_wp ) THEN Ppf = N/2 RETURN ELSE pf0 = (1.0D0-dppar)**N qfn = 1.0D0 - (dppar**N) IF ( P>pf0 ) THEN IF ( P>qfn ) GOTO 20 ! ! DETERMINE AN INITIAL APPROXIMATION TO THE BINOMIAL ! PERCENT POINT BY USE OF THE NORMAL APPROXIMATION ! TO THE BINOMIAL. ! (SEE JOHNSON AND KOTZ, DISCRETE DISTRIBUTIONS, ! page 64, FORMULA 36). ! amean = an*Ppar sd = SQRT(an*Ppar*(1.0_wp-Ppar)) CALL NORPPF(P,zppf) x2 = amean - 0.5_wp + zppf*sd ix2 = x2 ! ! CHECK AND MODIFY (IF NECESSARY) THIS INITIAL ! ESTIMATE OF THE PERCENT POINT ! TO ASSURE THAT IT BE IN THE CLOSED INTERVAL 0 TO N. ! IF ( ix2<0 ) ix2 = 0 IF ( ix2>N ) ix2 = N ! ! DETERMINE UPPER AND LOWER BOUNDS ON THE DESIRED ! PERCENT POINT BY ITERATING OUT (BOTH BELOW AND ABOVE) ! FROM THE ORIGINAL APPROXIMATION AT STEPS ! OF 1 STANDARD DEVIATION. ! THE RESULTING BOUNDS WILL BE AT MOST ! 1 STANDARD DEVIATION APART. ! ix0 = 0 ix1 = N isd = sd + 1.0_wp x2 = ix2 CALL BINCDF(x2,Ppar,N,p2) ! IF ( p2<P ) THEN ! ix0 = ix2 DO i = 1 , 100000 ix2 = ix0 + isd IF ( ix2>=ix1 ) GOTO 200 x2 = ix2 CALL BINCDF(x2,Ppar,N,p2) IF ( p2>=P ) GOTO 50 ix0 = ix2 ENDDO WRITE (G_IO,99020) WRITE (G_IO,99005) ! 99005 FORMAT (' NO UPPER BOUND FOUND AFTER 10**7 ITERATIONS') ELSE ! ix1 = ix2 DO i = 1 , 100000 ix2 = ix1 - isd IF ( ix2<=ix0 ) GOTO 200 x2 = ix2 CALL BINCDF(x2,Ppar,N,p2) IF ( p2<P ) GOTO 100 ix1 = ix2 ENDDO WRITE (G_IO,99020) WRITE (G_IO,99006) 99006 FORMAT (' NO LOWER BOUND FOUND AFTER 10**7 ITERATIONS') ENDIF GOTO 300 ENDIF ENDIF ENDIF Ppf = 0.0_wp RETURN ENDIF 20 Ppf = N RETURN ENDIF 50 ix1 = ix2 GOTO 200 ENDIF 100 ix0 = ix2 ! 200 IF ( ix0==ix1 ) THEN IF ( ix0==0 ) THEN ix1 = ix1 + 1 ELSEIF ( ix0==N ) THEN ix0 = ix0 - 1 ELSE WRITE (G_IO,99020) WRITE (G_IO,99007) 99007 FORMAT (' ','LOWER AND UPPER BOUND IDENTICAL') GOTO 300 ENDIF ENDIF ! ! COMPUTE BINOMIAL PROBABILITIES FOR THE ! DERIVED LOWER AND UPPER BOUNDS. ! x0 = ix0 x1 = ix1 CALL BINCDF(x0,Ppar,N,p0) CALL BINCDF(x1,Ppar,N,p1) ! ! CHECK THE PROBABILITIES FOR PROPER ORDERING ! IF ( p0<P .AND. P<=p1 ) THEN DO ! ! THE STOPPING CRITERION IS THAT THE LOWER BOUND ! AND UPPER BOUND ARE EXACTLY 1 UNIT APART. ! CHECK TO SEE IF IX1 = IX0 + 1; ! IF SO, THE ITERATIONS ARE COMPLETE; ! IF NOT, THEN BISECT, COMPUTE PROBABILIIES, ! CHECK PROBABILITIES, AND CONTINUE ITERATING ! UNTIL IX1 = IX0 + 1. ! ix0p1 = ix0 + 1 IF ( ix1==ix0p1 ) THEN Ppf = ix1 IF ( p0==P ) Ppf = ix0 RETURN ELSE ix2 = (ix0+ix1)/2 IF ( ix2/=ix0 ) THEN IF ( ix2==ix1 ) THEN WRITE (G_IO,99020) WRITE (G_IO,99021) EXIT ELSE x2 = ix2 CALL BINCDF(x2,Ppar,N,p2) IF ( p0<p2 .AND. p2<p1 ) THEN IF ( p2<=P ) THEN ix0 = ix2 p0 = p2 ELSE ix1 = ix2 p1 = p2 ENDIF CYCLE ELSEIF ( p2<=p0 ) THEN WRITE (G_IO,99020) WRITE (G_IO,99008) 99008 FORMAT (' BISECTION VALUE PROBABILITY (P2) ','LESS THAN LOWER BOUND PROBABILITY (P0)') EXIT ELSEIF ( p2>=p1 ) THEN WRITE (G_IO,99020) WRITE (G_IO,99009) 99009 FORMAT (' ','BISECTION VALUE PROBABILITY (P2) GREATER THAN UPPER BOUND PROBABILITY (P1)') EXIT ENDIF ENDIF ENDIF WRITE (G_IO,99020) WRITE (G_IO,99021) EXIT ENDIF ENDDO ELSEIF ( p0==P ) THEN Ppf = ix0 RETURN ELSEIF ( p1==P ) THEN Ppf = ix1 RETURN ELSEIF ( p0>p1 ) THEN WRITE (G_IO,99020) WRITE (G_IO,99010) 99010 FORMAT (' ','LOWER BOUND PROBABILITY (P0) GREATER THAN UPPER BOUND PROBABILITY (P1)') ELSEIF ( p0>P ) THEN WRITE (G_IO,99020) WRITE (G_IO,99011) 99011 FORMAT (' ','LOWER BOUND PROBABILITY (P0) GREATER THAN INPUT PROBABILITY (P)') ELSEIF ( p1<P ) THEN WRITE (G_IO,99020) WRITE (G_IO,99012) 99012 FORMAT (' ','UPPER BOUND PROBABILITY (P1) LESS THAN INPUT PROBABILITY (P)') ELSE WRITE (G_IO,99020) WRITE (G_IO,99013) 99013 FORMAT (' ','IMPOSSIBLE BRANCH CONDITION ENCOUNTERED') ENDIF ! 300 continue WRITE (G_IO,99014) ix0 , p0 99014 FORMAT (' ','IX0 = ',I0,10X,'P0 = ',F14.7) WRITE (G_IO,99015) ix1 , p1 99015 FORMAT (' ','IX1 = ',I0,10X,'P1 = ',F14.7) WRITE (G_IO,99016) ix2 , p2 99016 FORMAT (' ','IX2 = ',I0,10X,'P2 = ',F14.7) WRITE (G_IO,99017) P 99017 FORMAT (' ','P = ',F14.7) WRITE (G_IO,99018) Ppar , N 99018 FORMAT (' ','PPAR = ',F14.7,10X,'N = ',I0) RETURN 99019 FORMAT (' ','***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') 99020 FORMAT (' ','***** INTERNAL ERROR IN BINPPF SUBROUTINE *****') 99021 FORMAT (' ','BISECTION VALUE (X2) = LOWER BOUND (X0)') 99022 FORMAT (' ','BISECTION VALUE (X2) = UPPER BOUND (X1)') ! END SUBROUTINE BINPPF !> !!##NAME !! binran(3f) - [M_datapac:RANDOM] generate binomial random numbers !! !!##SYNOPSIS !! !! SUBROUTINE BINRAN(N,P,Npar,Iseed,X) !! !! INTEGER,intent(in) :: N !! REAL(kind=wp),intent(in) :: P !! INTEGER,intent(in) :: Npar !! INTEGER,intent(inout) :: Iseed !! REAL(kind=wp),intent(out) :: X !! !!##DESCRIPTION !! BINRAN(3f) generates a random sample of size N from the binomial !! distribution with 'Bernoulli probability' parameter = !! P, and integer 'number of bernoulli trials' parameter = NPAR. !! !! The binomial distribution used herein has mean = NPAR*P and standard !! deviation = sqrt(NPAR*P*(1-P)). !! !! This distribution is defined for all discrete integer X between 0 !! (inclusively) and NPAR (inclusively). This distribution has the !! probability function !! !! f(X) = c(NPAR,X) * P**X * (1-P)**(NPAR-X) !! !! Where c(NPAR,X) is the combinatorial function equaling the number of !! combinations of NPAR items taken X at a time. !! !! The binomial distribution is the distribution of the number of !! successes in NPAR Bernoulli (0,1) trials where the probability of !! success in a precision trial = P. !! !!##OPTIONS !!##INPUT ARGUMENTS !! !! N The desired integer number of random numbers to be generated. !! !! P The value of the 'Bernoulli probability' parameter for the !! binomial distribution. P should be between 0.0 (exclusively) !! and 1.0 (exclusively). !! !! ISEED An integer iseed value. Should be set to a non-negative value !! to start a new sequence of values. Will be set to -1 on return !! to indicate the next call should continue the current random !! sequence walk. !! !! NPAR The integer value of the 'number of Bernoulli trials' !! parameter. NPAR should be a positive integer. !! !!##OUTPUT ARGUMENTS !! !! X A vector (of dimension at least N) into which the generated !! random sample of size N from the binomial distribution !! will be placed; with 'Bernoulli probability' parameter = P !! and 'number of Bernoulli trials' parameter = NPAR. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_binran !! use M_datapac, only : binran !! implicit none !! real :: x(40), P !! integer :: N, Npar, Iseed !! Iseed=0 !! P=0.88 !! N=size(x) !! Npar=11111 !! call BINRAN(N,P,Npar,Iseed,X) !! write(*,*)X !! end program demo_binran !! !! Results: !! !! 9746.000 9795.000 9855.000 9805.000 9787.000 !! 9746.000 9764.000 9774.000 9767.000 9752.000 !! 9770.000 9784.000 9821.000 9805.000 9784.000 !! 9734.000 9805.000 9813.000 9792.000 9785.000 !! 9784.000 9815.000 9785.000 9748.000 9718.000 !! 9728.000 9824.000 9782.000 9776.000 9850.000 !! 9770.000 9821.000 9819.000 9724.000 9783.000 !! 9789.000 9813.000 9798.000 9747.000 9785.000 !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !! !!##REFERENCES !! * Johnson and Kotz, Discrete Distributions, 1969, pages 50-86. !! * Hastings and Peacock, Statistical Distributions, !! A Handbook for Students and Practitioners, 1975, !! page 41. !! * Feller, An Introduction to Probability Theory and Its Applications, !! Volume 1, Edition 2, 1957, pages 135-142. !! * National Bureau of Standards Applied Mathematics !! Series 55, 1964, page 929. !! * Kendall and Stuart, The Advanced Theory of Statistics, !! Volume 1, Edition 2, 1963, pages 120-125. !! * Mood and Grable, Introduction to the Theory of Statistics, !! Edition 2, 1963, pages 64-69. !! * Tocher, The Art Of Simulation, 1963, pages 39-40. ! VERSION NUMBER--82/7 ! ORIGINAL VERSION--NOVEMBER 1975. ! UPDATED --DECEMBER 1981. ! UPDATED --MAY 1982. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE BINRAN(N,P,Npar,Iseed,X) INTEGER,intent(in) :: N REAL(kind=wp),intent(in) :: P INTEGER,intent(in) :: Npar INTEGER,intent(inout) :: Iseed REAL(kind=wp),intent(out) :: X(:) REAL(kind=wp) :: g(1) , u(1) INTEGER :: i , ig , isum , j ! ! NOTE THAT EVEN THOUGH THE OUTPUT FROM THIS DISCRETE RANDOM NUMBER ! GENERATOR MUST NECESSARILY BE A SEQUENCE OF ***INTEGER*** VALUES, ! THE OUTPUT VECTOR X IS SINGLE PRECISION IN MODE. X HAS BEEN SPECIFIED ! AS SINGLE PRECISION SO AS TO CONFORM WITH THE DATAPAC CONVENTION THAT ! ALL OUTPUT VECTORS FROM ALL THIS CONVENTION IS BASED ON THE BELIEF THAT ! ! 1) A MIXTURE OF MODES (FLOATING POINT VERSUS INTEGER) IS INCONSISTENT ! AND AN UNNECESSARY COMPLICATION IN A DATA ANALYSIS; AND ! 2) FLOATING POINT MACHINE ARITHMETIC (AS OPPOSED TO INTEGER ! ARITHMETIC) IS THE MORE NATURAL MODE FOR DOING DATA ANALYSIS. ! !-----START POINT----------------------------------------------------- ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( N<1 ) THEN WRITE (G_IO,99001) 99001 FORMAT (' ***** FATAL ERROR--THE FIRST INPUT ARGUMENT TO BINRAN(3f) IS NON-POSITIVE *****') WRITE (G_IO,99005) N RETURN ELSEIF ( P<=0.0_wp .OR. P>=1.0_wp ) THEN WRITE (G_IO,99002) 99002 FORMAT (' ***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO BINRAN(3f) IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL *****') WRITE (G_IO,99003) P 99003 FORMAT (' ','***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') RETURN ELSEIF ( Npar<1 ) THEN WRITE (G_IO,99004) 99004 FORMAT (' ','***** FATAL ERROR--THE THIRD INPUT ARGUMENT TO BINRAN(3f) IS NON-POSITIVE *****') WRITE (G_IO,99005) Npar RETURN ELSEIF ( P<0.1_wp ) THEN ! ! CHECK ON THE MAGNITUDE OF P, ! AND BRANCH TO THE FASTER ! GENERATION METHOD ACCORDINGLY. ! ! ! IF P IS SMALL, ! GENERATE N BINOMIAL NUMBERS ! USING THE FACT THAT THE ! WAITING TIME FOR 1 SUCCESS IN ! BERNOULLI TRIALS HAS A ! GEOMETRIC DISTRIBUTION. ! DO i = 1 , N isum = 0 j = 1 DO CALL GEORAN(1,P,Iseed,g) ig = g(1) + 0.5_wp isum = isum + ig + 1 IF ( isum>Npar ) THEN X(i) = j - 1 EXIT ELSE j = j + 1 ENDIF ENDDO ENDDO GOTO 99999 ENDIF ! ! IF P IS MODERATE OR LARGE, ! GENERATE N BINOMIAL RANDOM NUMBERS ! USING THE REJECTION METHOD. ! DO i = 1 , N isum = 0 DO j = 1 , Npar CALL UNIRAN(1,Iseed,u) IF ( u(1)<=P ) isum = isum + 1 ENDDO X(i) = isum ENDDO RETURN 99005 FORMAT (' ','***** THE VALUE OF THE ARGUMENT IS ',I0,' *****') 99999 continue END SUBROUTINE BINRAN !> !!##NAME !! caucdf(3f) - [M_datapac:CUMULATIVE_DISTRIBUTION] compute the Cauchy cumulative !! distribution function !! !!##SYNOPSIS !! !! !! subroutine caucdf(X,Cdf) !! !! real(kind=wp),intent(in) :: X !! real(kind=wp),intent(out) :: Cdf !! !!##DESCRIPTION !! CAUCDF(3f) computes the cumulative distribution function value for !! the Cauchy distribution with median = 0 and 75% point = 1. !! !! This distribution is defined for all X and has the probability !! density function !! !! f(X) = (1/pi)*(1/(1+X*X)) !! !!##INPUT ARGUMENTS !! !! X The value at which the cumulative distribution function is to !! be evaluated. !! !!##OUTPUT ARGUMENTS !! !! CDF The cumulative distribution function value. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_caucdf !! !@(#) line plotter graph of cumulative distribution function !! use M_datapac, only : caucdf, plott, label !! implicit none !! real,allocatable :: x(:), y(:) !! integer :: i !! call label('caucdf') !! x=[(real(i),i=-100,100,1)] !! if(allocated(y))deallocate(y) !! allocate(y(size(x))) !! do i=1,size(x) !! call caucdf(x(i)/10.0,y(i)) !! enddo !! call plott(x,y,size(x)) !! end program demo_caucdf !! !! Results: !! !! The following is a plot of Y(I) (vertically) versus X(I) (horizontally) !! I-----------I-----------I-----------I-----------I !! 0.1000000E+03 - X !! 0.9166666E+02 I X !! 0.8333334E+02 I X !! 0.7500000E+02 I XX !! 0.6666667E+02 I X !! 0.5833334E+02 I X !! 0.5000000E+02 - XX !! 0.4166667E+02 I XX !! 0.3333334E+02 I XX !! 0.2500000E+02 I XXX !! 0.1666667E+02 I XXXX !! 0.8333336E+01 I XXXXXXX !! 0.0000000E+00 - XX XX X XX XX !! -0.8333328E+01 I XXXXXXX !! -0.1666666E+02 I XXXX !! -0.2499999E+02 I XXX !! -0.3333333E+02 I XX !! -0.4166666E+02 I XX !! -0.5000000E+02 - XX !! -0.5833333E+02 I X !! -0.6666666E+02 I X !! -0.7500000E+02 I XX !! -0.8333333E+02 I X !! -0.9166666E+02 I X !! -0.1000000E+03 - X !! I-----------I-----------I-----------I-----------I !! 0.3173E-01 0.2659E+00 0.5000E+00 0.7341E+00 0.9683E+00 !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !!##MAINTAINER !! John Urban, 2022.05.31 !!##LICENSE !! CC0-1.0 !!##REFERENCES !! * Johnson and Kotz, Continuous Univariate Distributions -- 1, 1970, !! pages 154-165. ! ORIGINAL VERSION--JUNE 1972. ! UPDATED --SEPTEMBER 1975. ! UPDATED --NOVEMBER 1975. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 subroutine caucdf(X,Cdf) real(kind=wp),intent(in) :: X real(kind=wp),intent(out) :: Cdf ! CHECK THE INPUT ARGUMENTS FOR ERRORS ... NO INPUT ARGUMENT ERRORS POSSIBLE FOR THIS DISTRIBUTION. Cdf = 0.5_wp + ((1.0_wp/G_pi)*atan(X)) end subroutine caucdf !> !!##NAME !! caupdf(3f) - [M_datapac:PROBABILITY_DENSITY] compute the Cauchy probability !! density function !! !!##SYNOPSIS !! !! subroutine caupdf(X,Pdf) !! !! real(kind=wp),intent(in) :: X !! real(kind=wp),intent(out):: Pdf !! !!##DESCRIPTION !! CAUPDF(3f) computes the probability density function value for the !! Cauchy distribution with median = 0 and 75% point = 1. !! !! This distribution is defined for all X and has the probability !! density function !! !! f(x) = (1/pi)*(1/(1+x*x)) !! !!##INPUT ARGUMENTS !! !! X The value at which the probability density function is to be !! evaluated. !! !!##OUTPUT ARGUMENTS !! !! PDF The probability density function value. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_caupdf !! !@(#) line plotter graph of probability density function !! use M_datapac, only : caupdf, plott, label !! implicit none !! real,allocatable :: x(:), y(:) !! integer :: i !! call label('caupdf') !! x=[(real(i),i=-100,100,1)] !! if(allocated(y))deallocate(y) !! allocate(y(size(x))) !! do i=1,size(x) !! call caupdf(x(i)/10.0,y(i)) !! enddo !! call plott(x,y,size(x)) !! end program demo_caupdf !! !! Results: !! !! The following is a plot of Y(i) (vertically) versus X(i) (horizontally) !! I-----------I-----------I-----------I-----------I !! 0.1000000E+03 - X !! 0.9166666E+02 I X !! 0.8333334E+02 I X !! 0.7500000E+02 I X !! 0.6666667E+02 I XX !! 0.5833334E+02 I X !! 0.5000000E+02 - XX !! 0.4166667E+02 I XX !! 0.3333334E+02 I XX !! 0.2500000E+02 I XXXX !! 0.1666667E+02 I XXXXXX X X !! 0.8333336E+01 I X X X X X X X X !! 0.0000000E+00 - X X X X !! -0.8333328E+01 I X X X X X X X X !! -0.1666666E+02 I XXXXXX X X !! -0.2499999E+02 I XXXX !! -0.3333333E+02 I XX !! -0.4166666E+02 I XX !! -0.5000000E+02 - XX !! -0.5833333E+02 I X !! -0.6666666E+02 I XX !! -0.7500000E+02 I X !! -0.8333333E+02 I X !! -0.9166666E+02 I X !! -0.1000000E+03 - X !! I-----------I-----------I-----------I-----------I !! 0.3152E-02 0.8194E-01 0.1607E+00 0.2395E+00 0.3183E+00 !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !! !!##REFERENCES !! !! * Johnson and Kotz, Continuous Univariate Distributions -- 1, 1970, !! pages 154-165. ! ORIGINAL VERSION--JUNE 1972. ! UPDATED --SEPTEMBER 1975. ! UPDATED --NOVEMBER 1975. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 subroutine caupdf(X,Pdf) real(kind=wp),intent(in) :: X real(kind=wp),intent(out):: Pdf real(kind=wp),parameter :: c = 0.31830988618379_wp ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS -- NO INPUT ARGUMENT ERRORS POSSIBLE FOR THIS DISTRIBUTION. ! Pdf = c*(1.0_wp/(1.0_wp+X*X)) end subroutine caupdf !> !!##NAME !! cauplt(3f) - [M_datapac:LINE_PLOT] generate a Cauchy probability plot !! !!##SYNOPSIS !! !! SUBROUTINE CAUPLT(X,N) !! !! REAL(kind=wp),intent(in) :: X(:) !! INTEGER,intent(in) :: N !! !!##DESCRIPTION !! CAUPLT(3f) generates a one-page Cauchy probability plot. !! !! The prototype Cauchy distribution used herein has median = 0 and 75% !! point = 1. !! !! This distribution is defined for all X and has the probability !! density function !! !! f(X) = (1/pi) * (1/(1+X*X)) !! !! As used herein, a probability plot for a distribution is a plot !! of the ordered observations versus the order statistic medians for !! that distribution. !! !! The Cauchy probability plot is useful in graphically testing the !! composite (that is, location and scale parameters need not be !! specified) hypothesis that the underlying distribution from which !! the data have been randomly drawn is the Cauchy distribution. !! !! If the hypothesis is true, the probability plot should be near-linear. !! !! A measure of such linearity is given by the calculated probability !! plot correlation coefficient. !! !!##INPUT ARGUMENTS !! !! X The vector of (unsorted or sorted) observations. !! N The integer number of observations in the vector X. !! !!##OUTPUT !! !! A one-page Cauchy probability plot. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_cauplt !! use M_datapac, only : cauplt !! implicit none !! ! call cauplt(x,y) !! end program demo_cauplt !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !!##MAINTAINER !! John Urban, 2022.05.31 !!##LICENSE !! CC0-1.0 !!##REFERENCES !! * Filliben, 'Techniques for Tail Length Analysis', proceedings of the !! Eighteenth Conference on the Design of Experiments in Army Research !! Development and Testing (Aberdeen, Maryland, October, 1972), !! pages 425-450. !! * Hahn and Shapiro, Statistical Methods in Engineering, 1967, pages !! 260-308. !! * Johnson and Kotz, Continuous Univariate Distributions--1, 1970, !! pages 154-165. ! ORIGINAL VERSION--JUNE 1972. ! UPDATED --SEPTEMBER 1975. ! UPDATED --NOVEMBER 1975. ! UPDATED --FEBRUARY 1976. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE CAUPLT(X,N) REAL(kind=wp),intent(in) :: X(:) INTEGER,intent(in) :: N REAL(kind=wp) :: an, arg, cc, hold, sum1, sum2, sum3, tau, wbar, WS, ybar, yint, yslope REAL(kind=wp) :: Y(7500), W(7500) INTEGER :: i, iupper COMMON /BLOCK2_real32/ WS(15000) EQUIVALENCE (Y(1),WS(1)) EQUIVALENCE (W(1),WS(7501)) DATA tau/10.02040649_wp/ iupper = size(y) ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( N<1 .OR. N>iupper ) THEN WRITE (G_IO,99001) iupper 99001 FORMAT (' ***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO CAUPLT(3f) IS OUTSIDE THE ALLOWABLE (1,' & & ,I0,') INTERVAL *****') WRITE (G_IO,99002) N 99002 FORMAT (' ','***** THE VALUE OF THE ARGUMENT IS ',I0,' *****') RETURN ELSEIF ( N==1 ) THEN WRITE (G_IO,99003) 99003 FORMAT (' ***** NON-FATAL DIAGNOSTIC--THE SECOND INPUT ARGUMENT TO THE CAUPLT SUBROUTINE HAS THE VALUE 1 *****') RETURN ELSE hold = X(1) DO i = 2 , N IF ( X(i)/=hold ) GOTO 50 ENDDO WRITE (G_IO,99004) hold 99004 FORMAT (' ***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT (A VECTOR) TO CAUPLT(3f) HAS ALL ELEMENTS = ', & & E15.8,' *****') ! !-----START POINT----------------------------------------------------- ! 50 continue an = N ! ! SORT THE DATA ! CALL SORT(X,N,Y) ! ! GENERATE UNIFORM ORDER STATISTIC MEDIANS ! CALL UNIMED(N,W) ! ! COMPUTE CAUCHY ORDER STATISTIC MEDIANS ! DO i = 1 , N arg = G_pi*W(i) W(i) = -COS(arg)/SIN(arg) ENDDO ! ! PLOT THE ORDERED OBSERVATIONS VERSUS ORDER STATISTICS MEDIANS. ! WRITE OUT THE TAIL LENGTH MEASURE OF THE DISTRIBUTION ! AND THE SAMPLE SIZE. ! CALL PLOT(Y,W,N) WRITE (G_IO,99005) tau , N 99005 FORMAT (' ','CAUCHY PROBABILITY PLOT (TAU = ',E15.8,')',56X, 'THE SAMPLE SIZE N = ',I0) ! ! COMPUTE THE PROBABILITY PLOT CORRELATION COEFFICIENT. ! COMPUTE LOCATION AND SCALE ESTIMATES ! FROM THE INTERCEPT AND SLOPE OF THE PROBABILITY PLOT. ! THEN WRITE THEM OUT. ! sum1 = 0.0_wp DO i = 1 , N sum1 = sum1 + Y(i) ENDDO ybar = sum1/an wbar = 0.0_wp sum1 = 0.0_wp sum2 = 0.0_wp sum3 = 0.0_wp DO i = 1 , N sum1 = sum1 + (Y(i)-ybar)*(Y(i)-ybar) sum2 = sum2 + W(i)*Y(i) sum3 = sum3 + W(i)*W(i) ENDDO cc = sum2/SQRT(sum3*sum1) yslope = sum2/sum3 yint = ybar - yslope*wbar WRITE (G_IO,99006) cc , yint , yslope 99006 FORMAT (' PROBABILITY PLOT CORRELATION COEFFICIENT = ',F8.5,5X,& & 'ESTIMATED INTERCEPT = ',E15.8,3X,'ESTIMATED SLOPE = ',E15.8) ENDIF ! END SUBROUTINE CAUPLT !> !!##NAME !! cauppf(3f) - [M_datapac:PERCENT_POINT] compute the Cauchy percent point !! function !! !!##SYNOPSIS !! !! SUBROUTINE CAUPPF(P,Ppf) !! !! REAL(kind=wp) :: P !! REAL(kind=wp) :: Ppf !! REAL(kind=wp) :: arg !! !!##DESCRIPTION !! CAUPPF(3f) computes the percent point function value for the cauchy !! distribution with median = 0 and 75% point = 1. !! !! This distribution is defined for all x and has the probability !! density function !! !! f(X) = (1/pi)*(1/(1+X*X)) !! !! Note that the percent point function of a distribution is identically !! the same as the inverse cumulative distribution function of the !! distribution. !! !!##INPUT ARGUMENTS !! !! P The value (between 0.0 and 1.0) at which the percent point !! function is to be evaluated. !! !! P should be between 0.0 and 1.0, exclusively. !! !!##OUTPUT ARGUMENTS !! !! PPF The percent point function value. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_cauppf !! use M_datapac, only : cauppf, label !! implicit none !! call label('cauppf') !! ! call cauppf(x,y) !! end program demo_cauppf !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !! !!##REFERENCES !! !! * Filliben, Simple and Robust Linear Estimation !! of the Location Parameter of a Symmetric !! Distribution (Unpublished PH.D. Dissertation, !! Princeton University), 1969, pages 21-44, 229-231. !! * Filliben, 'The Percent Point Function', (Unpublished Manuscript), !! 1970, pages 28-31. !! * Johnson and Kotz, Continuous Univariate Distributions !! -- 1, 1970, pages 154-165. ! ORIGINAL VERSION--JUNE 1972. ! UPDATED --SEPTEMBER 1975. ! UPDATED --NOVEMBER 1975. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE CAUPPF(P,Ppf) REAL(kind=wp) :: P REAL(kind=wp) :: Ppf REAL(kind=wp) :: arg ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( P<=0.0_wp .OR. P>=1.0_wp ) THEN WRITE (G_IO,99001) 99001 FORMAT (' ',& & '***** FATAL ERROR--THE FIRST INPUT ARGUMENT TO CAUPPF(3f) IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL *****') WRITE (G_IO,99002) P 99002 FORMAT (' ','***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') RETURN ELSE arg = G_pi*P Ppf = -COS(arg)/SIN(arg) ENDIF END SUBROUTINE CAUPPF !> !!##NAME !! cauran(3f) - [M_datapac:RANDOM] generate Cauchy random numbers !! !!##SYNOPSIS !! !! SUBROUTINE CAURAN(N,Iseed,X) !! !! INTEGER,intent(in) :: N !! INTEGER,intent(inout) :: Iseed !! REAL(kind=wp),intent(out) :: X(:) !! !!##DESCRIPTION !! CAURAN(3f) generates a random sample of size N from the Cauchy !! distribution with median = 0 and 75% point = 1. !! !! This distribution is defined for all X and has the probability !! density function !! !! f(X) = (1/pi)*(1/(1+X*X)) !! !!##INPUT ARGUMENTS !! !! N The desired integer number of random numbers to be generated. !! !! ISEED An integer seed value. Should be set to a non-negative value !! to start a new sequence of values. Will be set to -1 on return !! to indicate the next call should continue the current random !! sequence walk. !! !!##OUTPUT ARGUMENTS !! !! X A vector (of dimension at least N) into which the generated !! random sample of size N function value for the Cauchy !! distribution will be placed. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_cauran !! use m_datapac, only : cauran, plott, label, plotxt, sort !! implicit none !! integer,parameter :: n=100 !! real :: x(n) !! integer :: iseed !! call label('cauran') !! iseed=12345 !! call cauran(n,iseed,x) !! write(*,*)x !! call plotxt(x,n) !! call sort(x,n,x) ! sort to show distribution !! call plotxt(x,n) !! end program demo_cauran !! !! Results: !! !! THE FOLLOWING IS A PLOT OF X(I) (VERTICALLY) VERSUS I (HORIZONTALLY !! I-----------I-----------I-----------I-----------I !! 0.8386762E+02 - X !! 0.7943768E+02 I !! 0.7500773E+02 I !! 0.7057778E+02 I !! 0.6614783E+02 I !! 0.6171789E+02 I !! 0.5728794E+02 - !! 0.5285799E+02 I !! 0.4842804E+02 I !! 0.4399810E+02 I !! 0.3956815E+02 I !! 0.3513820E+02 I !! 0.3070825E+02 - !! 0.2627831E+02 I !! 0.2184836E+02 I !! 0.1741841E+02 I !! 0.1298846E+02 I X X !! 0.8558517E+01 I X X X !! 0.4128571E+01 - X X X X X X XX XX !! -0.3013763E+00 I XXX XXXXXXXXXXXXXXXXXXX XXXXXXXXXXXXXXXXXXXXXXXXX !! -0.4731323E+01 I XX X X X X XX X X !! -0.9161270E+01 I !! -0.1359122E+02 I X !! -0.1802116E+02 I !! -0.2245111E+02 - X X X !! I-----------I-----------I-----------I-----------I !! 0.1000E+01 0.2575E+02 0.5050E+02 0.7525E+02 0.1000E+03 !! !! THE FOLLOWING IS A PLOT OF X(I) (VERTICALLY) VERSUS I (HORIZONTALLY !! I-----------I-----------I-----------I-----------I !! 0.8386762E+02 - X !! 0.7943768E+02 I !! 0.7500773E+02 I !! 0.7057778E+02 I !! 0.6614783E+02 I !! 0.6171789E+02 I !! 0.5728794E+02 - !! 0.5285799E+02 I !! 0.4842804E+02 I !! 0.4399810E+02 I !! 0.3956815E+02 I !! 0.3513820E+02 I !! 0.3070825E+02 - !! 0.2627831E+02 I !! 0.2184836E+02 I !! 0.1741841E+02 I !! 0.1298846E+02 I XX !! 0.8558517E+01 I XX !! 0.4128571E+01 - XXXXX !! -0.3013763E+00 I XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX !! -0.4731323E+01 I XXXXXX !! -0.9161270E+01 I !! -0.1359122E+02 I X !! -0.1802116E+02 I !! -0.2245111E+02 - XX !! I-----------I-----------I-----------I-----------I !! 0.1000E+01 0.2575E+02 0.5050E+02 0.7525E+02 0.1000E+03 !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !! !!##REFERENCES !! * Tocher, The Art of Simulation, 1963, page 15. !! * Hammersley and Handscomb, Monte Carlo Methods, 1964, page 36. !! * Filliben, Simple and Robust Linear Estimation of the Location Parameter !! of a Symmetric Distribution (Unpublished PH.D. Dissertation, Princeton !! University), 1969, page 231. !! * Filliben, 'The Percent Point Function', (Unpublished Manuscript), !! 1970, pages 28-31. !! * Johnson and Kotz, Continuous Univariate Distributions--1, 1970, !! pages 154-165. ! VERSION NUMBER--82/7 ! ORIGINAL VERSION--JUNE 1972. ! UPDATED --SEPTEMBER 1975. ! UPDATED --NOVEMBER 1975. ! UPDATED --DECEMBER 1981. ! UPDATED --MAY 1982. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE CAURAN(N,Iseed,X) INTEGER,intent(in) :: N INTEGER,intent(inout) :: Iseed REAL(kind=wp),intent(out) :: X(:) REAL(kind=wp) :: arg , pi INTEGER :: i DATA pi/3.14159265359_wp/ ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( N<1 ) THEN WRITE (G_IO,99001) 99001 FORMAT (' ***** FATAL ERROR--The first input argument to CAURAN(3f) is non-positive *****') WRITE (G_IO,99002) N 99002 FORMAT (' ***** The value of the argument is ',I0,' *****') RETURN ELSE ! ! GENERATE N UNIFORM (0,1) RANDOM NUMBERS; ! CALL UNIRAN(N,Iseed,X) ! ! GENERATE N CAUCHY RANDOM NUMBERS ! USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD. ! DO i = 1 , N arg = pi*X(i) X(i) = -COS(arg)/SIN(arg) ENDDO ENDIF END SUBROUTINE CAURAN !> !!##NAME !! causf(3f) - [M_datapac:SPARSITY] compute the Cauchy sparsity function !! !!##SYNOPSIS !! !! !! SUBROUTINE CAUSF(P,Sf) !! !! REAL(kind=wp) :: P !! REAL(kind=wp) :: Sf !! !!##DESCRIPTION !! !! CAUSF(3f) computes the sparsity function value for the cauchy !! distribution with median = 0 and 75% point = 1. !! !! This distribution is defined for all X and has the probability density !! !! function f(X) = (1/pi)*(1/(1+X*X)) !! !! Note that the sparsity function of a distribution is the derivative !! of the percent point function, and also is the reciprocal of the !! probability density function (but in units of p rather than x). !! !!##INPUT ARGUMENTS !! P the value (between 0.0 and 1.0) at which the sparsity !! function is to be evaluated. P should be between 0.0 and 1.0, !! exclusively. !! !!##OUTPUT ARGUMENTS !! SF The sparsity function value. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_causf !! use M_datapac, only : causf !! implicit none !! ! call causf(x,y) !! end program demo_causf !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !! !!##REFERENCES !! !! * Filliben, Simple and Robust Linear Estimation of the Location Parameter !! of a Symmetric Distribution (Unpublished PH.D. Dissertation, Princeton !! University), 1969, pages 21-44, 229-231. !! * Filliben, 'The Percent Point Function', (Unpublished manuscript), !! 1970, pages 28-31. !! * Johnson and Kotz, Continuous Univariate Distributions--1, 1970, !! pages 154-165. ! ORIGINAL VERSION--JUNE 1972. ! UPDATED --SEPTEMBER 1975. ! UPDATED --NOVEMBER 1975. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE CAUSF(P,Sf) REAL(kind=wp) :: P REAL(kind=wp) :: Sf REAL(kind=wp) :: arg ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( P<=0.0_wp .OR. P>=1.0_wp ) THEN WRITE (G_IO,99001) 99001 FORMAT (' ***** FATAL ERROR--THE FIRST INPUT ARGUMENT TO CAUSF(3f) IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL *****') WRITE (G_IO,99002) P 99002 FORMAT (' ','***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') RETURN ELSE arg = G_pi*P Sf = G_pi/((SIN(arg))**2) ENDIF ! END SUBROUTINE CAUSF !> !!##NAME !! chscdf(3f) - [M_datapac:CUMULATIVE_DISTRIBUTION] compute the chi-square cumulative !! distribution function !! !!##SYNOPSIS !! !! SUBROUTINE CHSCDF(X,Nu,Cdf) !! !! REAL(kind=wp),intent(in) :: X !! REAL(kind=wp),intent(out) :: Cdf !! INTEGER,intent(in) :: Nu !! !!##DESCRIPTION !! CHSCDF(3f) computes the cumulative distribution function value for !! the chi-squared distribution with integer degrees of freedom parameter !! = NU. !! !! This distribution is defined for all non-negative X. !! !! The probability density function is given in the references below. !! !!##INPUT ARGUMENTS !! !! X The value at which the cumulative distribution function is to !! be evaluated. X should be non-negative. !! !! NU The integer number of degrees of freedom. NU should be positive. !! !!##OUTPUT ARGUMENTS !! !! CDF The cumulative distribution function value. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_chscdf !! use M_datapac, only : chscdf !! implicit none !! ! call chscdf(x,y) !! end program demo_chscdf !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the Statistical !! Engineering Division, National Institute of Standards and Technology. !!##MAINTAINER !! John Urban, 2022.05.31 !!##LICENSE !! CC0-1.0 !!##REFERENCES !! * National Bureau of Standards Applied Mathematics Series 55, 1964, !! page 941, Formulae 26.4.4 and 26.4.5. !! * Johnson and Kotz, Continuous Univariate Distributions--1, 1970, !! page 176, Formula 28, and page 180, Formula 33.1. !! * Owen, Handbook of Statistical Tables, 1962, pages 50-55. !! * Pearson and Hartley, Biometrika Tables for Statisticians, Volume 1, !! 1954, pages 122-131. ! ORIGINAL VERSION--JUNE 1972. ! UPDATED --MAY 1974. ! UPDATED --SEPTEMBER 1975. ! UPDATED --NOVEMBER 1975. ! UPDATED --OCTOBER 1976. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE CHSCDF(X,Nu,Cdf) REAL(kind=wp),intent(in) :: X REAL(kind=wp),intent(out) :: Cdf INTEGER,intent(in) :: Nu REAL(kind=wp) :: amean , anu , cdfn , danu , sd , spchi , u , z INTEGER :: i , ibran , ievodd , imax , imin , nucut DOUBLE PRECISION dx , chi , sum , term , ai , dcdfn DOUBLE PRECISION dnu DOUBLE PRECISION DSQRT , DEXP DOUBLE PRECISION DLOG DOUBLE PRECISION dfact , dpower DOUBLE PRECISION dw DOUBLE PRECISION d1 , d2 , d3 DOUBLE PRECISION term0 , term1 , term2 , term3 , term4 DOUBLE PRECISION b11 DOUBLE PRECISION b21 DOUBLE PRECISION b31 , b32 DOUBLE PRECISION b41 , b42 , b43 DATA nucut/1000/ DATA dpower/0.33333333333333D0/ DATA b11/0.33333333333333D0/ DATA b21/ - 0.02777777777778D0/ DATA b31/ - 0.00061728395061D0/ DATA b32/ - 13.0D0/ DATA b41/0.00018004115226D0/ DATA b42/6.0D0/ DATA b43/17.0D0/ ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( Nu<=0 ) THEN WRITE (G_IO,99001) 99001 FORMAT (' ', & &'***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE CHSCDF SUBROU& &TINE IS NON-POSITIVE *****') WRITE (G_IO,99002) Nu 99002 FORMAT (' ','***** THE VALUE OF THE ARGUMENT IS ',I0,' *****') Cdf = 0.0_wp RETURN ELSE IF ( X<0.0_wp ) THEN WRITE (G_IO,99003) 99003 FORMAT (' ', & &'***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT TO THE CHSC& &DF SUBROUTINE IS NEGATIVE *****') WRITE (G_IO,99004) X 99004 FORMAT (' ','***** THE VALUE OF THE ARGUMENT IS ',E15.8, & & ' *****') Cdf = 0.0_wp RETURN ELSE ! !-----START POINT----------------------------------------------------- ! dx = X anu = Nu dnu = Nu ! ! IF X IS NON-POSITIVE, SET CDF = 0.0 AND RETURN. ! IF NU IS SMALLER THAN 10 AND X IS MORE THAN 200 ! STANDARD DEVIATIONS BELOW THE MEAN, ! SET CDF = 0.0 AND RETURN. ! IF NU IS 10 OR LARGER AND X IS MORE THAN 100 ! STANDARD DEVIATIONS BELOW THE MEAN, ! SET CDF = 0.0 AND RETURN. ! IF NU IS SMALLER THAN 10 AND X IS MORE THAN 200 ! STANDARD DEVIATIONS ABOVE THE MEAN, ! SET CDF = 1.0 AND RETURN. ! IF NU IS 10 OR LARGER AND X IS MORE THAN 100 ! STANDARD DEVIATIONS ABOVE THE MEAN, ! SET CDF = 1.0 AND RETURN. ! IF ( X>0.0_wp ) THEN amean = anu sd = SQRT(2.0_wp*anu) z = (X-amean)/sd IF ( Nu>=10 .OR. z>=-200.0_wp ) THEN IF ( Nu<10 .OR. z>=-100.0_wp ) THEN IF ( Nu<10 .AND. z>200.0_wp ) GOTO 50 IF ( Nu>=10 .AND. z>100.0_wp ) GOTO 50 ! ! DISTINGUISH BETWEEN 3 SEPARATE REGIONS ! OF THE (X,NU) SPACE. ! BRANCH TO THE PROPER COMPUTATIONAL METHOD ! DEPENDING ON THE REGION. ! NUCUT HAS THE VALUE 1000. ! IF ( Nu<nucut ) THEN ! ! TREAT THE SMALL AND MODERATE DEGREES OF FREEDOM CASE ! (THAT IS, WHEN NU IS SMALLER THAN 1000). ! METHOD UTILIZED--EXACT FINITE SUM ! (SEE AMS 55, page 941, FORMULAE 26.4.4 AND 26.4.5). ! chi = DSQRT(dx) ievodd = Nu - 2*(Nu/2) IF ( ievodd==0 ) THEN ! sum = 1.0D0 term = 1.0D0 imin = 2 imax = Nu - 2 ELSE ! sum = 0.0D0 term = 1.0_wp/chi imin = 1 imax = Nu - 1 ENDIF ! IF ( imin<=imax ) THEN DO i = imin , imax , 2 ai = i term = term*(dx/ai) sum = sum + term ENDDO ENDIF ! sum = sum*DEXP(-dx/2.0D0) IF ( ievodd/=0 ) THEN sum = (DSQRT(2.0D0/G_pi_dp))*sum spchi = chi CALL NORCDF(spchi,cdfn) dcdfn = cdfn sum = sum + 2.0D0*(1.0D0-dcdfn) ENDIF GOTO 100 ELSEIF ( Nu>=nucut .AND. X<=anu ) THEN ! ! TREAT THE CASE WHEN NU IS LARGE ! (THAT IS, WHEN NU IS EQUAL TO OR GREATER THAN 1000) ! AND X IS LESS THAN OR EQUAL TO NU. ! METHOD UTILIZED--WILSON-HILFERTY APPROXIMATION ! (SEE JOHNSON AND KOTZ, VOLUME 1, page 176, FORMULA 28). ! dfact = 4.5D0*dnu u = (((dx/dnu)**dpower)-1.0D0+(1.0D0/dfact)) & & *DSQRT(dfact) CALL NORCDF(u,cdfn) Cdf = cdfn RETURN ELSEIF ( Nu>=nucut .AND. X>anu ) THEN ! ! TREAT THE CASE WHEN NU IS LARGE ! (THAT IS, WHEN NU IS EQUAL TO OR GREATER THAN 1000) ! AND X IS LARGER THAN NU. ! METHOD UTILIZED--HILL'S ASYMPTOTIC EXPANSION ! (SEE JOHNSON AND KOTZ, VOLUME 1, page 180, FORMULA 33.1). ! dw = DSQRT(dx-dnu-dnu*DLOG(dx/dnu)) danu = DSQRT(2.0D0/dnu) d1 = dw d2 = dw**2 d3 = dw**3 term0 = dw term1 = b11*danu term2 = b21*d1*(danu**2) term3 = b31*(d2+b32)*(danu**3) term4 = b41*(b42*d3+b43*d1)*(danu**4) u = term0 + term1 + term2 + term3 + term4 CALL NORCDF(u,cdfn) Cdf = cdfn GOTO 99999 ELSE ibran = 1 WRITE (G_IO,99005) ibran 99005 FORMAT (' ', & & '*****INTERNAL ERROR IN CHSCDF SUBROUTINE--'& & , & & 'IMPOSSIBLE BRANCH CONDITION AT BRANCH POINT = '& & ,I0) RETURN ENDIF ENDIF ENDIF ENDIF Cdf = 0.0_wp RETURN ENDIF 50 Cdf = 1.0_wp RETURN ENDIF 100 Cdf = 1.0D0 - sum RETURN ! 99999 END SUBROUTINE CHSCDF !> !!##NAME !! chsplt(3f) - [M_datapac:LINE_PLOT] generate a Chi-square probability !! plot !! !!##SYNOPSIS !! !! SUBROUTINE CHSPLT(X,N,Nu) !! !! REAL(kind=wp),intent(in) :: X(:) !! INTEGER,intent(in) :: N !! INTEGER,intent(in) :: Nu !! !!##DESCRIPTION !! Chsplt(3f) generates a Chi-squared probability plot (with integer !! degrees of freedom parameter value = NU). !! !! The prototype Chi-squared distribution used herein is defIned for all !! non-negative X, and its probability density function is given in the !! references below. !! !! As used herein, a probability plot for a distribution is a plot !! of the ordered observations versus the order statistic medians for !! that distribution. !! !! The Chi-squared probability plot is useful in graphically testing !! the composite (that is, location and scale parameters need not be !! specified) hypothesis that the underlying distribution from which !! the data have been randomly drawn is the Chi-squared distribution !! with degrees of freedom parameter value = NU. !! !! If the hypothesis is true, the probability plot should be near-linear. !! !! a measure of such linearity is given by the calculated probability !! plot correlation coefficient. !! !!##INPUT ARGUMENTS !! X The vector of (unsorted or sorted) observations. !! !! N The integer number of observations in the vector X. !! NU should be positive. The maximum allowable value of N for !! this subroutine is 7500. !! !! NU The integer number of degrees of freedom. NU should be positive. !! !!##OUTPUT !! !! A one-page Chi-squared probability plot. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_chsplt !! use M_datapac, only : chsplt !! implicit none !! ! call chsplt(x,y) !! end program demo_chsplt !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !!##REFERENCES !! * Wilk, Gnanadesikan, and Huyett, 'Probability Plots for the Gamma !! Distribution', Technometrics, 1962, pages 1-15. !! * Filliben, 'Techniques for Tail Length Analysis', Proceedings of the !! Eighteenth Conference on the Design of Experiments in Army Research !! Development and Testing (Aberdeen, Maryland, October, 1972), pages !! 425-450. !! * Hahn and Shapiro, Statistical Methods in Engineering, 1967, pages !! 260-308. !! * Johnson and Kotz, Continuous Univariate Distributions--1, 1970, !! pages 166-206. !! * Hastings and Peacock, Statistical Distributions--A Handbook for Students !! and Practitioners, 1975, pages 46-51. ! ORIGINAL VERSION--NOVEMBER 1975. ! UPDATED --FEBRUARY 1976. ! UPDATED --FEBRUARY 1977. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE CHSPLT(X,N,Nu) REAL(kind=wp),intent(in) :: X(:) INTEGER,intent(in) :: N INTEGER,intent(in) :: Nu REAL(kind=wp) :: an, cc, hold, pp0025, pp025, pp975, pp9975, q, sum1, sum2, sum3, tau, W, wbar, WS, ybar, yint, yslope, Y INTEGER :: i, iupper ! !--------------------------------------------------------------------- DIMENSION Y(7500) , W(7500) COMMON /BLOCK2_real32/ WS(15000) EQUIVALENCE (Y(1),WS(1)) EQUIVALENCE (W(1),WS(7501)) iupper = 7500 ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( N<1 .OR. N>iupper ) THEN WRITE (G_IO,99001) iupper 99001 FORMAT(' ***** FATAL ERROR--The second input argument to CHSPLT(3f) is outside the allowable (1,',& & i0,') interval *****') WRITE (G_IO,99007) N RETURN ELSEIF ( N==1 ) THEN WRITE (G_IO,99002) 99002 FORMAT (' ***** NON-FATAL DIAGNOSTIC--The second input argument to CHSPLT(3f) has the value 1 *****') RETURN ELSE IF ( Nu<=0 ) THEN WRITE (G_IO,99003) 99003 FORMAT (' ***** FATAL ERROR--The third input argument to CHSPLT(3f) is non-positive *****') WRITE (G_IO,99007) Nu RETURN ELSE hold = X(1) DO i = 2 , N IF ( X(i)/=hold ) GOTO 50 ENDDO WRITE (G_IO,99004) hold 99004 FORMAT (' ***** NON-FATAL DIAGNOSTIC--The first input argument (a vector) to CHSPLT(3f) has all elements = ',& & E15.8,' *****') RETURN ENDIF ! !-----START POINT----------------------------------------------------- 50 an = N ! ! SORT THE DATA ! CALL SORT(X,N,Y) ! ! GENERATE UNIFORM ORDER STATISTIC MEDIANS ! CALL UNIMED(N,W) ! ! COMPUTE CHI-SQUARED DISTRIBUTION ORDER STATISTIC MEDIANS ! DO i = 1 , N CALL CHSPPF(W(i),Nu,W(i)) ENDDO ! ! PLOT THE ORDERED OBSERVATIONS VERSUS ORDER STATISTICS MEDIANS. ! COMPUTE THE TAIL LENGTH MEASURE OF THE DISTRIBUTION. ! WRITE OUT THE TAIL LENGTH MEASURE OF THE DISTRIBUTION ! AND THE SAMPLE SIZE. ! CALL PLOT(Y,W,N) q = .9975_wp CALL CHSPPF(q,Nu,pp9975) q = .0025_wp CALL CHSPPF(q,Nu,pp0025) q = .975_wp CALL CHSPPF(q,Nu,pp975) q = .025_wp CALL CHSPPF(q,Nu,pp025) tau = (pp9975-pp0025)/(pp975-pp025) WRITE (G_IO,99005) Nu , tau , N 99005 FORMAT (' ', & & 'Chi-squared probability plot with degrees of freedom = '& & ,I0,1X,'(TAU = ',E15.8,')',11X,'The sample size N = ',I0) ! ! COMPUTE THE PROBABILITY PLOT CORRELATION COEFFICIENT. ! COMPUTE LOCATION AND SCALE ESTIMATES ! FROM THE INTERCEPT AND SLOPE OF THE PROBABILITY PLOT. ! THEN WRITE THEM OUT. ! sum1 = 0.0_wp sum2 = 0.0_wp DO i = 1 , N sum1 = sum1 + Y(i) sum2 = sum2 + W(i) ENDDO ybar = sum1/an wbar = sum2/an sum1 = 0.0_wp sum2 = 0.0_wp sum3 = 0.0_wp DO i = 1 , N sum1 = sum1 + (Y(i)-ybar)*(Y(i)-ybar) sum2 = sum2 + (Y(i)-ybar)*(W(i)-wbar) sum3 = sum3 + (W(i)-wbar)*(W(i)-wbar) ENDDO cc = sum2/SQRT(sum3*sum1) yslope = sum2/sum3 yint = ybar - yslope*wbar WRITE (G_IO,99006) cc , yint , yslope 99006 FORMAT (' ','Probability plot correlation coefficient = ',F8.5,& & 5X,'Estimated intercept = ',E15.8,3X, & & 'Estimated slope = ',E15.8) ENDIF 99007 FORMAT (' ','***** The value of the argument is ',I0,' *****') END SUBROUTINE CHSPLT !> !!##NAME !! chsppf(3f) - [M_datapac:PERCENT_POINT] compute the chi-square percent !! point function !! !!##SYNOPSIS !! !! SUBROUTINE CHSPPF(P,Nu,Ppf) !! !! REAL(kind=wp) :: P !! REAL(kind=wp) :: Ppf !! INTEGER :: Nu !! !!##DESCRIPTION !! CHSPPF(3f) computes the percent point function value for the !! chi-squared distribution with integer degrees of freedom parameter !! = nu. !! !! The chi-squared distribution used herein is defined for all !! non-negative x, and its probability density function is given in !! references 2, 3, and 4 below. !! !! Note that the percent point function of a distribution is identically !! the same as the inverse cumulative distribution function of the !! distribution. !! !!##INPUT ARGUMENTS !! !! P The value (between 0.0 (inclusively) and 1.0 (exclusively)) !! at which the percent point function is to be evaluated. !! !! NU The integer number of degrees of freedom. NU should be positive. !! !!##OUTPUT ARGUMENTS !! !! PPF The percent point function value for the chi-squared !! distribution !! !!##ACCURACY !! (On the UNIVAC 1108, EXEC 8 System at NBS) Compared to the known NU !! = 2 (exponential) results, agreement was had out to 6 significant !! digits for all tested P in the range P = .001 to P = .999. for P = !! .95 And smaller, The agreement was even better--7 significant digits. !! (Note that the tabulated values given in the Wilk, Gnanadesikan, !! and Huyett reference below, page 20, are in error for at least the !! GAMMA = 1 case-- The worst detected error was agreement to only 3 !! significant digits (in their 8 significant digit table) for P = .999.) !! !!##EXAMPLES !! !! Sample program: !! !! program demo_chsppf !! use M_datapac, only : chsppf !! implicit none !! ! call chsppf(x,y) !! end program demo_chsppf !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !! !!##REFERENCES !! * Wilk, gnanadesikan, and huyett, 'probability plots for the gamma !! Distribution', technometrics, 1962, pages 1-15, especially pages 3-5. !! * National bureau of standards applied mathematics series 55, 1964, !! page 257, formula 6.1.41, and pages 940-943. !! * Johnson and kotz, continuous univariate distributions--1, 1970, !! pages 166-206. !! * Hastings and peacock, statistical distributions--a handbook for !! Students and practitioners, 1975, pages 46-51. ! ORIGINAL VERSION--SEPTEMBER 1975. ! UPDATED --NOVEMBER 1975. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE CHSPPF(P,Nu,Ppf) REAL(kind=wp) :: P REAL(kind=wp) :: Ppf INTEGER :: Nu REAL(kind=wp) :: anu , dnu , gamma INTEGER :: icount , iloop , j , maxit DOUBLE PRECISION :: dp , dgamma DOUBLE PRECISION :: z , z2 , z3 , z4 , z5 , den , a , b , c , d(10) , g 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 :: DEXP , DLOG DATA c/.918938533204672741D0/ DATA d(1) , d(2) , d(3) , d(4) , d(5)/ + .833333333333333333D-1 , & & -.277777777777777778D-2 , +.793650793650793651D-3 , & & -.595238095238095238D-3 , +.841750841750841751D-3/ DATA d(6) , d(7) , d(8) , d(9) , d(10)/ - .191752691752691753D-2 ,& & +.641025641025641025D-2 , -.295506535947712418D-1 , & & +.179644372368830573D0 , -.139243221690590111D1/ ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( P<0.0_wp .OR. P>=1.0_wp ) THEN WRITE (G_IO,99001) 99001 FORMAT (' ', & &'***** FATAL ERROR--THE FIRST INPUT ARGUMENT TO THE CHSPPF SUBROU& &TINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL *****') WRITE (G_IO,99002) P 99002 FORMAT (' ','***** THE VALUE OF THE ARGUMENT IS ',E15.8, & & ' *****') Ppf = 0.0_wp RETURN ELSEIF ( Nu<1 ) THEN WRITE (G_IO,99003) 99003 FORMAT (' ', & &'***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE CHSPPF SUBROU& &TINE IS NON-POSITIVE *****') WRITE (G_IO,99004) Nu 99004 FORMAT (' ','***** THE VALUE OF THE ARGUMENT IS ',I0,' *****') Ppf = 0.0_wp RETURN ELSE ! !-----START POINT----------------------------------------------------- ! ! EXPRESS THE CHI-SQUARED DISTRIBUTION PERCENT POINT ! FUNCTION IN TERMS OF THE EQUIVALENT GAMMA ! DISTRIBUTION PERCENT POINT FUNCTION, ! AND THEN EVALUATE THE LATTER. ! anu = Nu gamma = anu/2.0_wp dp = P dnu = Nu dgamma = dnu/2.0D0 maxit = 10000 ! ! COMPUTE THE GAMMA FUNCTION USING THE ALGORITHM IN THE ! NBS APPLIED MATHEMATICS SERIES REFERENCE. ! THIS GAMMA FUNCTION NEED BE CALCULATED ONLY ONCE. ! IT IS USED IN THE CALCULATION OF THE CDF BASED ON ! THE TENTATIVE VALUE OF THE PPF IN THE ITERATION. ! z = dgamma den = 1.0D0 DO WHILE ( z<10.0D0 ) den = den*z z = z + 1.0D0 ENDDO 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) & & + d(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 ! ! DETERMINE LOWER AND UPPER LIMITS ON THE DESIRED 100P ! PERCENT POINT. ! iloop = 1 xmin0 = (dp*dgamma*g)**(1.0D0/dgamma) xmin = xmin0 icount = 1 ENDIF 100 ai = icount xmax = ai*xmin0 dx = xmax GOTO 500 200 xmid = (xmin+xmax)/2.0D0 ! ! NOW ITERATE BY BISECTION UNTIL THE DESIRED ACCURACY IS ACHIEVED. ! iloop = 2 xlower = xmin xupper = xmax icount = 0 300 dx = xmid GOTO 500 400 Ppf = 2.0D0*xmid RETURN ! !******************************************************************** ! THIS SECTION BELOW IS LOGICALLY SEPARATE FROM THE ABOVE. ! THIS SECTION COMPUTES A CDF VALUE FOR ANY GIVEN TENTATIVE ! PERCENT POINT X VALUE AS DEFINED IN EITHER OF THE 2 ! ITERATION LOOPS IN THE ABOVE CODE. ! ! COMPUTE T-SUB-Q AS DEFINED ON page 4 OF THE WILK, GNANADESIKAN, ! AND HUYETT REFERENCE ! 500 sum = 1.0D0/dgamma term = 1.0D0/dgamma cut1 = dx - dgamma cut2 = dx*10000000000.0D0 DO j = 1 , maxit aj = j term = dx*term/(dgamma+aj) sum = sum + term cutoff = cut1 + (cut2*term/sum) IF ( aj>cutoff ) GOTO 600 ENDDO WRITE (G_IO,99005) maxit ! 99005 FORMAT (' ','*****ERROR IN INTERNAL OPERATIONS IN THE CHSPPF ', & & 'SUBROUTINE--THE NUMBER OF ITERATIONS EXCEEDS ',I0) WRITE (G_IO,99006) P 99006 FORMAT (' ',' THE INPUT VALUE OF P IS ',E15.8) WRITE (G_IO,99007) Nu 99007 FORMAT (' ',' THE INPUT VALUE OF NU IS ',I0) WRITE (G_IO,99008) 99008 FORMAT (' ',' THE OUTPUT VALUE OF PPF HAS BEEN SET TO 0.0') Ppf = 0.0_wp RETURN ! 600 t = sum pcalc = (dx**dgamma)*(DEXP(-dx))*t/g IF ( iloop==1 ) THEN IF ( pcalc>=dp ) GOTO 200 xmin = xmax icount = icount + 1 IF ( icount>30000 ) GOTO 200 GOTO 100 ELSE IF ( pcalc==dp ) GOTO 400 IF ( pcalc>dp ) THEN xupper = xmid xmid = (xmid+xlower)/2.0D0 ELSE xlower = xmid xmid = (xmid+xupper)/2.0D0 ENDIF xdel = xmid - xlower IF ( xdel<0.0D0 ) xdel = -xdel icount = icount + 1 IF ( xdel>=0.0000000001D0 .AND. icount<=100 ) GOTO 300 GOTO 400 ENDIF ! END SUBROUTINE CHSPPF !> !!##NAME !! chsran(3f) - [M_datapac:RANDOM] generate chi-square random numbers !! !!##SYNOPSIS !! !! SUBROUTINE CHSRAN(N,Nu,Iseed,X) !! !! INTEGER,intent(in) :: N !! INTEGER,intent(in) :: Nu !! INTEGER,intent(inout) :: Iseed !! REAL(kind=wp),intent(out) :: X(:) !! !!##DESCRIPTION !! CHSRAN(3f) generates a random sample of size n from the chi-squared !! distribution with integer degrees of freedom parameter = NU. !! !!##INPUT ARGUMENTS !! !! N The desired integer number of random numbers to be generated. !! !! NU The integer degrees of freedom (parameter) for the chi-squared !! distribution. NU should be a positive integer variable. !! !! ISEED An integer seed value. Should be set to a non-negative value !! to start a new sequence of values. Will be set to -1 on return !! to indicate the next call should continue the current random !! sequence walk. !! !!##OUTPUT ARGUMENTS !! !! --X A vector (of dimension at least N) into which the generated !! random sample of size N from the chi-squared distribution will !! be placed. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_chsran !! use m_datapac, only : chsran, plott, label, plotxt, sort !! implicit none !! integer,parameter :: n=4000 !! integer :: iseed !! integer :: Nu !! real :: x(n) !! call label('chsran') !! Nu=8 !! iseed=12345 !! call chsran(N,Nu,Iseed,X) !! call plotxt(x,n) !! call sort(x,n,x) ! sort to show distribution !! call plotxt(x,n) !! end program demo_chsran !! !! Results: !! !! THE FOLLOWING IS A PLOT OF X(I) (VERTICALLY) VERSUS I (HORIZONTALLY !! I-----------I-----------I-----------I-----------I !! 0.3098298E+02 - X !! 0.2972390E+02 I !! 0.2846483E+02 I !! 0.2720575E+02 I X !! 0.2594668E+02 I X X !! 0.2468760E+02 I !! 0.2342853E+02 - X X X !! 0.2216945E+02 I X X X X X X !! 0.2091037E+02 I X X X X X XX X X XX X !! 0.1965130E+02 I XXX XX X XX X XXX X XX X XX X !! 0.1839222E+02 I XXX X X XXXXXXX XXX XXX XXXX XX X X X XXX !! 0.1713315E+02 I XX X XXX XX XXXX XXXXX XXXX XXX XXXXX XXX XX !! 0.1587407E+02 - XXXXXX XXXXXX XX XXXX XX XXX X XX XXXX XX XXXX !! 0.1461500E+02 I XXXXXXXXX XX XXXXXXXXX XX XXX XXXXXX X XXXXXXXX !! 0.1335592E+02 I X XXXXX XXXXXXX XXX XXX XX XXXXXXX XXXXXXXX XXXX !! 0.1209685E+02 I XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX !! 0.1083777E+02 I XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX !! 0.9578695E+01 I XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX !! 0.8319620E+01 - XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX !! 0.7060543E+01 I XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX !! 0.5801468E+01 I XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX !! 0.4542393E+01 I XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX !! 0.3283318E+01 I XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX !! 0.2024242E+01 I XXX XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX !! 0.7651675E+00 - X X X X XX X XXX X XX X !! I-----------I-----------I-----------I-----------I !! 0.1000E+01 0.1001E+04 0.2000E+04 0.3000E+04 0.4000E+04 !! !! THE FOLLOWING IS A PLOT OF X(I) (VERTICALLY) VERSUS I (HORIZONTALLY !! I-----------I-----------I-----------I-----------I !! 0.3098298E+02 - X !! 0.2972390E+02 I !! 0.2846483E+02 I !! 0.2720575E+02 I X !! 0.2594668E+02 I X !! 0.2468760E+02 I !! 0.2342853E+02 - X !! 0.2216945E+02 I X !! 0.2091037E+02 I X !! 0.1965130E+02 I XX !! 0.1839222E+02 I X !! 0.1713315E+02 I XX !! 0.1587407E+02 - XX !! 0.1461500E+02 I XX !! 0.1335592E+02 I XXX !! 0.1209685E+02 I XXXX !! 0.1083777E+02 I XXXX !! 0.9578695E+01 I XXXXXX !! 0.8319620E+01 - XXXXXX !! 0.7060543E+01 I XXXXXXXX !! 0.5801468E+01 I XXXXXXX !! 0.4542393E+01 I XXXXXXX !! 0.3283318E+01 I XXXXXX !! 0.2024242E+01 I XXX !! 0.7651675E+00 - X !! I-----------I-----------I-----------I-----------I !! 0.1000E+01 0.1001E+04 0.2000E+04 0.3000E+04 0.4000E+04 !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !! !!##REFERENCES !! * Tocher, The Art of Simulation, 1963, pages 34-35. !! * Mood and Grable, Introduction to the Theory of Statistics, 1963, !! pages 226-227. !! * Johnson and Kotz, Continuous Univariate Distributions--1, 1970, !! page 171. !! * Hastings and Peacock, Statistical Distributions--A Handbook for Students !! and Practitioners, 1975, page 48. ! VERSION NUMBER--82/7 ! ORIGINAL VERSION--FEBRUARY 1975. ! UPDATED --SEPTEMBER 1975. ! UPDATED --NOVEMBER 1975. ! UPDATED --DECEMBER 1981. ! UPDATED --MAY 1982. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE CHSRAN(N,Nu,Iseed,X) INTEGER,intent(in) :: N INTEGER,intent(in) :: Nu INTEGER,intent(inout) :: Iseed REAL(kind=wp),intent(out) :: X(:) REAL(kind=wp) :: arg1 , arg2 , sum , y , z INTEGER i , j ! DIMENSION y(2) , z(2) ! !--------------------------------------------------------------------- ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( N<1 ) THEN WRITE (G_IO,99001) 99001 FORMAT (' ***** FATAL ERROR--The first input argument to CHSRAN(3f) is non-positive *****') WRITE (G_IO,99003) N RETURN ELSEIF ( Nu<=0 ) THEN WRITE (G_IO,99002) 99002 FORMAT (' ***** FATAL ERROR--The second input argument to CHSRAN(3f) is non-positive *****') WRITE (G_IO,99003) Nu RETURN ELSE ! ! GENERATE N CHI-SQUARED RANDOM NUMBERS USING THE DEFINITION THAT ! A CHI-SQUARED VARIATE WITH NU DEGREES OF FREEDOM EQUALS THE SUM OF NU SQUARED NORMAL VARIATES. ! FIRST GENERATE 2 UNIFORM (0,1) RANDOM NUMBERS, THEN GENERATE 2 NORMAL RANDOM NUMBERS, ! THEN FORM THE SUM OF SQUARED NORMAL RANDOM NUMBERS. ! DO i = 1 , N sum = 0.0_wp DO j = 1 , Nu , 2 CALL UNIRAN(2,Iseed,y) arg1 = -2.0_wp*LOG(y(1)) arg2 = 2.0_wp*G_pi*y(2) z(1) = (SQRT(arg1))*(COS(arg2)) z(2) = (SQRT(arg1))*(SIN(arg2)) sum = sum + z(1)*z(1) IF ( j/=Nu ) sum = sum + z(2)*z(2) ENDDO X(i) = sum ENDDO ENDIF 99003 FORMAT (' ','***** The value of the argument is ',I0,' *****') ! END SUBROUTINE CHSRAN !> !!##NAME !! code(3f) - [M_datapac:VECTOR_OPERATIONS] code the elements of a vector !! (1 for the minimum, 2 for the next larger value, and so on) !! !!##SYNOPSIS !! !! SUBROUTINE CODE(X,N,Y) !! !! REAL(kind=wp),intent(in) :: X(:) !! INTEGER,intent(in) :: N !! REAL(kind=wp),intent(out) :: Y(:) !! !!##DESCRIPTION !! !! CODE(3f) codes the elements of the input vector X and puts the coded !! values into the output vector Y. This essentially ranks the array !! elements so they can be accessed in ascending order like RANK(3f), !! but allowing duplicate ranks. !! !! The coding is as follows-- !! !! * the minimum is coded as 1.0. !! * the next larger value as 2.0, !! * the next larger value as 3.0, !! * etc. !! !!##INPUT ARGUMENTS !! !! X The vector of observations to be coded. The input vector X !! remains unaltered. !! !! N The integer number of observations in the vector X. The maximum !! allowable value of N for this subroutine is 15000. !! !!##OUTPUT ARGUMENTS !! !! Y The vector Y which will contain the coded values corresponding !! to the observations in the vector X. It must be at least as large !! as X. !! !! o All occurrances of the minimum are coded as 1.0; !! o All occurances of the next larger value are coded as 2.0; !! o All occurances of the next larger value are coded as 3.0, etc. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_code !! use M_datapac, only : code !! implicit none !! integer,parameter :: isz=20 !! real :: vals(isz) !! real :: rndx(isz) !! integer :: i !! write(*,*)' initializing array with ',isz,' random numbers' !! call random_seed() !! CALL RANDOM_NUMBER(vals) !! vals=vals*450000.0 !! ! make sure some duplicates !! vals(3)=vals(6) !! vals(4)=vals(15) !! !! call code(vals,isz,rndx) ! code data !! ! check order !! write(*,*) !! write(*,'(2(5x,g0.10,1x))')'Values','Code',(vals(i),nint(rndx(i)),i=1,isz) !! !! end program demo_code !! !! Results: !! !! > initializing array with 20 random numbers !! > !! > Output from the code subroutine !! > Number of distinct code values = 18 !! > !! > Value Coded Value !! > 3137.9548340 1. !! > 39334.0585938 2. !! > 58048.1054688 3. !! > 60169.2890625 4. !! > 61479.1015625 5. !! > 92335.1250000 6. !! > 101141.3671875 7. !! > 107306.5859375 8. !! > 135199.7343750 9. !! > 185223.0625000 10. !! > 214747.2656250 11. !! > 251820.6718750 12. !! > 267047.5000000 13. !! > 277210.9062500 14. !! > 296296.5625000 15. !! > 382931.3437500 16. !! > 414374.2187500 17. !! > 427620.9375000 18. !! > !! > Values Code !! > 277210.9062 14 !! > 60169.28906 4 !! > 101141.3672 7 !! > 382931.3438 16 !! > 61479.10156 5 !! > 101141.3672 7 !! > 296296.5625 15 !! > 214747.2656 11 !! > 3137.954834 1 !! > 267047.5000 13 !! > 107306.5859 8 !! > 427620.9375 18 !! > 414374.2188 17 !! > 251820.6719 12 !! > 382931.3438 16 !! > 58048.10547 3 !! > 39334.05859 2 !! > 135199.7344 9 !! > 185223.0625 10 !! > 92335.12500 6 !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 ! ORIGINAL VERSION--OCTOBER 1975. ! UPDATED --NOVEMBER 1975. ! UPDATED --JUNE 1977. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE CODE(X,N,Y) REAL(kind=wp),intent(in) :: X(:) INTEGER,intent(in) :: N REAL(kind=wp),intent(out) :: Y(:) REAL(kind=wp) :: ai , DISt , hold , WS INTEGER i , iupper , j , numdis !--------------------------------------------------------------------- DIMENSION DISt(15000) COMMON /BLOCK2_real32/ WS(15000) EQUIVALENCE (DISt(1),WS(1)) ! iupper = 15000 ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( N<1 .OR. N>iupper ) THEN WRITE (G_IO,99001) iupper 99001 FORMAT (' ***** FATAL ERROR--The second input argument to CODE(3f) is outside the allowable (1,',& & I0,') interval *****') WRITE (G_IO,99002) N 99002 FORMAT (' ***** The value of the argument is ',I0,' *****') RETURN ELSE IF ( N==1 ) THEN WRITE (G_IO,99003) 99003 FORMAT (' ***** NON-FATAL DIAGNOSTIC--The second input argument to CODE(3f) has the value 1 *****') Y(1) = 1.0_wp RETURN ELSE hold = X(1) DO i = 2 , N IF ( X(i)/=hold ) GOTO 50 ENDDO WRITE (G_IO,99004) hold 99004 FORMAT (' ***** NON-FATAL DIAGNOSTIC--The first input argument (a vector) to CODE(3f) has all elements = ', & & E15.8,' *****') DO i = 1 , N Y(i) = i ENDDO RETURN ENDIF ! !-----START POINT----------------------------------------------------- ! ! PERFORM THE CODING-- ! PULL OUT THE DISTINCT VALUES, ! THEN SORT (AND ESSENTIALLY RANK) THE DISTINCT VALUES, ! THEN APPLY THE RANKS TO ALL THE VALUES. ! 50 continue numdis = 1 DISt(numdis) = X(1) DO i = 2 , N DO j = 1 , numdis IF ( X(i)==DISt(j) ) cycle ENDDO numdis = numdis + 1 DISt(numdis) = X(i) ENDDO CALL SORT(DISt,numdis,DISt) DO i = 1 , N DO j = 1 , numdis IF ( X(i)==DISt(j) ) GOTO 120 ENDDO WRITE (G_IO,99005) 99005 FORMAT (' ','*****Internal error in code subroutine') WRITE (G_IO,99006) i , X(i) 99006 FORMAT (' ','No code found for element number ',I0,' = ',F15.7) RETURN 120 Y(i) = j ENDDO ! ! WRITE OUT A FEW LINES OF SUMMARY INFORMATION ABOUT THE CODING. ! WRITE (G_IO,99011) WRITE (G_IO,99007) 99007 FORMAT (' Output from the CODE subroutine') WRITE (G_IO,99008) numdis 99008 FORMAT (' Number of distinct code values = ',I0) WRITE (G_IO,99011) WRITE (G_IO,99009) 99009 FORMAT (' ',8X,'Value Coded value') DO i = 1 , numdis ai = i WRITE (G_IO,99010) DISt(i) , ai 99010 FORMAT (' ',F15.7,6X,F6.0) ENDDO ENDIF 99011 FORMAT (' ') ! END SUBROUTINE CODE !> !!##NAME !! copy(3f) - [M_datapac:VECTOR_OPERATION] copy the elements of one !! vector into another vector !! !!##SYNOPSIS !! !! SUBROUTINE COPY(X,N,Y) !! !! REAL(kind=wp),intent(in) :: X(:) !! INTEGER,intent(in) :: N !! REAL(kind=wp),intent(inout) :: Y(:) !! !!##DESCRIPTION !! COPY(3f) copies the contents of the REAL vector X into the REAL !! vector Y. !! !! The first element of X is copied into the first element of Y; the !! second element of X is copied into the second element of Y, etc. !! !! This pre-f90 procedure can be replaced with modern array syntax !! and should not be required in new code. !! !!##INPUT ARGUMENTS !! !! X The vector of observations to be copied. the input vector X !! remains unaltered. !! !! N The integer number of observations in the vector X. !! !!##OUTPUT ARGUMENTS !! !! Y The vector into which the copied data values from X will be !! sequentially placed such that Y will have its first N !! elements identical to the vector X. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_copy !! use M_datapac, only : copy !! implicit none !! character(len=*),parameter :: g='(*(g0.3,1x))' !! real,allocatable :: from(:), to(:) !! from=[1.0,2.0,3.0,4.0,5.0] !! to=[-1.0,-1.0,-1.0,-1.0,-1.0,-1.0] !! call copy(from,3,to) !! write(*,g)to !! end program demo_copy !! !! Results: !! !! 1.00 2.00 3.00 -1.00 -1.00 -1.00 !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !!##MAINTAINER !! John Urban, 2022.05.31 !!##LICENSE !! CC0-1.0 ! ORIGINAL VERSION--NOVEMBER 1972. ! UPDATED --NOVEMBER 1975. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 subroutine copy(x,n,y) real(kind=wp),intent(in) :: X(:) integer,intent(in) :: N real(kind=wp),intent(inout) :: Y(:) ! integer :: i real(kind=wp) :: hold !--------------------------------------------------------------------- ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! if ( N<1 ) then write (G_IO,99001) 99001 format (' ***** FATAL ERROR--The second input argument to COPY(3f) is non-positive *****') write (G_IO,99002) N 99002 format (' ','***** The value of the argument is ',I0,' *****') elseif (N.gt.size(Y)) then write (G_IO,99003) 99003 format (' ***** FATAL ERROR--The target vector is too small in COPY(3f) *****') write (G_IO,99004) size(y),n 99004 format (' ','***** The size of the target vector is ',I0,' and the requested number of elements is ',i0,' *****') else USEABLE: if ( N==1 ) then write (G_IO,99005) 99005 format (' ***** NON-FATAL DIAGNOSTIC--The second input argument to COPY(3f) has the value 1 *****') else useable hold = X(1) do i = 2 , N if ( X(i)/=hold ) exit USEABLE enddo write (G_IO,99006) hold 99006 format (' ***** NON-FATAL DIAGNOSTIC--The first input argument (a vector) to COPY(3f) has all elements =',& & E15.8,' *****') endif USEABLE do i = 1 , N Y(i) = X(i) enddo endif end subroutine copy !> !!##NAME !! corr(3f) - [M_datapac:STATISTICS] compute the sample correlation !! coefficient !! !!##SYNOPSIS !! !! SUBROUTINE CORR(X,Y,N,Iwrite,C) !! !!##DESCRIPTION !! CORR(3f) computes the sample correlation coefficient between the 2 !! sets of data in the input vectors X and Y. The sample correlation !! coefficient will be a REAL value between -1.0 and 1.0 (inclusively). !! !!##OPTIONS !! X description of parameter !! Y description of parameter !! !!##EXAMPLES !! !! Sample program: !! !! program demo_corr !! use M_datapac, only : corr !! implicit none !! ! call corr(x,y) !! end program demo_corr !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !! !!##REFERENCES !! * Kendall and Stuart, The Advanced Theory of Statistics, Volume 1, !! Edition 2, 1963, pages 235-236. !! * Kendall and Stuart, The Advanced Theory of Statistics, Volume 2, !! Edition 1, 1961, pages 292-293. !! * Snedecor and Cochran, Statistical Methods, Edition 6, 1967, pages !! 172-198. ! ORIGINAL VERSION--JUNE 1972. ! UPDATED --SEPTEMBER 1975. ! UPDATED --NOVEMBER 1975. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE CORR(X,Y,N,Iwrite,C) REAL(kind=wp) :: an , C , hold , sum1 , sum2 , sum3 , X , xbar , Y , ybar INTEGER i , iflag , Iwrite , N ! ! INPUT ARGUMENTS--X = THE VECTOR OF ! (UNSORTED) OBSERVATIONS ! WHICH CONSTITUTE THE FIRST SET ! OF DATA. ! --Y = THE VECTOR OF ! (UNSORTED) OBSERVATIONS ! WHICH CONSTITUTE THE SECOND SET ! OF DATA. ! --N = THE INTEGER NUMBER OF OBSERVATIONS ! IN THE VECTOR X, OR EQUIVALENTLY, ! THE INTEGER NUMBER OF OBSERVATIONS ! IN THE VECTOR Y. ! --IWRITE = AN INTEGER FLAG CODE WHICH ! (IF SET TO 0) WILL SUPPRESS ! THE PRINTING OF THE ! SAMPLE CORRELATION COEFFICIENT ! AS IT IS COMPUTED; ! OR (IF SET TO SOME INTEGER ! VALUE NOT EQUAL TO 0), ! LIKE, SAY, 1) WILL CAUSE ! THE PRINTING OF THE ! SAMPLE CORRELATION COEFFICIENT ! AT THE TIME IT IS COMPUTED. ! OUTPUT ARGUMENTS--C = THE VALUE OF THE ! COMPUTED SAMPLE CORRELATION COEFFICIENT ! BETWEEN THE 2 SETS OF DATA ! IN THE INPUT VECTORS X AND Y. ! THIS VALUE ! WILL BE BETWEEN -1.0 AND 1.0 ! (INCLUSIVELY). ! OUTPUT--THE COMPUTED VALUE OF THE ! SAMPLE CORRELATION COEFFICIENT BETWEEN THE 2 SETS ! OF DATA IN THE INPUT VECTORS X AND Y. ! RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE ! OF N FOR THIS SUBROUTINE. !--------------------------------------------------------------------- DIMENSION X(:) , Y(:) ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! an = N C = 0.0_wp iflag = 0 IF ( N<1 ) THEN WRITE (G_IO,99001) 99001 FORMAT (' ***** FATAL ERROR--The third input argument to CORR(3f) is non-positive *****') WRITE (G_IO,99002) N 99002 FORMAT (' ','***** The value of the argument is ',I0,' *****') RETURN ELSEIF ( N==1 ) THEN WRITE (G_IO,99003) 99003 FORMAT (' ***** NON-FATAL DIAGNOSTIC--The third input argument to CORR(3f) has the value 1 *****') RETURN ELSE hold = X(1) DO i = 2 , N IF ( X(i)/=hold ) GOTO 50 ENDDO WRITE (G_IO,99004) hold 99004 FORMAT (' ***** NON-FATAL DIAGNOSTIC--The first input argument (a vector) to CORR(3f) has all elements =',& & E15.8,' *****') iflag = 1 50 hold = Y(1) DO i = 2 , N IF ( Y(i)/=hold ) GOTO 100 ENDDO WRITE (G_IO,99005) hold 99005 FORMAT (' ***** NON-FATAL DIAGNOSTIC--The second input argument (a vector) to CORR(3f) has all elements =', & & E15.8,' *****') iflag = 1 100 IF ( iflag==1 ) RETURN ! !-----START POINT----------------------------------------------------- ! xbar = 0.0_wp ybar = 0.0_wp DO i = 1 , N xbar = xbar + X(i) ybar = ybar + Y(i) ENDDO xbar = xbar/an ybar = ybar/an sum1 = 0.0_wp sum2 = 0.0_wp sum3 = 0.0_wp DO i = 1 , N sum1 = sum1 + (X(i)-xbar)*(Y(i)-ybar) sum2 = sum2 + (X(i)-xbar)**2 sum3 = sum3 + (Y(i)-ybar)**2 ENDDO sum2 = SQRT(sum2) sum3 = SQRT(sum3) C = sum1/(sum2*sum3) IF ( Iwrite/=0 ) WRITE (G_IO,99006) N , C 99006 FORMAT (' The linear correlation coefficient of the 2 sets of ',I0,' observations is ',F14.5) ENDIF END SUBROUTINE CORR !> !!##NAME !! count(3f) - [M_datapac:STATISTICS] compute the number of observations !! between a minimum and a maximum value !! !!##SYNOPSIS !! !! SUBROUTINE COUNT(X,N,Xmin,Xmax,Iwrite,Xcount) !! !!##DESCRIPTION !! COUNT(3f) computes the number of observations between xmin and xmax !! (inclusively) in the input vector x. !! !!##OPTIONS !! X description of parameter !! Y description of parameter !! !!##EXAMPLES !! !! Sample program: !! !! program demo_count !! use M_datapac, only : count !! implicit none !! ! call count(x,y) !! end program demo_count !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !! !!##REFERENCES !! * snedecor and cochran, statistical methods, edition 6, 1967, pages !! 207-213. !! * dixon and massey, introduction to statistical analysis, edition 2, !! 1957, pages 81-82, 228-231. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE COUNT(X,N,Xmin,Xmax,Iwrite,Xcount) REAL(kind=wp) :: an , hold , X , Xcount , Xmax , Xmin INTEGER i , isum , Iwrite , N ! ! INPUT ARGUMENTS--X = THE VECTOR OF ! (UNSORTED OR SORTED) OBSERVATIONS. ! --N = THE INTEGER NUMBER OF OBSERVATIONS ! IN THE VECTOR X. ! --XMIN = THE VALUE ! WHICH DEFINES THE LOWER LIMIT ! (INCLUSIVELY) OF THE REGION ! OF INTEREST. ! --XMAX = THE VALUE ! WHICH DEFINES THE UPPER LIMIT ! (INCLUSIVELY) OF THE REGION ! OF INTEREST. ! --IWRITE = AN INTEGER FLAG CODE WHICH ! (IF SET TO 0) WILL SUPPRESS ! THE PRINTING OF THE ! SAMPLE COUNT ! AS IT IS COMPUTED; ! OR (IF SET TO SOME INTEGER ! VALUE NOT EQUAL TO 0), ! LIKE, SAY, 1) WILL CAUSE ! THE PRINTING OF THE ! SAMPLE COUNT ! AT THE TIME IT IS COMPUTED. ! OUTPUT ARGUMENTS--XCOUNT = THE VALUE OF THE ! COMPUTED SAMPLE COUNT. ! OUTPUT--THE COMPUTED VALUE OF THE ! SAMPLE COUNT. ! PRINTING--NONE, UNLESS IWRITE HAS BEEN SET TO A NON-ZERO ! INTEGER, OR UNLESS AN INPUT ARGUMENT ERROR ! CONDITION EXISTS. ! RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE ! OF N FOR THIS SUBROUTINE. ! MODE OF INTERNAL OPERATIONS--. ! ORIGINAL VERSION--FEBRUARY 1976. ! !--------------------------------------------------------------------- ! DIMENSION X(:) ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( N<1 ) THEN WRITE (G_IO,99001) 99001 FORMAT (' ', & &'***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE COUNT SUBROU& &TINE IS NON-POSITIVE *****') WRITE (G_IO,99002) N 99002 FORMAT (' ','***** THE VALUE OF THE ARGUMENT IS ',I0,' *****') RETURN ELSEIF ( N==1 ) THEN WRITE (G_IO,99003) 99003 FORMAT (' ', & &'***** NON-FATAL DIAGNOSTIC--THE SECOND INPUT ARGUMENT TO THE COUN& &T SUBROUTINE HAS THE VALUE 1 *****') Xcount = 0.0_wp RETURN ELSE IF ( Xmin==Xmax ) THEN WRITE (G_IO,99004) 99004 FORMAT (' ','***** FATAL ERROR--THE THIRD AND FOURTH INPUT '& & ,'ARGUMENTS TO THE COUNT SUBROUTINE ARE IDENTICAL') WRITE (G_IO,99005) Xmin 99005 FORMAT (' ','***** THE VALUE OF THE ARGUMENTS ARE ',E15.7, & & ' *****') Xcount = 0.0_wp RETURN ELSE hold = X(1) DO i = 2 , N IF ( X(i)/=hold ) GOTO 50 ENDDO WRITE (G_IO,99006) hold 99006 FORMAT (' ', & &'***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT (A VECTOR) & &TO THE COUNT SUBROUTINE HAS ALL ELEMENTS =',E15.8,' *****') Xcount = 0.0_wp RETURN ENDIF ! !-----START POINT----------------------------------------------------- ! 50 an = N Xcount = 0.0_wp isum = 0 DO i = 1 , N IF ( X(i)>=Xmin .AND. Xmax>=X(i) ) isum = isum + 1 ENDDO Xcount = isum ! IF ( Iwrite==0 ) RETURN WRITE (G_IO,99007) 99007 FORMAT (' ') WRITE (G_IO,99008) N , Xmin , Xmax , Xcount 99008 FORMAT (' ','THE NUMBER (OUT OF THE ',I0, & & ' OBSERVATIONS) IN THE INTERVAL ',E15.7,' TO ',E15.7, & & ' IS ',E15.7) ENDIF END SUBROUTINE COUNT !> !!##NAME !! decomp(3f) - [M_datapac:STATISTICS] decomposes a weighted data matrix !! (utility routine used by other routines) !! !!##SYNOPSIS !! !! SUBROUTINE DECOMP(N,K,Eta,Tol,Irank,Insing) !! !! INTEGER :: N !! INTEGER :: K !! REAL(kind=wp) :: Eta !! REAL(kind=wp) :: Tol !! INTEGER :: Irank !! INTEGER :: Insing !! !!##DESCRIPTION !! DECOMP(3f) decomposes the weighted data matrix q which originally = !! the N by K data matrix x times the square root of the weights (in w). !! !! The original q is decomposed into a new q times the inverse of a !! diagonal matrix d times the diagonal matrix d times an upper triangular !! matrix r. !! !! The new N by K q has orthogonal columns. !! !! A second output from DECOMP(3f) is the rank and status (non-singular !! or singular) of the data matrix X. !! !! A third output from DECOMP(3f) is the numerically optimal pivot points !! for the decomposition. !! !!##OPTIONS !! X description of parameter !! Y description of parameter !! !!##EXAMPLES !! !! Sample program: !! !! program demo_decomp !! use M_datapac, only : decomp !! implicit none !! ! call decomp(x,y) !! end program demo_decomp !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the Statistical !! Engineering Division, National Institute of Standards and Technology. !!##MAINTAINER !! John Urban, 2022.05.31 !!##LICENSE !! CC0-1.0 ! UPDATED --NOVEMBER 1975. ! UPDATED --FEBRUARY 1976. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE DECOMP(N,K,Eta,Tol,Irank,Insing) INTEGER :: N INTEGER :: K REAL(kind=wp) :: Eta REAL(kind=wp) :: Tol INTEGER :: Irank INTEGER :: Insing REAL(kind=wp) :: D, dis, dn, DUM1, DUM2, hold, Q, R, risj, tol2, WS INTEGER i, ip, IPIvot, iqarg, iqarg1, iqarg2, irarg, irarg1, irarg2, is, ism1, isp1, j, l, m LOGICAL fsum DIMENSION Q(10000) , R(2500) , D(50) , IPIvot(50) COMMON /BLOCK2_real32/ WS(15000) COMMON /BLOCK3_real32/ DUM1(3000) , DUM2(3000) EQUIVALENCE (Q(1),WS(1)) ! Q--USED AND CHANGED EQUIVALENCE (R(1),WS(10001)) ! R--DEFINED EQUIVALENCE (D(1),WS(12501)) ! D--PERMANENTLY DEFINED EQUIVALENCE (IPIvot(1),WS(12551)) ! IPIVOT--PERMANENTLY DEFINED ! !-----START POINT----------------------------------------------------- ! ! ZERO-OUT SOME VARIABLES, VECTORS, AND ARRAYS ! Insing = 0 Irank = 0 DO j = 1 , K D(j) = 0.0_wp DO i = 1 , K irarg = (i-1)*K + j R(irarg) = 0.0_wp ENDDO ENDDO ! tol2 = Tol*Tol DO j = 1 , K IPIvot(j) = j ENDDO DO is = 1 , K ! ! BEGIN STEP NUMBER IS IN THE DECOMPOSITION ! IF ( is==1 ) fsum = .TRUE. 50 dis = 0.0_wp ip = is ! ! BEGIN THE PIVOT SEARCH ! DO j = is , K m = IPIvot(j) IF ( fsum ) THEN DO l = 1 , N iqarg = (l-1)*K + m DUM1(l) = Q(iqarg) DUM2(l) = Q(iqarg) ENDDO ! CALL DOT(DUM1,DUM2,1,N,0.0_wp,D(j)) ENDIF ! IF ( dis<D(j) ) THEN dis = D(j) ip = j ENDIF ENDDO ! ! END THE PIVOT SEARCH ! m = IPIvot(ip) IF ( fsum ) dn = dis IF ( dis<Eta*dn ) THEN fsum = .TRUE. ELSE fsum = .FALSE. ENDIF IF ( fsum ) GOTO 50 IF ( ip/=is ) THEN ! ! BEGIN COLUMN INTERCHANGES ! D(ip) = D(is) IPIvot(ip) = IPIvot(is) IPIvot(is) = m IF ( is/=1 ) THEN ism1 = is - 1 DO i = 1 , ism1 irarg1 = (i-1)*K + ip irarg2 = (i-1)*K + is hold = R(irarg1) R(irarg1) = R(irarg2) R(irarg2) = hold ENDDO ENDIF ENDIF ! ! END COLUMN INTERCHANGES ! DO l = 1 , N iqarg = (l-1)*K + m DUM1(l) = Q(iqarg) DUM2(l) = Q(iqarg) ENDDO ! CALL DOT(DUM1,DUM2,1,N,0.0_wp,D(is)) ! dis = D(is) IF ( dis<=tol2*D(1) ) RETURN IF ( dis/=0.0_wp ) THEN isp1 = is + 1 IF ( isp1<=K ) THEN ! ! BEGIN ORTHOGONALIZATION ! DO j = isp1 , K ip = IPIvot(j) DO l = 1 , N iqarg1 = (l-1)*K + m iqarg2 = (l-1)*K + ip DUM1(l) = Q(iqarg1) DUM2(l) = Q(iqarg2) ENDDO ! irarg = (is-1)*K + j CALL DOT(DUM1,DUM2,1,N,0.0_wp,R(irarg)) R(irarg) = R(irarg)/dis ! risj = R(irarg) DO i = 1 , N iqarg1 = (i-1)*K + ip iqarg2 = (i-1)*K + m Q(iqarg1) = Q(iqarg1) - risj*Q(iqarg2) ENDDO D(j) = D(j) - dis*risj*risj ENDDO ENDIF ! ! END ORTHOGONALIZATION ! Irank = is ELSE Insing = 0 RETURN ENDIF ENDDO ! ! END STEP NUMBER IS INTHE DECOMPOSITION ! Insing = 1 END SUBROUTINE DECOMP !> !!##NAME !! define(3f) - [M_datapac:VECTOR_OPERATION] set all elements of a vector !! equal to a specified constant !! !!##SYNOPSIS !! !! SUBROUTINE DEFINE(X,N,Xnew) !! !! REAL(kind=wp),intent(out) :: X(:) !! INTEGER,intent(in) :: N !! REAL(kind=wp),intent(in) :: Xnew !! !!##DESCRIPTION !! DEFINE(3f) sets all of the elements in the REAL vector X equal to XNEW. !! !! DEFINE(3f) is useful in defining a vector of constants. !! !! For example, if the data analyst wishes to treat the equal weights case !! in doing a polynomial regression, this could be done by defining as, !! say, 1.0 the input weight vector W to the datapac POLY(3f) subroutine; !! such defining could be done by use of the DEFINE(3f) subroutine with !! XNEW = 1.0. !! !! Except fo the verbose output, this procedure is deprecated as this !! can easily be done using Fortran array syntax. !! !! !!##INPUT ARGUMENTS !! !! X The vector of (unsorted or sorted) observations. !! !! N The integer number of observations in the vector X. !! !! XNEW The value to which all of the observations in the vector X !! will be set. !! !!##OUTPUT !! !! X The vector X every element of which will be equal to XNEW. !! Also, 3 lines of summary information will be generated indicating !! !! 1. What the sample size was (N) !! 2. What the defining constant was (XNEW) !! !!##EXAMPLES !! !! Sample program: !! !! program demo_define !! use M_datapac, only : define !! implicit none !! real :: x(4) !! call define(x,size(x),3.33333) !! write(*,'(*(g0.4,1x))')x !! end program demo_define !! !! Results: !! !! Output from the DEFINE(3f) subroutine-- !! The input number of observations is 4 !! The defining constant is 0.33333299E+01 !! 3.333 3.333 3.333 3.333 !! !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !!##MAINTAINER !! John Urban, 2022.05.31 !!##LICENSE !! CC0-1.0 ! ORIGINAL VERSION--NOVEMBER 1975. ! UPDATED VERSION--JULY 1976. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE DEFINE(X,N,Xnew) REAL(kind=wp),intent(out) :: X(:) INTEGER,intent(in) :: N REAL(kind=wp),intent(in) :: Xnew INTEGER :: i !--------------------------------------------------------------------- ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( N<1 ) THEN WRITE (G_IO,99001) 99001 FORMAT (' ***** FATAL ERROR--The second input argument to DEFINE(3f) is non-positive *****') WRITE (G_IO,99002) N 99002 FORMAT (' ***** The value of the argument is ',I0,' *****') RETURN ELSE IF ( N==1 ) THEN WRITE (G_IO,99003) 99003 FORMAT (' ***** NON-FATAL DIAGNOSTIC--The second input argument to DEFINE(3f) has the value 1 *****') ENDIF ! DO i = 1 , N X(i) = Xnew ENDDO ! ! WRITE OUT A BRIEF SUMMARY ! WRITE (G_IO,99004) 99004 FORMAT (' ') WRITE (G_IO,99005) 99005 FORMAT (' ','Output from the DEFINE(3f) subroutine--') WRITE (G_IO,99006) N 99006 FORMAT (' ',7X,'The input number of observations is ',I0) WRITE (G_IO,99007) Xnew 99007 FORMAT (' ',7X,'The defining constant is ',E15.8) ENDIF ! END SUBROUTINE DEFINE !> !!##NAME !! delete(3f) - [M_datapac:VECTOR_OPERATION] delete all elements of a vector !! within some specified interval !! !!##SYNOPSIS !! !! SUBROUTINE DELETE(X,N,Xmin,Xmax,Newn) !! !!##DESCRIPTION !! !! delete(3f) deletes all observations in the REAL vector !! x which are inside the closed (inclusive) interval defined by xmin !! and xmax, while retaining all observations outside of this interval. !! !! thus all observations in x which are larger than or equal to xmin !! and smaller than or equal to xmax are deleted from x. !! !! delete(3f) (and the replac and retain subroutines) gives the data !! analyst the ability to easily 'clean up' a data set which has missing !! and/or outlying observations so that a more appropriate subsequent !! data analysis may be performed. !! !!##OPTIONS !! X description of parameter !! Y description of parameter !! !!##EXAMPLES !! !! Sample program: !! !! program demo_delete !! use M_datapac, only : delete !! implicit none !! ! call delete(x,y) !! end program demo_delete !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the Statistical !! Engineering Division, National Institute of Standards and Technology. !!##MAINTAINER !! John Urban, 2022.05.31 !!##LICENSE !! CC0-1.0 ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE DELETE(X,N,Xmin,Xmax,Newn) REAL(kind=wp) :: hold , pointl , pointu , X , Xmax , Xmin INTEGER :: i , k , N , ndel , Newn , newnp1 , nold ! ! INPUT ARGUMENTS--X = THE VECTOR OF ! (UNSORTED OR SORTED) OBSERVATIONS. ! --N = THE INTEGER NUMBER OF OBSERVATIONS ! IN THE VECTOR X. ! --XMIN = THE VALUE ! WHICH DEFINES THE LOWER LIMIT ! (INCLUSIVELY) OF THE PARTICULAR ! INTERVAL OF INTEREST TO BE DELETED. ! --XMAX = THE VALUE ! WHICH DEFINES THE UPPER LIMIT ! (INCLUSIVELY) OF THE PARTICULAR ! INTERVAL OF INTEREST TO BE DELETED. ! OUTPUT ARGUMENTS--NEWN = THE INTEGER NUMBER OF OBSERVATIONS ! REMAINING IN X AFTER ALL ! OF THE OBSERVATIONS INSIDE ! (INCLUSIVELY) THE INTERVAL ! OF INTEREST HAVE BEEN DELETED. ! OUTPUT--THE VECTOR X ! IN WHICH ALL THOSE VALUES INSIDE ! (INCLUSIVELY) THE INTERVAL OF INTEREST ! HAVE BEEN DELETED, AND ! THE INTEGER VALUE NEWN ! WHICH GIVES THE NUMBER OF ! OBSERVATIONS REMAINING IN X. ! ALSO, 6 LINES OF SUMMARY INFORMATION ! WILL BE GENERATED INDICATING ! 1) WHAT THE INTERVAL OF INTEREST WAS; ! 2) HOW MANY OBSERVATIONS WERE DELETED; ! 3) WHAT THE OLD (ORIGINAL) SAMPLE SIZE WAS (N); ! 4) WHAT THE NEW SAMPLE SIZE IS (NEWN). ! PRINTING--YES. ! RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE ! OF N FOR THIS SUBROUTINE. ! MODE OF INTERNAL OPERATIONS--. ! COMMENT--IN THE END, AFTER THIS SUBROUTINE HAS ! MADE WHATEVER DELETIONS ARE APPROPRIATE, ! THE OUTPUT VECTOR X WILL BE 'PACKED'; ! THAT IS, NO 'HOLES' WILL EXIST IN THE ! VECTOR X--ALL OF THE RETAINED ELEMENTS ! OF X WILL BE PACKED INTO THE FIRST AVAILABLE ! LOCATIONS IN X, WHILE THE REMAINDER ! OF THE N LOCATIONS IN X WILL BE ZERO-FILLED. ! COMMENT--IN THE MAIN (CALLING) ROUTINE, IT IS ! PERMISSABLE (IF THE ANALYST SO DESIRES) ! TO USE THE SAME VARIABLE NAME ! IN THE FIFTH ARGUMENT AS USED IN THE SECOND ! ARGUMENT IN THE CALLING SEQUENCE TO THIS ! DELETE SUBROUTINE--NO CONFLICT WILL RESULT ! IN THE INTERNAL OPERATION OF THE DELETE ! SUBROUTINE. FOR EXAMPLE, IT IS PERMISSIBLE ! TO HAVE CALL DELETE(X,N,-10.0,10.0,N) ! IN WHICH THE VARIABLE NAME N IS USED ! AS BOTH THE SECOND AND FIFTH ARGUMENTS. ! COMMENT--THIS IS ONE OF THE FEW SUBROUTINES IN DATAPAC ! IN WHICH THE INPUT VECTOR X IS ALTERED. ! ORIGINAL VERSION--JULY 1975. ! UPDATED --NOVEMBER 1975. ! !--------------------------------------------------------------------- ! DIMENSION X(:) ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( N<1 ) THEN WRITE (G_IO,99001) 99001 FORMAT (' ', & &'***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE DELETE SUBROU& &TINE IS NON-POSITIVE *****') WRITE (G_IO,99002) N 99002 FORMAT (' ','***** THE VALUE OF THE ARGUMENT IS ',I0,' *****') RETURN ELSE IF ( N==1 ) THEN WRITE (G_IO,99003) 99003 FORMAT (' ', & &'***** NON-FATAL DIAGNOSTIC--THE SECOND INPUT ARGUMENT TO THE DELE& &TE SUBROUTINE HAS THE VALUE 1 *****') ELSE hold = X(1) DO i = 2 , N IF ( X(i)/=hold ) GOTO 50 ENDDO WRITE (G_IO,99004) hold 99004 FORMAT (' ', & &'***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT (A VECTOR) & &TO THE DELETE SUBROUTINE HAS ALL ELEMENTS =',E15.8,' *****') ENDIF ! !-----START POINT----------------------------------------------------- ! 50 pointl = Xmin pointu = Xmax IF ( Xmin>Xmax ) pointl = Xmax IF ( Xmin>Xmax ) pointu = Xmin ! nold = N k = 0 DO i = 1 , nold IF ( pointl>X(i) .OR. X(i)>pointu ) THEN k = k + 1 X(k) = X(i) ENDIF ENDDO Newn = k ndel = nold - Newn ! newnp1 = Newn + 1 IF ( newnp1<=nold ) THEN DO i = newnp1 , nold X(i) = 0.0_wp ENDDO ENDIF ! ! WRITE OUT A BRIEF SUMMARY ! WRITE (G_IO,99005) 99005 FORMAT (' ') WRITE (G_IO,99006) 99006 FORMAT (' ','OUTPUT FROM THE DELETE SUBROUTINE--') WRITE (G_IO,99007) pointl , pointu 99007 FORMAT (' ',7X,'ALL OBSERVATIONS BETWEEN ',E15.8,' AND ',E15.8) WRITE (G_IO,99008) 99008 FORMAT (' ',7X,'(INCLUSIVE) HAVE BEEN DELETED.') WRITE (G_IO,99009) 99009 FORMAT (' ',7X,'ALL OBSERVATIONS OUTSIDE OF THIS INTERVAL') WRITE (G_IO,99010) 99010 FORMAT (' ',7X,'HAVE BEEN RETAINED.') WRITE (G_IO,99011) nold 99011 FORMAT (' ',7X,'THE INPUT NUMBER OF OBSERVATIONS (IN X) IS ', & & I0) WRITE (G_IO,99012) Newn 99012 FORMAT (' ',7X,'THE OUTPUT NUMBER OF OBSERVATIONS (IN X) IS ', & & I0) WRITE (G_IO,99013) ndel 99013 FORMAT (' ',7X,'THE NUMBER OF OBSERVATIONS DELETED IS ', & & I0) ENDIF ! END SUBROUTINE DELETE !> !!##NAME !! demod(3f) - [M_datapac:STATISTICS] perform a complex demodulation !! !!##SYNOPSIS !! !! SUBROUTINE DEMOD(X,N,F) !! !!##DESCRIPTION !! demod(3f) performs a complex demodulation on the data in the input !! vector x at the input demodulation frequency = f. !! !! the complex demodulation consists of the following-- !! !! 1. an amplitude versus time plot; !! 2. a phase versus time plot; !! 3. an updated demodulation frequency estimate !! to assist the analyst in determining a !! more appropriate frequency at which !! to demodulate in case the specified !! input demodulation frequency f !! does not flatten sufficiently the !! phase plot. !! !! the allowable range of the input demodulation frequency f is 0.0 to !! 0.5 (exclusively). !! !! the input demodulation frequency f is measured of in units of !! cycles per 'data point' or, more precisely, in cycles per unit time !! where 'unit time' is defined as the elapsed time between adjacent !! observations. !! !!##OPTIONS !! X description of parameter !! Y description of parameter !! !!##EXAMPLES !! !! Sample program: !! !! program demo_demod !! use M_datapac, only : demod !! implicit none !! ! call demod(x,y) !! end program demo_demod !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the Statistical !! Engineering Division, National Institute of Standards and Technology. !!##MAINTAINER !! John Urban, 2022.05.31 !!##LICENSE !! CC0-1.0 !!##REFERENCES !! * granger and hatanaka, pages 170 to 189, especially pages 173, 177, !! and 182. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE DEMOD(X,N,F) REAL(kind=wp) :: ai, aiflag, aimax2, alen1, alen2, an, del, F, fest, fmin, hold, pi, range, slopeh, sloper, sum, WS, X, Y1, Y2 REAL(kind=wp) :: Z, zmax, zmin, znew INTEGER :: i, iend, iendp1, iflag, ilower, imax1, imax2, imax2m, ip1, istart, iupper, j, lenma1, lenma2, N ! ! INPUT ARGUMENTS--X = THE VECTOR OF ! (UNSORTED) OBSERVATIONS. ! N = THE INTEGER NUMBER OF OBSERVATIONS ! IN THE VECTOR X. ! F = THE ! DEMODULATION FREQUENCY. ! F IS IN UNITS OF CYCLES PER DATA POINT. ! F IS BETWEEN 0.0 AND 0.5 (EXCLUSIVELY). ! OUTPUT--2 pages OF AUTOMATIC PRINTOUT-- ! 1) AN AMPLITUDE PLOT; ! 2) A PHASE PLOT; AND ! 3) AN UPDATED DEMODULATION FREQUENCY ESTIMATE. ! PRINTING--YES. ! RESTRICTIONS--THE MAXIMUM ALLOWABLE VALUE OF N ! FOR THIS SUBROUTINE IS 5000. ! --THE SAMPLE SIZE N MUST BE GREATER ! THAN OR EQUAL TO 3. ! --THE INPUT FREQUENCY F MUST BE ! GREATER THAN OR EQUAL TO 2/(N-2). ! --THE INPUT FREQUENCY F MUST BE ! SMALLER THAN 0.5. ! OTHER DATAPAC SUBROUTINES NEEDED--PLOTX. ! FORTRAN LIBRARY SUBROUTINES NEEDED--SQRT, SIN, COS, ATAN. ! MODE OF INTERNAL OPERATIONS--. ! COMMENT--IN ORDER THAT THE RESULTS OF THE COMPLEX DEMODULATION ! BE VALID AND PROPERLY INTERPRETED, THE INPUT DATA ! IN X SHOULD BE EQUI-SPACED IN TIME ! (OR WHATEVER VARIABLE CORRESPONDS TO TIME). ! --IF THE INPUT OBSERVATIONS IN X ARE CONSIDERED ! TO HAVE BEEN COLLECTED 1 SECOND APART IN TIME, ! THEN THE DEMODULATION FREQUENCY F ! WOULD BE IN UNITS OF HERTZ ! (= CYCLES PER SECOND). ! --A FREQUENCY OF 0.0 CORRESPONDS TO A CYCLE ! IN THE DATA OF INFINITE (= 1/(0.0)) ! LENGTH OR PERIOD. ! A FREQUENCY OF 0.5 CORRESPONDS TO A CYCLE ! IN THE DATA OF LENGTH = 1/(0.5) = 2 DATA POINTS. ! --IN EXAMINING THE AMPLITUDE AND PHASE PLOTS, ! ATTENTION SHOULD BE PAID NOT ONLY TO THE ! STRUCTURE OF THE PHASE PLOT ! (NEAR-ZERO SLOPE VERSUS NON-ZERO SLOPE) ! BUT ALSO TO THE RANGE ! OF VALUES ON THE VERTICAL AXIS. ! A PLOT WITH MUCH STRUCTURE BUT ! WITH A SMALL RANGE ON THE VERTICAL AXIS ! IS USUALLY MORE INDICATIVE OF A ! DEFINITE CYCLIC COMPONENT AT THE ! SPECIFIED INPUT DEMODULATION FREQUENCY, ! THAN IS A PLOT WITH LESS STRUCTURE BUT ! A WIDER RANGE ON THE VERTICAL AXIS. ! --INTERNAL TO THIS SUBROUTINE, 2 MOVING ! AVERAGES ARE APPLIED, EACH OF LENGTH 1/F. ! HENCE THE AMPLITUDE AND PHASE PLOTS ! HAVE N - 2/F VALUES ! (RATHER THAN N VALUES) ALONG THE ! HORIZONTAL (TIME) AXIS. ! IN ORDER THAT THE AMPLITUDE AND PHASE ! PLOTS BE NON-EMPTY, AN INPUT ! REQUIREMENT ON F FOR THIS SUBROUTINE ! IS THAT THE SAMPLE SIZE N ! AND THE DEMODULATION FREQUENCY F ! MUST BE SUCH THAT ! N - 2/F BE GREATER THAN ZERO. ! FURTHER, SINCE A PLOT WITH BUT ! 1 POINT IS MEANINGLESS ! AND OUGHT ALSO BE EXCLUDED, ! THE REQUIREMENT IS EXTENDED ! SO THAT N - 2/F MUST BE GREATER THAN 1. ! ORIGINAL VERSION--NOVEMBER 1972. ! UPDATED --NOVEMBER 1975. ! UPDATED --FEBRUARY 1976. ! !--------------------------------------------------------------------- ! DIMENSION X(:) DIMENSION Y1(5000) , Y2(5000) , Z(5000) COMMON /BLOCK2_real32/ WS(15000) EQUIVALENCE (Y1(1),WS(1)) EQUIVALENCE (Y2(1),WS(5001)) EQUIVALENCE (Z(1),WS(10001)) DATA pi/3.141592653_wp/ ! ilower = 3 iupper = 5000 an = N fmin = 2.0_wp/(an-2.0_wp) ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( N<ilower .OR. N>iupper ) THEN WRITE (G_IO,99001) ilower , iupper 99001 FORMAT (' ', & &'***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE DEMOD SUBROU& &TINE IS OUTSIDE THE ALLOWABLE (',I0,',',I0,') INTERVAL *****') WRITE (G_IO,99002) N 99002 FORMAT (' ','***** THE VALUE OF THE ARGUMENT IS ',I0,' *****') RETURN ELSE IF ( F<=fmin .OR. F>=0.5_wp ) THEN WRITE (G_IO,99003) fmin 99003 FORMAT (' ', & &'***** FATAL ERROR--THE THIRD INPUT ARGUMENT TO THE DEMOD SUBROU& &TINE IS OUTSIDE THE ALLOWABLE (',F10.8,',0.5) ','INTERVAL *****') WRITE (G_IO,99004) F 99004 FORMAT (' ','***** THE VALUE OF THE ARGUMENT IS ',E15.8, & & ' *****') WRITE (G_IO,99005) fmin , N 99005 FORMAT (' ',' THE ABOVE LOWER LIMIT (', & & F10.8, & & ') = 2/(N-2) WHERE N = THE INPUT SAMPLE SIZE = ',I0) RETURN ELSE hold = X(1) DO i = 2 , N IF ( X(i)/=hold ) GOTO 50 ENDDO WRITE (G_IO,99006) hold 99006 FORMAT (' ', & &'***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT (A VECTOR) & &TO THE DEMOD SUBROUTINE HAS ALL ELEMENTS = ',E15.8,' *****') RETURN ENDIF ! !-----START POINT----------------------------------------------------- ! ! FORM THE COSINE AND SINE SERIES ! 50 DO i = 1 , N ai = i Y1(i) = X(i)*COS(6.2831853_wp*F*ai) Y2(i) = X(i)*SIN(6.2831853_wp*F*ai) ENDDO ! ! DEFINE THE LENGTH OF THE 2 MOVING AVERAGES ! lenma1 = 1.0_wp/F lenma2 = 1.0_wp/F alen1 = lenma1 alen2 = lenma2 imax1 = N - lenma1 imax2 = imax1 - lenma2 ! ! FORM THE FIRST MOVING AVERAGE FOR THE COSINE SERIES ! DO i = 1 , imax1 istart = i + 1 iend = i + lenma1 - 1 iendp1 = i + lenma1 sum = 0.0_wp DO j = istart , iend sum = sum + Y1(j) ENDDO sum = sum + Y1(i)/2.0_wp + Y1(iendp1)/2.0_wp Z(i) = sum/alen1 ENDDO ! ! FORM THE SECOND MOVING AVERAGE FOR THE COSINE SERIES ! DO i = 1 , imax2 istart = i + 1 iend = i + lenma2 - 1 iendp1 = i + lenma2 sum = 0.0_wp DO j = istart , iend sum = sum + Z(j) ENDDO sum = sum + Z(i)/2.0_wp + Z(iendp1)/2.0_wp Y1(i) = sum/alen2 ENDDO ! ! FORM THE FIRST MOVING AVERAGE FOR THE SINE SERIES ! DO i = 1 , imax1 istart = i + 1 iend = i + lenma1 - 1 iendp1 = i + lenma1 sum = 0.0_wp DO j = istart , iend sum = sum + Y2(j) ENDDO sum = sum + Y2(i)/2.0_wp + Y2(iendp1)/2.0_wp Z(i) = sum/alen1 ENDDO ! ! FORM THE SECOND MOVING AVERAGE FOR THE SINE SERIES ! DO i = 1 , imax2 istart = i + 1 iend = i + lenma1 - 1 iendp1 = i + lenma1 sum = 0.0_wp DO j = istart , iend sum = sum + Z(j) ENDDO sum = sum + Z(i)/2.0_wp + Z(iendp1)/2.0_wp Y2(i) = sum/alen2 ENDDO ! ! ! FORM THE AMPLITUDES AND PLOT THEM ! DO i = 1 , imax2 Z(i) = 2.0_wp*SQRT(Y1(i)*Y1(i)+Y2(i)*Y2(i)) ENDDO CALL PLOTX(Z,imax2) WRITE (G_IO,99007) F ! 99007 FORMAT (' ',30X, & & 'AMPLITUDE PLOT FOR THE DEMODULATION FREQUENCY = ', & & F8.6,' CYCLES PER UNIT TIME') ! ! COMPUTE THE DIFFERENCE BETWEEN THE MAX AND MIN AMPLITUDES AND WRITE IT OUT ! zmin = Z(1) zmax = Z(1) DO i = 1 , imax2 IF ( Z(i)<zmin ) zmin = Z(i) IF ( Z(i)>zmax ) zmax = Z(i) ENDDO range = zmax - zmin WRITE (G_IO,99008) zmin , zmax , range 99008 FORMAT (' ',9X,'MINIMUM AMPLITUDE = ',E15.8,5X, & & 'MAXIMUM AMPLITUDE = ',E15.8,5X, & & 'RANGE OF AMPLITUDES = ',E15.8) ! ! FORM THE PHASES AND PLOT THEM ! DO i = 1 , imax2 Z(i) = ATAN(Y1(i)/Y2(i)) ENDDO CALL PLOTX(Z,imax2) WRITE (G_IO,99009) F 99009 FORMAT (' ',32X,'PHASE PLOT FOR THE DEMODULATION FREQUENCY = ',& & F8.6,' CYCLES PER UNIT TIME') ! ! COMPUTE A NEW ESTIMATE FOR THE DEMODULATION FREQUENCY AND WRITE IT OUT ! aimax2 = imax2 imax2m = imax2 - 1 iflag = 0 zmin = Z(1) zmax = Z(1) DO i = 1 , imax2m ip1 = i + 1 del = Z(ip1) - Z(i) IF ( del>2.5_wp ) iflag = iflag - 1 IF ( del<-2.5_wp ) iflag = iflag + 1 aiflag = iflag znew = Z(ip1) + aiflag*pi IF ( znew<zmin ) zmin = znew IF ( znew>zmax ) zmax = znew ENDDO range = zmax - zmin sloper = range/aimax2 slopeh = sloper/(2.0_wp*pi) fest = F + slopeh WRITE (G_IO,99010) zmin , zmax , range 99010 FORMAT (' ',3X,'MINIMUM PHASE = ',E15.8,' RADIANS ', & & 'MAXIMUM PHASE = ',E15.8,' RADIANS ', & & 'RANGE OF PHASES = ',E15.8,' RADIANS') WRITE (G_IO,99011) sloper , slopeh , fest 99011 FORMAT (' ','SLOPE = ',E14.8,' RADIANS = ',E14.6, & & ' CYCLES PER UNIT TIME EST. OF NEW DEMOD. FREQ. = ',& & E15.8,' CYC./UNIT TIME') ENDIF ! END SUBROUTINE DEMOD !> !!##NAME !! dexcdf(3f) - [M_datapac:CUMULATIVE_DISTRIBUTION] compute the double !! exponential cumulative distribution function !! !!##SYNOPSIS !! !! SUBROUTINE DEXCDF(X,Cdf) !! !! real(kind=wp),intent(in) :: X !! real(kind=wp),intent(out) :: Cdf !! !!##DESCRIPTION !! DEXCDF(3f) computes the cumulative distribution function value for the !! double exponential (Laplace) distribution with mean = 0 and standard !! deviation = sqrt(2). !! !! This distribution is defined for all X and has the probability !! density function !! !! f(x) = 0.5*exp(-abs(x)) !! !!##INPUT ARGUMENTS !! X The REAL value at which the cumulative distribution !! function is to be evaluated. !! !!##OUTPUT ARGUMENTS !! CDF The REAL cumulative distribution function value. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_dexcdf !! !@(#) line plotter graph of cumulative distribution function !! use M_datapac, only : dexcdf, plott, label !! implicit none !! real,allocatable :: x(:), y(:) !! integer :: i !! call label('dexcdf') !! x=[(real(i),i=-100,100,1)] !! if(allocated(y))deallocate(y) !! allocate(y(size(x))) !! do i=1,size(x) !! call dexcdf(x(i)/10.0,y(i)) !! enddo !! call plott(x,y,size(x)) !! end program demo_dexcdf !! !! Results: !! !! The following is a plot of Y(I) (vertically) versus X(I) (horizontally) !! I-----------I-----------I-----------I-----------I !! 0.1000000E+03 - X !! 0.9166666E+02 I X !! 0.8333334E+02 I X !! 0.7500000E+02 I X !! 0.6666667E+02 I X !! 0.5833334E+02 I X !! 0.5000000E+02 - X !! 0.4166667E+02 I XX !! 0.3333334E+02 I X !! 0.2500000E+02 I XXX !! 0.1666667E+02 I XXXXX !! 0.8333336E+01 I X XXXXXXX !! 0.0000000E+00 - X X X X X X X X X !! -0.8333328E+01 I XXXXXXX X !! -0.1666666E+02 I XXXXX !! -0.2499999E+02 I XXX !! -0.3333333E+02 I X !! -0.4166666E+02 I XX !! -0.5000000E+02 - X !! -0.5833333E+02 I X !! -0.6666666E+02 I X !! -0.7500000E+02 I X !! -0.8333333E+02 I X !! -0.9166666E+02 I X !! -0.1000000E+03 - X !! I-----------I-----------I-----------I-----------I !! 0.2270E-04 0.2500E+00 0.5000E+00 0.7500E+00 0.1000E+01 !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !! !!##REFERENCES !! * Johnson and Kotz, Continuous Univariate Distributions--2, 1970, !! pages 22-36. ! ORIGINAL VERSION--JUNE 1972. ! UPDATED --SEPTEMBER 1975. ! UPDATED --NOVEMBER 1975. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 subroutine dexcdf(X,Cdf) real(kind=wp),intent(in) :: X real(kind=wp),intent(out) :: Cdf ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS -- NO INPUT ARGUMENT ERRORS POSSIBLE FOR THIS DISTRIBUTION. ! if ( X<=0.0_wp ) Cdf = 0.5_wp*exp(X) if ( X>0.0_wp ) Cdf = 1.0_wp - (0.5_wp*exp(-X)) end subroutine dexcdf !> !!##NAME !! dexpdf(3f) - [M_datapac:PROBABILITY_DENSITY] compute the double !! exponential probability density function !! !!##SYNOPSIS !! !! SUBROUTINE DEXPDF(X,Pdf) !! !! REAL(kind=wp),intent(in) :: X !! REAL(kind=wp),intent(out) :: Pdf !! !!##DESCRIPTION !! DEXPDF(3f) computes the probability density function value for the !! double exponential (Laplace) distribution with mean = 0 and standard !! deviation = sqrt(2). !! !! This distribution is defined for all X and has the probability !! density function !! !! f(X) = 0.5*exp(-abs(X)) !! !!##INPUT ARGUMENTS !! X The value at which the probability density function is to !! be evaluated. !! !!##OUTPUT ARGUMENTS !! PDF The probability density function value. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_dexpdf !! !@(#) line plotter graph !! !@(#) of probability density function for Laplace distribution !! use M_datapac, only : dexpdf, plott, label !! implicit none !! real,allocatable :: x(:), y(:) !! integer :: i !! call label('dexpdf') !! x=[(real(i),i=-100,100,1)] !! if(allocated(y))deallocate(y) !! allocate(y(size(x))) !! do i=1,size(x) !! call dexpdf(x(i)/10.0,y(i)) !! enddo !! call plott(x,y,size(x)) !! end program demo_dexpdf !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the Statistical !! Engineering Division, National Institute of Standards and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !! !!##REFERENCES !! * Johnson and Kotz, Continuous Univariate Distributions--2, 1970, !! pages 22-36. ! ORIGINAL VERSION--JUNE 1972. ! UPDATED --SEPTEMBER 1975. ! UPDATED --NOVEMBER 1975. ! UPDATED --SEPTEMBER 1978. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 subroutine dexpdf(X,Pdf) real(kind=wp),intent(in) :: X real(kind=wp),intent(out) :: Pdf real(kind=wp) :: arg ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS. -- NO INPUT ARGUMENT ERRORS POSSIBLE FOR THIS DISTRIBUTION. ! arg = X IF ( X<0.0_wp ) arg = -X Pdf = 0.5_wp*EXP(-arg) end subroutine dexpdf !> !!##NAME !! dexplt(3f) - [M_datapac:LINE_PLOT] generate a double exponential !! probability plot !! !!##SYNOPSIS !! !! SUBROUTINE DEXPLT(X,N) !! !!##DESCRIPTION !! dexplt(3f) generates a double exponential (laplace) probability plot. !! !! the prototype double exponential distribution used herein has mean = !! 0 and standard deviation = sqrt(2). !! !! this distribution is defined for all x and has the probability !! density function !! !! f(x) = 0.5 * exp(-abs(x)). !! !! as used herein, a probability plot for a distribution is a plot !! of the ordered observations versus the order statistic medians for !! that distribution. !! !! the double exponential probability plot is useful in graphically !! testing the composite (that is, location and scale parameters need !! not be specified) hypothesis that the underlying distribution from !! which the data have been randomly drawn is the double exponential !! distribution. !! !! if the hypothesis is true, the probability plot should be near-linear. !! !! a measure of such linearity is given by the calculated probability !! plot correlation coefficient. !! !!##OPTIONS !! X description of parameter !! Y description of parameter !! !!##EXAMPLES !! !! Sample program: !! !! program demo_dexplt !! use M_datapac, only : dexplt !! implicit none !! ! call dexplt(x,y) !! end program demo_dexplt !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !! !!##REFERENCES !! * FILLIBEN, 'TECHNIQUES FOR TAIL LENGTH ANALYSIS', PROCEEDINGS OF THE !! EIGHTEENTH CONFERENCE ON THE DESIGN OF EXPERIMENTS IN ARMY RESEARCH !! DEVELOPMENT AND TESTING (ABERDEEN, MARYLAND, OCTOBER, 1972), pages !! 425-450. !! * HAHN AND SHAPIRO, STATISTICAL METHODS IN ENGINEERING, 1967, pages !! 260-308. !! * JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE DISTRIBUTIONS--2, 1970, !! pages 22-36. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE DEXPLT(X,N) REAL(kind=wp) :: an , cc , hold , q , sum1 , sum2 , sum3 , tau , W , wbar , & & WS , X , Y , ybar , yint , yslope INTEGER :: i , iupper , N ! ! INPUT ARGUMENTS--X = THE VECTOR OF ! (UNSORTED OR SORTED) OBSERVATIONS. ! --N = THE INTEGER NUMBER OF OBSERVATIONS ! IN THE VECTOR X. ! OUTPUT--A ONE-page DOUBLE EXPONENTIAL PROBABILITY PLOT. ! PRINTING--YES. ! RESTRICTIONS--THE MAXIMUM ALLOWABLE VALUE OF N ! FOR THIS SUBROUTINE IS 7500. ! OTHER DATAPAC SUBROUTINES NEEDED--SORT, UNIMED, PLOT. ! FORTRAN LIBRARY SUBROUTINES NEEDED--SQRT, LOG. ! MODE OF INTERNAL OPERATIONS--. ! ORIGINAL VERSION--JUNE 1972. ! UPDATED --SEPTEMBER 1975. ! UPDATED --NOVEMBER 1975. ! UPDATED --FEBRUARY 1976. ! !--------------------------------------------------------------------- ! DIMENSION X(:) DIMENSION Y(7500) , W(7500) COMMON /BLOCK2_real32/ WS(15000) EQUIVALENCE (Y(1),WS(1)) EQUIVALENCE (W(1),WS(7501)) ! DATA tau/1.76862179_wp/ ! iupper = 7500 ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( N<1 .OR. N>iupper ) THEN WRITE (G_IO,99001) iupper 99001 FORMAT (' ', & &'***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE DEXPLT SUBROU& &TINE IS OUTSIDE THE ALLOWABLE (1,',I0,') INTERVAL *****') WRITE (G_IO,99002) N 99002 FORMAT (' ','***** THE VALUE OF THE ARGUMENT IS ',I0,' *****') RETURN ELSEIF ( N==1 ) THEN WRITE (G_IO,99003) 99003 FORMAT (' ', & &'***** NON-FATAL DIAGNOSTIC--THE SECOND INPUT ARGUMENT TO THE DEXP& < SUBROUTINE HAS THE VALUE 1 *****') RETURN ELSE hold = X(1) DO i = 2 , N IF ( X(i)/=hold ) GOTO 50 ENDDO WRITE (G_IO,99004) hold 99004 FORMAT (' ', & &'***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT (A VECTOR) & &TO THE DEXPLT SUBROUTINE HAS ALL ELEMENTS = ',E15.8,' *****') ! !-----START POINT----------------------------------------------------- ! 50 an = N ! ! SORT THE DATA ! CALL SORT(X,N,Y) ! ! GENERATE UNIFORM ORDER STATISTIC MEDIANS ! CALL UNIMED(N,W) ! ! COMPUTE DOUBLE EXPONENTIAL ORDER STATISTIC MEDIANS ! DO i = 1 , N q = W(i) IF ( q<=0.5_wp ) W(i) = LOG(2.0_wp*q) IF ( q>0.5_wp ) W(i) = -LOG(2.0_wp*(1.0_wp-q)) ENDDO ! ! PLOT THE ORDERED OBSERVATIONS VERSUS ORDER STATISTICS MEDIANS. ! WRITE OUT THE TAIL LENGTH MEASURE OF THE DISTRIBUTION ! AND THE SAMPLE SIZE. ! CALL PLOT(Y,W,N) WRITE (G_IO,99005) tau , N ! 99005 FORMAT (' ','DOUBLE EXPONENTIAL PROBABILITY PLOT (TAU = ', & & E15.8,')',44X,'THE SAMPLE SIZE N = ',I0) ! ! COMPUTE THE PROBABILITY PLOT CORRELATION COEFFICIENT. ! COMPUTE LOCATION AND SCALE ESTIMATES ! FROM THE INTERCEPT AND SLOPE OF THE PROBABILITY PLOT. ! THEN WRITE THEM OUT. ! sum1 = 0.0_wp DO i = 1 , N sum1 = sum1 + Y(i) ENDDO ybar = sum1/an wbar = 0.0_wp sum1 = 0.0_wp sum2 = 0.0_wp sum3 = 0.0_wp DO i = 1 , N sum1 = sum1 + (Y(i)-ybar)*(Y(i)-ybar) sum2 = sum2 + W(i)*Y(i) sum3 = sum3 + W(i)*W(i) ENDDO cc = sum2/SQRT(sum3*sum1) yslope = sum2/sum3 yint = ybar - yslope*wbar WRITE (G_IO,99006) cc , yint , yslope 99006 FORMAT (' ','PROBABILITY PLOT CORRELATION COEFFICIENT = ',F8.5,& & 5X,'ESTIMATED INTERCEPT = ',E15.8,3X, & & 'ESTIMATED SLOPE = ',E15.8) ENDIF ! END SUBROUTINE DEXPLT !> !!##NAME !! dexppf(3f) - [M_datapac:PERCENT_POINT] compute the double exponential !! percent point function !! !!##SYNOPSIS !! !! SUBROUTINE DEXPPF(P,Ppf) !! !! REAL(kind=wp),intent(in) :: P !! REAL(kind=wp),intent(out) :: Ppf !! !!##DESCRIPTION !! DEXPPF(3f) computes the percent point function value for the double !! exponential (laplace) distribution with mean = 0 and standard deviation !! = sqrt(2). !! !! This distribution is defined for all x and has the probability !! density function !! !! f(x) = 0.5*exp(-abs(x)). !! !! Note that the percent point function of a distribution is identically !! the same as the inverse cumulative distribution function of the !! distribution. !! !!##INPUT ARGUMENTS !! !! P The value (between 0.0 and 1.0, EXCLUSIVELY) at which the !! percent point function is to be evaluated. !! !!##OUTPUT ARGUMENTS !! !! PPF The percent point function value. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_dexppf !! use M_datapac, only : dexppf !! implicit none !! ! call dexppf(x,y) !! end program demo_dexppf !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !! !!##REFERENCES !! * Filliben, Simple and Robust Linear Estimation of the Location Parameter !! of a Symmetric Distribution (Unpublished PH.D. Dissertation, Princeton !! University), 1969, pages 21-44, 229-231. !! * Filliben, 'The Percent Point Function', (Unpublished Manuscript), !! 1970, pages 28-31. !! * Johnson and Kotz, Continuous Univariate Distributions--2, 1970, !! pages 22-36. ! ORIGINAL VERSION--JUNE 1972. ! UPDATED --SEPTEMBER 1975. ! UPDATED --NOVEMBER 1975. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE DEXPPF(P,Ppf) REAL(kind=wp),intent(in) :: P REAL(kind=wp),intent(out) :: Ppf ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( P<=0.0_wp .OR. P>=1.0_wp ) THEN WRITE (G_IO,99001) 99001 FORMAT (' ***** FATAL ERROR--THE FIRST INPUT ARGUMENT TO DEXPPF(3f) IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL *****') WRITE (G_IO,99002) P 99002 FORMAT (' ','***** THE VALUE OF THE ARGUMENT IS ',E15.8, ' *****') RETURN ELSE IF ( P<=0.5_wp ) Ppf = LOG(2.0_wp*P) IF ( P>0.5_wp ) Ppf = -LOG(2.0_wp*(1.0_wp-P)) ENDIF END SUBROUTINE DEXPPF !> !!##NAME !! dexran(3f) - [M_datapac:RANDOM] generate double exponential !! random numbers !! !!##SYNOPSIS !! !! subroutine dexran(N,Istart,X) !! !! integer,intent(in) :: N !! integer,intent(inout) :: Istart !! real(kind=wp) :: X(:) !! !!##DESCRIPTION !! DEXRAN(3f) generates a random sample of size n from the double !! exponential (Laplace) distribution with mean = 0 and standard deviation !! = sqrt(2). !! !! This distribution is defined for all X and has the probability !! density function !! !! f(X) = 0.5*exp(-abs(X)) !! !!##INPUT ARGUMENTS !! N The desired integer number of random numbers to be generated. !! !! ISTART An integer flag code which (if set to 0) will start the !! generator over and hence produce the same random sample !! over and over again upon successive calls to this subroutine !! within a run; or (if set to some integer value not equal to !! 0, like, say, 1) will allow the generator to continue from !! where it stopped and hence produce different random samples !! upon successive calls to this subroutine within a run. !!##OUTPUT ARGUMENTS !! !! X A REAL vector (of dimension at least N) into which !! the generated random sample will be placed. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_dexran !! use M_datapac, only : dexran !! implicit none !! ! call dexran(x,y) !! end program demo_dexran !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !! !!##REFERENCES !! * Tocher, The Art of Simulation, 1963, pages 14-15. !! * Hammersley and Handscomb, Monte Carlo Methods, 1964, page 36. !! * Filliben, Simple and Robust Linear Estimation of the Location Parameter !! of a Symmetric Distribution (Unpublished PH.D. dissertation, Princeton !! University), 1969, page 231. !! * Filliben, 'The percent point function', (Unpublished manuscript), !! 1970, pages 28-31. !! * Johnson and Kotz, Continuous Univariate Distributions--2, 1970, !! pages 22-36. ! ORIGINAL VERSION--JUNE 1972. ! UPDATED --SEPTEMBER 1975. ! UPDATED --NOVEMBER 1975. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 subroutine dexran(N,Istart,X) integer,intent(in) :: N integer,intent(inout) :: Istart real(kind=wp) :: X(:) integer :: i real(kind=wp) :: q !--------------------------------------------------------------------- ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! if ( N<1 ) then write (G_io,99001) 99001 format (' ***** FATAL ERROR--THE FIRST INPUT ARGUMENT TO DEXRAN(3f) IS NON-POSITIVE *****') write (G_io,99002) N 99002 format (' ','***** THE VALUE OF THE ARGUMENT IS ',I0,' *****') else ! ! GENERATE N UNIFORM (0,1) RANDOM NUMBERS; ! call uniran(N,Istart,X) ! ! GENERATE N DOUBLE EXPONENTIAL RANDOM NUMBERS ! USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD. ! do i = 1 , N q = X(i) if ( q<=0.5_wp ) X(i) = log(2.0_wp*q) if ( q>0.5_wp ) X(i) = -log(2.0_wp*(1.0-q)) enddo endif end subroutine dexran !> !!##NAME !! dexsf(3f) - [M_datapac:SPARSITY] compute the double exponential !! sparsity function !! !!##SYNOPSIS !! !! SUBROUTINE DEXSF(P,Sf) !! !! REAL(kind=wp),intent(in) :: P !! REAL(kind=wp),intent(out) :: Sf !! !!##DESCRIPTION !! DEXSF(3f) computes the sparsity function value for the double !! exponential (Laplace) distribution with mean = 0 and standard deviation !! = sqrt(2). !! !! This distribution is defined for all x and has the probability !! density function !! !! f(x) = 0.5*exp(-abs(x)) !! !! Note that the sparsity function of a distribution is the derivative !! of the percent point function, and also is the reciprocal of the !! probability density function (but in units of P rather than X). !! !!##INPUT ARGUMENTS !! P The value (between 0.0 and 1.0 exclusively) at which the !! sparsity function is to be evaluated. !!##OUTPUT ARGUMENTS !! SF The sparsity function value. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_dexsf !! use M_datapac, only : dexsf !! implicit none !! ! call dexsf(x,y) !! end program demo_dexsf !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !! !!##REFERENCES !! * Filliben, Simple and Robust Linear Estimation of the Location !! Parameter of a Symmetric Distribution (Unpublished PH.D. Dissertation, !! Princeton University), 1969, pages 21-44, 229-231. !! * Filliben, 'The Percent Point Function', (UNpublished Manuscript), !! 1970, pages 28-31. !! * Johnson and Kotz, Continuous Univariate Distributions--2, 1970, !! pages 22-36. ! ORIGINAL VERSION--JUNE 1972. ! UPDATED --SEPTEMBER 1975. ! UPDATED --NOVEMBER 1975. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE DEXSF(P,Sf) REAL(kind=wp),intent(in) :: P REAL(kind=wp),intent(out) :: Sf ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( P<=0.0_wp .OR. P>=1.0_wp ) THEN WRITE (G_IO,99001) 99001 FORMAT (' ***** FATAL ERROR--THE FIRST INPUT ARGUMENT TO DEXSF(3f) IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL *****') WRITE (G_IO,99002) P 99002 FORMAT (' ','***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') RETURN ELSE IF ( P<=0.5_wp ) Sf = 1.0_wp/P IF ( P>0.5_wp ) Sf = 1.0_wp/(1.0_wp-P) ENDIF ! END SUBROUTINE DEXSF !> !!##NAME !! discr2(3f) - [M_datapac:STATISTICS] bin the elements of a vector !! (output vector contains class midpoints) !! !!##SYNOPSIS !! !! SUBROUTINE DISCR2(X,N,Numcla,Y) !! !!##DESCRIPTION !! discr2(3f) 'discretizes' the data of the REAL vector x !! into numcla classes. !! !! all values in the vector x within a given class will be mapped into !! the midpoint of that class. !! !! the sample minimum and sample maximum are automatically computed !! internally and the class width (xdel) is computed as the (sample max - !! sample min)/numcla. !! !! the first class interval is from the sample min to the sample min + !! xdel; the second class interval is from the sample min + xdel to the !! sample min + 2*xdel; !! ...; !! !! the last class interval is from the sample max - xdel to the sample !! max. The use of discr2(3f) (and the discre and discr3 subroutines) !! gives the data analyst the capability of constructing a discrete !! variate from a continuous one. !! !! the resulting discrete variate might then (for example) be analyzed !! in itself for gross structure, or for adherence to some theoretical !! discrete probability model, or the discrete variate might be used as !! a subset definition vector for some other variate. !! !!##OPTIONS !! X description of parameter !! Y description of parameter !! !!##EXAMPLES !! !! Sample program: !! !! program demo_discr2 !! use M_datapac, only : discr2 !! implicit none !! ! call discr2(x,y) !! end program demo_discr2 !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the Statistical !! Engineering Division, National Institute of Standards and Technology. !!##MAINTAINER !! John Urban, 2022.05.31 !!##LICENSE !! CC0-1.0 ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE DISCR2(X,N,Numcla,Y) REAL(kind=wp) :: ai , anuml , classm , cmax , cmin , hold , p , X , xdel , & & xmax , xmin , Y INTEGER i , icount , ip , iupncl , N , Numcla ! ! INPUT ARGUMENTS--X = THE VECTOR OF ! (UNSORTED OR SORTED) OBSERVATIONS. ! TO BE DISCRETIZED. ! --N = THE INTEGER NUMBER OF OBSERVATIONS ! IN THE VECTOR X. ! --NUMLEV = THE INTEGER NUMBER OF CLASSES ! DESIRED IN THE DISCRETIZATION. ! OUTPUT ARGUMENTS--Y = THE VECTOR OF ! DISCRETIZED VALUES (= THE CLASS ! MIDPOINTS) CORRESPONDING TO ! THE CONTINUOUS VALUES IN THE VECTOR X. ! THERE WILL RESULT N SUCH DISCRETIZED ! VALUES. ! OUTPUT--THE VECTOR Y ! WHICH CONTAINS N DISCRETIZED VALUES ! (= THE CLASS MIDPOINTS) ! CORRESPONDING TO THE N ! CONTINUOUS VALUES IN THE ! INPUT VECTOR X. ! ALSO, (NUMCLA+5) LINES OF SUMMARY INFORMATION ! WILL BE GENERATED INDICATING ! 1) WHAT THE SAMPLE SIZE IS (N); ! 2) WHAT THE NUMBER OF CLASSES IS (NUMCLA). ! 3) WHAT THE CLASS BOUNDARIES AND ! THE NUMBER OF OBSERVATIONS ! FALLING IN EACH CLASS ARE. ! PRINTING--YES ! RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE ! OF N FOR THIS SUBROUTINE. ! --NUMCLA SHOULD BE POSITIVE AND NOT EXCEED 1000 ! MODE OF INTERNAL OPERATIONS--. ! COMMENT--THIS SUBROUTINE DIFFERS FROM THE DISCR3 ! SUBROUTINE INASMUCH AS THIS SUBROUTINE ! PERFORMS ITS DISCRETIZATION BY OUTPUTING ! CLASS MIDPOINTS, WHEREAS THE DISCR3 ! SUBROUTINE OUTPUTS CLASS NUMBERS ! (1, 2, ... , NUMCLA). ! COMMENT--THE INPUT VECTOR X REMAINS UNALTERED. ! COMMENT--IN THE MAIN (CALLING) ROUTINE, IT IS ! PERMISSABLE (IF THE ANALYST SO DESIRES) ! TO USE THE SAME VARIABLE NAME ! IN THE FOURTH ARGUMENT AS USED IN THE FIRST ! ARGUMENT IN THE CALLING SEQUENCE TO THIS ! DISCR2 SUBROUTINE--NO CONFLICT WILL RESULT ! IN THE INTERNAL OPERATION OF THE DISCR2 ! SUBROUTINE. FOR EXAMPLE, IT IS PERMISSIBLE ! TO HAVE CALL DISCR2(X,N,10,X) ! IN WHICH THE VARIABLE NAME X IS USED ! AS BOTH THE FIRST AND FOURTH ARGUMENTS. ! ORIGINAL VERSION--NOVEMBER 1974. ! UPDATED --APRIL 1975. ! UPDATED --NOVEMBER 1975. ! !--------------------------------------------------------------------- ! DIMENSION X(:) , Y(:) DIMENSION icount(1000) DIMENSION classm(1000) ! iupncl = 1000 ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( N<1 ) THEN WRITE (G_IO,99001) 99001 FORMAT (' ', & &'***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE DISCR2 SUBROU& &TINE IS NON-POSITIVE *****') WRITE (G_IO,99015) N RETURN ELSEIF ( N==1 ) THEN WRITE (G_IO,99002) 99002 FORMAT (' ', & &'***** NON-FATAL DIAGNOSTIC--THE SECOND INPUT ARGUMENT TO THE DISC& &R2 SUBROUTINE HAS THE VALUE 1 *****') Y(1) = X(1) RETURN ELSEIF ( Numcla<1 .OR. Numcla>iupncl ) THEN WRITE (G_IO,99003) iupncl 99003 FORMAT (' ', & &'***** FATAL ERROR--THE THIRD INPUT ARGUMENT TO THE DISCR2 SUBROU& &TINE IS OUTSIDE THE ALLOWABLE (1,',I0,') INTERVAL *****') WRITE (G_IO,99015) Numcla DO i = 1 , N Y(i) = 0.0_wp ENDDO RETURN ELSE IF ( Numcla==1 ) THEN WRITE (G_IO,99004) 99004 FORMAT (' ', & &'***** NON-FATAL DIAGNOSTIC--THE THIRD INPUT ARGUMENT TO THE DISC& &R2 SUBROUTINE HAS THE VALUE 1 *****') ELSE hold = X(1) DO i = 2 , N IF ( X(i)/=hold ) GOTO 50 ENDDO WRITE (G_IO,99005) hold 99005 FORMAT (' ', & &'***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT (A VECTOR) & &TO THE DISCR2 SUBROUTINE HAS ALL ELEMENTS =',E15.8,' *****') DO i = 1 , N Y(i) = X(i) ENDDO RETURN ENDIF ! !-----START POINT----------------------------------------------------- ! 50 anuml = Numcla ! ! ZERO OUT THE COUNT VECTOR (ICOUNT) ! DO i = 1 , Numcla icount(i) = 0 ENDDO ! ! COMPUTE THE SAMPLE MINIMUM AND MAXIMUM, ! THEN COMPUTE THE CLASS WIDTH. ! xmin = X(1) xmax = X(1) DO i = 1 , N IF ( X(i)<xmin ) xmin = X(i) IF ( X(i)>xmax ) xmax = X(i) ENDDO xdel = (xmax-xmin)/anuml ! ! COMPUTE THE CLASS MIDPOINT FOR EACH CLASS ! DO i = 1 , Numcla ai = i classm(i) = xmin + (ai-0.5_wp)*xdel ENDDO ! ! PERFORM THE DISCRETIZING TRANSFORMATION. ! ALSO, KEEP A FREQUENCY COUNT FOR EACH CLASS. ! DO i = 1 , N p = (X(i)-xmin)/(xmax-xmin) p = p*anuml + 1.0_wp ip = p IF ( ip<1 ) ip = 1 IF ( ip>Numcla ) ip = Numcla Y(i) = classm(ip) icount(ip) = icount(ip) + 1 ENDDO ! ! COMPUTE CLASS LIMITS AND WRITE OUT SUMMARY INFORMATION. ! WRITE (G_IO,99016) WRITE (G_IO,99006) ! 99006 FORMAT (' ','OUTPUT FROM THE DISCR2 SUBROUTINE--') WRITE (G_IO,99016) WRITE (G_IO,99007) N 99007 FORMAT (' ',7X,'NUMBER OF OBSERVATIONS = ',I0) WRITE (G_IO,99008) Numcla 99008 FORMAT (' ',7X,'SPECIFIED NUMBER OF LEVELS = ',I0) WRITE (G_IO,99009) xmin 99009 FORMAT (' ',7X,'COMPUTED LOWER BOUND OF INTERVAL = ',F15.7) WRITE (G_IO,99010) xdel 99010 FORMAT (' ',7X,'COMPUTED CLASS WIDTH = ',F15.7) WRITE (G_IO,99011) xmax 99011 FORMAT (' ',7X,'COMPUTED UPPER BOUND OF INTERVAL = ',F15.7) WRITE (G_IO,99016) WRITE (G_IO,99012) 99012 FORMAT (' ', & & ' CLASS MINIMUM MIDPOINT MAXIMUM',& & ' COUNT') WRITE (G_IO,99013) 99013 FORMAT (' ', & & ' -------------------------------------------', & & '-------------') DO i = 1 , Numcla ai = i cmin = xmin + (ai-1.0_wp)*xdel cmax = xmin + ai*xdel WRITE (G_IO,99014) i , cmin , classm(i) , cmax , icount(i) 99014 FORMAT (' ',4X,I6,2X,3F14.7,I8) ENDDO ENDIF 99015 FORMAT (' ','***** THE VALUE OF THE ARGUMENT IS ',I0,' *****') 99016 FORMAT (' ') ! END SUBROUTINE DISCR2 !> !!##NAME !! discr3(3f) - [M_datapac:STATISTICS] bin the elements of a vector !! (output vector contains 1's, 2's, 3's, and so on) !! !!##SYNOPSIS !! !! SUBROUTINE DISCR3(X,N,Numcla,Y) !! !!##DESCRIPTION !! discr3(3f) 'discretizes' the data on the REAL vector x !! into numcla classes. !! !! all values in the vector x within a given class will be mapped into !! the class number (1, 2, ... , numcla). thus all the elements in the !! lowermost class will be mapped into the value 1.0; all the elements !! of x in the next higher class will be mapped into 2.0; etc. !! !! the sample minimum and sample maximum are automatically computed !! internally and the class width (xdel) is computed as the (sample max !! - sample min)/numcla. the first class interval is from the sample !! min to the sample min + xdel; the second class interval is from the !! sample min + xdel to the sample min + 2*xdel; !! ...; !! !! the last class interval is from the sample max - xdel to the sample !! max. the use of discr3(3f) (and the discre and discr2 subroutines) !! gives the data analyst the capability of constructing a discrete !! variate from a continuous one. !! !! the resulting discrete variate might then (for example) be analyzed !! in itself for gross structure, or for adherence to some theoretical !! discrete probability model, or the discrete variate might be used as !! a subset definition vector for some other variate. !! !! this discr3 subroutine is particularly suited to this last purpose !! inasmuch as it output's 1's, 2's, etc. rather than midpoints. !! !!##OPTIONS !! X description of parameter !! Y description of parameter !! !!##EXAMPLES !! !! Sample program: !! !! program demo_discr3 !! use M_datapac, only : discr3 !! implicit none !! ! call discr3(x,y) !! end program demo_discr3 !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the Statistical !! Engineering Division, National Institute of Standards and Technology. !!##MAINTAINER !! John Urban, 2022.05.31 !!##LICENSE !! CC0-1.0 ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE DISCR3(X,N,Numcla,Y) REAL(kind=wp) :: ai , anuml , cmax , cmin , hold , p , X , xdel , xmax , & & xmin , Y INTEGER i , icount , ip , iupncl , N , Numcla ! ! INPUT ARGUMENTS--X = THE VECTOR OF ! (UNSORTED OR SORTED) OBSERVATIONS. ! TO BE DISCRETIZED. ! --N = THE INTEGER NUMBER OF OBSERVATIONS ! IN THE VECTOR X. ! --NUMLEV = THE INTEGER NUMBER OF CLASSES ! DESIRED IN THE DISCRETIZATION. ! OUTPUT ARGUMENTS--Y = THE VECTOR OF ! DISCRETIZED VALUES CORRESPONDING TO ! THE CONTINUOUS VALUES IN THE VECTOR X. ! THERE WILL RESULT N SUCH DISCRETIZED ! VALUES. ! OUTPUT--THE VECTOR Y ! WHICH CONTAINS N DISCRETIZED VALUES ! CORRESPONDING TO THE N ! CONTINUOUS VALUES IN THE ! INPUT VECTOR X. ! ALSO, (NUMCLA+5) LINES OF SUMMARY INFORMATION ! WILL BE GENERATED INDICATING ! 1) WHAT THE SAMPLE SIZE IS (N); ! 2) WHAT THE NUMBER OF CLASSES IS (NUMCLA). ! 3) WHAT THE CLASS BOUNDARIES AND ! THE NUMBER OF OBSERVATIONS ! FALLING IN EACH CLASS ARE. ! PRINTING--YES ! RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE ! OF N FOR THIS SUBROUTINE. ! --NUMCLA SHOULD BE POSITIVE AND NOT EXCEED 1000 ! MODE OF INTERNAL OPERATIONS--. ! COMMENT--THIS SUBROUTINE DIFFERS FROM THE DISCR2 ! SUBROUTINE INASMUCH AS THIS SUBROUTINE ! PERFORMS ITS DISCRETIZATION BY OUTPUTING ! CLASS NUMBERS (1, 2,, ..., NUMCLA); ! WHEREAS THE DISCR2 SUBROUTINE ! OUTPUTS CLASS MIDPOINTS. ! COMMENT--THE INPUT VECTOR X REMAINS UNALTERED. ! COMMENT--IN THE MAIN (CALLING) ROUTINE, IT IS ! PERMISSABLE (IF THE ANALYST SO DESIRES) ! TO USE THE SAME VARIABLE NAME ! IN THE FOURTH ARGUMENT AS USED IN THE FIRST ! ARGUMENT IN THE CALLING SEQUENCE TO THIS ! DISCR3 SUBROUTINE--NO CONFLICT WILL RESULT ! IN THE INTERNAL OPERATION OF THE DISCR3 ! SUBROUTINE. FOR EXAMPLE, IT IS PERMISSIBLE ! TO HAVE CALL DISCR3(X,N,10,X) ! IN WHICH THE VARIABLE NAME X IS USED ! AS BOTH THE FIRST AND FOURTH ARGUMENTS. ! ORIGINAL VERSION--NOVEMBER 1974. ! UPDATED --APRIL 1975. ! UPDATED --NOVEMBER 1975. ! !--------------------------------------------------------------------- ! DIMENSION X(:) , Y(:) DIMENSION icount(1000) ! iupncl = 1000 ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( N<1 ) THEN WRITE (G_IO,99001) 99001 FORMAT (' ', & &'***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE DISCR3 SUBROU& &TINE IS NON-POSITIVE *****') WRITE (G_IO,99015) N RETURN ELSEIF ( N==1 ) THEN WRITE (G_IO,99002) 99002 FORMAT (' ', & &'***** NON-FATAL DIAGNOSTIC--THE SECOND INPUT ARGUMENT TO THE DISC& &R3 SUBROUTINE HAS THE VALUE 1 *****') Y(1) = X(1) RETURN ELSEIF ( Numcla<1 .OR. Numcla>iupncl ) THEN WRITE (G_IO,99003) iupncl 99003 FORMAT (' ', & &'***** FATAL ERROR--THE THIRD INPUT ARGUMENT TO THE DISCR3 SUBROU& &TINE IS OUTSIDE THE ALLOWABLE (1,',I0,') INTERVAL *****') WRITE (G_IO,99015) Numcla DO i = 1 , N Y(i) = 0.0_wp ENDDO RETURN ELSE IF ( Numcla==1 ) THEN WRITE (G_IO,99004) 99004 FORMAT (' ', & &'***** NON-FATAL DIAGNOSTIC--THE THIRD INPUT ARGUMENT TO THE DISC& &R3 SUBROUTINE HAS THE VALUE 1 *****') ELSE hold = X(1) DO i = 2 , N IF ( X(i)/=hold ) GOTO 50 ENDDO WRITE (G_IO,99005) hold 99005 FORMAT (' ', & &'***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT (A VECTOR) & &TO THE DISCR3 SUBROUTINE HAS ALL ELEMENTS =',E15.8,' *****') DO i = 1 , N Y(i) = X(i) ENDDO RETURN ENDIF ! !-----START POINT----------------------------------------------------- ! 50 anuml = Numcla ! ! ZERO OUT THE COUNT VECTOR (ICOUNT) ! DO i = 1 , Numcla icount(i) = 0 ENDDO ! ! COMPUTE THE SAMPLE MINIMUM AND MAXIMUM, ! THEN COMPUTE THE CLASS WIDTH. ! xmin = X(1) xmax = X(1) DO i = 1 , N IF ( X(i)<xmin ) xmin = X(i) IF ( X(i)>xmax ) xmax = X(i) ENDDO xdel = (xmax-xmin)/anuml ! ! PERFORM THE DISCRETIZING TRANSFORMATION. ! ALSO, KEEP A FREQUENCY COUNT FOR EACH CLASS. ! DO i = 1 , N p = (X(i)-xmin)/(xmax-xmin) p = p*anuml + 1.0_wp ip = p IF ( ip<1 ) ip = 1 IF ( ip>Numcla ) ip = Numcla Y(i) = ip icount(ip) = icount(ip) + 1 ENDDO ! ! COMPUTE CLASS LIMITS AND WRITE OUT SUMMARY INFORMATION. ! WRITE (G_IO,99016) WRITE (G_IO,99006) ! 99006 FORMAT (' ','OUTPUT FROM THE DISCR3 SUBROUTINE--') WRITE (G_IO,99016) WRITE (G_IO,99007) N 99007 FORMAT (' ',7X,'NUMBER OF OBSERVATIONS = ',I0) WRITE (G_IO,99008) Numcla 99008 FORMAT (' ',7X,'SPECIFIED NUMBER OF LEVELS = ',I0) WRITE (G_IO,99009) xmin 99009 FORMAT (' ',7X,'COMPUTED LOWER BOUND OF INTERVAL = ',F15.7) WRITE (G_IO,99010) xdel 99010 FORMAT (' ',7X,'COMPUTED CLASS WIDTH = ',F15.7) WRITE (G_IO,99011) xmax 99011 FORMAT (' ',7X,'COMPUTED UPPER BOUND OF INTERVAL = ',F15.7) WRITE (G_IO,99016) WRITE (G_IO,99012) 99012 FORMAT (' ',' LEVEL MINIMUM MAXIMUM COUNT'& & ) WRITE (G_IO,99013) 99013 FORMAT (' ',' ------------------------------------------'& & ) DO i = 1 , Numcla ai = i cmin = xmin + (ai-1.0_wp)*xdel cmax = xmin + ai*xdel WRITE (G_IO,99014) i , cmin , cmax , icount(i) 99014 FORMAT (' ',4X,I6,2X,2F14.7,I8) ENDDO ENDIF 99015 FORMAT (' ','***** THE VALUE OF THE ARGUMENT IS ',I0,' *****') 99016 FORMAT (' ') ! END SUBROUTINE DISCR3 !> !!##NAME !! discre(3f) - [M_datapac:STATISTICS] bin the elements of a vector !! (like DISCR2, but allows specification of min and max class limits) !! !!##SYNOPSIS !! !! SUBROUTINE DISCRE(X,N,Xmin,Xdel,Xmax,Y) !! !!##DESCRIPTION !! discre(3f) 'discretizes' the data of the REAL vector x. !! the first class interval is from xmin to xmin + xdel; the second !! class interval is from xmin+ xdel to xmin + 2*xdel; etc. !! !! all values in the vector x within a given class will be mapped into !! the midpoint of that class. !! !! all values in the vector x smaller than xmin will be mapped into xmin - !! (xdel/2.0). !! !! all values in the vector x larger than xmax will be mapped into xmax + !! (xdel/2.0). !! !! the use of discre(3f) (and the discr2 and discr3 subroutines) gives !! the data analyst the capability of constructing a discrete variate !! from a continuous one. !! !! the resulting discrete variate might then (for example) be analyzed !! in itself for gross structure, or for adherence to some theoretical !! discrete probability model, or the discrete variate might be used as !! a subset definition vector for some other variate. !! !!##OPTIONS !! X description of parameter !! Y description of parameter !! !!##EXAMPLES !! !! Sample program: !! !! program demo_discre !! use M_datapac, only : discre !! implicit none !! ! call discre(x,y) !! end program demo_discre !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the Statistical !! Engineering Division, National Institute of Standards and Technology. !!##MAINTAINER !! John Urban, 2022.05.31 !!##LICENSE !! CC0-1.0 ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE DISCRE(X,N,Xmin,Xdel,Xmax,Y) REAL(kind=wp) :: ai , clasml , clasmu , classm , cmax , cmin , hold , pointl ,& & pointu , totdel , X , Xdel , Xmax , Xmin , Y INTEGER :: i , icounl , icount , icounu , ip , N , numcla ! ! INPUT ARGUMENTS--X = THE VECTOR OF ! (UNSORTED OR SORTED) OBSERVATIONS. ! TO BE DISCRETIZED. ! --N = THE INTEGER NUMBER OF OBSERVATIONS ! IN THE VECTOR X. ! --XMIN = THE VALUE ! WHICH DEFINES THE LOWER BOUNDARY ! (INCLUSIVELY) OF THE LOWERMOST ! CLASS. ! --XDEL = THE VALUE ! OF THE CLASS WIDTH. ! --XMAX = THE VALUE ! WHICH DEFINES THE UPPER BOUNDARY ! (INCLUSIVELY) OF THE UPPERMOST ! CLASS. ! OUTPUT ARGUMENTS--Y = THE VECTOR OF ! DISCRETIZED VALUES (= CLASS ! MIDPOINTS) CORRESPONDING TO ! THE CONTINUOUS VALUES IN THE VECTOR X. ! THERE WILL RESULT N SUCH DISCRETIZED ! VALUES. ! OUTPUT--THE VECTOR Y ! WHICH CONTAINS N DISCRETIZED VALUES ! (= CLASS MIDPOINTS) ! CORRESPONDING TO THE N ! CONTINUOUS VALUES IN THE ! INPUT VECTOR X. ! ALSO, A FEW LINES LINES OF SUMMARY INFORMATION ! WILL BE GENERATED INDICATING ! 1) WHAT THE SAMPLE SIZE IS (N); ! 2) WHAT THE NUMBER OF CLASSES IS (NUMCLA). ! 3) WHAT THE CLASS BOUNDARIES AND ! THE NUMBER OF OBSERVATIONS ! FALLING IN EACH CLASS ARE. ! PRINTING--YES. ! RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE ! OF N FOR THIS SUBROUTINE. ! --XDEL SHOULD BE POSITIVE. ! --(XMAX-XMIN)/XDEL SHOULD NOT EXCEED 999. ! MODE OF INTERNAL OPERATIONS--. ! COMMENT--IT IS SUGGESTED THAT XMIN, XDEL, ! AND XMAX HAVE AT LEAST 1 MORE ! DECIMAL PLACE THAN THE DATA VALUES ! IN THE VECTOR X SO AS TO HELP ASSURE ! A UNIQUE DISCRETIZATION MAPPING; ! THAT IS, TO HELP ASSURE THAT ! NO DATA VALUE WILL FALL ! EXACTLY ON THE BOUNDARY POINT ! BETWEEN 2 ADJACENT CLASSES. ! COMMENT--IN THE MAIN (CALLING) ROUTINE, IT IS ! PERMISSABLE (IF THE ANALYST SO DESIRES) ! TO USE THE SAME VARIABLE NAME ! IN THE SIXTH ARGUMENT AS USED IN THE FIRST ! ARGUMENT IN THE CALLING SEQUENCE TO THIS ! DISCRE SUBROUTINE--NO CONFLICT WILL RESULT ! IN THE INTERNAL OPERATION OF THE DISCRE ! SUBROUTINE. FOR EXAMPLE, IT IS PERMISSIBLE ! TO HAVE CALL DISCRE(X,N,0.5,1.0,20.5,X) ! IN WHICH THE VARIABLE NAME X IS USED ! AS BOTH THE FIRST AND SIXTH ARGUMENTS. ! ORIGINAL VERSION--NOVEMBER 1974. ! UPDATED --NOVEMBER 1975. ! !--------------------------------------------------------------------- ! DIMENSION X(:) , Y(:) DIMENSION icount(1000) DIMENSION classm(1000) ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( N<1 ) THEN WRITE (G_IO,99001) 99001 FORMAT (' ', & &'***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE DISCRE SUBROU& &TINE IS NON-POSITIVE *****') WRITE (G_IO,99002) N 99002 FORMAT (' ','***** THE VALUE OF THE ARGUMENT IS ',I0,' *****') RETURN ELSEIF ( N==1 ) THEN WRITE (G_IO,99003) 99003 FORMAT (' ', & &'***** NON-FATAL DIAGNOSTIC--THE SECOND INPUT ARGUMENT TO THE DISC& &RE SUBROUTINE HAS THE VALUE 1 *****') Y(1) = X(1) RETURN ELSEIF ( Xdel<=0.0_wp ) THEN WRITE (G_IO,99004) 99004 FORMAT (' ', & &'***** FATAL ERROR--THE FOURTH INPUT ARGUMENT TO THE DISCRE SUBROU& &TINE IS NON-POSITIVE *****') WRITE (G_IO,99005) Xdel 99005 FORMAT (' ','***** THE VALUE OF THE ARGUMENT IS ',E15.7, & & ' *****') DO i = 1 , N Y(i) = 0.0_wp ENDDO RETURN ELSE IF ( Xmin==Xmax ) THEN WRITE (G_IO,99006) 99006 FORMAT (' ','***** FATAL ERROR--THE THIRD AND FIFTH INPUT ',& & 'ARGUMENTS TO THE DISCRE SUBROUTINE ARE IDENTICAL') WRITE (G_IO,99007) Xmin 99007 FORMAT (' ','***** THE VALUE OF THE ARGUMENTS ARE ',E15.7, & & ' *****') DO i = 1 , N Y(i) = 0.0_wp ENDDO RETURN ELSE hold = X(1) DO i = 2 , N IF ( X(i)/=hold ) GOTO 50 ENDDO WRITE (G_IO,99008) hold 99008 FORMAT (' ', & &'***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT (A VECTOR) & &TO THE DISCRE SUBROUTINE HAS ALL ELEMENTS =',E15.8,' *****') DO i = 1 , N Y(i) = X(i) ENDDO RETURN ENDIF ! !-----START POINT----------------------------------------------------- ! ! DETERMINE THE TRUE INTERVAL MIN AND MAX; ! THEN DETERMINE THE NUMBER OF CLASSES ! WITHIN THE SPECIFIED MIN AND MAX. ! 50 pointl = Xmin pointu = Xmax IF ( Xmin>Xmax ) pointl = Xmax IF ( Xmin>Xmax ) pointu = Xmin totdel = pointu - pointl numcla = (totdel/Xdel) + 0.999_wp ! ! ZERO OUT THE COUNT VECTOR (ICOUNT) ! AND THE LOWER AND UPPER COUNT VARIABLES. ! DO i = 1 , numcla icount(i) = 0 ENDDO icounl = 0 icounu = 0 ! ! COMPUTE THE CLASS MIDPOINT FOR EACH CLASS. ! DO i = 1 , numcla ai = i cmin = Xmin + (ai-1.0)*Xdel cmax = Xmin + ai*Xdel classm(i) = (cmin+cmax)/2.0_wp ENDDO cmax = pointu classm(numcla) = (cmin+cmax)/2.0_wp ! ! PERFORM THE DISCRETIZING TRANSFORMATION. ! DO i = 1 , N IF ( X(i)>=pointl .AND. X(i)<=pointu ) THEN ip = (X(i)-pointl)/Xdel ip = ip + 1 IF ( ip>numcla ) ip = numcla Y(i) = classm(ip) icount(ip) = icount(ip) + 1 ELSEIF ( X(i)<pointl ) THEN clasml = pointl - (Xdel/2.0_wp) Y(i) = clasml icounl = icounl + 1 ELSEIF ( X(i)>pointu ) THEN clasmu = pointu + (Xdel/2.0_wp) Y(i) = clasmu icounu = icounu + 1 ENDIF ENDDO ! ! COMPUTE CLASS LIMITS AND WRITE OUT SUMMARY INFORMATION. ! WRITE (G_IO,99020) WRITE (G_IO,99009) ! 99009 FORMAT (' ','OUTPUT FROM THE DISCRE SUBROUTINE--') WRITE (G_IO,99020) WRITE (G_IO,99010) N 99010 FORMAT (' ',7X,'NUMBER OF OBSERVATIONS = ',I0) WRITE (G_IO,99011) Xmin 99011 FORMAT (' ',7X,'SPECIFIED LOWER BOUND OF INTERVAL = ',F15.7) WRITE (G_IO,99012) Xdel 99012 FORMAT (' ',7X,'SPECIFIED CLASS WIDTH = ',F15.7) WRITE (G_IO,99013) Xmax 99013 FORMAT (' ',7X,'SPECIFIED UPPER BOUND OF INTERVAL = ',F15.7) WRITE (G_IO,99014) numcla 99014 FORMAT (' ',7X,'COMPUTED NUMBER OF LEVELS = ',I0) WRITE (G_IO,99020) WRITE (G_IO,99015) 99015 FORMAT (' ', & & ' CLASS MINIMUM MIDPOINT MAXIMUM',& & ' COUNT') WRITE (G_IO,99016) 99016 FORMAT (' ', & & ' -------------------------------------------', & & '-------------') IF ( icounl>=1 ) WRITE (G_IO,99017) clasml , pointl , icounl 99017 FORMAT (' ',4X,' BELOW -INFINITY',2F14.7,I8) DO i = 1 , numcla ai = i cmin = pointl + (ai-1.0_wp)*Xdel cmax = pointl + ai*Xdel IF ( cmax>pointu ) cmax = pointu WRITE (G_IO,99018) i , cmin , classm(i) , cmax , icount(i) 99018 FORMAT (' ',4X,I6,2X,3F14.7,I8) ENDDO IF ( icounu>=1 ) WRITE (G_IO,99019) pointu , clasmu , icounu 99019 FORMAT (' ',4X,' ABOVE',2F14.7,' +INFINITY',I0) ENDIF 99020 FORMAT (' ') ! END SUBROUTINE DISCRE !> !!##NAME !! dot(3f) - [M_datapac:VECTOR_OPERATION] compute a dot product of !! two vectors !! !!##SYNOPSIS !! !! subroutine dot(A,B,Imin,Imax,Parpro,Dotpro) !! !! real(kind=wp),intent(in) :: A(:), B(:), Parpro !! real(kind=wp),intent(out) :: Dotpro !! integer,intent(in) :: Imax, Imin !! !!##DESCRIPTION !! !! To compute the dot product between 2 vectors A and B only elements !! IMIN through IMAX of the 2 vectors are considered. The computed dot !! product is added to the input value PARPRO to yield a final answer !! for DOTPRO. !! !! Note Fortran now has a dot product intrinsic called DOT_PRODUCT(3f). !! !!##INPUT OPTIONS !! !! A First vector !! B Second vector !! Imin First index in A and B to consider !! Imax Last index in A and B to consider !! Parpro Initial value to add the dot product to !! !!##OUTPUT OPTIONS !! !! Dotpro Dot product of A and B. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_dot !! use M_datapac, only : dot, label !! real, dimension(3) :: a, b !! real :: dotpro , parpro !! integer i , imax , imin !! call label('dot') !! a = [ 1.0, 2.0, 3.0 ] !! b = [ 4.0, 5.0, 6.0 ] !! imin=1 !! imax=size(a) !! parpro=0.0 !! call dot(a,b,imin,imax,parpro,dotpro) !! write(*,*)a !! write(*,*)b !! write(*,*)dotpro, dot_product(a,b), dotpro == dot_product(a,b) !! end program demo_dot !! !! Results: !! !! 1.000000 2.000000 3.000000 !! 4.000000 5.000000 6.000000 !! 32.00000 32.00000 T !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the Statistical !! Engineering Division, National Institute of Standards and Technology. !!##MAINTAINER !! John Urban, 2022.05.31 !!##LICENSE !! CC0-1.0 ! UPDATED --NOVEMBER 1975. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 subroutine dot(A,B,Imin,Imax,Parpro,Dotpro) real(kind=wp),intent(in) :: A(:) , B(:) , Parpro real(kind=wp),intent(out) :: Dotpro integer,intent(in) :: Imax , Imin integer :: i double precision :: sum , prod , dparpr dparpr = Parpro sum = 0.0d0 if ( Imin<=Imax ) then do i = Imin , Imax prod = A(i)*B(i) sum = sum + prod enddo endif Dotpro = sum + dparpr end subroutine dot !> !!##NAME !! ev1cdf(3f) - [M_datapac:CUMULATIVE_DISTRIBUTION] compute the extreme value type 1 !! (Gumbel) cumulative distribution function !! !!##SYNOPSIS !! !! SUBROUTINE EV1CDF(X,Cdf) !! !! REAL(kind=wp),intent(in) :: X !! REAL(kind=wp),intent(out) :: Cdf !! !!##DESCRIPTION !! EV1CDF(3f) computes the cumulative distribution function value for !! the extreme value type 1 distribution. !! !! The extreme value type 1 distribution used herein has mean = Euler's !! number = 0.57721566 and standard deviation = pi/sqrt(6) = 1.28254983. !! !! This distribution is defined for all X and has the probability !! density function !! !! f(X) = (exp(-X)) * (exp(-(exp(-X)))) !! !!##INPUT ARGUMENTS !! !! X The value at which the cumulative distribution function is !! to be evaluated. !! !!##OUTPUT ARGUMENTS !! !! CDF The cumulative distribution function value. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_ev1cdf !! use M_datapac, only : ev1cdf !! implicit none !! ! call ev1cdf(x,y) !! end program demo_ev1cdf !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !! !!##REFERENCES !! * Johnson and Kotz, Continuous Univariate Distributions--1, 1970, !! pages 272-295. ! ORIGINAL VERSION--NOVEMBER 1975. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE EV1CDF(X,Cdf) REAL(kind=wp),intent(in) :: X REAL(kind=wp),intent(out) :: Cdf ! CHECK THE INPUT ARGUMENTS FOR ERRORS. -- NO INPUT ARGUMENT ERRORS POSSIBLE FOR THIS DISTRIBUTION. Cdf = 1.0_wp - EXP(-(EXP(-X))) END SUBROUTINE EV1CDF !> !!##NAME !! ev1plt(3f) - [M_datapac:LINE_PLOT] generate a extreme value type 1 !! (Gumbel) probability plot !! !!##SYNOPSIS !! !! SUBROUTINE EV1PLT(X,N) !! !!##DESCRIPTION !! !! ev1plt(3f) generates an extreme value type 1 probability plot. !! !! the prototype extreme value type 1 distribution used here has mean !! = euler's number = 0.57721566 and standard deviation = pi/sqrt(6) !! = 1.28254983. !! !! this distribution is defined for all x and has the probability !! density function !! !! f(x) = (exp(-x)) * (exp(-(exp(-x)))) !! !! as used herein, a probability plot for a distribution is a plot !! of the ordered observations versus the order statistic medians for !! that distribution. !! !! the extreme value type 1 probability plot is useful in graphically !! testing the composite (that is, location and scale parameters need !! not be specified) hypothesis that the underlying distribution from !! which the data have been randomly drawn is the extreme value type !! 1 distribution. !! !! if the hypothesis is true, the probability plot should be near-linear. !! !! a measure of such linearity is given by the calculated probability !! plot correlation coefficient. !! !!##OPTIONS !! X description of parameter !! Y description of parameter !! !!##EXAMPLES !! !! Sample program: !! !! program demo_ev1plt !! use M_datapac, only : ev1plt !! implicit none !! ! call ev1plt(x,y) !! end program demo_ev1plt !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !! !!##REFERENCES !! * FILLIBEN, 'TECHNIQUES FOR TAIL LENGTH ANALYSIS', PROCEEDINGS OF THE !! EIGHTEENTH CONFERENCE ON THE DESIGN OF EXPERIMENTS IN ARMY RESEARCH !! DEVELOPMENT AND TESTING (ABERDEEN, MARYLAND, OCTOBER, 1972), pages !! 425-450. !! * HAHN AND SHAPIRO, STATISTICAL METHODS IN ENGINEERING, 1967, pages !! 260-308. !! * JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE DISTRIBUTIONS--1, 1970, !! pages 272-295. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE EV1PLT(X,N) REAL(kind=wp) :: an , cc , hold , sum1 , sum2 , sum3 , tau , W , wbar , WS , & & X , Y , ybar , yint , yslope INTEGER :: i , iupper , N ! ! INPUT ARGUMENTS--X = THE VECTOR OF ! (UNSORTED OR SORTED) OBSERVATIONS. ! --N = THE INTEGER NUMBER OF OBSERVATIONS ! IN THE VECTOR X. ! OUTPUT--A ONE-page EXTREME VALUE TYPE 1 PROBABILITY PLOT. ! PRINTING--YES. ! RESTRICTIONS--THE MAXIMUM ALLOWABLE VALUE OF N ! FOR THIS SUBROUTINE IS 7500. ! OTHER DATAPAC SUBROUTINES NEEDED--SORT, UNIMED, PLOT. ! FORTRAN LIBRARY SUBROUTINES NEEDED--SQRT, LOG. ! MODE OF INTERNAL OPERATIONS--. ! ORIGINAL VERSION--JUNE 1972. ! UPDATED --SEPTEMBER 1975. ! UPDATED --NOVEMBER 1975. ! UPDATED --FEBRUARY 1976. ! !--------------------------------------------------------------------- DIMENSION X(:) DIMENSION Y(7500) , W(7500) COMMON /BLOCK2_real32/ WS(15000) EQUIVALENCE (Y(1),WS(1)) EQUIVALENCE (W(1),WS(7501)) ! DATA tau/1.56186687_wp/ ! iupper = 7500 ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( N<1 .OR. N>iupper ) THEN WRITE (G_IO,99001) iupper 99001 FORMAT (' ', & &'***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE EV1PLT SUBROU& &TINE IS OUTSIDE THE ALLOWABLE (1,',I0,') INTERVAL *****') WRITE (G_IO,99002) N 99002 FORMAT (' ','***** THE VALUE OF THE ARGUMENT IS ',I0,' *****') RETURN ELSEIF ( N==1 ) THEN WRITE (G_IO,99003) 99003 FORMAT (' ', & &'***** NON-FATAL DIAGNOSTIC--THE SECOND INPUT ARGUMENT TO THE EV1P& < SUBROUTINE HAS THE VALUE 1 *****') RETURN ELSE hold = X(1) DO i = 2 , N IF ( X(i)/=hold ) GOTO 50 ENDDO WRITE (G_IO,99004) hold 99004 FORMAT (' ', & &'***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT (A VECTOR) & &TO THE EV1PLT SUBROUTINE HAS ALL ELEMENTS = ',E15.8,' *****') ! !-----START POINT----------------------------------------------------- ! 50 an = N ! ! SORT THE DATA ! CALL SORT(X,N,Y) ! ! GENERATE UNIFORM ORDER STATISTIC MEDIANS ! CALL UNIMED(N,W) ! ! COMPUTE EXTREME VALUE TYPE 1 ORDER STATISTIC MEDIANS ! DO i = 1 , N W(i) = -LOG(LOG(1.0_wp/W(i))) ENDDO ! ! PLOT THE ORDERED OBSERVATIONS VERSUS ORDER STATISTICS MEDIANS. ! WRITE OUT THE TAIL LENGTH MEASURE OF THE DISTRIBUTION ! AND THE SAMPLE SIZE. ! CALL PLOT(Y,W,N) WRITE (G_IO,99005) tau , N ! 99005 FORMAT (' ', & &'EXTREME VALUE TYPE 1 (EXPONENTIAL TYPE) PROBABILITY PLOT (TAU = '& &,E15.8,')',23X,'THE SAMPLE SIZE N = ',I0) ! ! COMPUTE THE PROBABILITY PLOT CORRELATION COEFFICIENT. ! COMPUTE LOCATION AND SCALE ESTIMATES ! FROM THE INTERCEPT AND SLOPE OF THE PROBABILITY PLOT. ! THEN WRITE THEM OUT. ! sum1 = 0.0_wp sum2 = 0.0_wp DO i = 1 , N sum1 = sum1 + Y(i) sum2 = sum2 + W(i) ENDDO ybar = sum1/an wbar = sum2/an sum1 = 0.0_wp sum2 = 0.0_wp sum3 = 0.0_wp DO i = 1 , N sum1 = sum1 + (Y(i)-ybar)*(Y(i)-ybar) sum2 = sum2 + (Y(i)-ybar)*(W(i)-wbar) sum3 = sum3 + (W(i)-wbar)*(W(i)-wbar) ENDDO cc = sum2/SQRT(sum3*sum1) yslope = sum2/sum3 yint = ybar - yslope*wbar WRITE (G_IO,99006) cc , yint , yslope 99006 FORMAT (' ','PROBABILITY PLOT CORRELATION COEFFICIENT = ',F8.5,& & 5X,'ESTIMATED INTERCEPT = ',E15.8,3X, & & 'ESTIMATED SLOPE = ',E15.8) ENDIF ! END SUBROUTINE EV1PLT !> !!##NAME !! ev1ppf(3f) - [M_datapac:PERCENT_POINT] compute the extreme value type 1 !! (Gumbel) percent point function !! !!##SYNOPSIS !! !! SUBROUTINE EV1PPF(P,Ppf) !! !! REAL(kind=wp),intent(in) :: P !! REAL(kind=wp),intent(out) :: Ppf !! !!##DESCRIPTION !! EV1PPF(3f) computes the percent point function value for the extreme !! value type 1 distribution. !! !! The extreme value type 1 distribution used herein has mean = Euler's !! number = 0.57721566 and standard deviation = pi/sqrt(6) = 1.28254983. !! !! This distribution is defined for all x and has the probability !! density function !! !! f(x) = (exp(-x)) * (exp(-(exp(-x)))) !! !! Note that the percent point function of a distribution is identically !! the same as the inverse cumulative distribution function of the !! distribution. !! !!##INPUT ARGUMENTS !! P The value (between 0.0 and 1.0 exclusively) at which the !! percent point function is to be evaluated. !! !!##OUTPUT ARGUMENTS !! PPF The percent point function value for the extreme value type !! 1 distribution with mean = Euler's number = 0.57721566 and standard !! deviation = pi/sqrt(6) = 1.28254983. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_ev1ppf !! use M_datapac, only : ev1ppf !! implicit none !! ! call ev1ppf(x,y) !! end program demo_ev1ppf !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !!##MAINTAINER !! John Urban, 2022.05.31 !!##LICENSE !! CC0-1.0 !!##REFERENCES !! * Johnson and Kotz, Continuous Univariate Distributions--1, 1970, !! pages 272-295. ! ORIGINAL VERSION--NOVEMBER 1975. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE EV1PPF(P,Ppf) REAL(kind=wp),intent(in) :: P REAL(kind=wp),intent(out) :: Ppf !--------------------------------------------------------------------- ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( P<=0.0_wp .OR. P>=1.0_wp ) THEN WRITE (G_IO,99001) 99001 FORMAT (' ***** FATAL ERROR--THE FIRST INPUT ARGUMENT TO EV1PPF(3f) IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL *****') WRITE (G_IO,99002) P 99002 FORMAT (' ','***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') Ppf = 0.0_wp RETURN ELSE Ppf = -LOG(LOG(1.0_wp/P)) ENDIF END SUBROUTINE EV1PPF !> !!##NAME !! ev1ran(3f) - [M_datapac:RANDOM] generate extreme value type 1 !! (Gumbel) random numbers !! !!##SYNOPSIS !! !! SUBROUTINE EV1RAN(N,Iseed,X) !! !! INTEGER,intent(in) :: N !! INTEGER,intent(inout) :: Iseed !! REAL(kind=wp),intent(out) :: X(:) !! !!##DESCRIPTION !! EV1RAN(3f) generates a random sample of size N from the extreme value !! type 1 distribution. !! !! The prototype extreme value type 1 distribution used herein has mean !! = Euler's number = 0.57721566 and standard deviation = pi/sqrt(6) !! = 1.28254983. This distribution is defined for all X and has the !! probability density function !! !! f(X) = (exp(-X)) * (exp(-(exp(-X)))) !! !!##INPUT ARGUMENTS !! !! N The desired integer number of random numbers to be generated. !! !! ISEED An integer seed value. Should be set to a non-negative value !! to start a new sequence of values. Will be set to -1 on return !! to indicate the next call should continue the current random !! sequence walk. !! !!##OUTPUT ARGUMENTS !! !! X A vector (of dimension at least N) into which the generated !! random sample of size N from the extreme value type 1 !! distribution will be placed. !! !! !!##EXAMPLES !! !! Sample program: !! !! program demo_ev1ran !! use m_datapac, only : ev1ran, plott, label, plotxt, sort !! implicit none !! integer,parameter :: n=4000 !! real :: x(n) !! integer :: iseed !! call label('ev1ran') !! iseed=12345 !! call ev1ran(n,iseed,x) !! call plotxt(x,n) !! call sort(x,n,x) ! sort to show distribution !! call plotxt(x,n) !! end program demo_ev1ran !! !! Results: !! !! THE FOLLOWING IS A PLOT OF X(I) (VERTICALLY) VERSUS I (HORIZONTALLY !! I-----------I-----------I-----------I-----------I !! 0.1011052E+02 - X !! 0.9597239E+01 I !! 0.9083955E+01 I !! 0.8570670E+01 I !! 0.8057385E+01 I X !! 0.7544101E+01 I X !! 0.7030817E+01 - X !! 0.6517532E+01 I X X !! 0.6004248E+01 I X X X X XX !! 0.5490964E+01 I X X XX X X X X X !! 0.4977679E+01 I X X X X X XXX X X X X !! 0.4464395E+01 I X X XXX X XX X X X XX X X !! 0.3951111E+01 - X X XX XXXXXX X X XXX XXX XXXXX XXX XXX X XXXXX !! 0.3437826E+01 I XXXXXXXXXXXXXX XXXXXXXX XX XX XXXX X X XX XXXXXX !! 0.2924542E+01 I XXXXXXXXXXXXXXXXXXXXX XXXXXXXXXXXXXXXXXXXXXXXXXXX !! 0.2411257E+01 I XXXXXXXXXXXXXXXXXX XXXXXXXXXXXXXXXX XXXXXXXXXXXXX !! 0.1897973E+01 I XXXXXXXXXXXXXXXXXXXXXXXXX XXXXXXXXXXXXXXXXXXXXXXX !! 0.1384688E+01 I XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX !! 0.8714046E+00 - XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX !! 0.3581200E+00 I XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX !! -0.1551647E+00 I XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX !! -0.6684484E+00 I XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX !! -0.1181733E+01 I XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX !! -0.1695018E+01 I X XXX XX XXXXXXXXXXXXXXXXXXXXXXX X X XXXXX !! -0.2208302E+01 - X X !! I-----------I-----------I-----------I-----------I !! 0.1000E+01 0.1001E+04 0.2000E+04 0.3000E+04 0.4000E+04 !! !! THE FOLLOWING IS A PLOT OF X(I) (VERTICALLY) VERSUS I (HORIZONTALLY !! I-----------I-----------I-----------I-----------I !! 0.1011052E+02 - X !! 0.9597239E+01 I !! 0.9083955E+01 I !! 0.8570670E+01 I !! 0.8057385E+01 I X !! 0.7544101E+01 I X !! 0.7030817E+01 - X !! 0.6517532E+01 I X !! 0.6004248E+01 I X !! 0.5490964E+01 I X !! 0.4977679E+01 I X !! 0.4464395E+01 I XX !! 0.3951111E+01 - X !! 0.3437826E+01 I XX !! 0.2924542E+01 I XX !! 0.2411257E+01 I XXX !! 0.1897973E+01 I XXXXX !! 0.1384688E+01 I XXXXXX !! 0.8714046E+00 - XXXXXXXX !! 0.3581200E+00 I XXXXXXXXX !! -0.1551647E+00 I XXXXXXXXX !! -0.6684484E+00 I XXXXXXXX !! -0.1181733E+01 I XXXX !! -0.1695018E+01 I XX !! -0.2208302E+01 - X !! I-----------I-----------I-----------I-----------I !! 0.1000E+01 0.1001E+04 0.2000E+04 0.3000E+04 0.4000E+04 !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !! !!##REFERENCES !! * Tocher, The Art of Simulation, 1963, pages 14-15. !! * Hammersley and Handscomb, Monte Carlo Methods, 1964, page 36. !! * Johnson and Kotz, Continuous Univariate Distributions--1, 1970, !! pages 272-295. ! VERSION NUMBER--82/7 ! ORIGINAL VERSION--NOVEMBER 1975. ! UPDATED --DECEMBER 1981. ! UPDATED --MAY 1982. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE EV1RAN(N,Iseed,X) INTEGER,intent(in) :: N INTEGER,intent(inout) :: Iseed REAL(kind=wp),intent(out) :: X(:) INTEGER :: i !--------------------------------------------------------------------- ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( N<1 ) THEN WRITE (G_IO,99001) 99001 FORMAT (' ***** FATAL ERROR--The first input argument to EV1RAN(3f) is non-positive *****') WRITE (G_IO,99002) N 99002 FORMAT (' ***** The value of the argument is ',I0,' *****') ELSE ! ! GENERATE N UNIFORM (0,1) RANDOM NUMBERS; ! CALL UNIRAN(N,Iseed,X) ! ! GENERATE N EXTREME VALUE TYPE 1 RANDOM NUMBERS ! USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD. ! DO i = 1 , N X(i) = -LOG(LOG(1.0_wp/X(i))) ENDDO ENDIF END SUBROUTINE EV1RAN !> !!##NAME !! ev2cdf(3f) - [M_datapac:CUMULATIVE_DISTRIBUTION] compute the extreme value type 2 !! (Frechet) cumulative distribution function !! !!##SYNOPSIS !! !! SUBROUTINE EV2CDF(X,Gamma,Cdf) !! !! REAL(kind=wp),intent(in) :: X !! REAL(kind=wp),intent(in) :: Gamma !! REAL(kind=wp),intent(out) :: Cdf !! !!##DESCRIPTION !! EV2CDF(3f) computes the cumulative distribution function value for !! the extreme value type 2 distribution with REAL tail !! length parameter = GAMMA. !! !! The extreme value type 2 distribution used herein is defined for all !! non-negative X, and has the probability density function !! !! f(X) = GAMMA * (X**(-GAMMA-1)) * exp(-(X**(-GAMMA))) !! !!##INPUT ARGUMENTS !! !! X The value at which the cumulative distribution function is !! to be evaluated. X should be non-negative. !! !! GAMMA The value of the tail length parameter. GAMMA should be !! positive. !! !!##OUTPUT ARGUMENTS !! !! CDF The cumulative distribution function value for the extreme !! value type 2 distribution with tail length parameter value = GAMMA. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_ev2cdf !! use M_datapac, only : ev2cdf !! implicit none !! ! call ev2cdf(x,y) !! end program demo_ev2cdf !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !!##MAINTAINER !! John Urban, 2022.05.31 !!##LICENSE !! CC0-1.0 !!##REFERENCES !! * Johnson and Kotz, Continuous Univariate Distributions--1, 1970, !! pages 272-295. ! ORIGINAL VERSION--NOVEMBER 1975. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE EV2CDF(X,Gamma,Cdf) REAL(kind=wp),intent(in) :: X REAL(kind=wp),intent(in) :: Gamma REAL(kind=wp),intent(out) :: Cdf ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( X<0.0_wp ) THEN WRITE (G_IO,99001) 99001 FORMAT (' ***** NON-FATAL DIAGNOSTIC--The first input argument to EV2CDF(3f) is negative *****') WRITE (G_IO,99003) X Cdf = 0.0_wp RETURN ELSEIF ( Gamma<=0.0_wp ) THEN WRITE (G_IO,99002) 99002 FORMAT (' ***** FATAL ERROR--The second input argument to EV2CDF(3f) is non-positive *****') WRITE (G_IO,99003) Gamma Cdf = 0.0_wp RETURN ELSE Cdf = 0.0_wp IF ( X==0.0_wp ) RETURN Cdf = EXP(-(X**(-Gamma))) ENDIF 99003 FORMAT (' ','***** The value of the argument is ',E15.8,' *****') END SUBROUTINE EV2CDF !> !!##NAME !! ev2plt(3f) - [M_datapac:LINE_PLOT] generate a extreme value type 2 !! (Frechet) probability plot !! !!##SYNOPSIS !! !! SUBROUTINE EV2PLT(X,N,Gamma) !! !!##DESCRIPTION !! ev2plt(3f) generates a extreme value type 2 probability plot (with !! tail length parameter value = gamma). !! !! the prototype extreme value type 2 distribution used n herein !! is defined for all non-negative x, and has the probability density !! function !! !! f(x) = gamma * (x**(-gamma-1)) * exp(-(x**(-gamma))). !! !! as used herein, a probability plot for a distribution is a plot !! of the ordered observations versus the order statistic medians for !! that distribution. !! !! the extreme value type 2 probability plot is useful in graphically !! testing the composite (that is, location and scale parameters need !! not be specified) hypothesis that the underlying distribution from !! which the data have been randomly drawn is the extreme value type !! 2 distribution with tail length parameter value = gamma. !! !! if the hypothesis is true, the probability plot should be near-linear. !! !! a measure of such linearity is given by the calculated probability !! plot correlation coefficient. !! !!##OPTIONS !! X description of parameter !! Y description of parameter !! !!##EXAMPLES !! !! Sample program: !! !! program demo_ev2plt !! use M_datapac, only : ev2plt !! implicit none !! ! call ev2plt(x,y) !! end program demo_ev2plt !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the Statistical !! Engineering Division, National Institute of Standards and Technology. !!##MAINTAINER !! John Urban, 2022.05.31 !!##LICENSE !! CC0-1.0 !!##REFERENCES !! * FILLIBEN, 'TECHNIQUES FOR TAIL LENGTH ANALYSIS', PROCEEDINGS OF THE !! EIGHTEENTH CONFERENCE ON THE DESIGN OF EXPERIMENTS IN ARMY RESEARCH !! DEVELOPMENT AND TESTING (ABERDEEN, MARYLAND, OCTOBER, 1972), pages !! 425-450. !! * HAHN AND SHAPIRO, STATISTICAL METHODS IN ENGINEERING, 1967, pages !! 260-308. !! * JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE DISTRIBUTIONS--1, 1970, !! pages 272-295. ! ORIGINAL VERSION--DECEMBER 1972. ! UPDATED --SEPTEMBER 1975. ! UPDATED --NOVEMBER 1975. ! UPDATED --FEBRUARY 1976. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE EV2PLT(X,N,Gamma) REAL(kind=wp) :: an , cc , Gamma , hold , pp0025 , pp025 , pp975 , pp9975 , & & q , sum1 , sum2 , sum3 , tau , W , wbar , WS , X , Y , ybar ,& & yint REAL(kind=wp) :: yslope INTEGER i , iupper , N ! ! INPUT ARGUMENTS--X = THE VECTOR OF ! (UNSORTED OR SORTED) OBSERVATIONS. ! --N = THE INTEGER NUMBER OF OBSERVATIONS ! IN THE VECTOR X. ! --GAMMA = THE VALUE OF THE ! TAIL LENGTH PARAMETER. ! GAMMA SHOULD BE POSITIVE. ! OUTPUT--A ONE-page EXTREME VALUE TYPE 2 PROBABILITY PLOT. ! PRINTING--YES. ! RESTRICTIONS--THE MAXIMUM ALLOWABLE VALUE OF N ! FOR THIS SUBROUTINE IS 7500. ! --GAMMA SHOULD BE POSITIVE. ! OTHER DATAPAC SUBROUTINES NEEDED--SORT, UNIMED, PLOT. ! FORTRAN LIBRARY SUBROUTINES NEEDED--SQRT, LOG. ! MODE OF INTERNAL OPERATIONS--. ! !--------------------------------------------------------------------- ! DIMENSION X(:) DIMENSION Y(7500) , W(7500) COMMON /BLOCK2_real32/ WS(15000) EQUIVALENCE (Y(1),WS(1)) EQUIVALENCE (W(1),WS(7501)) ! iupper = 7500 ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( N<1 .OR. N>iupper ) THEN WRITE (G_IO,99001) iupper 99001 FORMAT (' ', & &'***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE EV2PLT SUBROU& &TINE IS OUTSIDE THE ALLOWABLE (1,',I0,') INTERVAL *****') WRITE (G_IO,99002) N 99002 FORMAT (' ','***** THE VALUE OF THE ARGUMENT IS ',I0,' *****') RETURN ELSEIF ( N==1 ) THEN WRITE (G_IO,99003) 99003 FORMAT (' ', & &'***** NON-FATAL DIAGNOSTIC--THE SECOND INPUT ARGUMENT TO THE EV2P& < SUBROUTINE HAS THE VALUE 1 *****') RETURN ELSE IF ( Gamma<=0.0_wp ) THEN WRITE (G_IO,99004) 99004 FORMAT (' ', & &'***** FATAL ERROR--THE THIRD INPUT ARGUMENT TO THE EV2PLT SUBROU& &TINE IS NON-POSITIVE *****') WRITE (G_IO,99005) Gamma 99005 FORMAT (' ','***** THE VALUE OF THE ARGUMENT IS ',E15.8, & & ' *****') RETURN ELSE hold = X(1) DO i = 2 , N IF ( X(i)/=hold ) GOTO 50 ENDDO WRITE (G_IO,99006) hold 99006 FORMAT (' ', & &'***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT (A VECTOR) & &TO THE EV2PLT SUBROUTINE HAS ALL ELEMENTS = ',E15.8,' *****') RETURN ENDIF ! !-----START POINT----------------------------------------------------- ! 50 an = N ! ! SORT THE DATA ! CALL SORT(X,N,Y) ! ! GENERATE UNIFORM ORDER STATISTIC MEDIANS ! CALL UNIMED(N,W) ! ! COMPUTE EXREME VALUE TYPE 2 DISTRIBUTION ORDER STATISTIC MEDIANS ! DO i = 1 , N W(i) = (-LOG(W(i)))**(-1.0_wp/Gamma) ENDDO ! ! PLOT THE ORDERED OBSERVATIONS VERSUS ORDER STATISTICS MEDIANS. ! COMPUTE THE TAIL LENGTH MEASURE OF THE DISTRIBUTION. ! WRITE OUT THE TAIL LENGTH MEASURE OF THE DISTRIBUTION ! AND THE SAMPLE SIZE. ! CALL PLOT(Y,W,N) q = .9975_wp pp9975 = (-LOG(q))**(-1.0_wp/Gamma) q = .0025_wp pp0025 = (-LOG(q))**(-1.0_wp/Gamma) q = .975_wp pp975 = (-LOG(q))**(-1.0_wp/Gamma) q = .025_wp pp025 = (-LOG(q))**(-1.0_wp/Gamma) tau = (pp9975-pp0025)/(pp975-pp025) WRITE (G_IO,99007) Gamma , tau , N ! 99007 FORMAT (' ', & & 'EXTREME VALUE TYPE 2 (CAUCHY TYPE) PROB. PLOT WITH EXP. PAR. = '& & ,E17.10,1X,'(TAU = ',E15.8,')',1X,'SAMPLE SIZE N = ',I0) ! ! COMPUTE THE PROBABILITY PLOT CORRELATION COEFFICIENT. ! COMPUTE LOCATION AND SCALE ESTIMATES ! FROM THE INTERCEPT AND SLOPE OF THE PROBABILITY PLOT. ! THEN WRITE THEM OUT. ! sum1 = 0.0_wp sum2 = 0.0_wp DO i = 1 , N sum1 = sum1 + Y(i) sum2 = sum2 + W(i) ENDDO ybar = sum1/an wbar = sum2/an sum1 = 0.0_wp sum2 = 0.0_wp sum3 = 0.0_wp DO i = 1 , N sum1 = sum1 + (Y(i)-ybar)*(Y(i)-ybar) sum2 = sum2 + (Y(i)-ybar)*(W(i)-wbar) sum3 = sum3 + (W(i)-wbar)*(W(i)-wbar) ENDDO cc = sum2/SQRT(sum3*sum1) yslope = sum2/sum3 yint = ybar - yslope*wbar WRITE (G_IO,99008) cc , yint , yslope 99008 FORMAT (' ','PROBABILITY PLOT CORRELATION COEFFICIENT = ',F8.5,& & 5X,'ESTIMATED INTERCEPT = ',E15.8,3X, & & 'ESTIMATED SLOPE = ',E15.8) ENDIF ! END SUBROUTINE EV2PLT !> !!##NAME !! ev2ppf(3f) - [M_datapac:PERCENT_POINT] compute the extreme value type 2 !! (Frechet) percent point function !! !!##SYNOPSIS !! !! SUBROUTINE EV2PPF(P,Gamma,Ppf) !! !! REAL(kind=wp),intent(in) :: P !! REAL(kind=wp),intent(in) :: Gamma !! REAL(kind=wp),intent(out) :: Ppf !! !!##DESCRIPTION !! EV2PPF(3f) computes the percent point function value for the extreme !! value type 2 distribution with REAL tail length parameter !! = GAMMA. !! !! The extreme value type 2 distribution used herein is defined for all !! non-negative X, and has the probability density function !! !! f(X) = GAMMA * (X**(-GAMMA-1)) * exp(-(X**(-GAMMA))) !! !! Note that the percent point function of a distribution is identically !! the same as the inverse cumulative distribution function of the !! distribution. !! !!##INPUT ARGUMENTS !! !! P The value (between 0.0 (exclusively) and 1.0 (exclusively)) !! at which the percent point function is to be evaluated. !! !! GAMMA The value of the tail length parameter. GAMMA should be !! positive. !! !!##OUTPUT ARGUMENTS !! !! PPF The percent point function value for the extreme value type !! 2 distribution with tail length parameter value = GAMMA. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_ev2ppf !! use M_datapac, only : ev2ppf !! implicit none !! ! call ev2ppf(x,y) !! end program demo_ev2ppf !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !! !!##REFERENCES !! * Johnson and Kotz, Continuous Univariate Distributions--1, 1970, !! pages 272-295. ! ORIGINAL VERSION--NOVEMBER 1975. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE EV2PPF(P,Gamma,Ppf) REAL(kind=wp),intent(in) :: P REAL(kind=wp),intent(in) :: Gamma REAL(kind=wp),intent(out) :: Ppf ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( P<=0.0_wp .OR. P>=1.0_wp ) THEN WRITE (G_IO,99001) 99001 FORMAT (' ', & &'***** FATAL ERROR--THE FIRST INPUT ARGUMENT TO THE EV2PPF SUBROU& &TINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL *****') WRITE (G_IO,99003) P Ppf = 0.0_wp RETURN ELSEIF ( Gamma<=0.0_wp ) THEN WRITE (G_IO,99002) 99002 FORMAT (' ', & &'***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE EV2PPF SUBROU& &TINE IS NON-POSITIVE *****') WRITE (G_IO,99003) Gamma Ppf = 0.0_wp RETURN ELSE ! !-----START POINT----------------------------------------------------- ! Ppf = (-LOG(P))**(-1.0_wp/Gamma) ENDIF 99003 FORMAT (' ','***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') ! END SUBROUTINE EV2PPF !> !!##NAME !! ev2ran(3f) - [M_datapac:RANDOM] generate extreme value type 2 !! (Frechet) random numbers !! !!##SYNOPSIS !! !! SUBROUTINE EV2RAN(N,Gamma,Iseed,X) !! !! INTEGER,intent(in) :: N !! INTEGER,intent(inout) :: Iseed !! REAL(kind=wp),intent(in) :: Gamma !! REAL(kind=wp),intent(out) :: X(:) !! !!##DESCRIPTION !! EV2RAN(3f) generates a random sample of size N from the extreme value !! type 2 distribution with tail length parameter value = GAMMA. !! !! The prototype extreme value type 2 distribution used herein is defined !! for all non-negative X, and has the probability density function !! !! f(X) = GAMMA * (X**(-GAMMA-1)) * exp(-(X**(-GAMMA))) !! !!##INPUT ARGUMENTS !! !! N The desired integer number of random numbers to be generated. !! !! ISEED An integer seed value. Should be set to a non-negative value !! to start a new sequence of values. Will be set to -1 on return !! to indicate the next call should continue the current random !! sequence walk. !! !! GAMMA The value of the tail length parameter. GAMMA should be !! positive. !! !!##OUTPUT ARGUMENTS !! !! X A vector (of dimension at least N) into which the generated !! random sample of size N from the extreme value type 2 !! distribution will be placed. !! !! !!##EXAMPLES !! !! Sample program: !! !! program demo_ev2ran !! use m_datapac, only : ev2ran, plott, label, plotxt, sort !! implicit none !! integer,parameter :: n=8000 !! real :: x(n) !! integer :: iseed !! real :: gamma !! call label('ev2ran') !! gamma=3.4 !! iseed=12345 !! call ev2ran(N,Gamma,Iseed,X) !! call plotxt(x,n) !! call sort(x,n,x) ! sort to show distribution !! call plotxt(x,n) !! end program demo_ev2ran !! !! Results: !! !! THE FOLLOWING IS A PLOT OF X(I) (VERTICALLY) VERSUS I (HORIZONTALLY !! I-----------I-----------I-----------I-----------I !! 0.1956361E+02 - X !! 0.1876934E+02 I !! 0.1797507E+02 I !! 0.1718080E+02 I !! 0.1638653E+02 I !! 0.1559226E+02 I X !! 0.1479799E+02 - !! 0.1400372E+02 I !! 0.1320944E+02 I !! 0.1241517E+02 I !! 0.1162090E+02 I X !! 0.1082663E+02 I X !! 0.1003236E+02 - !! 0.9238092E+01 I X X !! 0.8443822E+01 I !! 0.7649551E+01 I X X !! 0.6855281E+01 I X X X !! 0.6061010E+01 I X X X X X X X !! 0.5266740E+01 - X XXX XX X X X X X X X !! 0.4472469E+01 I XX XX X XX X XXX XX X XX X X X X X X !! 0.3678199E+01 I XX X XXX XXXXX XX XX XX XX XXXX XXXXXXX XXXXXX !! 0.2883928E+01 I XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX !! 0.2089659E+01 I XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX !! 0.1295387E+01 I XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX !! 0.5011185E+00 - XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX !! I-----------I-----------I-----------I-----------I !! 0.1000E+01 0.2001E+04 0.4000E+04 0.6000E+04 0.8000E+04 !! !! THE FOLLOWING IS A PLOT OF X(I) (VERTICALLY) VERSUS I (HORIZONTALLY !! I-----------I-----------I-----------I-----------I !! 0.1956361E+02 - X !! 0.1876934E+02 I !! 0.1797507E+02 I !! 0.1718080E+02 I !! 0.1638653E+02 I !! 0.1559226E+02 I X !! 0.1479799E+02 - !! 0.1400372E+02 I !! 0.1320944E+02 I !! 0.1241517E+02 I !! 0.1162090E+02 I X !! 0.1082663E+02 I X !! 0.1003236E+02 - !! 0.9238092E+01 I X !! 0.8443822E+01 I !! 0.7649551E+01 I X !! 0.6855281E+01 I X !! 0.6061010E+01 I X !! 0.5266740E+01 - X !! 0.4472469E+01 I X !! 0.3678199E+01 I XX !! 0.2883928E+01 I XX !! 0.2089659E+01 I XXXXXX !! 0.1295387E+01 I XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX !! 0.5011185E+00 - XXXXXXXXXXXX !! I-----------I-----------I-----------I-----------I !! 0.1000E+01 0.2001E+04 0.4000E+04 0.6000E+04 0.8000E+04 !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !! !!##REFERENCES !! * Tocher, The Art of Simulation, 1963, pages 14-15. !! * Hammersley and Handscomb, Monte Carlo Methods, 1964, page 36. !! * Johnson and Kotz, Continuous Univariate Distributions--1, 1970, !! pages 272-295. ! VERSION NUMBER--82/7 ! ORIGINAL VERSION--NOVEMBER 1975. ! UPDATED --DECEMBER 1981. ! UPDATED --MAY 1982. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE EV2RAN(N,Gamma,Iseed,X) INTEGER,intent(in) :: N INTEGER,intent(inout) :: Iseed REAL(kind=wp),intent(in) :: Gamma REAL(kind=wp),intent(out) :: X(:) INTEGER :: i !--------------------------------------------------------------------- ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( N<1 ) THEN WRITE (G_IO,99001) 99001 FORMAT (' ***** FATAL ERROR--The first input argument to EV2RAN(3f) is non-positive *****') WRITE (G_IO,99002) N 99002 FORMAT (' ***** The value of the argument is ',I0,' *****') RETURN ELSEIF ( Gamma<=0.0_wp ) THEN WRITE (G_IO,99003) 99003 FORMAT (' ***** FATAL ERROR--the second input argument to EV2RAN(3f) is non-positive *****') WRITE (G_IO,99004) Gamma 99004 FORMAT (' ***** THE value of the argument is ',E15.8, ' *****') RETURN ELSE ! ! GENERATE N UNIFORM (0,1) RANDOM NUMBERS; ! CALL UNIRAN(N,Iseed,X) ! ! GENERATE N EXTREME VALUE TYPE 2 DISTRIBUTION RANDOM NUMBERS ! USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD. ! DO i = 1 , N X(i) = (-LOG(X(i)))**(-1.0_wp/Gamma) ENDDO ENDIF END SUBROUTINE EV2RAN !> !!##NAME !! expcdf(3f) - [M_datapac:CUMULATIVE_DISTRIBUTION] compute the exponential cumulative !! distribution function !! !!##SYNOPSIS !! !! SUBROUTINE EXPCDF(X,Cdf) !! !! REAL(kind=wp),intent(in) :: X !! REAL(kind=wp),intent(out) :: Cdf !! !!##DESCRIPTION !! EXPCDF(3f) computes the cumulative distribution function value for !! the exponential distribution with mean = 1 and standard deviation = 1. !! !! This distribution is defined for all non-negative X, and has the !! probability density function !! !! f(x) = exp(-x) !! !!##INPUT ARGUMENTS !! !! X The value at which the cumulative distribution function is !! to be evaluated. X should be non-negative. !! !!##OUTPUT ARGUMENTS !! !! CDF The cumulative distribution function value. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_expcdf !! use M_datapac, only : expcdf !! implicit none !! ! call expcdf(x,y) !! end program demo_expcdf !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !! !!##REFERENCES !! * Johnson and Kotz, Continuous Univariate Distributions--1, 1970, !! pages 207-232. ! ORIGINAL VERSION--JUNE 1972. ! UPDATED --SEPTEMBER 1975. ! UPDATED --NOVEMBER 1975. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE EXPCDF(X,Cdf) REAL(kind=wp),intent(in) :: X REAL(kind=wp),intent(out) :: Cdf ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( X<0.0_wp ) THEN WRITE (G_IO,99001) 99001 FORMAT (' ***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT TO EXPCDF(3f) IS NEGATIVE *****') WRITE (G_IO,99002) X 99002 FORMAT (' ','***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') Cdf = 0.0_wp RETURN ELSE Cdf = 1.0_wp - EXP(-X) ENDIF ! END SUBROUTINE EXPCDF !> !!##NAME !! exppdf(3f) - [M_datapac:PROBABILITY_DENSITY] compute the exponential probability !! density function !! !!##SYNOPSIS !! !! SUBROUTINE EXPPDF(X,Pdf) !! !! REAL(kind=wp),intent(in) :: X !! REAL(kind=wp),intent(out) :: Pdf !! !!##DESCRIPTION !! EXPPDF(3f) computes the probability density function value for the !! exponential distribution with mean = 1 and standard deviation = 1. !! !! This distribution is defined for all non-negative X, and has the !! probability density function !! !! f(X) = exp(-X) !! !!##INPUT ARGUMENTS !! !! X The value at which the probability density !! function is to be evaluated. Values should be non-negative. !! !!##OUTPUT ARGUMENTS !! !! PDF The probability density function value. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_exppdf !! !@(#) line plotter graph of probability density function !! use M_datapac, only : exppdf, plott, label !! implicit none !! real,allocatable :: x(:), y(:) !! integer :: i !! call label('exppdf') !! x=[(real(i),i=0,100,1)] !! if(allocated(y))deallocate(y) !! allocate(y(size(x))) !! do i=1,size(x) !! call exppdf(x(i)/10.0,y(i)) !! enddo !! call plott(x,y,size(x)) !! end program demo_exppdf !! ``` !! Results: !! !! The following is a plot of Y(I) (vertically) versus X(I) (horizontally) !! I-----------I-----------I-----------I-----------I !! 0.1000000E+03 - X !! 0.9583334E+02 I X !! 0.9166666E+02 I X !! 0.8750000E+02 I X !! 0.8333334E+02 I X !! 0.7916667E+02 I X !! 0.7500000E+02 - X !! 0.7083334E+02 I X !! 0.6666667E+02 I X !! 0.6250000E+02 I X !! 0.5833334E+02 I X !! 0.5416667E+02 I X !! 0.5000000E+02 - X !! 0.4583334E+02 I XX !! 0.4166667E+02 I X !! 0.3750000E+02 I X !! 0.3333334E+02 I XX !! 0.2916667E+02 I XX !! 0.2500000E+02 - XXX !! 0.2083334E+02 I XXX !! 0.1666667E+02 I XXXX !! 0.1250000E+02 I XXX X !! 0.8333336E+01 I X X X X !! 0.4166672E+01 I X X X X !! 0.0000000E+00 - X X X !! I-----------I-----------I-----------I-----------I !! 0.4540E-04 0.2500E+00 0.5000E+00 0.7500E+00 0.1000E+01 !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !!##MAINTAINER !! John Urban, 2022.05.31 !!##LICENSE !! CC0-1.0 !!##REFERENCES !! * Johnson and Kotz, Continuous Univariate Distributions--1, 1970, !! pages 207-232. ! ORIGINAL VERSION--JUNE 1972. ! UPDATED --SEPTEMBER 1975. ! UPDATED --NOVEMBER 1975. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE EXPPDF(X,Pdf) REAL(kind=wp),intent(in) :: X REAL(kind=wp),intent(out) :: Pdf ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( X<0.0_wp ) THEN WRITE (G_IO,99001) 99001 FORMAT (' ***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT TO EXPPDF(3f) IS NEGATIVE *****') WRITE (G_IO,99002) X 99002 FORMAT (' ***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') Pdf = 0.0_wp RETURN ELSE Pdf = EXP(-X) ENDIF ! END SUBROUTINE EXPPDF !> !!##NAME !! expplt(3f) - [M_datapac:LINE_PLOT] generate a exponential probability !! plot !! !!##SYNOPSIS !! !! SUBROUTINE EXPPLT(X,N) !! !!##DESCRIPTION !! expplt(3f) generates an exponential probability plot. !! !! the prototype exponential distribution used herein has mean = 1 and !! standard deviation = 1. !! !! this distribution is defined for all non-negative x, and has the !! probability density function !! !! f(x)=exp(-x). !! !! as used herein, a probability plot for a distribution is a plot !! of the ordered observations versus the order statistic medians for !! that distribution. !! !! the exponential probability plot is useful in graphically testing !! the composite (that is, location and scale parameters need not be !! specified) hypothesis that the underlying distribution from which !! the data have been randomly drawn is the exponential distribution. !! !! if the hypothesis is true, the probability plot should be near-linear. !! !! a measure of such linearity is given by the calculated probability !! plot correlation coefficient. !! !!##OPTIONS !! X description of parameter !! Y description of parameter !! !!##EXAMPLES !! !! Sample program: !! !! program demo_expplt !! use M_datapac, only : expplt !! implicit none !! ! call expplt(x,y) !! end program demo_expplt !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the Statistical !! Engineering Division, National Institute of Standards and Technology. !!##MAINTAINER !! John Urban, 2022.05.31 !!##LICENSE !! CC0-1.0 !!##REFERENCES !! * FILLIBEN, 'TECHNIQUES FOR TAIL LENGTH ANALYSIS', PROCEEDINGS OF THE !! EIGHTEENTH CONFERENCE ON THE DESIGN OF EXPERIMENTS IN ARMY RESEARCH !! DEVELOPMENT AND TESTING (ABERDEEN, MARYLAND, OCTOBER, 1972), pages !! 425-450. !! * HAHN AND SHAPIRO, STATISTICAL METHODS IN ENGINEERING, 1967, pages 260-308. !! * JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE DISTRIBUTIONS--1, 1970, !! pages 207-232. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE EXPPLT(X,N) REAL(kind=wp) :: an , cc , hold , sum1 , sum2 , sum3 , tau , W , wbar , WS , X , Y , ybar , yint , yslope INTEGER i , iupper , N ! ! INPUT ARGUMENTS--X = THE VECTOR OF ! (UNSORTED OR SORTED) OBSERVATIONS. ! --N = THE INTEGER NUMBER OF OBSERVATIONS ! IN THE VECTOR X. ! OUTPUT--A ONE-page EXPONENTIAL PROBABILITY PLOT. ! PRINTING--YES. ! RESTRICTIONS--THE MAXIMUM ALLOWABLE VALUE OF N ! FOR THIS SUBROUTINE IS 7500. ! OTHER DATAPAC SUBROUTINES NEEDED--SORT, UNIMED, PLOT. ! FORTRAN LIBRARY SUBROUTINES NEEDED--SQRT, LOG. ! MODE OF INTERNAL OPERATIONS--. ! ORIGINAL VERSION--JUNE 1972. ! UPDATED --SEPTEMBER 1975. ! UPDATED --NOVEMBER 1975. ! UPDATED --FEBRUARY 1976. ! !--------------------------------------------------------------------- ! DIMENSION X(:) DIMENSION Y(7500) , W(7500) COMMON /BLOCK2_real32/ WS(15000) EQUIVALENCE (Y(1),WS(1)) EQUIVALENCE (W(1),WS(7501)) ! DATA tau/1.63473745_wp/ ! iupper = 7500 ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( N<1 .OR. N>iupper ) THEN WRITE (G_IO,99001) iupper 99001 FORMAT (' ', & &'***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE EXPPLT SUBROU& &TINE IS OUTSIDE THE ALLOWABLE (1,',I0,') INTERVAL *****') WRITE (G_IO,99002) N 99002 FORMAT (' ','***** THE VALUE OF THE ARGUMENT IS ',I0,' *****') RETURN ELSEIF ( N==1 ) THEN WRITE (G_IO,99003) 99003 FORMAT (' ', & &'***** NON-FATAL DIAGNOSTIC--THE SECOND INPUT ARGUMENT TO THE EXPP& < SUBROUTINE HAS THE VALUE 1 *****') RETURN ELSE hold = X(1) DO i = 2 , N IF ( X(i)/=hold ) GOTO 50 ENDDO WRITE (G_IO,99004) hold 99004 FORMAT (' ', & &'***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT (A VECTOR) & &TO THE EXPPLT SUBROUTINE HAS ALL ELEMENTS = ',E15.8,' *****') ! !-----START POINT----------------------------------------------------- ! 50 an = N ! ! SORT THE DATA ! CALL SORT(X,N,Y) ! ! GENERATE UNIFORM ORDER STATISTIC MEDIANS ! CALL UNIMED(N,W) ! ! COMPUTE EXPONENTIAL ORDER STATISTIC MEDIANS ! DO i = 1 , N W(i) = -LOG(1.0_wp-W(i)) ENDDO ! ! PLOT THE ORDERED OBSERVATIONS VERSUS ORDER STATISTICS MEDIANS. ! WRITE OUT THE TAIL LENGTH MEASURE OF THE DISTRIBUTION ! AND THE SAMPLE SIZE. ! CALL PLOT(Y,W,N) WRITE (G_IO,99005) tau , N ! 99005 FORMAT (' ','EXPONENTIAL PROBABILITY PLOT (TAU = ',E15.8,')', & & 51X,'THE SAMPLE SIZE N = ',I0) ! ! COMPUTE THE PROBABILITY PLOT CORRELATION COEFFICIENT. ! COMPUTE LOCATION AND SCALE ESTIMATES ! FROM THE INTERCEPT AND SLOPE OF THE PROBABILITY PLOT. ! THEN WRITE THEM OUT. ! sum1 = 0.0_wp sum2 = 0.0_wp DO i = 1 , N sum1 = sum1 + Y(i) sum2 = sum2 + W(i) ENDDO ybar = sum1/an wbar = sum2/an sum1 = 0.0_wp sum2 = 0.0_wp sum3 = 0.0_wp DO i = 1 , N sum1 = sum1 + (Y(i)-ybar)*(Y(i)-ybar) sum2 = sum2 + (Y(i)-ybar)*(W(i)-wbar) sum3 = sum3 + (W(i)-wbar)*(W(i)-wbar) ENDDO cc = sum2/SQRT(sum3*sum1) yslope = sum2/sum3 yint = ybar - yslope*wbar WRITE (G_IO,99006) cc , yint , yslope 99006 FORMAT (' ','PROBABILITY PLOT CORRELATION COEFFICIENT = ',F8.5,& & 5X,'ESTIMATED INTERCEPT = ',E15.8,3X, & & 'ESTIMATED SLOPE = ',E15.8) ENDIF ! END SUBROUTINE EXPPLT !> !!##NAME !! expppf(3f) - [M_datapac:PERCENT_POINT] compute the exponential percent !! point function !! !!##SYNOPSIS !! !! SUBROUTINE EXPPPF(P,Ppf) !! !! REAL(kind=wp),intent(in) :: P !! REAL(kind=wp),intent(out) :: Ppf !! !!##DESCRIPTION !! EXPPPF(3f) computes the percent point function value for the !! exponential distribution with mean = 1 and standard deviation = 1. !! !! This distribution is defined for all non-negative X, and has the !! probability density function !! !! f(x) = exp(-x) !! !! Note that the percent point function of a distribution is identically !! the same as the inverse cumulative distribution function of the !! distribution. !! !!##INPUT ARGUMENTS !! !! P The value at which the percent point function is to be !! evaluated. P Should be between 0.0 (inclusively) and 1.0 !! (exclusively). !! !!##OUTPUT ARGUMENTS !! !! PPF The percent point function value. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_expppf !! use M_datapac, only : expppf !! implicit none !! ! call expppf(x,y) !! end program demo_expppf !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !! !!##REFERENCES !! * Filliben, Simple and Robust Linear Estimation of the Location !! parameter of a Symmetric Distribution (Unpublished PH.D. Dissertation, !! Princeton University), 1969, pages 21-44, 229-231. !! * filliben, 'The Percent Point Function', (Unpublished Manuscript), !! 1970, pages 28-31. !! * Johnson and Kotz, Continuous Univariate Distributions--1, 1970, !! pages 207-232. ! ORIGINAL VERSION--JUNE 1972. ! UPDATED --SEPTEMBER 1975. ! UPDATED --NOVEMBER 1975. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE EXPPPF(P,Ppf) REAL(kind=wp),intent(in) :: P REAL(kind=wp),intent(out) :: Ppf ! !--------------------------------------------------------------------- ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( P<0.0_wp .OR. P>=1.0_wp ) THEN WRITE (G_IO,99001) 99001 FORMAT (& &' ***** FATAL ERROR--THE FIRST INPUT ARGUMENT TO THE EXPPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL *****') WRITE (G_IO,99002) P 99002 FORMAT (' ','***** THE VALUE OF THE ARGUMENT IS ',E15.8, ' *****') ELSE Ppf = -LOG(1.0_wp-P) ENDIF END SUBROUTINE EXPPPF !> !!##NAME !! expran(3f) - [M_datapac:RANDOM] generate exponential random numbers !! !!##SYNOPSIS !! !! SUBROUTINE EXPRAN(N,Iseed,X) !! !! INTEGER,intent(in) :: N !! INTEGER,intent(inout) :: Iseed !! REAL(kind=wp),intent(out) :: X(:) !! !!##DESCRIPTION !! EXPRAN(3f) generates a random sample of size N from the exponential !! distribution with mean = 1 and standard deviation = 1. !! !! This distribution is defined for all non-negative X, and has the !! probability density function !! !! f(X) = exp(-X) !! !!##INPUT ARGUMENTS !! !! N The desired integer number of random numbers to be generated. !! !! ISEED An integer seed value. Should be set to a non-negative value !! to start a new sequence of values. Will be set to -1 on return !! to indicate the next call should continue the current random !! sequence walk. !! !!##OUTPUT ARGUMENTS !! !! X A vector (of dimension at least N) into which the generated !! random sample of size N from the exponential distribution will !! be placed. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_expran !! use m_datapac, only : expran, plott, label, plotxt, sort !! implicit none !! integer,parameter :: n=300 !! real :: x(n) !! integer :: iseed !! call label('expran') !! iseed=12345 !! call expran(n,iseed,x) !! call plotxt(x,n) !! call sort(x,n,x) ! sort to show distribution !! call plotxt(x,n) !! end program demo_expran !! !! Results: !! !! !! THE FOLLOWING IS A PLOT OF X(I) (VERTICALLY) VERSUS I (HORIZONTALLY !! I-----------I-----------I-----------I-----------I !! 0.4256731E+01 - X X X !! 0.4079369E+01 I X !! 0.3902006E+01 I !! 0.3724644E+01 I X !! 0.3547282E+01 I X !! 0.3369920E+01 I X X !! 0.3192558E+01 - !! 0.3015196E+01 I !! 0.2837834E+01 I X !! 0.2660472E+01 I X X !! 0.2483110E+01 I X X X X X !! 0.2305748E+01 I X X X XX XX X X !! 0.2128386E+01 - X X XX X X X X X !! 0.1951024E+01 I X X X XX X X X !! 0.1773661E+01 I X X X X X !! 0.1596299E+01 I X X X X X XX X !! 0.1418937E+01 I X X X X X X X !! 0.1241575E+01 I X X XX X X X X XX X X !! 0.1064213E+01 - X X X X X XXXX XX XX X !! 0.8868508E+00 I XXX X X X X XX XX XX X XX XX !! 0.7094889E+00 I XXXXX XXX X X XX XX XXX X XX XXX X !! 0.5321269E+00 I X XXX XX X X X XXX XXX X XXX XXXX XX !! 0.3547647E+00 I XXXX XXX XX X XX XXX X X XXX X XXXXX XXXX XX !! 0.1774025E+00 I X XXX XXX XXX X XXXXX XX X X XX X X XXXX X !! 0.4065119E-04 - X XX X X XX XX XX XX X X X X XXX !! I-----------I-----------I-----------I-----------I !! 0.1000E+01 0.7575E+02 0.1505E+03 0.2252E+03 0.3000E+03 !! !! THE FOLLOWING IS A PLOT OF X(I) (VERTICALLY) VERSUS I (HORIZONTALLY !! I-----------I-----------I-----------I-----------I !! 0.4256731E+01 - X !! 0.4079369E+01 I X !! 0.3902006E+01 I !! 0.3724644E+01 I X !! 0.3547282E+01 I X !! 0.3369920E+01 I X !! 0.3192558E+01 - !! 0.3015196E+01 I !! 0.2837834E+01 I X !! 0.2660472E+01 I XX !! 0.2483110E+01 I XX !! 0.2305748E+01 I XX !! 0.2128386E+01 - XXX !! 0.1951024E+01 I XX !! 0.1773661E+01 I XX !! 0.1596299E+01 I XX !! 0.1418937E+01 I XXX !! 0.1241575E+01 I XXX !! 0.1064213E+01 - XXXX !! 0.8868508E+00 I XXXX !! 0.7094889E+00 I XXXXX !! 0.5321269E+00 I XXXXXXX !! 0.3547647E+00 I XXXXXXX !! 0.1774025E+00 I XXXXXXXX !! 0.4065119E-04 - XXXXX !! I-----------I-----------I-----------I-----------I !! 0.1000E+01 0.7575E+02 0.1505E+03 0.2252E+03 0.3000E+03 !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !! !!##REFERENCES !! * Tocher, The Art of Simulation, 1963, pages 14, 35-36. !! * Hammersley and Handscomb, Monte Carlo Methods, 1964, page 36. !! * Filliben, 'The Percent Point Function', (unpublished manuscript), !! 1970, pages 28-31. !! * Johnson and Kotz, Continuous Univariate Distributions--1, 1970, !! pages 207-232. !! * Hastings and Peacock, Statistical Distributions--A Handbook for !! Students and Practitioners, 1975, page 58. ! VERSION NUMBER--82/7 ! ORIGINAL VERSION--JUNE 1972. ! UPDATED --SEPTEMBER 1975. ! UPDATED --NOVEMBER 1975. ! UPDATED --JULY 1976. ! UPDATED --DECEMBER 1981. ! UPDATED --MAY 1982. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE EXPRAN(N,Iseed,X) INTEGER,intent(in) :: N INTEGER,intent(inout) :: Iseed REAL(kind=wp),intent(out) :: X(:) INTEGER :: i !--------------------------------------------------------------------- ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( N<1 ) THEN WRITE (G_IO,99001) 99001 FORMAT (' ***** FATAL ERROR--The first input argument to EXPRAN(3f) is non-positive *****') WRITE (G_IO,99002) N 99002 FORMAT (' ***** The value of the argument is ',I0,' *****') RETURN ELSE ! ! GENERATE N UNIFORM (0,1) RANDOM NUMBERS; ! CALL UNIRAN(N,Iseed,X) ! ! GENERATE N EXPONENTIAL RANDOM NUMBERS ! USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD. ! DO i = 1 , N X(i) = -LOG(X(i)) ENDDO ENDIF END SUBROUTINE EXPRAN !> !!##NAME !! expsf(3f) - [M_datapac:SPARSITY] compute the exponential sparsity function !! !!##SYNOPSIS !! !! SUBROUTINE EXPSF(P,Sf) !! !! REAL(kind=wp),intent(in) :: P !! REAL(kind=wp),intent(out) :: Sf !! !!##DESCRIPTION !! EXPSF(3f) computes the sparsity function value for the exponential !! distribution with mean = 1 and standard deviation = 1. !! !! This distribution is defined for all non-negative X, and has the !! probability density function !! !! f(X) = exp(-X) !! !! Note that the sparsity function of a distribution is the derivative !! of the percent point function, and also is the reciprocal of the !! probability density function (but in units of P rather than X). !! !! !!##INPUT ARGUMENTS !! !! P The value at which the sparsity function is to be evaluated. !! P should be between 0.0 (inclusively) and 1.0 (exclusively). !! !!##OUTPUT ARGUMENTS !! !! SF The sparsity function value. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_expsf !! use M_datapac, only : expsf !! implicit none !! ! call expsf(x,y) !! end program demo_expsf !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !! !!##REFERENCES !! * Filliben, Simple and Robust Linear Estimation of the Location !! Parameter of a Symmetric Distribution (Unpublished PH.D. Dissertation, !! Princeton University), 1969, pages 21-44, 229-231. !! * Filliben, 'The Percent Point Function', (Unpublished Manuscript), !! 1970, pages 28-31. !! * Johnson and Kotz, Continuous Univariate Distributions--1, 1970, !! pages 207-232. ! ORIGINAL VERSION--JUNE 1972. ! UPDATED --SEPTEMBER 1975. ! UPDATED --NOVEMBER 1975. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE EXPSF(P,Sf) REAL(kind=wp),intent(in) :: P REAL(kind=wp),intent(out) :: Sf !--------------------------------------------------------------------- ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( P<0.0_wp .OR. P>=1.0_wp ) THEN WRITE (G_IO,99001) 99001 FORMAT (' ***** FATAL ERROR--The first input argument to EXPSF(3f) is outside the allowable (0,1) interval *****') WRITE (G_IO,99002) P 99002 FORMAT (' ','***** The value of the argument is ',E15.8,' *****') RETURN ELSE Sf = 1.0_wp/(1.0_wp-P) ENDIF ! END SUBROUTINE EXPSF !> !!##NAME !! extrem(3f) - [M_datapac:STATISTICS] determine whether a type 1 or !! type 2 extreme value distribution better fits a given data set !! !!##SYNOPSIS !! !! SUBROUTINE EXTREM(X,N) !! !!##DESCRIPTION !! extrem(3f) performs an extreme value analysis on the data in the !! input vector x. !! !! this analysis consists of determining that particular extreme value !! type 1 or extreme value type 2 distribution which best fits the !! data set. !! !! the goodness of fit criterion is the maximum probability plot !! correlation coefficient criterion. !! !! after the best-fit distribution is determined, estimates are computed !! and printed out for the location and scale parameters. !! !! two probability plots are also printed out-- the best-fit type 2 !! probability plot (if the best fit was in fact a type 2), and the type !! 1 probability plot. !! !! predicted extremes for various return periods are also computed and !! printed out. !! !!##OPTIONS !! X description of parameter !! Y description of parameter !! !!##EXAMPLES !! !! Sample program: !! !! program demo_extrem !! use M_datapac, only : extrem !! implicit none !! ! call extrem(x,y) !! end program demo_extrem !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the Statistical !! Engineering Division, National Institute of Standards and Technology. !!##MAINTAINER !! John Urban, 2022.05.31 !!##LICENSE !! CC0-1.0 !!##REFERENCES !! * FILLIBEN (1972), 'TECHNIQUES FOR TAIL LENGTH ANALYSIS', PROCEEDINGS !! OF THE EIGHTEENTH CONFERENCE ON THE DESIGN OF EXPERIMENTS IN ARMY !! RESEARCH AND TESTING, pages 425-450. !! * FILLIBEN, 'THE PERCENT POINT FUNCTION', UNPUBLISHED MANUSCRIPT. !! * JOHNSON AND KOTZ (1970), CONTINUOUS UNIVARIATE DISTRIBUTIONS-1, !! 1970, pages 272-295. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE EXTREM(X,N) REAL(kind=wp) :: a, aindex, am, an, arg, cc, corr, corrmx, gamtab, h, hold, p, r, scrat, sum1, sum2, sum3, sy, t, w REAL(kind=wp) :: wbar, WS, X, xmax, xmin, Y, ybar, yi, yint, ys, yslope, Z INTEGER :: i, idis, idismx, iupper, j, jskip, k, N, numam, numdis, numdm1 ! ! INPUT ARGUMENTS--X = THE VECTOR OF ! (UNSORTED OR SORTED) OBSERVATIONS. ! N = THE INTEGER NUMBER OF OBSERVATIONS ! IN THE VECTOR X. ! OUTPUT--6 pages OF AUTOMATIC PRINTOUT. ! PRINTING--YES. ! RESTRICTIONS--THE MAXIMUM ALLOWABLE VALUE OF N ! FOR THIS SUBROUTINE IS 7500. ! OTHER DATAPAC SUBROUTINES NEEDED--SORT, UNIMED, EV1PLT, ! EV2PLT, PLOT. ! FORTRAN LIBRARY SUBROUTINES NEEDED--SQRT, LOG. ! MODE OF INTERNAL OPERATIONS--. ! ORIGINAL VERSION--JUNE 1972. ! UPDATED --DECEMBER 1974. ! UPDATED --NOVEMBER 1975. ! UPDATED --MAY 1976. ! !--------------------------------------------------------------------- ! CHARACTER(len=4) :: blank , alpham , alphaa , alphax CHARACTER(len=4) :: alphai , alphan , alphaf , alphat , alphay CHARACTER(len=4) :: alphag , equal ! CHARACTER(len=4) :: iflag1 CHARACTER(len=4) :: iflag2 CHARACTER(len=4) :: iflag3 ! DIMENSION w(3000) DIMENSION X(:) DIMENSION Y(7500) , Z(7500) DIMENSION gamtab(50) , corr(50) DIMENSION yi(50) , ys(50) , t(50) DIMENSION iflag1(50) , iflag2(50) , iflag3(50) DIMENSION am(50) DIMENSION scrat(50) ! DIMENSION aindex(50) DIMENSION h(60,2) COMMON /BLOCK2_real32/ WS(15000) EQUIVALENCE (Y(1),WS(1)) EQUIVALENCE (Z(1),WS(7501)) DATA blank , alpham , alphaa , alphax/' ' , 'M' , 'A' , 'X'/ DATA alphai , alphan , alphaf , alphat , alphay/'I' , 'N' , 'F' , & & 'T' , 'Y'/ DATA alphag , equal/'G' , '='/ DATA gamtab(1) , gamtab(2) , gamtab(3) , gamtab(4) , gamtab(5) , & & gamtab(6) , gamtab(7) , gamtab(8) , gamtab(9) , gamtab(10) , & & gamtab(11) , gamtab(12) , gamtab(13) , gamtab(14) , & & gamtab(15) , gamtab(16) , gamtab(17) , gamtab(18) , & & gamtab(19) , gamtab(20) , gamtab(21) , gamtab(22) , & & gamtab(23) , gamtab(24) , gamtab(25)/1.0_wp , 2.0_wp , 3.0_wp , 4.0_wp , 5.0_wp ,& & 6.0_wp , 7.0_wp , 8.0_wp , 9.0_wp , 10.0_wp , 11.0_wp , 12.0_wp , 13.0_wp , 14.0_wp , 15.0_wp , 16.0_wp ,& & 17.0_wp , 18.0_wp , 19.0_wp , 20.0_wp , 21.0_wp , 22.0_wp , 23.0_wp , 24.0_wp , 25.0_wp/ DATA gamtab(26) , gamtab(27) , gamtab(28) , gamtab(29) , & & gamtab(30) , gamtab(31) , gamtab(32) , gamtab(33) , & & gamtab(34) , gamtab(35) , gamtab(36) , gamtab(37) , & & gamtab(38) , gamtab(39) , gamtab(40) , gamtab(41) , & & gamtab(42)/30.0_wp , 35.0_wp , 40.0_wp , 45.0_wp , 50.0_wp , 60.0_wp , 70.0_wp , 80.0_wp , & & 90.0_wp , 100.0_wp , 150.0_wp , 200.0_wp , 250.0_wp , 350.0_wp , 500.0_wp , 750.0_wp , 1000.0_wp/ !CCCC DATA C(1),C(2),C(3),C(4),C(5),C(6),C(7),C(8),C(9),C(10) !CCCC1/60.0_wp,75.0_wp,100.0_wp,150.0_wp,250.0_wp,500.0_wp,1000.0_wp,10000.0_wp,100000.0_wp,1000000.0_wp/ !CCCC DATA P0(1),P0(2),P0(3),P0(4),P0(5),P0(6),P0(7),P0(8),P0(9),P0(10) !CCCC1/0.0_wp,0.5_wp,0.75_wp,0.9_wp,0.95_wp,0.975_wp,0.99_wp,0.999_wp,0.9999_wp,0.99999_wp/ DATA t(1) , t(2) , t(3) , t(4) , t(5) , t(6) , t(7) , t(8) , & & t(9) , t(10) , t(11) , t(12) , t(13) , t(14) , t(15) , & & t(16) , t(17) , t(18) , t(19) , t(20) , t(21) , t(22) , & & t(23) , t(24) , t(25)/10.18011_wp , 3.39672_wp , 2.47043_wp , & & 2.14609_wp , 1.98712_wp , 1.89429_wp , 1.83394_wp , 1.79175_wp , 1.76069_wp , & & 1.73691_wp , 1.71814_wp , 1.70297_wp , 1.69045_wp , 1.67996_wp , 1.67103_wp , & & 1.66335_wp , 1.65667_wp , 1.65082_wp , 1.64564_wp , 1.64102_wp , 1.63689_wp , & & 1.63316_wp , 1.62979_wp , 1.62672_wp , 1.62391_wp/ DATA t(26) , t(27) , t(28) , t(29) , t(30) , t(31) , t(32) , & & t(33) , t(34) , t(35) , t(36) , t(37) , t(38) , t(39) , & & t(40) , t(41) , t(42) , t(43)/1.61287 , 1.60516 , 1.59947 , & & 1.59510_wp , 1.59164_wp , 1.58651_wp , 1.58289_wp , 1.58019_wp , 1.57811_wp , & & 1.57645_wp , 1.57152_wp , 1.56908_wp , 1.56763_wp , 1.56666_wp , 1.56546_wp , & & 1.56377_wp , 1.56330_wp , 1.56187_wp/ DATA aindex(1) , aindex(2) , aindex(3) , aindex(4) , aindex(5) , & & aindex(6) , aindex(7) , aindex(8) , aindex(9) , aindex(10) , & & aindex(11) , aindex(12) , aindex(13) , aindex(14) , & & aindex(15) , aindex(16) , aindex(17) , aindex(18) , & & aindex(19) , aindex(20) , aindex(21) , aindex(22) , & & aindex(23) , aindex(24) , aindex(25)/1.0_wp , 2.0_wp , 3.0_wp , 4.0_wp , 5.0_wp ,& & 6.0_wp , 7.0_wp , 8.0_wp , 9.0_wp , 10.0_wp , 11.0_wp , 12.0_wp , 13.0_wp , 14.0_wp , 15.0_wp , 16.0_wp ,& & 17.0_wp , 18.0_wp , 19.0_wp , 20.0_wp , 21.0_wp , 22.0_wp , 23.0_wp , 24.0_wp , 25.0_wp/ DATA aindex(26) , aindex(27) , aindex(28) , aindex(29) , & & aindex(30) , aindex(31) , aindex(32) , aindex(33) , & & aindex(34) , aindex(35) , aindex(36) , aindex(37) , & & aindex(38) , aindex(39) , aindex(40) , aindex(41) , & & aindex(42) , aindex(43) , aindex(44) , aindex(45) , & & aindex(46) , aindex(47) , aindex(48) , aindex(49) , & & aindex(50)/26.0_wp , 27.0_wp , 28.0_wp , 29.0_wp , 30.0_wp , 31.0_wp , 32.0_wp , 33.0_wp , & & 34.0_wp , 35.0_wp , 36.0_wp , 37.0_wp , 38.0_wp , 39.0_wp , 40.0_wp , 41.0_wp , 42.0_wp , 43.0_wp , & & 44.0_wp , 45.0_wp , 46.0_wp , 47.0_wp , 48.0_wp , 49.0_wp , 50.0_wp/ ! iupper = 7500 numdis = 43 ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( N<1 .OR. N>iupper ) THEN WRITE (G_IO,99001) iupper 99001 FORMAT (' ', & &'***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE EXTREM SUBROU& &TINE IS OUTSIDE THE ALLOWABLE (1,',I0,') INTERVAL *****') WRITE (G_IO,99002) N 99002 FORMAT (' ','***** THE VALUE OF THE ARGUMENT IS ',I0,' *****') RETURN ELSE IF ( N==1 ) THEN WRITE (G_IO,99003) 99003 FORMAT (' ', & &'***** NON-FATAL DIAGNOSTIC--THE SECOND INPUT ARGUMENT TO THE EXTR& &EM SUBROUTINE HAS THE VALUE 1 *****') RETURN ELSE hold = X(1) DO i = 2 , N IF ( X(i)/=hold ) GOTO 50 ENDDO WRITE (G_IO,99004) hold 99004 FORMAT (' ', & &'***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT (A VECTOR) & &TO THE EXTREM SUBROUTINE HAS ALL ELEMENTS = ',E15.8,' *****') RETURN ENDIF ! !-----START POINT----------------------------------------------------- ! 50 an = N ! ! COMPUTE THE SAMPLE MINIMUM AND SAMPLE MAXIMUM ! xmin = X(1) xmax = X(1) DO i = 2 , N IF ( X(i)<xmin ) xmin = X(i) IF ( X(i)>xmax ) xmax = X(i) ENDDO ! ! COMPUTE THE PROB PLOT CORRELATION COEFFICIENTS FOR THE VARIOUS VALUES ! OF GAMMA ! CALL SORT(X,N,Y) CALL UNIMED(N,Z) ! DO idis = 1 , numdis IF ( idis==numdis ) THEN DO i = 1 , N w(i) = -LOG(LOG(1.0_wp/Z(i))) ENDDO ELSE a = gamtab(idis) DO i = 1 , N w(i) = (-LOG(Z(i)))**(-1.0_wp/a) ENDDO ENDIF ! sum1 = 0.0_wp sum2 = 0.0_wp DO i = 1 , N sum1 = sum1 + Y(i) sum2 = sum2 + w(i) ENDDO ybar = sum1/an wbar = sum2/an sum1 = 0.0_wp sum2 = 0.0_wp sum3 = 0.0_wp DO i = 1 , N sum2 = sum2 + (Y(i)-ybar)*(w(i)-wbar) sum1 = sum1 + (Y(i)-ybar)*(Y(i)-ybar) sum3 = sum3 + (w(i)-wbar)*(w(i)-wbar) ENDDO sy = SQRT(sum1/(an-1.0_wp)) cc = sum2/SQRT(sum3*sum1) yslope = sum2/sum3 yint = ybar - yslope*wbar corr(idis) = cc yi(idis) = yint ys(idis) = yslope ENDDO ! ! DETERMINE THAT DISTRIBUTION WITH THE MAX PROB PLOT CORR COEFFICIENT ! idismx = 1 corrmx = corr(1) DO idis = 1 , numdis IF ( corr(idis)>corrmx ) idismx = idis IF ( corr(idis)>corrmx ) corrmx = corr(idis) ENDDO DO idis = 1 , numdis iflag1(idis) = blank iflag2(idis) = blank iflag3(idis) = blank IF ( idis==idismx ) THEN iflag1(idis) = alpham iflag2(idis) = alphaa iflag3(idis) = alphax ENDIF ENDDO ! ! WRITE OUT THE TABLE OF PROB PLOT CORR COEFFICIENTS FOR VARIOUS GAMMA ! WRITE (G_IO,99028) WRITE (G_IO,99005) 99005 FORMAT (' ',40X,'EXTREME VALUE ANALYSIS') WRITE (G_IO,99029) WRITE (G_IO,99006) N 99006 FORMAT (' ',37X,'THE SAMPLE SIZE N = ',I0) WRITE (G_IO,99007) ybar 99007 FORMAT (' ',34X,'THE SAMPLE MEAN = ',F14.7) WRITE (G_IO,99008) sy 99008 FORMAT (' ',28X,'THE SAMPLE STANDARD DEVIATION = ',F14.7) WRITE (G_IO,99009) xmin 99009 FORMAT (' ',32X,'THE SAMPLE MINIMUM = ',F14.7) WRITE (G_IO,99010) xmax 99010 FORMAT (' ',32X,'THE SAMPLE MAXIMUM = ',F14.7) WRITE (G_IO,99029) WRITE (G_IO,99011) 99011 FORMAT (' ', & &' EXTREME VALUE PROBABILITY PLOT LOCATION SCA& &LE TAIL LENGTH') WRITE (G_IO,99012) 99012 FORMAT (' ', & &' TYPE 2 TAIL LENGTH CORRELATION ESTIMATE ESTI& &MATE MEASURE') WRITE (G_IO,99013) 99013 FORMAT (' ',' PARAMETER (GAMMA) COEFFICIENT') WRITE (G_IO,99029) ! numdm1 = numdis - 1 IF ( numdm1>=1 ) THEN DO i = 1 , numdm1 WRITE (G_IO,99014) gamtab(i) , corr(i) , iflag1(i) , & & iflag2(i) , iflag3(i) , yi(i) , ys(i) ,& & t(i) 99014 FORMAT (' ',3X,F10.2,13X,F8.5,1X,3A1,2X,F14.7,2X,F14.7, & & 3X,F10.5) ENDDO ENDIF i = numdis WRITE (G_IO,99015) alphai , alphan , alphaf , alphai , alphan , & & alphai , alphat , alphay , corr(i) , & & iflag1(i) , iflag2(i) , iflag3(i) , yi(i) , & & ys(i) , t(i) 99015 FORMAT (' ',5X,8A1,13X,F8.5,1X,3A1,2X,F14.7,2X,F14.7,3X,F10.5) ! ! PLOT THE PROB PLOT CORR COEFFICIENT VERSUS GAMMA VALUE INDEX ! CALL PLOT(corr,aindex,numdis) WRITE (G_IO,99016) alphag , alphaa , alpham , alpham , alphaa , & & equal , gamtab(1) , gamtab(12) , gamtab(23) ,& & gamtab(34) , alphai , alphan , alphaf , & & alphai , alphan , alphai , alphat , alphay 99016 FORMAT (' ',12X,5A1,1X,A1,F14.7,11X,F14.7,11X,F14.7,11X,F14.7, & & 15X,8A1) WRITE (G_IO,99029) WRITE (G_IO,99017) 99017 FORMAT (' ', & &'THE ABOVE IS A PLOT OF THE 46 PROBABILITY PLOT CORRELATION COEFFI& &CIENTS (FROM THE PREVIOUS page)') WRITE (G_IO,99018) 99018 FORMAT (' ',16X,'VERSUS THE 46 EXTREME VALUE DISTRIBUTIONS') ! ! IF THE OPTIMAL GAMMA IS FINITE, PLOT OUT THE EXTREME VALUE ! TYPE 2 PROBABILITY PLOT FOR THE OPTIMAL VALUE ! OF GAMMA. ! IF ( idismx<numdis ) CALL EV2PLT(X,N,gamtab(idismx)) ! ! PLOT OUT AN EXTREME VALUE TYPE 1 PROBABILITY PLOT ! CALL EV1PLT(X,N) ! ! FORM THE VARIOUS RETURN PERIOD VALUES ! k = 0 DO i = 1 , 4 DO j = 1 , 9 k = k + 1 am(k) = j*(10**(i-1)) ENDDO ENDDO k = k + 1 am(k) = 10000.0_wp k = k + 1 am(k) = 50000.0_wp k = k + 1 am(k) = 100000.0_wp k = k + 1 am(k) = 500000.0_wp k = k + 1 am(k) = 1000000.0_wp k = k + 1 am(k) = N numam = k CALL SORT(am,numam,scrat) DO i = 1 , numam am(i) = scrat(i) ENDDO ! ! IF THE OPTIMAL GAMMA IS FINITE, COMPUTE THE ! PREDICTED EXTREME (= F(1-(1/M)) FOR VARIOUS RETURN PERIODS M ! FOR THE OPTIMAL EXTREME VALUE TYPE 2 DISTRIBUTION. ! IF ( idismx/=numdis ) THEN a = gamtab(idismx) yint = yi(idismx) yslope = ys(idismx) DO i = 2 , numam r = 1.0_wp/am(i) p = 1.0_wp - r arg = -LOG(p) IF ( arg>0.0_wp ) h(i,1) = yint + yslope*(arg**(-1.0_wp/a)) ENDDO ENDIF ! ! COMPUTE THE PREDICTED EXTREME (= F(1-(1/M)) FOR VARIOUS RETURN ! PERIODS M FOR THE EXTREME VALUE TYPE 1 DISTRIBUTION. ! yint = yi(numdis) yslope = ys(numdis) DO i = 2 , numam r = 1.0_wp/am(i) p = 1.0_wp - r arg = -LOG(p) IF ( arg>0.0_wp ) h(i,2) = yint + yslope*(-LOG(arg)) ENDDO ! ! WRITE OUT THE page WITH THE RETURN PERIODS AND THE PREDICTED EXTREMES ! FOR THE 2 DISTRIBUTIONS--OPTIMAL EXTREME VALUE TYPE 2, AND EXTREME ! VALUE TYPE 1. ! WRITE (G_IO,99028) IF ( idismx==numdis ) THEN ! WRITE (G_IO,99019) 99019 FORMAT (' ',' RETURN PERIOD PREDICTED EXTREME WIND') WRITE (G_IO,99020) 99020 FORMAT (' ',' (IN YEARS) BASED ON') WRITE (G_IO,99021) 99021 FORMAT (' ',' EXTREME VALUE TYPE 1') WRITE (G_IO,99022) 99022 FORMAT (' ',' DISTRIBUTION') WRITE (G_IO,99029) DO i = 2 , numam WRITE (G_IO,99030) am(i) , h(i,2) j = i - 1 jskip = j - 5*(j/5) IF ( jskip==0 ) WRITE (G_IO,99029) ENDDO GOTO 99999 ENDIF ENDIF WRITE (G_IO,99023) 99023 FORMAT (' ',' RETURN PERIOD PREDICTED EXTREME WIND', & & ' PREDICTED EXTREME WIND') WRITE (G_IO,99024) 99024 FORMAT (' ',' (IN YEARS) BASED ON OPTIMAL ', & & ' BASED ON') WRITE (G_IO,99025) 99025 FORMAT (' ',' EXTREME VALUE TYPE 2', & & ' EXTREME VALUE TYPE 1') WRITE (G_IO,99026) 99026 FORMAT (' ',' DISTRIBUTION ', & & ' DISTRIBUTION') WRITE (G_IO,99027) gamtab(idismx) 99027 FORMAT (' ',' (GAMMA = ',F12.5,')') WRITE (G_IO,99029) DO i = 2 , numam WRITE (G_IO,99030) am(i) , h(i,1) , h(i,2) j = i - 1 jskip = j - 5*(j/5) IF ( jskip==0 ) WRITE (G_IO,99029) ENDDO RETURN ! 99028 FORMAT ('1') 99029 FORMAT (' ') 99030 FORMAT (' ',2X,F9.1,13X,F10.2,17X,F10.2) ! 99999 END SUBROUTINE EXTREM !> !!##NAME !! fcdf(3f) - [M_datapac:CUMULATIVE_DISTRIBUTION] compute the F cumulative distribution !! function !! !!##SYNOPSIS !! !! SUBROUTINE FCDF(X,Nu1,Nu2,Cdf) !! !! REAL(kind=wp) :: X !! INTEGER :: Nu1 !! INTEGER :: Nu2 !! REAL(kind=wp) :: Cdf !! !!##DESCRIPTION !! FCDF(3f) computes the cumulative distribution function value for the F !! distribution with integer degrees of freedom parameters = NU1 and NU2. !! !! This distribution is defined for all non-negative X. The probability !! density function is given in the references below. !! !!##INPUT ARGUMENTS !! X The value at which the cumulative distribution function is to !! be evaluated. X should be non-negative. !! !! NU1 The integer degrees of freedom for the numerator of the F !! ratio. NU1 should be positive. !! !! NU2 The integer degrees of freedom for the denominator of the F !! ratio. NU2 should be positive. !! !!##OUTPUT ARGUMENTS !! !! CDF The cumulative distribution function value for the F distribution !! !!##EXAMPLES !! !! Sample program: !! !! program demo_fcdf !! use M_datapac, only : fcdf !! implicit none !! ! call fcdf(x,y) !! end program demo_fcdf !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !! !!##REFERENCES !! * National Bureau of Standards Applied Mathematics Series 55, 1964, !! pages 946-947, Formulae 26.6.4, 26.6.5, 26.6.8, and 26.6.15. !! * Johnson and Kotz, Continuous Univariate Distributions--2, 1970, !! page 83, Formula 20, and page 84, Third formula. !! * Paulson, An Approximate Normalization of the Analysis of Variance !! Distribution, Annals of Mathematical Statistics, 1942, Number 13, !! pages 233-135. !! * Scheffe and Tukey, A Formula for Sample Sizes for Population Tolerance !! Limits, 1944, Number 15, page 217. ! ORIGINAL VERSION--AUGUST 1972. ! UPDATED --SEPTEMBER 1975. ! UPDATED --NOVEMBER 1975. ! UPDATED --OCTOBER 1976. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE FCDF(X,Nu1,Nu2,Cdf) REAL(kind=wp) :: X INTEGER :: Nu1 INTEGER :: Nu2 REAL(kind=wp) :: Cdf REAL(kind=wp) :: amean , ccdf , gcdf , sd , t1 , t2 , t3 , u , zratio INTEGER :: i , ibran , ievodd , iflag1 , iflag2 , imax , imin , m , n , nucut1 , nucut2 DOUBLE PRECISION :: dx , pi , anu1 , anu2 , z , sum , term , ai , coef1 , coef2 , arg DOUBLE PRECISION :: coef DOUBLE PRECISION :: theta , sinth , costh , a , b DOUBLE PRECISION :: DSQRT , DATAN DOUBLE PRECISION :: dfact1 , dfact2 , dnum , dden DOUBLE PRECISION :: dpow1 , dpow2 DOUBLE PRECISION :: dnu1 , dnu2 DOUBLE PRECISION :: term1 , term2 , term3 DATA pi/3.14159265358979D0/ DATA dpow1 , dpow2/0.33333333333333D0 , 0.66666666666667D0/ DATA nucut1 , nucut2/100 , 1000/ ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( Nu1<=0 ) THEN WRITE (G_IO,99001) 99001 FORMAT (' ***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO FCDF(3f) IS NON-POSITIVE *****') WRITE (G_IO,99006) Nu1 Cdf = 0.0_wp RETURN ELSE IF ( Nu2<=0 ) THEN WRITE (G_IO,99002) 99002 FORMAT (' ***** FATAL ERROR--THE THIRD INPUT ARGUMENT TO FCDF(3f) IS NON-POSITIVE *****') WRITE (G_IO,99006) Nu2 Cdf = 0.0_wp RETURN ELSE IF ( X<0.0 ) THEN WRITE (G_IO,99003) 99003 FORMAT (' ***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT TO FCDF(3f) IS NEGATIVE *****') WRITE (G_IO,99004) X 99004 FORMAT (' ','***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') Cdf = 0.0_wp RETURN ELSE ! !-----START POINT----------------------------------------------------- ! dx = X m = Nu1 n = Nu2 anu1 = Nu1 anu2 = Nu2 dnu1 = Nu1 dnu2 = Nu2 ! ! IF X IS NON-POSITIVE, SET CDF = 0.0 AND RETURN. ! IF NU2 IS 5 THROUGH 9 AND X IS MORE THAN 3000 ! STANDARD DEVIATIONS BELOW THE MEAN, ! SET CDF = 0.0 AND RETURN. ! IF NU2 IS 10 OR LARGER AND X IS MORE THAN 150 ! STANDARD DEVIATIONS BELOW THE MEAN, ! SET CDF = 0.0 AND RETURN. ! IF NU2 IS 5 THROUGH 9 AND X IS MORE THAN 3000 ! STANDARD DEVIATIONS ABOVE THE MEAN, ! SET CDF = 1.0 AND RETURN. ! IF NU2 IS 10 OR LARGER AND X IS MORE THAN 150 ! STANDARD DEVIATIONS ABOVE THE MEAN, ! SET CDF = 1.0 AND RETURN. ! IF ( X>0.0_wp ) THEN IF ( Nu2<=4 ) GOTO 50 t1 = 2.0_wp/anu1 t2 = anu2/(anu2-2.0_wp) t3 = (anu1+anu2-2.0_wp)/(anu2-4.0_wp) amean = t2 sd = SQRT(t1*t2*t2*t3) zratio = (X-amean)/sd IF ( Nu2>=10 .OR. zratio>=-3000.0_wp ) THEN IF ( Nu2<10 .OR. zratio>=-150.0_wp ) THEN IF ( Nu2<10 .AND. zratio>3000.0_wp ) GOTO 20 IF ( Nu2<10 .OR. zratio<=150.0_wp ) GOTO 50 GOTO 20 ENDIF ENDIF ENDIF Cdf = 0.0_wp RETURN ENDIF 20 Cdf = 1.0_wp RETURN ENDIF ! ! DISTINGUISH BETWEEN 6 SEPARATE REGIONS ! OF THE (NU1,NU2) SPACE. ! BRANCH TO THE PROPER COMPUTATIONAL METHOD ! DEPENDING ON THE REGION. ! NUCUT1 HAS THE VALUE 100. ! NUCUT2 HAS THE VALUE 1000. ! 50 IF ( Nu1<nucut2 .AND. Nu2<nucut2 ) THEN ! ! TREAT THE CASE WHEN NU1 AND NU2 ! ARE BOTH SMALL OR MODERATE ! (THAT IS, BOTH ARE SMALLER THAN 1000). ! METHOD UTILIZED--EXACT FINITE SUM ! (SEE AMS 55, page 946, FORMULAE 26.6.4, 26.6.5, ! AND 26.6.8). ! z = anu2/(anu2+anu1*dx) iflag1 = Nu1 - 2*(Nu1/2) iflag2 = Nu2 - 2*(Nu2/2) IF ( iflag1==0 ) THEN ! ! DO THE NU1 EVEN AND NU2 EVEN OR ODD CASE ! sum = 0.0D0 term = 1.0D0 imax = (m-2)/2 IF ( imax>0 ) THEN DO i = 1 , imax ai = i coef1 = 2.0D0*(ai-1.0D0) coef2 = 2.0D0*ai term = term*((anu2+coef1)/coef2)*(1.0D0-z) sum = sum + term ENDDO ENDIF ! sum = sum + 1.0D0 sum = (z**(anu2/2.0D0))*sum Cdf = 1.0D0 - sum RETURN ELSEIF ( iflag2==0 ) THEN ! ! DO THE NU1 ODD AND NU2 EVEN CASE ! sum = 0.0D0 term = 1.0D0 imax = (n-2)/2 IF ( imax>0 ) THEN DO i = 1 , imax ai = i coef1 = 2.0D0*(ai-1.0D0) coef2 = 2.0D0*ai term = term*((anu1+coef1)/coef2)*z sum = sum + term ENDDO ENDIF ! sum = sum + 1.0D0 Cdf = ((1.0D0-z)**(anu1/2.0D0))*sum RETURN ELSE ! ! DO THE NU1 ODD AND NU2 ODD CASE ! sum = 0.0D0 term = 1.0D0 arg = DSQRT((anu1/anu2)*dx) theta = DATAN(arg) sinth = arg/DSQRT(1.0D0+arg*arg) costh = 1.0D0/DSQRT(1.0D0+arg*arg) IF ( n/=1 ) THEN IF ( n/=3 ) THEN imax = n - 2 DO i = 3 , imax , 2 ai = i coef1 = ai - 1.0D0 coef2 = ai term = term*(coef1/coef2)*(costh*costh) sum = sum + term ENDDO ENDIF ! sum = sum + 1.0D0 sum = sum*sinth*costh ENDIF ! a = (2.0D0/pi)*(theta+sum) sum = 0.0D0 term = 1.0D0 IF ( m==1 ) b = 0.0D0 IF ( m/=1 ) THEN IF ( m/=3 ) THEN imax = m - 3 DO i = 1 , imax , 2 ai = i coef1 = ai coef2 = ai + 2.0D0 term = term*((anu2+coef1)/coef2)*(sinth*sinth) sum = sum + term ENDDO ENDIF ! sum = sum + 1.0D0 sum = sum*sinth*(costh**n) coef = 1.0D0 ievodd = n - 2*(n/2) imin = 3 IF ( ievodd==0 ) imin = 2 IF ( imin<=n ) THEN DO i = imin , n , 2 ai = i coef = ((ai-1.0D0)/ai)*coef ENDDO ENDIF ! coef = coef*anu2 IF ( ievodd/=0 ) coef = coef*(2.0D0/pi) ! b = coef*sum ENDIF ! Cdf = a - b RETURN ENDIF ELSEIF ( Nu1<nucut2 .OR. Nu2<nucut2 ) THEN IF ( Nu1<nucut1 .AND. Nu2>=nucut2 ) THEN ! ! TREAT THE CASE WHEN NU1 IS SMALL ! AND NU2 IS LARGE ! (THAT IS, WHEN NU1 IS SMALLER THAN 100, ! AND NU2 IS EQUAL TO OR LARGER THAN 1000). ! METHOD UTILIZED--SHEFFE-TUKEY APPROXIMATION ! (SEE JOHNSON AND KOTZ, VOLUME 2, page 84, THIRD FORMULA). ! term1 = dnu1 term2 = (dnu1/dnu2)*(0.5D0*dnu1-1.0D0) term3 = -(dnu1/dnu2)*0.5D0 u = (term1+term2)/((1.0D0/dx)-term3) CALL CHSCDF(u,Nu1,ccdf) Cdf = ccdf RETURN ELSEIF ( Nu1<nucut1 .OR. Nu2<nucut2 ) THEN IF ( Nu1>=nucut2 .AND. Nu2<nucut1 ) THEN ! ! TREAT THE CASE WHEN NU2 IS SMALL ! AND NU1 IS LARGE ! (THAT IS, WHEN NU2 IS SMALLER THAN 100, ! AND NU1 IS EQUAL TO OR LARGER THAN 1000). ! METHOD UTILIZED--SHEFFE-TUKEY APPROXIMATION ! (SEE JOHNSON AND KOTZ, VOLUME 2, page 84, THIRD FORMULA). ! term1 = dnu2 term2 = (dnu2/dnu1)*(0.5D0*dnu2-1.0D0) term3 = -(dnu2/dnu1)*0.5D0 u = (term1+term2)/(dx-term3) CALL CHSCDF(u,Nu2,ccdf) Cdf = 1.0_wp - ccdf GOTO 99999 ELSEIF ( Nu1<nucut2 .OR. Nu2<nucut1 ) THEN ibran = 5 WRITE (G_IO,99005) ibran 99005 FORMAT (' ', & & '*****INTERNAL ERROR IN FCDF SUBROUTINE--', & & 'IMPOSSIBLE BRANCH CONDITION AT BRANCH POINT = '& & ,I0) RETURN ENDIF ENDIF ENDIF ENDIF ! ! TREAT THE CASE WHEN NU1 AND NU2 ! ARE BOTH LARGE ! (THAT IS, BOTH ARE EQUAL TO OR LARGER THAN 1000); ! OR WHEN NU1 IS MODERATE AND NU2 IS LARGE ! (THAT IS, WHEN NU1 IS EQUAL TO OR GREATER THAN 100 ! BUT SMALLER THAN 1000, ! AND NU2 IS EQUAL TO OR LARGER THAN 1000); ! OR WHEN NU2 IS MODERATE AND NU1 IS LARGE ! (THAT IS WHEN NU2 IS EQUAL TO OR GREATER THAN 100 ! BUT SMALLER THAN 1000, ! AND NU1 IS EQUAL TO OR LARGER THAN 1000). ! METHOD UTILIZED--PAULSON APPROXIMATION ! (SEE AMS 55, page 947, FORMULA 26.6.15). ! dfact1 = 1.0D0/(4.5D0*dnu1) dfact2 = 1.0D0/(4.5D0*dnu2) dnum = ((1.0D0-dfact2)*(dx**dpow1)) - (1.0D0-dfact1) dden = DSQRT((dfact2*(dx**dpow2))+dfact1) u = dnum/dden CALL NORCDF(u,gcdf) Cdf = gcdf RETURN 99006 FORMAT (' ','***** THE VALUE OF THE ARGUMENT IS ',I0,' *****') ! 99999 END SUBROUTINE FCDF !> !!##NAME !! fourie(3f) - [M_datapac:ANALYSIS] perform a Fourier analysis of a data set !! !!##SYNOPSIS !! !! SUBROUTINE FOURIE(X,N) !! !! REAL(kind=wp),intent(in) :: X(:) !! INTEGER :: N !! !!##DESCRIPTION !! FOURIE(3f) performs a Fourier analysis of the data in the input vector !! X. The analysis consists of the following-- !! !! 1. computing (and printing) !! (for each of the harmonic frequencies !! 1/n, 2/n, 3/n, ..., 1/2) !! the corresponding fourier coefficients, !! the amplitude, the phase, !! the contribution to the total variance, !! and the relative contribution to the total !! variance. !! 2. plotting out a fourier line spectrum = !! the periodogram = the plot of relative !! contribution to total variance !! (at each fourier frequency) versus !! the fourier frequency. !! !! In order that the results of the Fourier analysis be valid and properly !! interpreted, the input data in X should be equi-spaced in time (or !! whatever variable corresponds to time). !! !! The horizontal axis of the spectra produced by fourie(3f) is frequency. !! This frequency is measured in units of cycles per 'data point' or, !! more precisely, in cycles per unit time where 'unit time' is defined !! as the elapsed time between adjacent observations. !! !! The range of the frequency axis is 0.0 to 0.5. !! !! Fourier analysis differs from spectral analysis (as, for example, !! produced by the datapac TIMESE(3f) subroutine) in that a Fourier !! analysis does no smoothing on the spectral estimates whereas a spectral !! analysis does smooth the spectral estimates. The net result is that !! the spectral estimates obtained from a Fourier analysis are almost !! always more variable than those obtained in a spectral analysis. !! !! The practical conclusion is that when the data analyst has a choice !! of whether to perform a Fourier analysis or a spectral analysis, !! the spectral analysis should almost always be preferred. !! !! the maximum number of Fourier frequencies for which the Fourier !! coefficients is computed (and listed) is N/2 where N is the sample !! size (length of the data record in the vector X). This rule is !! overridden (for listing purposes only) in large data sets and is !! replaced by the rule that the maximum number of lags listed = 800 !! (which corresponds to an 8-page listing of Fourier coefficients. !! If more pages are desired, change the value of the variable MAXPAG !! within this subroutine from 8 to whatever is desired. !! !! If the input observations in X are considered to have been collected !! 1 second apart in time, then the frequency axis of the resulting !! spectra would be in units of Hertz (= cycles per second). !! !! The frequency of 0.0 corresponds to a cycle in the data of infinite !! (= 1/(0.0)) length or period. the frequency of 0.5 corresponds to !! a cycle in the data of length = 1/(0.5) = 2 data points. !! !! Any equi-spaced fourier analysis is intrinsically limited to detecting !! frequencies no larger than 0.5 cycles per data point; this corresponds !! to the fact that the smallest detectable cycle in the data is 2 data !! points per cycle. !! !!##INPUT ARGUMENTS !! !! X The vector of (unsorted) observations. !! !! N The integer number of observations in the vector X. !! The maximum allowable value of N for this subroutine is 15000. !! The sample size N must be greater than or equal to 3. !! !!##OUTPUT !! !! 2 to 10 pages (depending on the input sample size) of automatic !! printout-- !! !! 1. a listing of the amplitude, phase, contribution to the total !! variance, and relative contribution to the total variance for !! each of the fourier frequencies (1/n, 2/n, 3/n, ..., 1/2). !! this listing may take as little as 1 page or as many as n/100 !! pages (the exact number depending on the input sample size n). !! this listing is terminated after at most 8 computer pages. !! if more pages are desired, change the value of the variable !! maxpag within this subroutine from 8 to whatever desired. !! !! 2. a plot of the relative contribution to the total variance versus !! frequency. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_fourie !! use M_datapac, only : fourie !! implicit none !! ! call fourie(x,y) !! end program demo_fourie !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !! !!##REFERENCES !! * Jenkins and Watts, especially page 290. ! ORIGINAL VERSION--NOVEMBER 1972. ! UPDATED --NOVEMBER 1975. ! UPDATED --FEBRUARY 1976. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE FOURIE(X,N) REAL(kind=wp),intent(in) :: X(:) INTEGER :: N REAL(kind=wp) :: ai, amp, an, angdeg, angrad, conmsq, del, ffreq, hold, percon, period, phase1, phase2, pi, sum, suma, sumb, t REAL(kind=wp) :: A(7500), B(7500) REAL(kind=wp) :: vbias, WS, xbar INTEGER :: i, ievodd, ilower, ipage, iskip, iupper, j, maxpag, nhalf, nnpage CHARACTER(len=4) :: alperc COMMON /BLOCK2_real32/ WS(15000) EQUIVALENCE (A(1),WS(1)) EQUIVALENCE (B(1),WS(7501)) DATA pi/3.14159265358979_wp/ DATA alperc/'%'/ ! ilower = 3 iupper = 15000 maxpag = 8 ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( N<ilower .OR. N>iupper ) THEN WRITE (G_IO,99001) ilower , iupper 99001 FORMAT (' ', & &'***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE FOURIE SUBROU& &TINE IS OUTSIDE THE ALLOWABLE (',I0,',',I0,') INTERVAL *****') WRITE (G_IO,99002) N 99002 FORMAT (' ','***** THE VALUE OF THE ARGUMENT IS ',I0,' *****') RETURN ELSE hold = X(1) DO i = 2 , N IF ( X(i)/=hold ) GOTO 100 ENDDO WRITE (G_IO,99003) hold 99003 FORMAT (' ', & &'***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT (A VECTOR) & &TO THE FOURIE SUBROUTINE HAS ALL ELEMENTS = ',E15.8,' *****') RETURN ENDIF ! !-----START POINT----------------------------------------------------- ! 100 an = N ! ! DETERMINE IF N IS ODD OR EVEN ! ievodd = N - 2*(N/2) del = (an+1.0_wp)/2.0_wp IF ( ievodd==0 ) del = (an+2.0_wp)/2.0_wp ! ! COMPUTE THE SAMPLE MEAN ! sum = 0.0_wp DO i = 1 , N sum = sum + X(i) ENDDO xbar = sum/an ! ! COMPUTE THE BIASED SAMPLE VARIANCE ! sum = 0.0_wp DO i = 1 , N sum = sum + (X(i)-xbar)**2 ENDDO vbias = sum/an ! ! COMPUTE THE FOURIER COSINE AND SINE COEFFICIENTS--THEY ARE PLACED ! IN VECTORS A AND B, RESPECTIVELY. ! nhalf = N/2 DO i = 1 , nhalf ai = i suma = 0.0_wp sumb = 0.0_wp DO j = 1 , N t = j suma = suma + X(j)*COS(2.0_wp*pi*(ai/an)*(t-del)) sumb = sumb + X(j)*SIN(2.0_wp*pi*(ai/an)*(t-del)) ENDDO A(i) = suma/an B(i) = sumb/an ENDDO ! ! WRITE OUT THE SAMPLE SIZE, THE SAMPLE MEAN, ! AND THE (BIASED) SAMPLE VARIANCE. ! WRITE (G_IO,99013) WRITE (G_IO,99004) ! 99004 FORMAT (' ',44X,'FOURIER ANALYSIS') WRITE (G_IO,99014) WRITE (G_IO,99014) WRITE (G_IO,99005) N 99005 FORMAT (' ',40X,'THE SAMPLE SIZE N = ',I0) WRITE (G_IO,99006) xbar 99006 FORMAT (' ',40X,'THE SAMPLE MEAN = ',F20.8) WRITE (G_IO,99007) vbias 99007 FORMAT (' ',40X,'THE SAMPLE VARIANCE (WITH DIVISOR N-1) = ',F20.8) WRITE (G_IO,99014) ! ! COMPUTE THE HARMONIC CONTRIBUTION ! AT EACH OF THE FOURIER FREQUENCIES. ! THE FUNDAMENTAL FOURIER FREQUENCY ! IS 1/N CYCLES PER DATA POINT ! (WHERE N = THE INPUT SAMPLE SIZE). ! THE OTHER FOURIER FREQUENCIES ! ARE MULTIPLES OR HARMONICS ! (2/N, 3/N, 4/N, ...1/2) OF THE FUNDAMENTAL. ! COMPUTE AMPLITUDES, PHASES, AND ! CONTRIBUTIONS TO THE VARIANCE AT EACH ! OF THE FOURIER FREQUENCIES. ! COMPUTE THE PERCENTAGE CONTRIBUTION ! TO THE TOTAL VARIANCE AT EACH ! OF THE FOURIER FREQUENCIES. ! NOTE--TO SAVE STORAGE, ALSO COPY ! THE PERCENTAGE CONTRIBUTIONS TO THE VARIANCE) ! (WHICH WILL LATER BE PLOTTED OUT LIKE A SPECTRUM) ! INTO THE VECTOR A; THIS WILL DESTROY ! THE PREVIOUS CONTENTS OF THE VECTOR A. ! WRITE OUT ALL OF THE ABOVE. ! nnpage = 50 i = 0 DO ipage = 1 , maxpag WRITE (G_IO,99013) WRITE (G_IO,99008) 99008 FORMAT (' ',' I FOURIER PERIOD FOURIER ', & & ' FOURIER AMPLITUDE ', & & ' PHASE PHASE VARIANCE ', & & ' RELATIVE') WRITE (G_IO,99009) 99009 FORMAT (' ',' FREQUENCY COEFFICIENT ', & & 'COEFFICIENT', & & ' RADIANS DEGREES COMPONENT'& & ,' VARIANCE') WRITE (G_IO,99010) 99010 FORMAT (' ',' (CYCLES/POINT) A(I) ', & & ' B(I) ', & & ' ', & & ' COMPONENT (%)') DO j = 1 , nnpage i = i + 1 ai = i ffreq = ai/an period = 1.0_wp/ffreq angrad = (ai/an)*2.0_wp*pi angdeg = (ai/an)*360.0_wp amp = SQRT(A(i)*A(i)+B(i)*B(i)) phase1 = ATAN(-B(i)/A(i)) phase2 = phase1*360.0_wp/(2.0_wp*pi) conmsq = 2.0_wp*amp*amp IF ( i==nhalf .AND. ievodd==0 ) conmsq = conmsq/2.0_wp percon = 100.0_wp*(conmsq/vbias) WRITE (G_IO,99011) i , ffreq , period , A(i) , B(i) , amp , & & phase1 , phase2 , conmsq , percon , alperc 99011 FORMAT (' ',I0,2X,F8.6,1X,F8.2,6(1X,E14.7),2X,F6.2,A1) A(i) = percon IF ( i>=nhalf ) GOTO 200 iskip = i - 10*(i/10) IF ( iskip==0 ) WRITE (G_IO,99014) ENDDO ENDDO ! ! PLOT OUT THE PERCENTAGE CONTRIBUTIONS ! TO THE TOTAL VARIANCE AT ! EACH OF THE FOURIER FREQUENCIES ! (1/N, 2/N, 3/N, ..., 1/2). ! THIS WILL CORRESPOND TO A SPECTRAL ! PLOT IN SPECTRAL ANALYSIS. ! 200 CALL PLOTSP(A,nhalf,0) WRITE (G_IO,99012) 99012 FORMAT (' ',40X, & & 'PERIODOGRAM = FOURIER LINE SPECTRUM OF THE ORIGINAL DATA'& & ) 99013 FORMAT ('1') 99014 FORMAT (' ') ! END SUBROUTINE FOURIE !> !!##NAME !! fran(3f) - [M_datapac:RANDOM] generate F random numbers !! !!##SYNOPSIS !! !! SUBROUTINE FRAN(N,Nu1,Nu2,Istart,X) !! !! INTEGER,intent(in) :: N !! INTEGER,intent(in) :: Nu1 !! INTEGER,intent(in) :: Nu2 !! INTEGER,intent(inout) :: Istart !! REAL(kind=wp),intent(out) :: X(:) !! !!##DESCRIPTION !! FRAN(3f) generates a random sample of size n from the F distribution !! with integer degrees of freedom parameters = NU1 AND NU2. !! !! This distribution is defined for all non-negative x. !! !! The probability density function is given in the references below. !! !!##INPUT ARGUMENTS !! !! N The desired integer number of random numbers to be generated. !! !! NU1 The integer degrees of freedom for the numerator of the F ratio. !! nu1 should be a positive integer variable. !! !! NU2 The integer degrees of freedom NU2 should be a positive !! integer variable for the denominator of the F ratio. !! !! ISTART An integer flag code which (if set to 0) will start the !! generator over and hence produce the same random sample !! over and over again upon successive calls to this subroutine !! within a run; or (if set to some integer value not equal to 0, !! like, say, 1) will allow the generator to continue from where !! it stopped and hence produce different random samples upon !! successive calls to this subroutine within a run. !! !!##OUTPUT ARGUMENTS !! X A vector (of dimension at least N) into which the generated !! random sample will be placed. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_fran !! use M_datapac, only : fran !! implicit none !! ! call fran(x,y) !! end program demo_fran !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !! !!##REFERENCES !! * Mood and Grable, Introduction to the Theory of Statistics, 1963, !! pages 231-232. !! * Johnson and Kotz, Continuous Univariate Distributions--2, 1970, !! pages 75-93. !! * Hastings and Peacock, Statistical Distributions--A Handbook for !! Students and Practitioners, 1975, page 64. ! ORIGINAL VERSION--NOVEMBER 1975. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE FRAN(N,Nu1,Nu2,Istart,X) INTEGER,intent(in) :: N INTEGER,intent(in) :: Nu1 INTEGER,intent(in) :: Nu2 INTEGER,intent(inout) :: Istart REAL(kind=wp),intent(out) :: X(:) REAL(kind=wp) :: anu1 , anu2 , arg1 , arg2 , chs1 , chs2 , pi , sum , y , z INTEGER :: i , j INTEGER :: iseed ! DIMENSION y(2) , z(2) DATA pi/3.14159265358979_wp/ ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( N<1 ) THEN WRITE (G_IO,99001) 99001 FORMAT (' ***** FATAL ERROR--THE FIRST INPUT ARGUMENT TO FRAN(3f) IS NON-POSITIVE *****') WRITE (G_IO,99004) N RETURN ELSEIF ( Nu1<=0 ) THEN WRITE (G_IO,99002) 99002 FORMAT (' ***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO FRAN(3f) IS NON-POSITIVE *****') WRITE (G_IO,99004) Nu1 RETURN ELSEIF ( Nu2<=0 ) THEN WRITE (G_IO,99003) 99003 FORMAT (' ***** FATAL ERROR--THE THIRD INPUT ARGUMENT TO FRAN(3f) IS NON-POSITIVE *****') WRITE (G_IO,99004) Nu2 RETURN ELSE ! !-----START POINT----------------------------------------------------- ! CALL UNIRAN(1,Istart,y) ! ! GENERATE N F RANDOM NUMBERS ! USING THE DEFINITION THAT ! A F VARIATE WITH NU1 AND NU2 DEGREES OF FREEDOM ! EQUALS (CHS1/NU1)/(CHS2/NU2) ! WHERE CHS1 IS A CHI-SQUARED VARIATE ! WITH NU1 DEGREES OF FREEDOM, ! AND CHS2 IS A CHI-SQUARED VARIATE ! WITH NU2 DEGREES OF FREEDOM. ! FIRST GENERATE UNIFORM (0,1) RANDOM NUMBERS, ! THEN GENERATE NORMAL RANDOM NUMBERS, ! THEN CHI-SQUARED RANDOM NUMBERS WITH NU1 DEGREES ! OF FREEDOM, ! THEN CHI-SQUARED RANDOM NUMBERS WITH NU2 DEGREES ! OF FREEDOM, ! AND THEN FINALLY THE F RANDOM NUMBER. ! anu1 = Nu1 anu2 = Nu2 iseed=1 DO i = 1 , N ! sum = 0.0_wp DO j = 1 , Nu1 , 2 CALL UNIRAN(2,iseed,y) arg1 = -2.0_wp*LOG(y(1)) arg2 = 2.0_wp*pi*y(2) z(1) = (SQRT(arg1))*(COS(arg2)) z(2) = (SQRT(arg1))*(SIN(arg2)) sum = sum + z(1)*z(1) IF ( j/=Nu1 ) sum = sum + z(2)*z(2) ENDDO chs1 = sum ! sum = 0.0_wp DO j = 1 , Nu2 , 2 CALL UNIRAN(2,iseed,y) arg1 = -2.0_wp*LOG(y(1)) arg2 = 2.0_wp*pi*y(2) z(1) = (SQRT(arg1))*(COS(arg2)) z(2) = (SQRT(arg1))*(SIN(arg2)) sum = sum + z(1)*z(1) IF ( j/=Nu2 ) sum = sum + z(2)*z(2) ENDDO chs2 = sum ! X(i) = (chs1/anu1)/(chs2/anu2) ! ENDDO ENDIF 99004 FORMAT (' ','***** THE VALUE OF THE ARGUMENT IS ',I0,' *****') ! END SUBROUTINE FRAN !> !!##NAME !! freq(3f) - [M_datapac:STATISTICS] compute the sample frequency and !! cumulative sample frequency of a vector !! !!##SYNOPSIS !! !! SUBROUTINE FREQ(X,N) !! !! REAL(kind=wp),intent(in) :: X(:) !! INTEGER,intent(in) :: N !! !!##DESCRIPTION !! freq(3f) computes the sample frequency and sample cumulative frequency !! for the data in the input vector x. !! !!##INPUT ARGUMENTS !! !! X The vector of (unsorted or sorted) observations. !! !! N The integer number of observations in the vector X. !! The maximum allowable value of N for this subroutine is 15000. !!##OUTPUT !! !! Several (for large data sets) pages of automatic plots (with !! approximately 55 values per page) consisting of an ordered listing !! of each distinct value in the data set along with the frequency of !! occurance of that value and the cumulative frequency. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_freq !! use M_datapac, only : freq !! implicit none !! ! call freq(x,y) !! end program demo_freq !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !!##MAINTAINER !! John Urban, 2022.05.31 !!##LICENSE !! CC0-1.0 !!##REFERENCES !! * KENDALL AND STUART, THE ADVANCED THEORY OF STATISTICS, VOLUME 1, !! EDITION 2, 1963, page 8. ! ORIGINAL VERSION--DECEMBER 1972. ! UPDATED --NOVEMBER 1975. ! UPDATED --FEBRUARY 1976. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE FREQ(X,N) REAL(kind=wp),intent(in) :: X(:) INTEGER,intent(in) :: N REAL(kind=wp) :: an, cfreq, dvalue, frq, hold, pcfreq, pfreq, s, sum, WS, xbar, Y INTEGER i, icfreq, iflag, ifreq, ip1, iupper, ndv, nm1, numseq DIMENSION Y(15000) COMMON /BLOCK2_real32/ WS(15000) EQUIVALENCE (Y(1),WS(1)) ! iupper = 15000 ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( N<1 .OR. N>iupper ) THEN WRITE (G_IO,99001) iupper 99001 FORMAT (' ***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO FREQ(3f) IS OUTSIDE THE ALLOWABLE (1,',& & I0,') INTERVAL *****') WRITE (G_IO,99002) N 99002 FORMAT (' ','***** THE VALUE OF THE ARGUMENT IS ',I0,' *****') RETURN ELSEIF ( N==1 ) THEN WRITE (G_IO,99003) 99003 FORMAT (' ***** FATAL ERROR-- THE SECOND INPUT ARGUMENT TO FREQ(3f) HAS THE VALUE 1 *****') RETURN ELSE hold = X(1) DO i = 2 , N IF ( X(i)/=hold ) GOTO 50 ENDDO WRITE (G_IO,99004) hold 99004 FORMAT (' ***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT (A VECTOR) TO FREQ(3f) HAS ALL ELEMENTS = ', & & E15.8,' *****') ! !-----START POINT----------------------------------------------------- ! 50 an = N ! ! COMPUTE THE SAMPLE MEAN AND SAMPLE STANDARD DEVIATION ! sum = 0.0_wp DO i = 1 , N sum = sum + X(i) ENDDO xbar = sum/an sum = 0.0_wp DO i = 1 , N sum = sum + (X(i)-xbar)**2 ENDDO s = SQRT(sum/(an-1.0_wp)) ! WRITE (G_IO,99005) 99005 FORMAT ('1') WRITE (G_IO,99006) ! 99006 FORMAT (' ',18X,'SAMPLE FREQUENCY AND SAMPLE CUMULATIVE FREQUENCY') WRITE (G_IO,99014) WRITE (G_IO,99007) N 99007 FORMAT (' ',27X,'THE SAMPLE SIZE N = ',I0) WRITE (G_IO,99008) xbar 99008 FORMAT (' ',25X,'THE SAMPLE MEAN = ',E15.8) WRITE (G_IO,99009) s 99009 FORMAT (' ',20X,'THE SAMPLE STANDARD DEVIATION = ',E15.8) WRITE (G_IO,99014) WRITE (G_IO,99014) WRITE (G_IO,99010) 99010 FORMAT (' INDEX VALUE FREQUENCY PERCENTAGE CUMULATIVE PERCENTAGE') 99011 FORMAT (' FREQUENCY FREQUENCY CUMULATIVE') 99012 FORMAT (' FREQUENCY ') WRITE (G_IO,99011) WRITE (G_IO,99012) WRITE (G_IO,99014) ! CALL SORT(X,N,Y) ndv = 0 icfreq = 0 numseq = 1 nm1 = N - 1 DO i = 1 , nm1 ip1 = i + 1 IF ( Y(i)==Y(ip1) ) numseq = numseq + 1 IF ( Y(i)/=Y(ip1) ) THEN ndv = ndv + 1 dvalue = Y(i) ifreq = numseq icfreq = icfreq + ifreq frq = ifreq cfreq = icfreq pfreq = 100.0_wp*frq/an pcfreq = 100.0_wp*cfreq/an WRITE (G_IO,99013) ndv , dvalue , ifreq , pfreq , icfreq , pcfreq iflag = ndv - 10*(ndv/10) IF ( iflag==0 ) WRITE (G_IO,99014) numseq = 1 ENDIF ENDDO ndv = ndv + 1 dvalue = Y(N) ifreq = numseq icfreq = icfreq + ifreq frq = ifreq cfreq = icfreq pfreq = 100.0_wp*frq/an pcfreq = 100.0_wp*cfreq/an WRITE (G_IO,99013) ndv , dvalue , ifreq , pfreq , icfreq , pcfreq iflag = ndv - 10*(ndv/10) IF ( iflag==0 ) WRITE (G_IO,99014) ENDIF 99013 FORMAT (' ',I8,4X,E17.10,3X,I8,6X,F8.4,10X,I8,6X,F8.4) 99014 FORMAT (' ') END SUBROUTINE FREQ !> !!##NAME !! gamcdf(3f) - [M_datapac:CUMULATIVE_DISTRIBUTION] compute the gamma cumulative !! distribution function !! !!##SYNOPSIS !! !! SUBROUTINE GAMCDF(X,Gamma,Cdf) !! !! REAL(kind=wp),intent(in) :: Gamma !! REAL(kind=wp),intent(in) :: X !! REAL(kind=wp),intent(out) :: Cdf !! !!##DESCRIPTION !! GAMCDF(3f) computes the cumulative distribution function value for !! the gamma distribution with REAL tail length parameter !! = GAMMA. !! !! The Gamma distribution used herein has mean = GAMMA and standard !! deviation = sqrt(GAMMA). !! !! This distribution is defined for all positive X, and has the !! probability density function !! !! f(X) = (1/constant) * (X**(GAMMA-1)) * exp(-X) !! !! Where the constant = the Gamma function evaluated at the value GAMMA. !! !! Note the mode of internal operations is DOUBLE PRECISION. !! !!##ACCURACY !! !! (On the UNIVAC 1108, EXEC 8 system at NBS) !! !! Compared to the known GAMMA = 1 (exponential) results, agreement !! was had out to 7 significant digits for all tested X. The tested X !! values covered the entire range of the distribution--from the 0.00001 !! percent point up to the 99.99999 percent point of the distribution. !! !!##INPUT ARGUMENTS !! X The value at which the cumulative distribution function is !! to be evaluated. X should be positive. !! GAMMA The value of the tail length parameter. GAMMA should be positive. !! !!##OUTPUT ARGUMENTS !! !! CDF The cumulative distribution function value for the gamma !! distribution !! !!##EXAMPLES !! !! Sample program: !! !! program demo_gamcdf !! use M_datapac, only : gamcdf !! implicit none !! ! call gamcdf(x,y) !! end program demo_gamcdf !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !! !!##REFERENCES !! * WILK, GNANADESIKAN, AND HUYETT, 'PROBABILITY PLOTS FOR THE GAMMA !! DISTRIBUTION', TECHNOMETRICS, 1962, pages 1-15, ESPECIALLY pages 3-5. !! * NATIONAL BUREAU OF STANDARDS APPLIED MATHEMATICS SERIES 55, 1964, !! page 257, FORMULA 6.1.41. !! * JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE DISTRIBUTIONS--1, 1970, !! pages 166-206. !! * HASTINGS AND PEACOCK, STATISTICAL DISTRIBUTIONS--A HANDBOOK FOR !! STUDENTS AND PRACTITIONERS, 1975, pages 68-73. ! ORIGINAL VERSION--NOVEMBER 1975. ! ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE GAMCDF(X,Gamma,Cdf) REAL(kind=wp),intent(in) :: Gamma REAL(kind=wp),intent(in) :: X REAL(kind=wp),intent(out) :: Cdf INTEGER :: i , maxit 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)/ + .833333333333333333D-1 , & & -.277777777777777778D-2 , +.793650793650793651D-3 , & & -.595238095238095238D-3 , +.841750841750841751D-3/ DATA d(6) , d(7) , d(8) , d(9) , d(10)/ - .191752691752691753D-2 ,& & +.641025641025641025D-2 , -.295506535947712418D-1 , & & +.179644372368830573D0 , -.139243221690590111D1/ ! ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( X<=0.0_wp ) THEN WRITE (G_IO,99001) 99001 FORMAT (' ', & &'***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT TO THE GAMC& &DF SUBROUTINE IS NON-POSITIVE *****') WRITE (G_IO,99007) X Cdf = 0.0_wp RETURN ELSEIF ( Gamma<=0.0_wp ) THEN WRITE (G_IO,99002) 99002 FORMAT (' ', & &'***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE GAMCDF SUBROU& &TINE IS NON-POSITIVE *****') WRITE (G_IO,99007) Gamma Cdf = 0.0_wp RETURN ELSE ! !-----START POINT----------------------------------------------------- ! dx = X dgamma = Gamma maxit = 10000 ! ! COMPUTE THE GAMMA FUNCTION USING THE ALGORITHM IN THE ! NBS APPLIED MATHEMATICS SERIES REFERENCE. ! z = dgamma den = 1.0D0 DO WHILE ( z<10.0D0 ) den = den*z z = z + 1 ENDDO 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) & & + d(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 ! ! COMPUTE T-SUB-Q AS DEFINED ON page 4 OF THE WILK, GNANADESIKAN, ! AND HUYETT REFERENCE ! sum = 1.0D0/dgamma term = 1.0D0/dgamma cut1 = dx - dgamma cut2 = dx*10000000000.0D0 DO i = 1 , maxit ai = i term = dx*term/(dgamma+ai) sum = sum + term cutoff = cut1 + (cut2*term/sum) IF ( ai>cutoff ) GOTO 50 ENDDO WRITE (G_IO,99003) maxit ! 99003 FORMAT (' ','*****ERROR IN INTERNAL OPERATIONS IN THE GAMCDF ',& & 'SUBROUTINE--THE NUMBER OF ITERATIONS EXCEEDS ',I0) WRITE (G_IO,99004) X 99004 FORMAT (' ',' THE INPUT VALUE OF X IS ',E15.8) WRITE (G_IO,99005) Gamma 99005 FORMAT (' ',' THE INPUT VALUE OF GAMMA IS ',E15.8) WRITE (G_IO,99006) 99006 FORMAT (' ',' THE OUTPUT VALUE OF CDF HAS BEEN SET TO 1.0') Cdf = 1.0_wp RETURN ! 50 t = sum Cdf = (dx**dgamma)*(DEXP(-dx))*t/g ENDIF 99007 FORMAT (' ','***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') ! END SUBROUTINE GAMCDF !> !!##NAME !! gamplt(3f) - [M_datapac:LINE_PLOT] generate a gamma probability plot !! !!##SYNOPSIS !! !! SUBROUTINE GAMPLT(X,N,Gamma) !! !! REAL(kind=wp),intent(in) :: X(:) !! INTEGER,intent(in) :: N !! REAL(kind=wp),intent(in) :: Gamma !! !!##DESCRIPTION !! GAMPLT(3f) generates a gamma probability plot (with tail length !! parameter value = GAMMA). !! !! The prototype gamma distribution used herein has mean = GAMMA and !! standard deviation = sqrt(GAMMA). !! !! This distribution is defined for all positive X, and has the !! probability density function !! !! f(X) = (1/constant) * (X**(GAMMA-1)) * exp(-X) !! !! Where the constant = the gamma function evaluated at the value GAMMA. !! !! As used herein, a probability plot for a distribution is a plot !! of the ordered observations versus the order statistic medians for !! that distribution. !! !! The gamma probability plot is useful in graphically testing the !! composite (that is, location and scale parameters need not be !! specified) hypothesis that the underlying distribution from which !! the data have been randomly drawn is the gamma distribution with !! tail length parameter value = GAMMA. !! !! If the hypothesis is true, the probability plot should be near-linear. !! !! A measure of such linearity is given by the calculated probability !! plot correlation coefficient. !! !!##INPUT ARGUMENTS !! !! X The vector of (unsorted or sorted) observations. !! !! N The integer number of observations in the vector X. !! The maximum allowable value of N for this subroutine is 7500. !! !! GAMMA The value of the tail length parameter. Gamma should be positive. !! !!##OUTPUT !! A one-page gamma probability plot. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_gamplt !! use M_datapac, only : gamplt !! implicit none !! ! call gamplt(x,y) !! end program demo_gamplt !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !! !!##REFERENCES !! * Wilk, Gnanadesikan, and Huyett, 'Probability Plots for the Gamma !! Distribution', Technometrics, 1962, pages 1-15. !! * National Bureau of Standards Applied Mathematics Series 55, 1964, !! page 257, Formula 6.1.41. !! * Filliben, 'Techniques for Tail Length Analysis', Proceedings of the !! Eighteenth Conference on the Design of Experiments in Army Research !! Development and Testing (Aberdeen, Maryland, October, 1972), pages !! 425-450. !! * Hahn and Shapiro, Statistical Methods in Engineering, 1967, pages !! 260-308. !! * Johnson and Kotz, Continuous Univariate Distributions--1, 1970, !! pages 166-206. ! ORIGINAL VERSION--NOVEMBER 1974. ! UPDATED --SEPTEMBER 1975. ! UPDATED --NOVEMBER 1975. ! UPDATED --FEBRUARY 1976. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE GAMPLT(X,N,Gamma) REAL(kind=wp),intent(in) :: X(:) INTEGER,intent(in) :: N REAL(kind=wp),intent(in) :: Gamma REAL(kind=wp) :: acount, aj, an, cc, cut1, cut2, cutoff, dgamma, dp, dx, g, hold, pcalc, pp0025, pp025, pp975, pp9975, sum, sum1 REAL(kind=wp) :: sum2, sum3, t, tau, term, u, W, wbar, WS, xdel, xlower, xmax, xmid, xmin, xmin0, xupper, Y, ybar, yint REAL(kind=wp) :: yslope INTEGER i, icount, iloop, ip1, itail, iupper, j !--------------------------------------------------------------------- DOUBLE PRECISION z, z2, z3, z4, z5, den, a, b, c, d DOUBLE PRECISION DEXP, DLOG DIMENSION d(10) DIMENSION Y(7500), W(7500) COMMON /BLOCK2_real32/ WS(15000) EQUIVALENCE (Y(1),WS(1)) EQUIVALENCE (W(1),WS(7501)) DATA c/.918938533204672741D0/ DATA d(1), d(2), d(3), d(4), d(5)/ + .833333333333333333D-1, & & -.277777777777777778D-2, +.793650793650793651D-3, & & -.595238095238095238D-3, +.841750841750841751D-3/ DATA d(6), d(7), d(8), d(9), d(10)/ - .191752691752691753D-2,& & +.641025641025641025D-2, -.295506535947712418D-1, & & +.179644372368830573D0, -.139243221690590111D1/ ! iupper = 7500 ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( N<1 .OR. N>iupper ) THEN WRITE (G_IO,99001) iupper 99001 FORMAT (' ***** FATAL ERROR--The second input argument to GAMPLT(3f) is outside the allowable (1,',& & I0,') interval *****') WRITE (G_IO,99002) N 99002 FORMAT (' ','***** The value of the argument is ',I0,' *****') RETURN ELSEIF ( N==1 ) THEN WRITE (G_IO,99003) 99003 FORMAT (' ***** NON-FATAL DIAGNOSTIC--The second input argument to GAMPLT(3f) has the value 1 *****') RETURN ELSE IF ( Gamma<=0.0_wp ) THEN WRITE (G_IO,99004) 99004 FORMAT (' ***** FATAL ERROR--The third input argument to GAMPLT(3f) is non-positive *****') WRITE (G_IO,99005) Gamma 99005 FORMAT (' ','***** The value of the argument is ',E15.8,' *****') RETURN ELSE hold = X(1) DO i = 2 , N IF ( X(i)/=hold ) GOTO 50 ENDDO WRITE (G_IO,99006) hold 99006 FORMAT (' ***** NON-FATAL DIAGNOSTIC--The first input argument (a vector) to GAMPLT(3f) has all elements = ', & & E15.8,' *****') RETURN ENDIF ! !-----START POINT----------------------------------------------------- ! 50 an = N dgamma = Gamma ! ! COMPUTE THE GAMMA FUNCTION USING THE ALGORITHM IN THE ! NBS APPLIED MATHEMATICS SERIES REFERENCE. ! THIS GAMMA FUNCTION NEED BE CALCULATED ONLY ONCE. ! IT IS USED IN THE CALCULATION OF THE CDF BASED ON ! THE TENTATIVE VALUE OF THE PPF IN THE ITERATION. ! z = dgamma den = 1.0D0 DO WHILE ( z<10.0D0 ) den = den*z z = z + 1.0D0 ENDDO 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) & & + d(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 ! ! SORT THE DATA ! CALL SORT(X,N,Y) ! ! GENERATE UNIFORM ORDER STATISTIC MEDIANS ! CALL UNIMED(N,W) ! ! GENERATE GAMMA DISTRIBUTION ORDER STATISTIC MEDIANS ! ! DETERMINE LOWER AND UPPER BOUNDS ON THE DESIRED I-TH GAMMA ! ORDER STATISTIC MEDIAN. ! FOR EACH I, A LOWER BOUND IS GIVEN BY ! (Y(I)*GAMMA*THE GAMMA FUNCTION OF GAMMA)**(1.0/GAMMA) ! WHERE Y(I) IS THE CORRESPONDING UNIFORM (0,1) ORDER STATISIC ! MEDIAN. ! FOR EACH I EXCEPT I = N, AN UPPER BOUND IS GIVEN BY THE ! (I+1)-ST GAMMA ORDER STATISTIC MEDIAN (ASSUMEDLY ALREADY ! CALCULTATED). ! FOR I = N, AN UPPER BOUND IS DETERMINED BY COMPUTING ! MULTIPLES OF THE LOWER BOUND FOR I = N UNTIL A LARGER ! VALUE IS OBTAINED. ! DUE TO THE ABOVE CONSIDERATIONS, THE GAMMA ORDER STATISTIC ! MEDIANS WILL BE CALCULATED LARGEST TO SMALLEST, THAT IS, ! IN THE FOLLOWING SEQUENCE: W(N), W(N-1), ..., W(2), W(1). ! NOTE ALSO THAT 1) THE CODE IS COMPLICATED SLIGHTLY BY THE ! FACT THAT PERCENT POINT VALUES INVOLVED IN THE CALCULATION OF ! THE TAIL LENGTH MEASURE TAU (SEE LABEL 605) ARE GOING ON ! 'SIMULATNEOUSLY'. AND 2) THE VECTOR W WILL AT VARIOUS TIMES ! IN THE PROGRAM HAVE UNIFORM ORDER STATISTIC MEDIANS AND ! THEN LATER GRADUALLY FILL UP WITH GAMMA ORDER STATISTIC ! MEDIANS. ! i = N itail = 0 ENDIF 100 IF ( itail==0 ) u = W(i) dp = u xmin0 = (u*Gamma*g)**(1.0_wp/Gamma) xmin = xmin0 IF ( i==N .OR. itail>=1 ) THEN iloop = 1 icount = 1 ELSE ip1 = i + 1 xmax = W(ip1) GOTO 300 ENDIF 200 acount = icount xmax = acount*xmin0 dx = xmax GOTO 600 300 xmid = (xmin+xmax)/2.0_wp ! ! AT THIS STAGE WE NOW HAVE LOWER AND UPPER LIMITS ON ! THE DESIRED I-TH GAMMA ORDER STATISITC MEDIAN W(I). ! NOW ITERATE BY BISECTION UNTIL THE DESIRED ACCURACY IS ACHIEVED ! FOR THE I-TH GAMMA ORDER STATISITIC MEDIAN. ! iloop = 2 xlower = xmin xupper = xmax icount = 0 400 dx = xmid GOTO 600 500 IF ( itail<1 ) THEN W(i) = xmid IF ( i<=1 ) THEN ! ! AT THIS POINT, THE GAMMA ORDER STATISTIC MEDIANS ARE ALL COMPUTED. ! NOW PLOT OUT THE GAMMA PROBABILITY PLOT ! CALL PLOT(Y,W,N) ELSE i = i - 1 GOTO 100 ENDIF ENDIF ! ! COMPUTE THE TAIL LENGTH MEASURE OF THE DISTRIBUTION. ! WRITE OUT THE TAIL LENGTH MEASURE OF THE DISTRIBUTION ! AND THE SAMPLE SIZE. ! IF ( itail==0 ) THEN u = 0.9975_wp itail = 1 GOTO 100 ELSEIF ( itail==1 ) THEN pp9975 = xmid u = 0.0025_wp itail = 2 GOTO 100 ELSEIF ( itail==2 ) THEN pp0025 = xmid u = 0.975_wp itail = 3 GOTO 100 ELSEIF ( itail==3 ) THEN pp975 = xmid u = 0.025_wp itail = 4 GOTO 100 ELSE pp025 = xmid tau = (pp9975-pp0025)/(pp975-pp025) WRITE (G_IO,99007) Gamma , tau , N ! 99007 FORMAT (' ','Gamma probability plot with shape parameter = ', & & E17.10,1X,'(TAU = ',E15.8,')',16X,'sample size N = ', & & I0) ! ! COMPUTE THE PROBABILITY PLOT CORRELATION COEFFICIENT. ! COMPUTE LOCATION AND SCALE ESTIMATES ! FROM THE INTERCEPT AND SLOPE OF THE PROBABILITY PLOT. ! THEN WRITE THEM OUT. ! sum1 = 0.0_wp sum2 = 0.0_wp DO i = 1 , N sum1 = sum1 + Y(i) sum2 = sum2 + W(i) ENDDO ybar = sum1/an wbar = sum2/an sum1 = 0.0_wp sum2 = 0.0_wp sum3 = 0.0_wp DO i = 1 , N sum1 = sum1 + (Y(i)-ybar)*(Y(i)-ybar) sum2 = sum2 + (Y(i)-ybar)*(W(i)-wbar) sum3 = sum3 + (W(i)-wbar)*(W(i)-wbar) ENDDO cc = sum2/SQRT(sum3*sum1) yslope = sum2/sum3 yint = ybar - yslope*wbar WRITE (G_IO,99008) cc , yint , yslope 99008 FORMAT (' ','Probability plot correlation coefficient = ',F8.5,& & 5X,'estimated intercept = ',E15.8,3X, & & 'estimated slope = ',E15.8) ! RETURN ENDIF ! !******************************************************************** ! THIS SECTION BELOW IS LOGICALLY SEPARATE FROM THE ABOVE. ! THIS SECTION COMPUTES A CDF VALUE FOR ANY GIVEN TENTATIVE ! PERCENT POINT X VALUE AS DEFINED IN EITHER OF THE 2 ! ITERATION LOOPS IN THE ABOVE CODE. ! ! COMPUTE T-SUB-Q AS DEFINED ON page 4 OF THE WILK, GNANADESIKAN, ! AND HUYETT REFERENCE ! 600 sum = 1.0_wp/dgamma term = 1.0_wp/dgamma cut1 = dx - dgamma cut2 = dx*10000000.0_wp DO j = 1 , 1000 aj = j term = dx*term/(dgamma+aj) sum = sum + term cutoff = cut1 + (cut2*term/sum) IF ( aj>cutoff ) GOTO 700 ENDDO WRITE (G_IO,99009) 99009 FORMAT (' *****Error in internal operations in the GAMPLT subroutine--The number of CDF iterations exceeds 1000') WRITE (G_IO,99010) Gamma 99010 FORMAT (' The input value of GAMMA is ',E15.8) 700 t = sum pcalc = (dx**dgamma)*(EXP(-dx))*t/g IF ( iloop==1 ) THEN IF ( pcalc>=dp ) GOTO 300 xmin = xmax icount = icount + 1 IF ( icount>30000 ) GOTO 300 GOTO 200 ELSE IF ( pcalc==dp ) GOTO 500 IF ( pcalc>dp ) THEN xupper = xmid xmid = (xmid+xlower)/2.0_wp ELSE xlower = xmid xmid = (xmid+xupper)/2.0_wp ENDIF xdel = ABS(xmid-xlower) icount = icount + 1 IF ( xdel>=0.0000001_wp .AND. icount<=100 ) GOTO 400 GOTO 500 ENDIF ! END SUBROUTINE GAMPLT !> !!##NAME !! gamppf(3f) - [M_datapac:PERCENT_POINT] compute the gamma percent !! point function !! !!##SYNOPSIS !! !! SUBROUTINE GAMPPF(P,Gamma,Ppf) !! !! REAL(kind=wp),intent(in) :: P !! REAL(kind=wp),intent(in) :: Gamma !! REAL(kind=wp),intent(out) :: Ppf !! !!##DESCRIPTION !! GAMPPF(3f) computes the percent point function value for the gamma !! distribution with REAL tail length parameter = GAMMA. !! !! The gamma distribution used herein has mean = GAMMA and standard !! deviation = sqrt(GAMMA). This distribution is defined for all positive !! X, and has the probability density function !! !! f(X) = (1/constant) * (X**(GAMMA-1)) * exp(-X) !! !! where the constant = the gamma function evaluated at the value GAMMA. !! !! Note that the percent point function of a distribution is identically !! the same as the inverse cumulative distribution function of the !! distribution. !! !!##INPUT ARGUMENTS !! !! P The value (between 0.0 (exclusively) and 1.0 (exclusively)) !! at which the percent point function is to be evaluated. !! !! GAMMA The value of the tail length parameter. GAMMA should be positive. !! !!##OUTPUT ARGUMENTS !! !! PPF The percent point function value for the gamma distribution !! !!##EXAMPLES !! !! Sample program: !! !! program demo_gamppf !! use M_datapac, only : gamppf !! implicit none !! ! call gamppf(x,y) !! end program demo_gamppf !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !!##MAINTAINER !! John Urban, 2022.05.31 !!##LICENSE !! CC0-1.0 !!##REFERENCES !! * Wilk, Gnanadesikan, and Huyett, 'Probability Plots for the Gamma !! Distribution', Technometrics, 1962, pages 1-15, especially pages 3-5. !! * National Bureau of Standards Applied Mathematics Series 55, 1964, !! page 257, Formula 6.1.41. !! * Johnson and Kotz, Continuous Univariate Distributions--1, 1970, !! pages 166-206. !! * Hastings and Peacock, Statistical Distributions--A Handbook for !! Students and Practitioners, 1975, pages 68-73. ! ORIGINAL VERSION--NOVEMBER 1974. ! UPDATED --SEPTEMBER 1975. ! UPDATED --NOVEMBER 1975. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE GAMPPF(P,Gamma,Ppf) REAL(kind=wp),intent(in) :: P REAL(kind=wp),intent(in) :: Gamma REAL(kind=wp),intent(out) :: Ppf INTEGER :: icount , iloop , j , maxit ! ! ACCURACY--(ON THE UNIVAC 1108, EXEC 8 SYSTEM AT NBS) ! COMPARED TO THE KNOWN GAMMA = 1 (EXPONENTIAL) ! RESULTS, AGREEMENT WAS HAD OUT TO 6 SIGNIFICANT ! DIGITS FOR ALL TESTED P IN THE RANGE P = .001 TO ! P = .999. FOR P = .95 AND SMALLER, THE AGREEMENT ! WAS EVEN BETTER--7 SIGNIFICANT DIGITS. ! (NOTE THAT THE TABULATED VALUES GIVEN IN THE WILK, ! GNANADESIKAN, AND HUYETT REFERENCE BELOW, page 20, ! ARE IN ERROR FOR AT LEAST THE GAMMA = 1 CASE-- ! THE WORST DETECTED ERROR WAS AGREEMENT TO ONLY 3 ! SIGNIFICANT DIGITS (IN THEIR 8 SIGNIFICANT DIGIT TABLE) ! FOR P = .999.) ! !--------------------------------------------------------------------- ! DOUBLE PRECISION dp , dgamma DOUBLE PRECISION z , z2 , z3 , z4 , z5 , den , a , b , c , d , g 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 DEXP , DLOG DIMENSION d(10) DATA c/.918938533204672741D0/ DATA d(1) , d(2) , d(3) , d(4) , d(5)/ + .833333333333333333D-1 , & & -.277777777777777778D-2 , +.793650793650793651D-3 , & & -.595238095238095238D-3 , +.841750841750841751D-3/ DATA d(6) , d(7) , d(8) , d(9) , d(10)/ - .191752691752691753D-2 ,& & +.641025641025641025D-2 , -.295506535947712418D-1 , & & +.179644372368830573D0 , -.139243221690590111D1/ ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( P<=0.0_wp .OR. P>=1.0_wp ) THEN WRITE (G_IO,99001) 99001 FORMAT (' ***** FATAL ERROR--The first input argument to GAMPPF(3f) is outside the allowable (0,1) interval *****') WRITE (G_IO,99007) P Ppf = 0.0_wp RETURN ELSEIF ( Gamma<=0.0_wp ) THEN WRITE (G_IO,99002) 99002 FORMAT (' ***** FATAL ERROR--The second input argument to GAMPPF(3f) is non-positive *****') WRITE (G_IO,99007) Gamma Ppf = 0.0_wp RETURN ELSE ! !-----START POINT----------------------------------------------------- ! dp = P dgamma = Gamma maxit = 10000 ! ! COMPUTE THE GAMMA FUNCTION USING THE ALGORITHM IN THE ! NBS APPLIED MATHEMATICS SERIES REFERENCE. ! THIS GAMMA FUNCTION NEED BE CALCULATED ONLY ONCE. ! IT IS USED IN THE CALCULATION OF THE CDF BASED ON ! THE TENTATIVE VALUE OF THE PPF IN THE ITERATION. ! z = dgamma den = 1.0D0 DO WHILE ( z<10.0D0 ) den = den*z z = z + 1.0D0 ENDDO 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) & & + d(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 ! ! DETERMINE LOWER AND UPPER LIMITS ON THE DESIRED 100P ! PERCENT POINT. ! iloop = 1 xmin0 = (dp*dgamma*g)**(1.0D0/dgamma) xmin = xmin0 icount = 1 ENDIF 100 ai = icount xmax = ai*xmin0 dx = xmax GOTO 500 200 xmid = (xmin+xmax)/2.0D0 ! ! NOW ITERATE BY BISECTION UNTIL THE DESIRED ACCURACY IS ACHIEVED. ! iloop = 2 xlower = xmin xupper = xmax icount = 0 300 dx = xmid GOTO 500 400 Ppf = xmid RETURN ! !******************************************************************** ! THIS SECTION BELOW IS LOGICALLY SEPARATE FROM THE ABOVE. ! THIS SECTION COMPUTES A CDF VALUE FOR ANY GIVEN TENTATIVE ! PERCENT POINT X VALUE AS DEFINED IN EITHER OF THE 2 ! ITERATION LOOPS IN THE ABOVE CODE. ! ! COMPUTE T-SUB-Q AS DEFINED ON page 4 OF THE WILK, GNANADESIKAN, ! AND HUYETT REFERENCE ! 500 sum = 1.0D0/dgamma term = 1.0D0/dgamma cut1 = dx - dgamma cut2 = dx*10000000000.0D0 DO j = 1 , maxit aj = j term = dx*term/(dgamma+aj) sum = sum + term cutoff = cut1 + (cut2*term/sum) IF ( aj>cutoff ) GOTO 600 ENDDO WRITE (G_IO,99003) maxit ! 99003 FORMAT (' ','*****ERROR IN INTERNAL OPERATIONS in GAMPPF(3f) --The number of iterations exceeds ',I0) WRITE (G_IO,99004) P 99004 FORMAT (' ',' The input value of P is ',E15.8) WRITE (G_IO,99005) Gamma 99005 FORMAT (' ',' The input value of GAMMA is ',E15.8) WRITE (G_IO,99006) 99006 FORMAT (' ',' The output value of PPF has been set to 0.0') Ppf = 0.0_wp RETURN ! 600 t = sum pcalc = (dx**dgamma)*(DEXP(-dx))*t/g IF ( iloop==1 ) THEN IF ( pcalc>=dp ) GOTO 200 xmin = xmax icount = icount + 1 IF ( icount>30000 ) GOTO 200 GOTO 100 ELSE IF ( pcalc==dp ) GOTO 400 IF ( pcalc>dp ) THEN xupper = xmid xmid = (xmid+xlower)/2.0D0 ELSE xlower = xmid xmid = (xmid+xupper)/2.0D0 ENDIF xdel = xmid - xlower IF ( xdel<0.0D0 ) xdel = -xdel icount = icount + 1 IF ( xdel>=0.0000000001D0 .AND. icount<=100 ) GOTO 300 GOTO 400 ENDIF 99007 FORMAT (' ***** The value of the argument is ',E15.8,' *****') ! END SUBROUTINE GAMPPF !> !!##NAME !! gamran(3f) - [M_datapac:RANDOM] generate gamma random numbers !! !!##SYNOPSIS !! !! SUBROUTINE GAMRAN(N,Gamma,Iseed,X) !! !! INTEGER,intent(in) :: N !! INTEGER,intent(inout) :: Iseed !! REAL(kind=wp),intent(in) :: Gamma !! REAL(kind=wp),intent(out) :: X(:) !! !!##DESCRIPTION !! GAMRAN(3f) generates a random sample of size N from the gamma !! distribution with tail length parameter value = GAMMA. !! !! The prototype gamma distribution used herein has mean = GAMMA and !! standard deviation = sqrt(GAMMA). This distribution is defined for !! all positive X, and has the probability density function !! !! f(X) = (1/constant) * (X**(GAMMA-1)) * exp(-X) !! !! where the constant is equal to the Gamma function evaluated at the !! value GAMMA. !! !!##ALGORITHM !! !! Generate N Gamma Distribution random numbers using Greenwood's !! Rejection Algorithm-- !! !! 1. Generate a normal random number; !! !! 2. Transform the normal variate to an approximate gamma variate !! using the Wilson-Hilferty approximation (see the Johnson and Kotz !! reference, page 176); !! !! 3. Form the rejection function value, based !! on the probability density function value !! of the actual distribution of the pseudo-gamma !! variate, and the probability density function value !! of a true gamma variate. !! !! 4. Generate a uniform random number; !! !! 5. If the uniform random number is less than the rejection function !! value, then accept the pseudo-random number as a gamma variate; !! if the uniform random number is larger than the rejection function !! value, then reject the pseudo-random number as a gamma variate. !! !!##INPUT ARGUMENTS !! !! N The desired integer number of random numbers to be generated. !! !! GAMMA The value of the tail length parameter. GAMMA should be !! positive. GAMMA should be larger than 1/3 (algorithmic !! restriction). !! !! ISEED An integer seed value. Should be set to a non-negative value !! to start a new sequence of values. Will be set to -1 on return !! to indicate the next call should continue the current random !! sequence walk. !! !!##OUTPUT ARGUMENTS !! !! X A vector (of dimension at least N) into which the generated !! random sample from the gamma distribution will be placed. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_gamran !! use m_datapac, only : gamran, plott, label, plotxt, sort !! implicit none !! integer,parameter :: n=4000 !! real :: x(n) !! integer :: iseed !! real :: gamma !! call label('gamran') !! gamma=3.4 !! iseed=12345 !! call gamran(n,gamma,iseed,x) !! call plotxt(x,n) !! call sort(x,n,x) ! sort to show distribution !! call plotxt(x,n) !! end program demo_gamran !! !! Results: !! !! THE FOLLOWING IS A PLOT OF X(I) (VERTICALLY) VERSUS I (HORIZONTALLY) !! I-----------I-----------I-----------I-----------I !! 0.1547529E+02 - X X !! 0.1483860E+02 I !! 0.1420192E+02 I !! 0.1356523E+02 I X !! 0.1292854E+02 I X !! 0.1229185E+02 I X X !! 0.1165516E+02 - X !! 0.1101848E+02 I X X X !! 0.1038179E+02 I XX X X X X X X X !! 0.9745100E+01 I X X X XX X X XX X XX X X !! 0.9108413E+01 I X X X XX X XXX XX !! 0.8471725E+01 I X X XX XX X XXXXX XXX X XX X X X X XX X !! 0.7835037E+01 - X XXX XX X XXX X XX XXXXXXX XX XXXX XX X XX !! 0.7198349E+01 I X XXXXX XXXXX XXXX X X XXX XXXXX XXX XXX X X !! 0.6561661E+01 I XXXXXXXXXX XXXXXXXXXXXX XXXXXXXXXXXXXXXXXXXXXXXXX !! 0.5924973E+01 I XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX !! 0.5288285E+01 I XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX !! 0.4651597E+01 I XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX !! 0.4014910E+01 - XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX !! 0.3378222E+01 I XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX !! 0.2741534E+01 I XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX !! 0.2104846E+01 I XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX !! 0.1468158E+01 I XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX !! 0.8314705E+00 I XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX !! 0.1947823E+00 - X X X X XX X X X X XX XXXX X X X XX !! I-----------I-----------I-----------I-----------I !! 0.1000E+01 0.1001E+04 0.2000E+04 0.3000E+04 0.4000E+04 !! !! THE FOLLOWING IS A PLOT OF X(I) (VERTICALLY) VERSUS I (HORIZONTALLY) !! I-----------I-----------I-----------I-----------I !! 0.1547529E+02 - X !! 0.1483860E+02 I !! 0.1420192E+02 I !! 0.1356523E+02 I X !! 0.1292854E+02 I X !! 0.1229185E+02 I X !! 0.1165516E+02 - X !! 0.1101848E+02 I X !! 0.1038179E+02 I X !! 0.9745100E+01 I X !! 0.9108413E+01 I XX !! 0.8471725E+01 I X !! 0.7835037E+01 - XX !! 0.7198349E+01 I X !! 0.6561661E+01 I XXX !! 0.5924973E+01 I XXX !! 0.5288285E+01 I XXXX !! 0.4651597E+01 I XXXXX !! 0.4014910E+01 - XXXXXX !! 0.3378222E+01 I XXXXXXXX !! 0.2741534E+01 I XXXXXXXX !! 0.2104846E+01 I XXXXXXXX !! 0.1468158E+01 I XXXXXXX !! 0.8314705E+00 I XXXX !! 0.1947823E+00 - X !! I-----------I-----------I-----------I-----------I !! 0.1000E+01 0.1001E+04 0.2000E+04 0.3000E+04 0.4000E+04 !! ================================================================================ !! ``` !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !! !!##REFERENCES !! * Greenwood, 'A Fast generator for Gamma-Distributed Random Variables', !! Compstat 1974, Proceedings in Computational Statistics, Vienna, !! September, 1974, pages 19-27. !! * Tocher, The Art of Simulation, 1963, pages 24-27. !! * Hammersley and Handscomb, Monte Carlo Methods, 1964, pages 36-37. !! * Wilk, Gnanadesikan, and Huyett, 'Probability Plots for the Gamma !! Distribution', Technometrics, 1962, pages 1-15. !! * Johnson and Kotz, Continuous Univariate Distributions--1, 1970, !! pages 166-206. !! * Hastings and Peacock, Statistical Distributions--A Handbook for !! Students and Practitioners, 1975, pages 68-73. !! * National Bureau of Standards Applied Mathematics Series 55, 1964, !! page 952. ! VERSION NUMBER--82/7 ! ORIGINAL VERSION--NOVEMBER 1975. ! UPDATED --FEBRUARY 1976. ! UPDATED --JUNE 1978. ! UPDATED --DECEMBER 1981. ! UPDATED --MARCH 1982. ! UPDATED --MAY 1982. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE GAMRAN(N,Gamma,Iseed,X) INTEGER,intent(in) :: N INTEGER,intent(inout) :: Iseed REAL(kind=wp),intent(in) :: Gamma REAL(kind=wp),intent(out) :: X(:) REAL(kind=wp) :: a1, arg, athird, b1, funct, sqrt3, term, u(1), xg, xg0, xn(1), xn0 INTEGER :: i !--------------------------------------------------------------------- DATA athird/0.3333333_wp/ DATA sqrt3/1.73205081_wp/ !-----START POINT----------------------------------------------------- ! ******STILL NEEDS ALGORITHM WORK ****** ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( N<1 ) THEN WRITE (G_IO,99001) 99001 FORMAT (' ***** FATAL ERROR--The first input argument to GAMRAN(3f) is non-positive *****') WRITE (G_IO,99002) N 99002 FORMAT (' ***** The value of the argument is ',I0,' *****') RETURN ELSEIF ( Gamma<=0.0_wp ) THEN WRITE (G_IO,99003) 99003 FORMAT (' ***** FATAL ERROR--The second input argument to GAMRAN(3f) is non-positive *****') WRITE (G_IO,99006) Gamma RETURN ELSEIF ( Gamma<=0.33333333_wp ) THEN WRITE (G_IO,99004) 99004 FORMAT (' ***** FATAL ERROR--The second input argument to GAMRAN(3f) is smaller than or equal to 0.33333333 *****') WRITE (G_IO,99005) 99005 FORMAT (' (algorithmic restriction)') WRITE (G_IO,99006) Gamma RETURN ELSE a1 = 1.0_wp/(9.0_wp*Gamma) b1 = SQRT(a1) xn0 = -sqrt3 + b1 xg0 = Gamma*(1.0_wp-a1+b1*xn0)**3 DO i = 1 , N DO CALL NORRAN(1,Iseed,xn) xg = Gamma*(1.0_wp-a1+b1*xn(1))**3 IF ( xg>=0.0_wp ) THEN term = (xg/xg0)**(Gamma-athird) arg = 0.5_wp*xn(1)*xn(1) - xg - 0.5_wp*xn0*xn0 + xg0 funct = term*EXP(arg) CALL UNIRAN(1,Iseed,u(1:1)) IF ( u(1)<=funct ) THEN X(i) = xg EXIT ENDIF ENDIF ENDDO ENDDO ENDIF 99006 FORMAT (' ','***** The value of the argument is ',E15.8,' *****') ! END SUBROUTINE GAMRAN !> !!##NAME !! geocdf(3f) - [M_datapac:CUMULATIVE_DISTRIBUTION] compute the geometric !! cumulative distribution function !! !!##SYNOPSIS !! !! SUBROUTINE GEOCDF(X,P,Cdf) !! !! REAL(kind=wp),intent(in) :: X !! REAL(kind=wp),intent(in) :: P !! REAL(kind=wp),intent(out) :: Cdf !! !!##DESCRIPTION !! GEOCDF(3f) computes the cumulative distribution function value at the !! REAL value X for the geometric distribution with precision !! precision 'Bernoulli probability' parameter = P. !! !! The geometric distribution used herein herein has mean = (1-P)/P and !! standard deviation = sqrt((1-P)/(P*P))). !! !! This distribution is defined for all non-negative integer X where X = !! 0, 1, 2, ... . This distribution has the probability function !! !! f(X) = P * (1-P)**X !! !! The geometric distribution is the distribution of the number of !! failures before obtaining 1 success in an indefinite sequence of !! Bernoulli (0,1) trials where the probability of success in a precision !! trial = P. !! !! Note that even though the input to this cumulative distribution !! function subroutine for this discrete distribution should (under normal !! circumstances) be a discrete integer value, the input variable X is REAL. !! X has been specified as REAL so as to conform with the datapac convention !! that all input ****data**** (as opposed to sample size, for example) !! variables to all datapac subroutines are. !! !! This convention is based on the belief that !! !! 1. A mixture of modes (floating point versus integer) is inconsistent !! and an unnecessary complication in a data analysis; and !! 2. Floating point machine arithmetic (as opposed to integer !! arithmetic) is the more natural mode for doing data analysis. !! !!##INPUT ARGUMENTS !! !! X The value at which the cumulative distribution function is !! to be evaluated. X should be non-negative and integral-valued. !! P The value of the 'Bernoulli probability' parameter for the !! geometric distribution. P should be between 0.0 (exclusively) !! and 1.0 (exclusively). !! !!##OUTPUT ARGUMENTS !! !! CDF The cumulative distribution function value for the geometric !! distribution !! !!##EXAMPLES !! !! Sample program: !! !! program demo_geocdf !! use M_datapac, only : geocdf !! implicit none !! ! call geocdf(x,y) !! end program demo_geocdf !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !!##MAINTAINER !! John Urban, 2022.05.31 !!##LICENSE !! CC0-1.0 !!##REFERENCES !! * Feller, An Introduction to Probability Theory and its Applications, !! Volume 1, Edition 2, 1957, pages 155-157, 210. !! * National Bureau of Standards Applied Mathematics Series 55, 1964, !! page 929. ! ORIGINAL VERSION--NOVEMBER 1975. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE GEOCDF(X,P,Cdf) REAL(kind=wp),intent(in) :: X REAL(kind=wp),intent(in) :: P REAL(kind=wp),intent(out) :: Cdf REAL(kind=wp) :: del , fintx INTEGER intx ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( P<=0.0_wp .OR. P>=1.0_wp ) THEN WRITE (G_IO,99001) WRITE (G_IO,99004) P Cdf = 0.0_wp ELSEIF ( X<0.0_wp ) THEN WRITE (G_IO,99002) WRITE (G_IO,99004) X Cdf = 0.0_wp ELSE intx = X + 0.0001_wp fintx = intx del = X - fintx IF ( del<0.0_wp ) del = -del IF ( del>0.001_wp ) THEN WRITE (G_IO,99003) WRITE (G_IO,99004) X ENDIF Cdf = 1.0_wp - (1.0_wp-P)**(X+1.0_wp) ENDIF 99001 FORMAT(' ***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE GEOCDF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL *****') 99002 FORMAT(' ***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT TO THE GEOCDF SUBROUTINE IS NEGATIVE *****') 99003 FORMAT(' ***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT TO THE GEOCDF SUBROUTINE IS NON-INTEGRAL *****') 99004 FORMAT(' ***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') END SUBROUTINE GEOCDF !> !!##NAME !! geoplt(3f) - [M_datapac:LINE_PLOT] generate a geometric probability !! plot !! !!##SYNOPSIS !! !! SUBROUTINE GEOPLT(X,N,P) !! !!##DESCRIPTION !! geoplt(3f) generates a geometric probability plot (with 'bernoulli !! probability' parameter value = p). !! !! the geometric distribution used herein has mean = (1-p)/p and standard !! deviation = sqrt((1-p)/(p*p))). this distribution is defined for !! all non-negative integer x--x = 0, 1, 2, ... . this distribution !! has the probability function !! !! f(x) = p * (1-p)**x. !! !! the geometric distribution is the distribution of the number of !! failures before obtaining 1 success in an indefinite sequence of !! bernoulli (0,1) trials where the probability of success in a precision !! trial = p. !! !! as used herein, a probability plot for a distribution is a plot !! of the ordered observations versus the order statistic medians for !! that distribution. !! !! the geometric probability plot is useful in graphically testing !! the composite (that is, location and scale parameters need not be !! specified) hypothesis that the underlying distribution from which !! the data have been randomly drawn is the geometric distribution with !! probability parameter value = p. !! !! if the hypothesis is true, the probability plot should be near-linear. !! !! a measure of such linearity is given by the calculated probability !! plot correlation coefficient. !! !!##OPTIONS !! X description of parameter !! Y description of parameter !! !!##EXAMPLES !! !! Sample program: !! !! program demo_geoplt !! use M_datapac, only : geoplt !! implicit none !! ! call geoplt(x,y) !! end program demo_geoplt !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the Statistical !! Engineering Division, National Institute of Standards and Technology. !!##MAINTAINER !! John Urban, 2022.05.31 !!##LICENSE !! CC0-1.0 !!##REFERENCES !! * FILLIBEN, 'TECHNIQUES FOR TAIL LENGTH ANALYSIS', PROCEEDINGS OF THE !! EIGHTEENTH CONFERENCE ON THE DESIGN OF EXPERIMENTS IN ARMY RESEARCH !! DEVELOPMENT AND TESTING (ABERDEEN, MARYLAND, OCTOBER, 1972), pages !! 425-450. !! * FELLER, AN INTRODUCTION TO PROBABILITY THEORY AND ITS APPLICATIONS, !! VOLUME 1, EDITION 2, 1957, pages 155-157, 210. !! * NATIONAL BUREAU OF STANDARDS APPLIED MATHEMATICS SERIES 55, 1964, !! page 929. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE GEOPLT(X,N,P) REAL(kind=wp) :: an , cc , hold , P , pp0025 , pp025 , pp975 , pp9975 , q , & & sum1 , sum2 , sum3 , tau , W , wbar , WS , X , Y , ybar , & & yint REAL(kind=wp) :: yslope INTEGER i , iupper , N ! ! INPUT ARGUMENTS--X = THE VECTOR OF ! (UNSORTED OR SORTED) OBSERVATIONS. ! --N = THE INTEGER NUMBER OF OBSERVATIONS ! IN THE VECTOR X. ! --P = THE VALUE ! OF THE 'BERNOULLI PROBABILITY' ! PARAMETER FOR THE GEOMETRIC ! DISTRIBUTION. ! P SHOULD BE BETWEEN ! 0.0 (EXCLUSIVELY) AND ! 1.0 (EXCLUSIVELY). ! OUTPUT--A ONE-page GEOMETRIC PROBABILITY PLOT. ! PRINTING--YES. ! RESTRICTIONS--THE MAXIMUM ALLOWABLE VALUE OF N ! FOR THIS SUBROUTINE IS 7500. ! --P SHOULD BE BETWEEN 0.0 (EXCLUSIVELY) ! AND 1.0 (EXCLUSIVELY). ! OTHER DATAPAC SUBROUTINES NEEDED--SORT, UNIMED, PLOT, GEOPPF. ! FORTRAN LIBRARY SUBROUTINES NEEDED--SQRT. ! MODE OF INTERNAL OPERATIONS--. ! ORIGINAL VERSION--NOVEMBER 1975. ! UPDATED --FEBRUARY 1976. ! UPDATED --FEBRUARY 1976. ! UPDATED --MARCH 1987. ! !--------------------------------------------------------------------- ! DIMENSION X(:) DIMENSION Y(7500) , W(7500) COMMON /BLOCK2_real32/ WS(15000) EQUIVALENCE (Y(1),WS(1)) EQUIVALENCE (W(1),WS(7501)) ! iupper = 7500 ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( N<1 .OR. N>iupper ) THEN WRITE (G_IO,99001) iupper 99001 FORMAT (' ', & &'***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE GEOPLT SUBROU& &TINE IS OUTSIDE THE ALLOWABLE (1,',I0,') INTERVAL *****') WRITE (G_IO,99002) N 99002 FORMAT (' ','***** THE VALUE OF THE ARGUMENT IS ',I0,' *****') RETURN ELSEIF ( N==1 ) THEN WRITE (G_IO,99003) 99003 FORMAT (' ', & &'***** NON-FATAL DIAGNOSTIC--THE SECOND INPUT ARGUMENT TO THE GEOP& < SUBROUTINE HAS THE VALUE 1 *****') RETURN ELSE IF ( P<=0.0_wp .OR. P>=1.0_wp ) THEN WRITE (G_IO,99004) 99004 FORMAT (' ', & &'***** FATAL ERROR--THE THIRD INPUT ARGUMENT TO THE GEOPLT SUBROU& &TINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL *****') WRITE (G_IO,99005) P 99005 FORMAT (' ','***** THE VALUE OF THE ARGUMENT IS ',E15.8, & & ' *****') RETURN ELSE hold = X(1) DO i = 2 , N IF ( X(i)/=hold ) GOTO 50 ENDDO WRITE (G_IO,99006) hold 99006 FORMAT (' ', & &'***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT (A VECTOR) & &TO THE GEOPLT SUBROUTINE HAS ALL ELEMENTS = ',E15.8,' *****') RETURN ENDIF ! !-----START POINT----------------------------------------------------- ! 50 an = N ! ! SORT THE DATA ! CALL SORT(X,N,Y) ! ! GENERATE UNIFORM ORDER STATISTIC MEDIANS ! CALL UNIMED(N,W) ! ! COMPUTE GEOMETRIC DISTRIBUTION ORDER STATISTIC MEDIANS ! DO i = 1 , N CALL GEOPPF(W(i),P,W(i)) ENDDO ! ! PLOT THE ORDERED OBSERVATIONS VERSUS ORDER STATISTICS MEDIANS. ! COMPUTE THE TAIL LENGTH MEASURE OF THE DISTRIBUTION. ! WRITE OUT THE TAIL LENGTH MEASURE OF THE DISTRIBUTION ! AND THE SAMPLE SIZE. ! CALL PLOT(Y,W,N) q = 0.9975_wp CALL GEOPPF(q,P,pp9975) q = 0.0025_wp CALL GEOPPF(q,P,pp0025) q = 0.975_wp CALL GEOPPF(q,P,pp975) q = 0.025_wp CALL GEOPPF(q,P,pp025) tau = (pp9975-pp0025)/(pp975-pp025) WRITE (G_IO,99007) P , tau , N ! 99007 FORMAT (' ','GEOMETRIC PROBABILITY PLOT WITH PROBABILITY ', & & 'PARAMETER = ',E17.10,1X,'(TAU = ',E15.8,')',11X, & & 'THE SAMPLE ','SIZE N = ',I0) ! ! COMPUTE THE PROBABILITY PLOT CORRELATION COEFFICIENT. ! COMPUTE LOCATION AND SCALE ESTIMATES ! FROM THE INTERCEPT AND SLOPE OF THE PROBABILITY PLOT. ! THEN WRITE THEM OUT. ! sum1 = 0.0_wp sum2 = 0.0_wp DO i = 1 , N sum1 = sum1 + Y(i) sum2 = sum2 + W(i) ENDDO ybar = sum1/an wbar = sum2/an sum1 = 0.0_wp sum2 = 0.0_wp sum3 = 0.0_wp DO i = 1 , N sum1 = sum1 + (Y(i)-ybar)*(Y(i)-ybar) sum2 = sum2 + (Y(i)-ybar)*(W(i)-wbar) sum3 = sum3 + (W(i)-wbar)*(W(i)-wbar) ENDDO cc = sum2/SQRT(sum3*sum1) yslope = sum2/sum3 yint = ybar - yslope*wbar WRITE (G_IO,99008) cc , yint , yslope 99008 FORMAT (' ','PROBABILITY PLOT CORRELATION COEFFICIENT = ',F8.5,& & 5X,'ESTIMATED INTERCEPT = ',E15.8,3X, & & 'ESTIMATED SLOPE = ',E15.8) ENDIF ! END SUBROUTINE GEOPLT !> !!##NAME !! geoppf(3f) - [M_datapac:PERCENT_POINT] compute the geometric percent !! point function !! !!##SYNOPSIS !! !! SUBROUTINE GEOPPF(P,Ppar,Ppf) !! !!##DESCRIPTION !! geoppf(3f) computes the percent point function value for the geometric !! distribution with REAL 'bernoulli probability' parameter !! = ppar. !! !! the geometric distribution used herein has mean = (1-ppar)/ppar and !! standard deviation = sqrt((1-ppar)/(ppar*ppar))). !! !! this distribution is defined for all non-negative integer x--x = 0, !! 1, 2, ... . !! !! this distribution has the probability function !! !! f(x) = ppar * (1-ppar)**x. !! !! the geometric distribution is the distribution of the number of !! failures before obtaining 1 success in an indefinite sequence of !! bernoulli (0,1) trials where the probability of success in a precision !! trial = ppar. !! !! note that the percent point function of a distribution is identically !! the same as the inverse cumulative distribution function of the !! distribution. !! !!##OPTIONS !! X description of parameter !! Y description of parameter !! !!##EXAMPLES !! !! Sample program: !! !! program demo_geoppf !! use M_datapac, only : geoppf !! implicit none !! ! call geoppf(x,y) !! end program demo_geoppf !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !!##MAINTAINER !! John Urban, 2022.05.31 !!##LICENSE !! CC0-1.0 !!##REFERENCES !! * FELLER, AN INTRODUCTION TO PROBABILITY THEORY AND ITS APPLICATIONS, !! VOLUME 1, EDITION 2, 1957, pages 155-157, 210. !! * NATIONAL BUREAU OF STANDARDS APPLIED MATHEMATICS SERIES 55, 1964, !! page 929. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE GEOPPF(P,Ppar,Ppf) REAL(kind=wp) :: aden , anum , aratio , arg1 , arg2 , P , Ppar , Ppf , ratio INTEGER iratio ! ! INPUT ARGUMENTS--P = THE VALUE ! (BETWEEN 0.0 (INCLUSIVELY) ! AND 1.0 (EXCLUSIVELY)) ! AT WHICH THE PERCENT POINT ! FUNCTION IS TO BE EVALUATED. ! --PPAR = THE VALUE ! OF THE 'BERNOULLI PROBABILITY' ! PARAMETER FOR THE GEOMETRIC ! DISTRIBUTION. ! PPAR SHOULD BE BETWEEN ! 0.0 (EXCLUSIVELY) AND ! 1.0 (EXCLUSIVELY). ! OUTPUT ARGUMENTS--PPF = THE PERCENT ! POINT FUNCTION VALUE. ! OUTPUT--THE PERCENT POINT FUNCTION . ! VALUE PPF FOR THE GEOMETRIC DISTRIBUTION ! WITH 'BERNOULLI PROBABILITY' PARAMETER VALUE = PPAR. ! PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. ! RESTRICTIONS--PPAR SHOULD BE BETWEEN 0.0 (EXCLUSIVELY) ! AND 1.0 (EXCLUSIVELY). ! --P SHOULD BE BETWEEN 0.0 (INCLUSIVELY) ! AND 1.0 (EXCLUSIVELY). ! FORTRAN LIBRARY SUBROUTINES NEEDED--LOG. ! MODE OF INTERNAL OPERATIONS--. ! COMMENT--NOTE THAT EVEN THOUGH THE OUTPUT ! FROM THIS DISCRETE DISTRIBUTION ! PERCENT POINT FUNCTION ! SUBROUTINE MUST NECESSARILY BE A ! DISCRETE INTEGER VALUE, ! THE OUTPUT VARIABLE PPF IS SINGLE ! PRECISION IN MODE. ! PPF HAS BEEN SPECIFIED AS SINGLE ! PRECISION SO AS TO CONFORM WITH THE DATAPAC ! CONVENTION THAT ALL OUTPUT VARIABLES FROM ALL ! DATAPAC SUBROUTINES ARE . ! THIS CONVENTION IS BASED ON THE BELIEF THAT ! 1) A MIXTURE OF MODES (FLOATING POINT ! VERSUS INTEGER) IS INCONSISTENT AND ! AN UNNECESSARY COMPLICATION ! IN A DATA ANALYSIS; AND ! 2) FLOATING POINT MACHINE ARITHMETIC ! (AS OPPOSED TO INTEGER ARITHMETIC) ! IS THE MORE NATURAL MODE FOR DOING ! DATA ANALYSIS. ! ORIGINAL VERSION--NOVEMBER 1975. ! !--------------------------------------------------------------------- ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( P<0.0_wp .OR. P>=1.0_wp ) THEN WRITE (G_IO,99001) 99001 FORMAT (' ', & &'***** FATAL ERROR--THE FIRST INPUT ARGUMENT TO THE GEOPPF SUBROU& &TINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL *****') WRITE (G_IO,99003) P Ppf = 0.0_wp RETURN ELSEIF ( Ppar<=0.0_wp .OR. Ppar>=1.0_wp ) THEN WRITE (G_IO,99002) 99002 FORMAT (' ', & &'***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE GEOPPF SUBROU& &TINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL *****') WRITE (G_IO,99003) Ppar Ppf = 0.0_wp RETURN ! !-----START POINT----------------------------------------------------- ! ELSEIF ( P/=0.0 ) THEN ! arg1 = 1.0_wp - P arg2 = 1.0_wp - Ppar anum = LOG(arg1) aden = LOG(arg2) ratio = anum/aden iratio = ratio Ppf = iratio aratio = iratio IF ( aratio==ratio ) Ppf = iratio - 1 GOTO 99999 ENDIF Ppf = 0.0_wp RETURN 99003 FORMAT (' ','***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') ! 99999 END SUBROUTINE GEOPPF !> !!##NAME !! georan(3f) - [M_datapac:RANDOM] generate geometric random numbers !! !!##SYNOPSIS !! !! !! SUBROUTINE GEORAN(N,P,Iseed,X) !! !! INTEGER,intent(in) :: N !! REAL(kind=wp),intent(in) :: P !! INTEGER,intent(inout) :: Iseed !! REAL(kind=wp),intent(out) :: X(:) !! !!##DESCRIPTION !! GEORAN(3f) generates a random sample of size N from the geometric !! distribution with REAL 'Bernoulli probability' parameter !! = P. !! !! The geometric distribution used herein has mean = (1-P)/P and standard !! deviation = sqrt((1-P)/(P*P))). This distribution is defined for !! all non-negative integer X-- X = 0, 1, 2, ... . !! !! This distribution has the probability function !! !! f(X) = P * (1-P)**X. !! !! The geometric distribution is the distribution of the number of !! failures before obtaining 1 success in an indefinite sequence of !! Bernoulli (0,1) trials where the probability of success in a precision !! trial = P. !! !!##INPUT ARGUMENTS !! N The desired integer number of random numbers to be generated. !! !! ISEED An integer iseed value. Should be set to a non-negative value !! to start a new sequence of values. Will be set to -1 on return !! to indicate the next call should continue the current random !! sequence walk. !! !! P The value of the 'Bernoulli probability' parameter for the !! geometric distribution. P should be between 0.0 (exclusively) !! and 1.0 (exclusively). !! !!##OUTPUT ARGUMENTS !! X A vector (of dimension at least N) into which the generated random !! sample of size N from the geometric distribution will be placed. !! !! !!##EXAMPLES !! !! Sample program: !! !! !! program demo_georan !! use m_datapac, only : georan, plott, label, plotxt, sort !! implicit none !! integer,parameter :: n=4000 !! real :: x(n) !! integer :: iseed !! real :: P !! call label('georan') !! P=0.2 !! iseed=12345 !! call georan(N,P,Iseed,X) !! call plotxt(x,n) !! call sort(x,n,x) ! sort to show distribution !! call plotxt(x,n) !! end program demo_georan !! !! Results: !! !! THE FOLLOWING IS A PLOT OF X(I) (VERTICALLY) VERSUS I (HORIZONTALLY !! I-----------I-----------I-----------I-----------I !! 0.4500000E+02 - X !! 0.4312500E+02 I !! 0.4125000E+02 I !! 0.3937500E+02 I !! 0.3750000E+02 I X !! 0.3562500E+02 I !! 0.3375000E+02 - X !! 0.3187500E+02 I X !! 0.3000000E+02 I !! 0.2812500E+02 I X X !! 0.2625000E+02 I X X X X XX !! 0.2437500E+02 I X X XX X X X X !! 0.2250000E+02 - X X X X X !! 0.2062500E+02 I X X X XX X XX X X X X !! 0.1875000E+02 I X XX X XXX X XX X XX XX XX X XX !! 0.1687500E+02 I X X XX X XXXX X X XXX XX XXXXX XX XX X XXXX !! 0.1500000E+02 I XX X XXXXXXX X X X X XX XXXX X X X X XX !! 0.1312500E+02 I XXXX XXXXXX XXXXXXXXX XXXXXXX X X XXXXXXXX XXXX X !! 0.1125000E+02 - XXXXXXXXXXXXXXXXXXXXXXXX XXXXXXXX XX XXX XXX XX !! 0.9375000E+01 I XXXXXXXXXXXXXXXXX XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX !! 0.7500000E+01 I XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX !! 0.5625000E+01 I XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX !! 0.3750000E+01 I XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX !! 0.1875000E+01 I XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX !! 0.0000000E+00 - XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX !! I-----------I-----------I-----------I-----------I !! 0.1000E+01 0.1001E+04 0.2000E+04 0.3000E+04 0.4000E+04 !! !! THE FOLLOWING IS A PLOT OF X(I) (VERTICALLY) VERSUS I (HORIZONTALLY !! I-----------I-----------I-----------I-----------I !! 0.4500000E+02 - X !! 0.4312500E+02 I !! 0.4125000E+02 I !! 0.3937500E+02 I !! 0.3750000E+02 I X !! 0.3562500E+02 I !! 0.3375000E+02 - X !! 0.3187500E+02 I X !! 0.3000000E+02 I !! 0.2812500E+02 I X !! 0.2625000E+02 I X !! 0.2437500E+02 I X !! 0.2250000E+02 - X !! 0.2062500E+02 I XX !! 0.1875000E+02 I X !! 0.1687500E+02 I X !! 0.1500000E+02 I XX !! 0.1312500E+02 I XX !! 0.1125000E+02 - XX !! 0.9375000E+01 I XXX !! 0.7500000E+01 I XXXXXX !! 0.5625000E+01 I XXXXXX !! 0.3750000E+01 I XXXXXXXXXX !! 0.1875000E+01 I XXXXXXXXXXXXXX !! 0.0000000E+00 - XXXXXXXXXXX !! I-----------I-----------I-----------I-----------I !! 0.1000E+01 0.1001E+04 0.2000E+04 0.3000E+04 0.4000E+04 !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !! !!##REFERENCES !! * Tocher, The Art of Simulation, 1963, pages 14-15. !! * Hammersley and Handscomb, Monte Carlo Methods, 1964, page 36. !! * Feller, An Introduction to Probability Theory and its Applications, !! Volume 1, Edition 2, 1957, pages 155-157, 210. !! * National Bureau of Standards Applied Mathematics Series 55, 1964, !! page 929. ! VERSION NUMBER--82/7 ! ORIGINAL VERSION--NOVEMBER 1975. ! UPDATED --DECEMBER 1981. ! UPDATED --MAY 1982. ! ! COMMENT--NOTE THAT EVEN THOUGH THE OUTPUT FROM THIS DISCRETE RANDOM NUMBER ! GENERATOR MUST NECESSARILY BE A SEQUENCE OF ***INTEGER*** VALUES, ! THE OUTPUT VECTOR X IS SINGLE PRECISION IN MODE. ! X HAS BEEN SPECIFIED AS SINGLE PRECISION SO AS TO CONFORM WITH THE DATAPAC ! CONVENTION THAT ALL OUTPUT VECTORS FROM ALL DATAPAC SUBROUTINES ARE . ! THIS CONVENTION IS BASED ON THE BELIEF THAT ! ! 1. A MIXTURE OF MODES (FLOATING POINT ! VERSUS INTEGER) IS INCONSISTENT AND ! AN UNNECESSARY COMPLICATION ! IN A DATA ANALYSIS; AND ! ! 2. FLOATING POINT MACHINE ARITHMETIC ! (AS OPPOSED TO INTEGER ARITHMETIC) ! IS THE MORE NATURAL MODE FOR DOING ! DATA ANALYSIS. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE GEORAN(N,P,Iseed,X) INTEGER,intent(in) :: N REAL(kind=wp),intent(in) :: P INTEGER,intent(inout) :: Iseed REAL(kind=wp),intent(out) :: X(:) REAL(kind=wp) :: aden, anum, aratio, arg1, arg2, ratio INTEGER :: i, iratio ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( N<1 ) THEN WRITE (G_IO,99001) 99001 FORMAT (' ***** FATAL ERROR--The first input argument to GEORAN(3f) is non-positive *****') WRITE (G_IO,99002) N 99002 FORMAT (' ***** The value of the argument is ',I0,' *****') RETURN ELSEIF ( P<=0.0_wp .OR. P>=1.0_wp ) THEN WRITE (G_IO,99003) 99003 FORMAT (' ***** FATAL ERROR--The second input argument to GEORAN(3f) is outside the allowable (0,1) interval *****') WRITE (G_IO,99004) P 99004 FORMAT (' ***** The value of the argument is ',E15.8,' *****') RETURN ELSE ! ! GENERATE N UNIFORM (0,1) RANDOM NUMBERS; ! CALL UNIRAN(N,Iseed,X) ! ! GENERATE N GEOMETRIC RANDOM NUMBERS ! USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD. ! DO i = 1 , N IF ( X(i)/=0.0_wp ) THEN arg1 = 1.0_wp - X(i) arg2 = 1.0_wp - P anum = LOG(arg1) aden = LOG(arg2) ratio = anum/aden iratio = ratio X(i) = iratio aratio = iratio IF ( aratio==ratio ) X(i) = iratio - 1 ENDIF ENDDO ENDIF END SUBROUTINE GEORAN !> !!##NAME !! hfncdf(3f) - [M_datapac:CUMULATIVE_DISTRIBUTION] compute the half-normal cumulative !! distribution function !! !!##SYNOPSIS !! !! SUBROUTINE HFNCDF(X,Cdf) !! REAL(kind=wp),intent(in) :: X !! REAL(kind=wp),intent(out) :: Cdf !! !!##DESCRIPTION !! HFNCDF(3f) computes the cumulative distribution function value for !! the halfnormal distribution. !! !! The halfnormal distribution used herein has mean = sqrt(2/pi) = !! 0.79788456 and standard deviation = 1. !! !! This distribution is defined for all non-negative x and has the !! probability density function !! !! f(X) = (2/sqrt(2*pi)) * exp(-X*X/2). !! !! The halfnormal distribution used herein is the distribution of the !! variate X = abs(z) where the variate z is normally distributed with !! mean = 0 and standard deviation = 1. !! !!##INPUT ARGUMENTS !! !! X The value at which the cumulative distribution function is !! to be evaluated. X should be non-negative. !! !!##OUTPUT ARGUMENTS !! !! CDF The cumulative distribution function value. !! for the halfnormal distribution !! !!##EXAMPLES !! !! Sample program: !! !! program demo_hfncdf !! !@(#) line plotter graph of cumulative distribution function !! !@(#) for the halfnormal distribution !! use M_datapac, only : hfncdf, plott, label !! implicit none !! real,allocatable :: x(:), y(:) !! integer :: i !! call label('hfncdf') !! x=[(real(i),i=0,100,1)] !! if(allocated(y))deallocate(y) !! allocate(y(size(x))) !! do i=1,size(x) !! call hfncdf(x(i)/10.0,y(i)) !! enddo !! call plott(x,y,size(x)) !! end program demo_hfncdf !! Results: !! !! The following is a plot of Y(I) (vertically) versus X(I) (horizontally) !! I-----------I-----------I-----------I-----------I !! 0.1000000E+03 - X !! 0.9583334E+02 I X !! 0.9166666E+02 I X !! 0.8750000E+02 I X !! 0.8333334E+02 I X !! 0.7916667E+02 I X !! 0.7500000E+02 - X !! 0.7083334E+02 I X !! 0.6666667E+02 I X !! 0.6250000E+02 I X !! 0.5833334E+02 I X !! 0.5416667E+02 I X !! 0.5000000E+02 - X !! 0.4583334E+02 I X !! 0.4166667E+02 I X !! 0.3750000E+02 I X !! 0.3333334E+02 I X !! 0.2916667E+02 I X !! 0.2500000E+02 - XX !! 0.2083334E+02 I XXX !! 0.1666667E+02 I XXXX !! 0.1250000E+02 I X X XX !! 0.8333336E+01 I X X X X !! 0.4166672E+01 I X X X X !! 0.0000000E+00 - X X X !! I-----------I-----------I-----------I-----------I !! -0.1192E-06 0.2500E+00 0.5000E+00 0.7500E+00 0.1000E+01 !! ================================================================================ !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !! !!##REFERENCES !! * Johnson and Kotz, Continuous Univariate Distributions--1, 1970, !! pages 53, 59, 81, 83. !! * Daniel, 'Use of Half-Normal Plots in Interpreting Factorial Two-level !! Experiments', Technometrics, 1959, pages 311-341. ! ORIGINAL VERSION--NOVEMBER 1975. ! UPDATED --OCTOBER 1976. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 subroutine hfncdf(X,Cdf) real(kind=wp),intent(in) :: X real(kind=wp),intent(out) :: Cdf ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! if ( X<0.0_wp ) then write (G_io,99001) 99001 format (' ***** NON-FATAL DIAGNOSTIC--The first input argument to HFNCDF(3f) is negative *****') write (G_io,99002) X 99002 format (' ***** The value of the argument is ',E15.8,' *****') Cdf = 0.0_wp return else call norcdf(X,Cdf) Cdf = 2.0_wp*Cdf - 1.0_wp endif end subroutine hfncdf !> !!##NAME !! hfnplt(3f) - [M_datapac:LINE_PLOT] generate a half-normal probability !! plot !! !!##SYNOPSIS !! !! SUBROUTINE HFNPLT(X,N) !! !! REAL(kind=wp),intent(in) :: X(:) !! INTEGER,intent(in) :: N !! !!##DESCRIPTION !! HFNPLT(3f) generates a halfnormal probability plot. !! !! The prototype halfnormal distribution used herein has mean = sqrt(2/pi) !! = 0.79788456 and standard deviation = 1. !! !! This distribution is defined for all non-negative X and has the !! probability density function !! !! f(X) = (2/sqrt(2*pi)) * exp(-X*X/2) !! !! The prototype halfnormal distribution used herein is the distribution !! of the variate X = abs(Z) where the variate Z is normally distributed !! with mean = 0 and standard deviation = 1. !! !! As used herein, a probability plot for a distribution is a plot !! of the ordered observations versus the order statistic medians for !! that distribution. !! !! The halfnormal probability plot is useful in graphically testing !! the composite (that is, location and scale parameters need not be !! specified) hypothesis that the underlying distribution from which !! the data have been randomly drawn is the halfnormal distribution. !! !! If the hypothesis is true, the probability plot should be near-linear. !! !! A measure of such linearity is given by the calculated probability !! plot correlation coefficient. !! !!##OPTIONS !!##INPUT ARGUMENTS !! X The vector of (unsorted or sorted) observations. !! N The integer number of observations in the vector X. !! The maximum allowable value of N for this subroutine is 7500. !!##OUTPUT !! A one-page halfnormal probability plot. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_hfnplt !! use M_datapac, only : hfnplt !! implicit none !! ! call hfnplt(x,y) !! end program demo_hfnplt !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !! !!##REFERENCES !! * Daniel, 'Use of Half-Normal Plots in Interpreting Factorial Two-Level !! Experiments', Technometrics, 1959, pages 311-341. !! * Filliben, 'Techniques for Tail Length Analysis', Proceedings of the !! Eighteenth Conference on the Design of Experiments in Army Research !! Development and Testing (Aberdeen, Maryland, October, 1972), pages !! 425-450. !! * Hahn anD Shapiro, Statistical Methods in Engineering, 1967, pages !! 260-308. !! * Johnson and Kotz, Continuous Univariate Distributions--1, 1970, !! pages 53, 59, 81, 83. ! ORIGINAL VERSION--JUNE 1972. ! UPDATED --SEPTEMBER 1975. ! UPDATED --NOVEMBER 1975. ! UPDATED --FEBRUARY 1976. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE HFNPLT(X,N) REAL(kind=wp),intent(in) :: X(:) INTEGER,intent(in) :: N REAL(kind=wp) :: W(7500), Y(7500) REAL(kind=wp) :: an , cc , hold , q , sum1 , sum2 , sum3 , tau , wbar , WS , ybar , yint , yslope INTEGER :: i , iupper COMMON /BLOCK2_real32/ WS(15000) EQUIVALENCE (Y(1),WS(1)) EQUIVALENCE (W(1),WS(7501)) ! DATA tau/1.41223913_wp/ ! iupper = 7500 ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( N<1 .OR. N>iupper ) THEN WRITE (G_IO,99001) iupper 99001 FORMAT (' ***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO HFNPLT(3f) IS OUTSIDE THE ALLOWABLE (1,', & & I0,') INTERVAL *****') WRITE (G_IO,99002) N 99002 FORMAT (' ','***** THE VALUE OF THE ARGUMENT IS ',I0,' *****') RETURN ELSEIF ( N==1 ) THEN WRITE (G_IO,99003) 99003 FORMAT (' ***** NON-FATAL DIAGNOSTIC--THE SECOND INPUT ARGUMENT TO HFNPLT(3f) HAS THE VALUE 1 *****') RETURN ELSE hold = X(1) DO i = 2 , N IF ( X(i)/=hold ) GOTO 50 ENDDO WRITE (G_IO,99004) hold 99004 FORMAT (' ***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT (A VECTOR) TO HFNPLT(3f) HAS ALL ELEMENTS = ',& & E15.8,' *****') ! !-----START POINT----------------------------------------------------- ! 50 continue an = N ! ! SORT THE DATA ! CALL SORT(X,N,Y) ! ! GENERATE UNIFORM ORDER STATISTIC MEDIANS ! CALL UNIMED(N,W) ! ! COMPUTE HALFNORMAL ORDER STATISTIC MEDIANS ! DO i = 1 , N q = W(i) q = (q+1.0_wp)/2.0_wp CALL NORPPF(q,W(i)) ENDDO ! ! PLOT THE ORDERED OBSERVATIONS VERSUS ORDER STATISTICS MEDIANS. ! WRITE OUT THE TAIL LENGTH MEASURE OF THE DISTRIBUTION ! AND THE SAMPLE SIZE. ! CALL PLOT(Y,W,N) WRITE (G_IO,99005) tau , N 99005 FORMAT (' ','HALFNORMAL PROBABILITY PLOT (TAU = ',E15.8,')',52X,'THE SAMPLE SIZE N = ',I0) ! ! COMPUTE THE PROBABILITY PLOT CORRELATION COEFFICIENT. COMPUTE LOCATION AND SCALE ESTIMATES ! FROM THE INTERCEPT AND SLOPE OF THE PROBABILITY PLOT. THEN WRITE THEM OUT. ! sum1 = 0.0_wp sum2 = 0.0_wp DO i = 1 , N sum1 = sum1 + Y(i) sum2 = sum2 + W(i) ENDDO ybar = sum1/an wbar = sum2/an sum1 = 0.0_wp sum2 = 0.0_wp sum3 = 0.0_wp DO i = 1 , N sum1 = sum1 + (Y(i)-ybar)*(Y(i)-ybar) sum2 = sum2 + (Y(i)-ybar)*(W(i)-wbar) sum3 = sum3 + (W(i)-wbar)*(W(i)-wbar) ENDDO cc = sum2/SQRT(sum3*sum1) yslope = sum2/sum3 yint = ybar - yslope*wbar WRITE (G_IO,99006) cc , yint , yslope 99006 FORMAT (' ','PROBABILITY PLOT CORRELATION COEFFICIENT = ',F8.5,& & 5X,'ESTIMATED INTERCEPT = ',E15.8,3X,'ESTIMATED SLOPE = ',E15.8) ENDIF ! END SUBROUTINE HFNPLT !> !!##NAME !! hfnppf(3f) - [M_datapac:PERCENT_POINT] compute the half-normal percent !! point function !! !!##SYNOPSIS !! !! SUBROUTINE HFNPPF(P,Ppf) !! !! REAL(kind=wp),intent(in) :: P !! REAL(kind=wp),intent(out) :: Ppf !! !!##DESCRIPTION !! HFNPPF(3f) computes the percent point function value for the halfnormal !! distribution. !! !! The halfnormal distribution used herein has mean = sqrt(2/pi) = !! 0.79788456 and standard deviation = 1. this distribution is defined !! for all non-negative X and has the probability density function !! !! f(X) = (2/sqrt(2*pi)) * exp(-X*X/2). !! !! The halfnormal distribution used herein is the distribution of the !! variate X = abs(Z) where the variate Z is normally distributed with !! mean = 0 and standard deviation = 1. !! !! Note that the percent point function of a distribution is identically !! the same as the inverse cumulative distribution function of the !! distribution. !! !!##INPUT ARGUMENTS !! !! P The value (between 0.0 (inclusively) and 1.0 (exclusively)) !! at which the percent point function is to be evaluated. !! !!##OUTPUT ARGUMENTS !! !! PPF The percent point function value for the halfnormal !! distribution !! !!##EXAMPLES !! !! Sample program: !! !! program demo_hfnppf !! use M_datapac, only : hfnppf !! implicit none !! ! call hfnppf(x,y) !! end program demo_hfnppf !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !! !!##REFERENCES !! * Johnson and Kotz, Continuous Univariate Distributions--1, 1970, !! pages 53, 59, 81, 83. !! * Daniel, 'Use of Half-Normal Plots in Interpreting Factorial Two-Level !! Experiments', Technometrics, 1959, pages 311-341. ! ORIGINAL VERSION--NOVEMBER 1975. ! UPDATED --OCTOBER 1976. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE HFNPPF(P,Ppf) REAL(kind=wp),intent(in) :: P REAL(kind=wp),intent(out) :: Ppf REAL(kind=wp) :: arg ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( P<0.0_wp .OR. P>=1.0_wp ) THEN WRITE (G_IO,99001) 99001 FORMAT(' ***** FATAL ERROR--THE FIRST INPUT ARGUMENT TO HFNPPF(3f) IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL *****') WRITE (G_IO,99002) P 99002 FORMAT (' ***** THE VALUE OF THE ARGUMENT IS ',E15.8, ' *****') Ppf = 0.0_wp ELSE arg = (1.0_wp+P)/2.0_wp CALL NORPPF(arg,Ppf) IF ( Ppf<=0.0_wp ) Ppf = 0.0_wp ENDIF ! END SUBROUTINE HFNPPF !> !!##NAME !! hfnran(3f) - [M_datapac:RANDOM] generate half-normal random numbers !! !!##SYNOPSIS !! !! SUBROUTINE HFNRAN(N,Iseed,X) !! !! INTEGER,intent(in) :: N !! INTEGER,intent(inout) :: Iseed !! REAL(kind=wp),intent(out) :: X(:) !! !!##DESCRIPTION !! HFNRAN(3f) generates a random sample of size n from the halfnormal !! distribution. !! !! The prototype halfnormal distribution used herein has mean = sqrt(2/pi) !! = 0.79788456 and standard deviation = 1. this distribution is defined !! for all non-negative X and has the probability density function !! !! f(X) = (2/sqrt(2*pi)) * exp(-X*X/2). !! !! The prototype halfnormal distribution used herein is the distribution !! of the variate X = abs(Z) where the variate Z is normally distributed !! with mean = 0 and standard deviation = 1. !! !!##INPUT ARGUMENTS !! !! N = The desired integer number of random numbers to be generated. !! !! ISEED An integer iseed value. Should be set to a non-negative value !! to start a new sequence of values. Will be set to -1 on return !! to indicate the next call should continue the current random !! sequence walk. !! !!##OUTPUT ARGUMENTS !! X = A vector (of dimension at least N) into which the generated !! random sample from the halfnormal distribution will be placed. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_hfnran !! use M_datapac, only : hfnran !! implicit none !! ! call hfnran(x,y) !! end program demo_hfnran !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !! !!##REFERENCES !! * TOCHER, THE ART OF SIMULATION, 1963, pages 14-15. !! * HAMMERSLEY AND HANDSCOMB, MONTE CARLO METHODS, 1964, page 36. !! * JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE DISTRIBUTIONS--1, 1970, !! pages 53, 59, 81, 83. ! VERSION NUMBER--82/7 ! ORIGINAL VERSION--NOVEMBER 1975. ! UPDATED --JULY 1976. ! UPDATED --DECEMBER 1981. ! UPDATED --MAY 1982. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 subroutine hfnran(N,Iseed,X) integer,intent(in) :: N integer,intent(inout) :: Iseed real(kind=wp),intent(out) :: X(:) real(kind=wp) :: arg1 , arg2 , sqrt1 , u1 , u2 , y(2) , z1 , z2 integer :: i , ip1 ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! if ( N<1 ) then write (G_io,99001) 99001 format (' ***** FATAL ERROR--The first input argument to HFNRAN(3f) is non-positive *****') WRITE (G_IO,99002) N 99002 FORMAT (' ***** The value of the argument is ',I0,' *****') RETURN else ! ! GENERATE N UNIFORM (0,1) RANDOM NUMBERS; ! THEN GENERATE 2 ADDITIONAL UNIFORM (0,1) RANDOM NUMBERS ! (TO BE USED BELOW IN FORMING THE N-TH NORMAL RANDOM NUMBER WHEN THE DESIRED SAMPLE SIZE N HAPPENS TO BE ODD). ! call uniran(N,Iseed,X) call uniran(2,Iseed,y) ! ! GENERATE N NORMAL RANDOM NUMBERS USING THE BOX-MULLER METHOD. ! do i = 1 , N , 2 ip1 = i + 1 u1 = X(i) if ( i==N ) then u2 = y(2) else u2 = X(ip1) endif arg1 = -2.0_wp*LOG(u1) arg2 = 2.0_wp*G_pi*u2 sqrt1 = SQRT(arg1) z1 = sqrt1*COS(arg2) z2 = sqrt1*SIN(arg2) X(i) = z1 IF ( i/=N ) X(ip1) = z2 enddo ! ! GENERATE N HALFNORMAL RANDOM NUMBERS USING THE DEFINITION THAT A HALFNORMAL VARIATE ! EQUALS THE ABSOLUTE VALUE OF A NORMAL VARIATE. ! do i = 1 , N if ( X(i)<0.0_wp ) X(i) = -X(i) enddo endif ! end subroutine hfnran !> !!##NAME !! hist(3f) - [M_datapac:STATISTICS] generates histograms based on two !! different class widths !! !!##SYNOPSIS !! !! SUBROUTINE HIST(X,N) !! !! REAL(kind=wp),intent(in) :: X(:) !! INTEGER,intent(in) :: N !! !!##DESCRIPTION !! HIST(3f) produces 2 histograms (with differing class widths) of the !! data in the input vector X. !! !! The first histogram has class width = 0.1 sample standard deviations; !! the second histogram has class width = 0.2 sample standard deviations. !! !! Two histograms of the same data set are printed out so as to give !! the data analyst some feel for how dependent the histogram shape is !! as a function of the class width and number of classes. !! !!##INPUT ARGUMENTS !! X The vector of (unsorted or sorted) observations. !! N The integer number of observations in the vector X. !! !!##OUTPUT !! One page of automatic printout consisting of 2 half-page histograms (with !! class widths = 0.1 and 0.2 sAmple standard deviations, respectively) !! of the data in the input vector X. !! !! !!##EXAMPLES !! !! Sample program: !! !! program demo_hist !! use M_datapac, only : hist !! implicit none !! real,allocatable :: x(:) !! integer :: i !! integer :: n !! x=[(real(i),i=1,100)] !! n=size(x) !! call hist(x,n) !! end program demo_hist !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !! !!##REFERENCES !! * Kendall and Stuart, The Advanced Theory of Statistics, Volume 1, !! Edition 2, 1963, page 4. ! ORIGINAL VERSION--DECEMBER 1972. ! UPDATED --JANUARY 1975. ! UPDATED --NOVEMBER 1975. ! UPDATED --FEBRUARY 1976. ! UPDATED --FEBRUARY 1976. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE HIST(X,N) REAL(kind=wp),intent(in) :: X(:) INTEGER,intent(in) :: N REAL(kind=wp) :: acount, ai, amaxfr, an, cwidsd, cwidth, height, hold, prop, s, sum, tinc, tlable, xbar, xmax, xmin, z INTEGER :: i, icoun2, icount, ievodd, ihist, inc, irev, itlabl, ixlabl, j, jmax, jp1, jsum, maxfre, mt, mx, numcla, numhis INTEGER :: numout CHARACTER(len=4) :: blank , hyphen , alphai , alphax CHARACTER(len=4) :: IGRaph DIMENSION ixlabl(21) COMMON /BLOCK1/ IGRaph(55,130) DIMENSION icount(121) , icoun2(121) DIMENSION tlable(13) , itlabl(13) DATA blank , hyphen , alphai , alphax/' ' , '-' , 'I' , 'X'/ ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( N<1 ) THEN WRITE (G_IO,99001) 99001 FORMAT (' ***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO HIST(3f) IS NON-POSITIVE *****') WRITE (G_IO,99002) N 99002 FORMAT (' ','***** THE VALUE OF THE ARGUMENT IS ',I0,' *****') RETURN ELSE IF ( N==1 ) THEN WRITE (G_IO,99003) 99003 FORMAT (' ***** FATAL ERROR-- THE SECOND INPUT ARGUMENT TO HIST(3f) HAS THE VALUE 1 *****') RETURN ELSE hold = X(1) DO i = 2 , N IF ( X(i)/=hold ) GOTO 50 ENDDO WRITE (G_IO,99004) hold 99004 FORMAT (' ***** FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT (A VECTOR) TO HIST(3f) HAS ALL ELEMENTS = ',& & E15.8,' *****') RETURN ENDIF ! !-----START POINT----------------------------------------------------- ! 50 continue numhis = 2 an = N ! ! FIND THE MINIMUM AND THE MAXIMUM xmin = X(1) xmax = X(1) DO i = 1 , N IF ( X(i)<xmin ) xmin = X(i) IF ( X(i)>xmax ) xmax = X(i) ENDDO ! ! COMPUTE THE SAMPLE MEAN AND SAMPLE STANDARD DEVIATION ! sum = 0.0_wp DO i = 1 , N sum = sum + X(i) ENDDO xbar = sum/an sum = 0.0_wp DO i = 1 , N sum = sum + (X(i)-xbar)**2 ENDDO s = SQRT(sum/(an-1.0_wp)) ! ! FORM THE BASIC FREQUENCY TABLE (ICOUNT) WHICH CORRESPONDS TO A HISTOGRAM ! WITH 121 CLASSES AND A CLASS WIDTH OF ONE TENTH A SAMPLE STANDARD ! DEVIATION. ! DO i = 1 , 121 icount(i) = 0 ENDDO ! numout = 0 DO i = 1 , N z = (X(i)-xbar)/s mt = 10.0_wp*(z+6.0_wp) + 2.5_wp IF ( mt<2 .OR. mt>122 ) numout = numout + 1 IF ( mt>=2 .AND. mt<=122 ) icount(mt) = icount(mt) + 1 ENDDO ! ! LOOP THROUGH NUMHIS (= 2) HISTOGRAMS ! NOTE THAT NUMHIS WAS PREVIOUSLY SET TO 6 (BEFORE JANUARY 1975) ! DO ihist = 1 , numhis ! ! ZERO OUT THE MINI-GRAPH ! DO i = 1 , 22 DO j = 1 , 123 IGRaph(i,j) = blank ENDDO ENDDO ! ! PRODUCE THE HORIZONTAL AXES ! DO j = 2 , 122 IGRaph(1,j) = hyphen IGRaph(22,j) = hyphen ENDDO DO j = 2 , 122 , 10 IGRaph(1,j) = alphai IGRaph(22,j) = alphai ENDDO ! ! PRODUCE THE VERTICAL AXES ! DO i = 2 , 21 IGRaph(i,1) = alphai IGRaph(i,123) = alphai ENDDO DO i = 2 , 21 , 5 IGRaph(i,1) = hyphen IGRaph(i,123) = hyphen ENDDO inc = ihist IF ( ihist==4 ) inc = 5 IF ( ihist==5 ) inc = 10 IF ( ihist==6 ) inc = 20 ! ! FORM THE FREQUENCY TABLE FOR THIS PARTICULAR HISTOGRAM ! icoun2(1) = icount(1) DO i = 2 , 121 , inc jmax = i + inc - 1 jsum = 0 DO j = i , jmax jsum = jsum + icount(j) ENDDO DO j = i , jmax icoun2(j) = jsum ENDDO ENDDO ! ! DETERMINE THE MAXIMUM FREQUENCY ! maxfre = icoun2(1) DO i = 1 , 121 IF ( icoun2(i)>maxfre ) maxfre = icoun2(i) ENDDO ! ! DETERMINE THE PLOT POSITIONS ! amaxfr = maxfre height = 20.0_wp DO j = 1 , 121 jp1 = j + 1 IF ( maxfre<=20 ) mx = icoun2(j) IF ( maxfre>20 ) THEN acount = icoun2(j) prop = acount/amaxfr mx = prop*height + 0.999_wp ENDIF IF ( mx/=0 ) THEN DO i = 1 , mx irev = 22 - i IGRaph(irev,jp1) = alphax ENDDO ENDIF IF ( icoun2(j)>=1 ) IGRaph(21,jp1) = alphax ENDDO ! ! DETERMINE THE X VALUES TO BE LISTED ON THE LEFT LEFT VERTICAL AXIS ! IF ( maxfre>=21 ) THEN DO i = 1 , 20 irev = 22 - i ai = i prop = ai/20.0_wp ixlabl(irev) = prop*amaxfr + 0.5_wp ENDDO ELSE DO i = 1 , 20 irev = 22 - i ixlabl(irev) = i ENDDO ENDIF ! ! WRITE EVERYTHING OUT ! ievodd = ihist - 2*(ihist/2) IF ( ievodd==0 ) THEN WRITE (G_IO,99005) 99005 FORMAT (' ') ELSE WRITE (G_IO,99006) 99006 FORMAT ('1') ENDIF WRITE (G_IO,99013) (IGRaph(1,j),j=1,123) 99013 FORMAT (' ',6X,123A1) DO i = 2 , 21 WRITE (G_IO,99007) ixlabl(i) , (IGRaph(i,j),j=1,123) 99007 FORMAT (' ',I5,1X,123A1) ENDDO WRITE (G_IO,99013) (IGRaph(22,j),j=1,123) numcla = (120/inc) + 1 tinc = inc cwidsd = tinc*0.1_wp cwidth = cwidsd*s tlable(7) = xbar itlabl(7) = 0 DO i = 1 , 6 irev = 13 - i + 1 ai = i tlable(i) = xbar - (7.0_wp-ai)*s tlable(irev) = xbar + (7.0_wp-ai)*s itlabl(i) = i - 7 itlabl(irev) = 7 - i ENDDO WRITE (G_IO,99008) (tlable(i),i=1,13) 99008 FORMAT (' ',1X,12F10.4,F9.4) WRITE (G_IO,99009) (itlabl(i),i=1,13) 99009 FORMAT (' ',13(1X,I7,2X)) WRITE (G_IO,99010) numout 99010 FORMAT (' ',I0, & & ' OBSERVATIONS WERE IN EXCESS OF 6 SAMPLE STANDARD DEVIATIONS ABOUT THE SAMPLE MEAN AND SO WERE NOT PLOTTED') WRITE (G_IO,99011) numcla , cwidth , cwidsd 99011 FORMAT (' HISTOGRAM THE NUMBER OF CLASSES IS ',I0,& & 8X,'THE CLASS WIDTH IS ',E15.8,' = ',F7.1,' STANDARD DEVIATIONS') WRITE (G_IO,99012) N 99012 FORMAT (' ','THE SAMPLE SIZE N = ',I0) ENDDO ENDIF END SUBROUTINE HIST !> !!##NAME !! invxwx(3f) - [M_datapac:STATISTICS] compute the inverse of X'WX !! !!##SYNOPSIS !! !! SUBROUTINE INVXWX(N,K) !! !!##DESCRIPTION !! INVXWX(3f) computes the inverse of X'WX which is done by computing !! the inverse of R'R (where r has just recently been modified before !! calling this subroutine. The input r = the square root of the !! diagonal matrix D times the old matrix R. the inverse of X'WX will !! be identical (except for the absence of S**2 = the residual variance) !! to the covariance matrix of the coefficients. !! !! the only reason INVXWX(3f) exists is for the calculation of such !! covariances. !! !! Unpivoting has also been done herein so as to undo the pivoting done !! in the decomposition subroutine (DECOMP(3f)). The matrix C used herein !! is an intermediate result matrix. !! !! x--not used !! q--not used !! r--used and changed !! d--not used !! ipivot--used !! !!##OPTIONS !! X description of parameter !! Y description of parameter !! !!##EXAMPLES !! !! Sample program: !! !! program test_invxwx !! use M_datapac, only : invxwx !! implicit none !! ! private routine !! ! call invxwx(x,y) !! end program test_invxwx !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !!##MAINTAINER !! John Urban, 2022.05.31 !!##LICENSE !! CC0-1.0 ! UPDATED --NOVEMBER 1975. ! UPDATED --FEBRUARY 1976. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE INVXWX(N,K) REAL(kind=wp) :: anegri, D, dotpro, DUM1, DUM2, dum3, Q, R, ri, WS INTEGER i, ii, im1, ip1, IPIvot, irarg, irarg1, irarg2, irarg3, j, jj, K, l, N ! INVERSION ALGORITHM USED--CHOLESKI DECOMPOSITION !--------------------------------------------------------------------- ! DIMENSION Q(10000) , R(2500) , D(50) , IPIvot(50) COMMON /BLOCK2_real32/ WS(15000) COMMON /BLOCK3_real32/ DUM1(3000) , DUM2(3000) EQUIVALENCE (Q(1),WS(1)) EQUIVALENCE (R(1),WS(10001)) EQUIVALENCE (D(1),WS(12501)) EQUIVALENCE (IPIvot(1),WS(12551)) DIMENSION dum3(200) ! !-----START POINT----------------------------------------------------- ! DO i = 1 , K im1 = i - 1 IF ( im1>=1 ) THEN DO j = 1 , im1 irarg = (i-1)*K + j R(irarg) = 0.0_wp ENDDO ENDIF ENDDO DO jj = 1 , K j = K + 1 - jj DO ii = 1 , j i = j + 1 - ii ip1 = i + 1 IF ( ip1<=K ) THEN DO l = ip1 , K irarg1 = (i-1)*K + l irarg2 = (j-1)*K + l irarg3 = (l-1)*K + j DUM1(l) = R(irarg1) IF ( l<j ) DUM2(l) = R(irarg2) IF ( l==j ) DUM2(l) = dum3(l) IF ( l>j ) DUM2(l) = R(irarg3) ENDDO ENDIF ri = 0.0_wp irarg = (i-1)*K + i IF ( i==j ) ri = 1.0_wp/R(irarg) anegri = -ri ! CALL DOT(DUM1,DUM2,ip1,K,anegri,dotpro) ! irarg = (i-1)*K + i dotpro = -dotpro/R(irarg) IF ( i==j ) dum3(i) = dotpro irarg = (j-1)*K + i IF ( i<j ) R(irarg) = dotpro ENDDO ENDDO DO i = 1 , K irarg = (i-1)*K + i R(irarg) = dum3(i) ENDDO ! ! MATRIX C NOW EQUALS THE INVERSE OF R'R. ! NOW 'UNPIVOT' ON C AND PUT THE RESULTS BACK INTO R. ! DO i = 1 , K ii = IPIvot(i) DO j = 1 , i jj = IPIvot(j) irarg1 = (ii-1)*K + jj irarg2 = (i-1)*K + j irarg3 = (jj-1)*K + ii IF ( ii<jj ) R(irarg1) = R(irarg2) IF ( ii==jj ) dum3(ii) = R(irarg2) IF ( ii>jj ) R(irarg3) = R(irarg2) ENDDO ENDDO DO i = 1 , K irarg = (i-1)*K + i R(irarg) = dum3(i) ENDDO END SUBROUTINE INVXWX !> !!##NAME !! lamcdf(3f) - [M_datapac:CUMULATIVE_DISTRIBUTION] compute the !! Tukey-Lambda cumulative distribution function !! !!##SYNOPSIS !! !! SUBROUTINE LAMCDF(X,Alamba,Cdf) !! !! REAL(kind=wp),intent(in) :: X !! REAL(kind=wp),intent(in) :: Alamba !! REAL(kind=wp),intent(out) :: Cdf !! !!##DESCRIPTION !! LAMCDF(3f) computes the cumulative distribution function value for the !! (Tukey) lambda distribution with tail length parameter value = ALAMBA. !! In general, the probability density function for this distribution !! is not simple. !! !! The percent point function for this distribution is !! !! g(P) = ((P**ALAMBA)-((1-P)**ALAMBA))/ALAMBA !! !!##INPUT ARGUMENTS !! X The value at which the cumulative distribution function is !! to be evaluated. !! !! For ALAMBA non-positive, no restrictions on X. !! For ALAMBA positive, X should be between (-1/ALAMBA) and !! (+1/ALAMBA), inclusively. !! !! ALAMBA The value of lambda (the tail length parameter). !! !!##OUTPUT ARGUMENTS !! CDF The cumulative distribution function value for the Tukey !! lambda distribution. !! !!##EXAMPLES !! !! Sample program: !! !! !! program demo_lamcdf !! !@(#) line plotter graph of cumulative distribution function !! use M_datapac, only : lamcdf, plott, label !! implicit none !! real,allocatable :: x(:), y(:) !! real :: alamba !! integer :: i !! call label('lamcdf') !! alamba=4.0 !! x=[(real(i)/100.0/alamba,i=-100,100,1)] !! if(allocated(y))deallocate(y) !! allocate(y(size(x))) !! do i=1,size(x) !! call lamcdf(X(i),Alamba,y(i)) !! enddo !! call plott(x,y,size(x)) !! end program demo_lamcdf !! !! Results: !! !! The following is a plot of Y(I) (vertically) versus X(I) (horizontally) !! I-----------I-----------I-----------I-----------I !! 0.2500000E+00 - X !! 0.2291667E+00 I XX !! 0.2083333E+00 I XX !! 0.1875000E+00 I XX !! 0.1666667E+00 I XX !! 0.1458333E+00 I XXX !! 0.1250000E+00 - XX !! 0.1041667E+00 I XX !! 0.8333333E-01 I XX !! 0.6250000E-01 I XXX !! 0.4166666E-01 I XXXX !! 0.2083333E-01 I XXXX !! 0.0000000E+00 - XXXXX !! -0.2083334E-01 I XXXX !! -0.4166669E-01 I XXXX !! -0.6250000E-01 I XXX !! -0.8333334E-01 I XX !! -0.1041667E+00 I XX !! -0.1250000E+00 - XX !! -0.1458333E+00 I XXX !! -0.1666667E+00 I XX !! -0.1875000E+00 I XX !! -0.2083333E+00 I XX !! -0.2291667E+00 I XX !! -0.2500000E+00 - X !! I-----------I-----------I-----------I-----------I !! 0.0000E+00 0.2500E+00 0.5000E+00 0.7500E+00 0.1000E+01 !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !! !!##REFERENCES !! * Hastings, Mosteller, Tukey, and windsor, 'Low MOments for Small !! Samples: A Comparative Study of Order Statistics', Annals of !! Mathematical Statistics, 18, 1947, pages 413-426. !! * Filliben, Simple and Robust Linear Estimation of the Location !! Parameter of a Symmetric Distribution (Unpublished PH.D. Dissertation, !! Princeton University), 1969, pages 42-44, 53-58. ! ORIGINAL VERSION--JUNE 1972. ! UPDATED --MAY 1974. ! UPDATED --SEPTEMBER 1975. ! UPDATED --NOVEMBER 1975. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE LAMCDF(X,Alamba,Cdf) REAL(kind=wp),intent(in) :: X REAL(kind=wp),intent(in) :: Alamba REAL(kind=wp),intent(out) :: Cdf REAL(kind=wp) :: pdel , plower , pmax , pmid , pmin , pupper , xcalc , xmax , xmin INTEGER :: icount ! !--------------------------------------------------------------------- ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( Alamba>0.0_wp ) THEN xmax = 1.0_wp/Alamba xmin = -xmax IF ( X<xmin .OR. X>xmax ) THEN WRITE (G_IO,99001) 99001 FORMAT (& &' ***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT TO LAMCDF(3f) IS OUTSIDE THE USUAL +-(1/ALAMBA) INTERVAL *****') WRITE (G_IO,99002) X 99002 FORMAT (' ***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') IF ( X<xmin ) Cdf = 0.0_wp IF ( X>xmax ) Cdf = 1.0_wp RETURN ENDIF ENDIF ! !-----START POINT----------------------------------------------------- ! IF ( Alamba>0.0_wp ) THEN ! xmax = 1.0_wp/Alamba xmin = -xmax IF ( X<=xmin ) Cdf = 0.0_wp IF ( X>=xmax ) Cdf = 1.0_wp IF ( X<=xmin .OR. X>=xmax ) RETURN ENDIF ! IF ( -0.001_wp>=Alamba .OR. Alamba>=0.001_wp ) THEN ! IF ( -0.001_wp>=Alamba .OR. Alamba>=0.001_wp ) THEN pmin = 0.0_wp pmid = 0.5_wp pmax = 1.0_wp plower = pmin pupper = pmax icount = 0 DO xcalc = (pmid**Alamba-(1.0_wp-pmid)**Alamba)/Alamba IF ( xcalc==X ) THEN Cdf = pmid GOTO 99999 ELSE IF ( xcalc>X ) THEN pupper = pmid pmid = (pmid+plower)/2.0_wp ELSE plower = pmid pmid = (pmid+pupper)/2.0_wp ENDIF pdel = ABS(pmid-plower) icount = icount + 1 IF ( pdel<0.000001_wp .OR. icount>30 ) THEN Cdf = pmid GOTO 99999 ENDIF ENDIF ENDDO ENDIF ENDIF IF ( X>=0.0_wp ) THEN Cdf = 1.0_wp/(1.0_wp+EXP(-X)) RETURN ELSE Cdf = EXP(X)/(1.0_wp+EXP(X)) RETURN ENDIF ! 99999 END SUBROUTINE LAMCDF !> !!##NAME !! lampdf(3f) - [M_datapac:PROBABILITY_DENSITY] compute the Tukey-Lambda !! probability density function !! !!##SYNOPSIS !! !! SUBROUTINE LAMPDF(X,Alamba,Pdf) !! !! REAL(kind=wp) :: X !! REAL(kind=wp) :: Alamba !! !!##DESCRIPTION !! LAMPDF(3f) computes the probability density function value for the !! (tukey) lambda distribution with tail length parameter value = alamba. !! !! In general, the probability density function for this distribution !! is not simple. !! !! The percent point function for this distribution is !! !! g(p) = ((p**alamba)-((1-p)**alamba))/alamba !! !!##INPUT ARGUMENTS !! X The REAL value at which the probability density !! function is to be evaluated. !! !! For ALAMBA non-positive, no restrictions on X. !! !! For ALAMBA positive, X should be between (-1/ALAMBA) !! and (+1/ALAMBA), inclusively. !! !! ALAMBA The REAL value of lambda (the tail length !! parameter). !! !!##OUTPUT ARGUMENTS !! PDF The probability density function value for the Tukey Lambda !! distribution !! !!##OUTPUT !! !!##EXAMPLES !! !! Sample program: !! !! program demo_lampdf !! !@(#) line plotter graph of probability density function !! use M_datapac, only : lampdf, plott, label !! implicit none !! real,allocatable :: x(:), y(:) !! real :: alamba !! integer :: i !! call label('lampdf') !! alamba=0.0 !! x=[(real(i),i=-100,100,1)] !! if(allocated(y))deallocate(y) !! allocate(y(size(x))) !! do i=1,size(x) !! call LAMPDF(X(i)/100.0,Alamba,y(i)) !! enddo !! call plott(x,y,size(x)) !! end program demo_lampdf !! !! Results: !! !! The following is a plot of Y(I) (vertically) versus X(I) (horizontally) !! I-----------I-----------I-----------I-----------I !! 0.1000000E+03 - XXXX !! 0.9166666E+02 I XXXXXXX !! 0.8333334E+02 I XXXXXXX !! 0.7500000E+02 I XXXXXXX !! 0.6666667E+02 I XXXXX !! 0.5833334E+02 I XXXXX !! 0.5000000E+02 - XXXXXX !! 0.4166667E+02 I XXXX !! 0.3333334E+02 I XXXX !! 0.2500000E+02 I XXXX !! 0.1666667E+02 I XX !! 0.8333336E+01 I XX !! 0.0000000E+00 - X !! -0.8333328E+01 I XX !! -0.1666666E+02 I XX !! -0.2499999E+02 I XXXX !! -0.3333333E+02 I XXXX !! -0.4166666E+02 I XXXX !! -0.5000000E+02 - XXXXXX !! -0.5833333E+02 I XXXXX !! -0.6666666E+02 I XXXXX !! -0.7500000E+02 I XXXXXXX !! -0.8333333E+02 I XXXXXXX !! -0.9166666E+02 I XXXXXXX !! -0.1000000E+03 - XXXX !! I-----------I-----------I-----------I-----------I !! 0.1966E+00 0.2100E+00 0.2233E+00 0.2367E+00 0.2500E+00 !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !! !!##REFERENCES !! * Hastings, Mosteller, Tukey, and Windsor, 'Low Moments for Small !! Samples: A Comparative Study of Order Statistics', Annals of MAthematical !! Statistics, 18, 1947, pages 413-426. !! * Filliben, Simple and Robust Linear Estimation of the Location Parameter !! of a Symmetric Distribution (Unpublished PH.D. Dissertation, Princeton !! University), 1969, pages 42-44, 53-58. ! ORIGINAL VERSION--JUNE 1972. ! UPDATED --AUGUST 1974. ! UPDATED --SEPTEMBER 1975. ! UPDATED --NOVEMBER 1975. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE LAMPDF(X,Alamba,Pdf) REAL(kind=wp) :: X REAL(kind=wp) :: Alamba REAL(kind=wp) :: cdf , Pdf , sf , xmax , xmin ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( Alamba>0.0_wp ) THEN xmax = 1.0_wp/Alamba xmin = -xmax IF ( X<xmin .OR. X>xmax ) THEN WRITE (G_IO,99001) 99001 FORMAT (& &' ***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT TO LAMPDF(3f) IS OUTSIDE THE USUAL +-(1/ALAMBA) INTERVAL *****') WRITE (G_IO,99002) X 99002 FORMAT (' ','***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') IF ( X<xmin ) Pdf = 0.0_wp IF ( X>xmax ) Pdf = 1.0_wp RETURN ENDIF ENDIF ! !-----START POINT----------------------------------------------------- ! IF ( Alamba>0.0_wp ) THEN xmax = 1.0_wp/Alamba xmin = -xmax IF ( X<=xmin .OR. X>=xmax ) THEN IF ( X<xmin .OR. X>xmax ) Pdf = 0.0_wp IF ( X==xmin .AND. Alamba<1.0 ) Pdf = 0.0_wp IF ( X==xmax .AND. Alamba<1.0 ) Pdf = 0.0_wp IF ( X==xmin .AND. Alamba==1.0 ) Pdf = 0.5_wp IF ( X==xmax .AND. Alamba==1.0 ) Pdf = 0.5_wp IF ( X==xmin .AND. Alamba>1.0 ) Pdf = 1.0_wp IF ( X==xmax .AND. Alamba>1.0 ) Pdf = 1.0_wp RETURN ENDIF ENDIF CALL LAMCDF(X,Alamba,cdf) sf = cdf**(Alamba-1.0_wp) + (1.0_wp-cdf)**(Alamba-1.0_wp) Pdf = 1.0_wp/sf END SUBROUTINE LAMPDF !> !!##NAME !! lamplt(3f) - [M_datapac:LINE_PLOT] generate a Tukey-Lambda probability !! plot !! !!##SYNOPSIS !! !! SUBROUTINE LAMPLT(X,N,Alamba) !! !!##DESCRIPTION !! lamplt(3f) generates a (tukey) lambda distribution probability plot !! (with tail length parameter value = alamba). !! !! in general, the probability density function for this distribution !! is not simple. !! !! the percent point function for this distribution is !! !! g(p) = ((p**alamba)-((1-p)**alamba)) / alamba !! !! as used herein, a probability plot for a distribution is a plot !! of the ordered observations versus the order statistic medians for !! that distribution. !! !! the lambda probability plot is useful in graphically testing the !! composite (that is, location and scale parameters need not be !! specified) hypothesis that the underlying distribution from which !! the data have been randomly drawn is the lambda distribution with !! tail length parameter value = alamba. !! !! if the hypothesis is true, the probability plot should be near-linear. !! !! a measure of such linearity is given by the calculated probability !! plot correlation coefficient. !! !!##OPTIONS !! X description of parameter !! Y description of parameter !! !!##EXAMPLES !! !! Sample program: !! !! program demo_lamplt !! use M_datapac, only : lamplt !! implicit none !! ! call lamplt(x,y) !! end program demo_lamplt !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the Statistical !! Engineering Division, National Institute of Standards and Technology. !!##MAINTAINER !! John Urban, 2022.05.31 !!##LICENSE !! CC0-1.0 !!##REFERENCES !! * FILLIBEN, 'TECHNIQUES FOR TAIL LENGTH ANALYSIS', PROCEEDINGS OF THE !! EIGHTEENTH CONFERENCE ON THE DESIGN OF EXPERIMENTS IN ARMY RESEARCH !! DEVELOPMENT AND TESTING (ABERDEEN, MARYLAND, OCTOBER, 1972), pages !! 425-450. !! * HAHN AND SHAPIRO, STATISTICAL METHODS IN ENGINEERING, 1967, pages !! 260-308. !! * FILLIBEN, SIMPLE AND ROBUST LINEAR ESTIMATION OF THE LOCATION !! PARAMETER OF A SYMMETRIC DISTRIBUTION (UNPUBLISHED PH.D. DISSERTATION, !! PRINCETON UNIVERSITY, 1969), pages 21-44, 229-231, pages 53-58. !! * HASTINGS, MOSTELLER, TUKEY, AND WINDSOR, 'LOW MOMENTS FOR SMALL !! SAMPLES: A COMPARATIVE STUDY OF ORDER STATISTICS', ANNALS OF !! MATHEMATICAL STATISTICS, 18, 1947, pages 413-426. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE LAMPLT(X,N,Alamba) REAL(kind=wp) :: Alamba , an , cc , hold , pp0025 , pp025 , pp975 , pp9975 , & & q , sum1 , sum2 , sum3 , tau , W , wbar , WS , X , Y , ybar ,& & yint REAL(kind=wp) :: yslope INTEGER :: i , iupper , N ! ! INPUT ARGUMENTS--X = THE VECTOR OF ! (UNSORTED OR SORTED) OBSERVATIONS. ! --N = THE INTEGER NUMBER OF OBSERVATIONS ! IN THE VECTOR X. ! --ALAMBA = THE VALUE OF LAMBDA ! (THE TAIL LENGTH PARAMETER). ! OUTPUT--A ONE-page LAMBDA PROBABILITY PLOT. ! PRINTING--YES. ! RESTRICTIONS--THE MAXIMUM ALLOWABLE VALUE OF N ! FOR THIS SUBROUTINE IS 7500. ! OTHER DATAPAC SUBROUTINES NEEDED--SORT, UNIMED, PLOT. ! FORTRAN LIBRARY SUBROUTINES NEEDED--SQRT, LOG. ! MODE OF INTERNAL OPERATIONS--. ! ORIGINAL VERSION--JUNE 1972. ! UPDATED --SEPTEMBER 1975. ! UPDATED --NOVEMBER 1975. ! UPDATED --FEBRUARY 1976. ! !--------------------------------------------------------------------- ! DIMENSION X(:) DIMENSION Y(7500) , W(7500) COMMON /BLOCK2_real32/ WS(15000) EQUIVALENCE (Y(1),WS(1)) EQUIVALENCE (W(1),WS(7501)) ! iupper = 7500 ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( N<1 .OR. N>iupper ) THEN WRITE (G_IO,99001) iupper 99001 FORMAT (' ', & &'***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE LAMPLT SUBROU& &TINE IS OUTSIDE THE ALLOWABLE (1,',I0,') INTERVAL *****') WRITE (G_IO,99002) N 99002 FORMAT (' ','***** THE VALUE OF THE ARGUMENT IS ',I0,' *****') RETURN ELSEIF ( N==1 ) THEN WRITE (G_IO,99003) 99003 FORMAT (' ', & &'***** NON-FATAL DIAGNOSTIC--THE SECOND INPUT ARGUMENT TO THE LAMP& < SUBROUTINE HAS THE VALUE 1 *****') RETURN ELSE hold = X(1) DO i = 2 , N IF ( X(i)/=hold ) GOTO 50 ENDDO WRITE (G_IO,99004) hold 99004 FORMAT (' ', & &'***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT (A VECTOR) & &TO THE LAMPLT SUBROUTINE HAS ALL ELEMENTS = ',E15.8,' *****') ! !-----START POINT----------------------------------------------------- ! 50 an = N ! ! SORT THE DATA ! CALL SORT(X,N,Y) ! ! GENERATE UNIFORM ORDER STATISTIC MEDIANS ! CALL UNIMED(N,W) ! ! COMPUTE LAMBDA DISTRIBUTION ORDER STATISTIC MEDIANS ! DO i = 1 , N q = W(i) IF ( -0.001_wp<Alamba .AND. Alamba<0.001_wp ) W(i) & & = LOG(q/(1.0_wp-q)) IF ( -0.001_wp>=Alamba .OR. Alamba>=0.001_wp ) W(i) & & = (q**Alamba-(1.0_wp-q)**Alamba)/Alamba ENDDO ! ! PLOT THE ORDERED OBSERVATIONS VERSUS ORDER STATISTICS MEDIANS. ! COMPUTE THE TAIL LENGTH MEASURE OF THE DISTRIBUTION. ! WRITE OUT THE TAIL LENGTH MEASURE OF THE DISTRIBUTION ! AND THE SAMPLE SIZE. ! CALL PLOT(Y,W,N) IF ( -0.001_wp<Alamba .AND. Alamba<0.001_wp ) tau = 1.63473745_wp IF ( -0.001_wp>=Alamba .OR. Alamba>=0.001_wp ) THEN q = .9975_wp pp9975 = (q**Alamba-(1.0_wp-q)**Alamba)/Alamba q = .0025_wp pp0025 = (q**Alamba-(1.0_wp-q)**Alamba)/Alamba q = .975_wp pp975 = (q**Alamba-(1.0_wp-q)**Alamba)/Alamba q = .025_wp pp025 = (q**Alamba-(1.0_wp-q)**Alamba)/Alamba tau = (pp9975-pp0025)/(pp975-pp025) ENDIF WRITE (G_IO,99005) Alamba , tau , N ! 99005 FORMAT (' ','LAMBDA PROBABILITY PLOT WITH LAMBDA = ',E17.10,1X,& & '(TAU = ',E15.8,')',24X,'THE SAMPLE SIZE N = ',I0) ! ! COMPUTE THE PROBABILITY PLOT CORRELATION COEFFICIENT. ! COMPUTE LOCATION AND SCALE ESTIMATES ! FROM THE INTERCEPT AND SLOPE OF THE PROBABILITY PLOT. ! THEN WRITE THEM OUT. ! sum1 = 0.0_wp DO i = 1 , N sum1 = sum1 + Y(i) ENDDO ybar = sum1/an wbar = 0.0_wp sum1 = 0.0_wp sum2 = 0.0_wp sum3 = 0.0_wp DO i = 1 , N sum1 = sum1 + (Y(i)-ybar)*(Y(i)-ybar) sum2 = sum2 + W(i)*Y(i) sum3 = sum3 + W(i)*W(i) ENDDO cc = sum2/SQRT(sum3*sum1) yslope = sum2/sum3 yint = ybar - yslope*wbar WRITE (G_IO,99006) cc , yint , yslope 99006 FORMAT (' ','PROBABILITY PLOT CORRELATION COEFFICIENT = ',F8.5,& & 5X,'ESTIMATED INTERCEPT = ',E15.8,3X, & & 'ESTIMATED SLOPE = ',E15.8) ENDIF ! END SUBROUTINE LAMPLT !> !!##NAME !! lamppf(3f) - [M_datapac:PERCENT_POINT] compute the Tukey-Lambda percent !! point function !! !!##SYNOPSIS !! !! SUBROUTINE LAMPPF(P,Alamba,Ppf) !! !! REAL(kind=wp),intent(in) :: Alamba !! REAL(kind=wp),intent(in) :: P !! REAL(kind=wp),intent(out) :: Ppf !! !!##DESCRIPTION !! LAMPPF(3f) computes the percent point function value for the (Tukey) !! lambda distribution with tail length parameter value = ALAMBA. !! !! In general, the probability density function for this distribution !! is not simple. !! !! The percent point function for this distribution is !! !! g(P) = ((P**ALAMBA)-((1-P)**ALAMBA))/ALAMBA !! !! Note that the percent point function of a distribution is identically !! the same as the inverse cumulative distribution function of the !! distribution. !! !!##INPUT ARGUMENTS !! !! P The value (between 0.0 and 1.0) at which the percent point !! function is to be evaluated. !! !! If ALAMBA is positive, then P should be between 0.0 and 1.0, !! inclusively. !! !! If ALAMBA is non-positive, then P should be between 0.0 and !! 1.0, exclusively. !! !! ALAMBA The value of lambda (the tail length parameter). !! !!##OUTPUT ARGUMENTS !! !! PPF The percent point function value ppf for the Tukey lambda !! distribution !! !! !!##EXAMPLES !! !! Sample program: !! !! program demo_lamppf !! !@(#) line plotter graph of function !! use M_datapac, only : lamppf, plott, label !! implicit none !! integer,parameter :: n=200 !! real :: x(n), y(n) !! real :: alamba !! integer :: i !! alamba=3.3333 !! call label('lamppf') !! x=[(real(i)/real(n+1),i=1,n)] !! do i=1,n !! call lamppf(x(i),alamba,y(i)) !! enddo !! call plott(x,y,n) !! end program demo_lamppf !! !! Results: !! !! The following is a plot of Y(I) (vertically) versus X(I) (horizontally) !! I-----------I-----------I-----------I-----------I !! 0.9950249E+00 - XXX !! 0.9537728E+00 I XXX !! 0.9125207E+00 I XXX !! 0.8712686E+00 I XXXX !! 0.8300166E+00 I XXX !! 0.7887645E+00 I XXX !! 0.7475125E+00 - XXX !! 0.7062603E+00 I XXX !! 0.6650083E+00 I XX !! 0.6237562E+00 I XX !! 0.5825042E+00 I XX !! 0.5412520E+00 I XX !! 0.5000000E+00 - XXX !! 0.4587479E+00 I XX !! 0.4174958E+00 I XX !! 0.3762438E+00 I XX !! 0.3349917E+00 I XX !! 0.2937396E+00 I XXX !! 0.2524875E+00 - XXX !! 0.2112355E+00 I XXX !! 0.1699834E+00 I XXX !! 0.1287313E+00 I XXXX !! 0.8747923E-01 I XXX !! 0.4622716E-01 I XXX !! 0.4975124E-02 - XXX !! I-----------I-----------I-----------I-----------I !! -0.2951E+00 -0.1475E+00 0.0000E+00 0.1475E+00 0.2951E+00 !! !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !! !!##REFERENCES !! * Filliben, Simple and Robust Linear Estimation of the Location !! Parameter of a Symmetric Distribution (Unpublished PH.D. Dissertation, !! Princeton University), 1969, pages 21-44, 229-231, pages 53-58. !! * Filliben, 'The Percent Point Function', (Unpublished Manuscript), !! 1970, pages 28-31. !! * Hastings, Mosteller, Tukey, and Windsor, 'Low Moments for Small !! Samples: A Comparative Study of Order Statistics', Annals of !! Mathematical Statistics, 18, 1947, pages 413-426. ! ORIGINAL VERSION--JUNE 1972. ! UPDATED --SEPTEMBER 1975. ! UPDATED --NOVEMBER 1975. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE LAMPPF(P,Alamba,Ppf) REAL(kind=wp),intent(in) :: Alamba REAL(kind=wp),intent(in) :: P REAL(kind=wp),intent(out) :: Ppf !--------------------------------------------------------------------- ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( Alamba>0.0_wp .OR. P>0.0_wp ) THEN IF ( Alamba>0.0_wp .OR. P<1.0_wp ) THEN IF ( Alamba<=0.0_wp .OR. P>=0.0_wp ) THEN IF ( Alamba<=0.0_wp .OR. P<=1.0_wp ) THEN IF ( -0.001_wp<Alamba .AND. Alamba<0.001_wp ) THEN Ppf = LOG(P/(1.0_wp-P)) RETURN ELSE Ppf = (P**Alamba-(1.0_wp-P)**Alamba)/Alamba GOTO 99999 ENDIF ENDIF ENDIF ENDIF ENDIF WRITE (G_IO,99001) 99001 FORMAT (' ***** FATAL ERROR--The first input argument to LAMPPF(3f) is outside the allowable (0,1) interval *****') WRITE (G_IO,99002) P 99002 FORMAT (' ***** The value of the argument is ',E15.8,' *****') RETURN ! 99999 END SUBROUTINE LAMPPF !> !!##NAME !! lamran(3f) - [M_datapac:RANDOM] generate Tukey-Lambda random numbers !! !!##SYNOPSIS !! !! SUBROUTINE LAMRAN(N,Alamba,Iseed,X) !! !! INTEGER,intent(in) :: N !! REAL(kind=wp),intent(in) :: Alamba !! INTEGER,intent(inout) :: Iseed !! REAL(kind=wp),intent(out) :: X(:) !! !!##DESCRIPTION !! LAMRAN(3f) generates a random sample of size N from the (Tukey) !! lambda distribution with tail length parameter value = ALAMBA. !! !! In general, the probability density function for this distribution !! is not simple. the percent point function for this distribution is !! !! g(P) = ((P**ALAMBA)-((1-P)**ALAMBA))/ALAMBA !! !!##INPUT ARGUMENTS !! !! N The desired integer number of random numbers to be generated. !! !! ALAMBA The value of LAMBDA (the tail length parameter). !! !! ISEED An integer seed value. Should be set to a non-negative value !! to start a new sequence of values. Will be set to -1 on return !! to indicate the next call should continue the current random !! sequence walk. !! !!##OUTPUT ARGUMENTS !! !! X A vector (of dimension at least N) into which the generated !! random sample of size N from the (Tukey) lambda distribution !! will be placed. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_lamran !! use m_datapac, only : lamran, plott, label, plotxt, sort !! implicit none !! integer,parameter :: n=400 !! real :: x(n) !! integer :: iseed !! real :: gamma !! call label('lamran') !! gamma=3.4 !! iseed=12345 !! call lamran(n,gamma,iseed,x) !! call plotxt(x,n) !! call sort(x,n,x) ! sort to show distribution !! call plotxt(x,n) !! end program demo_lamran !! !! Results: !! !! THE FOLLOWING IS A PLOT OF X(I) (VERTICALLY) VERSUS I (HORIZONTALLY !! I-----------I-----------I-----------I-----------I !! 0.2940770E+00 - XX X X X !! 0.2701390E+00 I XXX X X X X X X !! 0.2462010E+00 I X XX X X X X !! 0.2222630E+00 I X XX X X X X X X X X !! 0.1983251E+00 I XX XX XX X X !! 0.1743871E+00 I XX X XX X X X X X X X XX XXXX !! 0.1504491E+00 - X X XX X X X XX X X !! 0.1265111E+00 I X X XXX X X X XX XX XX X X !! 0.1025732E+00 I X XX XXX XX XXXX XX X X XXXX !! 0.7863519E-01 I X XX XXXXX X X X X XXX X X XX !! 0.5469720E-01 I X XXX X X XX X X XX X XX X !! 0.3075922E-01 I X XXX X XXXX XXX XX XXX X XX XX X !! 0.6821245E-02 - XXXX X XX X X X X XX XX XX XX X X !! -0.1711673E-01 I X X X XX X XX XX X XX X X XX !! -0.4105473E-01 I XX X X XXXXXX XXXX XX X X X XXX !! -0.6499270E-01 I X XX X X X XX XXXX X XX X !! -0.8893067E-01 I X X X XX X X XX X X XX X X X !! -0.1128686E+00 I X X X X X X X X XX !! -0.1368066E+00 - XX X X X X X XXX X X X !! -0.1607446E+00 I X XX X X X X X XX X X !! -0.1846826E+00 I X X XX XXX X X X X X X X X X !! -0.2086205E+00 I X XX X X X X X XX XXX !! -0.2325585E+00 I X X X X X X !! -0.2564965E+00 I XX X X X !! -0.2804345E+00 - X X X X X X X !! I-----------I-----------I-----------I-----------I !! 0.1000E+01 0.1008E+03 0.2005E+03 0.3002E+03 0.4000E+03 !! !! THE FOLLOWING IS A PLOT OF X(I) (VERTICALLY) VERSUS I (HORIZONTALLY !! I-----------I-----------I-----------I-----------I !! 0.2940770E+00 - X !! 0.2701390E+00 I XX !! 0.2462010E+00 I XX !! 0.2222630E+00 I XX !! 0.1983251E+00 I XX !! 0.1743871E+00 I XXX !! 0.1504491E+00 - XXX !! 0.1265111E+00 I XXX !! 0.1025732E+00 I XXXX !! 0.7863519E-01 I XXXX !! 0.5469720E-01 I XXX !! 0.3075922E-01 I XXXX !! 0.6821245E-02 - XXXX !! -0.1711673E-01 I XXXX !! -0.4105473E-01 I XXXX !! -0.6499270E-01 I XXX !! -0.8893067E-01 I XXX !! -0.1128686E+00 I XX !! -0.1368066E+00 - XXX !! -0.1607446E+00 I XXX !! -0.1846826E+00 I XXX !! -0.2086205E+00 I XXX !! -0.2325585E+00 I X !! -0.2564965E+00 I X !! -0.2804345E+00 - XX !! I-----------I-----------I-----------I-----------I !! 0.1000E+01 0.1008E+03 0.2005E+03 0.3002E+03 0.4000E+03 !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !! !!##REFERENCES !! * Tocher, The Art of Simulation, 1963, pages 14-15. !! * Hammersley and Handscomb, Monte Carlo Methods, 1964, page 36. !! * Filliben, Simple and Robust Linear Estimation of the Location !! Parameter of a Symmetric Distribution (Unpublished PH.D. Dissertation, !! Princeton University), 1969, pages 21-44, 53-58. !! * Filliben, 'The Percent Point Function', (unpublished manuscript), !! 1970, pages 28-31. ! VERSION NUMBER--82.6 ! ORIGINAL VERSION--JUNE 1972. ! UPDATED --SEPTEMBER 1975. ! UPDATED --NOVEMBER 1975. ! UPDATED --DECEMBER 1981. ! UPDATED --MAY 1982. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE LAMRAN(N,Alamba,Iseed,X) INTEGER,intent(in) :: N REAL(kind=wp),intent(in) :: Alamba INTEGER,intent(inout) :: Iseed REAL(kind=wp),intent(out) :: X(:) REAL(kind=wp) :: alamb2 , q INTEGER :: i !--------------------------------------------------------------------- ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! alamb2 = Alamba IF ( N<1 ) THEN WRITE (G_IO,99001) 99001 FORMAT (' ***** FATAL ERROR--The first input argument to LAMRAN(3f) is non-positive *****') WRITE (G_IO,99002) N 99002 FORMAT (' ','***** The value of the argument is ',I0,' *****') RETURN ELSE ! ! GENERATE N UNIFORM (0,1) RANDOM NUMBERS; ! CALL UNIRAN(N,Iseed,X) ! ! GENERATE N LAMBDA DISTRIBUTION RANDOM NUMBERS ! USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD. ! DO i = 1 , N q = X(i) IF ( -0.001_wp<alamb2 .AND. alamb2<0.001_wp ) X(i) = LOG(q/(1.0-q)) IF ( -0.001_wp>=alamb2 .OR. alamb2>=0.001_wp ) X(i) = (q**alamb2-(1.0_wp-q)**alamb2)/alamb2 ENDDO ENDIF END SUBROUTINE LAMRAN !> !!##NAME !! lamsf(3f) - [M_datapac:SPARSITY] compute the Tukey-Lambda sparsity !! function !! !!##SYNOPSIS !! !! SUBROUTINE LAMSF(P,Alamba,Sf) !! !! REAL(kind=wp),intent(in) :: P !! REAL(kind=wp),intent(in) :: Alamba !! REAL(kind=wp),intent(out) :: Sf !! !!##DESCRIPTION !! LAMSF(3f) computes the sparsity function value for the (Tukey) lambda !! distribution with tail length parameter value = ALAMBA. !! !! In general, the probability density function for this distribution !! is not simple. !! !! The percent point function for this distribution is !! !! g(P) = ((P**ALAMBA)-((1-P)**ALAMBA))/ALAMBA !! !! Note that the sparsity function of a distribution is the derivative !! of the percent point function, and also is the reciprocal of the !! probability density function (but in units of P rather than X). !! !!##INPUT ARGUMENTS !! !! P The value (between 0.0 and 1.0) at which the sparsity function !! is to be evaluated. !! !! ALAMBA The value of Lambda (the Tail Length parameter). !! !! If ALAMBA is positive, then P should be between 0.0 and 1.0, !! inclusively. !! !! If ALAMBA is non-positive, then P should be between 0.0 and !! 1.0, exclusively. !! !!##OUTPUT ARGUMENTS !! !! SF The sparsity function value for the Tukey Lambda distribution !! !!##EXAMPLES !! !! Sample program: !! !! program demo_lamsf !! use M_datapac, only : lamsf !! implicit none !! ! call lamsf(x,y) !! end program demo_lamsf !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !! !!##REFERENCES !! * Filliben, Simple and Robust Linear Estimation of the Location !! Parameter of a Symmetric Distribution (Unpublished PH.D. Dissertation, !! Princeton University), 1969, pages 21-44, 229-231, pages 53-58. !! * Filliben, 'The Percent Point Function', (Unpublished Manuscript), !! 1970, pages 28-31. !! * Hastings, Mosteller, Tukey, and Windsor, 'Low Moments for Small !! Samples: A Comparative Study of Order Statistics', Annals of !! Mathematical Statistics, 18, 1947, pages 413-426. ! ORIGINAL VERSION--JUNE 1972. ! UPDATED --SEPTEMBER 1975. ! UPDATED --NOVEMBER 1975. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE LAMSF(P,Alamba,Sf) REAL(kind=wp),intent(in) :: P REAL(kind=wp),intent(in) :: Alamba REAL(kind=wp),intent(out) :: Sf !--------------------------------------------------------------------- ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( Alamba>0.0_wp .OR. P>0.0_wp ) THEN IF ( Alamba>0.0_wp .OR. P<1.0_wp ) THEN IF ( Alamba<=0.0_wp .OR. P>=0.0_wp ) THEN IF ( Alamba<=0.0_wp .OR. P<=1.0_wp ) THEN !-----START POINT----------------------------------------------------- Sf = P**(Alamba-1.0_wp) + (1.0-P)**(Alamba-1.0_wp) GOTO 99999 ENDIF ENDIF ENDIF ENDIF WRITE (G_IO,99001) 99001 FORMAT (' ***** FATAL ERROR--The first input argument to LAMSF(3f) is outside the allowable (0,1) interval *****') WRITE (G_IO,99002) P 99002 FORMAT (' ***** the value of the argument is ',E15.8,' *****') RETURN 99999 END SUBROUTINE LAMSF !> !!##NAME !! lgncdf(3f) - [M_datapac:CUMULATIVE_DISTRIBUTION] compute the lognormal !! cumulative distribution function !! !!##SYNOPSIS !! !! SUBROUTINE LGNCDF(X,Cdf) !! !! REAL(kind=wp),intent(in) :: X !! REAL(kind=wp),intent(out) :: Cdf !! !!##DESCRIPTION !! LGNCDF(3f) computes the cumulative distribution function value for !! the lognormal distribution. !! !! The lognormal distribution used herein has mean = sqrt(e) = 1.64872127 !! and standard deviation = sqrt(e*(e-1)) = 2.16119742. this distribution !! is defined for all positive X and has the probability density function !! !! f(X) = (1/(X*sqrt(2*pi))) * exp(-log(X)*log(X)/2) !! !! The lognormal distribution used herein is the distribution of the !! variate X = exp(z) where the variate z is normally distributed with !! mean = 0 and standard deviation = 1. !! !!##INPUT ARGUMENTS !! X The value at which the cumulative distribution function is !! to be evaluated. X should be positive. !!##OUTPUT ARGUMENTS !! Cdf The cumulative distribution function value for the lognormal !! distribution !! !!##EXAMPLES !! !! Sample program: !! !! program demo_lgncdf !! !@(#) line plotter graph of cumulative distribution function !! use M_datapac, only : lgncdf, plott, label !! implicit none !! real,allocatable :: x(:), y(:) !! integer :: i !! call label('lgncdf') !! x=[((real(i)+epsilon(0.0))/10.0,i=0,100,1)] !! if(allocated(y))deallocate(y) !! allocate(y(size(x))) !! do i=1,size(x) !! call lgncdf(x(i),y(i)) !! enddo !! call plott(x,y,size(x)) !! end program demo_lgncdf !! !! Results: !! !! The following is a plot of Y(I) (vertically) versus X(I) (horizontally) !! I-----------I-----------I-----------I-----------I !! 0.1000000E+02 - X !! 0.9583333E+01 I X !! 0.9166667E+01 I X !! 0.8750000E+01 I X !! 0.8333333E+01 I X !! 0.7916667E+01 I X !! 0.7500000E+01 - XX !! 0.7083333E+01 I X !! 0.6666667E+01 I X !! 0.6250000E+01 I X !! 0.5833333E+01 I X !! 0.5416667E+01 I X !! 0.5000000E+01 - X !! 0.4583333E+01 I XX !! 0.4166667E+01 I XX !! 0.3750000E+01 I X !! 0.3333333E+01 I X !! 0.2916667E+01 I XX !! 0.2500000E+01 - XXX !! 0.2083333E+01 I XXX !! 0.1666667E+01 I XXXX !! 0.1250000E+01 I X XX X !! 0.8333340E+00 I X X X X !! 0.4166670E+00 I X X X X !! 0.1192093E-07 - XX X !! I-----------I-----------I-----------I-----------I !! 0.0000E+00 0.2473E+00 0.4947E+00 0.7420E+00 0.9893E+00 !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !!##MAINTAINER !! John Urban, 2022.05.31 !!##LICENSE !! CC0-1.0 !!##REFERENCES !! * Johnson and Kotz, Continuous Univariate Distributions--1, 1970, !! pages 112-136. !! * Cramer, Mathematical Methods of Statistics, 1946, pages 219-220. ! ORIGINAL VERSION--NOVEMBER 1975. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE LGNCDF(X,Cdf) REAL(kind=wp),intent(in) :: X REAL(kind=wp),intent(out) :: Cdf REAL(kind=wp) :: arg ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( X<=0.0_wp ) THEN WRITE (G_IO,99001) 99001 FORMAT (' ***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT TO LGNCDF(3f) IS NON-POSITIVE *****') WRITE (G_IO,99002) X 99002 FORMAT (' ','***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') Cdf = 0.0_wp RETURN ELSE arg = LOG(X) CALL NORCDF(arg,Cdf) ENDIF ! END SUBROUTINE LGNCDF !> !!##NAME !! lgnplt(3f) - [M_datapac:LINE_PLOT] generates a lognormal probability !! plot !! !!##SYNOPSIS !! !! SUBROUTINE LGNPLT(X,N) !! !!##DESCRIPTION !! lgnplt(3f) generates a lognormal probability plot. !! !! the prototype lognormal distribution used herein has mean = sqrt(e) !! = 1.64872127 and standard deviation = sqrt(e*(e-1)) = 2.16119742. !! this distribution is defined for all positive x and has the probability !! density function !! !! f(x) = (1/(x*sqrt(2*pi))) * exp(-log(x)*log(x)/2) !! !! the prototype lognormal distribution used herein is the distribution !! of the variate x = exp(z) where the variate z is normally distributed !! with mean = 0 and standard deviation = 1. !! !! as used herein, a probability plot for a distribution is a plot !! of the ordered observations versus the order statistic medians for !! that distribution. !! !! the lognormal probability plot is useful in graphically testing !! the composite (that is, location and scale parameters need not be !! specified) hypothesis that the underlying distribution from which !! the data have been randomly drawn is the lognormal distribution. !! !! if the hypothesis is true, the probability plot should be near-linear. !! !! a measure of such linearity is given by the calculated probability !! plot correlation coefficient. !! !!##OPTIONS !! X description of parameter !! Y description of parameter !! !!##EXAMPLES !! !! Sample program: !! !! program demo_lgnplt !! use M_datapac, only : lgnplt !! implicit none !! ! call lgnplt(x,y) !! end program demo_lgnplt !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !! !!##REFERENCES !! * FILLIBEN, 'TECHNIQUES FOR TAIL LENGTH ANALYSIS', PROCEEDINGS OF THE !! EIGHTEENTH CONFERENCE ON THE DESIGN OF EXPERIMENTS IN ARMY RESEARCH !! DEVELOPMENT AND TESTING (ABERDEEN, MARYLAND, OCTOBER, 1972), pages !! 425-450. !! * HAHN AND SHAPIRO, STATISTICAL METHODS IN ENGINEERING, 1967, pages !! 260-308. !! * JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE DISTRIBUTIONS--1, 1970, !! pages 112-136. !! * CRAMER, MATHEMATICAL METHODS OF STATISTICS, 1946, pages 219-220. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE LGNPLT(X,N) REAL(kind=wp) :: an , cc , hold , q , sum1 , sum2 , sum3 , tau , W , wbar , WS , X , Y , ybar , yint , yslope INTEGER :: i , iupper , N ! ! INPUT ARGUMENTS--X = THE VECTOR OF ! (UNSORTED OR SORTED) OBSERVATIONS. ! --N = THE INTEGER NUMBER OF OBSERVATIONS ! IN THE VECTOR X. ! OUTPUT--A ONE-page LOGNORMAL PROBABILITY PLOT. ! PRINTING--YES. ! RESTRICTIONS--THE MAXIMUM ALLOWABLE VALUE OF N ! FOR THIS SUBROUTINE IS 7500. ! ORIGINAL VERSION--JUNE 1972. ! UPDATED --SEPTEMBER 1975. ! UPDATED --NOVEMBER 1975. ! UPDATED --FEBRUARY 1976. ! !--------------------------------------------------------------------- ! DIMENSION X(:) DIMENSION Y(7500) , W(7500) COMMON /BLOCK2_real32/ WS(15000) EQUIVALENCE (Y(1),WS(1)) EQUIVALENCE (W(1),WS(7501)) ! DATA tau/2.37134890_wp/ ! iupper = 7500 ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( N<1 .OR. N>iupper ) THEN WRITE (G_IO,99001) iupper 99001 FORMAT (' ', & &'***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE LGNPLT SUBROU& &TINE IS OUTSIDE THE ALLOWABLE (1,',I0,') INTERVAL *****') WRITE (G_IO,99002) N 99002 FORMAT (' ','***** THE VALUE OF THE ARGUMENT IS ',I0,' *****') RETURN ELSEIF ( N==1 ) THEN WRITE (G_IO,99003) 99003 FORMAT (' ', & &'***** NON-FATAL DIAGNOSTIC--THE SECOND INPUT ARGUMENT TO THE LGNP& < SUBROUTINE HAS THE VALUE 1 *****') RETURN ELSE hold = X(1) DO i = 2 , N IF ( X(i)/=hold ) GOTO 50 ENDDO WRITE (G_IO,99004) hold 99004 FORMAT (' ', & &'***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT (A VECTOR) & &TO THE LGNPLT SUBROUTINE HAS ALL ELEMENTS = ',E15.8,' *****') ! !-----START POINT----------------------------------------------------- ! 50 an = N ! ! SORT THE DATA ! CALL SORT(X,N,Y) ! ! GENERATE UNIFORM ORDER STATISTIC MEDIANS ! CALL UNIMED(N,W) ! ! COMPUTE LOGNORMAL ORDER STATISTIC MEDIANS ! DO i = 1 , N q = W(i) CALL NORPPF(q,q) W(i) = EXP(q) ENDDO ! ! PLOT THE ORDERED OBSERVATIONS VERSUS ORDER STATISTICS MEDIANS. ! WRITE OUT THE TAIL LENGTH MEASURE OF THE DISTRIBUTION ! AND THE SAMPLE SIZE. ! CALL PLOT(Y,W,N) WRITE (G_IO,99005) tau , N ! 99005 FORMAT (' ','LOGNORMAL PROBABILITY PLOT (TAU = ',E15.8,')',53X,& & 'THE SAMPLE SIZE N = ',I0) ! ! COMPUTE THE PROBABILITY PLOT CORRELATION COEFFICIENT. ! COMPUTE LOCATION AND SCALE ESTIMATES ! FROM THE INTERCEPT AND SLOPE OF THE PROBABILITY PLOT. ! THEN WRITE THEM OUT. ! sum1 = 0.0_wp sum2 = 0.0_wp DO i = 1 , N sum1 = sum1 + Y(i) sum2 = sum2 + W(i) ENDDO ybar = sum1/an wbar = sum2/an sum1 = 0.0_wp sum2 = 0.0_wp sum3 = 0.0_wp DO i = 1 , N sum1 = sum1 + (Y(i)-ybar)*(Y(i)-ybar) sum2 = sum2 + (Y(i)-ybar)*(W(i)-wbar) sum3 = sum3 + (W(i)-wbar)*(W(i)-wbar) ENDDO cc = sum2/SQRT(sum3*sum1) yslope = sum2/sum3 yint = ybar - yslope*wbar WRITE (G_IO,99006) cc , yint , yslope 99006 FORMAT (' ','PROBABILITY PLOT CORRELATION COEFFICIENT = ',F8.5,& & 5X,'ESTIMATED INTERCEPT = ',E15.8,3X, & & 'ESTIMATED SLOPE = ',E15.8) ENDIF ! END SUBROUTINE LGNPLT !> !!##NAME !! lgnppf(3f) - [M_datapac:PERCENT_POINT] compute the lognormal percent !! point function !! !!##SYNOPSIS !! !! SUBROUTINE LGNPPF(P,Ppf) !! !! REAL(kind=wp),intent(in) :: P !! REAL(kind=wp),intent(out) :: Ppf !! !!##DESCRIPTION !! LGNPPF(3f) computes the percent point function value for the lognormal !! distribution. !! !! The lognormal distribution used herein has mean = sqrt(e) = 1.64872127 !! and standard deviation = sqrt(e*(e-1)) = 2.16119742. This distribution !! is defined for all positive X and has the probability density function !! !! f(X) = (1/(X*sqrt(2*pi))) * exp(-log(X)*log(X)/2) !! !! The lognormal distribution used herein is the distribution of the !! variate x = exp(z) where the variate z is normally distributed with !! mean = 0 and standard deviation = 1. !! !! Note that the percent point function of a distribution is identically !! the same as the inverse cumulative distribution function of the !! distribution. !! !!##INPUT ARGUMENTS !! !! P The value (between 0.0 (exclusively) and 1.0 (exclusively)) !! at which the percent point function is to be evaluated. !! !!##OUTPUT ARGUMENTS !! !! PPF The percent point function value for the lognormal distribution !! !!##EXAMPLES !! !! Sample program: !! !! program demo_lgnppf !! !@(#) line plotter graph of function !! use M_datapac, only : lgnppf, plott, label !! implicit none !! integer,parameter :: n=200 !! real :: x(n), y(n) !! integer :: i !! call label('lgnppf') !! x=[(real(i)/real(n+1),i=1,n)] !! do i=1,n !! call lgnppf(x(i),y(i)) !! enddo !! call plott(x,y,n) !! end program demo_lgnppf !! !! Results: !! !! The following is a plot of Y(I) (vertically) versus X(I) (horizontally) !! I-----------I-----------I-----------I-----------I !! 0.9950249E+00 - X X X X X !! 0.9537728E+00 I XXXXXXX X !! 0.9125207E+00 I XXXX !! 0.8712686E+00 I XXX !! 0.8300166E+00 I XX !! 0.7887645E+00 I XX !! 0.7475125E+00 - X !! 0.7062603E+00 I X !! 0.6650083E+00 I XX !! 0.6237562E+00 I X !! 0.5825042E+00 I X !! 0.5412520E+00 I X !! 0.5000000E+00 - XX !! 0.4587479E+00 I X !! 0.4174958E+00 I X !! 0.3762438E+00 I XX !! 0.3349917E+00 I X !! 0.2937396E+00 I X !! 0.2524875E+00 - XX !! 0.2112355E+00 I X !! 0.1699834E+00 I X !! 0.1287313E+00 I X !! 0.8747923E-01 I X !! 0.4622716E-01 I XX !! 0.4975124E-02 - X !! I-----------I-----------I-----------I-----------I !! 0.7596E-01 0.3348E+01 0.6620E+01 0.9893E+01 0.1316E+02 !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !! !!##REFERENCES !! * Johnson and Kotz, Continuous Univariate Distributions--1, 1970, !! pages 112-136. !! * Cramer, Mathematical Methods of Statistics, 1946, pages 219-220. ! ORIGINAL VERSION--NOVEMBER 1975. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE LGNPPF(P,Ppf) REAL(kind=wp),intent(in) :: P REAL(kind=wp),intent(out) :: Ppf !--------------------------------------------------------------------- ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( P<=0.0_wp .OR. P>=1.0_wp ) THEN WRITE (G_IO,99001) WRITE (G_IO,99002) P Ppf = 0.0_wp ELSE CALL NORPPF(P,Ppf) Ppf = EXP(Ppf) ENDIF 99001 FORMAT(' ***** FATAL ERROR--The first input argument to LGNPPF(3f) is outside the allowable (0,1) interval *****') 99002 FORMAT(' ***** The value of the argument is ',E15.8, ' *****') ! END SUBROUTINE LGNPPF !> !!##NAME !! lgnran(3f) - [M_datapac:RANDOM] generate lognormal random numbers !! !!##SYNOPSIS !! !! !! SUBROUTINE LGNRAN(N,Iseed,X) !! !! INTEGER,intent(in) :: N !! INTEGER,intent(inout) :: Iseed !! REAL(kind=wp),intent(out) :: X(:) !! !!##DESCRIPTION !! LGNRAN(3f) generates a random sample of size N from the lognormal !! distribution. !! !! The prototype lognormal distribution used herein has mean = sqrt(e) !! = 1.64872127 and standard deviation = sqrt(e*(e-1)) = 2.16119742. !! this distribution is defined for all positive X and has the probability !! density function !! !! f(X) = (1/(X*sqrt(2*pi))) * exp(-log(X)*log(X)/2) !! !! The prototype lognormal distribution used herein is the distribution !! of the variate X = exp(z) where the variate z is normally distributed !! with mean = 0 and standard deviation = 1. !! !!##INPUT ARGUMENTS !! !! N The desired integer number of random numbers to be generated. !! !! ISEED An integer seed value. Should be set to a non-negative value !! to start a new sequence of values. Will be set to -1 on return !! to indicate the next call should continue the current random !! sequence walk. !! !!##OUTPUT ARGUMENTS !! !! X A vector (of dimension at least N) into which the generated !! random sample of size N from the lognormal distribution will !! be placed. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_lgnran !! use m_datapac, only : lgnran, plott, label, plotxt, sort !! implicit none !! integer,parameter :: n=500 !! real :: x(n) !! integer :: iseed !! call label('lgnran') !! iseed=12345 !! call lgnran(N,Iseed,X) !! call plotxt(x,n) !! call sort(x,n,x) ! sort to show distribution !! call plotxt(x,n) !! end program demo_lgnran !! !! Results: !! !! THE FOLLOWING IS A PLOT OF X(I) (VERTICALLY) VERSUS I (HORIZONTALLY !! I-----------I-----------I-----------I-----------I !! 0.2626150E+02 - X !! 0.2516970E+02 I !! 0.2407790E+02 I !! 0.2298611E+02 I !! 0.2189431E+02 I !! 0.2080252E+02 I !! 0.1971072E+02 - !! 0.1861893E+02 I !! 0.1752713E+02 I X !! 0.1643533E+02 I X !! 0.1534354E+02 I !! 0.1425174E+02 I !! 0.1315995E+02 - X !! 0.1206815E+02 I !! 0.1097635E+02 I X !! 0.9884558E+01 I X X !! 0.8792763E+01 I XXX !! 0.7700968E+01 I X !! 0.6609171E+01 - X X X X X !! 0.5517376E+01 I XX X X X XX X X !! 0.4425579E+01 I XX X X X XXXX XX X X XX X !! 0.3333784E+01 I X XXX X XX XX XXX X XXXX X X X X !! 0.2241987E+01 I X XXXXXX XX XXXX XXXXXXXXXX X XXXXXX XXX XXXXXXX !! 0.1150192E+01 I XXXXXXXXXXXXXX XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX !! 0.5839747E-01 - XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX !! I-----------I-----------I-----------I-----------I !! 0.1000E+01 0.1258E+03 0.2505E+03 0.3752E+03 0.5000E+03 !! !! THE FOLLOWING IS A PLOT OF X(I) (VERTICALLY) VERSUS I (HORIZONTALLY !! I-----------I-----------I-----------I-----------I !! 0.2626150E+02 - X !! 0.2516970E+02 I !! 0.2407790E+02 I !! 0.2298611E+02 I !! 0.2189431E+02 I !! 0.2080252E+02 I !! 0.1971072E+02 - !! 0.1861893E+02 I !! 0.1752713E+02 I X !! 0.1643533E+02 I X !! 0.1534354E+02 I !! 0.1425174E+02 I !! 0.1315995E+02 - X !! 0.1206815E+02 I !! 0.1097635E+02 I X !! 0.9884558E+01 I XX !! 0.8792763E+01 I X !! 0.7700968E+01 I X !! 0.6609171E+01 - XX !! 0.5517376E+01 I X !! 0.4425579E+01 I XX !! 0.3333784E+01 I XXX !! 0.2241987E+01 I XXXXXXXX !! 0.1150192E+01 I XXXXXXXXXXXXXXXXXXXX !! 0.5839747E-01 - XXXXXXXXXXXXXXXX !! I-----------I-----------I-----------I-----------I !! 0.1000E+01 0.1258E+03 0.2505E+03 0.3752E+03 0.5000E+03 !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !! !!##REFERENCES !! * Tocher, The Art of Simulation, 1963, pages 14-15. !! * Hammersley and Handscomb, Monte Carlo Methods, 1964, page 36. !! * Cramer, Mathematical Methods of Statistics, 1946, pages 219-220. !! * Johnson and Kotz, Continuous Univariate Distributions--1, 1970, !! pages 112-136. !! * Hastings and Peacock, Statistical Distributions--A Handbook for !! Students and Practitioners, 1975, page 88. ! VERSION NUMBER--82.6 ! ORIGINAL VERSION--NOVEMBER 1975. ! UPDATED --JULY 1976. ! UPDATED --DECEMBER 1981. ! UPDATED --MAY 1982. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE LGNRAN(N,Iseed,X) INTEGER,intent(in) :: N INTEGER,intent(inout) :: Iseed REAL(kind=wp),intent(out) :: X(:) REAL(kind=wp) :: arg1, arg2, sqrt1, u1, u2, y(2), z1, z2 INTEGER i, ip1 !--------------------------------------------------------------------- ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( N<1 ) THEN WRITE (G_IO,99001) 99001 FORMAT (' ***** FATAL ERROR--The first input argument to LGNRAN(3f) is non-positive *****') WRITE (G_IO,99002) N 99002 FORMAT (' ***** The value of the argument is ',I0,' *****') RETURN ELSE ! ! GENERATE N UNIFORM (0,1) RANDOM NUMBERS; ! THEN GENERATE 2 ADDITIONAL UNIFORM (0,1) RANDOM NUMBERS ! (TO BE USED BELOW IN FORMING THE N-TH NORMAL ! RANDOM NUMBER WHEN THE DESIRED SAMPLE SIZE N ! HAPPENS TO BE ODD). ! CALL UNIRAN(N,Iseed,X) CALL UNIRAN(2,Iseed,y) ! ! GENERATE N NORMAL RANDOM NUMBERS ! USING THE BOX-MULLER METHOD. ! DO i = 1 , N , 2 ip1 = i + 1 u1 = X(i) IF ( i==N ) THEN u2 = y(2) ELSE u2 = X(ip1) ENDIF arg1 = -2.0_wp*LOG(u1) arg2 = 2.0_wp*G_pi*u2 sqrt1 = SQRT(arg1) z1 = sqrt1*COS(arg2) z2 = sqrt1*SIN(arg2) X(i) = z1 IF ( i/=N ) X(ip1) = z2 ENDDO ! ! GENERATE N LOGNORMAL RANDOM NUMBERS ! USING THE DEFINITION THAT ! A LOGNORMAL VARIATE ! EQUALS AN EXPONETIATED NORMAL VARIATE. ! DO i = 1 , N X(i) = EXP(X(i)) ENDDO ENDIF END SUBROUTINE LGNRAN !> !!##NAME !! loc(3f) - [M_datapac:STATISTICS] print the sample mean, midrange, !! midmean, and median !! !!##SYNOPSIS !! !! SUBROUTINE LOC(X,N) !! !! REAL(kind=wp),intent(in) :: X(:) !! INTEGER,intent(in) :: N !! !!##DESCRIPTION !! LOC(3f) computes 4 estimates of the location (typical value, measure !! of central tendency) of the data in the input vector X. !! !! the 4 estimators employed are-- !! !! 1. the sample midrange; !! 2. the sample mean; !! 3. the sample midmean; and !! 4. the sample median. !! !! The above 4 estimators are near-optimal estimators of location for !! shorter-tailed symmetric distributions, moderate-tailed distributions, !! moderate-long-tailed distributions, and long-tailed distributions, !! respectively. !! !!##INPUT ARGUMENTS !! !! X The vector of (unsorted or sorted) observations. !! !! N The integer number of observations in the vector X. !! !!##OUTPUT !! !! 1/4 page of automatic output consisting of the following 4 estimates !! of location for the data in the input vector X !! !! 1. The sample midrange; !! 2. The sample mean; !! 3. The sample midmean; and !! 4. The sample median. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_loc !! use M_datapac, only : loc, label !! implicit none !! integer :: i !! real, allocatable :: x(:), y(:) !! call label('loc') !! y=[(real(i)/10.0,i=1,20000)] !! x=y**3.78-6*y**2.52+9*y**1.26 !! call loc(y,size(y)) !! end program demo_loc !! !! Results: !! !! !! !! !! !! Estimates of the Location Parameter !! !! (The sample size N = 30) !! !! !! The sample midrange is 0.15500000E+01 !! The sample mean is 0.15500000E+01 !! The sample 25 percent trimmed mean is 0.15500001E+01 !! The sample median is 0.15500000E+01 !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !! !!##REFERENCES !! * Dixon and Massey, pages 14, 70, and 71 !! * Crow, Journal of the American Statistical Association, pages 357 !! and 387 !! * Kendall and Stuart, The Advanced Theory of Statistics, Volume 1, !! Edition 2, 1963, page 8. ! ORIGINAL VERSION--JUNE 1972. ! UPDATED --NOVEMBER 1975. ! UPDATED --FEBRUARY 1976. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE LOC(X,N) REAL(kind=wp),intent(in) :: X(:) INTEGER,intent(in) :: N REAL(kind=wp) :: aiflag, an, hold, sum, WS, xmean, xmed, xmid, xmidm INTEGER :: i, iflag, imax, imaxm1, imin, iminp1, iupper, nmid, nmidp1 REAL(kind=wp) :: Y(N) iupper = N ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! xmid = 0.0_wp xmean = 0.0_wp xmidm = 0.0_wp xmed = 0.0_wp IF ( N<1 .OR. N>iupper ) THEN WRITE (G_IO,99001) iupper 99001 FORMAT(' ***** FATAL ERROR--The second input argument to LOC(3f) is outside the allowable (1,',I0,') interval *****') WRITE (G_IO,99002) N 99002 FORMAT (' ','***** the value of the argument is ',I0,' *****') RETURN ELSE IF ( N==1 ) THEN WRITE (G_IO,99003) 99003 FORMAT (' ***** NON-FATAL DIAGNOSTIC--The second input argument to LOC(3f) has the value 1 *****') xmid = X(1) xmean = X(1) xmidm = X(1) xmed = X(1) ELSE hold = X(1) DO i = 2 , N IF ( X(i)/=hold ) GOTO 20 ENDDO WRITE (G_IO,99004) hold 99004 FORMAT (& & ' ***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT (A VECTOR) TO LOC(3f)HAS ALL ELEMENTS = ',E15.8,' *****') ! !-----START POINT----------------------------------------------------- ! 20 continue an = N ! ! SORT THE DATA, ! THEN COMPUTE THE SAMPLE MIDRANGE. ! CALL SORT(X,N,Y) xmid = (Y(1)+Y(N))/2.0_wp ! ! COMPUTE THE SAMPLE MEAN ! sum = 0.0_wp DO i = 1 , N sum = sum + Y(i) ENDDO xmean = sum/an ! ! COMPUTE THE SAMPLE MIDMEAN ! iflag = N - (N/4)*4 aiflag = iflag imin = N/4 + 1 imax = N - imin + 1 sum = 0.0_wp sum = sum + Y(imin)*(4.0_wp-aiflag)/4.0_wp sum = sum + Y(imax)*(4.0_wp-aiflag)/4.0_wp iminp1 = imin + 1 imaxm1 = imax - 1 IF ( iminp1<=imaxm1 ) THEN DO i = iminp1 , imaxm1 sum = sum + Y(i) ENDDO ENDIF xmidm = sum/(an/2.0_wp) ! ! COMPUTE THE SAMPLE MEDIAN ! iflag = N - (N/2)*2 nmid = N/2 nmidp1 = nmid + 1 IF ( iflag==0 ) xmed = (Y(nmid)+Y(nmidp1))/2.0_wp IF ( iflag==1 ) xmed = Y(nmidp1) ENDIF ! ! WRITE EVERYTHING OUT ! WRITE (G_IO,99005) 99005 FORMAT (/,/,/,/,/,' ',30X,'Estimates of the LOCATION Parameter') WRITE (G_IO,99006) N 99006 FORMAT (/,' ',34X,'(The sample size N = ',I0,')') WRITE (G_IO,99007) xmid 99007 FORMAT (/,/,' The sample midrange is ',E15.8) WRITE (G_IO,99008) xmean 99008 FORMAT (' The sample mean is ',E15.8) WRITE (G_IO,99009) xmidm 99009 FORMAT (' The sample 25 Percent Trimmed Mean is ',E15.8) WRITE (G_IO,99010) xmed 99010 FORMAT (' The Sample Median is ',E15.8) ENDIF ! END SUBROUTINE LOC !> !!##NAME !! logcdf(3f) - [M_datapac:CUMULATIVE_DISTRIBUTION] compute the logistic !! cumulative distribution function !! !!##SYNOPSIS !! !! SUBROUTINE LOGCDF(X,Cdf) !! !! REAL(kind=wp),intent(in) :: X !! REAL(kind=wp),intent(out) :: Cdf !! !!##DESCRIPTION !! LOGCDF(3f) computes the cumulative distribution function value for !! the logistic distribution with mean = 0 and standard deviation = !! pi/sqrt(3). !! !! This distribution is defined for all X and has the probability !! density function !! !! f(X) = exp(X)/(1+exp(X)) !! !!##INPUT ARGUMENTS !! !! X The value at which the cumulative distribution function is to !! be evaluated. !!##OUTPUT ARGUMENTS !! !! CDF The cumulative distribution function value. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_logcdf !! !@(#) line plotter graph of cumulative distribution function !! use M_datapac, only : logcdf, plott, label !! implicit none !! real,allocatable :: x(:), y(:) !! integer :: i !! call label('logcdf') !! x=[(real(i),i=-100,100,1)] !! if(allocated(y))deallocate(y) !! allocate(y(size(x))) !! do i=1,size(x) !! call logcdf(x(i)/10.0,y(i)) !! enddo !! call plott(x,y,size(x)) !! end program demo_logcdf !! !! Results: !! !! The following is a plot of Y(I) (vertically) versus X(I) (horizontally) !! I-----------I-----------I-----------I-----------I !! 0.1000000E+03 - X !! 0.9166666E+02 I X !! 0.8333334E+02 I X !! 0.7500000E+02 I X !! 0.6666667E+02 I X !! 0.5833334E+02 I X !! 0.5000000E+02 - X !! 0.4166667E+02 I X !! 0.3333334E+02 I XX !! 0.2500000E+02 I XXX !! 0.1666667E+02 I XXXXX !! 0.8333336E+01 I XXXXXXXX !! 0.0000000E+00 - XX XXXXX XX !! -0.8333328E+01 I XXXXXXXX !! -0.1666666E+02 I XXXXX !! -0.2499999E+02 I XXX !! -0.3333333E+02 I XX !! -0.4166666E+02 I X !! -0.5000000E+02 - X !! -0.5833333E+02 I X !! -0.6666666E+02 I X !! -0.7500000E+02 I X !! -0.8333333E+02 I X !! -0.9166666E+02 I X !! -0.1000000E+03 - X !! I-----------I-----------I-----------I-----------I !! 0.4540E-04 0.2500E+00 0.5000E+00 0.7500E+00 0.1000E+01 !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !! !!##REFERENCES !! * Johnson and Kotz, Continuous Univariate Distributions--2, 1970, !! pages 1-21. ! ORIGINAL VERSION--JUNE 1972. ! UPDATED --MAY 1974. ! UPDATED --SEPTEMBER 1975. ! UPDATED --NOVEMBER 1975. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE LOGCDF(X,Cdf) REAL(kind=wp),intent(in) :: X REAL(kind=wp),intent(out) :: Cdf ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS -- NO INPUT ARGUMENT ERRORS POSSIBLE FOR THIS DISTRIBUTION. ! IF ( X>=0.0_wp ) THEN Cdf = 1.0_wp/(1.0_wp+EXP(-X)) ELSE Cdf = EXP(X)/(1.0_wp+EXP(X)) ENDIF END SUBROUTINE LOGCDF !> !!##NAME !! logpdf(3f) - [M_datapac:PROBABILITY_DENSITY] compute the logistic !! probability density function !! !!##SYNOPSIS !! !! SUBROUTINE LOGPDF(X,Pdf) !! !! REAL(kind=wp),intent(in) :: X !! REAL(kind=wp),intent(out) :: Pdf !! !!##DESCRIPTION !! LOGPDF(3f) computes the probability density function value for !! the logistic distribution with mean = 0 and standard deviation = !! pi/sqrt(3). !! !! This distribution is defined for all X and has the probability !! density function !! !! f(X) = exp(X)/(1+exp(X)) !! !!##INPUT ARGUMENTS !! !! X The value at which the probability density function is to !! be evaluated. !! !!##OUTPUT ARGUMENTS !! !! PDF the probability density function value. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_logpdf !! !@(#) line plotter graph of cumulative distribution function !! use M_datapac, only : logpdf, plott, label !! implicit none !! real,allocatable :: x(:), y(:) !! integer :: i !! call label('logpdf') !! x=[(real(i),i=-100,100,1)] !! if(allocated(y))deallocate(y) !! allocate(y(size(x))) !! do i=1,size(x) !! call logpdf(x(i)/10.0,y(i)) !! enddo !! call plott(x,y,size(x)) !! end program demo_logpdf !! !! Results: !! !! The following is a plot of Y(I) (vertically) versus X(I) (horizontally) !! I-----------I-----------I-----------I-----------I !! 0.1000000E+03 - X !! 0.9166666E+02 I X !! 0.8333334E+02 I X !! 0.7500000E+02 I X !! 0.6666667E+02 I X !! 0.5833334E+02 I XX !! 0.5000000E+02 - XX !! 0.4166667E+02 I XXX !! 0.3333334E+02 I XXXXX !! 0.2500000E+02 I XXXXX XXX X !! 0.1666667E+02 I X XX X X XX X !! 0.8333336E+01 I X X XX X XXX !! 0.0000000E+00 - XXX !! -0.8333328E+01 I X X XX X XXX !! -0.1666666E+02 I X XX X X XX X !! -0.2499999E+02 I XXXXX XXX X !! -0.3333333E+02 I XXXXX !! -0.4166666E+02 I XXX !! -0.5000000E+02 - XX !! -0.5833333E+02 I XX !! -0.6666666E+02 I X !! -0.7500000E+02 I X !! -0.8333333E+02 I X !! -0.9166666E+02 I X !! -0.1000000E+03 - X !! I-----------I-----------I-----------I-----------I !! 0.4540E-04 0.6253E-01 0.1250E+00 0.1875E+00 0.2500E+00 !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !! !!##REFERENCES !! * Johnson and Kotz, Continuous Univariate Distributions--2, 1970, pages 1-21. ! ORIGINAL VERSION--JUNE 1972. ! UPDATED --SEPTEMBER 1975. ! UPDATED --NOVEMBER 1975. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE LOGPDF(X,Pdf) REAL(kind=wp),intent(in) :: X REAL(kind=wp),intent(out) :: Pdf ! CHECK THE INPUT ARGUMENTS FOR ERRORS -- NO INPUT ARGUMENT ERRORS POSSIBLE FOR THIS DISTRIBUTION. ! Pdf = exp(X)/((1.0_wp+exp(X))**2) ! END SUBROUTINE LOGPDF !> !!##NAME !! logplt(3f) - [M_datapac:LINE_PLOT] generate a logistic probability !! plot !! !!##SYNOPSIS !! !! SUBROUTINE LOGPLT(X,N) !! !! INTEGER,intent(in) :: N !! REAL(kind=wp),intent(in) :: X(:) !! !!##DESCRIPTION !! LOGPLT(3f) generates a logistic probability plot. !! !! The prototype logistic distribution used herein has mean = 0 and !! standard deviation = pi/sqrt(3). This distribution is defined for !! all X and has the probability density function !! !! f(X) = exp(X) / (1+exp(X)) !! !! As used herein, a probability plot for a distribution is a plot !! of the ordered observations versus the order statistic medians for !! that distribution. !! !! The logistic probability plot is useful in graphically testing !! the composite (that is, location and scale parameters need not be !! specified) hypothesis that the underlying distribution from which !! the data have been randomly drawn is the logistic distribution. !! !! If the hypothesis is true, the probability plot should be near-linear. !! !! A measure of such linearity is given by the calculated probability !! plot correlation coefficient. !! !!##INPUT ARGUMENTS !! !! X The vector of (unsorted or sorted) observations. !! !! N The integer number of observations in the vector X. !! The maximum allowable value of N for this subroutine is 7500. !!##OUTPUT !! !! A one-page logistic probability plot. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_logplt !! use M_datapac, only : logplt !! implicit none !! ! call logplt(x,y) !! end program demo_logplt !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !! !!##REFERENCES !! * Filliben, 'Techniques for Tail Length Analysis', Proceedings of the !! Eighteenth Conference on the Design of Experiments in Army Research !! Development and testing (Aberdeen, Maryland, October, 1972), pages !! 425-450. !! * Hahn and Shapiro, Statistical Methods in Engineering, 1967, pages !! 260-308. !! * Johnson and Kotz, Continuous Univariate Distributions--2, 1970, !! pages 1-21. ! ORIGINAL VERSION--JUNE 1972. ! UPDATED --SEPTEMBER 1975. ! UPDATED --NOVEMBER 1975. ! UPDATED --FEBRUARY 1976. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE LOGPLT(X,N) INTEGER,intent(in) :: N REAL(kind=wp),intent(in) :: X(:) REAL(kind=wp) :: an, cc, hold, sum1, sum2, sum3, tau, W, wbar, WS, Y, ybar, yint, yslope INTEGER :: i, iupper DIMENSION Y(7500), W(7500) COMMON /BLOCK2_real32/ WS(15000) EQUIVALENCE (Y(1),WS(1)) EQUIVALENCE (W(1),WS(7501)) ! DATA tau/1.63473745_wp/ ! iupper = 7500 ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( N<1 .OR. N>iupper ) THEN WRITE (G_IO,99001) iupper 99001 FORMAT (' ', & & '***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE LOGPLT SUBROUTINE IS OUTSIDE THE ALLOWABLE (1,', & & I0, & & ') INTERVAL *****') WRITE (G_IO,99002) N 99002 FORMAT (' ','***** THE VALUE OF THE ARGUMENT IS ',I0,' *****') RETURN ELSEIF ( N==1 ) THEN WRITE (G_IO,99003) 99003 FORMAT (' ***** NON-FATAL DIAGNOSTIC--THE SECOND INPUT ARGUMENT TO THE LOGPLT SUBROUTINE HAS THE VALUE 1 *****') RETURN ELSE hold = X(1) DO i = 2 , N IF ( X(i)/=hold ) GOTO 50 ENDDO WRITE (G_IO,99004) hold 99004 FORMAT (' ', & &'***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT (A VECTOR) TO THE LOGPLT SUBROUTINE HAS ALL ELEMENTS = ',& & E15.8,& & ' *****') ! !-----START POINT----------------------------------------------------- ! 50 an = N ! ! SORT THE DATA ! CALL SORT(X,N,Y) ! ! GENERATE UNIFORM ORDER STATISTIC MEDIANS ! CALL UNIMED(N,W) ! ! COMPUTE LOGISTIC ORDER STATISTIC MEDIANS ! DO i = 1 , N W(i) = LOG(W(i)/(1.0_wp-W(i))) ENDDO ! ! PLOT THE ORDERED OBSERVATIONS VERSUS ORDER STATISTICS MEDIANS. ! WRITE OUT THE TAIL LENGTH MEASURE OF THE DISTRIBUTION ! AND THE SAMPLE SIZE. ! CALL PLOT(Y,W,N) WRITE (G_IO,99005) tau , N 99005 FORMAT (' ','LOGISTIC PROBABILITY PLOT (TAU = ',E15.8,')',54X, 'THE SAMPLE SIZE N = ',I0) ! ! COMPUTE THE PROBABILITY PLOT CORRELATION COEFFICIENT. ! COMPUTE LOCATION AND SCALE ESTIMATES ! FROM THE INTERCEPT AND SLOPE OF THE PROBABILITY PLOT. ! THEN WRITE THEM OUT. ! sum1 = 0.0_wp DO i = 1 , N sum1 = sum1 + Y(i) ENDDO ybar = sum1/an wbar = 0.0_wp sum1 = 0.0_wp sum2 = 0.0_wp sum3 = 0.0_wp DO i = 1 , N sum1 = sum1 + (Y(i)-ybar)*(Y(i)-ybar) sum2 = sum2 + W(i)*Y(i) sum3 = sum3 + W(i)*W(i) ENDDO cc = sum2/SQRT(sum3*sum1) yslope = sum2/sum3 yint = ybar - yslope*wbar WRITE (G_IO,99006) cc , yint , yslope 99006 FORMAT (' ','PROBABILITY PLOT CORRELATION COEFFICIENT = ',F8.5,& & 5X,'ESTIMATED INTERCEPT = ',E15.8,3X, & & 'ESTIMATED SLOPE = ',E15.8) ENDIF END SUBROUTINE LOGPLT !> !!##NAME !! logppf(3f) - [M_datapac:PERCENT_POINT] compute the logistic percent !! point function !! !!##SYNOPSIS !! !! SUBROUTINE LOGPPF(P,Ppf) !! !! REAL(kind=wp),intent(in) :: P !! REAL(kind=wp),intent(out) :: Ppf !! !!##DESCRIPTION !! LOGPPF(3f) computes the percent point function value for the logistic !! distribution with mean = 0 and standard deviation = pi/sqrt(3). !! !! This distribution is defined for all X and has the probability !! density function !! !! f(X) = exp(X)/(1+exp(X)) !! !! Note that the percent point function of a distribution is identically !! the same as the inverse cumulative distribution function of the !! distribution. !! !! !!##INPUT ARGUMENTS !! P The value at which the percent point function is to be !! evaluated. !! !! P should be between 0.0 and 1.0, exclusively. !! !!##OUTPUT ARGUMENTS !! !! PPF The percent point function value. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_logppf !! use M_datapac, only : logppf, plott, label !! implicit none !! integer,parameter :: n=40 !! real :: x(n), y(n) !! integer :: i !! call label('logppf') !! x=[(real(i)/real(n+1),i=1,n)] !! do i=1,n !! call logppf(x(i),y(i)) !! enddo !! call plott(x,y,n) !! end program demo_logppf !! !! Results: !! !! The following is a plot of Y(I) (vertically) versus X(I) (horizontally) !! I-----------I-----------I-----------I-----------I !! 0.9756098E+00 - X !! 0.9359756E+00 I X X !! 0.8963415E+00 I XX !! 0.8567073E+00 I X !! 0.8170732E+00 I XX !! 0.7774390E+00 I X !! 0.7378049E+00 - X !! 0.6981707E+00 I XX !! 0.6585366E+00 I X !! 0.6189024E+00 I XX !! 0.5792683E+00 I X !! 0.5396341E+00 I X !! 0.5000000E+00 - X !! 0.4603658E+00 I X !! 0.4207317E+00 I X !! 0.3810976E+00 I XX !! 0.3414634E+00 I X !! 0.3018292E+00 I XX !! 0.2621951E+00 - X !! 0.2225609E+00 I X !! 0.1829268E+00 I XX !! 0.1432927E+00 I X !! 0.1036585E+00 I XX !! 0.6402433E-01 I X X !! 0.2439024E-01 - X !! I-----------I-----------I-----------I-----------I !! -0.3689E+01 -0.1844E+01 0.4768E-06 0.1844E+01 0.3689E+01 !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !! !!##REFERENCES !! * Filliben, Simple and Robust Linear Estimation of the Location !! Parameter of a Symmetric Distribution (Unpublished PH.D. Dissertation, !! Princeton University), 1969, pages 21-44, 229-231. !! * Filliben, 'The Percent Point Function', (Unpublished Manuscript), !! 1970, pages 28-31. !! * Johnson and Kotz, Continuous Univariate Distributions--2, 1970, !! pages 1-21. ! ORIGINAL VERSION--JUNE 1972. ! UPDATED --SEPTEMBER 1975. ! UPDATED --NOVEMBER 1975. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE LOGPPF(P,Ppf) REAL(kind=wp),intent(in) :: P REAL(kind=wp),intent(out) :: Ppf !--------------------------------------------------------------------- ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( P<=0.0_wp .OR. P>=1.0_wp ) THEN WRITE (G_IO,99001) WRITE (G_IO,99002) P ELSE Ppf = LOG(P/(1.0_wp-P)) ENDIF ! 99001 FORMAT(' ***** FATAL ERROR--The first input argument to LOGPPF(3f) is outside the allowable (0,1) interval *****') 99002 FORMAT (' ','***** The value of the argument is ',g0, ' *****') END SUBROUTINE LOGPPF !> !!##NAME !! logran(3f) - [M_datapac:RANDOM] generate logistic random numbers !! !!##SYNOPSIS !! !! SUBROUTINE LOGRAN(N,Iseed,X) !! !! INTEGER,intent(in) :: N !! INTEGER,intent(inout) :: Iseed !! REAL(kind=wp),intent(out) :: X(:) !! !!##DESCRIPTION !! LOGRAN(3f) generates a random sample of size N from the logistic !! distribution with mean = 0 and standard deviation = pi/sqrt(3). !! !! This distribution is defined for all X and has the probability !! density function !! !! f(X) = exp(X)/(1+exp(X)) !! !!##INPUT ARGUMENTS !! !! N The desired integer number of random numbers to be generated. !! !! ISEED An integer seed value. Should be set to a non-negative value !! to start a new sequence of values. Will be set to -1 on return !! to indicate the next call should continue the current random !! sequence walk. !! !!##OUTPUT ARGUMENTS !! !! X A vector (of dimension at least N) into which the generated !! random sample of size N from the logistic distribution will !! be placed. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_logran !! use m_datapac, only : logran, plott, label, plotxt, sort !! implicit none !! integer,parameter :: n=4000 !! integer :: iseed !! real :: x(n) !! call label('logran') !! iseed=12345 !! call logran(N,Iseed,X) !! call plotxt(x,n) !! call sort(x,n,x) ! sort to show distribution !! call plotxt(x,n) !! end program demo_logran !! !! Results: !! !! !! THE FOLLOWING IS A PLOT OF X(I) (VERTICALLY) VERSUS I (HORIZONTALLY !! I-----------I-----------I-----------I-----------I !! 0.1011046E+02 - X !! 0.9310020E+01 I !! 0.8509579E+01 I X !! 0.7709137E+01 I X !! 0.6908696E+01 I X !! 0.6108254E+01 I X X X X X XXX !! 0.5307813E+01 - X X X X XX X X X X X X !! 0.4507371E+01 I X X X X XXX XXXX XXX X X X XX X X X !! 0.3706930E+01 I XXXXXXXXXXXXX XX XX XXX XXXXXXXXXXXXXXXXX X XXXXX !! 0.2906488E+01 I XXXXXXXXXXXXXXXXXXXXX XXXXXXXXXXXXXXXXXXXXXXXXXXX !! 0.2106047E+01 I XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX !! 0.1305605E+01 I XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX !! 0.5051632E+00 - XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX !! -0.2952785E+00 I XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX !! -0.1095719E+01 I XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX !! -0.1896161E+01 I XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX !! -0.2696603E+01 I XXXXXXXXXXXXXXXXXXXXXXXXX XXXX XXXXXXXXXXXXXXXXXX !! -0.3497045E+01 I XX XXXX XXXXX XXXXXXXX XX XXXX XXXX XXXXXXXXXXXX !! -0.4297486E+01 - XXX XXXXXXX XX X XXX XXX XXXX XXXXX X X XXXX !! -0.5097927E+01 I XX X X X XXX XX X XXXX X XXX !! -0.5898369E+01 I X X X XX XXX X X !! -0.6698811E+01 I X !! -0.7499252E+01 I X !! -0.8299694E+01 I !! -0.9100137E+01 - X !! I-----------I-----------I-----------I-----------I !! 0.1000E+01 0.1001E+04 0.2000E+04 0.3000E+04 0.4000E+04 !! !! THE FOLLOWING IS A PLOT OF X(I) (VERTICALLY) VERSUS I (HORIZONTALLY !! I-----------I-----------I-----------I-----------I !! 0.1011046E+02 - X !! 0.9310020E+01 I !! 0.8509579E+01 I X !! 0.7709137E+01 I X !! 0.6908696E+01 I X !! 0.6108254E+01 I X !! 0.5307813E+01 - X !! 0.4507371E+01 I XX !! 0.3706930E+01 I XX !! 0.2906488E+01 I XXX !! 0.2106047E+01 I XXXXX !! 0.1305605E+01 I XXXXXXXX !! 0.5051632E+00 - XXXXXXXXX !! -0.2952785E+00 I XXXXXXXXXX !! -0.1095719E+01 I XXXXXXXX !! -0.1896161E+01 I XXXXXX !! -0.2696603E+01 I XXX !! -0.3497045E+01 I XX !! -0.4297486E+01 - XX !! -0.5097927E+01 I X !! -0.5898369E+01 I X !! -0.6698811E+01 I X !! -0.7499252E+01 I X !! -0.8299694E+01 I !! -0.9100137E+01 - X !! I-----------I-----------I-----------I-----------I !! 0.1000E+01 0.1001E+04 0.2000E+04 0.3000E+04 0.4000E+04 !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !!##MAINTAINER !! John Urban, 2022.05.31 !!##LICENSE !! CC0-1.0 !!##REFERENCES !! * Tocher, The Art of Simulation, 1963, pages 14-15. !! * Hammersley and Handscomb, Monte Carlo Methods, 1964, page 36. !! * Filliben, Simple and Robust Linear Estimation of the Location !! Parameter of a Symmetric Distribution (Unpublished PH.D. Dissertation, !! Princeton University), 1969, page 230. !! * Filliben, 'The Percent Point Function', (Unpublished Manuscript), !! 1970, pages 28-31. !! * Johnson and Kotz, Continuous Univariate Distributions--2, 1970, !! pages 1-21. ! VERSION NUMBER--82.6 ! ORIGINAL VERSION--JUNE 1972. ! UPDATED --SEPTEMBER 1975. ! UPDATED --NOVEMBER 1975. ! UPDATED --DECEMBER 1981. ! UPDATED --MAY 1982. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE LOGRAN(N,Iseed,X) INTEGER,intent(in) :: N INTEGER,intent(inout) :: Iseed REAL(kind=wp),intent(out) :: X(:) INTEGER :: i !--------------------------------------------------------------------- ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( N<1 ) THEN WRITE (G_IO,99001) 99001 FORMAT (' ***** FATAL ERROR--The first input argument to LOGRAN(3f) is non-positive *****') WRITE (G_IO,99002) N 99002 FORMAT (' ','***** The value of the argument is ',I0,' *****') RETURN ELSE ! ! GENERATE N UNIFORM (0,1) RANDOM NUMBERS; ! CALL UNIRAN(N,Iseed,X) ! ! GENERATE N LOGISTIC RANDOM NUMBERS ! USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD. ! DO i = 1 , N X(i) = LOG(X(i)/(1.0_wp-X(i))) ENDDO ENDIF END SUBROUTINE LOGRAN !> !!##NAME !! logsf(3f) - [M_datapac:SPARSITY] compute the logistic sparsity function !! !!##SYNOPSIS !! !! SUBROUTINE LOGSF(P,Sf) !! !! REAL(kind=wp),intent(in) :: P !! REAL(kind=wp),intent(out) :: Sf !! !!##DESCRIPTION !! LOGSF(3f) computes the sparsity function value for the logistic !! distribution with mean = 0 and standard deviation = pi/sqrt(3). !! !! This distribution is defined for all X and has the probability !! density function !! !! f(X) = exp(X)/(1+exp(X)) !! !! Note that the sparsity function of a distribution is the derivative !! of the percent point function, and also is the reciprocal of the !! probability density function (but in units of P rather than X). !! !!##INPUT ARGUMENTS !! P The value at which the sparsity function is to be evaluated. !! P should be between 0.0 and 1.0, exclusively. !!##OUTPUT ARGUMENTS !! SF The sparsity function value. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_logsf !! use M_datapac, only : logsf !! implicit none !! ! call logsf(x,y) !! end program demo_logsf !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !! !!##REFERENCES !! * Filliben, Simple and Robust Linear Estimation of the Location !! Parameter of a Symmetric Distribution (Unpublished PH.D. Dissertation, !! Princeton University), 1969, pages 21-44, 229-231. !! * Filliben, 'The Percent Point Function', (Unpublished Manuscript), !! 1970, pages 28-31. !! * Johnson and Kotz, Continuous Univariate Distributions--2, 1970, !! pages 1-21. ! ORIGINAL VERSION--JUNE 1972. ! UPDATED --SEPTEMBER 1975. ! UPDATED --NOVEMBER 1975. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE LOGSF(P,Sf) REAL(kind=wp),intent(in) :: P REAL(kind=wp),intent(out) :: Sf !--------------------------------------------------------------------- ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( P<=0.0_wp .OR. P>=1.0_wp ) THEN WRITE (G_IO,99001) 99001 FORMAT (' ***** FATAL ERROR--The first input argument to LOGSF(3f) is outside the allowable (0,1) interval *****') WRITE (G_IO,99002) P 99002 FORMAT (' ','***** The value of the argument is ',E15.8,' *****') RETURN ELSE Sf = 1.0_wp/(P-P*P) ENDIF END SUBROUTINE LOGSF !> !!##NAME !! max(3f) - [M_datapac:VECTOR_OPERATION] MAX compute the maximum of a !! data vector !! !!##SYNOPSIS !! !! SUBROUTINE MAX(X,N,Iwrite,Xmax) !! !! REAL(kind=wp) :: X(:) , Xmax !! INTEGER :: Iwrite , N !! !!##DESCRIPTION !! !! MAX(3f) computes the sample maximum of the data in the input vector x. !! !!##INPUT ARGUMENTS !! !! X The vector of (unsorted or sorted) observations. !! !! N The integer number of observations in the vector X. !! !! IWRITE An integer flag code which (if set to 0) will suppress !! the printing of the sample maximum as it is computed; !! or (if set to some integer value not equal to 0), !! like, say, 1) will cause the printing of the !! sample maximum at the time it is computed. !! !!##OUTPUT ARGUMENTS !! !! XMAX The value of the computed sample maximum. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_max !! !use M_datapac, only : max, label !! use M_datapac, only : intel_max=>max, label ! ifort (IFORT) 2021.3.0 20210609 bug !! !! implicit none !! real :: xmax !! call label('max') !! call intel_max([-100.0, 200.0, 0.0, 400.0, -200.0],5,1,xmax) !! !call max([-100.0, 200.0, 0.0, 400.0, -200.0],5,1,xmax) !! write(*,*)xmax !! end program demo_max !! !! Results: !! !! THE MAXIMUM OF THE SET OF 5 OBSERVATIONS IS 0.40000000E+03 !! 400.000000 !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !!##MAINTAINER !! John Urban, 2022.05.31 !!##LICENSE !! CC0-1.0 !!##REFERENCES !! * David, Order Statistics, 1970, page 7. ! ORIGINAL VERSION--JUNE 1972. ! UPDATED --SEPTEMBER 1975. ! UPDATED --NOVEMBER 1975. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE MAX(X,N,Iwrite,Xmax) REAL(kind=wp) :: hold , X(:) , Xmax INTEGER i , Iwrite , N !--------------------------------------------------------------------- ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( N<1 ) THEN WRITE (G_IO,99001) 99001 FORMAT (' ***** FATAL ERROR--The second input argument to MAX(3f) is non-positive *****') WRITE (G_IO,99002) N 99002 FORMAT (' ','***** The value of the argument is ',I0,' *****') RETURN ELSE IF ( N==1 ) THEN WRITE (G_IO,99003) 99003 FORMAT (' ***** NON-FATAL DIAGNOSTIC--The second input argument to MAX(3f) has the value 1 *****') Xmax = X(1) ELSE hold = X(1) DO i = 2 , N IF ( X(i)/=hold ) GOTO 50 ENDDO WRITE (G_IO,99004) hold 99004 FORMAT (' ***** NON-FATAL DIAGNOSTIC--the first input argument (a vector) to MAX(3f) has all elements = ',g0,' *****') Xmax = X(1) ENDIF GOTO 100 50 continue Xmax = X(1) DO i = 2 , N IF ( X(i)>Xmax ) Xmax = X(i) ENDDO ENDIF 100 continue IF ( Iwrite==0 ) RETURN WRITE (G_IO,99005) 99005 FORMAT (' ') WRITE (G_IO,99006) N , Xmax 99006 FORMAT (' ','The maximum of the set of ',I0,' observations is ', e15.8) end subroutine max !> !!##NAME !! mean(3f) - [M_datapac:STATISTICS] compute the sample mean of a data vector !! !!##SYNOPSIS !! !! subroutine mean(X,N,Iwrite,Xmean) !! !! real(kind=wp),intent(in) :: X(:) !! integer,intent(in) :: N !! integer,intent(in) :: Iwrite !! real(kind=wp),intent(out) :: Xmean !! !!##DESCRIPTION !! MEAN(3f) computes the sample mean of the data in the input vector X. !! !! The sample mean = (sum of the observations)/n. !! !! For a data set, the arithmetic mean, also known as arithmetic !! average, is a measure of central tendency of a finite set of numbers: !! specifically, the sum of the values divided by the number of values. If !! the data set were based on a series of observations obtained by !! sampling from a statistical population, the arithmetic mean is the !! sample mean. !! !!##INPUT ARGUMENTS !! X The vector of (unsorted or sorted) observations. !! !! N The integer number of observations in the vector X. !! !! IWRITE An integer flag code which (if set to 0) will suppress !! the printing of the sample mean as it is computed; or (if set !! to some integer value not equal to 0), like, say, 1) will cause !! the printing of the sample mean at the time it is computed. !! !!##OUTPUT ARGUMENTS !! !! XMEAN The value of the computed sample mean. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_mean !! use M_datapac, only : mean, label !! implicit none !! real :: sp_mean !! double precision :: dp_mean !! call label('mean') !! call mean([4.0, 36.0, 45.0, 50.0, 75.0], 5, 1, sp_mean) !! write(*,*)sp_mean,sp_mean==42.0 !! call mean([4.0d0, 36.0d0, 45.0d0, 50.0d0, 75.0d0], 5, 1, dp_mean) !! write(*,*)dp_mean,dp_mean==42.0 !! end program demo_mean !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !! !!##REFERENCES !! * Kendall and Stuart, The Advanced Theory of Statistics, Volume 2, !! Edition 1, 1961, page 4. !! * Mood and Grable, Introduction to the Theory of Statistics, Edition 2, !! 1963, page 146. !! * Dixon and Massey, Introduction to Statistical Analysis, Edition 2, !! 1957, page 14. ! ORIGINAL VERSION--JUNE 1972. ! UPDATED --SEPTEMBER 1975. ! UPDATED --NOVEMBER 1975. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 subroutine mean(X,N,Iwrite,Xmean) real(kind=wp),intent(in) :: X(:) integer,intent(in) :: N integer,intent(in) :: Iwrite real(kind=wp),intent(out) :: Xmean integer :: i real(kind=wp) :: an, hold, sum an = real(N,kind=wp) ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! if ( N<1 ) then write (G_io,99001) 99001 format (' ***** FATAL ERROR--The second input argument to MEAN(3f) is non-positive *****') write (G_io,99002) N 99002 format (' ','***** The value of the argument is ',I0,' *****') return elseif ( N==1 ) then write (G_io,99003) 99003 format (' ***** NON-FATAL DIAGNOSTIC--The second input argument to MEAN(3f) has the value 1 *****') Xmean = X(1) else hold = X(1) if(all(x(2:n) == hold)) then write (G_io,99004) hold 99004 format(& &' ***** NON-FATAL DIAGNOSTIC--The first input argument (a vector) to MEAN(3f) has all elements = ',g0,' *****') Xmean = X(1) else sum = 0.0_wp do i = 1 , N sum = sum + X(i) enddo Xmean = sum/an endif endif if ( Iwrite /= 0 ) then write (G_io,99006) N , Xmean 99006 format (/,' The sample mean of the ',I0,' observations is ', g0) endif end subroutine mean !> !!##NAME !! median(3f) - [M_datapac:STATISTICS] compute the median of a data vector !! !!##SYNOPSIS !! !! SUBROUTINE MEDIAN(X,N,Iwrite,Xmed) !! !! REAL(kind=wp) :: WS , X(:) , Xmed !! INTEGER :: Iwrite , N !! !!##DESCRIPTION !! MEDIAN(3f) computes the sample median of the data in the input !! vector X. !! !! The sample median equals that value such that half the data set is !! below it and half above it. !! !!##INPUT ARGUMENTS !! X The vector of (unsorted or sorted) observations. !! !! N The integer number of observations in the vector X. !! !! The maximum allowable value of N for this subroutine is 15000. !! !! IWRITE An integer flag code which (if set to 0) will suppress the !! printing of the sample median as it is computed; or (if set to !! some integer value not equal to 0), like, say, 1) will cause !! the printing of the sample median at the time it is computed. !! !!##OUTPUT ARGUMENTS !! !! XMED The value of the computed sample median. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_median !! use M_datapac, only : median, label !! implicit none !! character(len=*),parameter :: g='(*(g0,1x))' !! real,allocatable :: x(:) !! real :: xmed !! integer :: iwrite , n !! !! call label('median') !! x=[ -10.0, 10.0, 0.0, 1.0, 2.0 ] !! n=size(x) !! call median(x, n, 1, xmed) !! write(*,g)' median of',x,'is',xmed !! !! x=[ 10.0, 20.0, 3.0, 40.0 ] !! n=size(x) !! call median(x, n, 1, xmed) !! write(*,g)' median of',x,'is',xmed !! !! end program demo_median !! !! Results: !! !! The sample median of the 5 observations is 0.10000000E+01 !! median of -10.00000 10.00000 .000000 1.000000 2.000000 is 1.000000 !! !! The sample median of the 4 observations is 0.15000000E+02 !! median of 10.00000 20.00000 3.000000 40.00000 is 15.00000 !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !! !!##REFERENCES !! * Kendall and Stuart, The Advanced Theory of Statistics, Volume 1, Edition 2, 1963, page 326. !! * Kendall and Stuart, The Advanced Theory of Statistics, Volume 2, Edition 1, 1961, page 49. !! * David, Order Statistics, 1970, page 139. !! * Snedecor and Cochran, Statistical Methods, Edition 6, 1967, page 123. !! * Dixon and Massey, Introduction to Statistical Analysis, Edition 2, 1957, page 70. ! ORIGINAL VERSION--JUNE 1972. ! UPDATED --SEPTEMBER 1975. ! UPDATED --NOVEMBER 1975. ! UPDATED --FEBRUARY 1976. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE MEDIAN(X,N,Iwrite,Xmed) REAL(kind=wp) :: hold , WS , X(:) , Xmed , Y(15000) INTEGER :: i , iflag , iupper , Iwrite , N , nmid , nmidp1 COMMON /BLOCK2_real32/ WS(15000) EQUIVALENCE (Y(1),WS(1)) ! iupper = 15000 ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( N<1 .OR. N>iupper ) THEN WRITE (G_IO,99001) iupper 99001 FORMAT (& & ' ***** FATAL ERROR--The second input argument to MEDIAN(3f) is outside the allowable (1,',I0,') interval *****') WRITE (G_IO,99002) N 99002 FORMAT (' ','***** The value of the argument is ',I0,' *****') RETURN ELSE IF ( N==1 ) THEN WRITE (G_IO,99003) 99003 FORMAT (' ',& & '***** NON-FATAL DIAGNOSTIC--The second input argument to MEDIAN(3f) has the value 1 *****') Xmed = X(1) ELSE hold = X(1) DO i = 2 , N IF ( X(i)/=hold ) GOTO 50 ENDDO WRITE (G_IO,99004) hold 99004 FORMAT (' ',& & '***** NON-FATAL DIAGNOSTIC--the first input argument (a vector) to MEDIAN(3f) has all elements = ',g0,' *****') Xmed = X(1) ENDIF GOTO 100 ! !-----START POINT----------------------------------------------------- ! 50 CALL SORT(X,N,Y) iflag = N - (N/2)*2 nmid = N/2 nmidp1 = nmid + 1 IF ( iflag==0 ) Xmed = (Y(nmid)+Y(nmidp1))/2.0_wp IF ( iflag==1 ) Xmed = Y(nmidp1) ENDIF ! 100 IF ( Iwrite==0 ) RETURN WRITE (G_IO,99005) 99005 FORMAT (' ') WRITE (G_IO,99006) N , Xmed 99006 FORMAT (' The sample median of the ',I0,' observations is ', g0) END SUBROUTINE MEDIAN !> !!##NAME !! midm(3f) - [M_datapac:STATISTICS] compute the midmean of a data vector !! !!##SYNOPSIS !! !! SUBROUTINE MIDM(X,N,Iwrite,Xmidm) !! !! REAL(kind=wp) :: X(:) !! INTEGER :: N !! INTEGER :: Iwrite !! REAL(kind=wp) :: Xmidm !! !!##DESCRIPTION !! MIDM(3f) computes the sample midmean = the sample 25% (on each side) !! trimmed mean of the data in the input vector X. !! !! !!##INPUT ARGUMENTS !! !! X The vector of (unsorted or sorted) observations. !! !! N The integer number of observations in the vector X. !! !! IWRITE An integer flag code which (if set to 0) will suppress the !! printing of the sample midmean as it is computed; or (if set !! to some integer value not equal to 0), like, say, 1) will cause !! the printing of the sample midmean at the time it is computed. !! !!##OUTPUT ARGUMENTS !! !! XMIDM The value of the computed sample midmean. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_midm !! use M_datapac, only : midm, label !! implicit none !! integer :: i !! real :: xmidm !! call label('midm') !! !! call midm([real :: (i,i=0,100) ],101,1,xmidm) !! write(*,*)merge('GOOD','BAD ',xmidm == 50.0),xmidm !! !! call midm([real :: (i,i=0,101) ],102,1,xmidm) !! write(*,*)merge('GOOD','BAD ',xmidm == 50.5),xmidm !! !! end program demo_midm !! !! Results: !! !! The sample MIDMEAN of the 101 observations is 0.50000000E+02 !! 25.0000 PERCENT (=25 observations) of the data were trimmed from below !! 25.0000 PERCENT (=25 observations) of the data were trimmed from above !! 50.0000 PERCENT (=51 observations) of the data remain in the middle ... !! after the trimming !! GOOD 50.00000 !! !! The sample MIDMEAN of the 102 observations is 0.50500000E+02 !! 25.0000 PERCENT (=25 observations) of the data were trimmed from below !! 25.0000 PERCENT (=25 observations) of the data were trimmed from above !! 50.0000 PERCENT (=52 observations) of the data remain in the middle ... !! after the trimming !! GOOD 50.50000 !! !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !! !!##REFERENCES !! * David, Order Statistics, 1970, pages 129, 136. !! * Crow and Siddiqui, 'Robust Estimation of Location', Journal of the !! American Statistical Association, 1967, pages 357, 387. !! * Filliben, Simple and Robust Linear Estimation of the Location !! Parameter of a Symmetric Distribution (Unpublished PH.D. Dissertation, !! Princeton University, 1969). ! ORIGINAL VERSION--JUNE 1972. ! UPDATED --SEPTEMBER 1975. ! UPDATED --NOVEMBER 1975. ! UPDATED --FEBRUARY 1976. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE MIDM(X,N,Iwrite,Xmidm) REAL(kind=wp) :: X(:) INTEGER :: N INTEGER :: Iwrite REAL(kind=wp) :: Xmidm REAL(kind=wp) :: ak, an, hold, p1, p2, perp1, perp2, perp3, sum INTEGER :: i, istart, istop, iupper, k, np1, np2 REAL(kind=wp) :: Y(N) DATA p1, p2, perp1, perp2, perp3/0.25_wp, 0.25_wp, 25.0_wp, 25.0_wp, 50.0_wp/ ! iupper = N ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! an = N IF ( N<1 .OR. N>iupper ) THEN WRITE (G_IO,99001) iupper 99001 FORMAT(' ***** FATAL ERROR--the second input argument to MIDM(3f) is outside the allowable (1,',I0,') interval *****') WRITE (G_IO,99002) N 99002 FORMAT (' ','***** the value of the argument is ',I0,' *****') RETURN ELSE IF ( N==1 ) THEN WRITE (G_IO,99003) 99003 FORMAT (' ***** NON-FATAL DIAGNOSTIC--The second input argument to midm(3f) has the value 1 *****') Xmidm = X(1) ELSE hold = X(1) DO i = 2 , N IF ( X(i)/=hold ) GOTO 50 ENDDO WRITE (G_IO,99004) hold 99004 FORMAT (& & ' ***** NON-FATAL DIAGNOSTIC--The first input argument (a vector) to midm(3F) has all elements = ',E15.8,' *****') Xmidm = X(1) ENDIF GOTO 100 ! !-----START POINT----------------------------------------------------- ! 50 CALL SORT(X,N,Y) ! an = N np1 = p1*an + 0.0001_wp istart = np1 + 1 np2 = p2*an + 0.0001_wp istop = N - np2 sum = 0.0_wp k = 0 IF ( istart>istop ) THEN WRITE (G_IO,99005) 99005 FORMAT (' ','INTERNAL ERROR in MIDM(3f) -- The start index is higher than the stop index') Xmidm = 0.0_wp RETURN ELSE DO i = istart , istop k = k + 1 sum = sum + Y(i) ENDDO ak = k Xmidm = sum/ak ENDIF ENDIF ! 100 IF ( Iwrite==0 ) RETURN WRITE (G_IO,99006) 99006 FORMAT (' ') WRITE (G_IO,99007) N , Xmidm 99007 FORMAT (' The sample MIDMEAN of the ',I0,' observations is ',E15.8) WRITE (G_IO,99008) perp1 , np1 99008 FORMAT (' ',8X,F10.4,' PERCENT (= ',I0,' observations) of the data were trimmed from below') WRITE (G_IO,99009) perp2 , np2 99009 FORMAT (' ',8X,F10.4,' PERCENT (= ',I0,' observations) of the data were trimmed from above') WRITE (G_IO,99010) perp3 , k 99010 FORMAT (' ',8X,F10.4,' PERCENT (= ',I0,' observations) of the data remain in the middle after the trimming') ! END SUBROUTINE MIDM !> !!##NAME !! midr(3f) - [M_datapac:STATISTICS] compute the midrange of a data vector !! !!##SYNOPSIS !! !! SUBROUTINE MIDR(X,N,Iwrite,Xmidr) !! !! REAL(kind=wp),intent(in) :: X(:) !! INTEGER,intent(in) :: N !! INTEGER,intent(in) :: Iwrite !! REAL(kind=wp),intent(out) :: Xmidr !! !!##DESCRIPTION !! MIDR(3f) computes the sample midrange of the data in the input !! vector X. !! !! The sample midrange = (sample min + sample max)/2. !! !!##INPUT ARGUMENTS !! !! X The vector of (unsorted or sorted) observations. !! !! N The integer number of observations in the vector X. !! !! IWRITE An integer flag code which (if set to 0) will suppress the !! printing of the sample midrange as it is computed; or (if set !! to some integer value not equal to 0), like, say, 1) will cause !! the printing of the sample midrange at the time it is computed. !! !!##OUTPUT ARGUMENTS !! !! XMIDR the value of the computed sample midrange. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_midr !! use M_datapac, only : midr, label !! implicit none !! integer :: i !! real :: xmidr !! call label('midr') !! !! call midr([real :: (i,i=0,100) ],101,1,xmidr) !! write(*,*)merge('GOOD','BAD ',xmidr == 50.0),xmidr !! !! call midr([real :: (i,i=0,101) ],102,1,xmidr) !! write(*,*)merge('GOOD','BAD ',xmidr == 50.5),xmidr !! !! end program demo_midr !! !! Results: !! !! The sample MIDRANGE of the 101 observations IS 0.500000000000000E+02 !! GOOD 50.00000 !! !! The sample MIDRANGE of the 102 observations is 0.505000000000000E+02 !! GOOD 50.50000 !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !! !!##REFERENCES !! * Kendall and Stuart, The Advanced Theory of Statistics, Volume 1, !! Edition 2, 1963, page 338. !! * Kendall and Stuart, The Advanced Theory of Statistics, Volume 2, !! Edition 1, 1961, page 91. !! * David, Order Statistics, 1970, page 97. !! * Dixon and Massey, Introduction to Statistical Analysis, Edition 2, !! 1957, page 71. ! ORIGINAL VERSION--JUNE 1972. ! UPDATED --SEPTEMBER 1975. ! UPDATED --NOVEMBER 1975. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE MIDR(X,N,Iwrite,Xmidr) REAL(kind=wp),intent(in) :: X(:) INTEGER,intent(in) :: N INTEGER,intent(in) :: Iwrite REAL(kind=wp),intent(out) :: Xmidr REAL(kind=wp) :: hold , xmax , xmin INTEGER :: i ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( N<1 ) THEN WRITE (G_IO,99001) 99001 FORMAT (' ***** FATAL ERROR--the second input argument to MIDR(3f) is non-positive *****') WRITE (G_IO,99002) N 99002 FORMAT (' ','***** the value of the argument is ',I0,' *****') RETURN ELSE IF ( N==1 ) THEN WRITE (G_IO,99003) 99003 FORMAT (' ***** NON-FATAL DIAGNOSTIC--the second input argument to MIDR(3f) has the value 1 *****') Xmidr = X(1) ELSE hold = X(1) DO i = 2 , N IF ( X(i)/=hold ) GOTO 50 ENDDO WRITE (G_IO,99004) hold 99004 FORMAT (& & ' ***** NON-FATAL DIAGNOSTIC--the first input argument (A VECTOR) to MIDR(3f) has all elements = ',E15.8,' *****') Xmidr = X(1) ENDIF GOTO 100 !-----START POINT----------------------------------------------------- 50 continue xmin = X(1) xmax = X(1) DO i = 1 , N IF ( X(i)<xmin ) xmin = X(i) IF ( X(i)>xmax ) xmax = X(i) ENDDO Xmidr = (xmin+xmax)/2.0_wp ENDIF ! 100 continue IF ( Iwrite==0 ) RETURN WRITE (G_IO,99005) 99005 FORMAT (' ') WRITE (G_IO,99006) N , Xmidr 99006 FORMAT (' The sample MIDRANGE of the ',I0,' observations is ', E22.15) END SUBROUTINE MIDR !> !!##NAME !! min(3f) - [M_datapac:STATISTICS] compute the minimum of a data vector !! !!##SYNOPSIS !! !! SUBROUTINE MIN(X,N,Iwrite,Xmin) !! !! real(kind=wp),intent(in) :: X(:) !! integer,intent(in) :: N !! integer,intent(in) :: Iwrite !! real(kind=wp),intent(out) :: Xmin !! !!##DESCRIPTION !! MIN(3f) computes the sample minimum of the data in the input vector X. !! !!##INPUT ARGUMENTS !! !! X The vector of (unsorted or sorted) observations. !! !! N The integer number of observations in the vector X. !! !! IWRITE An integer flag code which (if set to 0) will suppress !! The printing of the sample minimum as it is computed; or (if set !! to some integer value not equal to 0; like, say, 1) will cause !! The printing of the sample minimum at the time it is computed. !! !!##OUTPUT ARGUMENTS !! !! XMIN The value of the computed sample minimum. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_min !! use M_datapac, only : min, label !! implicit none !! real :: xmin !! call label('min') !! call min([-100.0, 200.0, 0.0, 400.0, -200.0],5,1,xmin) !! write(*,*)xmin !! end program demo_min !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the Statistical !! Engineering Division, National Institute of Standards and Technology. !!##MAINTAINER !! John Urban, 2022.05.31 !!##LICENSE !! CC0-1.0 !!##REFERENCES !! * David, Order Statistics, 1970, page 7. ! ORIGINAL VERSION--JUNE 1972. ! UPDATED --SEPTEMBER 1975. ! UPDATED --NOVEMBER 1975. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 subroutine min(X,N,Iwrite,Xmin) real(kind=wp) :: hold , X(:) , Xmin integer :: i , Iwrite , N ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! if ( N<1 ) then write (g_io,99001) 99001 format (' ***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO MIN(3f) IS NON-POSITIVE *****') write (g_io,99002) N 99002 format (' ***** THE VALUE OF THE ARGUMENT IS ',I0,' *****') return else if ( N==1 ) then write (g_io,99003) 99003 format (' ***** NON-FATAL DIAGNOSTIC--THE SECOND INPUT ARGUMENT TO MIN(3f) HAS THE VALUE 1 *****') Xmin = X(1) else hold = X(1) do i = 2 , N if ( X(i) /= hold ) goto 50 enddo write (g_io,99004) hold 99004 format (' ***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT (A VECTOR) TO MIN(3f) HAS ALL ELEMENTS = ', & & g0, & & ' *****') Xmin = X(1) endif goto 100 ! !-----START POINT----------------------------------------------------- ! 50 continue Xmin = X(1) do i = 2 , N if ( X(i) < Xmin ) Xmin = X(i) enddo endif ! 100 continue if ( Iwrite==0 ) return write (G_IO,99005) 99005 format (' ') write (g_io,99006) N , Xmin 99006 format (' ','THE MINIMUM OF THE SET OF ',I0,' OBSERVATIONS IS ', g0) end subroutine min !> !!##NAME !! !! move(3f) - [M_datapac:VECTOR_OPERATION] move selected elements of !! one vector into another vector !! !!##SYNOPSIS !! !! !! SUBROUTINE MOVE(X,M,Ix1,Iy1,Y) !! !! REAL(kind=wp),intent(in) :: X(:) !! INTEGER,intent(in) :: M !! INTEGER,intent(in) :: Ix1 !! INTEGER,intent(in) :: Iy1 !! REAL(kind=wp),intent(out) :: Y(:) !! !!##DESCRIPTION !! !! MOVE(3f) moves (copies) M elements of the REAL vector !! X (starting with position Ix1) into the REAL vector Y !! (starting with position Iy1). !! !! This allows the data analyst to take any subvector in X and place it !! anywhere in the vector Y. !! !! !!##INPUT ARGUMENTS !! !! X The vector of observations, part (or all) of which is to be moved !! (copied) over into the vector Y. The input vector X remains !! unaltered. !! !! M The integer number of elements in the vector X to be moved. !! !! IX1 The integer value which defines the position in the vector X !! of the first element to be moved. !! !! IY1 The integer value which defines the position in the vector Y !! where the first element to be moved will be placed. !! !!##OUTPUT ARGUMENTS !! !! Y The vector into which the copied data values from the vector !! X will be sequentially placed, starting in position IY1 of Y. !! The m elements in positions !! !! IY1, IY1+1, ... , IY1+M-1 !! !! will be identical to the M elements !! in the X vector IN positions !! !! IX1, IX1+1, ... , IX1+M-1. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_move !! use M_datapac, only : move, label !! real,allocatable :: x(:), y(:) !! call label('move') !! x=[10.0,20.0,30.0,40.0,50.0,60.0,70.0,80.0,90.0,100.0,110.0,120.0] !! if(allocated(y))deallocate(y) !! allocate(y(size(x))) !! y=99.0 !! call MOVE(X,4,5,1,Y) !! write(*,*)int(y) !! end program demo_move !! !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 ! ORIGINAL VERSION--NOVEMBER 1972. ! UPDATED --NOVEMBER 1975. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE MOVE(X,M,Ix1,Iy1,Y) REAL(kind=wp),intent(in) :: X(:) INTEGER,intent(in) :: M INTEGER,intent(in) :: Ix1 INTEGER,intent(in) :: Iy1 REAL(kind=wp) :: Y(:) REAL(kind=wp) :: hold INTEGER :: i, iend, istart, j, k ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( M<1 ) THEN WRITE (G_IO,99001) 99001 FORMAT (' ***** FATAL ERROR--the second input argument to MOVE(3f) is non-positive *****') WRITE (G_IO,99006) M RETURN ELSEIF ( Ix1<1 ) THEN WRITE (G_IO,99002) 99002 FORMAT (' ***** FATAL ERROR--the third input argument to MOVE(3f) is non-positive *****') WRITE (G_IO,99006) Ix1 RETURN ELSEIF ( Iy1<1 ) THEN WRITE (G_IO,99003) 99003 FORMAT (' ***** FATAL ERROR--the fourth input argument to MOVE(3f) is non-positive *****') WRITE (G_IO,99006) Iy1 RETURN ELSE IF ( M==1 ) THEN WRITE (G_IO,99004) 99004 FORMAT (' ***** NON-FATAL DIAGNOSTIC--the second input argument to MOVE(3f) has the value 1 *****') ELSE hold = X(Ix1) istart = Ix1 + 1 iend = Ix1 + M - 1 DO i = istart , iend IF ( X(i)/=hold ) GOTO 50 ENDDO WRITE (G_IO,99005) hold 99005 FORMAT (& & ' ***** NON-FATAL DIAGNOSTIC--the first input argument (a vector) to MOVE(3f) has all elements =',E15.8,' *****') ENDIF ! !-----START POINT----------------------------------------------------- ! 50 DO i = 1 , M j = Ix1 - 1 + i k = Iy1 - 1 + i Y(k) = X(j) ENDDO ENDIF 99006 FORMAT (' ***** The value of the argument is ',I0,' *****') ! END SUBROUTINE MOVE !> !!##NAME !! nbcdf(3f) - [M_datapac:CUMULATIVE_DISTRIBUTION] compute the negative !! binomial cumulative distribution function !! !!##SYNOPSIS !! !! SUBROUTINE NBCDF(X,P,N,Cdf) !! !! REAL(kind=wp),intent(in) :: X !! REAL(kind=wp),intent(in) :: P !! INTEGER :: N !! REAL(kind=wp),intent(out) :: Cdf !! !!##DESCRIPTION !! !! NBCDF(3f) computes the cumulative distribution function value at the !! REAL value X for the negative binomial distribution with !! REAL 'Bernoulli probability' parameter = P, and integer !! 'number of successes in Bernoulli trials' parameter = N. !! !! The negative binomial distribution used herein has mean = N*(1-P)/P !! and standard deviation = sqrt(N*(1-P)/(P*P))). this distribution !! is defined for all non-negative integer X-- X = 0, 1, 2, ... . !! This distribution has the probability function !! !! f(X) = c(N+X-1,N) * P**N * (1-P)**X !! !! Where c(N+X-1,N) is the combinatorial function equaling the number !! of combinations of N+X-1 items taken N at a time. !! !! The negative binomial distribution is the distribution of the number !! of failures before obtaining N successes in an indefinite sequence of !! Bernoulli (0,1) trials where the probability of success in a precision !! trial = P. !! !!##NOTE !! !! Even though the input to this cumulative distribution function !! subroutine for this discrete distribution should (under normal !! circumstances) be a discrete integer value, the input variable X is !! REAL in mode. !! !! X has been specified as REAL so as to conform with the datapac !! convention that all input ****data**** (as opposed to sample !! size, for example) variables to all datapac subroutines are REAL. !! This convention is based on the belief that !! !! 1. A mixture of modes (floating point versus integer) is inconsistent !! and an unnecessary complication in a data analysis; and !! !! 2. Floating point machine arithmetic (as opposed to integer !! arithmetic) is the more natural mode for doing data analysis. !! !!##INPUT ARGUMENTS !! !! X The value at which the cumulative distribution function is to !! be evaluated. X should be non-negative and integral-valued. !! !! P The value of the 'Bernoulli probability' parameter for the !! negative binomial distribution. !! P should be between 0.0 (exclusively) and 1.0 (exclusively). !! !! N The integer value of the 'number of successes in Bernoulli !! trials' parameter. N should be a positive integer. !! !!##OUTPUT ARGUMENTS !! !! CDF The cumulative distribution function value for the negative !! binomial distribution !! !!##EXAMPLES !! !! Sample program: !! !! program demo_nbcdf !! !@(#) line plotter graph of cumulative distribution function !! use M_datapac, only : nbcdf, plott, label !! implicit none !! real,allocatable :: x(:), y(:) !! real :: p !! integer :: i !! integer :: n !! call label('nbcdf') !! x=[(real(i),i=0,100,1)] !! if(allocated(y))deallocate(y) !! allocate(y(size(x))) !! p=0.50 !! n=size(x) !! do i=1,size(x) !! call NBCDF(X(i),P,N,y(i)) !! enddo !! call plott(x,y,size(x)) !! end program demo_nbcdf !! !! Results: !! !! The following is a plot of Y(I) (vertically) versus X(I) (horizontally) !! I-----------I-----------I-----------I-----------I !! 0.1000000E+03 - X X X !! 0.9583334E+02 I X X X X !! 0.9166666E+02 I X X X X !! 0.8750000E+02 I XX X X !! 0.8333334E+02 I XXX X !! 0.7916667E+02 I XXXX !! 0.7500000E+02 - XXX !! 0.7083334E+02 I XX !! 0.6666667E+02 I XX !! 0.6250000E+02 I X !! 0.5833334E+02 I X !! 0.5416667E+02 I X !! 0.5000000E+02 - X !! 0.4583334E+02 I X !! 0.4166667E+02 I X !! 0.3750000E+02 I X !! 0.3333334E+02 I X !! 0.2916667E+02 I X !! 0.2500000E+02 - X !! 0.2083334E+02 I X !! 0.1666667E+02 I X !! 0.1250000E+02 I X !! 0.8333336E+01 I X !! 0.4166672E+01 I X !! 0.0000000E+00 - X !! I-----------I-----------I-----------I-----------I !! -0.1776E-14 0.1250E+00 0.2500E+00 0.3750E+00 0.5000E+00 !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !! !!##REFERENCES !! * National Bureau of Standards Applied Mathematics Series 55, 1964, !! page 945, Formulae 26.5.24 and 26.5.28, and page 929. !! * Johnson and Kotz, Discrete Distributions, 1969, pages 122-142, !! especially page 127. !! * Hastings and Peacock, Statistical Distributions--A Handbook for !! Students and Practitioners, 1975, pages 92-95. !! * Feller, an Introduction to Probability Theory and Its Applications, !! Volume 1, Edition 2, 1957, pages 155-157, 210. !! * Kendall and Stuart, the Advanced Theory of Statistics, Volume 1, !! Edition 2, 1963, pages 130-131. !! * Williamson and Bretherton, Tables of the Negative Binomial Probability !! Distribution, 1963. !! * Owen, Handbook of Statistical Tables, 1962, page 304. ! ORIGINAL VERSION--NOVEMBER 1975. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE NBCDF(X,P,N,Cdf) REAL(kind=wp),intent(in) :: X REAL(kind=wp),intent(in) :: P INTEGER :: N REAL(kind=wp),intent(out) :: Cdf REAL(kind=wp) :: ak, an, an2, del, fintx INTEGER :: i, ievodd, iflag1, iflag2, imax, imin, intx, k, n2, nu1, nu2 DOUBLE PRECISION :: dx2, pi, anu1, anu2, z, sum, term, ai, coef1, coef2, arg DOUBLE PRECISION :: coef DOUBLE PRECISION :: theta, sinth, costh, a, b DOUBLE PRECISION :: DSQRT, DATAN DATA pi/3.14159265358979D0/ ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! an = N IF ( P<=0.0_wp .OR. P>=1.0_wp ) THEN WRITE (G_IO,99001) 99001 FORMAT (' ***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO NBCDF(3f) IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL *****') WRITE (G_IO,99006) P Cdf = 0.0_wp RETURN ELSEIF ( N<1 ) THEN WRITE (G_IO,99002) 99002 FORMAT (' ***** FATAL ERROR--THE THIRD INPUT ARGUMENT TO THE NBCDF SUBROUTINE IS NON-POSITIVE *****') WRITE (G_IO,99003) N 99003 FORMAT (' ','***** THE VALUE OF THE ARGUMENT IS ',I0,' *****') Cdf = 0.0_wp RETURN ELSEIF ( X<0.0_wp ) THEN WRITE (G_IO,99004) 99004 FORMAT (' ***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT TO NBCDF(3f) IS NEGATIVE *****') WRITE (G_IO,99006) X IF ( X<0.0_wp ) Cdf = 0.0_wp RETURN ELSE intx = X + 0.0001_wp fintx = intx del = X - fintx IF ( del<0.0_wp ) del = -del IF ( del>0.001_wp ) THEN WRITE (G_IO,99005) 99005 FORMAT (' ***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT TO NBCDF(3f) IS NON-INTEGRAL *****') WRITE (G_IO,99006) X ENDIF ! !-----START POINT----------------------------------------------------- ! ! EXPRESS THE NEGATIVE BINOMIAL CUMULATIVE DISTRIBUTION ! FUNCTION IN TERMS OF THE EQUIVALENT BINOMIAL ! CUMULATIVE DISTRIBUTION FUNCTION, ! AND THEN OPERATE ON THE LATTER. ! intx = X + 0.0001_wp k = N - 1 n2 = N + intx ! ! EXPRESS THE BINOMIAL CUMULATIVE DISTRIBUTION ! FUNCTION IN TERMS OF THE EQUIVALENT F ! CUMULATIVE DISTRIBUTION FUNCTION, ! AND THEN EVALUATE THE LATTER. ! ak = k an2 = n2 dx2 = (P/(1.0_wp-P))*((an2-ak)/(ak+1.0_wp)) nu1 = 2*(k+1) nu2 = 2*(n2-k) anu1 = nu1 anu2 = nu2 z = anu2/(anu2+anu1*dx2) ! ! DETERMINE IF NU1 AND NU2 ARE EVEN OR ODD ! iflag1 = nu1 - 2*(nu1/2) iflag2 = nu2 - 2*(nu2/2) IF ( iflag1==0 ) THEN ! ! DO THE NU1 EVEN AND NU2 EVEN OR ODD CASE ! sum = 0.0D0 term = 1.0D0 imax = (nu1-2)/2 IF ( imax>0 ) THEN DO i = 1 , imax ai = i coef1 = 2.0D0*(ai-1.0D0) coef2 = 2.0D0*ai term = term*((anu2+coef1)/coef2)*(1.0D0-z) sum = sum + term ENDDO ENDIF ! sum = sum + 1.0D0 sum = (z**(anu2/2.0D0))*sum Cdf = 1.0D0 - sum RETURN ELSEIF ( iflag2==0 ) THEN ! ! DO THE NU1 ODD AND NU2 EVEN CASE ! sum = 0.0D0 term = 1.0D0 imax = (nu2-2)/2 IF ( imax>0 ) THEN DO i = 1 , imax ai = i coef1 = 2.0D0*(ai-1.0D0) coef2 = 2.0D0*ai term = term*((anu1+coef1)/coef2)*z sum = sum + term ENDDO ENDIF ! sum = sum + 1.0D0 Cdf = ((1.0D0-z)**(anu1/2.0D0))*sum RETURN ELSE ! ! DO THE NU1 ODD AND NU2 ODD CASE ! sum = 0.0D0 term = 1.0D0 arg = DSQRT((anu1/anu2)*dx2) theta = DATAN(arg) sinth = arg/DSQRT(1.0D0+arg*arg) costh = 1.0D0/DSQRT(1.0D0+arg*arg) IF ( nu2/=1 ) THEN IF ( nu2/=3 ) THEN imax = nu2 - 2 DO i = 3 , imax , 2 ai = i coef1 = ai - 1.0D0 coef2 = ai term = term*(coef1/coef2)*(costh*costh) sum = sum + term ENDDO ENDIF ! sum = sum + 1.0D0 sum = sum*sinth*costh ENDIF ! a = (2.0D0/pi)*(theta+sum) sum = 0.0D0 term = 1.0D0 IF ( nu1==1 ) b = 0.0D0 IF ( nu1/=1 ) THEN IF ( nu1/=3 ) THEN imax = nu1 - 3 DO i = 1 , imax , 2 ai = i coef1 = ai coef2 = ai + 2.0D0 term = term*((anu2+coef1)/coef2)*(sinth*sinth) sum = sum + term ENDDO ENDIF ! sum = sum + 1.0D0 sum = sum*sinth*(costh**N) coef = 1.0D0 ievodd = nu2 - 2*(nu2/2) imin = 3 IF ( ievodd==0 ) imin = 2 IF ( imin<=nu2 ) THEN DO i = imin , nu2 , 2 ai = i coef = ((ai-1.0D0)/ai)*coef ENDDO ENDIF ! coef = coef*anu2 IF ( ievodd/=0 ) coef = coef*(2.0D0/pi) ! b = coef*sum ENDIF ! Cdf = a - b ENDIF ENDIF 99006 FORMAT (' ','***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') ! END SUBROUTINE NBCDF !> !!##NAME !! nbppf(3f) - [M_datapac:PERCENT_POINT] compute the negative binomial !! percent point function !! !!##SYNOPSIS !! !! SUBROUTINE NBPPF(P,Ppar,N,Ppf) !! !!##DESCRIPTION !! nbppf(3f) computes the percent point function value at the precision !! precision value p for the negative binomial distribution with precision !! precision 'bernoulli probability' parameter = ppar, and integer !! 'number of successes in bernoulli trials' parameter = n. !! !! the negative binomial distribution used herein has mean = !! n*(1-ppar)/ppar and standard deviation = sqrt(n*(1-ppar)/(ppar*ppar))). !! this distribution is defined for all non-negative integer x--x = 0, !! 1, 2, ... . !! !! this distribution has the probability function !! !! f(x) = c(n+x-1,n) * ppar**n * (1-ppar)**x. !! !! where c(n+x-1,n) is the combinatorial function !! equaling the number of combinations of n+x-1 items !! taken n at a time. !! !! the negative binomial distribution is the distribution of the number !! of failures before obtaining n successes in an indefinite sequence of !! bernoulli (0,1) trials where the probability of success in a precision !! trial = ppar. !! !! note that the percent point function of a distribution is identically !! the same as the inverse cumulative distribution function of the !! distribution. !! !!##OPTIONS !! X description of parameter !! Y description of parameter !! !!##EXAMPLES !! !! Sample program: !! !! program demo_nbppf !! use M_datapac, only : nbppf !! implicit none !! ! call nbppf(x,y) !! end program demo_nbppf !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the Statistical !! Engineering Division, National Institute of Standards and Technology. !!##MAINTAINER !! John Urban, 2022.05.31 !!##LICENSE !! CC0-1.0 !!##REFERENCES !! * JOHNSON AND KOTZ, DISCRETE DISTRIBUTIONS, 1969, pages 122-142, !! ESPECIALLY page 127, FORMULA 22. !! * HASTINGS AND PEACOCK, STATISTICAL DISTRIBUTIONS--A HANDBOOK FOR !! STUDENTS AND PRACTITIONERS, 1975, pages 92-95. !! * NATIONAL BUREAU OF STANDARDS APPLIED MATHEMATICS SERIES 55, 1964, !! page 929. !! * FELLER, AN INTRODUCTION TO PROBABILITY THEORY AND ITS APPLICATIONS, !! VOLUME 1, EDITION 2, 1957, pages 155-157, 210. !! * KENDALL AND STUART, THE ADVANCED THEORY OF STATISTICS, VOLUME 1, !! EDITION 2, 1963, pages 130-131. !! * WILLIAMSON AND BRETHERTON, TABLES OF THE NEGATIVE BINOMIAL PROBABILITY !! DISTRIBUTION, 1963. !! * OWEN, HANDBOOK OF STATISTICAL TABLES, 1962, page 304. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE NBPPF(P,Ppar,N,Ppf) REAL(kind=wp) :: amean , an , arcsh , arg , e , P , p0 , p1 , p2 , pf0 , & & Ppar , Ppf , sd , sinh , x0 , x1 , x2 , ymean , yppf , ysd REAL(kind=wp) :: zppf INTEGER :: i , isd , ix0 , ix0p1 , ix1 , ix2 , N ! ! INPUT ARGUMENTS--P = THE VALUE ! (BETWEEN 0.0 (INCLUSIVELY) ! AND 1.0 (EXCLUSIVELY)) ! AT WHICH THE PERCENT POINT ! FUNCTION IS TO BE EVALUATED. ! --PPAR = THE VALUE ! OF THE 'BERNOULLI PROBABILITY' ! PARAMETER FOR THE NEGATIVE BINOMIAL ! DISTRIBUTION. ! PPAR SHOULD BE BETWEEN ! 0.0 (EXCLUSIVELY) AND ! 1.0 (EXCLUSIVELY). ! --N = THE INTEGER VALUE ! OF THE 'NUMBER OF SUCCESSES ! IN BERNOULLI TRIALS' PARAMETER. ! N SHOULD BE A POSITIVE INTEGER. ! OUTPUT ARGUMENTS--PPF = THE PERCENT ! POINT FUNCTION VALUE. ! OUTPUT--THE PERCENT POINT . ! FUNCTION VALUE PPF ! FOR THE NEGATIVE BINOMIAL DISTRIBUTION ! WITH 'BERNOULLI PROBABILITY' PARAMETER = PPAR ! AND 'NUMBER OF SUCCESSES IN BERNOULLI TRIALS' ! PARAMETER = N. ! PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. ! RESTRICTIONS--PPAR SHOULD BE BETWEEN 0.0 (EXCLUSIVELY) ! AND 1.0 (EXCLUSIVELY). ! --N SHOULD BE A POSITIVE INTEGER. ! --P SHOULD BE BETWEEN 0.0 (INCLUSIVELY) ! AND 1.0 (EXCLUSIVELY). ! OTHER DATAPAC SUBROUTINES NEEDED--NORPPF, NBCDF. ! FORTRAN LIBRARY SUBROUTINES NEEDED--SQRT, EXP, LOG. ! MODE OF INTERNAL OPERATIONS-- AND DOUBLE PRECISION. ! COMMENT--NOTE THAT EVEN THOUGH THE OUTPUT ! FROM THIS DISCRETE DISTRIBUTION ! PERCENT POINT FUNCTION ! SUBROUTINE MUST NECESSARILY BE A ! DISCRETE INTEGER VALUE, ! THE OUTPUT VARIABLE PPF IS SINGLE ! PRECISION IN MODE. ! PPF HAS BEEN SPECIFIED AS SINGLE ! PRECISION SO AS TO CONFORM WITH THE DATAPAC ! CONVENTION THAT ALL OUTPUT VARIABLES FROM ALL ! DATAPAC SUBROUTINES ARE . ! THIS CONVENTION IS BASED ON THE BELIEF THAT ! 1) A MIXTURE OF MODES (FLOATING POINT ! VERSUS INTEGER) IS INCONSISTENT AND ! AN UNNECESSARY COMPLICATION ! IN A DATA ANALYSIS; AND ! 2) FLOATING POINT MACHINE ARITHMETIC ! (AS OPPOSED TO INTEGER ARITHMETIC) ! IS THE MORE NATURAL MODE FOR DOING ! DATA ANALYSIS. ! ORIGINAL VERSION--NOVEMBER 1975. ! !--------------------------------------------------------------------- ! DOUBLE PRECISION dppar ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( P<0.0_wp .OR. P>=1.0_wp ) THEN WRITE (G_IO,99001) 99001 FORMAT (' ', & &'***** FATAL ERROR--THE FIRST INPUT ARGUMENT TO THE NBPPF SUBROU& &TINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL *****') WRITE (G_IO,99019) P Ppf = 0.0_wp RETURN ELSE IF ( Ppar<=0.0_wp .OR. Ppar>=1.0_wp ) THEN WRITE (G_IO,99002) 99002 FORMAT (' ', & &'***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE NBPPF SUBROU& &TINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL *****') WRITE (G_IO,99019) Ppar Ppf = 0.0_wp RETURN ELSE IF ( N<1 ) THEN WRITE (G_IO,99003) 99003 FORMAT (' ', & &'***** FATAL ERROR--THE THIRD INPUT ARGUMENT TO THE NBPPF SUBROU& &TINE IS NON-POSITIVE *****') WRITE (G_IO,99004) N 99004 FORMAT (' ','***** THE VALUE OF THE ARGUMENT IS ',I0, & & ' *****') Ppf = 0.0_wp RETURN ELSE ! !-----START POINT----------------------------------------------------- ! an = N dppar = Ppar Ppf = 0.0_wp ix0 = 0 ix1 = 0 ix2 = 0 p0 = 0.0_wp p1 = 0.0_wp p2 = 0.0_wp ! ! TREAT CERTAIN SPECIAL CASES IMMEDIATELY-- ! 1) P = 0.0 ! 2) P = 0.5 AND PPAR = 0.5 ! 3) PPF = 0 ! IF ( P/=0.0_wp ) THEN IF ( P==0.5_wp .AND. Ppar==0.5_wp ) THEN Ppf = N - 1 RETURN ELSE pf0 = dppar**N IF ( P>pf0 ) THEN ! ! DETERMINE AN INITIAL APPROXIMATION TO THE NEGATIVE BINOMIAL ! PERCENT POINT BY USE OF THE HYPERBOLIC ARCSIN ! TRANSFORMATION OF THE NEGATIVE BINOMIAL ! TO APPROXIMATE NORMALITY. ! (SEE JOHNSON AND KOTZ, DISCRETE DISTRIBUTIONS, ! page 127, FORMULA 22). ! amean = an*(1.0_wp-Ppar)/Ppar sd = SQRT(an*(1.0_wp-Ppar)/(Ppar*Ppar)) arg = SQRT((amean+0.375_wp)/(an-0.75_wp)) arcsh = LOG(arg+SQRT(arg*arg+1.0_wp)) ymean = (SQRT(an-0.5_wp))*arcsh ysd = 0.5_wp CALL NORPPF(P,zppf) yppf = ymean + zppf*ysd arg = yppf/SQRT(an-0.5_wp) e = EXP(arg) sinh = (e-1.0_wp/e)/2.0_wp x2 = -0.375_wp + (an-0.75_wp)*sinh*sinh x2 = x2 + 0.5_wp ix2 = x2 ! ! CHECK AND MODIFY (IF NECESSARY) THIS INITIAL ! ESTIMATE OF THE PERCENT POINT ! TO ASSURE THAT IT BE NON-NEGATIVE. ! IF ( ix2<0 ) ix2 = 0 ! ! DETERMINE UPPER AND LOWER BOUNDS ON THE DESIRED ! PERCENT POINT BY ITERATING OUT (BOTH BELOW AND ABOVE) ! FROM THE ORIGINAL APPROXIMATION AT STEPS ! OF 1 STANDARD DEVIATION. ! THE RESULTING BOUNDS WILL BE AT MOST ! 1 STANDARD DEVIATION APART. ! ix0 = 0 ix1 = huge(0) ! = 10**10 isd = sd + 1.0_wp x2 = ix2 CALL NBCDF(x2,Ppar,N,p2) ! IF ( p2<P ) THEN ! ix0 = ix2 DO i = 1 , 100000 ix2 = ix0 + isd IF ( ix2>=ix1 ) GOTO 100 x2 = ix2 CALL NBCDF(x2,Ppar,N,p2) IF ( p2>=P ) GOTO 20 ix0 = ix2 ENDDO WRITE (G_IO,99020) WRITE (G_IO,99005) ! 99005 FORMAT (' ', & & 'NO UPPER BOUND FOUND AFTER 10**7 ITERATIONS'& & ) ELSE ! ix1 = ix2 DO i = 1 , 100000 ix2 = ix1 - isd IF ( ix2<=ix0 ) GOTO 100 x2 = ix2 CALL NBCDF(x2,Ppar,N,p2) IF ( p2<P ) GOTO 50 ix1 = ix2 ENDDO WRITE (G_IO,99020) WRITE (G_IO,99006) 99006 FORMAT (' ', & & 'NO LOWER BOUND FOUND AFTER 10**7 ITERATIONS'& & ) ENDIF GOTO 200 ENDIF ENDIF ENDIF Ppf = 0.0_wp RETURN ENDIF 20 ix1 = ix2 GOTO 100 ENDIF 50 ix0 = ix2 ENDIF ! 100 IF ( ix0==ix1 ) THEN IF ( ix0==0 ) THEN ix1 = ix1 + 1 ELSEIF ( ix0==N ) THEN ix0 = ix0 - 1 ELSE WRITE (G_IO,99020) WRITE (G_IO,99007) 99007 FORMAT (' ','LOWER AND UPPER BOUND IDENTICAL') GOTO 200 ENDIF ENDIF ! ! COMPUTE NEGATIVE BINOMIAL PROBABILITIES FOR THE ! DERIVED LOWER AND UPPER BOUNDS. ! x0 = ix0 x1 = ix1 CALL NBCDF(x0,Ppar,N,p0) CALL NBCDF(x1,Ppar,N,p1) ! ! CHECK THE PROBABILITIES FOR PROPER ORDERING ! IF ( p0<P .AND. P<=p1 ) THEN DO ! ! THE STOPPING CRITERION IS THAT THE LOWER BOUND ! AND UPPER BOUND ARE EXACTLY 1 UNIT APART. ! CHECK TO SEE IF IX1 = IX0 + 1; ! IF SO, THE ITERATIONS ARE COMPLETE; ! IF NOT, THEN BISECT, COMPUTE PROBABILIIES, ! CHECK PROBABILITIES, AND CONTINUE ITERATING ! UNTIL IX1 = IX0 + 1. ! ix0p1 = ix0 + 1 IF ( ix1==ix0p1 ) THEN Ppf = ix1 IF ( p0==P ) Ppf = ix0 RETURN ELSE ix2 = (ix0+ix1)/2 IF ( ix2/=ix0 ) THEN IF ( ix2==ix1 ) THEN WRITE (G_IO,99020) WRITE (G_IO,99021) EXIT ELSE x2 = ix2 CALL NBCDF(x2,Ppar,N,p2) IF ( p0<p2 .AND. p2<p1 ) THEN IF ( p2<=P ) THEN ix0 = ix2 p0 = p2 ELSE ix1 = ix2 p1 = p2 ENDIF CYCLE ELSEIF ( p2<=p0 ) THEN WRITE (G_IO,99020) WRITE (G_IO,99008) 99008 FORMAT (' ','BISECTION VALUE PROBABILITY (P2) ',& & 'LESS THAN LOWER BOUND PROBABILITY (P0)'& & ) EXIT ELSEIF ( p2>=p1 ) THEN WRITE (G_IO,99020) WRITE (G_IO,99009) 99009 FORMAT (' ','BISECTION VALUE PROBABILITY (P2) ',& & 'GREATER THAN UPPER BOUND PROBABILITY (P1)'& & ) EXIT ENDIF ENDIF ENDIF WRITE (G_IO,99020) WRITE (G_IO,99021) EXIT ENDIF ENDDO ELSEIF ( p0==P ) THEN Ppf = ix0 RETURN ELSEIF ( p1==P ) THEN Ppf = ix1 RETURN ELSEIF ( p0>p1 ) THEN WRITE (G_IO,99020) WRITE (G_IO,99010) 99010 FORMAT (' ','LOWER BOUND PROBABILITY (P0) GREATER THAN ', & & 'UPPER BOUND PROBABILITY (P1)') ELSEIF ( p0>P ) THEN WRITE (G_IO,99020) WRITE (G_IO,99011) 99011 FORMAT (' ','LOWER BOUND PROBABILITY (P0) GREATER THAN ', & & 'INPUT PROBABILITY (P)') ELSEIF ( p1<P ) THEN WRITE (G_IO,99020) WRITE (G_IO,99012) 99012 FORMAT (' ','UPPER BOUND PROBABILITY (P1) LESS THAN ', & & 'INPUT PROBABILITY (P)') ELSE WRITE (G_IO,99020) WRITE (G_IO,99013) 99013 FORMAT (' ','IMPOSSIBLE BRANCH CONDITION ENCOUNTERED') ENDIF ! 200 WRITE (G_IO,99014) ix0 , p0 99014 FORMAT (' ','IX0 = ',I8,10X,'P0 = ',F14.7) WRITE (G_IO,99015) ix1 , p1 99015 FORMAT (' ','IX1 = ',I8,10X,'P1 = ',F14.7) WRITE (G_IO,99016) ix2 , p2 99016 FORMAT (' ','IX2 = ',I8,10X,'P2 = ',F14.7) WRITE (G_IO,99017) P 99017 FORMAT (' ','P = ',F14.7) WRITE (G_IO,99018) Ppar , N 99018 FORMAT (' ','PPAR = ',F14.7,10X,'N = ',I0) RETURN 99019 FORMAT (' ','***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') 99020 FORMAT (' ','***** INTERNAL ERROR IN NBPPF SUBROUTINE *****') 99021 FORMAT (' ','BISECTION VALUE (X2) = LOWER BOUND (X0)') 99022 FORMAT (' ','BISECTION VALUE (X2) = UPPER BOUND (X1)') ! END SUBROUTINE NBPPF !> !!##NAME !! nbran(3f) - [M_datapac:RANDOM] generate negative binomial random numbers !! !!##SYNOPSIS !! !! SUBROUTINE NBRAN(N,P,Npar,Istart,X) !! !! INTEGER,intent(in) :: N !! REAL(kind=wp),intent(in) :: P !! INTEGER,intent(in) :: Npar !! INTEGER,intent(inout) :: Istart !! REAL(kind=wp),intent(out) :: X(:) !! !!##DESCRIPTION !! NBRAN(3f) generates a random sample of size N from the negative !! binomial distribution with precision 'Bernoulli probability' !! parameter = P, and integer 'number of successes in Bernoulli trials' !! parameter = NPAR. The negative binomial distribution used herein has !! mean = NPAR*(1-P)/P and standard deviation = sqrt(NPAR*(1-P)/(P*P))). !! !! This distribution is defined for all non-negative integer X-- X = 0, !! 1, 2, ... . !! !! This distribution has the probability function !! !! f(X) = c(NPAR+X-1,NPAR) * P**NPAR * (1-P)**X !! !! Where c(NPAR+X-1,NPAR) is the combinatorial function equaling the !! number of combinations of NPAR+X-1 items taken NPAR at a time. !! !! The negative binomial distribution is the distribution of the number !! of failures before obtaining NPAR successes in an indefinite sequence !! of Bernoulli (0,1) trials where the probability of success in a precision !! trial = P. !! !!##INPUT ARGUMENTS !! !! N The desired integer number of random numbers to be generated. !! !! P The value of the 'Bernoulli probability' parameter for the !! negative binomial distribution. P Should be between !! 0.0 (exclusively) and 1.0 (exclusively). !! !! NPAR The integer value of the 'number of successes in Bernoulli !! trials' parameter. NPAR should be a positive integer. !! !! ISTART An integer flag code which (if set to 0) will start the !! generator over and hence produce the same random sample !! over and over again upon successive calls to this subroutine !! within a run; or (if set to some integer value not equal to 0, !! like, say, 1) will allow the generator to continue from where !! it stopped and hence produce different random samples upon !! successive calls to this subroutine within a run. !! !!##OUTPUT ARGUMENTS !! !! X A vector (of dimension at least N) into which the generated !! random sample of size N from the negative binomial distribution !! will be placed. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_nbran !! use m_datapac, only : nbran, plott, label, plotxt, sort !! implicit none !! integer,parameter :: n=400 !! real :: p !! integer :: Npar !! integer :: Istart !! real :: x(n) !! call label('nbran') !! p=0.4 !! Npar=3 !! istart=12345 !! call nbran(N,P,Npar,Istart,X) !! call plotxt(x,n) !! call sort(x,n,x) ! sort to show distribution !! call plotxt(x,n) !! end program demo_nbran !! !! Results: !! !! The following is a plot of X(I) (vertically) versus I (horizontally) !! I-----------I-----------I-----------I-----------I !! 0.2700000E+02 - X !! 0.2600000E+02 I !! 0.2500000E+02 I !! 0.2400000E+02 I X !! 0.2300000E+02 I !! 0.2200000E+02 I !! 0.2100000E+02 - !! 0.2000000E+02 I X !! 0.1900000E+02 I !! 0.1800000E+02 I X X X X !! 0.1700000E+02 I X !! 0.1600000E+02 I X X !! 0.1500000E+02 - X X X X X !! 0.1400000E+02 I X X X X X X !! 0.1300000E+02 I X X X X X XX X X XXXX !! 0.1200000E+02 I X X X X X X !! 0.1100000E+02 I XX X X X XX X XXX XXXXX XX XX !! 0.1000000E+02 I X XX XXXX X XXX X XX X X X !! 0.9000000E+01 - XX XXXX XX X XX XX X X X X X XX X !! 0.8000000E+01 I XXXX XX XXX XX XXXXXXX X XX X XXX XXXX X X !! 0.7000000E+01 I XX XXXXXX XXXXX X XXXX X XXX X XXX XXXXX !! 0.6000000E+01 I X XXX X X XXXXXX X X XXX X XXXX X XXXXX XXXX X !! 0.5000000E+01 I XXXXXXXXXX XXXXXX XX XX XXX XXXX X XXXXXXXXXXX X !! 0.4000000E+01 I XX X X XXXX XXXX XXXX XX X XXXX XX XX XX X !! 0.3000000E+01 - X XXX XX X XXX XX XXX X XX XX XX X !! I-----------I-----------I-----------I-----------I !! 0.1000E+01 0.1008E+03 0.2005E+03 0.3002E+03 0.4000E+03 !! !! The following is a plot of X(I) (vertically) versus I (horizontally) !! I-----------I-----------I-----------I-----------I !! 0.2700000E+02 - X !! 0.2600000E+02 I !! 0.2500000E+02 I !! 0.2400000E+02 I X !! 0.2300000E+02 I !! 0.2200000E+02 I !! 0.2100000E+02 - !! 0.2000000E+02 I X !! 0.1900000E+02 I !! 0.1800000E+02 I XX !! 0.1700000E+02 I X !! 0.1600000E+02 I X !! 0.1500000E+02 - XX !! 0.1400000E+02 I XX !! 0.1300000E+02 I XX !! 0.1200000E+02 I XX !! 0.1100000E+02 I XXXX !! 0.1000000E+02 I XXXX !! 0.9000000E+01 - XXXX !! 0.8000000E+01 I XXXXXXX !! 0.7000000E+01 I XXXXXXX !! 0.6000000E+01 I XXXXXXX !! 0.5000000E+01 I XXXXXXXX !! 0.4000000E+01 I XXXXXX !! 0.3000000E+01 - XXXX !! I-----------I-----------I-----------I-----------I !! 0.1000E+01 0.1008E+03 0.2005E+03 0.3002E+03 0.4000E+03 !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !! !!##REFERENCES !! * Hastings and Peacock, Statistical Distributions--A Handbook for !! Students and Practitioners, 1975, page 95. !! * Johnson and Kotz, Discrete Distributions, 1969, pages 122-142. !! * Feller, an Introduction to Probability Theory and its Applications, !! Volume 1, Edition 2, 1957, pages 155-157, 210. !! * National Bureau of Standards Applied Mathematics Series 55, 1964, !! page 929. !! * Kendall and Stuart, the Advanced Theory of Statistics, Volume 1, !! Edition 2, 1963, pages 130-131. ! ORIGINAL VERSION--NOVEMBER 1975. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE NBRAN(N,P,Npar,Istart,X) INTEGER,intent(in) :: N REAL(kind=wp),intent(in) :: P INTEGER,intent(in) :: Npar INTEGER,intent(inout) :: Istart REAL(kind=wp),intent(out) :: X(:) REAL(kind=wp) :: b(1), g(1) INTEGER :: i, ib, ig, isum, j INTEGER,save :: iseed=1 ! NOTE THAT EVEN THOUGH THE OUTPUT FROM THIS DISCRETE RANDOM NUMBER GENERATOR MUST NECESSARILY BE A ! SEQUENCE OF ***INTEGER*** VALUES, THE OUTPUT VECTOR X IS SINGLE PRECISION IN MODE. ! X HAS BEEN SPECIFIED AS SINGLE PRECISION SO AS TO CONFORM WITH THE DATAPAC ! CONVENTION THAT ALL OUTPUT VECTORS FROM ALL DATAPAC SUBROUTINES ARE . THIS CONVENTION IS BASED ON THE BELIEF THAT ! ! 1. A MIXTURE OF MODES (FLOATING POINT VERSUS INTEGER) IS INCONSISTENT AND ! AN UNNECESSARY COMPLICATION IN A DATA ANALYSIS; AND ! ! 2. FLOATING POINT MACHINE ARITHMETIC (AS OPPOSED TO INTEGER ARITHMETIC) ! IS THE MORE NATURAL MODE FOR DOING DATA ANALYSIS. ! !--------------------------------------------------------------------- ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( N<1 ) THEN WRITE (G_IO,99001) 99001 FORMAT (' ***** FATAL ERROR--The first input argument to BINRAN(3f) is non-positive *****') WRITE (G_IO,99005) N RETURN ELSEIF ( P<=0.0_wp .OR. P>=1.0_wp ) THEN WRITE (G_IO,99002) 99002 FORMAT (' ***** FATAL ERROR--The second input argument to BINRAN(3f) is outside the allowable (0,1) interval *****') WRITE (G_IO,99003) P 99003 FORMAT (' ','***** The value of the argument is ',E15.8,' *****') RETURN ELSEIF ( Npar<1 ) THEN WRITE (G_IO,99004) 99004 FORMAT (' ***** FATAL ERROR--The third input argument to BINRAN(3f) is non-positive *****') WRITE (G_IO,99005) Npar RETURN ELSE CALL UNIRAN(1,Istart,g(1:1)) ! ! CHECK ON THE MAGNITUDE OF P, ! AND BRANCH TO THE FASTER ! GENERATION METHOD ACCORDINGLY. ! IF ( P<0.1_wp ) THEN ! ! IF P IS SMALL, ! GENERATE N NEGATIVE BINOMIAL NUMBERS ! BY USING THE FACT THAT THE SUM ! OF GEOMETRIC VARIATES IS A ! NEGATIVE BINOMIAL VARIATE. ! DO i = 1 , N isum = 0 DO j = 1 , Npar CALL GEORAN(1,P,iseed,g) ig = g(1) + 0.5_wp isum = isum + ig ENDDO X(i) = isum ENDDO GOTO 99999 ENDIF ENDIF ! ! IF P IS MODERATE OR LARGE, ! GENERATE N NEGATIVE BINOMIAL NUMBERS ! USING THE FACT THAT THE ! WAITING TIME FOR NPAR SUCCESSES IN ! BERNOULLI TRIALS HAS A ! NEGATIVE BINOMIAL DISTRIBUTION. ! DO i = 1 , N isum = 0 j = 1 DO CALL BINRAN(1,P,1,iseed,b) ib = b(1) + 0.5_wp isum = isum + ib IF ( isum==Npar ) THEN X(i) = j EXIT ELSE j = j + 1 ENDIF ENDDO ENDDO RETURN 99005 FORMAT (' ','***** The value of the argument is ',I0,' *****') ! 99999 END SUBROUTINE NBRAN !> !!##NAME !! norcdf(3f) - [M_datapac:CUMULATIVE_DISTRIBUTION] compute the normal cumulative !! distribution function !! !!##SYNOPSIS !! !! SUBROUTINE NORCDF(X,Cdf) !! !! REAL(kind=wp),intent(out) :: Cdf !! REAL(kind=wp),intent(in) :: X !! !!##DESCRIPTION !! NORCDF(3f) computes the cumulative distribution function value for the !! normal (Gaussian) distribution with mean = 0 and standard deviation !! = 1. !! !! This distribution is defined for all X and has the probability !! density function !! !! f(X) = (1/sqrt(2*pi))*exp(-X*X/2) !! !!##INPUT ARGUMENTS !! X The value at which the cumulative distribution function is to !! be evaluated. !!##OUTPUT ARGUMENTS !! CDF The cumulative distribution function value. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_norcdf !! !@(#) line plotter graph of cumulative distribution function !! use M_datapac, only : norcdf, plott, label !! implicit none !! real,allocatable :: x(:), y(:) !! integer :: i !! call label('norcdf') !! x=[(real(i),i=-100,100,1)] !! if(allocated(y))deallocate(y) !! allocate(y(size(x))) !! do i=1,size(x) !! call norcdf(x(i)/10.0,y(i)) !! enddo !! call plott(x,y,size(x)) !! end program demo_norcdf !! !! Results: !! !! The following is a plot of Y(I) (vertically) versus X(I) (horizontally) !! I-----------I-----------I-----------I-----------I !! 0.1000000E+03 - X !! 0.9166666E+02 I X !! 0.8333334E+02 I X !! 0.7500000E+02 I X !! 0.6666667E+02 I X !! 0.5833334E+02 I X !! 0.5000000E+02 - X !! 0.4166667E+02 I X !! 0.3333334E+02 I X !! 0.2500000E+02 I XX !! 0.1666667E+02 I XXXXX !! 0.8333336E+01 I X XX XXXXX !! 0.0000000E+00 - XX X X X X X XX !! -0.8333328E+01 I XXXXX XX X !! -0.1666666E+02 I XXXXX !! -0.2499999E+02 I XX !! -0.3333333E+02 I X !! -0.4166666E+02 I X !! -0.5000000E+02 - X !! -0.5833333E+02 I X !! -0.6666666E+02 I X !! -0.7500000E+02 I X !! -0.8333333E+02 I X !! -0.9166666E+02 I X !! -0.1000000E+03 - X !! I-----------I-----------I-----------I-----------I !! 0.0000E+00 0.2500E+00 0.5000E+00 0.7500E+00 0.1000E+01 !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !! !!##REFERENCES !! * National Bureau of Standards Applied Mathematics Series 55, 1964, !! page 932, Formula 26.2.17. !! * Johnson and Kotz, Continuous Univariate Distributions--1, 1970, !! pages 40-111. ! ORIGINAL VERSION--JUNE 1972. ! UPDATED --SEPTEMBER 1975. ! UPDATED --NOVEMBER 1975. ! ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE NORCDF(X,Cdf) REAL(kind=wp),intent(in) :: X REAL(kind=wp),intent(out) :: Cdf REAL(kind=wp) :: b1, b2, b3, b4, b5, p, t, z !--------------------------------------------------------------------- ! DATA b1, b2, b3, b4, b5, p/.319381530_wp, -0.356563782_wp, 1.781477937_wp, -1.821255978_wp, 1.330274429_wp, .2316419_wp/ ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS. -- NO INPUT ARGUMENT ERRORS POSSIBLE FOR THIS DISTRIBUTION. ! !-----START POINT----------------------------------------------------- z = X IF ( X<0.0_wp ) z = -z t = 1.0_wp/(1.0_wp+p*z) Cdf = 1.0_wp - ((0.39894228040143_wp)*EXP(-0.5_wp*z*z)) *(b1*t+b2*t**2+b3*t**3+b4*t**4+b5*t**5) IF ( X<0.0_wp ) Cdf = 1.0_wp - Cdf END SUBROUTINE NORCDF !> !!##NAME !! norout(3f) - [M_datapac:ANALYSIS] Performs a normal outlier analysis !! on the data in the input vector X. !! !!##SYNOPSIS !! !! SUBROUTINE NOROUT(X,N) !! !! real(kind=wp),intent(in) :: X(:) !! integer,intent(in) :: N !! !!##DESCRIPTION !! !! NOROUT(3f) performs a normal outlier analysis on the data in the !! input vector X. !! !! This analysis consists of-- !! !! 1. various normal outlier statistics; !! 2. various partial sample means !! 3. various partial sample standard deviations; !! 4. the first 40 and last 40 ordered observations; !! 5. a line plot; and !! 6. a normal probability plot. !! !! When the first 40 and last 40 ordered observations are printed out, !! also included for each of the 40+40 = 80 listed data values is the !! corresponding residual about the (full) sample mean, the standardized !! residual, the normal n(0,1) value for the standardized residual, !! and the position number in the original data vector X. !! !! This last piece of information allows the data analyst to easily !! locate back in the original data vector. A suspected outlier or !! otherwise interesting observation. !! !!##INPUT ARGUMENTS !! !! X The vector of (unsorted or sorted) observations. !! !! N The integer number of observations in the vector X. !! The maximum allowable value of N for this subroutine is 7500. !!##OUTPUT !! !! 4 pages of automatic printout as described in the description above. !! !! !!##EXAMPLES !! !! Sample program: !! !! program demo_norout !! use M_datapac, only : norout !! implicit none !! ! call norout(x,y) !! end program demo_norout !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !! !!##REFERENCES !! * Grubbs, Technometrics, 1969, pages 1-21 ! ORIGINAL VERSION--JUNE 1972. ! UPDATED --NOVEMBER 1975. ! UPDATED --FEBRUARY 1976. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 subroutine norout(X,N) real(kind=wp),intent(in) :: X(:) integer,intent(in) :: N real(kind=wp) :: ai, an, anm1, anm2, anm3, anm4, anm5, cdf, hold, res, s, s1, s13, s14, s2, s23, s24, s3, s4, ssq real(kind=wp) :: ssq1, ssq13, ssq14, ssq2, ssq23, ssq24, ssq3, ssq4, st1, st2, st3, st4, st5, st6, st7, st8, st9, stres, sum, sum4 real(kind=wp) :: WS, xb, xb1, xb13, xb14, xb2, xb23, xb24, xb3, xb4, xline, XPOs, Y integer :: i, icount, iflag, irev, iupper, j, mx, nm1, nm2, nm3, nm4, nm5 !--------------------------------------------------------------------- character(len=4) :: blank , hyphen , alphai , alphax character(len=4) :: iline1 character(len=4) :: iline2 ! DIMENSION Y(7500) , XPOs(7500) DIMENSION iline1(130) , iline2(130) DIMENSION xline(13) COMMON /BLOCK2_real32/ WS(15000) EQUIVALENCE (Y(1),WS(1)) EQUIVALENCE (XPOs(1),WS(7501)) ! DATA blank , hyphen , alphai , alphax/' ' , '-' , 'I' , 'X'/ ! iupper = 7500 ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( N<1 .OR. N>iupper ) THEN WRITE (G_IO,99001) iupper 99001 FORMAT (' ***** FATAL ERROR--The second input argument to NOROUT(3f) is outside the allowable (1,',& & I0,') intervaL *****') WRITE (G_IO,99002) N 99002 FORMAT (' ','***** The value of the argument is ',I0,' *****') RETURN ELSE IF ( N==1 ) THEN WRITE (G_IO,99003) 99003 FORMAT (' ***** NON-FATAL DIAGNOSTIC--The second input argument to NOROUT(3f) has the value 1 *****') RETURN ELSE hold = X(1) DO i = 2 , N IF ( X(i)/=hold ) GOTO 50 ENDDO WRITE (G_IO,99004) hold 99004 FORMAT (' ***** NON-FATAL DIAGNOSTIC--The first input argument (a vector) to NOROUT(3f) has all elements = ',& & E15.8,' *****') RETURN ENDIF ! !-----START POINT----------------------------------------------------- ! 50 nm1 = N - 1 nm2 = N - 2 nm3 = N - 3 nm4 = N - 4 nm5 = N - 5 an = N anm1 = nm1 anm2 = nm2 anm3 = nm3 anm4 = nm4 anm5 = nm5 ! ! SORT THE DATA AND ALSO CARRY ALONG THE OBSERVATION NUMBER--THAT IS, ! THE POSITION IN THE ORIGINAL DATA SET OF THE I-TH ORDER STATISTIC ! CALL SORTP(X,N,Y,XPOs) ! ! COMPUTE PARTIAL SAMPLE MEANS ! sum = 0.0_wp DO i = 3 , nm2 sum = sum + Y(i) ENDDO xb23 = sum/anm4 xb13 = (sum+Y(2))/anm3 xb24 = (sum+Y(nm1))/anm3 xb3 = (sum+Y(1)+Y(2))/anm2 xb2 = (sum+Y(nm1)+Y(N))/anm2 xb14 = (sum+Y(2)+Y(nm1))/anm2 xb4 = (sum+Y(1)+Y(2)+Y(nm1))/anm1 xb1 = (sum+Y(2)+Y(nm1)+Y(N))/anm1 xb = (sum+Y(1)+Y(2)+Y(nm1)+Y(N))/an ! ! COMPUTE PARTIAL SUMS OF SQUARED DEVIATIONS ! ABOUT THE PARTIAL SAMPLE MEANS ! ssq = 0.0_wp ssq1 = 0.0_wp ssq4 = 0.0_wp ssq14 = 0.0_wp ssq2 = 0.0_wp ssq3 = 0.0_wp ssq24 = 0.0_wp ssq13 = 0.0_wp ssq23 = 0.0_wp DO i = 1 , N ssq = ssq + (Y(i)-xb)**2 ENDDO DO i = 2 , N ssq1 = ssq1 + (Y(i)-xb1)**2 ENDDO DO i = 1 , nm1 ssq4 = ssq4 + (Y(i)-xb4)**2 ENDDO DO i = 2 , nm1 ssq14 = ssq14 + (Y(i)-xb14)**2 ENDDO DO i = 3 , N ssq2 = ssq2 + (Y(i)-xb2)**2 ENDDO DO i = 1 , nm2 ssq3 = ssq3 + (Y(i)-xb3)**2 ENDDO DO i = 3 , nm1 ssq24 = ssq24 + (Y(i)-xb24)**2 ENDDO DO i = 2 , nm2 ssq13 = ssq13 + (Y(i)-xb13)**2 ENDDO DO i = 3 , nm2 ssq23 = ssq23 + (Y(i)-xb23)**2 ENDDO ! ! COMPUTE PARTIAL SAMPLE STANDARD DEVIATIONS ! s = SQRT(ssq/anm1) s1 = SQRT(ssq1/anm2) s4 = SQRT(ssq4/anm2) s14 = SQRT(ssq14/anm3) s2 = SQRT(ssq2/anm3) s3 = SQRT(ssq3/anm3) s24 = SQRT(ssq24/anm4) s13 = SQRT(ssq13/anm4) s23 = SQRT(ssq23/anm5) ! ! COMPUTE OUTLIER STATISTICS ! OMIT NO OBSERVATIONS, TEST FOR X(1) st1 = (xb-Y(1))/s ! OMIT NO OBSERVATIONS, TEST FOR X(N) st2 = (Y(N)-xb)/s ! OMIT NO OBSERVATIONS, TEST FOR X(1) AND X(N) SIMULTANEOUSLY st3 = (Y(N)-Y(1))/s ! OMIT X(1), TEST FOR X(2) st4 = ssq2/ssq ! OMIT X(N), TEST FOR X(N-1) st5 = ssq3/ssq ! OMIT X(1) AND X(N), TEST FOR X(2) st6 = (xb14-Y(2))/s14 ! OMIT X(1) AND X(N), TEST FOR X(N-1) st7 = (Y(nm1)-xb14)/s14 ! OMIT X(1) AND X(N), TEST FOR X(2) AND X(N-1) st8 = (Y(nm1)-Y(2))/s14 sum4 = 0.0_wp DO i = 2 , nm2 sum4 = sum4 + (Y(i)-xb14)**4 ENDDO st9 = (an-2.0_wp)*sum4/(ssq14**2) st9 = st9 + 3.0_wp ! ! COMPUTE THE LINE PLOT WHICH SHOWS THE DISTRIBUTION OF THE OBSERVED ! VALUES IN TERMS OF MULTIPLES OF SAMPLE STANDARD DEVIATIONS AWAY FROM ! THE SAMPLE MEAN ! DO i = 1 , 130 iline1(i) = blank iline2(i) = blank ENDDO icount = 0 DO i = 1 , N mx = 10.0_wp*(((X(i)-xb)/s)+6.0_wp) + 0.5_wp mx = mx + 7 IF ( mx<7 .OR. mx>127 ) icount = icount + 1 IF ( mx>=7 .AND. mx<=127 ) iline1(mx) = alphax ENDDO DO i = 7 , 127 iline2(i) = hyphen ENDDO DO i = 7 , 127 , 10 iline2(i) = alphai ENDDO xline(7) = xb DO i = 1 , 6 irev = 13 - i + 1 ai = i xline(i) = xb - (7.0_wp-ai)*s xline(irev) = xb + (7.0_wp-ai)*s ENDDO ! ! WRITE EVERYTHING OUT ! ! WRITE OUT THE OUTLIER STATISTICS ! WRITE (G_IO,99041) WRITE (G_IO,99005) 99005 FORMAT (' ',48X,'NORMAL OUTLIER ANALYSIS') WRITE (G_IO,99042) WRITE (G_IO,99006) N 99006 FORMAT (' ',46X,'(THE SAMPLE SIZE N = ',I0,')') WRITE (G_IO,99042) WRITE (G_IO,99007) 99007 FORMAT (' ',39X,'REFERENCE--GRUBBS, TECHNOMETRICS, 1969, pages 1-21') DO i = 1 , 6 WRITE (G_IO,99042) ENDDO WRITE (G_IO,99008) 99008 FORMAT (' ',49X,'OUTLIER STATISTICS') WRITE (G_IO,99042) WRITE (G_IO,99042) WRITE (G_IO,99009) 99009 FORMAT (& & ' OMIT TEST FORM VALUE PSEUDO-SAMPLE SIZE TABLE') WRITE (G_IO,99010) 99010 FORMAT (& & ' AS AN OUTLIER AS AN OUTLIER OF STATISTIC OF STATISTIC FOR TABLE LOOK-UP REFERENCE') WRITE (G_IO,99042) WRITE (G_IO,99011) st1 , N 99011 FORMAT (& & ' NONE X(1) (XBAR - X(1))/S ',F8.4,' N = ',& & I5,' GRUBBS, TECH., 1969, P. 4') WRITE (G_IO,99012) st2 , N 99012 FORMAT (' ',' NONE X(N) (X(N) - XBAR)/S & &',F8.4,' N = ',I5,' GRUBBS, TECH., 1969, P. 4') WRITE (G_IO,99013) st3 , N 99013 FORMAT (' ',& &' NONE X(1) AND X(N) RANGE/S ',F8.4,' N = ',I5,' GRUBBS, TECH., 1969, P. 8') WRITE (G_IO,99014) st4 , N 99014 FORMAT (' ',& &' X(1) X(2) SSQD(1,2)/SSQD ',F8.4,' N = ',I5,' GRUBBS, TECH., 1969, P. 11') WRITE (G_IO,99015) st5 , N 99015 FORMAT (' ',& &' X(N) X(N-1) SSQD(N-1,N)/SSQD ',F8.4,' N = ',I5,' GRUBBS, TECH., 1969, P. 11') WRITE (G_IO,99016) st6 , nm2 99016 FORMAT (' ',& &'X(1) AND X(N) X(2) (XBAR(1,N) - X(2))/S(1,N) ',F8.4,' N-2 = ',I5,' GRUBBS, TECH., 1969, P. 4') WRITE (G_IO,99017) st7 , nm2 99017 FORMAT (' ',& &'X(1) AND X(N) X(N-1) (X(N-1) - XBAR(1,N))/S(1,N) ',F8.4,' N-2 = ',I5,' GRUBBS, TECH., 1969, P. 4') WRITE (G_IO,99018) st8 , nm2 99018 FORMAT (' ',& &'X(1) AND X(N) X(2) AND X(N-1) RANGE(1,N)/S(1,N) ',F8.4,' N-2 = ',I5,' GRUBBS, TECH., 1969, P. 8') WRITE (G_IO,99019) st9 , nm2 99019 FORMAT (' ',& &'X(1) AND X(N) X(2) AND X(N-1) SAMPLE KURTOSIS(1,N) ',F8.4,' N-2 = ',I5,' GRUBBS, TECH., 1969, P. 14') DO i = 1 , 10 WRITE (G_IO,99042) ENDDO ! ! WRITE OUT THE PARTIAL SAMPLE MEANS ! AND THE PARTIAL SAMPLE STANDARD DEVIATIONS. ! WRITE (G_IO,99020) 99020 FORMAT (' ',30X, & & 'Partial sample means and partial sample standard deviations'& & ) WRITE (G_IO,99042) WRITE (G_IO,99042) WRITE (G_IO,99021) 99021 FORMAT (' ', & &' OMIT PARTIAL SAMPLE PARTIAL SAMPLE& &') WRITE (G_IO,99022) 99022 FORMAT (' ', & &' AS AN OUTLIER MEAN STANDARD DEVIATI& &ON') WRITE (G_IO,99042) WRITE (G_IO,99023) xb , s 99023 FORMAT (' ',' NONE ',E15.8,5X,E15.8) WRITE (G_IO,99024) xb1 , s1 99024 FORMAT (' ',' X(1) ',E15.8,5X,E15.8) WRITE (G_IO,99025) xb4 , s4 99025 FORMAT (' ',' X(N) ',E15.8,5X,E15.8) WRITE (G_IO,99026) xb14 , s14 99026 FORMAT (' ',' X(1) AND X(N) ',E15.8,5X,E15.8) WRITE (G_IO,99027) xb2 , s2 99027 FORMAT (' ',' X(1) AND X(2) ',E15.8,5X,E15.8) WRITE (G_IO,99028) xb3 , s3 99028 FORMAT (' ',' X(N-1) AND X(N) ',E15.8,5X,E15.8) WRITE (G_IO,99029) xb24 , s24 99029 FORMAT (' ',' X(1), X(2), AND X(N) ',E15.8,5X,E15.8) WRITE (G_IO,99030) xb13 , s13 99030 FORMAT (' ',' X(1), X(N-1), AND X(N) ',E15.8,5X,E15.8) WRITE (G_IO,99031) xb23 , s23 99031 FORMAT (' ','X(1), X(2), X(N-1), AND X(N) ',E15.8,5X,E15.8) ! ! WRITE OUT THE FIRST 40 AND LAST 40 ORDERED OBSERVATIONS, ! INCLUDING THEIR RESIDUALS ABOUT THE (FULL) SAMPLE MEAN, ! THE STANDARDIZED RESIDUALS, ! THE NORMAL N(0,1) CUMULATIVE DISTRIBUTION FUNCTION VALUE ! OF THE STANDARDIZED RESIDUAL, AND ! THE POSITION NUMBER IN THE ORIGINAL DATA VECTOR X. ! WRITE (G_IO,99041) WRITE (G_IO,99032) 99032 FORMAT (' ',& &'Order Statistics, Residuals about the sample mean, Standardized r& &Esiduals, and Normal(0,1) cumulative distribution function values'& &) WRITE (G_IO,99042) WRITE (G_IO,99042) WRITE (G_IO,99033) 99033 FORMAT (' ',& &' INDEX ORDERED RESIDUALS STANDARDIZED NORMAL(0,1) OBSERVATION') WRITE (G_IO,99034) 99034 FORMAT (' ',& &' OBSERVATIONS ABOUT THE RESIDUALS CDF VALUES OF THE NUMBER') WRITE (G_IO,99035) 99035 FORMAT (' ',& &' SAMPLE MEAN STANDARDIZED') WRITE (G_IO,99036) 99036 FORMAT (' ',& &' RESIDUALS') WRITE (G_IO,99042) IF ( N<=80 ) THEN DO i = 1 , N res = Y(i) - xb stres = res/s CALL NORCDF(stres,cdf) WRITE (G_IO,99043) i , Y(i) , res , stres , cdf , XPOs(i) iflag = i - (i/10)*10 IF ( iflag==0 ) WRITE (G_IO,99042) ENDDO ELSE DO i = 1 , 80 IF ( i<=40 ) j = i IF ( i>=41 ) j = i + N - 80 res = Y(j) - xb stres = res/s CALL NORCDF(stres,cdf) WRITE (G_IO,99043) j , Y(j) , res , stres , cdf , XPOs(j) iflag = i - (i/10)*10 IF ( iflag==0 ) WRITE (G_IO,99042) ENDDO ENDIF DO i = 1 , 10 WRITE (G_IO,99042) ENDDO ! ! WRITE OUT THE LINE PLOT SHOWING THE DEVIATIONS ! OF THE OBSERVATIONS ABOUT THE (FULL) SAMPLE MEAN ! IN TERMS OF MULTIPLES OF THE (FULL) SAMPLE STANDARD ! DEVIATION. ! WRITE (G_IO,99037) 99037 FORMAT (' ', & &'LINE PLOT SHOWING THE DISTRIBUTION OF THE OBSERVATIONS ABOUT THE & &SAMPLE MEAN IN TERMS OF MULTIPLES OF THE SAMPLE STANDARD DEVIATION& &') WRITE (G_IO,99042) WRITE (G_IO,99042) WRITE (G_IO,99044) (iline1(i),i=1,130) WRITE (G_IO,99044) (iline2(i),i=1,130) WRITE (G_IO,99038) 99038 FORMAT (' ',& &' -6 -5 -4 -3 -2 -1 0 1 2 3 4 5 6') WRITE (G_IO,99039) (xline(i),i=1,13) 99039 FORMAT (' ',13F10.4) WRITE (G_IO,99042) WRITE (G_IO,99040) icount 99040 FORMAT (' ',10X,I5,& &' OBSERVATIONS WERE IN EXCESS OF 6 SAMPLE STANDARD DEVIATIONS FROM THE SAMPLE MEAN AND SO WERE NOT PLOTTED') ! ! WRITE OUT A NORMAL PROBABILITY PLOT ! CALL NORPLT(Y,N) ENDIF ! 99041 FORMAT ('1') 99042 FORMAT (' ') 99043 FORMAT (' ',I5,4X,E15.8,1X,E15.8,7X,F7.2,11X,F8.5,11X,F7.0) 99044 FORMAT (' ',130A1) ! END SUBROUTINE NOROUT !> !!##NAME !! norpdf(3f) - [M_datapac:PROBABILITY_DENSITY] compute the normal !! probability density function !! !!##SYNOPSIS !! !! SUBROUTINE NORPDF(X,Pdf) !! !! REAL(kind=wp),intent(in) :: X !! REAL(kind=wp),intent(out) :: Pdf !! !!##DESCRIPTION !! NORPDF(3f) computes the probability density function value for the !! normal (Gaussian) distribution with mean = 0 and standard deviation !! = 1. !! !! This distribution is defined for all X and has the probability !! density function !! !! f(X) = (1/sqrt(2*pi))*exp(-X*X/2) !! !!##INPUT ARGUMENTS !! !! X The value at which the probability density function is to !! be evaluated. !! !!##OUTPUT ARGUMENTS !! !! PDF The probability density function value. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_norpdf !! !@(#) line plotter graph of probability density function !! use M_datapac, only : norpdf, plott, label !! implicit none !! real,allocatable :: x(:), y(:) !! integer :: i !! call label('norpdf') !! x=[(real(i),i=-100,100,1)] !! if(allocated(y))deallocate(y) !! allocate(y(size(x))) !! do i=1,size(x) !! call norpdf(x(i)/10.0,y(i)) !! enddo !! call plott(x,y,size(x)) !! end program demo_norpdf !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !!##MAINTAINER !! John Urban, 2022.05.31 !!##LICENSE !! CC0-1.0 !!##REFERENCES !! * Johnson and Kotz, Continuous Univariate Distributions--1, 1970, pages 40-111. ! ORIGINAL VERSION--JUNE 1972. ! UPDATED --SEPTEMBER 1975. ! UPDATED --NOVEMBER 1975. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE NORPDF(X,Pdf) REAL(kind=wp),intent(in) :: X REAL(kind=wp),intent(out) :: Pdf REAL(kind=wp),parameter :: c=0.3989422804_wp ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS. -- NO INPUT ARGUMENT ERRORS POSSIBLE FOR THIS DISTRIBUTION. ! Pdf = c*EXP(-(X*X)/2.0_wp) ! END SUBROUTINE NORPDF !> !!##NAME !! norplt(3f) - [M_datapac:LINE_PLOT] generate a normal probability plot !! !!##SYNOPSIS !! !! SUBROUTINE NORPLT(X,N) !! !!##DESCRIPTION !! norplt(3f) generates a normal (gaussian) probability plot. !! !! the prototype normal distribution used herein has mean = 0 and standard !! deviation = 1. this distribution is defined for all x and has the !! probability density function !! !! f(x) = (1/sqrt(2*pi)) * exp(-x*x/2). !! !! as used herein, a probability plot for a distribution is a plot of !! the ordered observations versus the order statistic medians for that !! distribution. the normal probability plot is useful in graphically !! testing the composite (that is, location and scale parameters need !! not be specified) hypothesis that the underlying distribution from !! which the data have been randomly drawn is the normal distribution. !! !! if the hypothesis is true, the probability plot should be near-linear. !! !! a measure of such linearity is given by the calculated probability !! plot correlation coefficient. !! !!##OPTIONS !! X description of parameter !! Y description of parameter !! !!##EXAMPLES !! !! Sample program: !! !! program demo_norplt !! use M_datapac, only : norplt !! implicit none !! ! call norplt(x,y) !! end program demo_norplt !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the Statistical !! Engineering Division, National Institute of Standards and Technology. !!##MAINTAINER !! John Urban, 2022.05.31 !!##LICENSE !! CC0-1.0 !!##REFERENCES !! * FILLIBEN, 'TECHNIQUES FOR TAIL LENGTH ANALYSIS', PROCEEDINGS OF THE !! EIGHTEENTH CONFERENCE ON THE DESIGN OF EXPERIMENTS IN ARMY RESEARCH !! DEVELOPMENT AND TESTING (ABERDEEN, MARYLAND, OCTOBER, 1972), pages !! 425-450. !! * FILLIBEN, 'THE PROBABILITY PLOT CORRELATION COEFFICIENT TEST FOR !! NORMALITY', TECHNOMETRICS, 1975, pages 111-117. !! * RYAN AND JOINER, 'NORMAL PROBABILITY PLOTS AND TESTS FOR NORMALITY' !! PENNSYLVANIA STATE UNIVERSITY REPORT. !! * HAHN AND SHAPIRO, STATISTICAL METHODS IN ENGINEERING, 1967, pages !! 260-308. !! * JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE DISTRIBUTIONS--1, 1970, !! pages 40-111. ! ORIGINAL VERSION--JUNE 1972. ! UPDATED --SEPTEMBER 1975. ! UPDATED --NOVEMBER 1975. ! UPDATED --FEBRUARY 1976. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE NORPLT(X,N) REAL(kind=wp) :: an , cc , hold , sum1 , sum2 , sum3 , tau , W , wbar , WS , X , Y , ybar , yint , yslope INTEGER :: i , iupper , N ! ! INPUT ARGUMENTS--X = THE VECTOR OF ! (UNSORTED OR SORTED) OBSERVATIONS. ! --N = THE INTEGER NUMBER OF OBSERVATIONS ! IN THE VECTOR X. ! OUTPUT--A ONE-page NORMAL PROBABILITY PLOT. ! PRINTING--YES. ! RESTRICTIONS--THE MAXIMUM ALLOWABLE VALUE OF N ! FOR THIS SUBROUTINE IS 7500. ! !--------------------------------------------------------------------- ! DIMENSION X(:) DIMENSION Y(7500) , W(7500) COMMON /BLOCK2_real32/ WS(15000) EQUIVALENCE (Y(1),WS(1)) EQUIVALENCE (W(1),WS(7501)) ! DATA tau/1.43218641_wp/ ! iupper = 7500 ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( N<1 .OR. N>iupper ) THEN WRITE (G_IO,99001) iupper 99001 FORMAT (' ', & &'***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE NORPLT SUBROU& &TINE IS OUTSIDE THE ALLOWABLE (1,',I0,') INTERVAL *****') WRITE (G_IO,99002) N 99002 FORMAT (' ','***** THE VALUE OF THE ARGUMENT IS ',I0,' *****') RETURN ELSEIF ( N==1 ) THEN WRITE (G_IO,99003) 99003 FORMAT (' ', & &'***** NON-FATAL DIAGNOSTIC--THE SECOND INPUT ARGUMENT TO THE NORP& < SUBROUTINE HAS THE VALUE 1 *****') RETURN ELSE hold = X(1) DO i = 2 , N IF ( X(i)/=hold ) GOTO 50 ENDDO WRITE (G_IO,99004) hold 99004 FORMAT (' ', & &'***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT (A VECTOR) & &TO THE NORPLT SUBROUTINE HAS ALL ELEMENTS = ',E15.8,' *****') ! !-----START POINT----------------------------------------------------- ! 50 an = N ! ! SORT THE DATA ! CALL SORT(X,N,Y) ! ! GENERATE UNIFORM ORDER STATISTIC MEDIANS ! CALL UNIMED(N,W) ! ! COMPUTE NORMAL ORDER STATISTIC MEDIANS ! DO i = 1 , N CALL NORPPF(W(i),W(i)) ENDDO ! ! PLOT THE ORDERED OBSERVATIONS VERSUS ORDER STATISTICS MEDIANS. ! WRITE OUT THE TAIL LENGTH MEASURE OF THE DISTRIBUTION ! AND THE SAMPLE SIZE. ! CALL PLOT(Y,W,N) WRITE (G_IO,99005) tau , N ! 99005 FORMAT (' ','NORMAL PROBABILITY PLOT (TAU = ',E15.8,')',56X, & & 'THE SAMPLE SIZE N = ',I0) ! ! COMPUTE THE PROBABILITY PLOT CORRELATION COEFFICIENT. ! COMPUTE LOCATION AND SCALE ESTIMATES ! FROM THE INTERCEPT AND SLOPE OF THE PROBABILITY PLOT. ! THEN WRITE THEM OUT. ! sum1 = 0.0_wp DO i = 1 , N sum1 = sum1 + Y(i) ENDDO ybar = sum1/an wbar = 0.0_wp sum1 = 0.0_wp sum2 = 0.0_wp sum3 = 0.0_wp DO i = 1 , N sum1 = sum1 + (Y(i)-ybar)*(Y(i)-ybar) sum2 = sum2 + W(i)*Y(i) sum3 = sum3 + W(i)*W(i) ENDDO cc = sum2/SQRT(sum3*sum1) yslope = sum2/sum3 yint = ybar - yslope*wbar WRITE (G_IO,99006) cc , yint , yslope 99006 FORMAT (' ','PROBABILITY PLOT CORRELATION COEFFICIENT = ',F8.5,& & 5X,'ESTIMATED INTERCEPT = ',E15.8,3X, & & 'ESTIMATED SLOPE = ',E15.8) ENDIF ! END SUBROUTINE NORPLT !> !!##NAME !! norppf(3f) - [M_datapac:PERCENT_POINT] compute the normal percent point function !! !!##SYNOPSIS !! !! SUBROUTINE NORPPF(P,Ppf) !! !!##DESCRIPTION !! norppf(3f) computes the percent point function value for the normal !! (gaussian) distribution with mean = 0 and standard deviation = 1. !! !! this distribution is defined for all x and has the probability !! density function !! !! f(x) = (1/sqrt(2*pi))*exp(-x*x/2). !! !! note that the percent point function of a distribution is identically !! the same as the inverse cumulative distribution function of the !! distribution. !! !!##OPTIONS !! X description of parameter !! Y description of parameter !! !!##EXAMPLES !! !! Sample program: !! !! program demo_norppf !! use M_datapac, only : norppf !! implicit none !! ! call norppf(x,y) !! end program demo_norppf !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the Statistical !! Engineering Division, National Institute of Standards and Technology. !!##MAINTAINER !! John Urban, 2022.05.31 !!##LICENSE !! CC0-1.0 !!##REFERENCES !! * ODEH AND EVANS, THE PERCENTAGE POINTS OF THE NORMAL DISTRIBUTION, !! ALGORITHM 70, APPLIED STATISTICS, 1974, pages 96-97. !! * EVANS, ALGORITHMS FOR MINIMAL DEGREE POLYNOMIAL AND RATIONAL !! APPROXIMATION, M. SC. THESIS, 1972, UNIVERSITY OF VICTORIA, B. C., !! CANADA. !! * HASTINGS, APPROXIMATIONS FOR DIGITAL COMPUTERS, 1955, pages 113, !! 191, 192. !! * NATIONAL BUREAU OF STANDARDS APPLIED MATHEMATICS SERIES 55, 1964, !! page 933, FORMULA 26.2.23. !! * FILLIBEN, SIMPLE AND ROBUST LINEAR ESTIMATION OF THE LOCATION !! PARAMETER OF A SYMMETRIC DISTRIBUTION (UNPUBLISHED PH.D. DISSERTATION, !! PRINCETON UNIVERSITY), 1969, pages 21-44, 229-231. !! * FILLIBEN, 'THE PERCENT POINT FUNCTION', (UNPUBLISHED MANUSCRIPT), !! 1970, pages 28-31. !! * JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE DISTRIBUTIONS--1, 1970, !! pages 40-111. !! * THE KELLEY STATISTICAL TABLES, 1948. !! * OWEN, HANDBOOK OF STATISTICAL TABLES, 1962, pages 3-16. !! * PEARSON AND HARTLEY, BIOMETRIKA TABLES FOR STATISTICIANS, VOLUME 1, !! 1954, pages 104-113. ! ORIGINAL VERSION--JUNE 1972. ! UPDATED --SEPTEMBER 1975. ! UPDATED --NOVEMBER 1975. ! UPDATED --OCTOBER 1976. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE NORPPF(P,Ppf) REAL(kind=wp) :: aden , anum , P , p0 , p1 , p2 , p3 , p4 , Ppf , q0 , q1 , q2 , q3 , q4 , r , t ! ! INPUT ARGUMENTS--P = THE VALUE ! (BETWEEN 0.0 AND 1.0) ! AT WHICH THE PERCENT POINT ! FUNCTION IS TO BE EVALUATED. ! OUTPUT ARGUMENTS--PPF = THE PERCENT ! POINT FUNCTION VALUE. ! OUTPUT--THE PERCENT POINT ! FUNCTION VALUE PPF. ! PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. ! RESTRICTIONS--P SHOULD BE BETWEEN 0.0 AND 1.0, EXCLUSIVELY. ! COMMENTS--THE CODING AS PRESENTED BELOW ! IS ESSENTIALLY IDENTICAL TO THAT ! PRESENTED BY ODEH AND EVANS ! AS ALGORITHM 70 OF APPLIED STATISTICS. ! THE PRESENT AUTHOR HAS MODIFIED THE ! ORIGINAL ODEH AND EVANS CODE WITH ONLY ! MINOR STYLISTIC CHANGES. ! --AS POINTED OUT BY ODEH AND EVANS ! IN APPLIED STATISTICS, ! THEIR ALGORITHM REPRESENTES A ! SUBSTANTIAL IMPROVEMENT OVER THE ! PREVIOUSLY EMPLOYED ! HASTINGS APPROXIMATION FOR THE ! NORMAL PERCENT POINT FUNCTION-- ! THE ACCURACY OF APPROXIMATION ! BEING IMPROVED FROM 4.5*(10**-4) ! TO 1.5*(10**-8). ! !--------------------------------------------------------------------- ! DATA p0 , p1 , p2 , p3 , p4/ - .322232431088_wp , -1.0_wp , & & -.342242088547_wp , -.204231210245E-1_wp , -.453642210148E-4_wp/ DATA q0 , q1 , q2 , q3 , q4/.993484626060E-1_wp , .588581570495_wp , & & .531103462366_wp , .103537752850_wp , .38560700634E-2_wp/ ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( P<=0.0_wp .OR. P>=1.0_wp ) THEN WRITE (G_IO,99001) 99001 FORMAT (' ', & &'***** FATAL ERROR--THE FIRST INPUT ARGUMENT TO THE NORPPF SUBROU& &TINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL *****') WRITE (G_IO,99002) P 99002 FORMAT (' ','***** THE VALUE OF THE ARGUMENT IS ',E15.8, & & ' *****') RETURN ! !-----START POINT----------------------------------------------------- ! ELSEIF ( P/=0.5_wp ) THEN ! r = P IF ( P>0.5_wp ) r = 1.0_wp - r t = SQRT(-2.0_wp*LOG(r)) anum = ((((t*p4+p3)*t+p2)*t+p1)*t+p0) aden = ((((t*q4+q3)*t+q2)*t+q1)*t+q0) Ppf = t + (anum/aden) IF ( P<0.5_wp ) Ppf = -Ppf GOTO 99999 ENDIF Ppf = 0.0_wp RETURN ! 99999 END SUBROUTINE NORPPF !> !!##NAME !! norran(3f) - [M_datapac:RANDOM] generate normal random numbers !! !!##SYNOPSIS !! !! SUBROUTINE NORRAN(N,Iseed,X) !! !! INTEGER,integer(in) :: N !! INTEGER,integer(inout) :: Iseed !! REAL(kind=wp),integer(out) :: X(:) !! !!##DESCRIPTION !! !! NORRAN(3f) generates a random sample of size N from the normal !! (Gaussian) distribution with mean = 0 and standard deviation = 1. !! !! Internally, it uses the Box-Muller algorithm. !! !! This distribution is defined for all X and has the probability !! density function !! !! f(X) = (1/sqrt(2*pi))*exp(-X*X/2) !! !!##INPUT ARGUMENTS !! !! N The desired integer number of random numbers to be generated. !! !! ISEED An integer seed value. Should be set to a non-negative value !! to start a new sequence of values. Will be set to -1 on return !! to indicate the next call should continue the current random !! sequence walk. !! !!##OUTPUT ARGUMENTS !! !! X A vector (of dimension at least N) into which the generated !! random sample of size N from the normal distribution with mean = !! 0 and standard deviation = 1 will be placed. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_norran !! use M_datapac, only : norran, label, plotxt, sort, norplt, plott !! implicit none !! integer,parameter :: N=300 !! real :: x(N), y(N) !! real :: mu, sigma !! integer :: Iseed !! integer :: i !! Iseed=1234 !! sigma=1.00000 !! mu=0.0 !! call label('norran') !! call norran(N,Iseed,x) !! x = sigma*x !! x = x + mu !! call plotxt(x,n) !! call sort(x,n,y) ! sort and replot to better discern distribution !! call plott([(real(i),i=1,n)],y,n) !! end program demo_norran !! !! Results: !! !! THE FOLLOWING IS A PLOT OF X(I) (VERTICALLY) VERSUS I (HORIZONTALLY !! I-----------I-----------I-----------I-----------I !! 0.3016713E+01 - X !! 0.2787551E+01 I !! 0.2558388E+01 I !! 0.2329226E+01 I X !! 0.2100063E+01 I !! 0.1870901E+01 I X X XX X XX XX X !! 0.1641738E+01 - X X X !! 0.1412575E+01 I X X X X XX X X X X !! 0.1183413E+01 I X X XX X XXX XX !! 0.9542503E+00 I X XX X X X XX X X !! 0.7250879E+00 I X XX X X X XXX XX X X X !! 0.4959254E+00 I XX X XXX XXXXX X XX X X XX XX X !! 0.2667627E+00 - X XX XXX X XXX X X XX X XXXX X X XX !! 0.3760028E-01 I X X X XX XXX X XXX X X XXXX XX XX X XX !! -0.1915622E+00 I XX X X X X X X X X XXXX XX XX X X X !! -0.4207249E+00 I XX XX XX XXXX X XX XX X XXXX X X XXX XXX !! -0.6498873E+00 I X XXX XX XX XXXXXX X XX X XX !! -0.8790498E+00 I XX X X X X X XXX X X XX XX !! -0.1108212E+01 - X XXX XXX X X X !! -0.1337375E+01 I X X X X X X X XX X X !! -0.1566537E+01 I X X X X XX !! -0.1795700E+01 I X X X XX X X !! -0.2024862E+01 I X X X !! -0.2254025E+01 I X XX !! -0.2483188E+01 - X !! I-----------I-----------I-----------I-----------I !! 0.1000E+01 0.7575E+02 0.1505E+03 0.2252E+03 0.3000E+03 !! !! The following is a plot of Y(I) (vertically) versus X(I) (horizontally) !! I-----------I-----------I-----------I-----------I !! 0.3000000E+03 - XX X X !! 0.2875417E+03 I XXXXX !! 0.2750833E+03 I XXX !! 0.2626250E+03 I XXX !! 0.2501667E+03 I XXX !! 0.2377083E+03 I XX !! 0.2252500E+03 - XXX !! 0.2127917E+03 I X !! 0.2003333E+03 I XX !! 0.1878750E+03 I XX !! 0.1754167E+03 I XX !! 0.1629583E+03 I X !! 0.1505000E+03 - XX !! 0.1380417E+03 I XX !! 0.1255833E+03 I XX !! 0.1131250E+03 I XX !! 0.1006667E+03 I X !! 0.8820834E+02 I XX !! 0.7575000E+02 - X !! 0.6329167E+02 I XX !! 0.5083334E+02 I XX !! 0.3837500E+02 I XX !! 0.2591669E+02 I XXX !! 0.1345834E+02 I XXXXX !! 0.1000000E+01 - X X XX !! I-----------I-----------I-----------I-----------I !! -0.2483E+01 -0.1108E+01 0.2668E+00 0.1642E+01 0.3017E+01 !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !! !!##REFERENCES !! * Box and Muller, 'A Note on the Generation of Random Normal Deviates', !! Journal of the Association for Computing Machinery, 1958, pages 610-611. !! * Tocher, The Art of Simulation, 1963, pages 33-34. !! * Hammersley and Handscomb, Monte Carlo Methods, 1964, page 39. !! * Johnson and Kotz, Continuous Univariate Distributions--1, 1970, !! pages 40-111. ! VERSION NUMBER--82.6 ! ORIGINAL VERSION--JUNE 1972. ! UPDATED --SEPTEMBER 1975. ! UPDATED --NOVEMBER 1975. ! UPDATED --JULY 1976. ! UPDATED --DECEMBER 1981. ! UPDATED --MAY 1982. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE NORRAN(N,Iseed,X) INTEGER,intent(in) :: N INTEGER,intent(inout) :: Iseed REAL(kind=wp),intent(out) :: X(:) REAL(kind=wp) :: arg1, arg2, sqrt1, u1, u2, y(2), z1, z2 INTEGER :: i, ip1 ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( N<1 ) THEN WRITE (G_IO,99001) 99001 FORMAT (' ***** FATAL ERROR--THE FIRST INPUT ARGUMENT TO THE NORRAN SUBROUTINE IS NON-POSITIVE *****') WRITE (G_IO,99002) N 99002 FORMAT (' ','***** THE VALUE OF THE ARGUMENT IS ',I0,' *****') RETURN ELSE ! ! GENERATE N UNIFORM (0,1) RANDOM NUMBERS; ! THEN GENERATE 2 ADDITIONAL UNIFORM (0,1) RANDOM NUMBERS ! (TO BE USED BELOW IN FORMING THE N-TH NORMAL ! RANDOM NUMBER WHEN THE DESIRED SAMPLE SIZE N ! HAPPENS TO BE ODD). ! CALL UNIRAN(N,Iseed,X) CALL UNIRAN(2,Iseed,y) ! ! GENERATE N NORMAL RANDOM NUMBERS ! USING THE BOX-MULLER METHOD. ! DO i = 1 , N , 2 ip1 = i + 1 u1 = X(i) IF ( i==N ) THEN u2 = y(2) ELSE u2 = X(ip1) ENDIF arg1 = -2.0_wp*LOG(u1) arg2 = 2.0_wp*G_pi*u2 sqrt1 = SQRT(arg1) z1 = sqrt1*COS(arg2) z2 = sqrt1*SIN(arg2) X(i) = z1 IF ( i/=N ) X(ip1) = z2 ENDDO ENDIF END SUBROUTINE NORRAN !> !!##NAME !! norsf(3f) - [M_datapac:SPARSITY] compute the normal sparsity function !! !!##SYNOPSIS !! !! SUBROUTINE NORSF(P,Sf) !! !! REAL(kind=wp),intent(in) :: P !! REAL(kind=wp),intent(out) :: Sf !! !!##DESCRIPTION !! NORSF(3f) computes the sparsity function value for the normal !! (Gaussian) distribution with mean = 0 and standard deviation = 1. !! !! This distribution is defined for all X and has the probability !! density function !! !! f(X) = (1/sqrt(2*pi))*exp(-x*x/2) !! !! Note that the sparsity function of a distribution is the derivative !! of the percent point function, and also is the reciprocal of the !! probability density function (but in units of P rather than X). !! !!##INPUT ARGUMENTS !! !! P The value at which the sparsity function is to be evaluated. !! P should be between 0.0 and 1.0, exclusively. !! !!##OUTPUT ARGUMENTS !! !! SF The sparsity function value. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_norsf !! use M_datapac, only : norsf !! implicit none !! ! call norsf(x,y) !! end program demo_norsf !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !! !!##REFERENCES !! * Filliben, Simple and Robust Linear Estimation of the Location !! Parameter of a Symmetric Distribution (Unpublished PH.D. Dissertation, !! Princeton University), 1969, pages 21-44, 229-231. !! * Filliben, 'The Percent Point Function', (Unpublished Manuscript), !! 1970, pages 28-31. !! * Johnson and Kotz, Continuous Univariate Distributions--1, 1970, !! pages 40-111. ! ORIGINAL VERSION--JUNE 1972. ! UPDATED --SEPTEMBER 1975. ! UPDATED --NOVEMBER 1975. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE NORSF(P,Sf) REAL(kind=wp),intent(in) :: P REAL(kind=wp),intent(out) :: Sf REAL(kind=wp) :: c, pdf, ppf !--------------------------------------------------------------------- DATA c/0.3989422804_wp/ ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( P<=0.0_wp .OR. P>=1.0_wp ) THEN WRITE (G_IO,99001) 99001 FORMAT (' ***** FATAL ERROR--THE first input argument to NORSF(3f) is outside the allowable (0,1) interval *****') WRITE (G_IO,99002) P 99002 FORMAT (' ','***** The value of the argument is ',E15.8,' *****') RETURN ELSE CALL NORPPF(P,ppf) pdf = c*EXP(-(ppf*ppf)/2.0_wp) Sf = 1.0_wp/pdf ENDIF ! END SUBROUTINE NORSF !> !!##NAME !! parcdf(3f) - [M_datapac:CUMULATIVE_DISTRIBUTION] compute the Pareto !! cumulative distribution function !! !!##SYNOPSIS !! !! SUBROUTINE PARCDF(X,Gamma,Cdf) !! !! REAL(kind=wp),intent(in) :: X !! REAL(kind=wp),intent(in) :: Gamma !! REAL(kind=wp),intent(out) :: Cdf !! !!##DESCRIPTION !! !! PARCDF(3f) computes the cumulative distribution function value for !! the Pareto distribution with REAL tail length parameter !! = GAMMA. !! !! The Pareto distribution used herein is defined for all X greater than !! or equal to 1, and has the probability density function !! !! f(X) = GAMMA / (X**(GAMMA+1)) !! !!##INPUT ARGUMENTS !! !! X The value at which the cumulative distribution function is !! to be evaluated. X should be greater than or equal to 1. !! !! GAMMA The value of the tail length parameter. GAMMA should be !! positive. !! !!##OUTPUT ARGUMENTS !! !! CDF The cumulative distribution function value for the Pareto !! distribution !! !!##EXAMPLES !! !! Sample program: !! !! program demo_parcdf !! !@(#) line plotter graph of cumulative distribution function !! use M_datapac, only : parcdf, plott, label !! implicit none !! real,allocatable :: x(:), y(:) !! real :: gamma !! integer :: i !! call label('parcdf') !! x=[(real(i)/10.0+1.0,i=1,100,1)] !! if(allocated(y))deallocate(y) !! allocate(y(size(x))) !! gamma=0.3 !! do i=1,size(x) !! call parcdf(X(i),Gamma,y(i)) !! enddo !! call plott(x,y,size(x)) !! end program demo_parcdf !! !! Results: !! !! The following is a plot of Y(I) (vertically) versus X(I) (horizontally) !! I-----------I-----------I-----------I-----------I !! 0.1100000E+02 - X !! 0.1058750E+02 I XX !! 0.1017500E+02 I X !! 0.9762500E+01 I X !! 0.9350000E+01 I XX !! 0.8937500E+01 I X !! 0.8525000E+01 - X !! 0.8112500E+01 I XX !! 0.7700000E+01 I XX !! 0.7287500E+01 I XX !! 0.6875000E+01 I XX !! 0.6462500E+01 I XX !! 0.6050000E+01 - XX !! 0.5637500E+01 I XX !! 0.5225000E+01 I XXX !! 0.4812500E+01 I XX !! 0.4400000E+01 I XXX !! 0.3987500E+01 I XX !! 0.3575000E+01 - XX !! 0.3162500E+01 I XXX !! 0.2750000E+01 I XXX !! 0.2337501E+01 I XXXX !! 0.1925000E+01 I X XXX !! 0.1512500E+01 I X XX X !! 0.1100000E+01 - X X X !! I-----------I-----------I-----------I-----------I !! 0.2819E-01 0.1494E+00 0.2706E+00 0.3918E+00 0.5129E+00 !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !!##MAINTAINER !! John Urban, 2022.05.31 !!##LICENSE !! CC0-1.0 !!##REFERENCES !! * Johnson and Kotz, Continuous Univariate Distributions--1, 1970, !! pages 233-249. !! * hastings and Peacock, Statistical Distributions--A Handbook for !! Students and Practitioners, 1975, page 102. ! ORIGINAL VERSION--NOVEMBER 1975. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE PARCDF(X,Gamma,Cdf) REAL(kind=wp),intent(in) :: X REAL(kind=wp),intent(in) :: Gamma REAL(kind=wp),intent(out) :: Cdf !--------------------------------------------------------------------- ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( X<1.0_wp ) THEN WRITE (G_IO,99001) 99001 FORMAT (' ***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT TO PARCDF(3f) IS LESS THAN 1.0 *****') WRITE (G_IO,99003) X Cdf = 0.0_wp RETURN ELSEIF ( Gamma<=0.0_wp ) THEN WRITE (G_IO,99002) 99002 FORMAT (' ***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO PARCDF(3f) IS NON-POSITIVE *****') WRITE (G_IO,99003) Gamma Cdf = 0.0_wp RETURN ELSE ! !-----START POINT----------------------------------------------------- ! Cdf = 1.0_wp - (X**(-Gamma)) ENDIF 99003 FORMAT (' ','***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') ! END SUBROUTINE PARCDF !> !!##NAME !! parplt(3f) - [M_datapac:LINE_PLOT] generate a Pareto probability plot !! !!##SYNOPSIS !! !! SUBROUTINE PARPLT(X,N,Gamma) !! !!##DESCRIPTION !! PARPLT(3f) generates a Pareto probability plot (with tail length !! parameter value = GAMMA). !! !! The prototype pareto distribution used herein is defined for all X !! equal to or greater than 1, and has the probability density function !! !! f(X) = GAMMA / (X**(GAMMA+1)). !! !! As used herein, a probability plot for a distribution is a plot !! of the ordered observations versus the order statistic medians for !! that distribution. !! !! The Pareto probability plot is useful in graphically testing the !! composite (that is, location and scale parameters need not be !! specified) hypothesis that the underlying distribution from which !! the data have been randomly drawn is the pareto distribution with !! tail length parameter value = gamma. !! !! If the hypothesis is true, the probability plot should be near-linear. !! !! A measure of such linearity is given by the calculated probability !! plot correlation coefficient. !! !!##OPTIONS !! X description of parameter !! Y description of parameter !! !!##EXAMPLES !! !! Sample program: !! !! program demo_parplt !! use M_datapac, only : parplt !! implicit none !! ! call parplt(x,y) !! end program demo_parplt !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !! !!##REFERENCES !! * Filliben, 'Techniques for Tail Length Analysis', Proceedings of the !! Eighteenth Conference on the Design of Experiments in Army Research !! Development and Testing (Aberdeen, Maryland, October, 1972), pages !! 425-450. !! * Hahn and Shapiro, Statistical Methods in Engineering, 1967, pages !! 260-308. !! * Johnson and Kotz, Continuous Univariate Distributions--1, 1970, !! pages 233-249. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE PARPLT(X,N,Gamma) REAL(kind=wp) :: an, cc, Gamma, hold, pp0025, pp025, pp975, pp9975, q, sum1, sum2, sum3, tau, W, wbar, WS, X, Y, ybar, yint REAL(kind=wp) :: yslope INTEGER :: i, iupper, N ! ! INPUT ARGUMENTS--X = THE VECTOR OF ! (UNSORTED OR SORTED) OBSERVATIONS. ! --N = THE INTEGER NUMBER OF OBSERVATIONS ! IN THE VECTOR X. ! --GAMMA = THE VALUE OF THE ! TAIL LENGTH PARAMETER. ! GAMMA SHOULD BE POSITIVE. ! OUTPUT--A ONE-page PARETO PROBABILITY PLOT. ! PRINTING--YES. ! RESTRICTIONS--THE MAXIMUM ALLOWABLE VALUE OF N ! FOR THIS SUBROUTINE IS 7500. ! --GAMMA SHOULD BE POSITIVE. ! OTHER DATAPAC SUBROUTINES NEEDED--SORT, UNIMED, PLOT. ! FORTRAN LIBRARY SUBROUTINES NEEDED--SQRT. ! MODE OF INTERNAL OPERATIONS--. ! ORIGINAL VERSION--NOVEMBER 1975. ! UPDATED --FEBRUARY 1976. !--------------------------------------------------------------------- DIMENSION X(:) DIMENSION Y(7500) , W(7500) COMMON /BLOCK2_real32/ WS(15000) EQUIVALENCE (Y(1),WS(1)) EQUIVALENCE (W(1),WS(7501)) ! iupper = 7500 ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( N<1 .OR. N>iupper ) THEN WRITE (G_IO,99001) iupper 99001 FORMAT (' ', & &'***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE PARPLT SUBROU& &TINE IS OUTSIDE THE ALLOWABLE (1,',I0,') INTERVAL *****') WRITE (G_IO,99002) N 99002 FORMAT (' ','***** THE VALUE OF THE ARGUMENT IS ',I0,' *****') RETURN ELSEIF ( N==1 ) THEN WRITE (G_IO,99003) 99003 FORMAT (' ', & &'***** NON-FATAL DIAGNOSTIC--THE SECOND INPUT ARGUMENT TO THE PARP& < SUBROUTINE HAS THE VALUE 1 *****') RETURN ELSE IF ( Gamma<=0.0_wp ) THEN WRITE (G_IO,99004) 99004 FORMAT (' ', & &'***** FATAL ERROR--THE THIRD INPUT ARGUMENT TO THE PARPLT SUBROU& &TINE IS NON-POSITIVE *****') WRITE (G_IO,99005) Gamma 99005 FORMAT (' ','***** THE VALUE OF THE ARGUMENT IS ',E15.8, & & ' *****') RETURN ELSE hold = X(1) DO i = 2 , N IF ( X(i)/=hold ) GOTO 50 ENDDO WRITE (G_IO,99006) hold 99006 FORMAT (' ', & &'***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT (A VECTOR) & &TO THE PARPLT SUBROUTINE HAS ALL ELEMENTS = ',E15.8,' *****') RETURN ENDIF ! !-----START POINT----------------------------------------------------- ! 50 an = N ! ! SORT THE DATA ! CALL SORT(X,N,Y) ! ! GENERATE UNIFORM ORDER STATISTIC MEDIANS ! CALL UNIMED(N,W) ! ! COMPUTE PARETO DISTRIBUTION ORDER STATISTIC MEDIANS ! DO i = 1 , N W(i) = (1.0_wp-W(i))**(-1.0_wp/Gamma) ENDDO ! ! PLOT THE ORDERED OBSERVATIONS VERSUS ORDER STATISTICS MEDIANS. ! COMPUTE THE TAIL LENGTH MEASURE OF THE DISTRIBUTION. ! WRITE OUT THE TAIL LENGTH MEASURE OF THE DISTRIBUTION ! AND THE SAMPLE SIZE. ! CALL PLOT(Y,W,N) q = 0.9975_wp pp9975 = (1.0_wp-q)**(-1.0_wp/Gamma) q = 0.0025_wp pp0025 = (1.0_wp-q)**(-1.0_wp/Gamma) q = 0.975_wp pp975 = (1.0_wp-q)**(-1.0_wp/Gamma) q = 0.025_wp pp025 = (1.0_wp-q)**(-1.0_wp/Gamma) tau = (pp9975-pp0025)/(pp975-pp025) WRITE (G_IO,99007) Gamma , tau , N ! 99007 FORMAT (' ', & & 'PARETO PROBABILITY PLOT WITH EXPONENT PARAMETER = ', & & E17.10,1X,'(TAU = ',E15.8,')',11X, & & 'THE SAMPLE SIZE N = ',I0) ! ! COMPUTE THE PROBABILITY PLOT CORRELATION COEFFICIENT. ! COMPUTE LOCATION AND SCALE ESTIMATES ! FROM THE INTERCEPT AND SLOPE OF THE PROBABILITY PLOT. ! THEN WRITE THEM OUT. ! sum1 = 0.0_wp sum2 = 0.0_wp DO i = 1 , N sum1 = sum1 + Y(i) sum2 = sum2 + W(i) ENDDO ybar = sum1/an wbar = sum2/an sum1 = 0.0_wp sum2 = 0.0_wp sum3 = 0.0_wp DO i = 1 , N sum1 = sum1 + (Y(i)-ybar)*(Y(i)-ybar) sum2 = sum2 + (Y(i)-ybar)*(W(i)-wbar) sum3 = sum3 + (W(i)-wbar)*(W(i)-wbar) ENDDO cc = sum2/SQRT(sum3*sum1) yslope = sum2/sum3 yint = ybar - yslope*wbar WRITE (G_IO,99008) cc , yint , yslope 99008 FORMAT (' ','PROBABILITY PLOT CORRELATION COEFFICIENT = ',F8.5,& & 5X,'ESTIMATED INTERCEPT = ',E15.8,3X, & & 'ESTIMATED SLOPE = ',E15.8) ENDIF ! END SUBROUTINE PARPLT !> !!##NAME !! parppf(3f) - [M_datapac:PERCENT_POINT] compute the Pareto percent !! point function !! !!##SYNOPSIS !! !! SUBROUTINE PARPPF(P,Gamma,Ppf) !! !! REAL(kind=wp),intent(in) :: P !! REAL(kind=wp),intent(in) :: Gamma !! REAL(kind=wp),intent(out) :: Ppf !! !!##DESCRIPTION !! PARPPF(3f) computes the percent point function value for the Pareto !! distribution with REAL tail length parameter = GAMMA. !! !! The Pareto distribution used herein is defined for all X greater than !! or equal to 1, and has the probability density function !! !! f(X) = GAMMA / (X**(GAMMA+1)) !! !! Note that the percent point function of a distribution is identically !! the same as the inverse cumulative distribution function of the !! distribution. !! !!##INPUT ARGUMENTS !! !! P The value (between 0.0 (inclusively) and 1.0 (exclusively)) !! at which the percent point function is to be evaluated. !! !! GAMMA The value of the tail length parameter. GAMMA should be !! positive. !! !!##OUTPUT ARGUMENTS !! !! PPF The percent point function value for the Pareto distribution !! !!##EXAMPLES !! !! Sample program: !! !! program demo_parppf !! use M_datapac, only : parppf !! implicit none !! ! call parppf(x,y) !! end program demo_parppf !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !! !!##REFERENCES !! * Johnson and Kotz, Continuous Univariate Distributions--1, 1970, !! pages 233-249. !! * Hastings and Peacock, Statistical Distributions--A Handbook for !! Students and Practitioners, 1975, page 102. ! ORIGINAL VERSION--NOVEMBER 1975. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE PARPPF(P,Gamma,Ppf) REAL(kind=wp),intent(in) :: P REAL(kind=wp),intent(in) :: Gamma REAL(kind=wp),intent(out) :: Ppf !--------------------------------------------------------------------- ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( P<0.0_wp .OR. P>=1.0_wp ) THEN WRITE (G_IO,99001) 99001 FORMAT (' ***** FATAL ERROR--The first input argument to PARPPF(3f) is outside the allowable (0,1) interval *****') WRITE (G_IO,99003) P Ppf = 0.0_wp RETURN ELSEIF ( Gamma<=0.0_wp ) THEN WRITE (G_IO,99002) 99002 FORMAT (' ***** FATAL ERROR--The second input argument to PARPPF(3f) is non-positive *****') WRITE (G_IO,99003) Gamma Ppf = 0.0_wp RETURN ELSE Ppf = (1.0_wp-P)**(-1.0_wp/Gamma) ENDIF 99003 FORMAT (' ','***** The value of the argument is ',E15.8,' *****') END SUBROUTINE PARPPF !> !!##NAME !! parran(3f) - [M_datapac:RANDOM] generate Pareto random numbers !! !!##SYNOPSIS !! !! SUBROUTINE PARRAN(N,Gamma,Iseed,X) !! !! INTEGER :: N !! REAL(kind=wp) :: Gamma !! INTEGER :: Iseed !! REAL(kind=wp) :: X(:) !! !!##DESCRIPTION !! PARRAN(3f) generates a random sample of size N from the Pareto !! distribution with tail length parameter value = GAMMA. !! !! The prototype Pareto distribution used herein is defined for all X !! greater than or equal to 1, and has the probability density function !! !! f(X) = GAMMA / (X**(GAMMA+1)) !! !!##INPUT ARGUMENTS !! !! N The desired integer number of random numbers to be generated. !! !! GAMMA The value of the tail length parameter. GAMMA should be !! positive. !! !! ISEED An integer seed value. Should be set to a non-negative value !! to start a new sequence of values. Will be set to -1 on return !! to indicate the next call should continue the current random !! sequence walk. !! !!##OUTPUT ARGUMENTS !! !! X A vector (of dimension at least N) into which the generated !! random sample from the Pareto distribution will be placed. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_parran !! use m_datapac, only : parran, plott, label, plotxt, sort !! implicit none !! integer,parameter :: n=4000 !! real :: x(n) !! integer :: iseed !! real :: gamma !! call label('parran') !! gamma=3.4 !! iseed=12345 !! call parran(n,gamma,iseed,x) !! call plotxt(x,n) !! call sort(x,n,x) ! sort to show distribution !! call plotxt(x,n) !! end program demo_parran !! !! Results: !! !! !! THE FOLLOWING IS A PLOT OF X(I) (VERTICALLY) VERSUS I (HORIZONTALLY !! I-----------I-----------I-----------I-----------I !! 0.1956372E+02 - X !! 0.1879024E+02 I !! 0.1801675E+02 I !! 0.1724326E+02 I !! 0.1646978E+02 I !! 0.1569629E+02 I !! 0.1492280E+02 - !! 0.1414931E+02 I !! 0.1337583E+02 I !! 0.1260234E+02 I !! 0.1182885E+02 I !! 0.1105537E+02 I X !! 0.1028188E+02 - !! 0.9508391E+01 I !! 0.8734904E+01 I X !! 0.7961417E+01 I X !! 0.7187930E+01 I !! 0.6414443E+01 I X X X XX !! 0.5640956E+01 - X XX XX !! 0.4867469E+01 I X X X X XX X X X X !! 0.4093982E+01 I X X X XX X XX X X X X X !! 0.3320494E+01 I X X XX XXXXXX X XXX XXX XXX XXXXX XXX XXX X XXXXX !! 0.2547007E+01 I XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX !! 0.1773520E+01 I XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX !! 0.1000033E+01 - XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX !! I-----------I-----------I-----------I-----------I !! 0.1000E+01 0.1001E+04 0.2000E+04 0.3000E+04 0.4000E+04 !! !! THE FOLLOWING IS A PLOT OF X(I) (VERTICALLY) VERSUS I (HORIZONTALLY !! I-----------I-----------I-----------I-----------I !! 0.1956372E+02 - X !! 0.1879024E+02 I !! 0.1801675E+02 I !! 0.1724326E+02 I !! 0.1646978E+02 I !! 0.1569629E+02 I !! 0.1492280E+02 - !! 0.1414931E+02 I !! 0.1337583E+02 I !! 0.1260234E+02 I !! 0.1182885E+02 I !! 0.1105537E+02 I X !! 0.1028188E+02 - !! 0.9508391E+01 I !! 0.8734904E+01 I X !! 0.7961417E+01 I X !! 0.7187930E+01 I !! 0.6414443E+01 I X !! 0.5640956E+01 - X !! 0.4867469E+01 I X !! 0.4093982E+01 I XX !! 0.3320494E+01 I X !! 0.2547007E+01 I XXXX !! 0.1773520E+01 I XXXXXXXXXXXXX !! 0.1000033E+01 - XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX !! I-----------I-----------I-----------I-----------I !! 0.1000E+01 0.1001E+04 0.2000E+04 0.3000E+04 0.4000E+04 !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !! !!##REFERENCES !! * Tocher, The Art of Simulation, 1963, pages 14-15. !! * Hammersley and Handscomb, Monte Carlo Methods, 1964, page 36. !! * Johnson and Kotz, Continuous Univariate Distributions--1, 1970, !! pages 233-249. !! * Hastings and Peacock, Statistical Distributions--A Handbook for !! Students and Practitioners, 1975, page 104. ! VERSION NUMBER--82.6 ! ORIGINAL VERSION--NOVEMBER 1975. ! UPDATED --DECEMBER 1981. ! UPDATED --MAY 1982. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE PARRAN(N,Gamma,Iseed,X) INTEGER :: N REAL(kind=wp) :: Gamma INTEGER :: Iseed REAL(kind=wp) :: X(:) INTEGER :: i !--------------------------------------------------------------------- ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( N<1 ) THEN WRITE (G_IO,99001) 99001 FORMAT (' ***** FATAL ERROR--The first input argument to PARRAN(3f) is non-positive *****') WRITE (G_IO,99002) N 99002 FORMAT (' ','***** The value of the argument is ',I0,' *****') RETURN ELSEIF ( Gamma<=0.0_wp ) THEN WRITE (G_IO,99003) 99003 FORMAT (' ***** FATAL ERROR--The second input argument to PARRAN(3f) subroutine is non-positive *****') WRITE (G_IO,99004) Gamma 99004 FORMAT (' ***** The value of the argument is ',E15.8,' *****') RETURN ELSE ! ! GENERATE N UNIFORM (0,1) RANDOM NUMBERS; ! CALL UNIRAN(N,Iseed,X) ! ! GENERATE N PARETO DISTRIBUTION RANDOM NUMBERS ! USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD. ! DO i = 1 , N X(i) = (1.0_wp-X(i))**(-1.0_wp/Gamma) ENDDO ENDIF END SUBROUTINE PARRAN !> !!##NAME !! plot10(3f) - [M_datapac:GENERIC_LINE_PLOT] generate a line printer !! plot with special plot characters !! !!##SYNOPSIS !! !! SUBROUTINE PLOT10( & !! & Y,X,Char,N,Ymin,Ymax,Xmin,Xmax,D,Dmin,Dmax,Yaxid,Xaxid,Plchid) !! !! REAL(kind=wp) :: Y(:) !! REAL(kind=wp) :: X(:) !! REAL(kind=wp) :: Char(:) !! INTEGER :: N !! REAL(kind=wp) :: Ymin, Ymax !! REAL(kind=wp) :: Xmin, Xmax !! REAL(kind=wp) :: D(:) !! REAL(kind=wp) :: Dmin, Dmax !! REAL(kind=wp) :: Yaxid, Xaxid !! REAL(kind=wp) :: Plchid !! !!##DESCRIPTION !! PLOT10(3f) yields a one-page printer plot of y(i) versus x(i): !! !! 1. with special plot characters; !! 2. with the vertical (y) axis min and max !! and the horizontal (x) axis min and max !! values specified by the data analyst; !! 3. with only those points (x(i),y(i)) plotted !! for which the corresponding value of d(i) !! is between the specified values of dmin and dmax; and !! 4. with hollerith labels (at most 6 characters) !! for the vertical axis variable, !! the horizontal axis variable, and !! the plotting character variable !! also being provided by the data analyst. !! !! The 'special plotting character' capability allows the data analyst !! to incorporate information from a third variable (aside from y and x) !! into the plot. !! !! The plot character used at the i-th plotting position (that is, !! at the coordinate (x(i),y(i))) will be !! !! 1 if char(i) is between 0.5 and 1.5 !! 2 if char(i) is between 1.5 and 2.5 !! . !! . !! . !! 9 if char(i) is between 8.5 and 9.5 !! 0 if char(i) is between 9.5 and 10.5 !! a if char(i) is between 10.5 and 11.5 !! b if char(i) is between 11.5 and 12.5 !! c if char(i) is between 12.5 and 13.5 !! . !! . !! . !! w if char(i) is between 32.5 and 33.5 !! x if char(i) is between 33.5 and 34.5 !! y if char(i) is between 34.5 and 35.5 !! z if char(i) is between 35.5 and 36.5 !! x if char(i) is any value outside the range 0.5 to 36.5. !! !! The use of the ymin, ymax, xmin, and xmax specifications allows the !! data analyst to control fully the plot axis limits, so as, for example, !! to zero-in on an interesting sub-region of a previous plot. !! !! The use of the subset definition vector d gives the data analyst !! the capability of plotting subsets of the data, where the subset is !! defined by values in the vector d. !! !! The use of hollerith identifying labels allows the data analyst to !! automatically have the plots labeled. this is particularly useful !! in a large analysis when many plots are being generated. !! !! Values in the vertical axis vector (Y) which are smaller than YMIN !! or larger than YMAX, or values in the horizontal axis vector (X) !! which are smaller than XMIN or larger than XMAX will not be plotted. !! !! For a given dummy index I, if D(I) is smaller than DMIN or larger than !! DMAX, then the corresponding point (X(I),Y(I)) will not be plotted. !! !! Values in the vertical axis vector (Y), the horizontal axis vector !! (X), or the plot character vector (CHAR) which are equal to or in !! excess of 10.0**10 will not be plotted. !! !! This convention greatly simplifies the problem of plotting when !! some elements in the vector Y (or X, or CHAR) are 'missing data', !! or when we purposely want to ignore certain elements in the vector Y !! (or X, or CHAR) for plotting purposes (that is, we do not want certain !! elements in Y (or X, or CHAR) to be plotted). !! !! to cause specific elements in Y (or X, or CHAR) to be ignored, !! we replace the elements beforehand (by, for example, use of the !! REPLAC(3f) subroutine) by some large value (like, say, 10.0**10) !! and they will subsequently be ignored in the PLOTC(3f) subroutine. !! !!##INPUT ARGUMENTS !! !! Y The vector of (unsorted or sorted) observations to be !! plotted vertically. !! X The vector of (unsorted or sorted) observations to be plotted !! horizontally. !! CHAR The vector of observations which control the value of each !! individual plot character. !! N The integer number of observations in the vector y. !! There is no restriction on the maximum value of n for this !! subroutine. !! YMIN The value of desired minimum for the vertical axis. !! YMAX The value of desired maximum for the vertical axis. !! XMIN The value of desired minimum for the horizontal axis. !! XMAX The value of desired maximum for the horizontal axis. !! D The vector which 'defines' the various possible subsets. !! DMIN The value which defines the lower bound (inclusively) of !! The particular subset of interest to be plotted. !! DMAX The value which defines the upper bound (inclusively) of !! The particular subset of interest to be plotted. !! YAXID The hollerith value (at most 6 characters) of the desired !! label for the vertical axis variable. !! XAXID The hollerith value (at most 6 characters) of the desired !! label for the horizontal axis variable. !! PLCHID The hollerith value (at most 6 characters) of the desired !! label for the plotting character variable. !! !!##OUTPUT !! !! A one-page printer plot of Y(I) versus X(I), with special plot !! characters, with specified axis limits, for only of a specified subset !! of the data, and with specified labels. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_plot10 !! use M_datapac, only : plot10 !! implicit none !! ! call plot10(x,y) !! end program demo_plot10 !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !! !!##REFERENCES !! * Filliben, 'Statistical Analysis of Interlab Fatigue Time Data', !! Unpublished Manuscript (available from Author) Presented at the !! 'Computer-Assisted Data Analysis' session at the National Meeting of the !! American Statistical Association, New York City, December 27-30, 1973. ! ORIGINAL VERSION--JANUARY 1974. ! UPDATED --OCTOBER 1975. ! UPDATED --NOVEMBER 1975. ! UPDATED --FEBRUARY 1976. ! UPDATED --FEBRUARY 1977. ! UPDATED --JUNE 1977. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE PLOT10(Y,X,Char,N,Ymin,Ymax,Xmin,Xmax,D,Dmin,Dmax,Yaxid,Xaxid,Plchid) REAL(kind=wp) :: Y(:) REAL(kind=wp) :: X(:) REAL(kind=wp) :: Char(:) INTEGER :: N REAL(kind=wp) :: Ymin, Ymax REAL(kind=wp) :: Xmin, Xmax REAL(kind=wp) :: D(:) REAL(kind=wp) :: Dmin, Dmax REAL(kind=wp) :: Yaxid, Xaxid REAL(kind=wp) :: Plchid REAL(kind=wp) :: aim1, cutoff, hold, ratiox, ratioy, x25, x75, xmid, ylable INTEGER :: i, iarg, iflag, ip2, j, k, mx, my, n2 CHARACTER(len=4) :: IGRaph CHARACTER(len=4) :: iplotc CHARACTER(len=4) :: sbnam1 , sbnam2 CHARACTER(len=4) :: alph11 , alph12 , alph21 , alph22 , alph31 , alph32 CHARACTER(len=4) :: alph41 , alph42 , alph91 , alph92 CHARACTER(len=4) :: blank , hyphen , alphai , alphax CHARACTER(len=4) :: alpham , alphaa , alphad , alphan , equal ! DIMENSION ylable(11) DIMENSION iplotc(37) COMMON /BLOCK1/ IGRaph(55,130) ! DATA sbnam1 , sbnam2/'PLOT' , '10 '/ DATA alph11 , alph12/'FIRS' , 'T '/ DATA alph21 , alph22/'SECO' , 'ND '/ DATA alph31 , alph32/'THIR' , 'D '/ DATA alph41 , alph42/'FOUR' , 'TH '/ DATA alph91 , alph92/'FIFT' , 'H '/ DATA blank , hyphen , alphai , alphax/' ' , '-' , 'I' , 'X'/ DATA alpham , alphaa , alphad , alphan , equal/'M' , 'A' , 'D' , & & 'N' , '='/ DATA iplotc(1) , iplotc(2) , iplotc(3) , iplotc(4) , iplotc(5) , & & iplotc(6) , iplotc(7) , iplotc(8) , iplotc(9) , iplotc(10) , & & iplotc(11) , iplotc(12) , iplotc(13) , iplotc(14) , & & iplotc(15) , iplotc(16) , iplotc(17) , iplotc(18) , & & iplotc(19) , iplotc(20) , iplotc(21) , iplotc(22) , & & iplotc(23) , iplotc(24) , iplotc(25) , iplotc(26) , & & iplotc(27) , iplotc(28) , iplotc(29) , iplotc(30) , & & iplotc(31) , iplotc(32) , iplotc(33) , iplotc(34) , & & iplotc(35) , iplotc(36) , iplotc(37)/'1' , '2' , '3' , '4' , & & '5' , '6' , '7' , '8' , '9' , '0' , 'A' , 'B' , 'C' , 'D' , & & 'E' , 'F' , 'G' , 'H' , 'I' , 'J' , 'K' , 'L' , 'M' , 'N' , & & 'O' , 'P' , 'Q' , 'R' , 'S' , 'T' , 'U' , 'V' , 'W' , 'X' , & & 'Y' , 'Z' , 'X'/ ! cutoff = (10.0_wp**10) - 1000.0_wp ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! WRITE (G_IO,99001) 99001 FORMAT ('1') IF ( N<1 ) THEN WRITE (G_IO,99016) WRITE (G_IO,99017) WRITE (G_IO,99019) alph41 , alph42 , sbnam1 , sbnam2 WRITE (G_IO,99002) N 99002 FORMAT (' ','IS NON-NEGATIVE (WITH VALUE = ',I0,')') WRITE (G_IO,99016) RETURN ELSE IF ( N==1 ) THEN WRITE (G_IO,99016) WRITE (G_IO,99017) WRITE (G_IO,99019) alph41 , alph42 , sbnam1 , sbnam2 WRITE (G_IO,99003) N 99003 FORMAT (' ','HAS THE VALUE 1') WRITE (G_IO,99016) RETURN ELSE ! hold = Y(1) DO i = 2 , N IF ( Y(i)/=hold ) GOTO 50 ENDDO WRITE (G_IO,99016) WRITE (G_IO,99017) WRITE (G_IO,99019) alph11 , alph12 , sbnam1 , sbnam2 WRITE (G_IO,99020) hold WRITE (G_IO,99016) RETURN ENDIF 50 hold = X(1) DO i = 2 , N IF ( X(i)/=hold ) GOTO 100 ENDDO WRITE (G_IO,99016) WRITE (G_IO,99017) WRITE (G_IO,99019) alph21 , alph22 , sbnam1 , sbnam2 WRITE (G_IO,99020) hold WRITE (G_IO,99016) RETURN ENDIF 100 hold = Char(1) DO i = 2 , N IF ( Char(i)/=hold ) GOTO 200 ENDDO WRITE (G_IO,99016) WRITE (G_IO,99018) WRITE (G_IO,99019) alph31 , alph32 , sbnam1 , sbnam2 WRITE (G_IO,99020) hold WRITE (G_IO,99016) 200 hold = D(1) DO i = 2 , N IF ( D(i)/=hold ) GOTO 300 ENDDO WRITE (G_IO,99016) WRITE (G_IO,99018) WRITE (G_IO,99019) alph91 , alph92 , sbnam1 , sbnam2 WRITE (G_IO,99020) hold WRITE (G_IO,99016) ! 300 DO i = 1 , N IF ( Y(i)<cutoff ) GOTO 400 ENDDO WRITE (G_IO,99016) WRITE (G_IO,99017) WRITE (G_IO,99019) alph11 , alph12 , sbnam1 , sbnam2 WRITE (G_IO,99021) WRITE (G_IO,99022) cutoff WRITE (G_IO,99016) RETURN 400 DO i = 1 , N IF ( X(i)<cutoff ) GOTO 500 ENDDO WRITE (G_IO,99016) WRITE (G_IO,99017) WRITE (G_IO,99019) alph21 , alph22 , sbnam1 , sbnam2 WRITE (G_IO,99021) WRITE (G_IO,99022) cutoff WRITE (G_IO,99016) RETURN 500 DO i = 1 , N IF ( Char(i)<cutoff ) GOTO 600 ENDDO WRITE (G_IO,99016) WRITE (G_IO,99017) WRITE (G_IO,99019) alph31 , alph32 , sbnam1 , sbnam2 WRITE (G_IO,99021) WRITE (G_IO,99022) cutoff WRITE (G_IO,99016) RETURN 600 DO i = 1 , N IF ( D(i)<cutoff ) GOTO 700 ENDDO WRITE (G_IO,99016) WRITE (G_IO,99017) WRITE (G_IO,99019) alph91 , alph92 , sbnam1 , sbnam2 WRITE (G_IO,99021) WRITE (G_IO,99022) cutoff WRITE (G_IO,99016) RETURN ! 700 DO i = 1 , N IF ( Dmin<D(i) .AND. D(i)<Dmax ) GOTO 800 ENDDO WRITE (G_IO,99016) WRITE (G_IO,99017) WRITE (G_IO,99019) alph91 , alph92 , sbnam1 , sbnam2 WRITE (G_IO,99004) 99004 FORMAT (' ','HAS ALL ELEMENTS OUTSIDE THE INTERVAL') WRITE (G_IO,99005) Dmin , Dmax 99005 FORMAT (' ','(',E15.8,',',E15.8,')',' AS DEFINED BY') WRITE (G_IO,99006) 99006 FORMAT (' ','THE TENTH AND ELEVENTH INPUT ARGUMENTS.') WRITE (G_IO,99016) RETURN ! 800 n2 = 0 DO i = 1 , N IF ( Y(i)<cutoff .AND. X(i)<cutoff .AND. Char(i)<cutoff .AND. D(i)<cutoff ) THEN IF ( Dmin<D(i) .AND. D(i)<Dmax ) n2 = n2 + 1 IF ( n2>=2 ) GOTO 900 ENDIF ENDDO WRITE (G_IO,99016) WRITE (G_IO,99017) WRITE (G_IO,99007) alph11 , alph12 , alph21 , alph22 , alph31 , alph32 , alph91 , alph92 99007 FORMAT (' ','THE ',A4,A4,', ',A4,A4,', ',A4,A4,', AND ',A4,A4) WRITE (G_IO,99008) sbnam1 , sbnam2 99008 FORMAT (' ','INPUT ARGUMENTS TO THE ',A4,A4,' SUBROUTINE') WRITE (G_IO,99009) 99009 FORMAT (' ','ARE SUCH THAT TOO MANY POINTS HAVE BEEN EXCLUDED FROM THE PLOT.') WRITE (G_IO,99010) n2 99010 FORMAT (' ','ONLY ',I0,' POINTS ARE LEFT TO BE PLOTTED.') WRITE (G_IO,99016) RETURN ! !-----START POINT----------------------------------------------------- ! ! DETERMINE THE VALUES TO BE LISTED ON THE LEFT VERTICAL AXIS ! 900 DO i = 1 , 9 aim1 = i - 1 ylable(i) = Ymax - (aim1/8.0)*(Ymax-Ymin) ENDDO ! ! DETERMINE THE VALUES TO BE LISTED ON THE BOTTOM HORIZONTAL AXIS ! DETERMINE XMID, X25 (=THE 25% POINT), AND ! X75 (=THE 75% POINT) ! xmid = (Xmin+Xmax)/2.0_wp x25 = 0.75_wp*Xmin + 0.25_wp*Xmax x75 = 0.25_wp*Xmin + 0.75_wp*Xmax ! ! BLANK OUT THE GRAPH ! DO i = 1 , 45 DO j = 1 , 109 IGRaph(i,j) = blank ENDDO ENDDO ! ! PRODUCE THE VERTICAL AXES ! DO i = 3 , 43 IGRaph(i,5) = alphai IGRaph(i,109) = alphai ENDDO DO i = 3 , 43 , 5 IGRaph(i,5) = hyphen IGRaph(i,109) = hyphen ENDDO IGRaph(3,1) = equal IGRaph(3,2) = alpham IGRaph(3,3) = alphaa IGRaph(3,4) = alphax IGRaph(23,1) = equal IGRaph(23,2) = alpham IGRaph(23,3) = alphai IGRaph(23,4) = alphad IGRaph(43,1) = equal IGRaph(43,2) = alpham IGRaph(43,3) = alphai IGRaph(43,4) = alphan ! ! PRODUCE THE HORIZONTAL AXES ! DO j = 7 , 107 IGRaph(1,j) = hyphen IGRaph(45,j) = hyphen ENDDO DO j = 7 , 107 , 25 IGRaph(1,j) = alphai IGRaph(45,j) = alphai ENDDO DO j = 20 , 107 , 25 IGRaph(1,j) = alphai IGRaph(45,j) = alphai ENDDO ! ! DETERMINE THE (X,Y) PLOT POSITIONS ! ratioy = 40.0_wp/(Ymax-Ymin) ratiox = 100.0_wp/(Xmax-Xmin) DO i = 1 , N IF ( Y(i)<cutoff ) THEN IF ( X(i)<cutoff ) THEN IF ( Char(i)<cutoff ) THEN IF ( Y(i)>=Ymin .AND. Y(i)<=Ymax ) THEN IF ( X(i)>=Xmin .AND. X(i)<=Xmax ) THEN IF ( D(i)>=Dmin ) THEN IF ( D(i)<=Dmax ) THEN mx = ratiox*(X(i)-Xmin) + 0.5_wp mx = mx + 7 my = ratioy*(Y(i)-Ymin) + 0.5_wp my = 43 - my iarg = 37 IF ( 0.5_wp<Char(i) .AND. Char(i)<36.5_wp ) iarg = Char(i) + 0.5_wp IGRaph(my,mx) = iplotc(iarg) ENDIF ENDIF ENDIF ENDIF ENDIF ENDIF ENDIF ENDDO ! ! WRITE OUT THE GRAPH ! DO i = 1 , 45 ip2 = i + 2 iflag = ip2 - (ip2/5)*5 k = ip2/5 IF ( iflag/=0 ) WRITE (G_IO,99011) (IGRaph(i,j),j=1,109) ! 99011 FORMAT (' ',20X,109A1) IF ( iflag==0 ) WRITE (G_IO,99012) ylable(k) , (IGRaph(i,j),j=1,109) 99012 FORMAT (' ',F20.7,109A1) ENDDO WRITE (G_IO,99013) Xmin , x25 , xmid , x75 , Xmax 99013 FORMAT (' ',14X,F20.7,5X,F20.7,5X,F20.7,5X,F20.7,1X,F20.7) WRITE (G_IO,99014) Yaxid , Xaxid , Plchid 99014 FORMAT (' ',9X,A4,A4,' (VERTICAL AXIS) VERSUS ',A4,A4,' (HORIZONTAL AXIS) ',20X,'THE PLOTTING CHARACTER IS ',A4,A4) WRITE (G_IO,99015) N 99015 FORMAT (' ',83X,'THE NUMBER OF OBSERVATIONS PLOTTED IS ',I0) ! 99016 FORMAT (' ','**********************************************************************') 99017 FORMAT (' ',' FATAL ERROR ') 99018 FORMAT (' ',' NON-FATAL DIAGNOSTIC ') 99019 FORMAT (' ','THE ',A4,A4,' INPUT ARGUMENT TO THE ',A4,A4,' SUBROUTINE') 99020 FORMAT (' ','HAS ALL ELEMENTS = ',E15.8) 99021 FORMAT (' ','HAS ALL ELEMENTS IN EXCESS OF THE CUTOFF') 99022 FORMAT (' ','VALUE OF ',E15.8) ! END SUBROUTINE PLOT10 !> !!##NAME !! plot6(3f) - [M_datapac:GENERIC_LINE_PLOT] generate a line printer plot !! !!##SYNOPSIS !! !! SUBROUTINE PLOT6(Y,X,N,Ymin,Ymax,Xmin,Xmax) !! !!##DESCRIPTION !! PLOT6(3f) yields a one-page printer plot of Y(i) versus X(i): !! !! 1. with the vertical (Y) axis min and max !! and the horizontal (X) axis min and max !! values specified by the data analyst. !! !! the use of the YMIN, YMAX, XMIN, and XMAX specifications allows the !! data analyst to control fully the plot axis limits, so as, for example, !! to zero-in on an interesting sub-region of a previous plot. !! !!##INPUT ARGUMENTS !! Y the vector of (unsorted or sorted) observations to be plotted !! vertically. !! !! X the vector of (unsorted or sorted) observations to be plotted !! horizontally. !! !! N the integer number of observations in the vector y. there is !! no restriction on the maximum value of n for this subroutine. !! !! YMIN the value of desired minimum for the vertical axis. !! YMAX the value of desired maximum for the vertical axis. !! XMIN the value of desired minimum for the horizontal axis. !! XMAX the value of desired maximum for the horizontal axis. !! !!##OUTPUT !! A one-page printer plot of y(i) versus x(i), with specified axis limits. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_plot6 !! use M_datapac, only : plot6 !! implicit none !! ! call plot6(x,y) !! end program demo_plot6 !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 ! ORIGINAL VERSION--JUNE 1972. ! UPDATED --OCTOBER 1975. ! UPDATED --NOVEMBER 1975. ! UPDATED --FEBRUARY 1976. ! UPDATED --FEBRUARY 1977. ! UPDATED --JUNE 1977. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE PLOT6(Y,X,N,Ymin,Ymax,Xmin,Xmax) IMPLICIT NONE REAL(kind=wp) :: aim1 , cutoff , hold , ratiox , ratioy , X , x25 , x75 , Xmax , xmid , Xmin , Y , ylable , Ymax , Ymin INTEGER i , iflag , ip2 , j , k , mx , my , N , n2 ! ! COMMENT--VALUES IN THE VERTICAL AXIS VECTOR (Y) ! WHICH ARE SMALLER THAN YMIN OR LARGER THAN YMAX, ! OR VALUES IN THE HORIZONTAL AXIS VECTOR (X) ! WHICH ARE SMALLER THAN XMIN OR LARGER THAN XMAX ! WILL NOT BE PLOTTED. ! --VALUES IN THE VERTICAL AXIS VECTOR (Y) ! OR THE HORIZONTAL AXIS VECTOR (X) WHICH ARE ! EQUAL TO OR IN EXCESS OF 10.0**10 WILL NOT BE ! PLOTTED. ! THIS CONVENTION GREATLY SIMPLIFIES THE PROBLEM ! OF PLOTTING WHEN SOME ELEMENTS IN THE VECTOR Y ! (OR X) ARE 'MISSING DATA', OR WHEN WE PURPOSELY ! WANT TO IGNORE CERTAIN ELEMENTS IN THE VECTOR Y ! (OR X) FOR PLOTTING PURPOSES (THAT IS, WE DO NOT ! WANT CERTAIN ELEMENTS IN Y (OR X) TO BE PLOTTED). ! TO CAUSE SPECIFIC ELEMENTS IN Y (OR X) TO BE ! IGNORED, WE REPLACE THE ELEMENTS BEFOREHAND ! (BY, FOR EXAMPLE, USE OF THE REPLAC SUBROUTINE) ! BY SOME LARGE VALUE (LIKE, SAY, 10.0**10) AND ! THEY WILL SUBSEQUENTLY BE IGNORED IN THE PLOT ! SUBROUTINE. ! !--------------------------------------------------------------------- ! CHARACTER(len=4) :: IGRaph CHARACTER(len=4) :: sbnam1 , sbnam2 CHARACTER(len=4) :: alph11 , alph12 , alph21 , alph22 , alph31 , alph32 CHARACTER(len=4) :: blank , hyphen , alphai , alphax CHARACTER(len=4) :: alpham , alphaa , alphad , alphan , equal ! DIMENSION Y(:) DIMENSION X(:) DIMENSION ylable(11) COMMON /BLOCK1/ IGRaph(55,130) ! DATA sbnam1 , sbnam2/'PLOT' , '6 '/ DATA alph11 , alph12/'FIRS' , 'T '/ DATA alph21 , alph22/'SECO' , 'ND '/ DATA alph31 , alph32/'THIR' , 'D '/ DATA blank , hyphen , alphai , alphax/' ' , '-' , 'I' , 'X'/ DATA alpham , alphaa , alphad , alphan , equal/'M' , 'A' , 'D' , & & 'N' , '='/ ! cutoff = (10.0_wp**10) - 1000.0_wp ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! WRITE (G_IO,99001) 99001 FORMAT ('1') IF ( N<1 ) THEN WRITE (G_IO,99011) WRITE (G_IO,99012) WRITE (G_IO,99013) alph31 , alph32 , sbnam1 , sbnam2 WRITE (G_IO,99002) N 99002 FORMAT (' ','IS NON-NEGATIVE (WITH VALUE = ',I0,')') WRITE (G_IO,99011) RETURN ELSE IF ( N==1 ) THEN WRITE (G_IO,99011) WRITE (G_IO,99012) WRITE (G_IO,99013) alph31 , alph32 , sbnam1 , sbnam2 WRITE (G_IO,99003) N 99003 FORMAT (' ','HAS THE VALUE 1') WRITE (G_IO,99011) RETURN ELSE ! hold = Y(1) DO i = 2 , N IF ( Y(i)/=hold ) GOTO 50 ENDDO WRITE (G_IO,99011) WRITE (G_IO,99012) WRITE (G_IO,99013) alph11 , alph12 , sbnam1 , sbnam2 WRITE (G_IO,99014) hold WRITE (G_IO,99011) RETURN ENDIF 50 hold = X(1) DO i = 2 , N IF ( X(i)/=hold ) GOTO 100 ENDDO WRITE (G_IO,99011) WRITE (G_IO,99012) WRITE (G_IO,99013) alph21 , alph22 , sbnam1 , sbnam2 WRITE (G_IO,99014) hold WRITE (G_IO,99011) RETURN ENDIF ! 100 DO i = 1 , N IF ( Y(i)<cutoff ) GOTO 200 ENDDO WRITE (G_IO,99011) WRITE (G_IO,99012) WRITE (G_IO,99013) alph11 , alph12 , sbnam1 , sbnam2 WRITE (G_IO,99015) WRITE (G_IO,99016) cutoff WRITE (G_IO,99011) RETURN 200 DO i = 1 , N IF ( X(i)<cutoff ) GOTO 300 ENDDO WRITE (G_IO,99011) WRITE (G_IO,99012) WRITE (G_IO,99013) alph21 , alph22 , sbnam1 , sbnam2 WRITE (G_IO,99015) WRITE (G_IO,99016) cutoff WRITE (G_IO,99011) RETURN ! 300 n2 = 0 DO i = 1 , N IF ( Y(i)<cutoff .AND. X(i)<cutoff ) THEN n2 = n2 + 1 IF ( n2>=2 ) GOTO 400 ENDIF ENDDO WRITE (G_IO,99011) WRITE (G_IO,99012) WRITE (G_IO,99004) alph11 , alph12 , alph21 , alph22 99004 FORMAT (' ','THE ',A4,A4,', AND ',A4,A4) WRITE (G_IO,99005) sbnam1 , sbnam2 99005 FORMAT (' ','INPUT ARGUMENTS TO THE ',A4,A4,' SUBROUTINE') WRITE (G_IO,99006) 99006 FORMAT (' ','ARE SUCH THAT TOO MANY POINTS HAVE BEEN', & & ' EXCLUDED FROM THE PLOT.') WRITE (G_IO,99007) n2 99007 FORMAT (' ','ONLY ',I0,' POINTS ARE LEFT TO BE PLOTTED.') WRITE (G_IO,99011) RETURN ! !-----START POINT----------------------------------------------------- ! ! DETERMINE THE VALUES TO BE LISTED ON THE LEFT VERTICAL AXIS ! 400 DO i = 1 , 9 aim1 = i - 1 ylable(i) = Ymax - (aim1/8.0_wp)*(Ymax-Ymin) ENDDO ! ! DETERMINE THE VALUES TO BE LISTED ON THE BOTTOM HORIZONTAL AXIS ! DETERMINE XMID, X25 (=THE 25% POINT), AND ! X75 (=THE 75% POINT) ! xmid = (Xmin+Xmax)/2.0_wp x25 = 0.75_wp*Xmin + 0.25_wp*Xmax x75 = 0.25_wp*Xmin + 0.75_wp*Xmax ! ! BLANK OUT THE GRAPH ! DO i = 1 , 45 DO j = 1 , 109 IGRaph(i,j) = blank ENDDO ENDDO ! ! PRODUCE THE VERTICAL AXES ! DO i = 3 , 43 IGRaph(i,5) = alphai IGRaph(i,109) = alphai ENDDO DO i = 3 , 43 , 5 IGRaph(i,5) = hyphen IGRaph(i,109) = hyphen ENDDO IGRaph(3,1) = equal IGRaph(3,2) = alpham IGRaph(3,3) = alphaa IGRaph(3,4) = alphax IGRaph(23,1) = equal IGRaph(23,2) = alpham IGRaph(23,3) = alphai IGRaph(23,4) = alphad IGRaph(43,1) = equal IGRaph(43,2) = alpham IGRaph(43,3) = alphai IGRaph(43,4) = alphan ! ! PRODUCE THE HORIZONTAL AXES ! DO j = 7 , 107 IGRaph(1,j) = hyphen IGRaph(45,j) = hyphen ENDDO DO j = 7 , 107 , 25 IGRaph(1,j) = alphai IGRaph(45,j) = alphai ENDDO DO j = 20 , 107 , 25 IGRaph(1,j) = alphai IGRaph(45,j) = alphai ENDDO ! ! DETERMINE THE (X,Y) PLOT POSITIONS ! ratioy = 40.0_wp/(Ymax-Ymin) ratiox = 100.0_wp/(Xmax-Xmin) DO i = 1 , N IF ( Y(i)<cutoff ) THEN IF ( X(i)<cutoff ) THEN IF ( Y(i)>=Ymin .AND. Y(i)<=Ymax ) THEN IF ( X(i)>=Xmin .AND. X(i)<=Xmax ) THEN mx = ratiox*(X(i)-Xmin) + 0.5_wp mx = mx + 7 my = ratioy*(Y(i)-Ymin) + 0.5_wp my = 43 - my IGRaph(my,mx) = alphax ENDIF ENDIF ENDIF ENDIF ENDDO ! ! WRITE OUT THE GRAPH ! DO i = 1 , 45 ip2 = i + 2 iflag = ip2 - (ip2/5)*5 k = ip2/5 IF ( iflag/=0 ) WRITE (G_IO,99008) (IGRaph(i,j),j=1,109) ! 99008 FORMAT (' ',20X,109A1) IF ( iflag==0 ) WRITE (G_IO,99009) ylable(k) , & & (IGRaph(i,j),j=1,109) 99009 FORMAT (' ',F20.7,109A1) ENDDO WRITE (G_IO,99010) Xmin , x25 , xmid , x75 , Xmax 99010 FORMAT (' ',14X,F20.7,5X,F20.7,5X,F20.7,5X,F20.7,1X,F20.7) ! 99011 FORMAT (' ','**************************************************', & & '********************') 99012 FORMAT (' ',' FATAL ERROR ') 99013 FORMAT (' ','THE ',A4,A4,' INPUT ARGUMENT TO THE ',A4,A4, & & ' SUBROUTINE') 99014 FORMAT (' ','HAS ALL ELEMENTS = ',E15.8) 99015 FORMAT (' ','HAS ALL ELEMENTS IN EXCESS OF THE CUTOFF') 99016 FORMAT (' ','VALUE OF ',E15.8) ! END SUBROUTINE PLOT6 !> !!##NAME !! plot7(3f) - [M_datapac:GENERIC_LINE_PLOT] generate a line printer !! plot with special plot characters !! !!##SYNOPSIS !! !! SUBROUTINE PLOT7(Y,X,Char,N,Ymin,Ymax,Xmin,Xmax) !! !!##DESCRIPTION !! PLOT7(3f) yields a one-page printer plot of Y(i) versus X(i): !! !! 1. With special plot characters; and !! 2. With the vertical (y) axis min and max !! and the horizontal (x) axis min and max !! values specified by the data analyst. !! !! The 'special plotting character' capability allows the data analyst !! to incorporate information from a third variable (aside from Y and X) !! into the plot. !! !! The plot character used at the i-th plotting position (that is, !! at the coordinate (X(i),Y(i))) will be !! !! 1 if Char(i) is between 0.5 and 1.5 !! 2 if Char(i) is between 1.5 and 2.5 !! . !! . !! . !! 9 if Char(i) is between 8.5 and 9.5 !! 0 if Char(i) is between 9.5 and 10.5 !! a if Char(i) is between 10.5 and 11.5 !! b if Char(i) is between 11.5 and 12.5 !! c if Char(i) is between 12.5 and 13.5 !! . !! . !! . !! w if Char(i) is between 32.5 and 33.5 !! x if Char(i) is between 33.5 and 34.5 !! y if Char(i) is between 34.5 and 35.5 !! z if Char(i) is between 35.5 and 36.5 !! x if Char(i) is any value outside the range !! 0.5 to 36.5. !! !! The use of the YMIN, YMAX, XMIN, and XMAX specifications allows the !! data analyst to control fully the plot axis limits, so as, for example, !! to zero-in on an interesting sub-region of a previous plot. !! !!##OPTIONS !! X description of parameter !! Y description of parameter !! !!##EXAMPLES !! !! Sample program: !! !! program demo_plot7 !! use M_datapac, only : plot7 !! implicit none !! ! call plot7(x,y) !! end program demo_plot7 !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !! !!##REFERENCES !! * Filliben, 'Statistical Analysis of Interlab Fatigue Time Data', !! Unpublished Manuscript (Available from Author) Presented at the !! 'Computer-Assisted Data Analysis' Session at the National Meeting of the !! American Statistical Association, New York City, December 27-30, 1973. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE PLOT7(Y,X,Char,N,Ymin,Ymax,Xmin,Xmax) REAL(kind=wp) :: aim1, Char, cutoff, hold, ratiox, ratioy, X, x25, x75, Xmax, xmid, Xmin, Y, ylable, Ymax, Ymin INTEGER :: i, iarg, iflag, ip2, j, k, mx, my, N, n2 ! ! INPUT ARGUMENTS--Y = THE VECTOR OF ! (UNSORTED OR SORTED) OBSERVATIONS ! TO BE PLOTTED VERTICALLY. ! --X = THE VECTOR OF ! (UNSORTED OR SORTED) OBSERVATIONS ! TO BE PLOTTED HORIZONTALLY. ! --CHAR = THE VECTOR OF ! OBSERVATIONS WHICH CONTROL THE ! VALUE OF EACH INDIVIDUAL PLOT ! CHARACTER. ! --N = THE INTEGER NUMBER OF OBSERVATIONS ! IN THE VECTOR Y. ! --YMIN = THE VALUE OF ! DESIRED MINIMUM FOR THE VERTICAL AXIS. ! --YMAX = THE VALUE OF ! DESIRED MAXIMUM FOR THE VERTICAL AXIS. ! --XMIN = THE VALUE OF ! DESIRED MINIMUM FOR THE HORIZONTAL AXIS. ! --XMAX = THE VALUE OF ! DESIRED MAXIMUM FOR THE HORIZONTAL AXIS. ! OUTPUT--A ONE-page PRINTER PLOT OF Y(I) VERSUS X(I), ! WITH SPECIAL PLOT CHARACTERS, ! AND WITH SPECIFIED AXIS LIMITS. ! PRINTING--YES. ! RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE ! OF N FOR THIS SUBROUTINE. ! MODE OF INTERNAL OPERATIONS--. ! COMMENT--VALUES IN THE VERTICAL AXIS VECTOR (Y) ! WHICH ARE SMALLER THAN YMIN OR LARGER THAN YMAX, ! OR VALUES IN THE HORIZONTAL AXIS VECTOR (X) ! WHICH ARE SMALLER THAN XMIN OR LARGER THAN XMAX ! WILL NOT BE PLOTTED. ! --VALUES IN THE VERTICAL AXIS VECTOR (Y), ! THE HORIZONTAL AXIS VECTOR (X), ! OR THE PLOT CHARACTER VECTOR (CHAR) WHICH ARE ! EQUAL TO OR IN EXCESS OF 10.0**10 WILL NOT BE ! PLOTTED. ! THIS CONVENTION GREATLY SIMPLIFIES THE PROBLEM ! OF PLOTTING WHEN SOME ELEMENTS IN THE VECTOR Y ! (OR X, OR CHAR) ARE 'MISSING DATA', OR WHEN WE PURPOSELY ! WANT TO IGNORE CERTAIN ELEMENTS IN THE VECTOR Y ! (OR X, OR CHAR) FOR PLOTTING PURPOSES (THAT IS, WE DO NOT ! WANT CERTAIN ELEMENTS IN Y (OR X, OR CHAR) TO BE ! PLOTTED). ! TO CAUSE SPECIFIC ELEMENTS IN Y (OR X, OR CHAR) TO BE ! IGNORED, WE REPLACE THE ELEMENTS BEFOREHAND ! (BY, FOR EXAMPLE, USE OF THE REPLAC SUBROUTINE) ! BY SOME LARGE VALUE (LIKE, SAY, 10.0**10) AND ! THEY WILL SUBSEQUENTLY BE IGNORED IN THE PLOTC ! SUBROUTINE. ! ORIGINAL VERSION--JUNE 1972. ! UPDATED --JUNE 1974. ! UPDATED --OCTOBER 1975. ! UPDATED --NOVEMBER 1975. ! UPDATED --FEBRUARY 1976. ! UPDATED --FEBRUARY 1977. ! UPDATED --JUNE 1977. ! !--------------------------------------------------------------------- ! CHARACTER(len=4) :: IGRaph CHARACTER(len=4) :: iplotc CHARACTER(len=4) :: sbnam1 , sbnam2 CHARACTER(len=4) :: alph11 , alph12 , alph21 , alph22 , alph31 , alph32 CHARACTER(len=4) :: alph41 , alph42 CHARACTER(len=4) :: blank , hyphen , alphai , alphax CHARACTER(len=4) :: alpham , alphaa , alphad , alphan , equal ! DIMENSION Y(:) DIMENSION X(:) DIMENSION Char(:) DIMENSION ylable(11) DIMENSION iplotc(37) COMMON /BLOCK1/ IGRaph(55,130) ! DATA sbnam1 , sbnam2/'PLOT' , '7 '/ DATA alph11 , alph12/'FIRS' , 'T '/ DATA alph21 , alph22/'SECO' , 'ND '/ DATA alph31 , alph32/'THIR' , 'D '/ DATA alph41 , alph42/'FOUR' , 'TH '/ DATA blank , hyphen , alphai , alphax/' ' , '-' , 'I' , 'X'/ DATA alpham , alphaa , alphad , alphan , equal/'M' , 'A' , 'D' , & & 'N' , '='/ DATA iplotc(1) , iplotc(2) , iplotc(3) , iplotc(4) , iplotc(5) , & & iplotc(6) , iplotc(7) , iplotc(8) , iplotc(9) , iplotc(10) , & & iplotc(11) , iplotc(12) , iplotc(13) , iplotc(14) , & & iplotc(15) , iplotc(16) , iplotc(17) , iplotc(18) , & & iplotc(19) , iplotc(20) , iplotc(21) , iplotc(22) , & & iplotc(23) , iplotc(24) , iplotc(25) , iplotc(26) , & & iplotc(27) , iplotc(28) , iplotc(29) , iplotc(30) , & & iplotc(31) , iplotc(32) , iplotc(33) , iplotc(34) , & & iplotc(35) , iplotc(36) , iplotc(37)/'1' , '2' , '3' , '4' , & & '5' , '6' , '7' , '8' , '9' , '0' , 'A' , 'B' , 'C' , 'D' , & & 'E' , 'F' , 'G' , 'H' , 'I' , 'J' , 'K' , 'L' , 'M' , 'N' , & & 'O' , 'P' , 'Q' , 'R' , 'S' , 'T' , 'U' , 'V' , 'W' , 'X' , & & 'Y' , 'Z' , 'X'/ ! cutoff = (10.0_wp**10) - 1000.0_wp ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! WRITE (G_IO,99001) 99001 FORMAT ('1') IF ( N<1 ) THEN WRITE (G_IO,99012) WRITE (G_IO,99013) WRITE (G_IO,99014) alph41 , alph42 , sbnam1 , sbnam2 WRITE (G_IO,99002) N 99002 FORMAT (' ','IS NON-NEGATIVE (WITH VALUE = ',I0,')') WRITE (G_IO,99012) RETURN ELSE IF ( N==1 ) THEN WRITE (G_IO,99012) WRITE (G_IO,99013) WRITE (G_IO,99014) alph41 , alph42 , sbnam1 , sbnam2 WRITE (G_IO,99003) N 99003 FORMAT (' ','HAS THE VALUE 1') WRITE (G_IO,99012) RETURN ELSE ! hold = Y(1) DO i = 2 , N IF ( Y(i)/=hold ) GOTO 50 ENDDO WRITE (G_IO,99012) WRITE (G_IO,99013) WRITE (G_IO,99014) alph11 , alph12 , sbnam1 , sbnam2 WRITE (G_IO,99015) hold WRITE (G_IO,99012) RETURN ENDIF 50 hold = X(1) DO i = 2 , N IF ( X(i)/=hold ) GOTO 100 ENDDO WRITE (G_IO,99012) WRITE (G_IO,99013) WRITE (G_IO,99014) alph21 , alph22 , sbnam1 , sbnam2 WRITE (G_IO,99015) hold WRITE (G_IO,99012) RETURN ENDIF 100 hold = Char(1) DO i = 2 , N IF ( Char(i)/=hold ) GOTO 200 ENDDO WRITE (G_IO,99012) WRITE (G_IO,99004) 99004 FORMAT (' ',' NON-FATAL DIAGNOSTIC ') WRITE (G_IO,99014) alph31 , alph32 , sbnam1 , sbnam2 WRITE (G_IO,99015) hold WRITE (G_IO,99012) ! 200 DO i = 1 , N IF ( Y(i)<cutoff ) GOTO 300 ENDDO WRITE (G_IO,99012) WRITE (G_IO,99013) WRITE (G_IO,99014) alph11 , alph12 , sbnam1 , sbnam2 WRITE (G_IO,99016) WRITE (G_IO,99017) cutoff WRITE (G_IO,99012) RETURN 300 DO i = 1 , N IF ( X(i)<cutoff ) GOTO 400 ENDDO WRITE (G_IO,99012) WRITE (G_IO,99013) WRITE (G_IO,99014) alph21 , alph22 , sbnam1 , sbnam2 WRITE (G_IO,99016) WRITE (G_IO,99017) cutoff WRITE (G_IO,99012) RETURN 400 DO i = 1 , N IF ( Char(i)<cutoff ) GOTO 500 ENDDO WRITE (G_IO,99012) WRITE (G_IO,99013) WRITE (G_IO,99014) alph31 , alph32 , sbnam1 , sbnam2 WRITE (G_IO,99016) WRITE (G_IO,99017) cutoff WRITE (G_IO,99012) RETURN ! 500 n2 = 0 DO i = 1 , N IF ( Y(i)<cutoff .AND. X(i)<cutoff .AND. Char(i)<cutoff ) THEN n2 = n2 + 1 IF ( n2>=2 ) GOTO 600 ENDIF ENDDO WRITE (G_IO,99012) WRITE (G_IO,99013) WRITE (G_IO,99005) alph11 , alph12 , alph21 , alph22 , alph31 , & & alph32 99005 FORMAT (' ','THE ',A4,A4,', ',A4,A4,', AND ',A4,A4) WRITE (G_IO,99006) sbnam1 , sbnam2 99006 FORMAT (' ','INPUT ARGUMENTS TO THE ',A4,A4,' SUBROUTINE') WRITE (G_IO,99007) 99007 FORMAT (' ','ARE SUCH THAT TOO MANY POINTS HAVE BEEN', & & ' EXCLUDED FROM THE PLOT.') WRITE (G_IO,99008) n2 99008 FORMAT (' ','ONLY ',I0,' POINTS ARE LEFT TO BE PLOTTED.') WRITE (G_IO,99012) RETURN ! !-----START POINT----------------------------------------------------- ! ! DETERMINE THE VALUES TO BE LISTED ON THE LEFT VERTICAL AXIS ! 600 DO i = 1 , 9 aim1 = i - 1 ylable(i) = Ymax - (aim1/8.0_wp)*(Ymax-Ymin) ENDDO ! ! DETERMINE THE VALUES TO BE LISTED ON THE BOTTOM HORIZONTAL AXIS ! DETERMINE XMID, X25 (=THE 25% POINT), AND ! X75 (=THE 75% POINT) ! xmid = (Xmin+Xmax)/2.0_wp x25 = 0.75_wp*Xmin + 0.25_wp*Xmax x75 = 0.25_wp*Xmin + 0.75_wp*Xmax ! ! BLANK OUT THE GRAPH ! DO i = 1 , 45 DO j = 1 , 109 IGRaph(i,j) = blank ENDDO ENDDO ! ! PRODUCE THE VERTICAL AXES ! DO i = 3 , 43 IGRaph(i,5) = alphai IGRaph(i,109) = alphai ENDDO DO i = 3 , 43 , 5 IGRaph(i,5) = hyphen IGRaph(i,109) = hyphen ENDDO IGRaph(3,1) = equal IGRaph(3,2) = alpham IGRaph(3,3) = alphaa IGRaph(3,4) = alphax IGRaph(23,1) = equal IGRaph(23,2) = alpham IGRaph(23,3) = alphai IGRaph(23,4) = alphad IGRaph(43,1) = equal IGRaph(43,2) = alpham IGRaph(43,3) = alphai IGRaph(43,4) = alphan ! ! PRODUCE THE HORIZONTAL AXES ! DO j = 7 , 107 IGRaph(1,j) = hyphen IGRaph(45,j) = hyphen ENDDO DO j = 7 , 107 , 25 IGRaph(1,j) = alphai IGRaph(45,j) = alphai ENDDO DO j = 20 , 107 , 25 IGRaph(1,j) = alphai IGRaph(45,j) = alphai ENDDO ! ! DETERMINE THE (X,Y) PLOT POSITIONS ! ratioy = 40.0_wp/(Ymax-Ymin) ratiox = 100.0_wp/(Xmax-Xmin) DO i = 1 , N IF ( Y(i)<cutoff ) THEN IF ( X(i)<cutoff ) THEN IF ( Char(i)<cutoff ) THEN IF ( Y(i)>=Ymin .AND. Y(i)<=Ymax ) THEN IF ( X(i)>=Xmin .AND. X(i)<=Xmax ) THEN mx = ratiox*(X(i)-Xmin) + 0.5_wp mx = mx + 7 my = ratioy*(Y(i)-Ymin) + 0.5_wp my = 43 - my iarg = 37 IF ( 0.5_wp<Char(i) .AND. Char(i)<36.5_wp ) & & iarg = Char(i) + 0.5_wp IGRaph(my,mx) = iplotc(iarg) ENDIF ENDIF ENDIF ENDIF ENDIF ENDDO ! ! WRITE OUT THE GRAPH ! DO i = 1 , 45 ip2 = i + 2 iflag = ip2 - (ip2/5)*5 k = ip2/5 IF ( iflag/=0 ) WRITE (G_IO,99009) (IGRaph(i,j),j=1,109) ! 99009 FORMAT (' ',20X,109A1) IF ( iflag==0 ) WRITE (G_IO,99010) ylable(k) , & & (IGRaph(i,j),j=1,109) 99010 FORMAT (' ',F20.7,109A1) ENDDO WRITE (G_IO,99011) Xmin , x25 , xmid , x75 , Xmax 99011 FORMAT (' ',14X,F20.7,5X,F20.7,5X,F20.7,5X,F20.7,1X,F20.7) ! 99012 FORMAT (' ','**************************************************', & & '********************') 99013 FORMAT (' ',' FATAL ERROR ') 99014 FORMAT (' ','THE ',A4,A4,' INPUT ARGUMENT TO THE ',A4,A4, & & ' SUBROUTINE') 99015 FORMAT (' ','HAS ALL ELEMENTS = ',E15.8) 99016 FORMAT (' ','HAS ALL ELEMENTS IN EXCESS OF THE CUTOFF') 99017 FORMAT (' ','VALUE OF ',E15.8) ! END SUBROUTINE PLOT7 !> !!##NAME !! plot8(3f) - [M_datapac:GENERIC_LINE_PLOT] generate a line printer !! plot with special plot characters !! !!##SYNOPSIS !! !! SUBROUTINE PLOT8(Y,X,Char,N,Ymin,Ymax,Xmin,Xmax,D,Dmin,Dmax) !! !!##DESCRIPTION !! PLOT8(3f) yields a one-page printer plot of Y(i) versus X(i): !! !! 1. With special plot characters; !! 2. With the vertical (Y) axis min and max !! and the horizontal (X) axis min and max !! values specified by the data analyst; and !! 3. With only those points (X(i),Y(i)) plotted !! for which the corresponding value of D(i) !! is between the specified values of DMIN and DMAX. !! !! The 'special plotting character' capability allows the data analyst !! to incorporate information from a third variable (aside from Y and X) !! into the plot. !! !! The plot character used at the i-th plotting position (that is, !! at the coordinate (X(i),Y(i))) will be !! !! 1 if char(i) is between 0.5 and 1.5 !! 2 if char(i) is between 1.5 and 2.5 !! . !! . !! . !! 9 if char(i) is between 8.5 and 9.5 !! 0 if char(i) is between 9.5 and 10.5 !! a if char(i) is between 10.5 and 11.5 !! b if char(i) is between 11.5 and 12.5 !! c if char(i) is between 12.5 and 13.5 !! . !! . !! . !! w if char(i) is between 32.5 and 33.5 !! x if char(i) is between 33.5 and 34.5 !! y if char(i) is between 34.5 and 35.5 !! z if char(i) is between 35.5 and 36.5 !! x if char(i) is any value outside the range !! 0.5 to 36.5. !! !! The use of the YMIN, YMAX, XMIN, and XMAX specifications allows the !! data analyst to control fully the plot axis limits, so as, for example, !! to zero-in on an interesting sub-region of a previous plot. !! !! The use of the subset definition vector d gives the data analyst !! the capability of plotting subsets of the data, where the subset is !! defined by values in the vector d. !! !!##OPTIONS !! X description of parameter !! Y description of parameter !! !!##EXAMPLES !! !! Sample program: !! !! program demo_plot8 !! use M_datapac, only : plot8 !! implicit none !! ! call plot8(x,y) !! end program demo_plot8 !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !! !!##REFERENCES !! * Filliben, 'Statistical Analysis of Interlab Fatigue Time Data', !! Unpublished Manuscript (Available from Author) presented at the !! 'Computer-Assisted Data Analysis' Session at the National Meeting of the !! American Statistical Association, New York City, December 27-30, 1973. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE PLOT8(Y,X,Char,N,Ymin,Ymax,Xmin,Xmax,D,Dmin,Dmax) REAL(kind=wp) :: aim1 , Char , cutoff , D , Dmax , Dmin , hold , ratiox , & & ratioy , X , x25 , x75 , Xmax , xmid , Xmin , Y , ylable , & & Ymax , Ymin INTEGER :: i , iarg , iflag , ip2 , j , k , mx , my , N , n2 ! ! ! INPUT ARGUMENTS--Y = THE VECTOR OF ! (UNSORTED OR SORTED) OBSERVATIONS ! TO BE PLOTTED VERTICALLY. ! --X = THE VECTOR OF ! (UNSORTED OR SORTED) OBSERVATIONS ! TO BE PLOTTED HORIZONTALLY. ! --CHAR = THE VECTOR OF ! OBSERVATIONS WHICH CONTROL THE ! VALUE OF EACH INDIVIDUAL PLOT ! CHARACTER. ! --N = THE INTEGER NUMBER OF OBSERVATIONS ! IN THE VECTOR Y. ! --YMIN = THE VALUE OF ! DESIRED MINIMUM FOR THE VERTICAL AXIS. ! --YMAX = THE VALUE OF ! DESIRED MAXIMUM FOR THE VERTICAL AXIS. ! --XMIN = THE VALUE OF ! DESIRED MINIMUM FOR THE HORIZONTAL AXIS. ! --XMAX = THE VALUE OF ! DESIRED MAXIMUM FOR THE HORIZONTAL AXIS. ! --D = THE VECTOR ! WHICH 'DEFINES' THE VARIOUS ! POSSIBLE SUBSETS. ! --DMIN = THE VALUE ! WHICH DEFINES THE LOWER BOUND ! (INCLUSIVELY) OF THE PARTICULAR ! SUBSET OF INTEREST TO BE PLOTTED. ! --DMAX = THE VALUE ! WHICH DEFINES THE UPPER BOUND ! (INCLUSIVELY) OF THE PARTICULAR ! SUBSET OF INTEREST TO BE PLOTTED. ! OUTPUT--A ONE-page PRINTER PLOT OF Y(I) VERSUS X(I), ! WITH SPECIAL PLOT CHARACTERS, ! WITH SPECIFIED AXIS LIMITS, ! AND ONLY FOR A SPECIFIED SUBSET OF THE DATA. ! PRINTING--YES. ! RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE ! OF N FOR THIS SUBROUTINE. ! MODE OF INTERNAL OPERATIONS--. ! COMMENT--VALUES IN THE VERTICAL AXIS VECTOR (Y) ! WHICH ARE SMALLER THAN YMIN OR LARGER THAN YMAX, ! OR VALUES IN THE HORIZONTAL AXIS VECTOR (X) ! WHICH ARE SMALLER THAN XMIN OR LARGER THAN XMAX ! WILL NOT BE PLOTTED. ! --FOR A GIVEN DUMMY INDEX I, ! IF D(I) IS SMALLER THAN DMIN OR LARGER THAN DMAX, ! THEN THE CORRESPONDING POINT (X(I),Y(I)) ! WILL NOT BE PLOTTED. ! --VALUES IN THE VERTICAL AXIS VECTOR (Y), ! THE HORIZONTAL AXIS VECTOR (X), ! OR THE PLOT CHARACTER VECTOR (CHAR) WHICH ARE ! EQUAL TO OR IN EXCESS OF 10.0**10 WILL NOT BE ! PLOTTED. ! THIS CONVENTION GREATLY SIMPLIFIES THE PROBLEM ! OF PLOTTING WHEN SOME ELEMENTS IN THE VECTOR Y ! (OR X, OR CHAR) ARE 'MISSING DATA', OR WHEN WE PURPOSELY ! WANT TO IGNORE CERTAIN ELEMENTS IN THE VECTOR Y ! (OR X, OR CHAR) FOR PLOTTING PURPOSES (THAT IS, WE DO NOT ! WANT CERTAIN ELEMENTS IN Y (OR X, OR CHAR) TO BE ! PLOTTED). ! TO CAUSE SPECIFIC ELEMENTS IN Y (OR X, OR CHAR) TO BE ! IGNORED, WE REPLACE THE ELEMENTS BEFOREHAND ! (BY, FOR EXAMPLE, USE OF THE REPLAC SUBROUTINE) ! BY SOME LARGE VALUE (LIKE, SAY, 10.0**10) AND ! THEY WILL SUBSEQUENTLY BE IGNORED IN THE PLOTC ! SUBROUTINE. ! ORIGINAL VERSION--JANUARY 1974. ! UPDATED --OCTOBER 1975. ! UPDATED --NOVEMBER 1975. ! UPDATED --FEBRUARY 1976. ! UPDATED --FEBRUARY 1977. ! UPDATED --JUNE 1977. ! !--------------------------------------------------------------------- ! CHARACTER(len=4) :: IGRaph CHARACTER(len=4) :: iplotc CHARACTER(len=4) :: sbnam1 , sbnam2 CHARACTER(len=4) :: alph11 , alph12 , alph21 , alph22 , alph31 , alph32 CHARACTER(len=4) :: alph41 , alph42 , alph91 , alph92 CHARACTER(len=4) :: blank , hyphen , alphai , alphax CHARACTER(len=4) :: alpham , alphaa , alphad , alphan , equal ! DIMENSION Y(:) DIMENSION X(:) DIMENSION D(:) DIMENSION Char(:) DIMENSION ylable(11) DIMENSION iplotc(37) COMMON /BLOCK1/ IGRaph(55,130) ! DATA sbnam1 , sbnam2/'PLOT' , '8 '/ DATA alph11 , alph12/'FIRS' , 'T '/ DATA alph21 , alph22/'SECO' , 'ND '/ DATA alph31 , alph32/'THIR' , 'D '/ DATA alph41 , alph42/'FOUR' , 'TH '/ DATA alph91 , alph92/'NINT' , 'H '/ DATA blank , hyphen , alphai , alphax/' ' , '-' , 'I' , 'X'/ DATA alpham , alphaa , alphad , alphan , equal/'M' , 'A' , 'D' , & & 'N' , '='/ DATA iplotc(1) , iplotc(2) , iplotc(3) , iplotc(4) , iplotc(5) , & & iplotc(6) , iplotc(7) , iplotc(8) , iplotc(9) , iplotc(10) , & & iplotc(11) , iplotc(12) , iplotc(13) , iplotc(14) , & & iplotc(15) , iplotc(16) , iplotc(17) , iplotc(18) , & & iplotc(19) , iplotc(20) , iplotc(21) , iplotc(22) , & & iplotc(23) , iplotc(24) , iplotc(25) , iplotc(26) , & & iplotc(27) , iplotc(28) , iplotc(29) , iplotc(30) , & & iplotc(31) , iplotc(32) , iplotc(33) , iplotc(34) , & & iplotc(35) , iplotc(36) , iplotc(37)/'1' , '2' , '3' , '4' , & & '5' , '6' , '7' , '8' , '9' , '0' , 'A' , 'B' , 'C' , 'D' , & & 'E' , 'F' , 'G' , 'H' , 'I' , 'J' , 'K' , 'L' , 'M' , 'N' , & & 'O' , 'P' , 'Q' , 'R' , 'S' , 'T' , 'U' , 'V' , 'W' , 'X' , & & 'Y' , 'Z' , 'X'/ ! cutoff = (10.0_wp**10) - 1000.0_wp ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! WRITE (G_IO,99001) 99001 FORMAT ('1') IF ( N<1 ) THEN WRITE (G_IO,99014) WRITE (G_IO,99015) WRITE (G_IO,99017) alph41 , alph42 , sbnam1 , sbnam2 WRITE (G_IO,99002) N 99002 FORMAT (' ','IS NON-NEGATIVE (WITH VALUE = ',I0,')') WRITE (G_IO,99014) RETURN ELSE IF ( N==1 ) THEN WRITE (G_IO,99014) WRITE (G_IO,99015) WRITE (G_IO,99017) alph41 , alph42 , sbnam1 , sbnam2 WRITE (G_IO,99003) N 99003 FORMAT (' ','HAS THE VALUE 1') WRITE (G_IO,99014) RETURN ELSE ! hold = Y(1) DO i = 2 , N IF ( Y(i)/=hold ) GOTO 50 ENDDO WRITE (G_IO,99014) WRITE (G_IO,99015) WRITE (G_IO,99017) alph11 , alph12 , sbnam1 , sbnam2 WRITE (G_IO,99018) hold WRITE (G_IO,99014) RETURN ENDIF 50 hold = X(1) DO i = 2 , N IF ( X(i)/=hold ) GOTO 100 ENDDO WRITE (G_IO,99014) WRITE (G_IO,99015) WRITE (G_IO,99017) alph21 , alph22 , sbnam1 , sbnam2 WRITE (G_IO,99018) hold WRITE (G_IO,99014) RETURN ENDIF 100 hold = Char(1) DO i = 2 , N IF ( Char(i)/=hold ) GOTO 200 ENDDO WRITE (G_IO,99014) WRITE (G_IO,99016) WRITE (G_IO,99017) alph31 , alph32 , sbnam1 , sbnam2 WRITE (G_IO,99018) hold WRITE (G_IO,99014) 200 hold = D(1) DO i = 2 , N IF ( D(i)/=hold ) GOTO 300 ENDDO WRITE (G_IO,99014) WRITE (G_IO,99016) WRITE (G_IO,99017) alph91 , alph92 , sbnam1 , sbnam2 WRITE (G_IO,99018) hold WRITE (G_IO,99014) ! 300 DO i = 1 , N IF ( Y(i)<cutoff ) GOTO 400 ENDDO WRITE (G_IO,99014) WRITE (G_IO,99015) WRITE (G_IO,99017) alph11 , alph12 , sbnam1 , sbnam2 WRITE (G_IO,99019) WRITE (G_IO,99020) cutoff WRITE (G_IO,99014) RETURN 400 DO i = 1 , N IF ( X(i)<cutoff ) GOTO 500 ENDDO WRITE (G_IO,99014) WRITE (G_IO,99015) WRITE (G_IO,99017) alph21 , alph22 , sbnam1 , sbnam2 WRITE (G_IO,99019) WRITE (G_IO,99020) cutoff WRITE (G_IO,99014) RETURN 500 DO i = 1 , N IF ( Char(i)<cutoff ) GOTO 600 ENDDO WRITE (G_IO,99014) WRITE (G_IO,99015) WRITE (G_IO,99017) alph31 , alph32 , sbnam1 , sbnam2 WRITE (G_IO,99019) WRITE (G_IO,99020) cutoff WRITE (G_IO,99014) RETURN 600 DO i = 1 , N IF ( D(i)<cutoff ) GOTO 700 ENDDO WRITE (G_IO,99014) WRITE (G_IO,99015) WRITE (G_IO,99017) alph91 , alph92 , sbnam1 , sbnam2 WRITE (G_IO,99019) WRITE (G_IO,99020) cutoff WRITE (G_IO,99014) RETURN ! 700 DO i = 1 , N IF ( Dmin<D(i) .AND. D(i)<Dmax ) GOTO 800 ENDDO WRITE (G_IO,99014) WRITE (G_IO,99015) WRITE (G_IO,99017) alph91 , alph92 , sbnam1 , sbnam2 WRITE (G_IO,99004) 99004 FORMAT (' ','HAS ALL ELEMENTS OUTSIDE THE INTERVAL') WRITE (G_IO,99005) Dmin , Dmax 99005 FORMAT (' ','(',E15.8,',',E15.8,')',' AS DEFINED BY') WRITE (G_IO,99006) 99006 FORMAT (' ','THE FIFTH AND SIXTH INPUT ARGUMENTS.') WRITE (G_IO,99014) RETURN ! 800 n2 = 0 DO i = 1 , N IF ( Y(i)<cutoff .AND. X(i)<cutoff .AND. Char(i)<cutoff .AND. & & D(i)<cutoff ) THEN IF ( Dmin<D(i) .AND. D(i)<Dmax ) n2 = n2 + 1 IF ( n2>=2 ) GOTO 900 ENDIF ENDDO WRITE (G_IO,99014) WRITE (G_IO,99015) WRITE (G_IO,99007) alph11 , alph12 , alph21 , alph22 , alph31 , & & alph32 , alph91 , alph92 99007 FORMAT (' ','THE ',A4,A4,', ',A4,A4,', ',A4,A4,', AND ',A4,A4) WRITE (G_IO,99008) sbnam1 , sbnam2 99008 FORMAT (' ','INPUT ARGUMENTS TO THE ',A4,A4,' SUBROUTINE') WRITE (G_IO,99009) 99009 FORMAT (' ','ARE SUCH THAT TOO MANY POINTS HAVE BEEN', & & ' EXCLUDED FROM THE PLOT.') WRITE (G_IO,99010) n2 99010 FORMAT (' ','ONLY ',I0,' POINTS ARE LEFT TO BE PLOTTED.') WRITE (G_IO,99014) RETURN ! !-----START POINT----------------------------------------------------- ! ! DETERMINE THE VALUES TO BE LISTED ON THE LEFT VERTICAL AXIS ! 900 DO i = 1 , 9 aim1 = i - 1 ylable(i) = Ymax - (aim1/8.0_wp)*(Ymax-Ymin) ENDDO ! ! DETERMINE THE VALUES TO BE LISTED ON THE BOTTOM HORIZONTAL AXIS ! DETERMINE XMID, X25 (=THE 25% POINT), AND ! X75 (=THE 75% POINT) ! xmid = (Xmin+Xmax)/2.0_wp x25 = 0.75_wp*Xmin + 0.25_wp*Xmax x75 = 0.25_wp*Xmin + 0.75_wp*Xmax ! ! BLANK OUT THE GRAPH ! DO i = 1 , 45 DO j = 1 , 109 IGRaph(i,j) = blank ENDDO ENDDO ! ! PRODUCE THE VERTICAL AXES ! DO i = 3 , 43 IGRaph(i,5) = alphai IGRaph(i,109) = alphai ENDDO DO i = 3 , 43 , 5 IGRaph(i,5) = hyphen IGRaph(i,109) = hyphen ENDDO IGRaph(3,1) = equal IGRaph(3,2) = alpham IGRaph(3,3) = alphaa IGRaph(3,4) = alphax IGRaph(23,1) = equal IGRaph(23,2) = alpham IGRaph(23,3) = alphai IGRaph(23,4) = alphad IGRaph(43,1) = equal IGRaph(43,2) = alpham IGRaph(43,3) = alphai IGRaph(43,4) = alphan ! ! PRODUCE THE HORIZONTAL AXES ! DO j = 7 , 107 IGRaph(1,j) = hyphen IGRaph(45,j) = hyphen ENDDO DO j = 7 , 107 , 25 IGRaph(1,j) = alphai IGRaph(45,j) = alphai ENDDO DO j = 20 , 107 , 25 IGRaph(1,j) = alphai IGRaph(45,j) = alphai ENDDO ! ! DETERMINE THE (X,Y) PLOT POSITIONS ! ratioy = 40.0_wp/(Ymax-Ymin) ratiox = 100.0_wp/(Xmax-Xmin) DO i = 1 , N IF ( Y(i)<cutoff ) THEN IF ( X(i)<cutoff ) THEN IF ( Char(i)<cutoff ) THEN IF ( Y(i)>=Ymin .AND. Y(i)<=Ymax ) THEN IF ( X(i)>=Xmin .AND. X(i)<=Xmax ) THEN IF ( D(i)>=Dmin ) THEN IF ( D(i)<=Dmax ) THEN mx = ratiox*(X(i)-Xmin) + 0.5_wp mx = mx + 7 my = ratioy*(Y(i)-Ymin) + 0.5_wp my = 43 - my iarg = 37 IF ( 0.5_wp<Char(i) .AND. Char(i)<36.5_wp ) & & iarg = Char(i) + 0.5_wp IGRaph(my,mx) = iplotc(iarg) ENDIF ENDIF ENDIF ENDIF ENDIF ENDIF ENDIF ENDDO ! ! WRITE OUT THE GRAPH ! DO i = 1 , 45 ip2 = i + 2 iflag = ip2 - (ip2/5)*5 k = ip2/5 IF ( iflag/=0 ) WRITE (G_IO,99011) (IGRaph(i,j),j=1,109) ! 99011 FORMAT (' ',20X,109A1) IF ( iflag==0 ) WRITE (G_IO,99012) ylable(k) , & & (IGRaph(i,j),j=1,109) 99012 FORMAT (' ',F20.7,109A1) ENDDO WRITE (G_IO,99013) Xmin , x25 , xmid , x75 , Xmax 99013 FORMAT (' ',14X,F20.7,5X,F20.7,5X,F20.7,5X,F20.7,1X,F20.7) ! 99014 FORMAT (' ','**************************************************', & & '********************') 99015 FORMAT (' ',' FATAL ERROR ') 99016 FORMAT (' ',' NON-FATAL DIAGNOSTIC ') 99017 FORMAT (' ','THE ',A4,A4,' INPUT ARGUMENT TO THE ',A4,A4, & & ' SUBROUTINE') 99018 FORMAT (' ','HAS ALL ELEMENTS = ',E15.8) 99019 FORMAT (' ','HAS ALL ELEMENTS IN EXCESS OF THE CUTOFF') 99020 FORMAT (' ','VALUE OF ',E15.8) ! END SUBROUTINE PLOT8 !> !!##NAME !! plot9(3f) - [M_datapac:GENERIC_LINE_PLOT] generate a line printer !! plot with special plot characters !! !!##SYNOPSIS !! !! SUBROUTINE PLOT9(Y,X,Char,N,Ymin,Ymax,Xmin,Xmax,Yaxid,Xaxid,Plchid) !! !!##DESCRIPTION !! PLOT9(3f) yields a one-page printer plot of y(i) versus x(i): !! !! 1. With special plot characters; !! 2. With the vertical (y) axis min and max !! and the horizontal (x) axis min and max !! values specified by the data analyst; and !! 3. With hollerith labels (at most 6 characters) !! for the vertical axis variable, !! the horizontal axis variable, and !! the plotting character variable !! also being provided by the data analyst. !! !! The 'special plotting character' capability allows the data analyst !! to incorporate information from a third variable (aside from Y and X) !! into the plot. !! !! The plot character used at the i-th plotting position (that is, !! at the coordinate (X(i),Y(i))) will be !! !! 1 if char(i) is between 0.5 and 1.5 !! 2 if char(i) is between 1.5 and 2.5 !! . !! . !! . !! 9 if char(i) is between 8.5 and 9.5 !! 0 if char(i) is between 9.5 and 10.5 !! a if char(i) is between 10.5 and 11.5 !! b if char(i) is between 11.5 and 12.5 !! c if char(i) is between 12.5 and 13.5 !! . !! . !! . !! w if char(i) is between 32.5 and 33.5 !! x if char(i) is between 33.5 and 34.5 !! y if char(i) is between 34.5 and 35.5 !! z if char(i) is between 35.5 and 36.5 !! x if char(i) is any value outside the range !! 0.5 to 36.5. !! !! The use of the YMIN, YMAX, XMIN, and XMAX specifications allows the !! data analyst to control fully the plot axis limits, so as, for example, !! to zero-in on an interesting sub-region of a previous plot. !! !! The use of hollerith identifying labels allows the data analyst to !! automatically have the plots labeled. This is particularly useful !! in a large analysis when many plots are being generated. !! !!##OPTIONS !! X description of parameter !! Y description of parameter !! !!##EXAMPLES !! !! Sample program: !! !! program demo_plot9 !! use M_datapac, only : plot9 !! implicit none !! ! call plot9(x,y) !! end program demo_plot9 !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !! !!##REFERENCES !! * Filliben, 'Statistical Analysis of Interlab Fatigue Time Data', !! Unpublished Manuscript (Available from Author) presented at the !! 'Computer-Assisted Data Analysis' Session at the National Meeting of the !! American Statistical Association, New York City, December 27-30, 1973. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE PLOT9(Y,X,Char,N,Ymin,Ymax,Xmin,Xmax,Yaxid,Xaxid,Plchid) REAL(kind=wp) :: aim1 , Char , cutoff , hold , Plchid , ratiox , ratioy , X , & & x25 , x75 , Xaxid , Xmax , xmid , Xmin , Y , Yaxid , ylable ,& & Ymax , Ymin INTEGER :: i , iarg , iflag , ip2 , j , k , mx , my , N , n2 ! ! ! INPUT ARGUMENTS--Y = THE VECTOR OF ! (UNSORTED OR SORTED) OBSERVATIONS ! TO BE PLOTTED VERTICALLY. ! --X = THE VECTOR OF ! (UNSORTED OR SORTED) OBSERVATIONS ! TO BE PLOTTED HORIZONTALLY. ! --CHAR = THE VECTOR OF ! OBSERVATIONS WHICH CONTROL THE ! VALUE OF EACH INDIVIDUAL PLOT ! CHARACTER. ! --N = THE INTEGER NUMBER OF OBSERVATIONS ! IN THE VECTOR Y. ! --YMIN = THE VALUE OF ! DESIRED MINIMUM FOR THE VERTICAL AXIS. ! --YMAX = THE VALUE OF ! DESIRED MAXIMUM FOR THE VERTICAL AXIS. ! --XMIN = THE VALUE OF ! DESIRED MINIMUM FOR THE HORIZONTAL AXIS. ! --XMAX = THE VALUE OF ! DESIRED MAXIMUM FOR THE HORIZONTAL AXIS. ! --YAXID = THE HOLLERITH VALUE ! (AT MOST 6 CHARACTERS) ! OF THE DESIRED LABEL FOR THE ! VERTICAL AXIS VARIABLE. ! --XAXID = THE HOLLERITH VALUE ! (AT MOST 6 CHARACTERS) ! OF THE DESIRED LABEL FOR THE ! HORIZONTAL AXIS VARIABLE. ! --PLCHID = THE HOLLERITH VALUE ! (AT MOST 6 CHARACTERS) ! OF THE DESIRED LABEL FOR THE ! PLOTTING CHARACTER VARIABLE. ! OUTPUT--A ONE-page PRINTER PLOT OF Y(I) VERSUS X(I), ! WITH SPECIAL PLOT CHARACTERS, ! WITH SPECIFIED AXIS LIMITS, ! AND WITH SPECIFIED LABELS. ! PRINTING--YES. ! RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE ! OF N FOR THIS SUBROUTINE. ! MODE OF INTERNAL OPERATIONS--. ! COMMENT--VALUES IN THE VERTICAL AXIS VECTOR (Y) ! WHICH ARE SMALLER THAN YMIN OR LARGER THAN YMAX, ! OR VALUES IN THE HORIZONTAL AXIS VECTOR (X) ! WHICH ARE SMALLER THAN XMIN OR LARGER THAN XMAX ! WILL NOT BE PLOTTED. ! --VALUES IN THE VERTICAL AXIS VECTOR (Y), ! THE HORIZONTAL AXIS VECTOR (X), ! OR THE PLOT CHARACTER VECTOR (CHAR) WHICH ARE ! EQUAL TO OR IN EXCESS OF 10.0**10 WILL NOT BE ! PLOTTED. ! THIS CONVENTION GREATLY SIMPLIFIES THE PROBLEM ! OF PLOTTING WHEN SOME ELEMENTS IN THE VECTOR Y ! (OR X, OR CHAR) ARE 'MISSING DATA', OR WHEN WE PURPOSELY ! WANT TO IGNORE CERTAIN ELEMENTS IN THE VECTOR Y ! (OR X, OR CHAR) FOR PLOTTING PURPOSES (THAT IS, WE DO NOT ! WANT CERTAIN ELEMENTS IN Y (OR X, OR CHAR) TO BE ! PLOTTED). ! TO CAUSE SPECIFIC ELEMENTS IN Y (OR X, OR CHAR) TO BE ! IGNORED, WE REPLACE THE ELEMENTS BEFOREHAND ! (BY, FOR EXAMPLE, USE OF THE REPLAC SUBROUTINE) ! BY SOME LARGE VALUE (LIKE, SAY, 10.0**10) AND ! THEY WILL SUBSEQUENTLY BE IGNORED IN THE PLOTC ! SUBROUTINE. ! ORIGINAL VERSION--JUNE 1972. ! UPDATED --JUNE 1974. ! UPDATED --OCTOBER 1975. ! UPDATED --NOVEMBER 1975. ! UPDATED --FEBRUARY 1976. ! UPDATED --FEBRUARY 1977. ! UPDATED --JUNE 1977. ! !--------------------------------------------------------------------- ! CHARACTER(len=4) :: IGRaph CHARACTER(len=4) :: iplotc CHARACTER(len=4) :: sbnam1 , sbnam2 CHARACTER(len=4) :: alph11 , alph12 , alph21 , alph22 , alph31 , alph32 CHARACTER(len=4) :: alph41 , alph42 CHARACTER(len=4) :: blank , hyphen , alphai , alphax CHARACTER(len=4) :: alpham , alphaa , alphad , alphan , equal ! DIMENSION Y(:) DIMENSION X(:) DIMENSION Char(:) DIMENSION ylable(11) DIMENSION iplotc(37) COMMON /BLOCK1/ IGRaph(55,130) ! DATA sbnam1 , sbnam2/'PLOT' , '9 '/ DATA alph11 , alph12/'FIRS' , 'T '/ DATA alph21 , alph22/'SECO' , 'ND '/ DATA alph31 , alph32/'THIR' , 'D '/ DATA alph41 , alph42/'FOUR' , 'TH '/ DATA blank , hyphen , alphai , alphax/' ' , '-' , 'I' , 'X'/ DATA alpham , alphaa , alphad , alphan , equal/'M' , 'A' , 'D' , & & 'N' , '='/ DATA iplotc(1) , iplotc(2) , iplotc(3) , iplotc(4) , iplotc(5) , & & iplotc(6) , iplotc(7) , iplotc(8) , iplotc(9) , iplotc(10) , & & iplotc(11) , iplotc(12) , iplotc(13) , iplotc(14) , & & iplotc(15) , iplotc(16) , iplotc(17) , iplotc(18) , & & iplotc(19) , iplotc(20) , iplotc(21) , iplotc(22) , & & iplotc(23) , iplotc(24) , iplotc(25) , iplotc(26) , & & iplotc(27) , iplotc(28) , iplotc(29) , iplotc(30) , & & iplotc(31) , iplotc(32) , iplotc(33) , iplotc(34) , & & iplotc(35) , iplotc(36) , iplotc(37)/'1' , '2' , '3' , '4' , & & '5' , '6' , '7' , '8' , '9' , '0' , 'A' , 'B' , 'C' , 'D' , & & 'E' , 'F' , 'G' , 'H' , 'I' , 'J' , 'K' , 'L' , 'M' , 'N' , & & 'O' , 'P' , 'Q' , 'R' , 'S' , 'T' , 'U' , 'V' , 'W' , 'X' , & & 'Y' , 'Z' , 'X'/ ! cutoff = (10.0_wp**10) - 1000.0_wp ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! WRITE (G_IO,99001) 99001 FORMAT ('1') IF ( N<1 ) THEN WRITE (G_IO,99014) WRITE (G_IO,99015) WRITE (G_IO,99016) alph41 , alph42 , sbnam1 , sbnam2 WRITE (G_IO,99002) N 99002 FORMAT (' ','IS NON-NEGATIVE (WITH VALUE = ',I0,')') WRITE (G_IO,99014) RETURN ELSE IF ( N==1 ) THEN WRITE (G_IO,99014) WRITE (G_IO,99015) WRITE (G_IO,99016) alph41 , alph42 , sbnam1 , sbnam2 WRITE (G_IO,99003) N 99003 FORMAT (' ','HAS THE VALUE 1') WRITE (G_IO,99014) RETURN ELSE ! hold = Y(1) DO i = 2 , N IF ( Y(i)/=hold ) GOTO 50 ENDDO WRITE (G_IO,99014) WRITE (G_IO,99015) WRITE (G_IO,99016) alph11 , alph12 , sbnam1 , sbnam2 WRITE (G_IO,99017) hold WRITE (G_IO,99014) RETURN ENDIF 50 hold = X(1) DO i = 2 , N IF ( X(i)/=hold ) GOTO 100 ENDDO WRITE (G_IO,99014) WRITE (G_IO,99015) WRITE (G_IO,99016) alph21 , alph22 , sbnam1 , sbnam2 WRITE (G_IO,99017) hold WRITE (G_IO,99014) RETURN ENDIF 100 hold = Char(1) DO i = 2 , N IF ( Char(i)/=hold ) GOTO 200 ENDDO WRITE (G_IO,99014) WRITE (G_IO,99004) 99004 FORMAT (' ',' NON-FATAL DIAGNOSTIC ') WRITE (G_IO,99016) alph31 , alph32 , sbnam1 , sbnam2 WRITE (G_IO,99017) hold WRITE (G_IO,99014) ! 200 DO i = 1 , N IF ( Y(i)<cutoff ) GOTO 300 ENDDO WRITE (G_IO,99014) WRITE (G_IO,99015) WRITE (G_IO,99016) alph11 , alph12 , sbnam1 , sbnam2 WRITE (G_IO,99018) WRITE (G_IO,99019) cutoff WRITE (G_IO,99014) RETURN 300 DO i = 1 , N IF ( X(i)<cutoff ) GOTO 400 ENDDO WRITE (G_IO,99014) WRITE (G_IO,99015) WRITE (G_IO,99016) alph21 , alph22 , sbnam1 , sbnam2 WRITE (G_IO,99018) WRITE (G_IO,99019) cutoff WRITE (G_IO,99014) RETURN 400 DO i = 1 , N IF ( Char(i)<cutoff ) GOTO 500 ENDDO WRITE (G_IO,99014) WRITE (G_IO,99015) WRITE (G_IO,99016) alph31 , alph32 , sbnam1 , sbnam2 WRITE (G_IO,99018) WRITE (G_IO,99019) cutoff WRITE (G_IO,99014) RETURN ! 500 n2 = 0 DO i = 1 , N IF ( Y(i)<cutoff .AND. X(i)<cutoff .AND. Char(i)<cutoff ) THEN n2 = n2 + 1 IF ( n2>=2 ) GOTO 600 ENDIF ENDDO WRITE (G_IO,99014) WRITE (G_IO,99015) WRITE (G_IO,99005) alph11 , alph12 , alph21 , alph22 , alph31 , & & alph32 99005 FORMAT (' ','THE ',A4,A4,', ',A4,A4,', AND ',A4,A4) WRITE (G_IO,99006) sbnam1 , sbnam2 99006 FORMAT (' ','INPUT ARGUMENTS TO THE ',A4,A4,' SUBROUTINE') WRITE (G_IO,99007) 99007 FORMAT (' ','ARE SUCH THAT TOO MANY POINTS HAVE BEEN', & & ' EXCLUDED FROM THE PLOT.') WRITE (G_IO,99008) n2 99008 FORMAT (' ','ONLY ',I0,' POINTS ARE LEFT TO BE PLOTTED.') WRITE (G_IO,99014) RETURN ! !-----START POINT----------------------------------------------------- ! ! DETERMINE THE VALUES TO BE LISTED ON THE LEFT VERTICAL AXIS ! 600 DO i = 1 , 9 aim1 = i - 1 ylable(i) = Ymax - (aim1/8.0)*(Ymax-Ymin) ENDDO ! ! DETERMINE THE VALUES TO BE LISTED ON THE BOTTOM HORIZONTAL AXIS ! DETERMINE XMID, X25 (=THE 25% POINT), AND ! X75 (=THE 75% POINT) ! xmid = (Xmin+Xmax)/2.0_wp x25 = 0.75_wp*Xmin + 0.25_wp*Xmax x75 = 0.25_wp*Xmin + 0.75_wp*Xmax ! ! BLANK OUT THE GRAPH ! DO i = 1 , 45 DO j = 1 , 109 IGRaph(i,j) = blank ENDDO ENDDO ! ! PRODUCE THE VERTICAL AXES ! DO i = 3 , 43 IGRaph(i,5) = alphai IGRaph(i,109) = alphai ENDDO DO i = 3 , 43 , 5 IGRaph(i,5) = hyphen IGRaph(i,109) = hyphen ENDDO IGRaph(3,1) = equal IGRaph(3,2) = alpham IGRaph(3,3) = alphaa IGRaph(3,4) = alphax IGRaph(23,1) = equal IGRaph(23,2) = alpham IGRaph(23,3) = alphai IGRaph(23,4) = alphad IGRaph(43,1) = equal IGRaph(43,2) = alpham IGRaph(43,3) = alphai IGRaph(43,4) = alphan ! ! PRODUCE THE HORIZONTAL AXES ! DO j = 7 , 107 IGRaph(1,j) = hyphen IGRaph(45,j) = hyphen ENDDO DO j = 7 , 107 , 25 IGRaph(1,j) = alphai IGRaph(45,j) = alphai ENDDO DO j = 20 , 107 , 25 IGRaph(1,j) = alphai IGRaph(45,j) = alphai ENDDO ! ! DETERMINE THE (X,Y) PLOT POSITIONS ! ratioy = 40.0_wp/(Ymax-Ymin) ratiox = 100.0_wp/(Xmax-Xmin) DO i = 1 , N IF ( Y(i)<cutoff ) THEN IF ( X(i)<cutoff ) THEN IF ( Char(i)<cutoff ) THEN IF ( Y(i)>=Ymin .AND. Y(i)<=Ymax ) THEN IF ( X(i)>=Xmin .AND. X(i)<=Xmax ) THEN mx = ratiox*(X(i)-Xmin) + 0.5_wp mx = mx + 7 my = ratioy*(Y(i)-Ymin) + 0.5_wp my = 43 - my iarg = 37 IF ( 0.5_wp<Char(i) .AND. Char(i)<36.5_wp ) & & iarg = Char(i) + 0.5_wp IGRaph(my,mx) = iplotc(iarg) ENDIF ENDIF ENDIF ENDIF ENDIF ENDDO ! ! WRITE OUT THE GRAPH ! DO i = 1 , 45 ip2 = i + 2 iflag = ip2 - (ip2/5)*5 k = ip2/5 IF ( iflag/=0 ) WRITE (G_IO,99009) (IGRaph(i,j),j=1,109) 99009 FORMAT (' ',20X,109A1) IF ( iflag==0 ) WRITE (G_IO,99010) ylable(k) , & & (IGRaph(i,j),j=1,109) 99010 FORMAT (' ',F20.7,109A1) ENDDO WRITE (G_IO,99011) Xmin , x25 , xmid , x75 , Xmax 99011 FORMAT (' ',14X,F20.7,5X,F20.7,5X,F20.7,5X,F20.7,1X,F20.7) ! WRITE (G_IO,99012) Yaxid , Xaxid , Plchid 99012 FORMAT (' ',9X,A4,A4,' (VERTICAL AXIS) VERSUS ',A4,A4, & & ' (HORIZONTAL AXIS)',20X,'THE PLOTTING CHARACTER IS ',A4, & & A4) WRITE (G_IO,99013) N 99013 FORMAT (' ',83X,'THE NUMBER OF OBSERVATIONS PLOTTED IS ',I0) ! 99014 FORMAT (' ','**************************************************', & & '********************') 99015 FORMAT (' ',' FATAL ERROR ') 99016 FORMAT (' ','THE ',A4,A4,' INPUT ARGUMENT TO THE ',A4,A4, & & ' SUBROUTINE') 99017 FORMAT (' ','HAS ALL ELEMENTS = ',E15.8) 99018 FORMAT (' ','HAS ALL ELEMENTS IN EXCESS OF THE CUTOFF') 99019 FORMAT (' ','VALUE OF ',E15.8) ! END SUBROUTINE PLOT9 !> !!##NAME !! plotc(3f) - [M_datapac:GENERIC_LINE_PLOT] generate a line printer !! plot with special plot characters !! !!##SYNOPSIS !! !! SUBROUTINE PLOTC(Y,X,Char,N) !! !!##DESCRIPTION !! plotc(3f) yields a one-page printer plot of y(i) versus x(i) with !! special plotting characters. !! !! this 'special plotting character' capability allows the data analyst !! to incorporate information from a third variable (aside from y and x) !! into the plot. !! !! the plot character used at the i-th plotting position (that is, !! at the coordinate (x(i),y(i))) will be !! !! 1 if char(i) is between 0.5 and 1.5 !! 2 if char(i) is between 1.5 and 2.5 !! . !! . !! . !! 9 if char(i) is between 8.5 and 9.5 !! 0 if char(i) is between 9.5 and 10.5 !! a if char(i) is between 10.5 and 11.5 !! b if char(i) is between 11.5 and 12.5 !! c if char(i) is between 12.5 and 13.5 !! . !! . !! . !! w if char(i) is between 32.5 and 33.5 !! x if char(i) is between 33.5 and 34.5 !! y if char(i) is between 34.5 and 35.5 !! z if char(i) is between 35.5 and 36.5 !! x if char(i) is any value outside the range !! 0.5 to 36.5. !! !!##OPTIONS !! X description of parameter !! Y description of parameter !! !!##EXAMPLES !! !! Sample program: !! !! program demo_plotc !! use M_datapac, only : plotc !! implicit none !! ! call plotc(x,y) !! end program demo_plotc !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the Statistical !! Engineering Division, National Institute of Standards and Technology. !!##MAINTAINER !! John Urban, 2022.05.31 !!##LICENSE !! CC0-1.0 !!##REFERENCES !! * FILLIBEN, 'STATISTICAL ANALYSIS OF INTERLAB FATIGUE TIME DATA', !! UNPUBLISHED MANUSCRIPT (AVAILABLE FROM AUTHOR) PRESENTED AT THE !! 'COMPUTER-ASSISTED DATA ANALYSIS' SESSION AT THE NATIONAL MEETING OF THE !! AMERICAN STATISTICAL ASSOCIATION, NEW YORK CITY, DECEMBER 27-30, 1973. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE PLOTC(Y,X,Char,N) REAL(kind=wp) :: aim1, Char, cutoff, hold, ratiox, ratioy, X, x25, x75, xmax, xmid, xmin, Y, ylable, ymax, ymin INTEGER :: i, iarg, iflag, ip2, j, k, mx, my, N, n2 ! ! INPUT ARGUMENTS--Y = THE VECTOR OF ! (UNSORTED OR SORTED) OBSERVATIONS ! TO BE PLOTTED VERTICALLY. ! --X = THE VECTOR OF ! (UNSORTED OR SORTED) OBSERVATIONS ! TO BE PLOTTED HORIZONTALLY. ! --CHAR = THE VECTOR OF ! OBSERVATIONS WHICH CONTROL THE ! VALUE OF EACH INDIVIDUAL PLOT ! CHARACTER. ! --N = THE INTEGER NUMBER OF OBSERVATIONS ! IN THE VECTOR Y. ! OUTPUT--A ONE-page PRINTER PLOT OF Y(I) VERSUS X(I) ! WITH SPECIAL PLOT CHARACTERS. ! PRINTING--YES. ! RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE ! OF N FOR THIS SUBROUTINE. ! MODE OF INTERNAL OPERATIONS--. ! COMMENT--VALUES IN THE VERTICAL AXIS VECTOR (Y), ! THE HORIZONTAL AXIS VECTOR (X), ! OR THE PLOT CHARACTER VECTOR (CHAR) WHICH ARE ! EQUAL TO OR IN EXCESS OF 10.0**10 WILL NOT BE ! PLOTTED. ! THIS CONVENTION GREATLY SIMPLIFIES THE PROBLEM ! OF PLOTTING WHEN SOME ELEMENTS IN THE VECTOR Y ! (OR X, OR CHAR) ARE 'MISSING DATA', OR WHEN WE PURPOSELY ! WANT TO IGNORE CERTAIN ELEMENTS IN THE VECTOR Y ! (OR X, OR CHAR) FOR PLOTTING PURPOSES (THAT IS, WE DO NOT ! WANT CERTAIN ELEMENTS IN Y (OR X, OR CHAR) TO BE ! PLOTTED). ! TO CAUSE SPECIFIC ELEMENTS IN Y (OR X, OR CHAR) TO BE ! IGNORED, WE REPLACE THE ELEMENTS BEFOREHAND ! (BY, FOR EXAMPLE, USE OF THE REPLAC SUBROUTINE) ! BY SOME LARGE VALUE (LIKE, SAY, 10.0**10) AND ! THEY WILL SUBSEQUENTLY BE IGNORED IN THE PLOTC ! SUBROUTINE. ! ORIGINAL VERSION--OCTOBER 1974. ! UPDATED --NOVEMBER 1974. ! UPDATED --JANUARY 1975. ! UPDATED --JULY 1975. ! UPDATED --SEPTEMBER 1975. ! UPDATED --OCTOBER 1975. ! UPDATED --NOVEMBER 1975. ! UPDATED --FEBRUARY 1976. ! UPDATED --FEBRUARY 1977. ! !--------------------------------------------------------------------- ! CHARACTER(len=4) :: IGRaph CHARACTER(len=4) :: iplotc CHARACTER(len=4) :: sbnam1 , sbnam2 CHARACTER(len=4) :: alph11 , alph12 , alph21 , alph22 , alph31 , alph32 CHARACTER(len=4) :: alph41 , alph42 CHARACTER(len=4) :: blank , hyphen , alphai , alphax CHARACTER(len=4) :: alpham , alphaa , alphad , alphan , equal ! DIMENSION Y(:) DIMENSION X(:) DIMENSION Char(:) DIMENSION ylable(11) DIMENSION iplotc(37) COMMON /BLOCK1/ IGRaph(55,130) ! DATA sbnam1 , sbnam2/'PLOT' , 'C '/ DATA alph11 , alph12/'FIRS' , 'T '/ DATA alph21 , alph22/'SECO' , 'ND '/ DATA alph31 , alph32/'THIR' , 'D '/ DATA alph41 , alph42/'FOUR' , 'TH '/ DATA blank , hyphen , alphai , alphax/' ' , '-' , 'I' , 'X'/ DATA alpham , alphaa , alphad , alphan , equal/'M' , 'A' , 'D' , & & 'N' , '='/ DATA iplotc(1) , iplotc(2) , iplotc(3) , iplotc(4) , iplotc(5) , & & iplotc(6) , iplotc(7) , iplotc(8) , iplotc(9) , iplotc(10) , & & iplotc(11) , iplotc(12) , iplotc(13) , iplotc(14) , & & iplotc(15) , iplotc(16) , iplotc(17) , iplotc(18) , & & iplotc(19) , iplotc(20) , iplotc(21) , iplotc(22) , & & iplotc(23) , iplotc(24) , iplotc(25) , iplotc(26) , & & iplotc(27) , iplotc(28) , iplotc(29) , iplotc(30) , & & iplotc(31) , iplotc(32) , iplotc(33) , iplotc(34) , & & iplotc(35) , iplotc(36) , iplotc(37)/'1' , '2' , '3' , '4' , & & '5' , '6' , '7' , '8' , '9' , '0' , 'A' , 'B' , 'C' , 'D' , & & 'E' , 'F' , 'G' , 'H' , 'I' , 'J' , 'K' , 'L' , 'M' , 'N' , & & 'O' , 'P' , 'Q' , 'R' , 'S' , 'T' , 'U' , 'V' , 'W' , 'X' , & & 'Y' , 'Z' , 'X'/ ! cutoff = (10.0_wp**10) - 1000.0_wp ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! WRITE (G_IO,99001) 99001 FORMAT ('1') IF ( N<1 ) THEN WRITE (G_IO,99012) WRITE (G_IO,99013) WRITE (G_IO,99014) alph41 , alph42 , sbnam1 , sbnam2 WRITE (G_IO,99002) N 99002 FORMAT (' ','IS NON-NEGATIVE (WITH VALUE = ',I0,')') WRITE (G_IO,99012) RETURN ELSE IF ( N==1 ) THEN WRITE (G_IO,99012) WRITE (G_IO,99013) WRITE (G_IO,99014) alph41 , alph42 , sbnam1 , sbnam2 WRITE (G_IO,99003) N 99003 FORMAT (' ','HAS THE VALUE 1') WRITE (G_IO,99012) RETURN ELSE ! hold = Y(1) DO i = 2 , N IF ( Y(i)/=hold ) GOTO 50 ENDDO WRITE (G_IO,99012) WRITE (G_IO,99013) WRITE (G_IO,99014) alph11 , alph12 , sbnam1 , sbnam2 WRITE (G_IO,99015) hold WRITE (G_IO,99012) RETURN ENDIF 50 hold = X(1) DO i = 2 , N IF ( X(i)/=hold ) GOTO 100 ENDDO WRITE (G_IO,99012) WRITE (G_IO,99013) WRITE (G_IO,99014) alph21 , alph22 , sbnam1 , sbnam2 WRITE (G_IO,99015) hold WRITE (G_IO,99012) RETURN ENDIF 100 hold = Char(1) DO i = 2 , N IF ( Char(i)/=hold ) GOTO 200 ENDDO WRITE (G_IO,99012) WRITE (G_IO,99004) 99004 FORMAT (' ',' NON-FATAL DIAGNOSTIC ') WRITE (G_IO,99014) alph31 , alph32 , sbnam1 , sbnam2 WRITE (G_IO,99015) hold WRITE (G_IO,99012) ! 200 DO i = 1 , N IF ( Y(i)<cutoff ) GOTO 300 ENDDO WRITE (G_IO,99012) WRITE (G_IO,99013) WRITE (G_IO,99014) alph11 , alph12 , sbnam1 , sbnam2 WRITE (G_IO,99016) WRITE (G_IO,99017) cutoff WRITE (G_IO,99012) RETURN 300 DO i = 1 , N IF ( X(i)<cutoff ) GOTO 400 ENDDO WRITE (G_IO,99012) WRITE (G_IO,99013) WRITE (G_IO,99014) alph21 , alph22 , sbnam1 , sbnam2 WRITE (G_IO,99016) WRITE (G_IO,99017) cutoff WRITE (G_IO,99012) RETURN 400 DO i = 1 , N IF ( Char(i)<cutoff ) GOTO 500 ENDDO WRITE (G_IO,99012) WRITE (G_IO,99013) WRITE (G_IO,99014) alph31 , alph32 , sbnam1 , sbnam2 WRITE (G_IO,99016) WRITE (G_IO,99017) cutoff WRITE (G_IO,99012) RETURN ! 500 n2 = 0 DO i = 1 , N IF ( Y(i)<cutoff .AND. X(i)<cutoff .AND. Char(i)<cutoff ) THEN n2 = n2 + 1 IF ( n2>=2 ) GOTO 600 ENDIF ENDDO WRITE (G_IO,99012) WRITE (G_IO,99013) WRITE (G_IO,99005) alph11 , alph12 , alph21 , alph22 , alph31 , & & alph32 99005 FORMAT (' ','THE ',A4,A4,', ',A4,A4,', AND ',A4,A4) WRITE (G_IO,99006) sbnam1 , sbnam2 99006 FORMAT (' ','INPUT ARGUMENTS TO THE ',A4,A4,' SUBROUTINE') WRITE (G_IO,99007) 99007 FORMAT (' ','ARE SUCH THAT TOO MANY POINTS HAVE BEEN', & & ' EXCLUDED FROM THE PLOT.') WRITE (G_IO,99008) n2 99008 FORMAT (' ','ONLY ',I0,' POINTS ARE LEFT TO BE PLOTTED.') WRITE (G_IO,99012) RETURN ! !-----START POINT----------------------------------------------------- ! ! DETERMINE THE VALUES TO BE LISTED ON THE LEFT VERTICAL AXIS ! 600 DO i = 1 , N IF ( Y(i)<cutoff ) THEN IF ( X(i)<cutoff ) THEN IF ( Char(i)<cutoff ) THEN ymin = Y(i) ymax = Y(i) EXIT ENDIF ENDIF ENDIF ENDDO DO i = 1 , N IF ( Y(i)<cutoff ) THEN IF ( X(i)<cutoff ) THEN IF ( Char(i)<cutoff ) THEN IF ( Y(i)<ymin ) ymin = Y(i) IF ( Y(i)>ymax ) ymax = Y(i) ENDIF ENDIF ENDIF ENDDO DO i = 1 , 9 aim1 = i - 1 ylable(i) = ymax - (aim1/8.0_wp)*(ymax-ymin) ENDDO ! ! DETERMINE THE VALUES TO BE LISTED ON THE BOTTOM HORIZONTAL AXIS ! DETERMINE XMIN, XMAX, XMID, X25 (=THE 25% POINT), AND ! X75 (=THE 75% POINT) ! DO i = 1 , N IF ( Y(i)<cutoff ) THEN IF ( X(i)<cutoff ) THEN IF ( Char(i)<cutoff ) THEN xmin = X(i) xmax = X(i) EXIT ENDIF ENDIF ENDIF ENDDO DO i = 1 , N IF ( Y(i)<cutoff ) THEN IF ( X(i)<cutoff ) THEN IF ( Char(i)<cutoff ) THEN IF ( X(i)<xmin ) xmin = X(i) IF ( X(i)>xmax ) xmax = X(i) ENDIF ENDIF ENDIF ENDDO xmid = (xmin+xmax)/2.0_wp x25 = 0.75_wp*xmin + 0.25_wp*xmax x75 = 0.25_wp*xmin + 0.75_wp*xmax ! ! BLANK OUT THE GRAPH ! DO i = 1 , 45 DO j = 1 , 109 IGRaph(i,j) = blank ENDDO ENDDO ! ! PRODUCE THE VERTICAL AXES ! DO i = 3 , 43 IGRaph(i,5) = alphai IGRaph(i,109) = alphai ENDDO DO i = 3 , 43 , 5 IGRaph(i,5) = hyphen IGRaph(i,109) = hyphen ENDDO IGRaph(3,1) = equal IGRaph(3,2) = alpham IGRaph(3,3) = alphaa IGRaph(3,4) = alphax IGRaph(23,1) = equal IGRaph(23,2) = alpham IGRaph(23,3) = alphai IGRaph(23,4) = alphad IGRaph(43,1) = equal IGRaph(43,2) = alpham IGRaph(43,3) = alphai IGRaph(43,4) = alphan ! ! PRODUCE THE HORIZONTAL AXES ! DO j = 7 , 107 IGRaph(1,j) = hyphen IGRaph(45,j) = hyphen ENDDO DO j = 7 , 107 , 25 IGRaph(1,j) = alphai IGRaph(45,j) = alphai ENDDO DO j = 20 , 107 , 25 IGRaph(1,j) = alphai IGRaph(45,j) = alphai ENDDO ! ! DETERMINE THE (X,Y) PLOT POSITIONS ! ratioy = 40.0_wp/(ymax-ymin) ratiox = 100.0_wp/(xmax-xmin) DO i = 1 , N IF ( Y(i)<cutoff ) THEN IF ( X(i)<cutoff ) THEN IF ( Char(i)<cutoff ) THEN mx = ratiox*(X(i)-xmin) + 0.5_wp mx = mx + 7 my = ratioy*(Y(i)-ymin) + 0.5_wp my = 43 - my iarg = 37 IF ( 0.5_wp<Char(i) .AND. Char(i)<36.5_wp ) iarg = Char(i) & & + 0.5_wp IGRaph(my,mx) = iplotc(iarg) ENDIF ENDIF ENDIF ENDDO ! ! WRITE OUT THE GRAPH ! DO i = 1 , 45 ip2 = i + 2 iflag = ip2 - (ip2/5)*5 k = ip2/5 IF ( iflag/=0 ) WRITE (G_IO,99009) (IGRaph(i,j),j=1,109) ! 99009 FORMAT (' ',20X,109A1) IF ( iflag==0 ) WRITE (G_IO,99010) ylable(k) , & & (IGRaph(i,j),j=1,109) 99010 FORMAT (' ',F20.7,109A1) ENDDO WRITE (G_IO,99011) xmin , x25 , xmid , x75 , xmax 99011 FORMAT (' ',14X,F20.7,5X,F20.7,5X,F20.7,5X,F20.7,1X,F20.7) ! 99012 FORMAT (' ','**************************************************', & & '********************') 99013 FORMAT (' ',' FATAL ERROR ') 99014 FORMAT (' ','THE ',A4,A4,' INPUT ARGUMENT TO THE ',A4,A4, & & ' SUBROUTINE') 99015 FORMAT (' ','HAS ALL ELEMENTS = ',E15.8) 99016 FORMAT (' ','HAS ALL ELEMENTS IN EXCESS OF THE CUTOFF') 99017 FORMAT (' ','VALUE OF ',E15.8) ! END SUBROUTINE PLOTC !> !!##NAME !! plotco(3f) - [M_datapac:GENERIC_LINE_PLOT] generate a line printer !! autocorrelation plot !! !!##SYNOPSIS !! !! SUBROUTINE PLOTCO(Y,N) !! !! REAL(kind=wp) :: Y(:) !! INTEGER :: N !! !!##DESCRIPTION !! This routine yields a multi-page (if necessary) plot of the !! autocorrelation coefficient r(k) versus the lag k. !! !! There is no restriction on the maximum value of n for this routine. !! !!##OPTIONS !! X description of parameter !! Y description of parameter !! !!##EXAMPLES !! !! Sample program: !! !! program demo_plotco !! use M_datapac, only : plotco !! implicit none !! ! call plotco(x,y) !! end program demo_plotco !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the Statistical !! Engineering Division, National Institute of Standards and Technology. !!##MAINTAINER !! John Urban, 2022.05.31 !!##LICENSE !! CC0-1.0 ! UPDATED -- JUN 1972 ! UPDATED -- UPDATED FEB 1975 ! UPDATED -- NOVEMBER 1975. ! UPDATED -- FEBRUARY 1976. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE PLOTCO(Y,N) REAL(kind=wp) :: hold, ratioy, Y(:), ylable(11), ymax, ymin INTEGER i, iaxdel, idel, iflag, imax, imin, ix(25), ixmax, ixmin, iz, j, jmax, jmin, k, mx, my, N, numpag ! CHARACTER(len=4) :: IGRaph CHARACTER(len=4) :: blank, star, hyphen, alphai COMMON /BLOCK1/ IGRaph(55,130) ! DATA blank, star, hyphen, alphai/' ', '*', '-', 'I'/ ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( N<1 ) THEN WRITE (G_IO,99001) 99001 FORMAT (' ***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE PLOTCO SUBROUTINE IS NON-POSITIVE *****') WRITE (G_IO,99002) N 99002 FORMAT (' ','***** THE VALUE OF THE ARGUMENT IS ',I0,' *****') RETURN ELSEIF ( N==1 ) THEN WRITE (G_IO,99003) 99003 FORMAT (' ***** NON-FATAL DIAGNOSTIC--THE SECOND INPUT ARGUMENT TO THE PLOTCO SUBROUTINE HAS THE VALUE 1 *****') RETURN ELSE hold = Y(1) DO i = 2 , N IF ( Y(i)/=hold ) GOTO 50 ENDDO WRITE (G_IO,99004) hold 99004 FORMAT (' ', & &'***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT (A VECTOR) & &TO THE PLOTCO SUBROUTINE HAS ALL ELEMENTS = ',E15.8,' *****') ! !-----START POINT----------------------------------------------------- ! ! DETERMINE THE Y VALUES TO BE LISTED ON THE LEFT VERTICAL AXIS ! 50 ymin = -1.0_wp ymax = 1.0_wp DO i = 1 , 11 ylable(i) = FLOAT(6-i)/5.0_wp ENDDO ! ! DETERMINE DISTANCES BETWEEN HORIZONTAL PLOT POINTS AND DISTANCES BETWEEN ! HASH MARKS ON THE X AXIS ! IF ( N<=24 ) idel = 5 IF ( 25<=N .AND. N<=40 ) idel = 3 IF ( 41<=N .AND. N<=60 ) idel = 2 IF ( 61<=N ) idel = 1 iaxdel = 10 IF ( N<=24 ) iaxdel = 5 IF ( 25<=N .AND. N<=40 ) iaxdel = 15 ! ! DETERMINE THE NUMBER OF pages THE PLOT WILL TAKE UP ! numpag = ((N-1)/120) + 1 ! ! OPERATE ON EACH page ! DO iz = 1 , numpag ! ! DETERMINE THE X-AXIS VALUES ! ixmin = 0 ixmax = N IF ( N<=24 ) THEN DO i = 1 , 25 ix(i) = i - 1 ENDDO ELSEIF ( 25<=N .AND. N<=40 ) THEN DO i = 1 , 9 ix(i) = 5*(i-1) ENDDO ELSEIF ( 41<=N .AND. N<=60 ) THEN DO i = 1 , 13 ix(i) = 5*(i-1) ENDDO ELSE ixmax = 120*iz ixmin = ixmax - 120 i = 0 DO i = i + 1 ix(i) = ixmin + 10*(i-1) IF ( i>=13 ) EXIT ENDDO ENDIF ! ! BLANK OUT THE GRAPH ! DO i = 1 , 55 DO j = 1 , 130 IGRaph(i,j) = blank ENDDO ENDDO ! ! PRODUCE THE Y AXIS ! DO i = 5 , 55 IGRaph(i,10) = alphai IGRaph(i,130) = alphai ENDDO DO i = 5 , 55 , 5 IGRaph(i,10) = hyphen IGRaph(i,130) = hyphen ENDDO ! ! PRODUCE THE X AXIS ! DO j = 10 , 130 IGRaph(55,j) = hyphen IGRaph(30,j) = hyphen IGRaph(5,j) = hyphen ENDDO DO j = 10 , 130 , iaxdel IGRaph(55,j) = alphai IGRaph(5,j) = alphai ENDDO ! ! DETERMINE THE (X,Y) PLOT POSITIONS ! imin = ixmin + 1 imax = ixmax IF ( imax>N ) imax = N ratioy = 50.0_wp/(ymax-ymin) DO i = imin , imax mx = MOD(i,120) mx = mx*idel IF ( mx==0 ) mx = 120 mx = mx + 10 my = ratioy*(Y(i)-ymin) + 0.5_wp my = 55 - my IGRaph(my,mx) = star jmax = MAX0(my,30) jmin = MIN0(my,30) DO j = jmin , jmax IGRaph(j,mx) = star ENDDO ENDDO ! ! WRITE OUT THE GRAPH ! WRITE (G_IO,99005) 99005 FORMAT ('1') IF ( iz==1 ) WRITE (G_IO,99006) N 99006 FORMAT ( ' THE TOTAL NUMBER OF POINTS PLOTTED (ON ALL pages) IS ',I0) IF ( iz>=2 ) WRITE (G_IO,99007) 99007 FORMAT (' THE PLOT ON THIS page IS A CONTINUATION OF THE PLOT ON THE PREVIOUS page') WRITE (G_IO,99008) 99008 FORMAT (' ') IF ( N<=24 ) WRITE (G_IO,99011) (ix(i),i=1,25) IF ( 25<=N .AND. N<=40 ) WRITE (G_IO,99012) (ix(i),i=1,9) IF ( 41<=N ) WRITE (G_IO,99013) (ix(i),i=1,13) DO i = 5 , 55 iflag = i - (i/5)*5 k = i/5 IF ( iflag/=0 ) WRITE (G_IO,99009) (IGRaph(i,j),j=1,130) 99009 FORMAT (' ',130A1) IF ( iflag==0 ) WRITE (G_IO,99010) ylable(k) , (IGRaph(i,j),j=10,130) 99010 FORMAT (' ',F9.2,130A1) ENDDO IF ( N<=24 ) WRITE (G_IO,99011) (ix(i),i=1,25) IF ( 25<=N .AND. N<=40 ) WRITE (G_IO,99012) (ix(i),i=1,9) IF ( 41<=N ) WRITE (G_IO,99013) (ix(i),i=1,13) ENDDO ENDIF 99011 FORMAT (' ',6X,24(I4,1X),I4) 99012 FORMAT (' ',6X,8(I4,11X),I4) 99013 FORMAT (' ',6X,12(I4,6X),I4) END SUBROUTINE PLOTCO !> !!##NAME !! plotct(3f) - [M_datapac:GENERIC_LINE_PLOT] generate a line printer !! plot for the terminal (71 characters wide) !! !!##SYNOPSIS !! !! SUBROUTINE PLOTCT(Y,X,Char,N) !! !!##DESCRIPTION !! !! plotct(3f) yields a narrow-width (71-character) plot of y(i) versus !! x(i) with special plotting characters. !! !! its narrow width makes it appropriate for use on a terminal. !! !! this 'special plotting character' capability allows the data analyst !! to incorporate information from a third variable (aside from y and x) !! into the plot. !! !! the plot character used at the i-th plotting position (that is, !! at the coordinate (x(i),y(i))) will be !! !! 1 if char(i) is between 0.5 and 1.5 !! 2 if char(i) is between 1.5 and 2.5 !! . !! . !! . !! 9 if char(i) is between 8.5 and 9.5 !! 0 if char(i) is between 9.5 and 10.5 !! a if char(i) is between 10.5 and 11.5 !! b if char(i) is between 11.5 and 12.5 !! c if char(i) is between 12.5 and 13.5 !! . !! . !! . !! w if char(i) is between 32.5 and 33.5 !! x if char(i) is between 33.5 and 34.5 !! y if char(i) is between 34.5 and 35.5 !! z if char(i) is between 35.5 and 36.5 !! x if char(i) is any value outside the range !! 0.5 to 36.5. !! !!##OPTIONS !! X description of parameter !! Y description of parameter !! !!##EXAMPLES !! !! Sample program: !! !! program demo_plotct !! use M_datapac, only : plotct !! implicit none !! ! call plotct(x,y) !! end program demo_plotct !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !! !!##REFERENCES !! * FILLIBEN, 'STATISTICAL ANALYSIS OF INTERLAB FATIGUE TIME DATA', !! UNPUBLISHED MANUSCRIPT (AVAILABLE FROM AUTHOR) PRESENTED AT THE !! 'COMPUTER-ASSISTED DATA ANALYSIS' SESSION AT THE NATIONAL MEETING OF THE !! AMERICAN STATISTICAL ASSOCIATION, NEW YORK CITY, DECEMBER 27-30, 1973. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE PLOTCT(Y,X,Char,N) REAL(kind=wp) :: aim1 , airow , anumcm , anumlm , anumr , anumrm , Char , & & cutoff , delx , dely , hold , X , xlable , xmax , xmin , & & xwidth , Y , ylable , ylower , ymax REAL(kind=wp) :: ymin , yupper , ywidth INTEGER :: i , ia , icol , icolmx , irow , ixdel , N , n2 , & & numcol , numlab , numr25 , numr50 , numr75 , numrow ! ! INPUT ARGUMENTS--Y = THE VECTOR OF ! (UNSORTED OR SORTED) OBSERVATIONS ! TO BE PLOTTED VERTICALLY. ! --X = THE VECTOR OF ! (UNSORTED OR SORTED) OBSERVATIONS ! TO BE PLOTTED HORIZONTALLY. ! --CHAR = THE VECTOR OF ! OBSERVATIONS WHICH CONTROL THE ! VALUE OF EACH INDIVIDUAL PLOT ! CHARACTER. ! --N = THE INTEGER NUMBER OF OBSERVATIONS ! IN THE VECTOR Y. ! OUTPUT--A NARROW-WIDTH (71-CHARACTER) TERMINAL PLOT ! OF Y(I) VERSUS X(I) WITH SPECIAL PLOT CHARACTERS. ! THE BODY OF THE PLOT (NOT COUNTING AXIS VALUES ! AND MARGINS) IS 25 ROWS (LINES) AND 49 COLUMNS. ! PRINTING--YES. ! RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE ! OF N FOR THIS SUBROUTINE. ! MODE OF INTERNAL OPERATIONS--. ! COMMENT--VALUES IN THE VERTICAL AXIS VECTOR (Y), ! THE HORIZONTAL AXIS VECTOR (X), ! OR THE PLOT CHARACTER VECTOR (CHAR) WHICH ARE ! EQUAL TO OR IN EXCESS OF 10.0**10 WILL NOT BE ! PLOTTED. ! THIS CONVENTION GREATLY SIMPLIFIES THE PROBLEM ! OF PLOTTING WHEN SOME ELEMENTS IN THE VECTOR Y ! (OR X, OR CHAR) ARE 'MISSING DATA', OR WHEN WE PURPOSELY ! WANT TO IGNORE CERTAIN ELEMENTS IN THE VECTOR Y ! (OR X, OR CHAR) FOR PLOTTING PURPOSES (THAT IS, WE DO NOT ! WANT CERTAIN ELEMENTS IN Y (OR X, OR CHAR) TO BE ! PLOTTED). ! TO CAUSE SPECIFIC ELEMENTS IN Y (OR X, OR CHAR) TO BE ! IGNORED, WE REPLACE THE ELEMENTS BEFOREHAND ! (BY, FOR EXAMPLE, USE OF THE REPLAC SUBROUTINE) ! BY SOME LARGE VALUE (LIKE, SAY, 10.0**10) AND ! THEY WILL SUBSEQUENTLY BE IGNORED IN THE PLOTC ! SUBROUTINE. ! --NOTE THAT THE STORAGE REQUIREMENTS FOR THIS ! (AND THE OTHER) TERMINAL PLOT SUBROUTINESS ARE . ! VERY SMALL. ! THIS IS DUE TO THE 'ONE LINE AT A TIME' ALGORITHM ! EMPLOYED FOR THE PLOT. ! ORIGINAL VERSION--FEBRUARY 1974. ! UPDATED --APRIL 1974. ! UPDATED --OCTOBER 1974. ! UPDATED --OCTOBER 1975. ! UPDATED --NOVEMBER 1975. ! UPDATED --FEBRUARY 1977. ! !--------------------------------------------------------------------- ! CHARACTER(len=4) :: iline CHARACTER(len=4) :: iplotc CHARACTER(len=4) :: jplotc CHARACTER(len=4) :: iaxisc CHARACTER(len=4) :: sbnam1 , sbnam2 CHARACTER(len=4) :: alph11 , alph12 , alph21 , alph22 , alph31 , alph32 CHARACTER(len=4) :: alph41 , alph42 CHARACTER(len=4) :: blank , hyphen , alphai ! DIMENSION Y(:) DIMENSION X(:) DIMENSION Char(:) DIMENSION iline(72) , xlable(10) DIMENSION iplotc(37) ! DATA sbnam1 , sbnam2/'PLOT' , 'CT '/ DATA alph11 , alph12/'FIRS' , 'T '/ DATA alph21 , alph22/'SECO' , 'ND '/ DATA alph31 , alph32/'THIR' , 'D '/ DATA alph41 , alph42/'FOUR' , 'TH '/ DATA blank , hyphen , alphai/' ' , '-' , 'I'/ DATA iplotc(1) , iplotc(2) , iplotc(3) , iplotc(4) , iplotc(5) , & & iplotc(6) , iplotc(7) , iplotc(8) , iplotc(9) , iplotc(10) , & & iplotc(11) , iplotc(12) , iplotc(13) , iplotc(14) , & & iplotc(15) , iplotc(16) , iplotc(17) , iplotc(18) , & & iplotc(19) , iplotc(20) , iplotc(21) , iplotc(22) , & & iplotc(23) , iplotc(24) , iplotc(25) , iplotc(26) , & & iplotc(27) , iplotc(28) , iplotc(29) , iplotc(30) , & & iplotc(31) , iplotc(32) , iplotc(33) , iplotc(34) , & & iplotc(35) , iplotc(36) , iplotc(37)/'1' , '2' , '3' , '4' , & & '5' , '6' , '7' , '8' , '9' , '0' , 'A' , 'B' , 'C' , 'D' , & & 'E' , 'F' , 'G' , 'H' , 'I' , 'J' , 'K' , 'L' , 'M' , 'N' , & & 'O' , 'P' , 'Q' , 'R' , 'S' , 'T' , 'U' , 'V' , 'W' , 'X' , & & 'Y' , 'Z' , 'X'/ ! cutoff = (10.0_wp**10) - 1000.0_wp ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( N<1 ) THEN WRITE (G_IO,99012) WRITE (G_IO,99013) WRITE (G_IO,99014) alph41 , alph42 , sbnam1 , sbnam2 WRITE (G_IO,99001) N 99001 FORMAT (' ','IS NON-NEGATIVE (WITH VALUE = ',I0,')') WRITE (G_IO,99012) RETURN ELSE IF ( N==1 ) THEN WRITE (G_IO,99012) WRITE (G_IO,99013) WRITE (G_IO,99014) alph41 , alph42 , sbnam1 , sbnam2 WRITE (G_IO,99002) N 99002 FORMAT (' ','HAS THE VALUE 1') WRITE (G_IO,99012) RETURN ELSE ! hold = Y(1) DO i = 2 , N IF ( Y(i)/=hold ) GOTO 50 ENDDO WRITE (G_IO,99012) WRITE (G_IO,99013) WRITE (G_IO,99014) alph11 , alph12 , sbnam1 , sbnam2 WRITE (G_IO,99015) hold WRITE (G_IO,99012) RETURN ENDIF 50 hold = X(1) DO i = 2 , N IF ( X(i)/=hold ) GOTO 100 ENDDO WRITE (G_IO,99012) WRITE (G_IO,99013) WRITE (G_IO,99014) alph21 , alph22 , sbnam1 , sbnam2 WRITE (G_IO,99015) hold WRITE (G_IO,99012) RETURN ENDIF 100 hold = Char(1) DO i = 2 , N IF ( Char(i)/=hold ) GOTO 200 ENDDO WRITE (G_IO,99012) WRITE (G_IO,99003) 99003 FORMAT (' ',' NON-FATAL DIAGNOSTIC ') WRITE (G_IO,99014) alph31 , alph32 , sbnam1 , sbnam2 WRITE (G_IO,99015) hold WRITE (G_IO,99012) ! 200 DO i = 1 , N IF ( Y(i)<cutoff ) GOTO 300 ENDDO WRITE (G_IO,99012) WRITE (G_IO,99013) WRITE (G_IO,99014) alph11 , alph12 , sbnam1 , sbnam2 WRITE (G_IO,99016) WRITE (G_IO,99017) cutoff WRITE (G_IO,99012) RETURN 300 DO i = 1 , N IF ( X(i)<cutoff ) GOTO 400 ENDDO WRITE (G_IO,99012) WRITE (G_IO,99013) WRITE (G_IO,99014) alph21 , alph22 , sbnam1 , sbnam2 WRITE (G_IO,99016) WRITE (G_IO,99017) cutoff WRITE (G_IO,99012) RETURN 400 DO i = 1 , N IF ( Char(i)<cutoff ) GOTO 500 ENDDO WRITE (G_IO,99012) WRITE (G_IO,99013) WRITE (G_IO,99014) alph31 , alph32 , sbnam1 , sbnam2 WRITE (G_IO,99016) WRITE (G_IO,99017) cutoff WRITE (G_IO,99012) RETURN ! 500 n2 = 0 DO i = 1 , N IF ( Y(i)<cutoff .AND. X(i)<cutoff .AND. Char(i)<cutoff ) THEN n2 = n2 + 1 IF ( n2>=2 ) GOTO 600 ENDIF ENDDO WRITE (G_IO,99012) WRITE (G_IO,99013) WRITE (G_IO,99004) alph11 , alph12 , alph21 , alph22 , alph31 , & & alph32 99004 FORMAT (' ','THE ',A4,A4,', ',A4,A4,', AND ',A4,A4) WRITE (G_IO,99005) sbnam1 , sbnam2 99005 FORMAT (' ','INPUT ARGUMENTS TO THE ',A4,A4,' SUBROUTINE') WRITE (G_IO,99006) 99006 FORMAT (' ','ARE SUCH THAT TOO MANY POINTS HAVE BEEN', & & ' EXCLUDED FROM THE PLOT.') WRITE (G_IO,99007) n2 99007 FORMAT (' ','ONLY ',I0,' POINTS ARE LEFT TO BE PLOTTED.') WRITE (G_IO,99012) RETURN ! !-----START POINT----------------------------------------------------- ! ! DEFINE THE NUMBER OF ROWS AND COLUMNS WITHIN THE PLOT--THIS HAS ! BEEN SET TO 25 ROWS AND 49 COLUMNS. ! 600 numrow = 25 numcol = 49 anumr = numrow anumrm = numrow - 1 anumcm = numcol - 1 numr25 = (numrow/4) + 1 numr50 = (numrow/2) + 1 numr75 = 3*(numrow/4) + 1 ixdel = (numcol-1)/4 numlab = 5 anumlm = numlab - 1 ! ! SKIP A LINE, WRITE OUT AN IDENTIFYING LINE FOR THE TYPE OF PLOT, ! WRITE OUT THE TOP HORIZONTAL AXIS OF THE PLOT, AND SKIP 1 LINE ! FOR A MARGIN WITHIN THE PLOT. ! WRITE (G_IO,99008) 99008 FORMAT (' ') WRITE (G_IO,99009) ! 99009 FORMAT (' ','THE FOLLOWING IS A PLOT OF Y(I) VERSUS X(I)') DO icol = 1 , numcol iline(icol) = hyphen ENDDO DO icol = 1 , numcol , ixdel iline(icol) = alphai ENDDO WRITE (G_IO,99018) (iline(i),i=1,numcol) WRITE (G_IO,99019) blank ! ! DETERMINE THE MIN AND MAX VALUES OF Y, AND OF X. ! DO i = 1 , N IF ( Y(i)<cutoff ) THEN IF ( X(i)<cutoff ) THEN IF ( Char(i)<cutoff ) THEN ymin = Y(i) ymax = Y(i) xmin = X(i) xmax = X(i) EXIT ENDIF ENDIF ENDIF ENDDO DO i = 1 , N IF ( Y(i)<cutoff ) THEN IF ( X(i)<cutoff ) THEN IF ( Char(i)<cutoff ) THEN IF ( Y(i)<ymin ) ymin = Y(i) IF ( Y(i)>ymax ) ymax = Y(i) IF ( X(i)<xmin ) xmin = X(i) IF ( X(i)>xmax ) xmax = X(i) ENDIF ENDIF ENDIF ENDDO dely = ymax - ymin delx = xmax - xmin ywidth = dely/anumrm xwidth = delx/anumcm ! ! DETERMINE AND WRITE OUT THE PLOT POSITIONS ONE LINE AT A TIME. ! ALSO DETERMINE THE APPROPRIATE PLOT CHARACTERS. ! DO irow = 1 , numrow DO icol = 1 , numcol iline(icol) = blank ENDDO airow = irow yupper = ymax + (1.5_wp-airow)*ywidth ylable = ymax + (1.0_wp-airow)*ywidth ylower = ymax + (0.5_wp-airow)*ywidth IF ( irow==numrow ) ylable = ymin DO i = 1 , N IF ( Y(i)<cutoff ) THEN IF ( X(i)<cutoff ) THEN IF ( Char(i)<cutoff ) THEN IF ( ylower<=Y(i) .AND. Y(i)<yupper ) THEN icol = ((X(i)-xmin)/xwidth) + 1.5_wp ia = Char(i) + 0.5_wp IF ( 1<=ia .AND. ia<=36 ) THEN jplotc = iplotc(ia) ELSE jplotc = iplotc(37) ENDIF iline(icol) = jplotc ENDIF ENDIF ENDIF ENDIF ENDDO icolmx = 1 DO icol = 1 , numcol IF ( iline(icol)/=blank ) icolmx = icol ENDDO iaxisc = alphai IF ( irow==1 .OR. irow==numrow ) iaxisc = hyphen IF ( irow==numr25 .OR. irow==numr50 .OR. irow==numr75 ) & & iaxisc = hyphen WRITE (G_IO,99010) ylable , iaxisc , (iline(icol),icol=1,icolmx) 99010 FORMAT (' ',E14.7,1X,A1,2X,50A1) ENDDO ! ! SKIP 1 LINE FOR A BOTTOM MARGIN WITHIN THE PLOT, WRITE OUT THE ! BOTTOM HORIZONTAL AXIS, AND WRITE OUT THE X AXIS LABELS. ! WRITE (G_IO,99019) blank DO icol = 1 , numcol iline(icol) = hyphen ENDDO DO icol = 1 , numcol , ixdel iline(icol) = alphai ENDDO WRITE (G_IO,99018) (iline(icol),icol=1,numcol) DO i = 1 , numlab aim1 = i - 1 xlable(i) = xmin + (aim1/anumlm)*delx ENDDO WRITE (G_IO,99011) (xlable(i),i=1,numlab) 99011 FORMAT (' ',9X,5E12.4) ! 99012 FORMAT (' ','**************************************************', & & '********************') 99013 FORMAT (' ',' FATAL ERROR ') 99014 FORMAT (' ','THE ',A4,A4,' INPUT ARGUMENT TO THE ',A4,A4, & & ' SUBROUTINE') 99015 FORMAT (' ','HAS ALL ELEMENTS = ',E15.8) 99016 FORMAT (' ','HAS ALL ELEMENTS IN EXCESS OF THE CUTOFF') 99017 FORMAT (' ','VALUE OF ',E15.8) 99018 FORMAT (' ',18X,54A1) 99019 FORMAT (' ',15X,A1) ! END SUBROUTINE PLOTCT !> !!##NAME !! plot(3f) - [M_datapac:GENERIC_LINE_PLOT] yields a one-page printer !! plot of Y(I) versus X(I) !! !!##SYNOPSIS !! !! Subroutine plot (X, Y, N) !! !! Real(kind=wp) :: (In) :: X(:) !! Real(kind=wp) :: (In) :: Y(:) !! Integer, Intent (In) :: N !! !!##DESCRIPTION !! This subroutine yields a one-page printer plot of Y(I) versus X(I). !! !! Values in the vertical axis vector (Y) or the horizontal axis vector !! (X) which are equal to or in excess of 10.0**10 will not be plotted. !! !! This convention greatly simplifies the problem of plotting when !! some elements in the vector Y (or X) are 'missing data', or when !! we purposely want to ignore certain elements in the vector Y (or X) !! for plotting purposes (That is, we do not want certain elements in !! Y (or X) to be plotted). To cause specific elements in Y (or X) !! to be ignored, we replace the elements beforehand (by, for example, !! use of the REPLAC subroutine) by some large value (like, say, !! 10.0**10) and they will subsequently be ignored in the plot subroutine. !! !!##OPTIONS !! Y The REAL vector of (unsorted or sorted) observations !! to be plotted vertically. !! X The REAL vector of (unsorted or sorted) observations !! to be plotted horizontally. !! N The integer number of observations in the vector Y. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_plot !! use M_datapac, only : plot !! implicit none !! integer :: i !! real, allocatable :: x(:), y(:) !! x=[(real(i),i=1,30)] !! y=0.075*(x**4)-0.525*(x**3)+0.75*(x**2)+2.40 !! call plot(x,y,size(x)) !! y=[(real(i)/10.0,i=1,30)] !! x=y**3.78-6*y**2.52+9*y**1.26 !! call plot(x,y,size(x)) !! end program demo_plot !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the Statistical !! Engineering Division, National Institute of Standards and Technology. !!##MAINTAINER !! John Urban, 2022.05.31 !!##LICENSE !! CC0-1.0 ! ORIGINAL VERSION--JUNE 1972. ! UPDATED --OCTOBER 1974. ! UPDATED --NOVEMBER 1974. ! UPDATED --JANUARY 1975. ! UPDATED --JULY 1975. ! UPDATED --SEPTEMBER 1975. ! UPDATED --OCTOBER 1975. ! UPDATED --NOVEMBER 1975. ! UPDATED --FEBRUARY 1976. ! UPDATED --FEBRUARY 1977. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE PLOT(Y,X,N) REAL(kind=wp),intent(in) :: X(:), Y(:) integer,intent(in) :: n REAL(kind=wp) :: aim1, cutoff, hold, ratiox, ratioy, x25, x75, xmax, xmid, xmin, ymax, ymin REAL(kind=wp) :: ylable(11) INTEGER i, iflag, ip2, j, k, mx, my, n2 ! !--------------------------------------------------------------------- ! CHARACTER(len=4) :: IGRaph CHARACTER(len=4) :: sbnam1 , sbnam2 CHARACTER(len=4) :: alph11 , alph12 , alph21 , alph22 , alph31 , alph32 CHARACTER(len=4) :: blank , hyphen , alphai , alphax CHARACTER(len=4) :: alpham , alphaa , alphad , alphan , equal COMMON /BLOCK1/ IGRaph(55,130) ! DATA sbnam1 , sbnam2/'PLOT' , ' '/ DATA alph11 , alph12/'FIRS' , 'T '/ DATA alph21 , alph22/'SECO' , 'ND '/ DATA alph31 , alph32/'THIR' , 'D '/ DATA blank , hyphen , alphai , alphax/' ' , '-' , 'I' , 'X'/ DATA alpham , alphaa , alphad , alphan , equal/'M' , 'A' , 'D' , 'N' , '='/ ! cutoff = (10.0_wp**10) - 1000.0_wp ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! WRITE (G_IO,99001) 99001 FORMAT ('1') IF ( N<1 ) THEN WRITE (G_IO,99011) WRITE (G_IO,99012) WRITE (G_IO,99013) alph31 , alph32 , sbnam1 , sbnam2 WRITE (G_IO,99002) N 99002 FORMAT (' ','IS NON-NEGATIVE (WITH VALUE = ',I0,')') WRITE (G_IO,99011) RETURN ELSE IF ( N==1 ) THEN WRITE (G_IO,99011) WRITE (G_IO,99012) WRITE (G_IO,99013) alph31 , alph32 , sbnam1 , sbnam2 WRITE (G_IO,99003) N 99003 FORMAT (' ','HAS THE VALUE 1') WRITE (G_IO,99011) RETURN ELSE ! hold = Y(1) DO i = 2 , N IF ( Y(i)/=hold ) GOTO 50 ENDDO WRITE (G_IO,99011) WRITE (G_IO,99012) WRITE (G_IO,99013) alph11 , alph12 , sbnam1 , sbnam2 WRITE (G_IO,99014) hold WRITE (G_IO,99011) RETURN ENDIF 50 hold = X(1) DO i = 2 , N IF ( X(i)/=hold ) GOTO 100 ENDDO WRITE (G_IO,99011) WRITE (G_IO,99012) WRITE (G_IO,99013) alph21 , alph22 , sbnam1 , sbnam2 WRITE (G_IO,99014) hold WRITE (G_IO,99011) RETURN ENDIF ! 100 DO i = 1 , N IF ( Y(i)<cutoff ) GOTO 200 ENDDO WRITE (G_IO,99011) WRITE (G_IO,99012) WRITE (G_IO,99013) alph11 , alph12 , sbnam1 , sbnam2 WRITE (G_IO,99015) WRITE (G_IO,99016) cutoff WRITE (G_IO,99011) RETURN 200 DO i = 1 , N IF ( X(i)<cutoff ) GOTO 300 ENDDO WRITE (G_IO,99011) WRITE (G_IO,99012) WRITE (G_IO,99013) alph21 , alph22 , sbnam1 , sbnam2 WRITE (G_IO,99015) WRITE (G_IO,99016) cutoff WRITE (G_IO,99011) RETURN ! 300 n2 = 0 DO i = 1 , N IF ( Y(i)<cutoff .AND. X(i)<cutoff ) THEN n2 = n2 + 1 IF ( n2>=2 ) GOTO 400 ENDIF ENDDO WRITE (G_IO,99011) WRITE (G_IO,99012) WRITE (G_IO,99004) alph11 , alph12 , alph21 , alph22 99004 FORMAT (' ','THE ',A4,A4,', AND ',A4,A4) WRITE (G_IO,99005) sbnam1 , sbnam2 99005 FORMAT (' ','INPUT ARGUMENTS TO THE ',A4,A4,' SUBROUTINE') WRITE (G_IO,99006) 99006 FORMAT (' ','ARE SUCH THAT TOO MANY POINTS HAVE BEEN EXCLUDED FROM THE PLOT.') WRITE (G_IO,99007) n2 99007 FORMAT (' ','ONLY ',I0,' POINTS ARE LEFT TO BE PLOTTED.') WRITE (G_IO,99011) RETURN ! !-----START POINT----------------------------------------------------- ! ! DETERMINE THE VALUES TO BE LISTED ON THE LEFT VERTICAL AXIS ! 400 DO i = 1 , N IF ( Y(i)<cutoff ) THEN IF ( X(i)<cutoff ) THEN ymin = Y(i) ymax = Y(i) EXIT ENDIF ENDIF ENDDO DO i = 1 , N IF ( Y(i)<cutoff ) THEN IF ( X(i)<cutoff ) THEN IF ( Y(i)<ymin ) ymin = Y(i) IF ( Y(i)>ymax ) ymax = Y(i) ENDIF ENDIF ENDDO DO i = 1 , 9 aim1 = i - 1 ylable(i) = ymax - (aim1/8.0_wp)*(ymax-ymin) ENDDO ! ! DETERMINE THE VALUES TO BE LISTED ON THE BOTTOM HORIZONTAL AXIS ! DETERMINE XMIN, XMAX, XMID, X25 (=THE 25% POINT), AND ! X75 (=THE 75% POINT) ! DO i = 1 , N IF ( Y(i)<cutoff ) THEN IF ( X(i)<cutoff ) THEN xmin = X(i) xmax = X(i) EXIT ENDIF ENDIF ENDDO DO i = 1 , N IF ( Y(i)<cutoff ) THEN IF ( X(i)<cutoff ) THEN IF ( X(i)<xmin ) xmin = X(i) IF ( X(i)>xmax ) xmax = X(i) ENDIF ENDIF ENDDO xmid = (xmin+xmax)/2.0_wp x25 = 0.75_wp*xmin + 0.25_wp*xmax x75 = 0.25_wp*xmin + 0.75_wp*xmax ! ! BLANK OUT THE GRAPH ! DO i = 1 , 45 DO j = 1 , 109 IGRaph(i,j) = blank ENDDO ENDDO ! ! PRODUCE THE VERTICAL AXES ! DO i = 3 , 43 IGRaph(i,5) = alphai IGRaph(i,109) = alphai ENDDO DO i = 3 , 43 , 5 IGRaph(i,5) = hyphen IGRaph(i,109) = hyphen ENDDO IGRaph(3,1) = equal IGRaph(3,2) = alpham IGRaph(3,3) = alphaa IGRaph(3,4) = alphax IGRaph(23,1) = equal IGRaph(23,2) = alpham IGRaph(23,3) = alphai IGRaph(23,4) = alphad IGRaph(43,1) = equal IGRaph(43,2) = alpham IGRaph(43,3) = alphai IGRaph(43,4) = alphan ! ! PRODUCE THE HORIZONTAL AXES ! DO j = 7 , 107 IGRaph(1,j) = hyphen IGRaph(45,j) = hyphen ENDDO DO j = 7 , 107 , 25 IGRaph(1,j) = alphai IGRaph(45,j) = alphai ENDDO DO j = 20 , 107 , 25 IGRaph(1,j) = alphai IGRaph(45,j) = alphai ENDDO ! ! DETERMINE THE (X,Y) PLOT POSITIONS ! ratioy = 40.0_wp/(ymax-ymin) ratiox = 100.0_wp/(xmax-xmin) DO i = 1 , N IF ( Y(i)<cutoff ) THEN IF ( X(i)<cutoff ) THEN mx = ratiox*(X(i)-xmin) + 0.5_wp mx = mx + 7 my = ratioy*(Y(i)-ymin) + 0.5_wp my = 43 - my IGRaph(my,mx) = alphax ENDIF ENDIF ENDDO ! ! WRITE OUT THE GRAPH ! DO i = 1 , 45 ip2 = i + 2 iflag = ip2 - (ip2/5)*5 k = ip2/5 IF ( iflag/=0 ) WRITE (G_IO,99008) (IGRaph(i,j),j=1,109) ! IF ( iflag==0 ) WRITE (G_IO,99009) ylable(k) ,(IGRaph(i,j),j=1,109) ENDDO 99008 FORMAT (' ',20X,109A1) 99009 FORMAT (' ',F20.7,109A1) WRITE (G_IO,99010) xmin , x25 , xmid , x75 , xmax 99010 FORMAT (' ',14X,F20.7,5X,F20.7,5X,F20.7,5X,F20.7,1X,F20.7) ! 99011 FORMAT (' ','**********************************************************************') 99012 FORMAT (' ',' FATAL ERROR ') 99013 FORMAT (' ','THE ',A4,A4,' INPUT ARGUMENT TO THE ',A4,A4,' SUBROUTINE') 99014 FORMAT (' ','HAS ALL ELEMENTS = ',E15.8) 99015 FORMAT (' ','HAS ALL ELEMENTS IN EXCESS OF THE CUTOFF') 99016 FORMAT (' ','VALUE OF ',E15.8) ! END SUBROUTINE PLOT !> !!##NAME !! plotsc(3f) - [M_datapac:GENERIC_LINE_PLOT] generate a line printer !! plot with special plot characters !! !!##SYNOPSIS !! !! SUBROUTINE PLOTSC(Y,X,Char,N,D,Dmin,Dmax) !! !!##DESCRIPTION !! plotsc(3f) yields a one-page printer plot of y(i) versus x(i): !! !! 1. with special plot characters; and !! 2. with only those points (x(i),y(i)) plotted !! for which the corresponding value of d(i) !! is between the specified values of dmin and dmax. !! !! the 'special plotting character' capability allows the data analyst !! to incorporate information from a third variable (aside from y and x) !! into the plot. !! !! the plot character used at the i-th plotting position (that is, !! at the coordinate (x(i),y(i))) will be !! !! 1 if char(i) is between 0.5 and 1.5 !! 2 if char(i) is between 1.5 and 2.5 !! . !! . !! . !! 9 if char(i) is between 8.5 and 9.5 !! 0 if char(i) is between 9.5 and 10.5 !! a if char(i) is between 10.5 and 11.5 !! b if char(i) is between 11.5 and 12.5 !! c if char(i) is between 12.5 and 13.5 !! . !! . !! . !! w if char(i) is between 32.5 and 33.5 !! x if char(i) is between 33.5 and 34.5 !! y if char(i) is between 34.5 and 35.5 !! z if char(i) is between 35.5 and 36.5 !! x if char(i) is any value outside the range !! 0.5 to 36.5. !! !! the use of the subset definition vector d gives the data analyst !! the capability of plotting subsets of the data, where the subset is !! defined by values in the vector d. !! !! !!##OPTIONS !! X description of parameter !! Y description of parameter !! !!##EXAMPLES !! !! Sample program: !! !! program demo_plotsc !! use M_datapac, only : plotsc !! implicit none !! ! call plotsc(x,y) !! end program demo_plotsc !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the Statistical !! Engineering Division, National Institute of Standards and Technology. !!##MAINTAINER !! John Urban, 2022.05.31 !!##LICENSE !! CC0-1.0 !!##REFERENCES !! * FILLIBEN, 'STATISTICAL ANALYSIS OF INTERLAB FATIGUE TIME DATA', !! UNPUBLISHED MANUSCRIPT (AVAILABLE FROM AUTHOR) PRESENTED AT THE !! 'COMPUTER-ASSISTED DATA ANALYSIS' SESSION AT THE NATIONAL MEETING OF THE !! AMERICAN STATISTICAL ASSOCIATION, NEW YORK CITY, DECEMBER 27-30, 1973. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE PLOTSC(Y,X,Char,N,D,Dmin,Dmax) REAL(kind=wp) :: aim1 , Char , cutoff , D , Dmax , Dmin , hold , ratiox , & & ratioy , X , x25 , x75 , xmax , xmid , xmin , Y , ylable , & & ymax , ymin INTEGER :: i , iarg , iflag , ip2 , j , k , mx , my , N , n2 ! ! INPUT ARGUMENTS--Y = THE VECTOR OF ! (UNSORTED OR SORTED) OBSERVATIONS ! TO BE PLOTTED VERTICALLY. ! --X = THE VECTOR OF ! (UNSORTED OR SORTED) OBSERVATIONS ! TO BE PLOTTED HORIZONTALLY. ! --CHAR = THE VECTOR OF ! OBSERVATIONS WHICH CONTROL THE ! VALUE OF EACH INDIVIDUAL PLOT ! CHARACTER. ! --N = THE INTEGER NUMBER OF OBSERVATIONS ! IN THE VECTOR Y. ! --D = THE VECTOR ! WHICH 'DEFINES' THE VARIOUS ! POSSIBLE SUBSETS. ! --DMIN = THE VALUE ! WHICH DEFINES THE LOWER BOUND ! (INCLUSIVELY) OF THE PARTICULAR ! SUBSET OF INTEREST TO BE PLOTTED. ! --DMAX = THE VALUE ! WHICH DEFINES THE UPPER BOUND ! (INCLUSIVELY) OF THE PARTICULAR ! SUBSET OF INTEREST TO BE PLOTTED. ! OUTPUT--A ONE-page PRINTER PLOT OF Y(I) VERSUS X(I), ! WITH SPECIAL PLOT CHARACTERS, ! AND FOR ONLY OF A SPECIFIED SUBSET OF THE DATA. ! PRINTING--YES. ! RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE ! OF N FOR THIS SUBROUTINE. ! MODE OF INTERNAL OPERATIONS--. ! COMMENT--FOR A GIVEN DUMMY INDEX I, ! IF D(I) IS SMALLER THAN DMIN OR LARGER THAN DMAX, ! THEN THE CORRESPONDING POINT (X(I),Y(I)) ! WILL NOT BE PLOTTED. ! --VALUES IN THE VERTICAL AXIS VECTOR (Y), ! THE HORIZONTAL AXIS VECTOR (X), ! OR THE PLOT CHARACTER VECTOR (CHAR) WHICH ARE ! EQUAL TO OR IN EXCESS OF 10.0**10 WILL NOT BE ! PLOTTED. ! THIS CONVENTION GREATLY SIMPLIFIES THE PROBLEM ! OF PLOTTING WHEN SOME ELEMENTS IN THE VECTOR Y ! (OR X, OR CHAR) ARE 'MISSING DATA', OR WHEN WE PURPOSELY ! WANT TO IGNORE CERTAIN ELEMENTS IN THE VECTOR Y ! (OR X, OR CHAR) FOR PLOTTING PURPOSES (THAT IS, WE DO NOT ! WANT CERTAIN ELEMENTS IN Y (OR X, OR CHAR) TO BE ! PLOTTED). ! TO CAUSE SPECIFIC ELEMENTS IN Y (OR X, OR CHAR) TO BE ! IGNORED, WE REPLACE THE ELEMENTS BEFOREHAND ! (BY, FOR EXAMPLE, USE OF THE REPLAC SUBROUTINE) ! BY SOME LARGE VALUE (LIKE, SAY, 10.0**10) AND ! THEY WILL SUBSEQUENTLY BE IGNORED IN THE PLOTC ! SUBROUTINE. ! ORIGINAL VERSION--OCTOBER 1975. ! UPDATED --NOVEMBER 1975. ! UPDATED --FEBRUARY 1976. ! UPDATED --FEBRUARY 1977. ! !--------------------------------------------------------------------- ! CHARACTER(len=4) :: IGRaph CHARACTER(len=4) :: iplotc CHARACTER(len=4) :: sbnam1 , sbnam2 CHARACTER(len=4) :: alph11 , alph12 , alph21 , alph22 , alph31 , alph32 CHARACTER(len=4) :: alph41 , alph42 , alph51 , alph52 CHARACTER(len=4) :: blank , hyphen , alphai , alphax CHARACTER(len=4) :: alpham , alphaa , alphad , alphan , equal ! DIMENSION Y(:) DIMENSION X(:) DIMENSION D(:) DIMENSION Char(:) DIMENSION ylable(11) DIMENSION iplotc(37) COMMON /BLOCK1/ IGRaph(55,130) ! DATA sbnam1 , sbnam2/'PLOT' , 'SC '/ DATA alph11 , alph12/'FIRS' , 'T '/ DATA alph21 , alph22/'SECO' , 'ND '/ DATA alph31 , alph32/'THIR' , 'D '/ DATA alph41 , alph42/'FOUR' , 'TH '/ DATA alph51 , alph52/'FIFT' , 'H '/ DATA blank , hyphen , alphai , alphax/' ' , '-' , 'I' , 'X'/ DATA alpham , alphaa , alphad , alphan , equal/'M' , 'A' , 'D' , & & 'N' , '='/ DATA iplotc(1) , iplotc(2) , iplotc(3) , iplotc(4) , iplotc(5) , & & iplotc(6) , iplotc(7) , iplotc(8) , iplotc(9) , iplotc(10) , & & iplotc(11) , iplotc(12) , iplotc(13) , iplotc(14) , & & iplotc(15) , iplotc(16) , iplotc(17) , iplotc(18) , & & iplotc(19) , iplotc(20) , iplotc(21) , iplotc(22) , & & iplotc(23) , iplotc(24) , iplotc(25) , iplotc(26) , & & iplotc(27) , iplotc(28) , iplotc(29) , iplotc(30) , & & iplotc(31) , iplotc(32) , iplotc(33) , iplotc(34) , & & iplotc(35) , iplotc(36) , iplotc(37)/'1' , '2' , '3' , '4' , & & '5' , '6' , '7' , '8' , '9' , '0' , 'A' , 'B' , 'C' , 'D' , & & 'E' , 'F' , 'G' , 'H' , 'I' , 'J' , 'K' , 'L' , 'M' , 'N' , & & 'O' , 'P' , 'Q' , 'R' , 'S' , 'T' , 'U' , 'V' , 'W' , 'X' , & & 'Y' , 'Z' , 'X'/ ! cutoff = (10.0_wp**10) - 1000.0_wp ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! WRITE (G_IO,99001) 99001 FORMAT ('1') IF ( N<1 ) THEN WRITE (G_IO,99014) WRITE (G_IO,99015) WRITE (G_IO,99017) alph41 , alph42 , sbnam1 , sbnam2 WRITE (G_IO,99002) N 99002 FORMAT (' ','IS NON-NEGATIVE (WITH VALUE = ',I0,')') WRITE (G_IO,99014) RETURN ELSE IF ( N==1 ) THEN WRITE (G_IO,99014) WRITE (G_IO,99015) WRITE (G_IO,99017) alph41 , alph42 , sbnam1 , sbnam2 WRITE (G_IO,99003) N 99003 FORMAT (' ','HAS THE VALUE 1') WRITE (G_IO,99014) RETURN ELSE ! hold = Y(1) DO i = 2 , N IF ( Y(i)/=hold ) GOTO 50 ENDDO WRITE (G_IO,99014) WRITE (G_IO,99015) WRITE (G_IO,99017) alph11 , alph12 , sbnam1 , sbnam2 WRITE (G_IO,99018) hold WRITE (G_IO,99014) RETURN ENDIF 50 hold = X(1) DO i = 2 , N IF ( X(i)/=hold ) GOTO 100 ENDDO WRITE (G_IO,99014) WRITE (G_IO,99015) WRITE (G_IO,99017) alph21 , alph22 , sbnam1 , sbnam2 WRITE (G_IO,99018) hold WRITE (G_IO,99014) RETURN ENDIF 100 hold = Char(1) DO i = 2 , N IF ( Char(i)/=hold ) GOTO 200 ENDDO WRITE (G_IO,99014) WRITE (G_IO,99016) WRITE (G_IO,99017) alph31 , alph32 , sbnam1 , sbnam2 WRITE (G_IO,99018) hold WRITE (G_IO,99014) 200 hold = D(1) DO i = 2 , N IF ( D(i)/=hold ) GOTO 300 ENDDO WRITE (G_IO,99014) WRITE (G_IO,99016) WRITE (G_IO,99017) alph51 , alph52 , sbnam1 , sbnam2 WRITE (G_IO,99018) hold WRITE (G_IO,99014) ! 300 DO i = 1 , N IF ( Y(i)<cutoff ) GOTO 400 ENDDO WRITE (G_IO,99014) WRITE (G_IO,99015) WRITE (G_IO,99017) alph11 , alph12 , sbnam1 , sbnam2 WRITE (G_IO,99019) WRITE (G_IO,99020) cutoff WRITE (G_IO,99014) RETURN 400 DO i = 1 , N IF ( X(i)<cutoff ) GOTO 500 ENDDO WRITE (G_IO,99014) WRITE (G_IO,99015) WRITE (G_IO,99017) alph21 , alph22 , sbnam1 , sbnam2 WRITE (G_IO,99019) WRITE (G_IO,99020) cutoff WRITE (G_IO,99014) RETURN 500 DO i = 1 , N IF ( Char(i)<cutoff ) GOTO 600 ENDDO WRITE (G_IO,99014) WRITE (G_IO,99015) WRITE (G_IO,99017) alph31 , alph32 , sbnam1 , sbnam2 WRITE (G_IO,99019) WRITE (G_IO,99020) cutoff WRITE (G_IO,99014) RETURN 600 DO i = 1 , N IF ( D(i)<cutoff ) GOTO 700 ENDDO WRITE (G_IO,99014) WRITE (G_IO,99015) WRITE (G_IO,99017) alph51 , alph52 , sbnam1 , sbnam2 WRITE (G_IO,99019) WRITE (G_IO,99020) cutoff WRITE (G_IO,99014) RETURN ! 700 DO i = 1 , N IF ( Dmin<D(i) .AND. D(i)<Dmax ) GOTO 800 ENDDO WRITE (G_IO,99014) WRITE (G_IO,99015) WRITE (G_IO,99017) alph51 , alph52 , sbnam1 , sbnam2 WRITE (G_IO,99004) 99004 FORMAT (' ','HAS ALL ELEMENTS OUTSIDE THE INTERVAL') WRITE (G_IO,99005) Dmin , Dmax 99005 FORMAT (' ','(',E15.8,',',E15.8,')',' AS DEFINED BY') WRITE (G_IO,99006) 99006 FORMAT (' ','THE SIXTH AND SEVENTH INPUT ARGUMENTS.') WRITE (G_IO,99014) RETURN ! 800 n2 = 0 DO i = 1 , N IF ( Y(i)<cutoff .AND. X(i)<cutoff .AND. Char(i)<cutoff .AND. & & D(i)<cutoff ) THEN IF ( Dmin<D(i) .AND. D(i)<Dmax ) n2 = n2 + 1 IF ( n2>=2 ) GOTO 900 ENDIF ENDDO WRITE (G_IO,99014) WRITE (G_IO,99015) WRITE (G_IO,99007) alph11 , alph12 , alph21 , alph22 , alph31 , & & alph32 , alph51 , alph52 99007 FORMAT (' ','THE ',A4,A4,', ',A4,A4,', ',A4,A4,', AND ',A4,A4) WRITE (G_IO,99008) sbnam1 , sbnam2 99008 FORMAT (' ','INPUT ARGUMENTS TO THE ',A4,A4,' SUBROUTINE') WRITE (G_IO,99009) 99009 FORMAT (' ','ARE SUCH THAT TOO MANY POINTS HAVE BEEN', & & ' EXCLUDED FROM THE PLOT.') WRITE (G_IO,99010) n2 99010 FORMAT (' ','ONLY ',I0,' POINTS ARE LEFT TO BE PLOTTED.') WRITE (G_IO,99014) RETURN ! !-----START POINT----------------------------------------------------- ! ! DETERMINE THE VALUES TO BE LISTED ON THE LEFT VERTICAL AXIS ! 900 DO i = 1 , N IF ( Y(i)<cutoff ) THEN IF ( X(i)<cutoff ) THEN IF ( Char(i)<cutoff ) THEN IF ( D(i)>=Dmin ) THEN IF ( D(i)<=Dmax ) THEN ymin = Y(i) ymax = Y(i) EXIT ENDIF ENDIF ENDIF ENDIF ENDIF ENDDO DO i = 1 , N IF ( Y(i)<cutoff ) THEN IF ( X(i)<cutoff ) THEN IF ( Char(i)<cutoff ) THEN IF ( D(i)>=Dmin ) THEN IF ( D(i)<=Dmax ) THEN IF ( Y(i)<ymin ) ymin = Y(i) IF ( Y(i)>ymax ) ymax = Y(i) ENDIF ENDIF ENDIF ENDIF ENDIF ENDDO DO i = 1 , 9 aim1 = i - 1 ylable(i) = ymax - (aim1/8.0_wp)*(ymax-ymin) ENDDO ! ! DETERMINE THE VALUES TO BE LISTED ON THE BOTTOM HORIZONTAL AXIS ! DETERMINE XMIN, XMAX, XMID, X25 (=THE 25% POINT), AND ! X75 (=THE 75% POINT) ! DO i = 1 , N IF ( Y(i)<cutoff ) THEN IF ( X(i)<cutoff ) THEN IF ( Char(i)<cutoff ) THEN IF ( D(i)>=Dmin ) THEN IF ( D(i)<=Dmax ) THEN xmin = X(i) xmax = X(i) EXIT ENDIF ENDIF ENDIF ENDIF ENDIF ENDDO DO i = 1 , N IF ( Y(i)<cutoff ) THEN IF ( X(i)<cutoff ) THEN IF ( Char(i)<cutoff ) THEN IF ( D(i)>=Dmin ) THEN IF ( D(i)<=Dmax ) THEN IF ( X(i)<xmin ) xmin = X(i) IF ( X(i)>xmax ) xmax = X(i) ENDIF ENDIF ENDIF ENDIF ENDIF ENDDO xmid = (xmin+xmax)/2.0_wp x25 = 0.75_wp*xmin + 0.25_wp*xmax x75 = 0.25_wp*xmin + 0.75_wp*xmax ! ! BLANK OUT THE GRAPH ! DO i = 1 , 45 DO j = 1 , 109 IGRaph(i,j) = blank ENDDO ENDDO ! ! PRODUCE THE VERTICAL AXES ! DO i = 3 , 43 IGRaph(i,5) = alphai IGRaph(i,109) = alphai ENDDO DO i = 3 , 43 , 5 IGRaph(i,5) = hyphen IGRaph(i,109) = hyphen ENDDO IGRaph(3,1) = equal IGRaph(3,2) = alpham IGRaph(3,3) = alphaa IGRaph(3,4) = alphax IGRaph(23,1) = equal IGRaph(23,2) = alpham IGRaph(23,3) = alphai IGRaph(23,4) = alphad IGRaph(43,1) = equal IGRaph(43,2) = alpham IGRaph(43,3) = alphai IGRaph(43,4) = alphan ! ! PRODUCE THE HORIZONTAL AXES ! DO j = 7 , 107 IGRaph(1,j) = hyphen IGRaph(45,j) = hyphen ENDDO DO j = 7 , 107 , 25 IGRaph(1,j) = alphai IGRaph(45,j) = alphai ENDDO DO j = 20 , 107 , 25 IGRaph(1,j) = alphai IGRaph(45,j) = alphai ENDDO ! ! DETERMINE THE (X,Y) PLOT POSITIONS ! ratioy = 40.0_wp/(ymax-ymin) ratiox = 100.0_wp/(xmax-xmin) DO i = 1 , N IF ( Y(i)<cutoff ) THEN IF ( X(i)<cutoff ) THEN IF ( Char(i)<cutoff ) THEN IF ( D(i)>=Dmin ) THEN IF ( D(i)<=Dmax ) THEN mx = ratiox*(X(i)-xmin) + 0.5_wp mx = mx + 7 my = ratioy*(Y(i)-ymin) + 0.5_wp my = 43 - my iarg = 37 IF ( 0.5_wp<Char(i) .AND. Char(i)<36.5_wp ) & & iarg = Char(i) + 0.5_wp IGRaph(my,mx) = iplotc(iarg) ENDIF ENDIF ENDIF ENDIF ENDIF ENDDO ! ! WRITE OUT THE GRAPH ! DO i = 1 , 45 ip2 = i + 2 iflag = ip2 - (ip2/5)*5 k = ip2/5 IF ( iflag/=0 ) WRITE (G_IO,99011) (IGRaph(i,j),j=1,109) ! 99011 FORMAT (' ',20X,109A1) IF ( iflag==0 ) WRITE (G_IO,99012) ylable(k) , & & (IGRaph(i,j),j=1,109) 99012 FORMAT (' ',F20.7,109A1) ENDDO WRITE (G_IO,99013) xmin , x25 , xmid , x75 , xmax 99013 FORMAT (' ',14X,F20.7,5X,F20.7,5X,F20.7,5X,F20.7,1X,F20.7) ! 99014 FORMAT (' ','**************************************************', & & '********************') 99015 FORMAT (' ',' FATAL ERROR ') 99016 FORMAT (' ',' NON-FATAL DIAGNOSTIC ') 99017 FORMAT (' ','THE ',A4,A4,' INPUT ARGUMENT TO THE ',A4,A4, & & ' SUBROUTINE') 99018 FORMAT (' ','HAS ALL ELEMENTS = ',E15.8) 99019 FORMAT (' ','HAS ALL ELEMENTS IN EXCESS OF THE CUTOFF') 99020 FORMAT (' ','VALUE OF ',E15.8) ! END SUBROUTINE PLOTSC !> !!##NAME !! plots(3f) - [M_datapac:GENERIC_LINE_PLOT] generate a line printer !! plot of Y vs X !! !!##SYNOPSIS !! !! SUBROUTINE PLOTS(Y,X,N,D,Dmin,Dmax) !! !!##DESCRIPTION !! plots(3f) yields a one-page printer plot of y(i) versus x(i): !! !! 1. with only those points (x(i),y(i)) plotted !! for which the corresponding value of d(i) !! is between the specified values of dmin and dmax. !! !! the use of the subset definition vector d gives the data analyst !! the capability of plotting subsets of the data, where the subset is !! defined by values in the vector d. !! !!##OPTIONS !! X description of parameter !! Y description of parameter !! !!##EXAMPLES !! !! Sample program: !! !! program demo_plots !! use M_datapac, only : plots !! implicit none !! ! call plots(x,y) !! end program demo_plots !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the Statistical !! Engineering Division, National Institute of Standards and Technology. !!##MAINTAINER !! John Urban, 2022.05.31 !!##LICENSE !! CC0-1.0 ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE PLOTS(Y,X,N,D,Dmin,Dmax) REAL(kind=wp) :: aim1 , cutoff , D , Dmax , Dmin , hold , ratiox , ratioy , & & X , x25 , x75 , xmax , xmid , xmin , Y , ylable , ymax , ymin INTEGER i , iflag , ip2 , j , k , mx , my , N , n2 ! ! INPUT ARGUMENTS--Y = THE VECTOR OF ! (UNSORTED OR SORTED) OBSERVATIONS ! TO BE PLOTTED VERTICALLY. ! --X = THE VECTOR OF ! (UNSORTED OR SORTED) OBSERVATIONS ! TO BE PLOTTED HORIZONTALLY. ! --N = THE INTEGER NUMBER OF OBSERVATIONS ! IN THE VECTOR Y. ! --D = THE VECTOR ! WHICH 'DEFINES' THE VARIOUS ! POSSIBLE SUBSETS. ! --DMIN = THE VALUE ! WHICH DEFINES THE LOWER BOUND ! (INCLUSIVELY) OF THE PARTICULAR ! SUBSET OF INTEREST TO BE PLOTTED. ! --DMAX = THE VALUE ! WHICH DEFINES THE UPPER BOUND ! (INCLUSIVELY) OF THE PARTICULAR ! SUBSET OF INTEREST TO BE PLOTTED. ! OUTPUT--A ONE-page PRINTER PLOT OF Y(I) VERSUS X(I), ! FOR ONLY OF A SPECIFIED SUBSET OF THE DATA. ! PRINTING--YES. ! COMMENT--FOR A GIVEN DUMMY INDEX I, ! IF D(I) IS SMALLER THAN DMIN OR LARGER THAN DMAX, ! THEN THE CORRESPONDING POINT (X(I),Y(I)) ! WILL NOT BE PLOTTED. ! --VALUES IN THE VERTICAL AXIS VECTOR (Y) ! OR THE HORIZONTAL AXIS VECTOR (X) WHICH ARE ! EQUAL TO OR IN EXCESS OF 10.0**10 WILL NOT BE ! PLOTTED. ! THIS CONVENTION GREATLY SIMPLIFIES THE PROBLEM ! OF PLOTTING WHEN SOME ELEMENTS IN THE VECTOR Y ! (OR X) ARE 'MISSING DATA', OR WHEN WE PURPOSELY ! WANT TO IGNORE CERTAIN ELEMENTS IN THE VECTOR Y ! (OR X) FOR PLOTTING PURPOSES (THAT IS, WE DO NOT ! WANT CERTAIN ELEMENTS IN Y (OR X) TO BE PLOTTED). ! TO CAUSE SPECIFIC ELEMENTS IN Y (OR X) TO BE ! IGNORED, WE REPLACE THE ELEMENTS BEFOREHAND ! (BY, FOR EXAMPLE, USE OF THE REPLAC SUBROUTINE) ! BY SOME LARGE VALUE (LIKE, SAY, 10.0**10) AND ! THEY WILL SUBSEQUENTLY BE IGNORED IN THE PLOT ! SUBROUTINE. ! ORIGINAL VERSION--OCTOBER 1975. ! UPDATED --NOVEMBER 1975. ! UPDATED --FEBRUARY 1977. ! !--------------------------------------------------------------------- ! CHARACTER(len=4) :: IGRaph CHARACTER(len=4) :: sbnam1 , sbnam2 CHARACTER(len=4) :: alph11 , alph12 , alph21 , alph22 , alph31 , alph32 CHARACTER(len=4) :: alph41 , alph42 CHARACTER(len=4) :: blank , hyphen , alphai , alphax CHARACTER(len=4) :: alpham , alphaa , alphad , alphan , equal ! DIMENSION Y(:) DIMENSION X(:) DIMENSION D(:) DIMENSION ylable(11) COMMON /BLOCK1/ IGRaph(55,130) ! DATA sbnam1 , sbnam2/'PLOT' , 'S '/ DATA alph11 , alph12/'FIRS' , 'T '/ DATA alph21 , alph22/'SECO' , 'ND '/ DATA alph31 , alph32/'THIR' , 'D '/ DATA alph41 , alph42/'FOUR' , 'TH '/ DATA blank , hyphen , alphai , alphax/' ' , '-' , 'I' , 'X'/ DATA alpham , alphaa , alphad , alphan , equal/'M' , 'A' , 'D' , & & 'N' , '='/ ! cutoff = (10.0_wp**10) - 1000.0_wp ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! WRITE (G_IO,99001) 99001 FORMAT ('1') IF ( N<1 ) THEN WRITE (G_IO,99015) WRITE (G_IO,99016) WRITE (G_IO,99017) alph31 , alph32 , sbnam1 , sbnam2 WRITE (G_IO,99002) N 99002 FORMAT (' ','IS NON-NEGATIVE (WITH VALUE = ',I0,')') WRITE (G_IO,99015) RETURN ELSE IF ( N==1 ) THEN WRITE (G_IO,99015) WRITE (G_IO,99016) WRITE (G_IO,99017) alph31 , alph32 , sbnam1 , sbnam2 WRITE (G_IO,99003) N 99003 FORMAT (' ','HAS THE VALUE 1') WRITE (G_IO,99015) RETURN ELSE ! hold = Y(1) DO i = 2 , N IF ( Y(i)/=hold ) GOTO 50 ENDDO WRITE (G_IO,99015) WRITE (G_IO,99016) WRITE (G_IO,99017) alph11 , alph12 , sbnam1 , sbnam2 WRITE (G_IO,99018) hold WRITE (G_IO,99015) RETURN ENDIF 50 hold = X(1) DO i = 2 , N IF ( X(i)/=hold ) GOTO 100 ENDDO WRITE (G_IO,99015) WRITE (G_IO,99016) WRITE (G_IO,99017) alph21 , alph22 , sbnam1 , sbnam2 WRITE (G_IO,99018) hold WRITE (G_IO,99015) RETURN ENDIF 100 hold = D(1) DO i = 2 , N IF ( D(i)/=hold ) GOTO 200 ENDDO WRITE (G_IO,99015) WRITE (G_IO,99004) 99004 FORMAT (' ',' NON-FATAL DIAGNOSTIC ') WRITE (G_IO,99017) alph41 , alph42 , sbnam1 , sbnam2 WRITE (G_IO,99018) hold WRITE (G_IO,99015) ! 200 DO i = 1 , N IF ( Y(i)<cutoff ) GOTO 300 ENDDO WRITE (G_IO,99015) WRITE (G_IO,99016) WRITE (G_IO,99017) alph11 , alph12 , sbnam1 , sbnam2 WRITE (G_IO,99019) WRITE (G_IO,99020) cutoff WRITE (G_IO,99015) RETURN 300 DO i = 1 , N IF ( X(i)<cutoff ) GOTO 400 ENDDO WRITE (G_IO,99015) WRITE (G_IO,99016) WRITE (G_IO,99017) alph21 , alph22 , sbnam1 , sbnam2 WRITE (G_IO,99019) WRITE (G_IO,99020) cutoff WRITE (G_IO,99015) RETURN 400 DO i = 1 , N IF ( D(i)<cutoff ) GOTO 500 ENDDO WRITE (G_IO,99015) WRITE (G_IO,99016) WRITE (G_IO,99017) alph41 , alph42 , sbnam1 , sbnam2 WRITE (G_IO,99019) WRITE (G_IO,99020) cutoff WRITE (G_IO,99015) RETURN ! 500 DO i = 1 , N IF ( Dmin<D(i) .AND. D(i)<Dmax ) GOTO 600 ENDDO WRITE (G_IO,99015) WRITE (G_IO,99016) WRITE (G_IO,99017) alph41 , alph42 , sbnam1 , sbnam2 WRITE (G_IO,99005) 99005 FORMAT (' ','HAS ALL ELEMENTS OUTSIDE THE INTERVAL') WRITE (G_IO,99006) Dmin , Dmax 99006 FORMAT (' ','(',E15.8,',',E15.8,')',' AS DEFINED BY') WRITE (G_IO,99007) 99007 FORMAT (' ','THE FIFTH AND SIXTH INPUT ARGUMENTS.') WRITE (G_IO,99015) RETURN ! 600 n2 = 0 DO i = 1 , N IF ( Y(i)<cutoff .AND. X(i)<cutoff .AND. D(i)<cutoff ) THEN IF ( Dmin<D(i) .AND. D(i)<Dmax ) n2 = n2 + 1 IF ( n2>=2 ) GOTO 700 ENDIF ENDDO WRITE (G_IO,99015) WRITE (G_IO,99016) WRITE (G_IO,99008) alph11 , alph12 , alph21 , alph22 , alph41 , & & alph42 99008 FORMAT (' ','THE ',A4,A4,', ',A4,A4,', AND ',A4,A4) WRITE (G_IO,99009) sbnam1 , sbnam2 99009 FORMAT (' ','INPUT ARGUMENTS TO THE ',A4,A4,' SUBROUTINE') WRITE (G_IO,99010) 99010 FORMAT (' ','ARE SUCH THAT TOO MANY POINTS HAVE BEEN', & & ' EXCLUDED FROM THE PLOT.') WRITE (G_IO,99011) n2 99011 FORMAT (' ','ONLY ',I0,' POINTS ARE LEFT TO BE PLOTTED.') WRITE (G_IO,99015) RETURN ! !-----START POINT----------------------------------------------------- ! ! DETERMINE THE VALUES TO BE LISTED ON THE LEFT VERTICAL AXIS ! 700 DO i = 1 , N IF ( Y(i)<cutoff ) THEN IF ( X(i)<cutoff ) THEN IF ( D(i)>=Dmin ) THEN IF ( D(i)<=Dmax ) THEN ymin = Y(i) ymax = Y(i) EXIT ENDIF ENDIF ENDIF ENDIF ENDDO DO i = 1 , N IF ( Y(i)<cutoff ) THEN IF ( X(i)<cutoff ) THEN IF ( D(i)>=Dmin ) THEN IF ( D(i)<=Dmax ) THEN IF ( Y(i)<ymin ) ymin = Y(i) IF ( Y(i)>ymax ) ymax = Y(i) ENDIF ENDIF ENDIF ENDIF ENDDO DO i = 1 , 9 aim1 = i - 1 ylable(i) = ymax - (aim1/8.0_wp)*(ymax-ymin) ENDDO ! ! DETERMINE THE VALUES TO BE LISTED ON THE BOTTOM HORIZONTAL AXIS ! DETERMINE XMIN, XMAX, XMID, X25 (=THE 25% POINT), AND ! X75 (=THE 75% POINT) ! DO i = 1 , N IF ( Y(i)<cutoff ) THEN IF ( X(i)<cutoff ) THEN IF ( D(i)>=Dmin ) THEN IF ( D(i)<=Dmax ) THEN xmin = X(i) xmax = X(i) EXIT ENDIF ENDIF ENDIF ENDIF ENDDO DO i = 1 , N IF ( Y(i)<cutoff ) THEN IF ( X(i)<cutoff ) THEN IF ( D(i)>=Dmin ) THEN IF ( D(i)<=Dmax ) THEN IF ( X(i)<xmin ) xmin = X(i) IF ( X(i)>xmax ) xmax = X(i) ENDIF ENDIF ENDIF ENDIF ENDDO xmid = (xmin+xmax)/2.0_wp x25 = 0.75_wp*xmin + 0.25_wp*xmax x75 = 0.25_wp*xmin + 0.75_wp*xmax ! ! BLANK OUT THE GRAPH ! DO i = 1 , 45 DO j = 1 , 109 IGRaph(i,j) = blank ENDDO ENDDO ! ! PRODUCE THE VERTICAL AXES ! DO i = 3 , 43 IGRaph(i,5) = alphai IGRaph(i,109) = alphai ENDDO DO i = 3 , 43 , 5 IGRaph(i,5) = hyphen IGRaph(i,109) = hyphen ENDDO IGRaph(3,1) = equal IGRaph(3,2) = alpham IGRaph(3,3) = alphaa IGRaph(3,4) = alphax IGRaph(23,1) = equal IGRaph(23,2) = alpham IGRaph(23,3) = alphai IGRaph(23,4) = alphad IGRaph(43,1) = equal IGRaph(43,2) = alpham IGRaph(43,3) = alphai IGRaph(43,4) = alphan ! ! PRODUCE THE HORIZONTAL AXES ! DO j = 7 , 107 IGRaph(1,j) = hyphen IGRaph(45,j) = hyphen ENDDO DO j = 7 , 107 , 25 IGRaph(1,j) = alphai IGRaph(45,j) = alphai ENDDO DO j = 20 , 107 , 25 IGRaph(1,j) = alphai IGRaph(45,j) = alphai ENDDO ! ! DETERMINE THE (X,Y) PLOT POSITIONS ! ratioy = 40.0_wp/(ymax-ymin) ratiox = 100.0_wp/(xmax-xmin) DO i = 1 , N IF ( Y(i)<cutoff ) THEN IF ( X(i)<cutoff ) THEN IF ( D(i)>=Dmin ) THEN IF ( D(i)<=Dmax ) THEN mx = ratiox*(X(i)-xmin) + 0.5_wp mx = mx + 7 my = ratioy*(Y(i)-ymin) + 0.5_wp my = 43 - my IGRaph(my,mx) = alphax ENDIF ENDIF ENDIF ENDIF ENDDO ! ! WRITE OUT THE GRAPH ! DO i = 1 , 45 ip2 = i + 2 iflag = ip2 - (ip2/5)*5 k = ip2/5 IF ( iflag/=0 ) WRITE (G_IO,99012) (IGRaph(i,j),j=1,109) ! 99012 FORMAT (' ',20X,109A1) IF ( iflag==0 ) WRITE (G_IO,99013) ylable(k) , & & (IGRaph(i,j),j=1,109) 99013 FORMAT (' ',F20.7,109A1) ENDDO WRITE (G_IO,99014) xmin , x25 , xmid , x75 , xmax 99014 FORMAT (' ',14X,F20.7,5X,F20.7,5X,F20.7,5X,F20.7,1X,F20.7) ! 99015 FORMAT (' ','**************************************************', & & '********************') 99016 FORMAT (' ',' FATAL ERROR ') 99017 FORMAT (' ','THE ',A4,A4,' INPUT ARGUMENT TO THE ',A4,A4, & & ' SUBROUTINE') 99018 FORMAT (' ','HAS ALL ELEMENTS = ',E15.8) 99019 FORMAT (' ','HAS ALL ELEMENTS IN EXCESS OF THE CUTOFF') 99020 FORMAT (' ','VALUE OF ',E15.8) ! END SUBROUTINE PLOTS !> !!##NAME !! plotsp(3f) - [M_datapac:LINE_PLOT] generate a line printer spectrum !! plot !! !!##SYNOPSIS !! !! SUBROUTINE PLOTSP(Y,N,Idf) !! !! REAL(kind=wp),intent(in) :: Y(:) !! INTEGER,intent(in) :: N !! INTEGER,intent(in) :: Idf !! !!##DESCRIPTION !! This routine yields a one-page plot of the spectrum, along with upper !! and lower limits of the spectrum. !! !! The convention has been followed that if the integer input parameter !! idf has the value 0, then no confidence limits will be computed and !! only the spectrum itself will be plotted out. !! !! Multiple plot points are not indicated. !! !! The first point will be plotted on the left vertical axis the !! last point will be plotted on the right vertical axis there is no !! restriction on the maximum value of n for this routine. !! !!##OPTIONS !! X description of parameter !! Y description of parameter !! !!##EXAMPLES !! !! Sample program: !! !! program demo_plotsp !! use M_datapac, only : plotsp !! implicit none !! ! call plotsp(x,y) !! end program demo_plotsp !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the Statistical !! Engineering Division, National Institute of Standards and Technology. !!##MAINTAINER !! John Urban, 2022.05.31 !!##LICENSE !! CC0-1.0 ! UPDATED --NOVEMBER 1975. ! UPDATED --FEBRUARY 1976. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE PLOTSP(Y,N,Idf) REAL(kind=wp),intent(in) :: Y(:) INTEGER,intent(in) :: N INTEGER,intent(in) :: Idf REAL(kind=wp) :: ai, an, df, hold, pp025, pp975, ratiox, ratioy, slower, spmax, spmin, supper, xi, ylable, ymax, ymin INTEGER :: i, iflag, j, k, mx, my ! !--------------------------------------------------------------------- ! CHARACTER(len=4) :: IGRaph CHARACTER(len=4) :: blank , hyphen , alphai , alphax , dot ! DIMENSION ylable(11) COMMON /BLOCK1/ IGRaph(55,130) ! DATA blank , hyphen , alphai/' ' , '-' , 'I'/ DATA alphax/'X'/ DATA dot/'.'/ ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( N<1 ) THEN WRITE (G_IO,99001) 99001 FORMAT (' ***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE PLOTSP SUBROUTINE IS NON-POSITIVE *****') WRITE (G_IO,99002) N 99002 FORMAT (' ***** THE VALUE OF THE ARGUMENT IS ',I0,' *****') RETURN ELSEIF ( N==1 ) THEN WRITE (G_IO,99003) 99003 FORMAT (' ***** NON-FATAL DIAGNOSTIC--THE SECOND INPUT ARGUMENT TO PLOTSP(3f) HAS THE VALUE 1 *****') RETURN ELSE hold = Y(1) DO i = 2 , N IF ( Y(i)/=hold ) GOTO 50 ENDDO WRITE (G_IO,99004) hold 99004 FORMAT (' ***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT (A VECTOR) TO PLOTSP(3f) HAS ALL ELEMENTS = ', & & E15.8,' *****') ! !-----START POINT----------------------------------------------------- ! 50 continue an = N ! ! DETERMINE THE MINIMUM AND MAXIMUM OF THE SPECTRUM ! spmin = Y(1) spmax = Y(1) DO i = 2 , N IF ( Y(i)<spmin ) spmin = Y(i) IF ( Y(i)>spmax ) spmax = Y(i) ENDDO ! ! COMPUTE THE MAXIMUM VALUE OF THE UPPER CONFIDENCE LIMIT ! AND THE MINIMUM VALUE OF THE LOWER CONFIDENCE LIMIT--THESE TWO VALUES ! WILL DEFINE THE RANGE OF VALUES TO BE LISTED ON THE VERTICAL AXIS ! IF ( Idf==0 ) THEN ymin = spmin ymax = spmax ELSE df = Idf CALL CHSPPF(0.975_wp,Idf,pp975) CALL CHSPPF(0.025_wp,Idf,pp025) ymax = df*spmax/pp025 ymin = df*spmin/pp975 ENDIF ! ! DETERMINE THE 11 VALUES TO BE LISTED ON THE LEFT VERTICAL AXIS ! DO i = 1 , 11 ylable(i) = ymax - ((FLOAT(i-1))/10.0_wp)*(ymax-ymin) ENDDO ! ! BLANK OUT THE GRAPH DO i = 1 , 55 DO j = 1 , 130 IGRaph(i,j) = blank ENDDO ENDDO ! ! PRODUCE THE Y AXIS DO i = 5 , 55 IGRaph(i,10) = alphai IGRaph(i,130) = alphai ENDDO DO i = 5 , 55 , 5 IGRaph(i,10) = hyphen IGRaph(i,130) = hyphen ENDDO ! ! PRODUCE THE X AXIS DO j = 10 , 130 IGRaph(55,j) = hyphen IGRaph(5,j) = hyphen ENDDO DO j = 10 , 130 , 10 IGRaph(55,j) = alphai IGRaph(5,j) = alphai ENDDO ! ! DETERMINE THE (X,Y) PLOT POSITIONS ratioy = 50.0_wp/(ymax-ymin) ratiox = 240.0_wp DO i = 1 , N ai = i xi = (ai-1.0_wp)/(2.0_wp*(an-1.0_wp)) mx = ratiox*xi + 0.5_wp mx = mx + 10 IF ( Idf/=0 ) THEN supper = df*Y(i)/pp025 slower = df*Y(i)/pp975 my = ratioy*(supper-ymin) + 0.5_wp my = 55 - my IGRaph(my,mx) = dot my = ratioy*(slower-ymin) + 0.5_wp my = 55 - my IGRaph(my,mx) = dot ENDIF my = ratioy*(Y(i)-ymin) + 0.5_wp my = 55 - my IGRaph(my,mx) = alphax ENDDO ! ! WRITE OUT THE GRAPH WRITE (G_IO,99005) 99005 FORMAT ('1') DO i = 5 , 55 iflag = i - (i/5)*5 k = i/5 IF ( iflag/=0 ) WRITE (G_IO,99006) (IGRaph(i,j),j=1,130) 99006 FORMAT (' ',130A1) IF ( iflag==0 ) WRITE (G_IO,99007) ylable(k) ,(IGRaph(i,j),j=10,130) 99007 FORMAT (' ',F9.2,130A1) ENDDO WRITE (G_IO,99008) 99008 FORMAT (& & ' FREQ .000 .042 .083 .125 .167 .208 .250& &.292 .333 .375 .417 .458 .500') WRITE (G_IO,99009) 99009 FORMAT (' ',& &'PERIOD INF 24.0 12.0 8.00 6.00 4.80 & & 4.00 3.43 3.00 2.67 2.40 2.18 2.00& &') ENDIF END SUBROUTINE PLOTSP !> !!##NAME !! plotst(3f) - [M_datapac:GENERIC_LINE_PLOT] generate a line printer !! plot of Y vs X for the terminal (71 characters wide) !! !!##SYNOPSIS !! !! SUBROUTINE PLOTST(Y,X,N,D,Dmin,Dmax) !! !!##DESCRIPTION !! !! plotst(3f) yields a narrow-width (71-character) of y(i) versus x(i): !! !! 1. with only those points (x(i),y(i)) plotted !! for which the corresponding value of d(i) !! is between the specified values of dmin and dmax. !! !! its narrow width makes it appropriate for use on a terminal. !! !! the use of the subset definition vector d gives the data analyst !! the capability of plotting subsets of the data, where the subset is !! defined by values in the vector d. !! !! ! INPUT ARGUMENTS--Y = THE VECTOR OF !! ! (UNSORTED OR SORTED) OBSERVATIONS !! ! TO BE PLOTTED VERTICALLY. !! ! --X = THE VECTOR OF !! ! (UNSORTED OR SORTED) OBSERVATIONS !! ! TO BE PLOTTED HORIZONTALLY. !! ! --N = THE INTEGER NUMBER OF OBSERVATIONS !! ! IN THE VECTOR Y. !! ! --D = THE VECTOR !! ! WHICH 'DEFINES' THE VARIOUS !! ! POSSIBLE SUBSETS. !! ! --DMIN = THE VALUE !! ! WHICH DEFINES THE LOWER BOUND !! ! (INCLUSIVELY) OF THE PARTICULAR !! ! SUBSET OF INTEREST TO BE PLOTTED. !! ! --DMAX = THE VALUE !! ! WHICH DEFINES THE UPPER BOUND !! ! (INCLUSIVELY) OF THE PARTICULAR !! ! SUBSET OF INTEREST TO BE PLOTTED. !! ! OUTPUT--A NARROW-WIDTH (71-CHARACTER) TERMINAL PLOT !! ! OF Y(I) VERSUS X(I), !! ! FOR ONLY OF A SPECIFIED SUBSET OF THE DATA. !! ! THE BODY OF THE PLOT (NOT COUNTING AXIS VALUES !! ! AND MARGINS) IS 25 ROWS (LINES) AND 49 COLUMNS. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_plotst !! use M_datapac, only : plotst !! implicit none !! ! call plotst(x,y) !! end program demo_plotst !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the Statistical !! Engineering Division, National Institute of Standards and Technology. !!##MAINTAINER !! John Urban, 2022.05.31 !!##LICENSE !! CC0-1.0 ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE PLOTST(Y,X,N,D,Dmin,Dmax) REAL(kind=wp) :: aim1 , airow , anumcm , anumlm , anumr , anumrm , cutoff , & & D , delx , dely , Dmax , Dmin , hold , X , xlable , xmax , & & xmin , xwidth , Y , ylable REAL(kind=wp) :: ylower , ymax , ymin , yupper , ywidth INTEGER :: i , icol , icolmx , irow , ixdel , N , n2 , numcol ,& & numlab , numr25 , numr50 , numr75 , numrow ! PRINTING--YES. ! RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE ! OF N FOR THIS SUBROUTINE. ! COMMENT--FOR A GIVEN DUMMY INDEX I, ! IF D(I) IS SMALLER THAN DMIN OR LARGER THAN DMAX, ! THEN THE CORRESPONDING POINT (X(I),Y(I)) ! WILL NOT BE PLOTTED. ! --VALUES IN THE VERTICAL AXIS VECTOR (Y) ! OR THE HORIZONTAL AXIS VECTOR (X) WHICH ARE ! EQUAL TO OR IN EXCESS OF 10.0**10 WILL NOT BE ! PLOTTED. ! THIS CONVENTION GREATLY SIMPLIFIES THE PROBLEM ! OF PLOTTING WHEN SOME ELEMENTS IN THE VECTOR Y ! (OR X) ARE 'MISSING DATA', OR WHEN WE PURPOSELY ! WANT TO IGNORE CERTAIN ELEMENTS IN THE VECTOR Y ! (OR X) FOR PLOTTING PURPOSES (THAT IS, WE DO NOT ! WANT CERTAIN ELEMENTS IN Y (OR X) TO BE PLOTTED). ! TO CAUSE SPECIFIC ELEMENTS IN Y (OR X) TO BE ! IGNORED, WE REPLACE THE ELEMENTS BEFOREHAND ! (BY, FOR EXAMPLE, USE OF THE REPLAC SUBROUTINE) ! BY SOME LARGE VALUE (LIKE, SAY, 10.0**10) AND ! THEY WILL SUBSEQUENTLY BE IGNORED IN THE PLOT ! SUBROUTINE. ! --NOTE THAT THE STORAGE REQUIREMENTS FOR THIS ! (AND THE OTHER) TERMINAL PLOT SUBROUTINESS ARE . ! VERY SMALL. ! THIS IS DUE TO THE 'ONE LINE AT A TIME' ALGORITHM ! EMPLOYED FOR THE PLOT. ! ORIGINAL VERSION--OCTOBER 1975. ! UPDATED --NOVEMBER 1975. ! UPDATED --FEBRUARY 1977. ! !--------------------------------------------------------------------- ! CHARACTER(len=4) :: iline CHARACTER(len=4) :: iaxisc CHARACTER(len=4) :: sbnam1 , sbnam2 CHARACTER(len=4) :: alph11 , alph12 , alph21 , alph22 , alph31 , alph32 CHARACTER(len=4) :: alph41 , alph42 CHARACTER(len=4) :: blank , hyphen , alphai , alphax ! DIMENSION Y(:) DIMENSION X(:) DIMENSION D(:) DIMENSION iline(72) , xlable(10) ! DATA sbnam1 , sbnam2/'PLOT' , 'ST '/ DATA alph11 , alph12/'FIRS' , 'T '/ DATA alph21 , alph22/'SECO' , 'ND '/ DATA alph31 , alph32/'THIR' , 'D '/ DATA alph41 , alph42/'FOUR' , 'TH '/ DATA blank , hyphen , alphai , alphax/' ' , '-' , 'I' , 'X'/ ! cutoff = (10.0_wp**10) - 1000.0_wp ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( N<1 ) THEN WRITE (G_IO,99015) WRITE (G_IO,99016) WRITE (G_IO,99017) alph31 , alph32 , sbnam1 , sbnam2 WRITE (G_IO,99001) N 99001 FORMAT (' ','IS NON-NEGATIVE (WITH VALUE = ',I0,')') WRITE (G_IO,99015) RETURN ELSE IF ( N==1 ) THEN WRITE (G_IO,99015) WRITE (G_IO,99016) WRITE (G_IO,99017) alph31 , alph32 , sbnam1 , sbnam2 WRITE (G_IO,99002) N 99002 FORMAT (' ','HAS THE VALUE 1') WRITE (G_IO,99015) RETURN ELSE ! hold = Y(1) DO i = 2 , N IF ( Y(i)/=hold ) GOTO 50 ENDDO WRITE (G_IO,99015) WRITE (G_IO,99016) WRITE (G_IO,99017) alph11 , alph12 , sbnam1 , sbnam2 WRITE (G_IO,99018) hold WRITE (G_IO,99015) RETURN ENDIF 50 hold = X(1) DO i = 2 , N IF ( X(i)/=hold ) GOTO 100 ENDDO WRITE (G_IO,99015) WRITE (G_IO,99016) WRITE (G_IO,99017) alph21 , alph22 , sbnam1 , sbnam2 WRITE (G_IO,99018) hold WRITE (G_IO,99015) RETURN ENDIF 100 hold = D(1) DO i = 2 , N IF ( D(i)/=hold ) GOTO 200 ENDDO WRITE (G_IO,99015) WRITE (G_IO,99003) 99003 FORMAT (' ',' NON-FATAL DIAGNOSTIC ') WRITE (G_IO,99017) alph41 , alph42 , sbnam1 , sbnam2 WRITE (G_IO,99018) hold WRITE (G_IO,99015) ! 200 DO i = 1 , N IF ( Y(i)<cutoff ) GOTO 300 ENDDO WRITE (G_IO,99015) WRITE (G_IO,99016) WRITE (G_IO,99017) alph11 , alph12 , sbnam1 , sbnam2 WRITE (G_IO,99019) WRITE (G_IO,99020) cutoff WRITE (G_IO,99015) RETURN 300 DO i = 1 , N IF ( X(i)<cutoff ) GOTO 400 ENDDO WRITE (G_IO,99015) WRITE (G_IO,99016) WRITE (G_IO,99017) alph21 , alph22 , sbnam1 , sbnam2 WRITE (G_IO,99019) WRITE (G_IO,99020) cutoff WRITE (G_IO,99015) RETURN 400 DO i = 1 , N IF ( D(i)<cutoff ) GOTO 500 ENDDO WRITE (G_IO,99015) WRITE (G_IO,99016) WRITE (G_IO,99017) alph41 , alph42 , sbnam1 , sbnam2 WRITE (G_IO,99019) WRITE (G_IO,99020) cutoff WRITE (G_IO,99015) RETURN ! 500 DO i = 1 , N IF ( Dmin<D(i) .AND. D(i)<Dmax ) GOTO 600 ENDDO WRITE (G_IO,99015) WRITE (G_IO,99016) WRITE (G_IO,99017) alph41 , alph42 , sbnam1 , sbnam2 WRITE (G_IO,99004) 99004 FORMAT (' ','HAS ALL ELEMENTS OUTSIDE THE INTERVAL') WRITE (G_IO,99005) Dmin , Dmax 99005 FORMAT (' ','(',E15.8,',',E15.8,')',' AS DEFINED BY') WRITE (G_IO,99006) 99006 FORMAT (' ','THE FIFTH AND SIXTH INPUT ARGUMENTS.') WRITE (G_IO,99015) RETURN ! 600 n2 = 0 DO i = 1 , N IF ( Y(i)<cutoff .AND. X(i)<cutoff .AND. D(i)<cutoff ) THEN IF ( Dmin<D(i) .AND. D(i)<Dmax ) n2 = n2 + 1 IF ( n2>=2 ) GOTO 700 ENDIF ENDDO WRITE (G_IO,99015) WRITE (G_IO,99016) WRITE (G_IO,99007) alph11 , alph12 , alph21 , alph22 , alph41 , & & alph42 99007 FORMAT (' ','THE ',A4,A4,', ',A4,A4,', AND ',A4,A4) WRITE (G_IO,99008) sbnam1 , sbnam2 99008 FORMAT (' ','INPUT ARGUMENTS TO THE ',A4,A4,' SUBROUTINE') WRITE (G_IO,99009) 99009 FORMAT (' ','ARE SUCH THAT TOO MANY POINTS HAVE BEEN', & & ' EXCLUDED FROM THE PLOT.') WRITE (G_IO,99010) n2 99010 FORMAT (' ','ONLY ',I0,' POINTS ARE LEFT TO BE PLOTTED.') WRITE (G_IO,99015) RETURN ! !-----START POINT----------------------------------------------------- ! ! DEFINE THE NUMBER OF ROWS AND COLUMNS WITHIN THE PLOT-- ! THIS HAS BEEN SET TO 25 ROWS AND 49 COLUMNS. ! 700 numrow = 25 numcol = 49 anumr = numrow anumrm = numrow - 1 anumcm = numcol - 1 numr25 = (numrow/4) + 1 numr50 = (numrow/2) + 1 numr75 = 3*(numrow/4) + 1 ixdel = (numcol-1)/4 numlab = 5 anumlm = numlab - 1 ! ! SKIP A LINE, WRITE OUT AN IDENTIFYING LINE FOR THE TYPE OF PLOT, ! WRITE OUT THE TOP HORIZONTAL AXIS OF THE PLOT, AND SKIP 1 LINE ! FOR A MARGIN WITHIN THE PLOT. ! WRITE (G_IO,99011) 99011 FORMAT (' ') WRITE (G_IO,99012) ! 99012 FORMAT (' ', & &'THE FOLLOWING IS A PLOT OF Y(I) (VERTICALLY) VERSUS X(I) (HORIZON& &TALLY)') DO icol = 1 , numcol iline(icol) = hyphen ENDDO DO icol = 1 , numcol , ixdel iline(icol) = alphai ENDDO WRITE (G_IO,99021) (iline(i),i=1,numcol) WRITE (G_IO,99022) blank ! ! DETERMINE THE MIN AND MAX VALUES OF Y, AND OF X. ! DO i = 1 , N IF ( Y(i)<cutoff ) THEN IF ( X(i)<cutoff ) THEN IF ( D(i)>=Dmin ) THEN IF ( D(i)<=Dmax ) THEN ymin = Y(i) ymax = Y(i) xmin = X(i) xmax = X(i) EXIT ENDIF ENDIF ENDIF ENDIF ENDDO DO i = 1 , N IF ( Y(i)<cutoff ) THEN IF ( X(i)<cutoff ) THEN IF ( D(i)>=Dmin ) THEN IF ( D(i)<=Dmax ) THEN IF ( Y(i)<ymin ) ymin = Y(i) IF ( Y(i)>ymax ) ymax = Y(i) IF ( X(i)<xmin ) xmin = X(i) IF ( X(i)>xmax ) xmax = X(i) ENDIF ENDIF ENDIF ENDIF ENDDO dely = ymax - ymin delx = xmax - xmin ywidth = dely/anumrm xwidth = delx/anumcm ! ! DETERMINE AND WRITE OUT THE PLOT POSITIONS ONE LINE AT A TIME. ! DO irow = 1 , numrow DO icol = 1 , numcol iline(icol) = blank ENDDO airow = irow yupper = ymax + (1.5_wp-airow)*ywidth ylable = ymax + (1.0_wp-airow)*ywidth ylower = ymax + (0.5_wp-airow)*ywidth IF ( irow==numrow ) ylable = ymin DO i = 1 , N IF ( Y(i)<cutoff ) THEN IF ( X(i)<cutoff ) THEN IF ( D(i)>=Dmin ) THEN IF ( D(i)<=Dmax ) THEN IF ( ylower<=Y(i) .AND. Y(i)<yupper ) THEN icol = ((X(i)-xmin)/xwidth) + 1.5_wp iline(icol) = alphax ENDIF ENDIF ENDIF ENDIF ENDIF ENDDO icolmx = 1 DO icol = 1 , numcol IF ( iline(icol)==alphax ) icolmx = icol ENDDO iaxisc = alphai IF ( irow==1 .OR. irow==numrow ) iaxisc = hyphen IF ( irow==numr25 .OR. irow==numr50 .OR. irow==numr75 ) & & iaxisc = hyphen WRITE (G_IO,99013) ylable , iaxisc , (iline(icol),icol=1,icolmx) 99013 FORMAT (' ',E14.7,1X,A1,2X,50A1) ENDDO ! ! SKIP 1 LINE FOR A BOTTOM MARGIN WITHIN THE PLOT, WRITE OUT THE ! BOTTOM HORIZONTAL AXIS, AND WRITE OUT THE X AXIS LABELS. ! WRITE (G_IO,99022) blank DO icol = 1 , numcol iline(icol) = hyphen ENDDO DO icol = 1 , numcol , ixdel iline(icol) = alphai ENDDO WRITE (G_IO,99021) (iline(icol),icol=1,numcol) DO i = 1 , numlab aim1 = i - 1 xlable(i) = xmin + (aim1/anumlm)*delx ENDDO WRITE (G_IO,99014) (xlable(i),i=1,numlab) 99014 FORMAT (' ',9X,5E12.4) ! 99015 FORMAT (' ','**************************************************', & & '********************') 99016 FORMAT (' ',' FATAL ERROR ') 99017 FORMAT (' ','THE ',A4,A4,' INPUT ARGUMENT TO THE ',A4,A4, & & ' SUBROUTINE') 99018 FORMAT (' ','HAS ALL ELEMENTS = ',E15.8) 99019 FORMAT (' ','HAS ALL ELEMENTS IN EXCESS OF THE CUTOFF') 99020 FORMAT (' ','VALUE OF ',E15.8) 99021 FORMAT (' ',18X,54A1) 99022 FORMAT (' ',15X,A1) ! END SUBROUTINE PLOTST !> !!##NAME !! plott(3f) - [M_datapac:GENERIC_LINE_PLOT] generate a line printer !! plot of Y vs X for the terminal (71 characters wide) !! !!##SYNOPSIS !! !! SUBROUTINE PLOTT(Y,X,N) !! !! REAL(kind=wp),intent(in) :: X(:) !! REAL(kind=wp),intent(in) :: Y(:) !! INTEGER,intent(in) :: N !! !!##DESCRIPTION !! !! PLOTT(3f) yields a narrow-width (71-character) plot of Y(i) versus !! X(i). Its narrow width makes it appropriate for use on a terminal. !! !! Note values in the vertical axis vector (y) or the horizontal axis !! vector (x) which are equal to or in excess of 10.0**10 will not !! be plotted. !! !! This convention greatly simplifies the problem of plotting when !! some elements in the vector y (or x) are 'missing data', or when !! we purposely want to ignore certain elements in the vector y (or x) !! for plotting purposes (that is, we do not want certain elements in !! y (or x) to be plotted). To cause specific elements in y (or x) !! to be ignored, we replace the elements beforehand (by, for example, !! use of the REPLAC(3f) subroutine) by some large value (like, say, !! 10.0**10) and they will subsequently be ignored in the plot subroutine. !! !! Note that the storage requirements for this (and the other) terminal !! plot subroutines are very small. This is due to the "one line at !! a time" algorithm employed for the plot. !! !!##INPUT ARGUMENTS !! !! Y The vector of (unsorted or sorted) observations to be plotted !! vertically. !! !! X The REAL vector of (unsorted or sorted) observations !! to be plotted horizontally. !! !! N The integer number of observations in the vector Y. !! There is no restriction on the maximum value of N for this !! subroutine. !! !!##OUTPUT !! A narrow-width (71-character) terminal plot of y(i) versus x(i). !! The body of the plot (not counting axis values and margins) is 25 rows !! (lines) and 49 columns. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_plott !! use M_datapac, only : plott, label !! implicit none !! integer :: i !! integer,parameter :: dp=kind(0.0d0) !! real(kind=dp), allocatable :: x(:), y(:) !! call label('plott') !! y=[(real(i)/10.0,i=1,30)] !! x=y**3.78-6*y**2.52+9*y**1.26 !! call plott(x,y,size(x)) !! end program demo_plott !! !! Results: !! !! The following is a plot of Y(I) (vertically) versus X(I) (horizontally) !! I-----------I-----------I-----------I-----------I !! 0.4000000E+01 - X X X X !! 0.3833356E+01 I X X !! 0.3666712E+01 I X !! 0.3500068E+01 I X !! 0.3333424E+01 I X !! 0.3166780E+01 I X !! 0.3000137E+01 - X !! 0.2833493E+01 I X !! 0.2666849E+01 I X !! 0.2500205E+01 I X !! 0.2333561E+01 I X !! 0.2166917E+01 I X !! 0.2000273E+01 - !! 0.1833629E+01 I !! 0.1666985E+01 I X X X !! 0.1500341E+01 I !! 0.1333698E+01 I X !! 0.1167054E+01 I !! 0.1000410E+01 - X !! 0.8337659E+00 I X X !! 0.6671220E+00 I !! 0.5004781E+00 I X X !! 0.3338342E+00 I X !! 0.1671903E+00 I X X !! 0.5463774E-03 - X X !! I-----------I-----------I-----------I-----------I !! 0.1000E+00 0.8250E+00 0.1550E+01 0.2275E+01 0.3000E+01 !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 ! ORIGINAL VERSION--FEBRUARY 1974. ! UPDATED --APRIL 1974. ! UPDATED --OCTOBER 1974. ! UPDATED --OCTOBER 1975. ! UPDATED --NOVEMBER 1975. ! UPDATED --FEBRUARY 1977. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE PLOTT(Y,X,N) REAL(kind=wp),intent(in) :: X(:) REAL(kind=wp),intent(in) :: Y(:) INTEGER,intent(in) :: N REAL(kind=wp) :: aim1, airow, anumcm, anumlm, anumr, anumrm REAL(kind=wp) :: cutoff, delx, dely, hold, xlable, xmax, xmin, xwidth, ylable, ylower, ymax, ymin REAL(kind=wp) :: yupper, ywidth INTEGER :: i, icol, icolmx, irow, ixdel, n2, numcol, numlab, numr25, numr50, numr75, numrow CHARACTER(len=4) :: iline CHARACTER(len=4) :: iaxisc CHARACTER(len=4) :: sbnam1 , sbnam2 CHARACTER(len=4) :: alph11 , alph12 , alph21 , alph22 , alph31 , alph32 CHARACTER(len=4) :: blank , hyphen , alphai , alphax DIMENSION iline(72) , xlable(10) DATA sbnam1 , sbnam2/'PLOT' , 'T '/ DATA alph11 , alph12/'FIRS' , 'T '/ DATA alph21 , alph22/'SECO' , 'ND '/ DATA alph31 , alph32/'THIR' , 'D '/ DATA blank , hyphen , alphai , alphax/' ' , '-' , 'I' , 'X'/ ! cutoff = (10.0_wp**10) - 1000.0_wp ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( N<1 ) THEN WRITE (G_IO,99011) WRITE (G_IO,99012) WRITE (G_IO,99013) alph31 , alph32 , sbnam1 , sbnam2 WRITE (G_IO,99001) N 99001 FORMAT (' is non-negative (with value = ',I0,')') WRITE (G_IO,99011) RETURN ELSE IF ( N==1 ) THEN WRITE (G_IO,99011) WRITE (G_IO,99012) WRITE (G_IO,99013) alph31 , alph32 , sbnam1 , sbnam2 WRITE (G_IO,99002) N 99002 FORMAT (' has the value 1') WRITE (G_IO,99011) RETURN ELSE ! hold = Y(1) DO i = 2 , N IF ( Y(i)/=hold ) GOTO 50 ENDDO WRITE (G_IO,99011) WRITE (G_IO,99012) WRITE (G_IO,99013) alph11 , alph12 , sbnam1 , sbnam2 WRITE (G_IO,99014) hold WRITE (G_IO,99011) RETURN ENDIF 50 continue hold = X(1) DO i = 2 , N IF ( X(i)/=hold ) GOTO 100 ENDDO WRITE (G_IO,99011) WRITE (G_IO,99012) WRITE (G_IO,99013) alph21 , alph22 , sbnam1 , sbnam2 WRITE (G_IO,99014) hold WRITE (G_IO,99011) RETURN ENDIF ! 100 continue DO i = 1 , N IF ( Y(i)<cutoff ) GOTO 200 ENDDO WRITE (G_IO,99011) WRITE (G_IO,99012) WRITE (G_IO,99013) alph11 , alph12 , sbnam1 , sbnam2 WRITE (G_IO,99015) WRITE (G_IO,99016) cutoff WRITE (G_IO,99011) RETURN 200 continue DO i = 1 , N IF ( X(i)<cutoff ) GOTO 300 ENDDO WRITE (G_IO,99011) WRITE (G_IO,99012) WRITE (G_IO,99013) alph21 , alph22 , sbnam1 , sbnam2 WRITE (G_IO,99015) WRITE (G_IO,99016) cutoff WRITE (G_IO,99011) RETURN ! 300 continue n2 = 0 DO i = 1 , N IF ( Y(i)<cutoff .AND. X(i)<cutoff ) THEN n2 = n2 + 1 IF ( n2>=2 ) GOTO 400 ENDIF ENDDO WRITE (G_IO,99011) WRITE (G_IO,99012) WRITE (G_IO,99003) alph11 , alph12 , alph21 , alph22 99003 FORMAT (' The ',A4,A4,', and ',A4,A4) WRITE (G_IO,99004) sbnam1 , sbnam2 99004 FORMAT (' input arguments to the ',A4,A4,' subroutine') WRITE (G_IO,99005) 99005 FORMAT (' are such that too many points have been', ' excluded from the plot.') WRITE (G_IO,99006) n2 99006 FORMAT (' only ',I0,' points are left to be plotted.') WRITE (G_IO,99011) RETURN ! !-----START POINT----------------------------------------------------- ! ! DEFINE THE NUMBER OF ROWS AND COLUMNS WITHIN THE PLOT-- ! THIS HAS BEEN SET TO 25 ROWS AND 49 COLUMNS. ! 400 continue numrow = 25 numcol = 49 anumr = numrow anumrm = numrow - 1 anumcm = numcol - 1 numr25 = (numrow/4) + 1 numr50 = (numrow/2) + 1 numr75 = 3*(numrow/4) + 1 ixdel = (numcol-1)/4 numlab = 5 anumlm = numlab - 1 ! ! SKIP A LINE, WRITE OUT AN IDENTIFYING LINE FOR THE TYPE OF PLOT, ! WRITE OUT THE TOP HORIZONTAL AXIS OF THE PLOT, AND SKIP 1 LINE ! FOR A MARGIN WITHIN THE PLOT. ! WRITE (G_IO,99007) 99007 FORMAT (' ') WRITE (G_IO,99008) ! 99008 FORMAT (' The following is a plot of Y(I) (vertically) versus X(I) (horizontally)') DO icol = 1 , numcol iline(icol) = hyphen ENDDO DO icol = 1 , numcol , ixdel iline(icol) = alphai ENDDO WRITE (G_IO,99017) (iline(i),i=1,numcol) WRITE (G_IO,99018) blank ! ! DETERMINE THE MIN AND MAX VALUES OF Y, AND OF X. ! DO i = 1 , N IF ( Y(i)<cutoff ) THEN IF ( X(i)<cutoff ) THEN ymin = Y(i) ymax = Y(i) xmin = X(i) xmax = X(i) EXIT ENDIF ENDIF ENDDO DO i = 1 , N IF ( Y(i)<cutoff ) THEN IF ( X(i)<cutoff ) THEN IF ( Y(i)<ymin ) ymin = Y(i) IF ( Y(i)>ymax ) ymax = Y(i) IF ( X(i)<xmin ) xmin = X(i) IF ( X(i)>xmax ) xmax = X(i) ENDIF ENDIF ENDDO dely = ymax - ymin delx = xmax - xmin ywidth = dely/anumrm xwidth = delx/anumcm ! ! DETERMINE AND WRITE OUT THE PLOT POSITIONS ONE LINE AT A TIME. ! DO irow = 1 , numrow DO icol = 1 , numcol iline(icol) = blank ENDDO airow = irow yupper = ymax + (1.5_wp-airow)*ywidth ylable = ymax + (1.0_wp-airow)*ywidth ylower = ymax + (0.5_wp-airow)*ywidth IF ( irow==numrow ) ylable = ymin DO i = 1 , N IF ( Y(i)<cutoff ) THEN IF ( X(i)<cutoff ) THEN IF ( ylower<=Y(i) .AND. Y(i)<yupper ) THEN icol = ((X(i)-xmin)/xwidth) + 1.5_wp iline(icol) = alphax ENDIF ENDIF ENDIF ENDDO icolmx = 1 DO icol = 1 , numcol IF ( iline(icol)==alphax ) icolmx = icol ENDDO iaxisc = alphai IF ( irow==1 .OR. irow==numrow ) iaxisc = hyphen IF ( irow==numr25 .OR. irow==numr50 .OR. irow==numr75 ) iaxisc = hyphen WRITE (G_IO,99009) ylable , iaxisc , (iline(icol),icol=1,icolmx) 99009 FORMAT (' ',E14.7,1X,A1,2X,50A1) ENDDO ! ! SKIP 1 LINE FOR A BOTTOM MARGIN WITHIN THE PLOT, WRITE OUT THE ! BOTTOM HORIZONTAL AXIS, AND WRITE OUT THE X AXIS LABELS. ! WRITE (G_IO,99018) blank DO icol = 1 , numcol iline(icol) = hyphen ENDDO DO icol = 1 , numcol , ixdel iline(icol) = alphai ENDDO WRITE (G_IO,99017) (iline(icol),icol=1,numcol) DO i = 1 , numlab aim1 = i - 1 xlable(i) = xmin + (aim1/anumlm)*delx ENDDO WRITE (G_IO,99010) (xlable(i),i=1,numlab) 99010 FORMAT (' ',9X,5E12.4) 99011 FORMAT (' **********************************************************************') 99012 FORMAT (' FATAL ERROR ') 99013 FORMAT (' The ',A4,A4,' input argument to the ',A4,A4,' subroutine') 99014 FORMAT (' has all elements = ',E15.8) 99015 FORMAT (' has all elements in excess of the cutoff') 99016 FORMAT (' value of ',E15.8) 99017 FORMAT (' ',18X,54A1) 99018 FORMAT (' ',15X,A1) END SUBROUTINE PLOTT !> !!##NAME !! plotu(3f) - [M_datapac:GENERIC_LINE_PLOT] generate a line printer !! 4-plot !! !!##SYNOPSIS !! !! SUBROUTINE PLOTU(X,N) !! !!##DESCRIPTION !! PLOTU(3f) produces the following 4 plots-- !! all on the same printer page-- !! !! 1. data plot--x(i) versus i !! 2. autoregression plot--x(i) versus x(i-1) !! 3. histogram !! 4. normal probability plot !! !! In addition, location, scale, and autocorrelation summary statistics !! are printed out automatically on the same page. !! !! These plots give the data analyst a quick first-pass check at some of !! the underlying assumptions typically made-- constant location, constant !! scale, no outliers, unautocorrelated data, symmetry, normality. !! !!##OPTIONS !! X description of parameter !! Y description of parameter !! !!##EXAMPLES !! !! Sample program: !! !! program demo_plotu !! use M_datapac, only : plotu !! implicit none !! ! call plotu(x,y) !! end program demo_plotu !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the Statistical !! Engineering Division, National Institute of Standards and Technology. !!##MAINTAINER !! John Urban, 2022.05.31 !!##LICENSE !! CC0-1.0 !!##REFERENCES !! * FILLIBEN, 'SOME USEFUL COMPUTERIZED TECHNIQUES FOR DATA ANALYSIS', !! (UNPUBLISHED MANUSCRIPT AVAILABLE FROM AUTHOR), 1975. !! * HAHN AND SHAPIRO, STATISTICAL METHODS IN ENGINEERING, 1967, pages !! 260-308. !! * FILLIBEN, 'THE PROBABILITY PLOT CORRELATION COEFFICIENT TEST FOR !! NORMALITY', TECHNOMETRICS, 1975, pages 111-117. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE PLOTU(X,N) REAL(kind=wp) :: ai , an , anum , cwidsd , cwidth , height , hold , promax , & & promin , ratiox , ratioy , s , sum , sum1 , sum2 , sum23 , & & sum3 , width , WS , X REAL(kind=wp) :: X2 , x25 , x75 , xmax , xmax2 , xmean , xmid , xmin , xmin2 ,& & Y2 , ylable , ymax , ymin , z , zautoc , zdeva , zdevb , & & zmax , zmean , zmean1 REAL(kind=wp) :: zmean2 , zmed , zmin , zrange , zrdeva , zrdevb , zsd INTEGER :: i , ibax , ibaxis , ibaxm1 , ibaxm2 , ievodd , ilax , & & ilaxis , ilaxm1 , ilaxm2 , ilaxm3 , ilaxm4 , ilaxp2 , & & ilower , inc , ip1 , iplot , irax , iraxis INTEGER :: iraxm2 , irev , iskipm , itax , itaxis , itaxp1 , itaxp2 ,& & iupper , ixdel , ixmid , iy , iydel , iymid , j , j1 , & & j2 , j3 , j4 , mt , mx INTEGER :: my , N , n2 , nhalf , nhalfp , nm1 , nmi , numcla , & & numdis , nummax , nummin , numout ! ! INPUT ARGUMENTS--X = THE VECTOR OF ! (UNSORTED) OBSERVATIONS. ! N = THE INTEGER NUMBER OF OBSERVATIONS ! IN THE VECTOR X. ! OUTPUT--4 PLOTS (ALL ON THE SAME PRINTER page)-- ! 1) DATA PLOT--X(I) VERSUS I ! 2) AUTOREGRESSION PLOT--X(I) VERSUS X(I-1) ! 3) HISTOGRAM ! 4) NORMAL PROBABILITY PLOT ! PLUS LOCATION, SCALE, AND ! AUTOCORRELATION SUMMARY STATISTICS. ! PRINTING--YES ! RESTRICTIONS--THE MINIMUM ALLOWABLE VALUE OF N ! FOR THIS SUBROUTINE IS 2. ! --THE MAXIMUM ALLOWABLE VALUE OF N ! FOR THIS SUBROUTINE IS 7500. ! OTHER DATAPAC SUBROUTINES NEEDED--SORT, UNIMED, NORPPF. ! FORTRAN LIBRARY SUBROUTINES NEEDED--SQRT. ! MODE OF INTERNAL OPERATIONS-- ! ORIGINAL VERSION--NOVEMBER 1974. ! UPDATED --JANUARY 1975. ! UPDATED --NOVEMBER 1975. ! UPDATED --FEBRUARY 1976. ! UPDATED --MAY 1976. ! UPDATED --FEBRUARY 1977. ! !--------------------------------------------------------------------- ! CHARACTER(len=4) :: IGRaph CHARACTER(len=4) :: blank , hyphen , alphai , alphax CHARACTER(len=4) :: alpham , alphaa , alphad , alphan , equal ! DIMENSION X(:) DIMENSION X2(7500) , Y2(7500) DIMENSION ylable(45,4) DIMENSION xmin(4) , xmax(4) , xmid(4) , x25(4) , x75(4) DIMENSION itaxis(4) , ibaxis(4) , ilaxis(4) , iraxis(4) COMMON /BLOCK1/ IGRaph(55,130) COMMON /BLOCK2_real32/ WS(15000) !CCCC COMMON IGRAPH(45,110) EQUIVALENCE (X2(1),WS(1)) EQUIVALENCE (Y2(1),WS(7501)) ! DATA blank , hyphen , alphai , alphax/' ' , '-' , 'I' , 'X'/ DATA alpham , alphaa , alphad , alphan , equal/'M' , 'A' , 'D' , & & 'N' , '='/ DATA itaxis(1) , ibaxis(1) , ilaxis(1) , iraxis(1)/1 , 19 , 5 , & & 49/ DATA itaxis(2) , ibaxis(2) , ilaxis(2) , iraxis(2)/1 , 19 , 54 , & & 98/ DATA itaxis(3) , ibaxis(3) , ilaxis(3) , iraxis(3)/27 , 45 , 5 , & & 49/ DATA itaxis(4) , ibaxis(4) , ilaxis(4) , iraxis(4)/27 , 45 , 54 , & & 98/ ! ilower = 2 iupper = 7500 ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! WRITE (G_IO,99001) 99001 FORMAT ('1') IF ( N<ilower .OR. N>iupper ) THEN WRITE (G_IO,99002) ilower , iupper 99002 FORMAT (' ', & &'***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO PLOTU(3f) IS OUTSIDE THE ALLOWABLE (',I0,',',I0,') INTERVAL *****') WRITE (G_IO,99003) N 99003 FORMAT (' ','***** THE VALUE OF THE ARGUMENT IS ',I0,' *****') RETURN ELSE hold = X(1) DO i = 2 , N IF ( X(i)/=hold ) GOTO 100 ENDDO WRITE (G_IO,99004) hold 99004 FORMAT (' ', & &'***** FATAL ERROR--THE FIRST INPUT ARGUMENT (A VECTOR) TO THE PL& &OTU SUBROUTINE HAS ALL ELEMENTS = ',E15.8,' *****') RETURN ENDIF ! !-----START POINT----------------------------------------------------- ! ! PRODUCE THE FIRST PLOT (UPPER LEFT)--X(I) VERSUS I ! ! DETERMINE THE VERTICAL AXIS VECTOR Y2, THE HORIZONTAL ! AXIS VECTOR X2, AND THE PLOT SAMPLE SIZE N2 FOR THIS ! PARTICUAR PLOT. ! 100 n2 = N DO i = 1 , n2 Y2(i) = X(i) X2(i) = i ENDDO ! iplot = 1 ! ! !********************************************************************* ! ! OPERATE ON A PARTICULAR PLOT ! 200 itax = itaxis(iplot) ibax = ibaxis(iplot) ilax = ilaxis(iplot) irax = iraxis(iplot) ! itaxp2 = itax + 2 ibaxm2 = ibax - 2 ilaxp2 = ilax + 2 iraxm2 = irax - 2 ilaxm4 = ilax - 4 ilaxm3 = ilax - 3 ilaxm2 = ilax - 2 ilaxm1 = ilax - 1 iymid = (itaxp2+ibaxm2)/2 ixmid = (ilaxp2+iraxm2)/2 height = ibaxm2 - itaxp2 width = iraxm2 - ilaxp2 ! ! BLANK OUT THE GRAPH ! DO i = itax , ibax DO j = ilaxm4 , irax IGRaph(i,j) = blank ENDDO ENDDO ! ! PRODUCE THE Y AXIS ! DO i = itaxp2 , ibaxm2 IGRaph(i,ilax) = alphai IGRaph(i,irax) = alphai ENDDO iydel = (ibaxm2-itaxp2)/2 DO i = itaxp2 , ibaxm2 , iydel IGRaph(i,ilax) = hyphen IGRaph(i,irax) = hyphen ENDDO IGRaph(itaxp2,ilaxm4) = equal IGRaph(itaxp2,ilaxm3) = alpham IGRaph(itaxp2,ilaxm2) = alphaa IGRaph(itaxp2,ilaxm1) = alphax IGRaph(iymid,ilaxm4) = equal IGRaph(iymid,ilaxm3) = alpham IGRaph(iymid,ilaxm2) = alphai IGRaph(iymid,ilaxm1) = alphad IGRaph(ibaxm2,ilaxm4) = equal IGRaph(ibaxm2,ilaxm3) = alpham IGRaph(ibaxm2,ilaxm2) = alphai IGRaph(ibaxm2,ilaxm1) = alphan ! ! PRODUCE THE X AXIS ! DO j = ilaxp2 , iraxm2 IGRaph(itax,j) = hyphen IGRaph(ibax,j) = hyphen ENDDO ixdel = (iraxm2-ilaxp2)/4 DO j = ilaxp2 , iraxm2 , ixdel IGRaph(itax,j) = alphai IGRaph(ibax,j) = alphai ENDDO ! ! DETERMINE THE VALUES TO BE LISTED ON THE LEFT VERTICAL AXIS ! ymin = Y2(1) ymax = Y2(1) DO i = 1 , n2 IF ( Y2(i)<ymin ) ymin = Y2(i) IF ( Y2(i)>ymax ) ymax = Y2(i) ENDDO IF ( iplot==3 ) ymin = 1.0_wp DO i = itaxp2 , ibaxm2 anum = i - itaxp2 ylable(i,iplot) = ymax - (anum/height)*(ymax-ymin) ENDDO ! ! DETERMINE XMIN, XMAX, XMID, X25 (=THE 25% POINT), AND ! X75 (=THE 75% POINT) ! xmin2 = X2(1) xmax2 = X2(1) DO i = 1 , n2 IF ( X2(i)<xmin2 ) xmin2 = X2(i) IF ( X2(i)>xmax2 ) xmax2 = X2(i) ENDDO xmin(iplot) = xmin2 xmax(iplot) = xmax2 xmid(iplot) = (xmin2+xmax2)/2.0_wp x25(iplot) = 0.75_wp*xmin2 + 0.25_wp*xmax2 x75(iplot) = 0.25_wp*xmin2 + 0.75_wp*xmax2 ! ! DETERMINE THE (X,Y) PLOT POSITIONS ! ratioy = 0.0_wp ratiox = 0.0_wp IF ( ymax>ymin ) ratioy = height/(ymax-ymin) IF ( xmax(iplot)>xmin(iplot) ) & & ratiox = width/(xmax(iplot)-xmin(iplot)) IF ( iplot==3 ) THEN ! DO i = 1 , n2 IF ( Y2(i)>0.5_wp ) THEN mx = ratiox*(X2(i)-xmin(iplot)) + 0.5_wp mx = mx + ilaxp2 my = ratioy*(Y2(i)-ymin) + 0.5_wp my = ibaxm2 - my IGRaph(my,mx) = alphax DO iy = my , ibaxm2 IGRaph(iy,mx) = alphax ENDDO ENDIF ENDDO ELSE DO i = 1 , n2 mx = ratiox*(X2(i)-xmin(iplot)) + 0.5_wp mx = mx + ilaxp2 my = ratioy*(Y2(i)-ymin) + 0.5_wp my = ibaxm2 - my IGRaph(my,mx) = alphax ENDDO ENDIF ! IF ( iplot==1 ) THEN ! !********************************************************************* ! ! PRODUCE THE SECOND PLOT (UPPER RIGHT)--X(I) VERSUS X(I-1) ! ! DETERMINE THE VERTICAL AXIS VECTOR Y2, THE HORIZONTAL ! AXIS VECTOR X2, AND THE PLOT SAMPLE SIZE N2 FOR THIS ! PARTICULAR PLOT. ! n2 = N - 1 DO i = 1 , n2 ip1 = i + 1 Y2(i) = X(ip1) X2(i) = X(i) ENDDO ! iplot = 2 GOTO 200 ELSEIF ( iplot==2 ) THEN ! !********************************************************************* ! ! PRODUCE THE THIRD PLOT (LOWER LEFT)-A HISTOGRAM ! n2 = 41 inc = 3 ! ! COMPUTE THE SAMPLE MEAN AND SAMPLE STANDARD DEVIATION ! an = N sum = 0.0_wp DO i = 1 , N sum = sum + X(i) ENDDO xmean = sum/an sum = 0.0_wp DO i = 1 , N sum = sum + (X(i)-xmean)**2 ENDDO s = SQRT(sum/(an-1.0_wp)) ! ! FORM THE FREQUENCY TABLE (Y2) WHICH CORRESPONDS TO A HISTOGRAM ! WITH 41 CLASSES AND A CLASS WIDTH OF THREE TENTHS OF A SAMPLE STANDARD ! DEVIATION. ! DO i = 1 , 41 Y2(i) = 0.0_wp ENDDO ! numout = 0 DO i = 1 , N z = (X(i)-xmean)/s IF ( -6.0_wp<=z .AND. z<=6.0_wp ) THEN mt = ((z+6.0_wp)/0.3_wp) + 1.5_wp Y2(mt) = Y2(mt) + 1.0_wp ELSE numout = numout + 1 ENDIF ENDDO ! DO i = 1 , 41 ai = i X2(i) = xmean + ((ai-21.0_wp)*0.3_wp)*s ENDDO ! numcla = 41 cwidsd = 0.3_wp cwidth = cwidsd*s ! iplot = 3 GOTO 200 ELSEIF ( iplot==3 ) THEN ! !********************************************************************* ! ! PRODUCE THE FOURTH PLOT (LOWER RIGHT)--A NORMAL PROBABILITY PLOT ! ! DETERMINE THE VERTICAL AXIS VECTOR Y2, THE HORIZONTAL ! AXIS VECTOR X2, AND THE PLOT SAMPLE SIZE N2 FOR THIS ! PARTICUAR PLOT. ! n2 = N CALL SORT(X,N,Y2) CALL UNIMED(N,X2) DO i = 1 , N CALL NORPPF(X2(i),X2(i)) ENDDO ! iplot = 4 GOTO 200 ELSE ! !******************************************************************** ! ! COMPUTE SUMMARY STATISTICS ! zmin = Y2(1) zmax = Y2(N) zrange = zmax - zmin zmean = xmean zsd = s zdevb = zmean - zmin zrdevb = 0.0_wp IF ( zmean/=0.0_wp ) zrdevb = 100.0_wp*zdevb/zmean IF ( zrdevb<0.0_wp ) zrdevb = -zrdevb zdeva = zmax - zmean zrdeva = 0.0_wp IF ( zmean/=0.0_wp ) zrdeva = 100.0_wp*zdeva/zmean IF ( zrdeva<0.0_wp ) zrdeva = -zrdeva ! ! DETERMINE THE NUMBER OF DISTINCT POINTS ! numdis = 1 nm1 = N - 1 DO i = 1 , nm1 ip1 = i + 1 IF ( Y2(i)/=Y2(ip1) ) numdis = numdis + 1 ENDDO ! ! COMPUTE THE SAMPLE MEDIAN ! nhalf = N/2 ievodd = N - 2*(N/2) IF ( ievodd==0 ) THEN nhalfp = nhalf + 1 zmed = (Y2(nhalf)+Y2(nhalfp))/2.0_wp ELSE zmed = Y2(nhalf) ENDIF ! ! DETERMINE THE FREQUENCY OF THE SAMPLE MIN AND MAX ! nummin = 1 nm1 = N - 1 DO i = 1 , nm1 ip1 = i + 1 IF ( Y2(i)==Y2(ip1) ) nummin = nummin + 1 IF ( Y2(i)/=Y2(ip1) ) EXIT ENDDO nummax = 1 DO i = 1 , nm1 irev = N - i + 1 nmi = N - i IF ( Y2(irev)==Y2(nmi) ) nummax = nummax + 1 IF ( Y2(irev)/=Y2(nmi) ) EXIT ENDDO promin = nummin promin = 100.0_wp*promin/an promax = nummax promax = 100.0_wp*promax/an ! ! COMPUTE THE AUTOCORRELATION ! zmean1 = (an*zmean-X(N))/(an-1.0_wp) zmean2 = (an*zmean-X(1))/(an-1.0_wp) sum1 = 0.0_wp sum2 = 0.0_wp sum3 = 0.0_wp nm1 = N - 1 DO i = 1 , nm1 ip1 = i + 1 sum1 = sum1 + (X(i)-zmean1)*(X(ip1)-zmean2) sum2 = sum2 + (X(i)-zmean1)**2 sum3 = sum3 + (X(ip1)-zmean2)**2 ENDDO sum23 = sum2*sum3 zautoc = 9999.99_wp IF ( sum23>0.0_wp ) zautoc = sum1/(SQRT(sum23)) zautoc = 100.0_wp*zautoc ! ! WRITE EVERYTHING OUT ! itax = itaxis(1) ibax = ibaxis(1) itaxp1 = itax + 1 itaxp2 = itax + 2 ibaxm1 = ibax - 1 ibaxm2 = ibax - 2 j1 = ilaxis(1) - 4 j2 = iraxis(1) j3 = ilaxis(2) - 4 j4 = iraxis(2) WRITE (G_IO,99005) ! 99005 FORMAT (' ',20X,12X,'PLOT OF X(I) VERSUS I',41X,'PLOT OF ', & & 'X(I) VERSUS X(I-1)') WRITE (G_IO,99018) (IGRaph(itax,j),j=j1,j2) , & & (IGRaph(itax,j),j=j3,j4) WRITE (G_IO,99018) (IGRaph(itaxp1,j),j=j1,j2) , & & (IGRaph(itaxp1,j),j=j3,j4) DO i = itaxp2 , ibaxm2 WRITE (G_IO,99019) ylable(i,1) , (IGRaph(i,j),j=j1,j2) , & & ylable(i,2) , (IGRaph(i,j),j=j3,j4) ENDDO WRITE (G_IO,99018) (IGRaph(ibaxm1,j),j=j1,j2) , & & (IGRaph(ibaxm1,j),j=j3,j4) WRITE (G_IO,99018) (IGRaph(ibax,j),j=j1,j2) , & & (IGRaph(ibax,j),j=j3,j4) WRITE (G_IO,99020) xmin(1) , x25(1) , xmid(1) , x75(1) , xmax(1)& & , xmin(2) , x25(2) , xmid(2) , x75(2) , & & xmax(2) ! iskipm = 2 DO i = 1 , iskipm WRITE (G_IO,99006) 99006 FORMAT (' ') ENDDO ! itax = itaxis(3) ibax = ibaxis(3) itaxp1 = itax + 1 itaxp2 = itax + 2 ibaxm1 = ibax - 1 ibaxm2 = ibax - 2 j1 = ilaxis(3) - 4 j2 = iraxis(3) j3 = ilaxis(4) - 4 j4 = iraxis(4) WRITE (G_IO,99007) 99007 FORMAT (' ',38X,'HISTOGRAM',49X,'NORMAL PROBABILITY PLOT') WRITE (G_IO,99018) (IGRaph(itax,j),j=j1,j2) , & & (IGRaph(itax,j),j=j3,j4) WRITE (G_IO,99018) (IGRaph(itaxp1,j),j=j1,j2) , & & (IGRaph(itaxp1,j),j=j3,j4) DO i = itaxp2 , ibaxm2 WRITE (G_IO,99019) ylable(i,3) , (IGRaph(i,j),j=j1,j2) , & & ylable(i,4) , (IGRaph(i,j),j=j3,j4) ENDDO WRITE (G_IO,99018) (IGRaph(ibaxm1,j),j=j1,j2) , & & (IGRaph(ibaxm1,j),j=j3,j4) WRITE (G_IO,99018) (IGRaph(ibax,j),j=j1,j2) , & & (IGRaph(ibax,j),j=j3,j4) WRITE (G_IO,99020) xmin(3) , x25(3) , xmid(3) , x75(3) , xmax(3)& & , xmin(4) , x25(4) , xmid(4) , x75(4) , & & xmax(4) WRITE (G_IO,99008) 99008 FORMAT (' ',20X,' -6 -3 0 3 6') WRITE (G_IO,99009) numcla , N , numdis 99009 FORMAT (' ',20X,'NUMBER OF CLASSES = ',I0,42X,'SAMPLE SIZE =', & & I0,' DISTINCT POINTS =',I0) WRITE (G_IO,99010) cwidth , cwidsd , zmin , nummin , promin 99010 FORMAT (' ',20X,'CLASS WIDTH = ',E14.7,' = ',F3.1, & & ' STANDARD DEVIATIONS',11X,'MINIMUM =',F13.6, & & ' COUNT =',I0,' (',F7.2,'%)') WRITE (G_IO,99011) numout , zmed 99011 FORMAT (' ',16X,I0,' OBSERVATIONS WERE IN EXCESS OF 6 STANDARD'& & ,' DEVIATIONS',11X,'MEDIAN =',F14.6) WRITE (G_IO,99012) zmean 99012 FORMAT (' ',20X, & & 'ABOUT THE SAMPLE MEAN AND SO WERE NOT PRINTED IN HISTOGRAM'& & ,7X,'MEAN =',F16.6) WRITE (G_IO,99013) zmax , nummax , promax 99013 FORMAT (' ',85X,'MAXIMUM =',F13.6,' COUNT =',I0,' (',F7.2,'%)') WRITE (G_IO,99014) zsd , zrange 99014 FORMAT (' ',85X,'ST. DEV. =',F12.6,' RANGE =',F16.6) WRITE (G_IO,99015) zdevb , zrdevb 99015 FORMAT (' ',20X,65X,'MAX DEV. BELOW MEAN =',F14.6,' (',F7.2, & & '%)') WRITE (G_IO,99016) zdeva , zrdeva 99016 FORMAT (' ',85X,'MAX DEV. ABOVE MEAN =',F14.6,' (',F7.2,'%)') WRITE (G_IO,99017) zautoc 99017 FORMAT (' ',85X,'AUTOCORR. =',F10.2,'%') ENDIF 99018 FORMAT (' ',16X,4A1,45A1,16X,4A1,45A1) 99019 FORMAT (' ',F16.7,4A1,45A1,F16.7,4A1,45A1) 99020 FORMAT (' ',17X,5F10.4,15X,4F10.4,F9.3) ! END SUBROUTINE PLOTU !> !!##NAME !! plotx(3f) - [M_datapac:GENERIC_LINE_PLOT] generate a line printer !! run sequence plot !! !!##SYNOPSIS !! !! SUBROUTINE PLOTX(X,N) !! !!##DESCRIPTION !! PLOTX(3f) yields a one-page printer plot of X(I) versus I. !! !!##OPTIONS !! X description of parameter !! Y description of parameter !! !!##EXAMPLES !! !! Sample program: !! !! program demo_plotx !! use M_datapac, only : plotx !! implicit none !! ! call plotx(x,y) !! end program demo_plotx !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the Statistical !! Engineering Division, National Institute of Standards and Technology. !!##MAINTAINER !! John Urban, 2022.05.31 !!##LICENSE !! CC0-1.0 ! ORIGINAL VERSION--JUNE 1972. ! UPDATED --JANUARY 1975. ! UPDATED --JULY 1975. ! UPDATED --SEPTEMBER 1975. ! UPDATED --OCTOBER 1975. ! UPDATED --NOVEMBER 1975. ! UPDATED --FEBRUARY 1976. ! UPDATED --FEBRUARY 1977. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE PLOTX(X,N) REAL(kind=wp) :: aim1 , cutoff , hold , ratiox , ratioy , X , x25 , x75 , xi ,& & xmax , xmid , xmin , ylable , ymax , ymin INTEGER i , iflag , ip2 , j , k , mx , my , N ! ! INPUT ARGUMENTS--X = THE VECTOR OF ! (UNSORTED OR SORTED) OBSERVATIONS ! TO BE PLOTTED VERTICALLY. ! --N = THE INTEGER NUMBER OF OBSERVATIONS ! IN THE VECTOR X. ! OUTPUT--A ONE-page PRINTER PLOT OF X(I) VERSUS I. ! PRINTING--YES. ! COMMENT--VALUES IN THE VERTICAL AXIS VECTOR (X) WHICH ARE ! EQUAL TO OR IN EXCESS OF 10.0**10 WILL NOT BE ! PLOTTED. ! THIS CONVENTION GREATLY SIMPLIFIES THE PROBLEM ! OF PLOTTING WHEN SOME ELEMENTS IN THE VECTOR X ! ARE 'MISSING DATA', OR WHEN WE PURPOSELY ! WANT TO IGNORE CERTAIN ELEMENTS IN THE VECTOR X ! FOR PLOTTING PURPOSES (THAT IS, WE DO NOT ! WANT CERTAIN ELEMENTS IN X TO BE PLOTTED). ! TO CAUSE SPECIFIC ELEMENTS IN X TO BE ! IGNORED, WE REPLACE THE ELEMENTS BEFOREHAND ! (BY, FOR EXAMPLE, USE OF THE REPLAC SUBROUTINE) ! BY SOME LARGE VALUE (LIKE, SAY, 10.0**10) AND ! THEY WILL SUBSEQUENTLY BE IGNORED IN THE PLOTX ! SUBROUTINE. ! !--------------------------------------------------------------------- ! CHARACTER(len=4) :: IGRaph CHARACTER(len=4) :: sbnam1 , sbnam2 CHARACTER(len=4) :: alph11 , alph12 , alph21 , alph22 CHARACTER(len=4) :: blank , hyphen , alphai , alphax CHARACTER(len=4) :: alpham , alphaa , alphad , alphan , equal ! DIMENSION X(:) DIMENSION ylable(11) COMMON /BLOCK1/ IGRaph(55,130) ! DATA sbnam1 , sbnam2/'PLOT' , 'X '/ DATA alph11 , alph12/'FIRS' , 'T '/ DATA alph21 , alph22/'SECO' , 'ND '/ DATA blank , hyphen , alphai , alphax/' ' , '-' , 'I' , 'X'/ DATA alpham , alphaa , alphad , alphan , equal/'M' , 'A' , 'D' , & & 'N' , '='/ ! cutoff = (10.0_wp**10) - 1000.0_wp ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! WRITE (G_IO,99001) 99001 FORMAT ('1') IF ( N<1 ) THEN WRITE (G_IO,99011) WRITE (G_IO,99012) WRITE (G_IO,99013) alph21 , alph22 , sbnam1 , sbnam2 WRITE (G_IO,99002) N 99002 FORMAT (' ','IS NON-NEGATIVE (WITH VALUE = ',I0,')') WRITE (G_IO,99011) RETURN ELSE IF ( N==1 ) THEN WRITE (G_IO,99011) WRITE (G_IO,99012) WRITE (G_IO,99013) alph21 , alph22 , sbnam1 , sbnam2 WRITE (G_IO,99003) N 99003 FORMAT (' ','HAS THE VALUE 1') WRITE (G_IO,99011) RETURN ELSE ! hold = X(1) DO i = 2 , N IF ( X(i)/=hold ) GOTO 50 ENDDO WRITE (G_IO,99011) WRITE (G_IO,99012) WRITE (G_IO,99013) alph11 , alph12 , sbnam1 , sbnam2 WRITE (G_IO,99004) hold 99004 FORMAT (' ','HAS ALL ELEMENTS = ',E15.8) WRITE (G_IO,99011) RETURN ENDIF ! 50 DO i = 1 , N IF ( X(i)<cutoff ) GOTO 100 ENDDO WRITE (G_IO,99011) WRITE (G_IO,99012) WRITE (G_IO,99013) alph11 , alph12 , sbnam1 , sbnam2 WRITE (G_IO,99005) 99005 FORMAT (' ','HAS ALL ELEMENTS IN EXCESS OF THE CUTOFF') WRITE (G_IO,99006) cutoff 99006 FORMAT (' ','VALUE OF ',E15.8) WRITE (G_IO,99011) RETURN ENDIF ! !-----START POINT----------------------------------------------------- ! ! DETERMINE THE VALUES TO BE LISTED ON THE LEFT VERTICAL AXIS ! 100 DO i = 1 , N IF ( X(i)<cutoff ) THEN ymin = X(i) ymax = X(i) EXIT ENDIF ENDDO DO i = 1 , N IF ( X(i)<cutoff ) THEN IF ( X(i)<ymin ) ymin = X(i) IF ( X(i)>ymax ) ymax = X(i) ENDIF ENDDO DO i = 1 , 9 aim1 = i - 1 ylable(i) = ymax - (aim1/8.0_wp)*(ymax-ymin) ENDDO ! ! DETERMINE THE VALUES TO BE LISTED ON THE BOTTOM HORIZONTAL AXIS. ! DETERMINE XMIN, XMAX, XMID, X25 (=THE 25% POINT), AND ! X75 (=THE 75% POINT). ! xmin = 1.0_wp xmax = N xmid = (xmin+xmax)/2.0_wp x25 = 0.75_wp*xmin + 0.25_wp*xmax x75 = 0.25_wp*xmin + 0.75_wp*xmax ! ! BLANK OUT THE GRAPH ! DO i = 1 , 45 DO j = 1 , 109 IGRaph(i,j) = blank ENDDO ENDDO ! ! PRODUCE THE VERTICAL AXES ! DO i = 3 , 43 IGRaph(i,5) = alphai IGRaph(i,109) = alphai ENDDO DO i = 3 , 43 , 5 IGRaph(i,5) = hyphen IGRaph(i,109) = hyphen ENDDO IGRaph(3,1) = equal IGRaph(3,2) = alpham IGRaph(3,3) = alphaa IGRaph(3,4) = alphax IGRaph(23,1) = equal IGRaph(23,2) = alpham IGRaph(23,3) = alphai IGRaph(23,4) = alphad IGRaph(43,1) = equal IGRaph(43,2) = alpham IGRaph(43,3) = alphai IGRaph(43,4) = alphan ! ! PRODUCE THE HORIZONTAL AXES ! DO j = 7 , 107 IGRaph(1,j) = hyphen IGRaph(45,j) = hyphen ENDDO DO j = 7 , 107 , 25 IGRaph(1,j) = alphai IGRaph(45,j) = alphai ENDDO DO j = 20 , 107 , 25 IGRaph(1,j) = alphai IGRaph(45,j) = alphai ENDDO ! ! DETERMINE THE (X,Y) PLOT POSITIONS ! ratioy = 40.0_wp/(ymax-ymin) ratiox = 100.0_wp/(xmax-xmin) DO i = 1 , N IF ( X(i)<cutoff ) THEN xi = i mx = ratiox*(xi-xmin) + 0.5_wp mx = mx + 7 my = ratioy*(X(i)-ymin) + 0.5_wp my = 43 - my IGRaph(my,mx) = alphax ENDIF ENDDO ! ! WRITE OUT THE GRAPH ! WRITE (G_IO,99007) ! 99007 FORMAT (' ', & &'THE FOLLOWING IS A PLOT OF X(I) (VERTICALLY) VERSUS I (HORIZONTAL& &LY)') DO i = 1 , 45 ip2 = i + 2 iflag = ip2 - (ip2/5)*5 k = ip2/5 IF ( iflag/=0 ) WRITE (G_IO,99008) (IGRaph(i,j),j=1,109) 99008 FORMAT (' ',20X,109A1) IF ( iflag==0 ) WRITE (G_IO,99009) ylable(k) , & & (IGRaph(i,j),j=1,109) 99009 FORMAT (' ',F20.7,109A1) ENDDO WRITE (G_IO,99010) xmin , x25 , xmid , x75 , xmax 99010 FORMAT (' ',14X,F20.7,5X,F20.7,5X,F20.7,5X,F20.7,1X,F20.7) ! 99011 FORMAT (' ','**************************************************', & & '********************') 99012 FORMAT (' ',' FATAL ERROR ') 99013 FORMAT (' ','THE ',A4,A4,' INPUT ARGUMENT TO THE ',A4,A4, & & ' SUBROUTINE') ! END SUBROUTINE PLOTX !> !!##NAME !! plotxt(3f) - [M_datapac:LINE_PLOT] generate a line printer run !! sequence plot for the terminal (71 characters wide) !! !!##SYNOPSIS !! !! SUBROUTINE PLOTXT(X,N) !! !! REAL(kind=wp),intent(in) :: X(:) !! INTEGER,intent(in) :: N !! !!##DESCRIPTION !! PLOTXT(3f) yields a narrow-width (71-character) plot of x(i) versus i. !! Its narrow width makes it appropriate for use on a terminal. !! !! Values in the vertical axis vector (X) which are equal to or in excess !! of 10.0**10 will not be plotted. !! !! This convention greatly simplifies the problem of plotting when some !! elements in the vector X are 'missing data', or when we purposely !! want to ignore certain elements in the vector X for plotting purposes !! (that is, we do not want certain elements in X to be plotted). To !! cause specific elements in X to be ignored, we replace the elements !! beforehand (by, for example, use of the REPLAC(3f) subroutine) by !! some large value (like, say, 10.0**10) and they will subsequently be !! ignored in the PLOTXT(3f) subroutine. !! !! Note that the storage requirements for this (and the other) terminal !! plot subroutiness are very small. This is due to the 'one line at a !! time' algorithm employed for the plot. !! !!##INPUT ARGUMENTS !! !! X The vector of (unsorted or sorted) observations to be plotted !! vertically. !! !! N The integer number of observations in the vector X. !! !!##OUTPUT !! !! A narrow-width (71-character) terminal plot of X(I) versus I. !! The body of the plot (not counting axis values !! and margins) is 25 rows (lines) and 49 columns. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_plotxt !! use M_datapac, only : plotxt !! implicit none !! ! call plotxt(x,y) !! end program demo_plotxt !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !!##MAINTAINER !! John Urban, 2022.05.31 !!##LICENSE !! CC0-1.0 ! ORIGINAL VERSION--FEBRUARY 1974. ! UPDATED --APRIL 1974. ! UPDATED --OCTOBER 1974. ! UPDATED --OCTOBER 1975. ! UPDATED --NOVEMBER 1975. ! UPDATED --FEBRUARY 1977. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE PLOTXT(X,N) REAL(kind=wp),intent(in) :: X(:) INTEGER,intent(in) :: N REAL(kind=wp) :: ai, ailabl, aim1, aimax, aimin, airow, aiwidt, anumcm, anumlm, anumr, anumrm, cutoff, delai, delx, hold REAL(kind=wp) :: xlable, xlower, xmax, xmin REAL(kind=wp) :: xupper, xwidth INTEGER :: i, icol, icolmx, irow, ixdel, numcol, numlab, numr25, numr50, numr75, numrow CHARACTER(len=4) :: iline CHARACTER(len=4) :: iaxisc CHARACTER(len=4) :: sbnam1 , sbnam2 CHARACTER(len=4) :: alph11 , alph12 , alph21 , alph22 CHARACTER(len=4) :: blank , hyphen , alphai , alphax DIMENSION iline(72) , ailabl(10) DATA sbnam1 , sbnam2/'PLOT' , 'XT '/ DATA alph11 , alph12/'FIRS' , 'T '/ DATA alph21 , alph22/'SECO' , 'ND '/ DATA blank , hyphen , alphai , alphax/' ' , '-' , 'I' , 'X'/ ! cutoff = (10.0_wp**10) - 1000.0_wp ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( N<1 ) THEN WRITE (G_IO,99010) WRITE (G_IO,99011) WRITE (G_IO,99012) alph21 , alph22 , sbnam1 , sbnam2 WRITE (G_IO,99001) N 99001 FORMAT (' is non-negative (with value = ',I0,')') WRITE (G_IO,99010) RETURN ELSE IF ( N==1 ) THEN WRITE (G_IO,99010) WRITE (G_IO,99011) WRITE (G_IO,99012) alph21 , alph22 , sbnam1 , sbnam2 WRITE (G_IO,99002) N 99002 FORMAT (' has the value 1') WRITE (G_IO,99010) RETURN ELSE ! hold = X(1) DO i = 2 , N IF ( X(i)/=hold ) GOTO 50 ENDDO WRITE (G_IO,99010) WRITE (G_IO,99011) WRITE (G_IO,99012) alph11 , alph12 , sbnam1 , sbnam2 WRITE (G_IO,99003) hold 99003 FORMAT (' ','has all elements = ',E15.8) WRITE (G_IO,99010) RETURN ENDIF ! 50 DO i = 1 , N IF ( X(i)<cutoff ) GOTO 100 ENDDO WRITE (G_IO,99010) WRITE (G_IO,99011) WRITE (G_IO,99012) alph11 , alph12 , sbnam1 , sbnam2 WRITE (G_IO,99004) 99004 FORMAT (' ','has all elements in excess of the cutoff') WRITE (G_IO,99005) cutoff 99005 FORMAT (' ','value of ',E15.8) WRITE (G_IO,99010) RETURN ENDIF ! !-----START POINT----------------------------------------------------- ! ! DEFINE THE NUMBER OF ROWS AND COLUMNS WITHIN THE PLOT-- ! THIS HAS BEEN SET TO 25 ROWS AND 49 COLUMNS. ! 100 numrow = 25 numcol = 49 anumr = numrow anumrm = numrow - 1 anumcm = numcol - 1 numr25 = (numrow/4) + 1 numr50 = (numrow/2) + 1 numr75 = 3*(numrow/4) + 1 ixdel = (numcol-1)/4 numlab = 5 anumlm = numlab - 1 ! ! WRITE OUT THE TOP HORIZONTAL AXIS OF THE PLOT, AND SKIP 1 LINE ! FOR A MARGIN WITHIN THE PLOT. ! WRITE (G_IO,99006) 99006 FORMAT (' ') WRITE (G_IO,99007) 99007 FORMAT (' The following is a plot of X(I) (vertically) versus I (horizontally)') DO icol = 1 , numcol iline(icol) = hyphen ENDDO DO icol = 1 , numcol , ixdel iline(icol) = alphai ENDDO WRITE (G_IO,99013) (iline(i),i=1,numcol) WRITE (G_IO,99014) blank ! ! DETERMINE THE MIN AND MAX VALUES OF X, AND OF I. ! xmin = X(1) xmax = X(1) aimin = 1 aimax = N DO i = 1 , N IF ( X(i)<cutoff ) THEN IF ( X(i)<xmin ) xmin = X(i) IF ( X(i)>xmax ) xmax = X(i) ENDIF ENDDO delx = xmax - xmin delai = aimax - aimin xwidth = delx/anumrm aiwidt = delai/anumcm ! ! DETERMINE AND WRITE OUT THE PLOT POSITIONS ONE LINE AT A TIME. ! DO irow = 1 , numrow DO icol = 1 , numcol iline(icol) = blank ENDDO airow = irow xupper = xmax + (1.5_wp-airow)*xwidth xlable = xmax + (1.0_wp-airow)*xwidth xlower = xmax + (0.5_wp-airow)*xwidth IF ( irow==numrow ) xlable = xmin DO i = 1 , N ai = i IF ( X(i)<cutoff ) THEN IF ( xlower<=X(i) .AND. X(i)<xupper ) THEN icol = ((ai-aimin)/aiwidt) + 1.5_wp iline(icol) = alphax ENDIF ENDIF ENDDO icolmx = 1 DO icol = 1 , numcol IF ( iline(icol)==alphax ) icolmx = icol ENDDO iaxisc = alphai IF ( irow==1 .OR. irow==numrow ) iaxisc = hyphen IF ( irow==numr25 .OR. irow==numr50 .OR. irow==numr75 ) iaxisc = hyphen WRITE (G_IO,99008) xlable , iaxisc , (iline(icol),icol=1,icolmx) 99008 FORMAT (' ',E14.7,1X,A1,2X,50A1) ENDDO ! ! SKIP 1 LINE FOR A BOTTOM MARGIN WITHIN THE PLOT, WRITE OUT THE ! BOTTOM HORIZONTAL AXIS, AND WRITE OUT THE X AXIS LABELS. ! WRITE (G_IO,99014) blank DO icol = 1 , numcol iline(icol) = hyphen ENDDO DO icol = 1 , numcol , ixdel iline(icol) = alphai ENDDO WRITE (G_IO,99013) (iline(icol),icol=1,numcol) DO i = 1 , numlab aim1 = i - 1 ailabl(i) = aimin + (aim1/anumlm)*delai ENDDO WRITE (G_IO,99009) (ailabl(i),i=1,numlab) 99009 FORMAT (' ',9X,5E12.4) 99010 FORMAT (' ','**********************************************************************') 99011 FORMAT (' ',' FATAL ERROR ') 99012 FORMAT (' ','The ',A4,A4,' input argument to the ',A4,A4,' subroutine') 99013 FORMAT (' ',18X,54A1) 99014 FORMAT (' ',15X,A1) END SUBROUTINE PLOTXT !> !!##NAME !! plotxx(3f) - [M_datapac:LINE_PLOT] generate a line printer lag plot !! !!##SYNOPSIS !! !! SUBROUTINE PLOTXX(X,N) !! !!##DESCRIPTION !! plotxx(3f) yields a one-page printer plot of x(i) versus x(i-1). !! !! this type of plot (which is called an autocorrelation plot or a lag !! 1 plot) is useful in examining for autocorrelation in a sequence !! of observations. !! !! uncorrelated data will produce an autocorrelation plot with no apparent !! structure; autocorrelated data will produce an autocorrelation plot !! with linear, elliptical, or other kinds of structure. !! !!##OPTIONS !! X description of parameter !! Y description of parameter !! !!##EXAMPLES !! !! Sample program: !! !! program demo_plotxx !! use M_datapac, only : plotxx !! implicit none !! ! call plotxx(x,y) !! end program demo_plotxx !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the Statistical !! Engineering Division, National Institute of Standards and Technology. !!##MAINTAINER !! John Urban, 2022.05.31 !!##LICENSE !! CC0-1.0 !!##REFERENCES !! * FILLIBEN, 'SOME USEFUL PROCEDURES FOR THE STATISTICAL ANALYSIS OF !! DATA', UNPUBLISHED MANUSCRIPT (AVAILABLE FROM AUTHOR) PRESENTED AT !! THE FALL CONFERENCE OF THE CHEMICAL DIVISION OF THE AMERICAN SOCIETY !! FOR QUALITY CONTROL, KNOXVILLE, TENNESSEE, OCTOBER 19-20, 1972. !! * FILLIBEN, 'DATA EXPLORATION USING STAND-ALONE SUBROUTINES', !! UNPUBLISHED MANUSCRIPT (AVAILABLE FROM AUTHOR) PRESENTED AT THE !! 'STRATEGY FOR DATA ANALYSIS BY COMPUTERS' SESSION AT THE NATIONAL !! MEETING OF THE AMERICAN STATISTICAL ASSOCIATION, ST. LOUIS, MISSOURI, !! AUGUST 26-29, 1974. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE PLOTXX(X,N) REAL(kind=wp) :: aim1 , cutoff , hold , ratiox , ratioy , X , x25 , x75 , & & xmax , xmid , xmin , ylable , ymax , ymin INTEGER :: i , iflag , im1 , ip2 , j , k , mx , my , N ! ! INPUT ARGUMENTS--X = THE VECTOR OF ! (UNSORTED) OBSERVATIONS ! TO BE GRAPHICALLY TESTED FOR ! AUTOCORRELATION. ! --N = THE INTEGER NUMBER OF OBSERVATIONS ! IN THE VECTOR X. ! OUTPUT--A ONE-page PRINTER PLOT OF X(I) VERSUS X(I-1). ! PRINTING--YES. ! RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE ! OF N FOR THIS SUBROUTINE. ! MODE OF INTERNAL OPERATIONS--. ! COMMENT--VALUES IN THE INPUT VECTOR X WHICH ARE ! EQUAL TO OR IN EXCESS OF 10.0**10 WILL NOT BE ! PLOTTED. ! THIS CONVENTION GREATLY SIMPLIFIES THE PROBLEM ! OF PLOTTING WHEN SOME ELEMENTS IN THE VECTOR X ! ARE 'MISSING DATA', OR WHEN WE PURPOSELY ! WANT TO IGNORE CERTAIN ELEMENTS IN THE VECTOR X ! FOR PLOTTING PURPOSES (THAT IS, WE DO NOT ! WANT CERTAIN ELEMENTS IN X TO BE PLOTTED). ! TO CAUSE SPECIFIC ELEMENTS IN X TO BE ! IGNORED, WE REPLACE THE ELEMENTS BEFOREHAND ! (BY, FOR EXAMPLE, USE OF THE REPLAC SUBROUTINE) ! BY SOME LARGE VALUE (LIKE, SAY, 10.0**10) AND ! THEY WILL SUBSEQUENTLY BE IGNORED IN THE PLOTXX ! SUBROUTINE. ! ORIGINAL VERSION--JUNE 1972. ! UPDATED --OCTOBER 1974. ! UPDATED --NOVEMBER 1974. ! UPDATED --JANUARY 1975. ! UPDATED --JULY 1975. ! UPDATED --SEPTEMBER 1975. ! UPDATED --OCTOBER 1975. ! UPDATED --NOVEMBER 1975. ! UPDATED --FEBRUARY 1976. ! UPDATED --FEBRUARY 1977. ! !--------------------------------------------------------------------- ! CHARACTER(len=4) :: IGRaph CHARACTER(len=4) :: sbnam1 , sbnam2 CHARACTER(len=4) :: alph11 , alph12 , alph21 , alph22 CHARACTER(len=4) :: blank , hyphen , alphai , alphax CHARACTER(len=4) :: alpham , alphaa , alphad , alphan , equal ! DIMENSION X(:) DIMENSION ylable(11) COMMON /BLOCK1/ IGRaph(55,130) ! DATA sbnam1 , sbnam2/'PLOT' , 'XX '/ DATA alph11 , alph12/'FIRS' , 'T '/ DATA alph21 , alph22/'SECO' , 'ND '/ DATA blank , hyphen , alphai , alphax/' ' , '-' , 'I' , 'X'/ DATA alpham , alphaa , alphad , alphan , equal/'M' , 'A' , 'D' , & & 'N' , '='/ ! cutoff = (10.0_wp**10) - 1000.0_wp ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! WRITE (G_IO,99001) 99001 FORMAT ('1') IF ( N<1 ) THEN WRITE (G_IO,99011) WRITE (G_IO,99012) WRITE (G_IO,99013) alph21 , alph22 , sbnam1 , sbnam2 WRITE (G_IO,99002) N 99002 FORMAT (' ','IS NON-NEGATIVE (WITH VALUE = ',I0,')') WRITE (G_IO,99011) RETURN ELSE IF ( N==1 ) THEN WRITE (G_IO,99011) WRITE (G_IO,99012) WRITE (G_IO,99013) alph21 , alph22 , sbnam1 , sbnam2 WRITE (G_IO,99003) N 99003 FORMAT (' ','HAS THE VALUE 1') WRITE (G_IO,99011) RETURN ELSE ! hold = X(1) DO i = 2 , N IF ( X(i)/=hold ) GOTO 50 ENDDO WRITE (G_IO,99011) WRITE (G_IO,99012) WRITE (G_IO,99013) alph11 , alph12 , sbnam1 , sbnam2 WRITE (G_IO,99004) hold 99004 FORMAT (' ','HAS ALL ELEMENTS = ',E15.8) WRITE (G_IO,99011) RETURN ENDIF ! 50 DO i = 1 , N IF ( X(i)<cutoff ) GOTO 100 ENDDO WRITE (G_IO,99011) WRITE (G_IO,99012) WRITE (G_IO,99013) alph11 , alph12 , sbnam1 , sbnam2 WRITE (G_IO,99005) 99005 FORMAT (' ','HAS ALL ELEMENTS IN EXCESS OF THE CUTOFF') WRITE (G_IO,99006) cutoff 99006 FORMAT (' ','VALUE OF ',E15.8) WRITE (G_IO,99011) RETURN ENDIF ! !-----START POINT----------------------------------------------------- ! ! DETERMINE THE VALUES TO BE LISTED ON THE LEFT VERTICAL AXIS ! 100 DO i = 1 , N IF ( X(i)<cutoff ) THEN ymin = X(i) ymax = X(i) EXIT ENDIF ENDDO DO i = 1 , N IF ( X(i)<cutoff ) THEN IF ( X(i)<ymin ) ymin = X(i) IF ( X(i)>ymax ) ymax = X(i) ENDIF ENDDO DO i = 1 , 9 aim1 = i - 1 ylable(i) = ymax - (aim1/8.0_wp)*(ymax-ymin) ENDDO ! ! DETERMINE THE VALUES TO BE LISTED ON THE BOTTOM HORIZONTAL AXIS. ! DETERMINE XMIN, XMAX, XMID, X25 (=THE 25% POINT), AND ! X75 (=THE 75% POINT). ! xmin = ymin xmax = ymax xmid = (xmin+xmax)/2.0_wp x25 = 0.75_wp*xmin + 0.25_wp*xmax x75 = 0.25_wp*xmin + 0.75_wp*xmax ! ! BLANK OUT THE GRAPH ! DO i = 1 , 45 DO j = 1 , 109 IGRaph(i,j) = blank ENDDO ENDDO ! ! PRODUCE THE VERTICAL AXES ! DO i = 3 , 43 IGRaph(i,5) = alphai IGRaph(i,109) = alphai ENDDO DO i = 3 , 43 , 5 IGRaph(i,5) = hyphen IGRaph(i,109) = hyphen ENDDO IGRaph(3,1) = equal IGRaph(3,2) = alpham IGRaph(3,3) = alphaa IGRaph(3,4) = alphax IGRaph(23,1) = equal IGRaph(23,2) = alpham IGRaph(23,3) = alphai IGRaph(23,4) = alphad IGRaph(43,1) = equal IGRaph(43,2) = alpham IGRaph(43,3) = alphai IGRaph(43,4) = alphan ! ! PRODUCE THE HORIZONTAL AXES ! DO j = 7 , 107 IGRaph(1,j) = hyphen IGRaph(45,j) = hyphen ENDDO DO j = 7 , 107 , 25 IGRaph(1,j) = alphai IGRaph(45,j) = alphai ENDDO DO j = 20 , 107 , 25 IGRaph(1,j) = alphai IGRaph(45,j) = alphai ENDDO ! ! DETERMINE THE (X,Y) PLOT POSITIONS ! ratioy = 40.0_wp/(ymax-ymin) ratiox = 100.0_wp/(xmax-xmin) DO i = 2 , N im1 = i - 1 IF ( X(i)<cutoff ) THEN IF ( X(im1)<cutoff ) THEN mx = ratiox*(X(im1)-xmin) + 0.5_wp mx = mx + 7 my = ratioy*(X(i)-ymin) + 0.5_wp my = 43 - my IGRaph(my,mx) = alphax ENDIF ENDIF ENDDO ! ! WRITE OUT THE GRAPH ! WRITE (G_IO,99007) ! 99007 FORMAT (' ', & &'THE FOLLOWING IS A PLOT OF X(I) (VERTICALLY) VERSUS X(I-1) (HORIZ& &ONTALLY)') DO i = 1 , 45 ip2 = i + 2 iflag = ip2 - (ip2/5)*5 k = ip2/5 IF ( iflag/=0 ) WRITE (G_IO,99008) (IGRaph(i,j),j=1,109) 99008 FORMAT (' ',20X,109A1) IF ( iflag==0 ) WRITE (G_IO,99009) ylable(k) , & & (IGRaph(i,j),j=1,109) 99009 FORMAT (' ',F20.7,109A1) ENDDO WRITE (G_IO,99010) xmin , x25 , xmid , x75 , xmax 99010 FORMAT (' ',14X,F20.7,5X,F20.7,5X,F20.7,5X,F20.7,1X,F20.7) ! 99011 FORMAT (' ','**************************************************', & & '********************') 99012 FORMAT (' ',' FATAL ERROR ') 99013 FORMAT (' ','THE ',A4,A4,' INPUT ARGUMENT TO THE ',A4,A4, & & ' SUBROUTINE') ! END SUBROUTINE PLOTXX !> !!##NAME !! pltsct(3f) - [M_datapac:GENERIC_LINE_PLOT] generate a line printer !! plot with special plot characters for the terminal (71 characters wide) !! !!##SYNOPSIS !! !! SUBROUTINE PLTSCT(Y,X,Char,N,D,Dmin,Dmax) !! !!##DESCRIPTION !! pltsct(3f) yields a narrow-width (71-character) plot of y(i) versus !! x(i): !! !! 1. with special plot characters; and !! 2. with only those points (x(i),y(i)) plotted !! for which the corresponding value of d(i) !! is between the specified values of dmin and dmax. !! !! its narrow width makes it appropriate for use on a terminal. !! !! the 'special plotting character' capability allows the data analyst !! to incorporate information from a third variable (aside from y and x) !! into the plot. !! !! the plot character used at the i-th plotting position (that is, !! at the coordinate (x(i),y(i))) will be !! !! 1 if char(i) is between 0.5 and 1.5 !! 2 if char(i) is between 1.5 and 2.5 !! . !! . !! . !! 9 if char(i) is between 8.5 and 9.5 !! 0 if char(i) is between 9.5 and 10.5 !! a if char(i) is between 10.5 and 11.5 !! b if char(i) is between 11.5 and 12.5 !! c if char(i) is between 12.5 and 13.5 !! . !! . !! . !! w if char(i) is between 32.5 and 33.5 !! x if char(i) is between 33.5 and 34.5 !! y if char(i) is between 34.5 and 35.5 !! z if char(i) is between 35.5 and 36.5 !! x if char(i) is any value outside the range !! 0.5 to 36.5. !! !! the use of the subset definition vector d gives the data analyst !! the capability of plotting subsets of the data, where the subset is !! defined by values in the vector d. !! !!##OPTIONS !! X description of parameter !! Y description of parameter !! !!##EXAMPLES !! !! Sample program: !! !! program demo_pltsct !! use M_datapac, only : pltsct !! implicit none !! ! call pltsct(x,y) !! end program demo_pltsct !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the Statistical !! Engineering Division, National Institute of Standards and Technology. !!##MAINTAINER !! John Urban, 2022.05.31 !!##LICENSE !! CC0-1.0 !!##REFERENCES !! * FILLIBEN, 'STATISTICAL ANALYSIS OF INTERLAB FATIGUE TIME DATA', !! UNPUBLISHED MANUSCRIPT (AVAILABLE FROM AUTHOR) PRESENTED AT THE !! 'COMPUTER-ASSISTED DATA ANALYSIS' SESSION AT THE NATIONAL MEETING OF !! THE AMERICAN STATISTICAL ASSOCIATION, NEW YORK CITY, DECEMBER 27-30, 1973. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE PLTSCT(Y,X,Char,N,D,Dmin,Dmax) REAL(kind=wp) :: aim1 , airow , anumcm , anumlm , anumr , anumrm , Char , & & cutoff , D , delx , dely , Dmax , Dmin , hold , X , xlable , & & xmax , xmin , xwidth , Y REAL(kind=wp) :: ylable , ylower , ymax , ymin , yupper , ywidth INTEGER :: i , ia , icol , icolmx , irow , ixdel , N , n2 , & & numcol , numlab , numr25 , numr50 , numr75 , numrow ! ! ! INPUT ARGUMENTS--Y = THE VECTOR OF ! (UNSORTED OR SORTED) OBSERVATIONS ! TO BE PLOTTED VERTICALLY. ! --X = THE VECTOR OF ! (UNSORTED OR SORTED) OBSERVATIONS ! TO BE PLOTTED HORIZONTALLY. ! --CHAR = THE VECTOR OF ! OBSERVATIONS WHICH CONTROL THE ! VALUE OF EACH INDIVIDUAL PLOT ! CHARACTER. ! --N = THE INTEGER NUMBER OF OBSERVATIONS ! IN THE VECTOR Y. ! --D = THE VECTOR ! WHICH 'DEFINES' THE VARIOUS ! POSSIBLE SUBSETS. ! --DMIN = THE VALUE ! WHICH DEFINES THE LOWER BOUND ! (INCLUSIVELY) OF THE PARTICULAR ! SUBSET OF INTEREST TO BE PLOTTED. ! --DMAX = THE VALUE ! WHICH DEFINES THE UPPER BOUND ! (INCLUSIVELY) OF THE PARTICULAR ! SUBSET OF INTEREST TO BE PLOTTED. ! OUTPUT--A NARROW-WIDTH (71-CHARACTER) TERMINAL PLOT ! OF Y(I) VERSUS X(I) WITH SPECIAL PLOT CHARACTERS ! AND FOR ONLY A SPECIFIED SUBSET OF THE DATA. ! THE BODY OF THE PLOT (NOT COUNTING AXIS VALUES ! AND MARGINS) IS 25 ROWS (LINES) AND 49 COLUMNS. ! PRINTING--YES. ! RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE ! OF N FOR THIS SUBROUTINE. ! MODE OF INTERNAL OPERATIONS--. ! COMMENT--FOR A GIVEN DUMMY INDEX I, ! IF D(I) IS SMALLER THAN DMIN OR LARGER THAN DMAX, ! THEN THE CORRESPONDING POINT (X(I),Y(I)) ! WILL NOT BE PLOTTED. ! --VALUES IN THE VERTICAL AXIS VECTOR (Y), ! THE HORIZONTAL AXIS VECTOR (X), ! OR THE PLOT CHARACTER VECTOR (CHAR) WHICH ARE ! EQUAL TO OR IN EXCESS OF 10.0**10 WILL NOT BE ! PLOTTED. ! THIS CONVENTION GREATLY SIMPLIFIES THE PROBLEM ! OF PLOTTING WHEN SOME ELEMENTS IN THE VECTOR Y ! (OR X, OR CHAR) ARE 'MISSING DATA', OR WHEN WE PURPOSELY ! WANT TO IGNORE CERTAIN ELEMENTS IN THE VECTOR Y ! (OR X, OR CHAR) FOR PLOTTING PURPOSES (THAT IS, WE DO NOT ! WANT CERTAIN ELEMENTS IN Y (OR X, OR CHAR) TO BE ! PLOTTED). ! TO CAUSE SPECIFIC ELEMENTS IN Y (OR X, OR CHAR) TO BE ! IGNORED, WE REPLACE THE ELEMENTS BEFOREHAND ! (BY, FOR EXAMPLE, USE OF THE REPLAC SUBROUTINE) ! BY SOME LARGE VALUE (LIKE, SAY, 10.0**10) AND ! THEY WILL SUBSEQUENTLY BE IGNORED IN THE PLOTC ! SUBROUTINE. ! ORIGINAL VERSION--NOVEMBER 1975. ! UPDATED --FEBRUARY 1977. ! !--------------------------------------------------------------------- ! CHARACTER(len=4) :: iline CHARACTER(len=4) :: iaxisc CHARACTER(len=4) :: iplotc CHARACTER(len=4) :: jplotc CHARACTER(len=4) :: sbnam1 , sbnam2 CHARACTER(len=4) :: alph11 , alph12 , alph21 , alph22 , alph31 , alph32 CHARACTER(len=4) :: alph41 , alph42 , alph51 , alph52 CHARACTER(len=4) :: blank , hyphen , alphai ! DIMENSION Y(:) DIMENSION X(:) DIMENSION Char(:) DIMENSION D(:) DIMENSION iline(72) , xlable(10) DIMENSION iplotc(37) ! DATA sbnam1 , sbnam2/'PLTS' , 'CT '/ DATA alph11 , alph12/'FIRS' , 'T '/ DATA alph21 , alph22/'SECO' , 'ND '/ DATA alph31 , alph32/'THIR' , 'D '/ DATA alph41 , alph42/'FOUR' , 'TH '/ DATA alph51 , alph52/'FIFT' , 'H '/ DATA blank , hyphen , alphai/' ' , '-' , 'I'/ DATA iplotc(1) , iplotc(2) , iplotc(3) , iplotc(4) , iplotc(5) , & & iplotc(6) , iplotc(7) , iplotc(8) , iplotc(9) , iplotc(10) , & & iplotc(11) , iplotc(12) , iplotc(13) , iplotc(14) , & & iplotc(15) , iplotc(16) , iplotc(17) , iplotc(18) , & & iplotc(19) , iplotc(20) , iplotc(21) , iplotc(22) , & & iplotc(23) , iplotc(24) , iplotc(25) , iplotc(26) , & & iplotc(27) , iplotc(28) , iplotc(29) , iplotc(30) , & & iplotc(31) , iplotc(32) , iplotc(33) , iplotc(34) , & & iplotc(35) , iplotc(36) , iplotc(37)/'1' , '2' , '3' , '4' , & & '5' , '6' , '7' , '8' , '9' , '0' , 'A' , 'B' , 'C' , 'D' , & & 'E' , 'F' , 'G' , 'H' , 'I' , 'J' , 'K' , 'L' , 'M' , 'N' , & & 'O' , 'P' , 'Q' , 'R' , 'S' , 'T' , 'U' , 'V' , 'W' , 'X' , & & 'Y' , 'Z' , 'X'/ ! cutoff = (10.0_wp**10) - 1000.0_wp ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( N<1 ) THEN WRITE (G_IO,99014) WRITE (G_IO,99015) WRITE (G_IO,99017) alph41 , alph42 , sbnam1 , sbnam2 WRITE (G_IO,99001) N 99001 FORMAT (' ','IS NON-NEGATIVE (WITH VALUE = ',I0,')') WRITE (G_IO,99014) RETURN ELSE IF ( N==1 ) THEN WRITE (G_IO,99014) WRITE (G_IO,99015) WRITE (G_IO,99017) alph41 , alph42 , sbnam1 , sbnam2 WRITE (G_IO,99002) N 99002 FORMAT (' ','HAS THE VALUE 1') WRITE (G_IO,99014) RETURN ELSE ! hold = Y(1) DO i = 2 , N IF ( Y(i)/=hold ) GOTO 50 ENDDO WRITE (G_IO,99014) WRITE (G_IO,99015) WRITE (G_IO,99017) alph11 , alph12 , sbnam1 , sbnam2 WRITE (G_IO,99018) hold WRITE (G_IO,99014) RETURN ENDIF 50 hold = X(1) DO i = 2 , N IF ( X(i)/=hold ) GOTO 100 ENDDO WRITE (G_IO,99014) WRITE (G_IO,99015) WRITE (G_IO,99017) alph21 , alph22 , sbnam1 , sbnam2 WRITE (G_IO,99018) hold WRITE (G_IO,99014) RETURN ENDIF 100 hold = Char(1) DO i = 2 , N IF ( Char(i)/=hold ) GOTO 200 ENDDO WRITE (G_IO,99014) WRITE (G_IO,99016) WRITE (G_IO,99017) alph31 , alph32 , sbnam1 , sbnam2 WRITE (G_IO,99018) hold WRITE (G_IO,99014) 200 hold = D(1) DO i = 2 , N IF ( D(i)/=hold ) GOTO 300 ENDDO WRITE (G_IO,99014) WRITE (G_IO,99016) WRITE (G_IO,99017) alph51 , alph52 , sbnam1 , sbnam2 WRITE (G_IO,99018) hold WRITE (G_IO,99014) ! 300 DO i = 1 , N IF ( Y(i)<cutoff ) GOTO 400 ENDDO WRITE (G_IO,99014) WRITE (G_IO,99015) WRITE (G_IO,99017) alph11 , alph12 , sbnam1 , sbnam2 WRITE (G_IO,99019) WRITE (G_IO,99020) cutoff WRITE (G_IO,99014) RETURN 400 DO i = 1 , N IF ( X(i)<cutoff ) GOTO 500 ENDDO WRITE (G_IO,99014) WRITE (G_IO,99015) WRITE (G_IO,99017) alph21 , alph22 , sbnam1 , sbnam2 WRITE (G_IO,99019) WRITE (G_IO,99020) cutoff WRITE (G_IO,99014) RETURN 500 DO i = 1 , N IF ( Char(i)<cutoff ) GOTO 600 ENDDO WRITE (G_IO,99014) WRITE (G_IO,99015) WRITE (G_IO,99017) alph31 , alph32 , sbnam1 , sbnam2 WRITE (G_IO,99019) WRITE (G_IO,99020) cutoff WRITE (G_IO,99014) RETURN 600 DO i = 1 , N IF ( D(i)<cutoff ) GOTO 700 ENDDO WRITE (G_IO,99014) WRITE (G_IO,99015) WRITE (G_IO,99017) alph51 , alph52 , sbnam1 , sbnam2 WRITE (G_IO,99019) WRITE (G_IO,99020) cutoff WRITE (G_IO,99014) RETURN ! 700 DO i = 1 , N IF ( Dmin<D(i) .AND. D(i)<Dmax ) GOTO 800 ENDDO WRITE (G_IO,99014) WRITE (G_IO,99015) WRITE (G_IO,99017) alph51 , alph52 , sbnam1 , sbnam2 WRITE (G_IO,99003) 99003 FORMAT (' ','HAS ALL ELEMENTS OUTSIDE THE INTERVAL') WRITE (G_IO,99004) Dmin , Dmax 99004 FORMAT (' ','(',E15.8,',',E15.8,')',' AS DEFINED BY') WRITE (G_IO,99005) 99005 FORMAT (' ','THE SIXTH AND SEVENTH INPUT ARGUMENTS.') WRITE (G_IO,99014) RETURN ! 800 n2 = 0 DO i = 1 , N IF ( Y(i)<cutoff .AND. X(i)<cutoff .AND. Char(i)<cutoff .AND. & & D(i)<cutoff ) THEN IF ( Dmin<D(i) .AND. D(i)<Dmax ) n2 = n2 + 1 IF ( n2>=2 ) GOTO 900 ENDIF ENDDO WRITE (G_IO,99014) WRITE (G_IO,99015) WRITE (G_IO,99006) alph11 , alph12 , alph21 , alph22 , alph31 , & & alph32 , alph51 , alph52 99006 FORMAT (' ','THE ',A4,A4,', ',A4,A4,', ',A4,A4,', AND ',A4,A4) WRITE (G_IO,99007) sbnam1 , sbnam2 99007 FORMAT (' ','INPUT ARGUMENTS TO THE ',A4,A4,' SUBROUTINE') WRITE (G_IO,99008) 99008 FORMAT (' ','ARE SUCH THAT TOO MANY POINTS HAVE BEEN', & & ' EXCLUDED FROM THE PLOT.') WRITE (G_IO,99009) n2 99009 FORMAT (' ','ONLY ',I0,' POINTS ARE LEFT TO BE PLOTTED.') WRITE (G_IO,99014) RETURN ! !-----START POINT----------------------------------------------------- ! ! DEFINE THE NUMBER OF ROWS AND COLUMNS WITHIN THE PLOT--THIS HAS ! BEEN SET TO 25 ROWS AND 49 COLUMNS. ! 900 numrow = 25 numcol = 49 anumr = numrow anumrm = numrow - 1 anumcm = numcol - 1 numr25 = (numrow/4) + 1 numr50 = (numrow/2) + 1 numr75 = 3*(numrow/4) + 1 ixdel = (numcol-1)/4 numlab = 5 anumlm = numlab - 1 ! ! SKIP A LINE, WRITE OUT AN IDENTIFYING LINE FOR THE TYPE OF PLOT, ! WRITE OUT THE TOP HORIZONTAL AXIS OF THE PLOT, AND SKIP 1 LINE ! FOR A MARGIN WITHIN THE PLOT. ! WRITE (G_IO,99010) 99010 FORMAT (' ') WRITE (G_IO,99011) ! 99011 FORMAT (' ','THE FOLLOWING IS A PLOT OF Y(I) VERSUS X(I)') DO icol = 1 , numcol iline(icol) = hyphen ENDDO DO icol = 1 , numcol , ixdel iline(icol) = alphai ENDDO WRITE (G_IO,99021) (iline(i),i=1,numcol) WRITE (G_IO,99022) blank ! ! DETERMINE THE MIN AND MAX VALUES OF Y, AND OF X. ! DO i = 1 , N IF ( Y(i)<cutoff ) THEN IF ( X(i)<cutoff ) THEN IF ( Char(i)<cutoff ) THEN IF ( D(i)>=Dmin ) THEN IF ( D(i)<=Dmax ) THEN ymin = Y(i) ymax = Y(i) xmin = X(i) xmax = X(i) EXIT ENDIF ENDIF ENDIF ENDIF ENDIF ENDDO DO i = 1 , N IF ( Y(i)<cutoff ) THEN IF ( X(i)<cutoff ) THEN IF ( Char(i)<cutoff ) THEN IF ( D(i)>=Dmin ) THEN IF ( D(i)<=Dmax ) THEN IF ( Y(i)<ymin ) ymin = Y(i) IF ( Y(i)>ymax ) ymax = Y(i) IF ( X(i)<xmin ) xmin = X(i) IF ( X(i)>xmax ) xmax = X(i) ENDIF ENDIF ENDIF ENDIF ENDIF ENDDO dely = ymax - ymin delx = xmax - xmin ywidth = dely/anumrm xwidth = delx/anumcm ! ! DETERMINE AND WRITE OUT THE PLOT POSITIONS ONE LINE AT A TIME. ! ALSO DETERMINE THE APPROPRIATE PLOT CHARACTERS. ! DO irow = 1 , numrow DO icol = 1 , numcol iline(icol) = blank ENDDO airow = irow yupper = ymax + (1.5_wp-airow)*ywidth ylable = ymax + (1.0_wp-airow)*ywidth ylower = ymax + (0.5_wp-airow)*ywidth IF ( irow==numrow ) ylable = ymin DO i = 1 , N IF ( Y(i)<cutoff ) THEN IF ( X(i)<cutoff ) THEN IF ( Char(i)<cutoff ) THEN IF ( D(i)>=Dmin ) THEN IF ( D(i)<=Dmax ) THEN IF ( ylower<=Y(i) .AND. Y(i)<yupper ) THEN icol = ((X(i)-xmin)/xwidth) + 1.5_wp ia = Char(i) + 0.5_wp IF ( 1<=ia .AND. ia<=36 ) THEN jplotc = iplotc(ia) ELSE jplotc = iplotc(37) ENDIF iline(icol) = jplotc ENDIF ENDIF ENDIF ENDIF ENDIF ENDIF ENDDO icolmx = 1 DO icol = 1 , numcol IF ( iline(icol)/=blank ) icolmx = icol ENDDO iaxisc = alphai IF ( irow==1 .OR. irow==numrow ) iaxisc = hyphen IF ( irow==numr25 .OR. irow==numr50 .OR. irow==numr75 ) & & iaxisc = hyphen WRITE (G_IO,99012) ylable , iaxisc , (iline(icol),icol=1,icolmx) 99012 FORMAT (' ',E14.7,1X,A1,2X,50A1) ENDDO ! ! SKIP 1 LINE FOR A BOTTOM MARGIN WITHIN THE PLOT, WRITE OUT THE ! BOTTOM HORIZONTAL AXIS, AND WRITE OUT THE X AXIS LABELS. ! WRITE (G_IO,99022) blank DO icol = 1 , numcol iline(icol) = hyphen ENDDO DO icol = 1 , numcol , ixdel iline(icol) = alphai ENDDO WRITE (G_IO,99021) (iline(icol),icol=1,numcol) DO i = 1 , numlab aim1 = i - 1 xlable(i) = xmin + (aim1/anumlm)*delx ENDDO WRITE (G_IO,99013) (xlable(i),i=1,numlab) 99013 FORMAT (' ',9X,5E12.4) ! 99014 FORMAT (' ','**************************************************', & & '********************') 99015 FORMAT (' ',' FATAL ERROR ') 99016 FORMAT (' ',' NON-FATAL DIAGNOSTIC ') 99017 FORMAT (' ','THE ',A4,A4,' INPUT ARGUMENT TO THE ',A4,A4, & & ' SUBROUTINE') 99018 FORMAT (' ','HAS ALL ELEMENTS = ',E15.8) 99019 FORMAT (' ','HAS ALL ELEMENTS IN EXCESS OF THE CUTOFF') 99020 FORMAT (' ','VALUE OF ',E15.8) 99021 FORMAT (' ',18X,54A1) 99022 FORMAT (' ',15X,A1) ! END SUBROUTINE PLTSCT !> !!##NAME !! pltxxt(3f) - [M_datapac:LINE_PLOT] generate a line printer lag plot !! for the terminal (71 characters wide) !! !!##SYNOPSIS !! !! SUBROUTINE PLTXXT(X,N) !! !!##DESCRIPTION !! !! pltxxt(3f) yields a narrow-width (71-character) plot of x(i) versus !! x(i-1). Its narrow width makes it appropriate for use on a terminal. !! !! this type of plot (which is called an autocorrelation plot or a lag !! 1 plot) is useful in examining for autocorrelation in a sequence !! of observations. !! !! uncorrelated data will produce an autocorrelation plot with no apparent !! structure; autocorrelated data will produce an autocorrelation plot !! with linear, elliptical, or other kinds of structure. !! !!##OPTIONS !! X description of parameter !! Y description of parameter !! !!##EXAMPLES !! !! Sample program: !! !! program demo_pltxxt !! use M_datapac, only : pltxxt !! implicit none !! ! call pltxxt(x,y) !! end program demo_pltxxt !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !! !!##REFERENCES !! * FILLIBEN, 'SOME USEFUL PROCEDURES FOR THE STATISTICAL ANALYSIS OF !! DATA', UNPUBLISHED MANUSCRIPT (AVAILABLE FROM AUTHOR) PRESENTED AT !! THE FALL CONFERENCE OF THE CHEMICAL DIVISION OF THE AMERICAN SOCIETY !! FOR QUALITY CONTROL, KNOXVILLE, TENNESSEE, OCTOBER 19-20, 1972. !! * FILLIBEN, 'DATA EXPLORATION USING STAND-ALONE SUBROUTINES', !! UNPUBLISHED MANUSCRIPT (AVAILABLE FROM AUTHOR) PRESENTED AT THE !! 'STRATEGY FOR DATA ANALYSIS BY COMPUTERS' SESSION AT THE NATIONAL !! MEETING OF THE AMERICAN STATISTICAL ASSOCIATION, ST. LOUIS, MISSOURI, !! AUGUST 26-29, 1974. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE PLTXXT(X,N) REAL(kind=wp) :: aim1 , airow , anumcm , anumlm , anumr , anumrm , cutoff , & & delx , hold , X , x2labl , xcwidt , xlable , xlower , xmax , & & xmin , xrwidt , xupper INTEGER :: i , icol , icolmx , im1 , irow , ixdel , N , & & numcol , numlab , numr25 , numr50 , numr75 , numrow ! ! INPUT ARGUMENTS--X = THE VECTOR OF ! (UNSORTED) OBSERVATIONS ! TO BE GRAPHICALLY TESTED FOR ! AUTOCORRELATION. ! --N = THE INTEGER NUMBER OF OBSERVATIONS ! IN THE VECTOR X. ! OUTPUT--A NARROW-WIDTH (71-CHARACTER) TERMINAL PLOT ! OF X(I) VERSUS X(I-1). ! THE BODY OF THE PLOT (NOT COUNTING AXIS VALUES ! AND MARGINS) IS 25 ROWS (LINES) AND 49 COLUMNS. ! PRINTING--YES. ! RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE ! OF N FOR THIS SUBROUTINE. ! MODE OF INTERNAL OPERATIONS--. ! COMMENT--VALUES IN THE VERTICAL AXIS VECTOR (X) WHICH ARE ! EQUAL TO OR IN EXCESS OF 10.0**10 WILL NOT BE ! PLOTTED. ! THIS CONVENTION GREATLY SIMPLIFIES THE PROBLEM ! OF PLOTTING WHEN SOME ELEMENTS IN THE VECTOR X ! ARE 'MISSING DATA', OR WHEN WE PURPOSELY ! WANT TO IGNORE CERTAIN ELEMENTS IN THE VECTOR X ! FOR PLOTTING PURPOSES (THAT IS, WE DO NOT ! WANT CERTAIN ELEMENTS IN X TO BE PLOTTED). ! TO CAUSE SPECIFIC ELEMENTS IN X TO BE ! IGNORED, WE REPLACE THE ELEMENTS BEFOREHAND ! (BY, FOR EXAMPLE, USE OF THE REPLAC SUBROUTINE) ! BY SOME LARGE VALUE (LIKE, SAY, 10.0**10) AND ! THEY WILL SUBSEQUENTLY BE IGNORED IN THE PLTXXT ! SUBROUTINE. ! --NOTE THAT THE STORAGE REQUIREMENTS FOR THIS ! (AND THE OTHER) TERMINAL PLOT SUBROUTINESS ARE . ! VERY SMALL. ! THIS IS DUE TO THE 'ONE LINE AT A TIME' ALGORITHM ! EMPLOYED FOR THE PLOT. ! ORIGINAL VERSION--FEBRUARY 1974. ! UPDATED --APRIL 1974. ! UPDATED --OCTOBER 1974. ! UPDATED --OCTOBER 1975. ! UPDATED --NOVEMBER 1975. ! UPDATED --FEBRUARY 1977. ! !--------------------------------------------------------------------- ! CHARACTER(len=4) :: iline CHARACTER(len=4) :: iaxisc CHARACTER(len=4) :: sbnam1 , sbnam2 CHARACTER(len=4) :: alph11 , alph12 , alph21 , alph22 CHARACTER(len=4) :: blank , hyphen , alphai , alphax ! DIMENSION X(:) DIMENSION iline(72) , x2labl(10) ! DATA sbnam1 , sbnam2/'PLTX' , 'XT '/ DATA alph11 , alph12/'FIRS' , 'T '/ DATA alph21 , alph22/'SECO' , 'ND '/ DATA blank , hyphen , alphai , alphax/' ' , '-' , 'I' , 'X'/ ! cutoff = (10.0_wp**10) - 1000.0_wp ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( N<1 ) THEN WRITE (G_IO,99010) WRITE (G_IO,99011) WRITE (G_IO,99012) alph21 , alph22 , sbnam1 , sbnam2 WRITE (G_IO,99001) N 99001 FORMAT (' ','IS NON-NEGATIVE (WITH VALUE = ',I0,')') WRITE (G_IO,99010) RETURN ELSE IF ( N==1 ) THEN WRITE (G_IO,99010) WRITE (G_IO,99011) WRITE (G_IO,99012) alph21 , alph22 , sbnam1 , sbnam2 WRITE (G_IO,99002) N 99002 FORMAT (' ','HAS THE VALUE 1') WRITE (G_IO,99010) RETURN ELSE ! hold = X(1) DO i = 2 , N IF ( X(i)/=hold ) GOTO 50 ENDDO WRITE (G_IO,99010) WRITE (G_IO,99011) WRITE (G_IO,99012) alph11 , alph12 , sbnam1 , sbnam2 WRITE (G_IO,99003) hold 99003 FORMAT (' ','HAS ALL ELEMENTS = ',E15.8) WRITE (G_IO,99010) RETURN ENDIF ! 50 DO i = 1 , N IF ( X(i)<cutoff ) GOTO 100 ENDDO WRITE (G_IO,99010) WRITE (G_IO,99011) WRITE (G_IO,99012) alph11 , alph12 , sbnam1 , sbnam2 WRITE (G_IO,99004) 99004 FORMAT (' ','HAS ALL ELEMENTS IN EXCESS OF THE CUTOFF') WRITE (G_IO,99005) cutoff 99005 FORMAT (' ','VALUE OF ',E15.8) WRITE (G_IO,99010) RETURN ENDIF ! !-----START POINT----------------------------------------------------- ! ! DEFINE THE NUMBER OF ROWS AND COLUMNS WITHIN THE PLOT-- ! THIS HAS BEEN SET TO 25 ROWS AND 49 COLUMNS. ! 100 numrow = 25 numcol = 49 anumr = numrow anumrm = numrow - 1 anumcm = numcol - 1 numr25 = (numrow/4) + 1 numr50 = (numrow/2) + 1 numr75 = 3*(numrow/4) + 1 ixdel = (numcol-1)/4 numlab = 5 anumlm = numlab - 1 ! ! WRITE OUT THE TOP HORIZONTAL AXIS OF THE PLOT, AND SKIP 1 LINE ! FOR A MARGIN WITHIN THE PLOT. ! WRITE (G_IO,99006) 99006 FORMAT (' ') WRITE (G_IO,99007) ! 99007 FORMAT (' ', & &'THE FOLLOWING IS A PLOT OF X(I) (VERTICALLY) VS. , 21HX(I-1) (HO& &RIZONTALLY)') DO icol = 1 , numcol iline(icol) = hyphen ENDDO DO icol = 1 , numcol , ixdel iline(icol) = alphai ENDDO WRITE (G_IO,99013) (iline(i),i=1,numcol) WRITE (G_IO,99014) blank ! ! DETERMINE THE MIN AND MAX VALUES OF X. ! xmin = X(1) xmax = X(1) DO i = 1 , N IF ( X(i)<cutoff ) THEN IF ( X(i)<xmin ) xmin = X(i) IF ( X(i)>xmax ) xmax = X(i) ENDIF ENDDO delx = xmax - xmin xrwidt = delx/anumrm xcwidt = delx/anumcm ! ! DETERMINE AND WRITE OUT THE PLOT POSITIONS ONE LINE AT A TIME. ! DO irow = 1 , numrow DO icol = 1 , numcol iline(icol) = blank ENDDO airow = irow xupper = xmax + (1.5_wp-airow)*xrwidt xlable = xmax + (1.0_wp-airow)*xrwidt xlower = xmax + (0.5_wp-airow)*xrwidt IF ( irow==numrow ) xlable = xmin DO i = 2 , N im1 = i - 1 IF ( X(im1)<cutoff ) THEN IF ( X(i)<cutoff ) THEN IF ( xlower<=X(i) .AND. X(i)<xupper ) THEN icol = ((X(im1)-xmin)/xcwidt) + 1.5_wp iline(icol) = alphax ENDIF ENDIF ENDIF ENDDO icolmx = 1 DO icol = 1 , numcol IF ( iline(icol)==alphax ) icolmx = icol ENDDO iaxisc = alphai IF ( irow==1 .OR. irow==numrow ) iaxisc = hyphen IF ( irow==numr25 .OR. irow==numr50 .OR. irow==numr75 ) & & iaxisc = hyphen WRITE (G_IO,99008) xlable , iaxisc , (iline(icol),icol=1,icolmx) 99008 FORMAT (' ',E14.7,1X,A1,2X,50A1) ENDDO ! ! SKIP 1 LINE FOR A BOTTOM MARGIN WITHIN THE PLOT, WRITE OUT THE ! BOTTOM HORIZONTAL AXIS, AND WRITE OUT THE X AXIS LABELS. ! WRITE (G_IO,99014) blank DO icol = 1 , numcol iline(icol) = hyphen ENDDO DO icol = 1 , numcol , ixdel iline(icol) = alphai ENDDO WRITE (G_IO,99013) (iline(icol),icol=1,numcol) DO i = 1 , numlab aim1 = i - 1 x2labl(i) = xmin + (aim1/anumlm)*delx ENDDO WRITE (G_IO,99009) (x2labl(i),i=1,numlab) 99009 FORMAT (' ',9X,5E12.4) ! 99010 FORMAT (' ','**********************************************************************') 99011 FORMAT (' ',' FATAL ERROR ') 99012 FORMAT (' ','THE ',A4,A4,' INPUT ARGUMENT TO THE ',A4,A4, ' SUBROUTINE') 99013 FORMAT (' ',18X,54A1) 99014 FORMAT (' ',15X,A1) ! END SUBROUTINE PLTXXT !> !!##NAME !! poicdf(3f) - [M_datapac:CUMULATIVE_DISTRIBUTION] compute the Poisson !! cumulative distribution function !! !!##SYNOPSIS !! !! SUBROUTINE POICDF(X,Alamba,Cdf) !! !! REAL(kind=wp),intent(in) :: X !! REAL(kind=wp),intent(in) :: Alamba !! REAL(kind=wp),intent(out) :: Cdf !! !!##DESCRIPTION !! POICDF(3f) computes the cumulative distribution function value at !! the precision value X for the Poisson distribution with !! precision tail length parameter = alamba. !! !! The Poisson distribution used herein has mean = ALAMBA and standard !! deviation = sqrt(ALAMBA). !! !! This distribution is defined for all discrete non-negative integer !! X-- X = 0, 1, 2, ... . !! !! This distribution has the probability function !! !! f(X) = exp(-ALAMBA) * ALAMBA**X / X! !! !! The Poisson distribution is the distribution of the number of events !! in the interval (0,ALAMBA) when the waiting time between events is !! exponentially distributed with mean = 1 and standard deviation = 1. !! !!##INPUT ARGUMENTS !! !! X The value at which the cumulative distribution function is !! to be evaluated. x should be non-negative and integral-valued. !! ALAMBA The value of the tail length parameter. alamba should be !! positive. The tail length parameter alamba is not restricted !! to only integer values. ALAMBA can be set to any positive !! real value --integer or non-integer. !! !!##OUTPUT ARGUMENTS !! !! CDF The cumulative distribution function value. For the Poisson !! distribution !! !!##NOTE !! Even though the input to this cumulative distribution !! function subroutine for this discrete distribution should (under !! normal circumstances) be a discrete integer value, !! X has been specified as REAL so as to conform with the datapac !! convention that all input ****data**** (as opposed to sample !! size, for example) variables to all datapac subroutines are real. !! this convention is based on the belief that !! !! 1) a mixture of modes (floating point versus integer) is inconsistent !! and an unnecessary complication in a data analysis; and !! 2) floating point machine arithmetic (as opposed to integer !! arithmetic) is the more natural mode for doing data analysis. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_poicdf !! !@(#) line plotter graph of cumulative distribution function !! use M_datapac, only : poicdf, plott, label !! implicit none !! real,allocatable :: x(:), y(:) !! real :: alamba !! integer :: i !! call label('poicdf') !! x=[(real(i),i=0,100,1)] !! if(allocated(y))deallocate(y) !! allocate(y(size(x))) !! alamba=29.5 !! do i=1,size(x) !! call poicdf(X(i),Alamba,y(i)) !! enddo !! call plott(x,y,size(x)) !! end program demo_poicdf !! !! Results: !! !! The following is a plot of Y(I) (vertically) versus X(I) (horizontally) !! I-----------I-----------I-----------I-----------I !! 0.1000000E+03 - X !! 0.9583334E+02 I X !! 0.9166666E+02 I X !! 0.8750000E+02 I X !! 0.8333334E+02 I X !! 0.7916667E+02 I X !! 0.7500000E+02 - X !! 0.7083334E+02 I X !! 0.6666667E+02 I X !! 0.6250000E+02 I X !! 0.5833334E+02 I X !! 0.5416667E+02 I X !! 0.5000000E+02 - X !! 0.4583334E+02 I X !! 0.4166667E+02 I XX !! 0.3750000E+02 I XXXX !! 0.3333334E+02 I X X X X !! 0.2916667E+02 I X X X X !! 0.2500000E+02 - X X X X X !! 0.2083334E+02 I XXX X !! 0.1666667E+02 I XX !! 0.1250000E+02 I X !! 0.8333336E+01 I X !! 0.4166672E+01 I X !! 0.0000000E+00 - X !! I-----------I-----------I-----------I-----------I !! 0.1543E-12 0.2500E+00 0.5000E+00 0.7500E+00 0.1000E+01 !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !! !!##REFERENCES !! * Johnson and Kotz, Discrete Distributions, 1969, pages 87-121, !! especially page 114, Formula 93. !! * Hastings and Peacock, Statistical Distributions--A Handbook for !! Students and Practitioners, 1975, page 112. !! * National Bureau of Standards Applied Mathematics Series 55, 1964, !! page 941, Formulae 26.4.4 and 26.4.5, and page 929. !! * Feller, An Introduction to Probability Theory and Its Applications, !! Volume 1, Edition 2, 1957, pages 146-154. !! * Cox and Miller, The Theory of Stochastic Processes, 1965, page 7. !! * General Electric Company, Tables of the Individual and Cumulative !! Terms of Poisson Distribution, 1962. !! * Owen, Handbook of Statistical Tables, 1962, pages 259-261. ! ORIGINAL VERSION--NOVEMBER 1975. ! ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE POICDF(X,Alamba,Cdf) REAL(kind=wp) :: X REAL(kind=wp) :: Alamba REAL(kind=wp) :: Cdf REAL(kind=wp) :: del, fintx, gcdf, spchi INTEGER :: i, ievodd, imax, imin, intx, nu DOUBLE PRECISION dx, pi, chi, sum, term, ai, dgcdf DOUBLE PRECISION DSQRT, DEXP DATA pi/3.14159265358979D0/ ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( Alamba<=0.0_wp ) THEN WRITE (G_IO,99001) 99001 FORMAT (' ***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO POICDF(3f) IS NON-POSITIVE *****') WRITE (G_IO,99005) Alamba Cdf = 0.0_wp RETURN ELSEIF ( X<0.0_wp ) THEN WRITE (G_IO,99002) 99002 FORMAT (' ***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT TO POICDF(3f) IS NEGATIVE *****') WRITE (G_IO,99005) X Cdf = 0.0_wp RETURN ELSE intx = X + 0.0001_wp fintx = intx del = X - fintx IF ( del<0.0_wp ) del = -del IF ( del>0.001_wp ) THEN WRITE (G_IO,99003) 99003 FORMAT (' ***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT TO POICDF(3f) IS NON-INTEGRAL *****') WRITE (G_IO,99005) X 99004 FORMAT (' ','***** THE VALUE OF THE ARGUMENT IS ',I0,' *****') ENDIF ! !-----START POINT----------------------------------------------------- ! ! EXPRESS THE POISSON CUMULATIVE DISTRIBUTION ! FUNCTION IN TERMS OF THE EQUIVALENT CHI-SQUARED ! CUMULATIVE DISTRIBUTION FUNCTION, ! AND THEN EVALUATE THE LATTER. ! dx = Alamba dx = 2.0D0*dx nu = X + 0.0001_wp nu = 2*(1+nu) ! chi = DSQRT(dx) ievodd = nu - 2*(nu/2) IF ( ievodd==0 ) THEN ! sum = 1.0D0 term = 1.0D0 imin = 2 imax = nu - 2 ELSE ! sum = 0.0D0 term = 1.0_wp/chi imin = 1 imax = nu - 1 ENDIF ! IF ( imin<=imax ) THEN DO i = imin , imax , 2 ai = i term = term*(dx/ai) sum = sum + term ENDDO ENDIF ! sum = sum*DEXP(-dx/2.0D0) IF ( ievodd/=0 ) THEN sum = (DSQRT(2.0D0/pi))*sum spchi = chi CALL NORCDF(spchi,gcdf) dgcdf = gcdf sum = sum + 2.0D0*(1.0D0-dgcdf) ENDIF Cdf = sum ENDIF 99005 FORMAT (' ','***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') ! END SUBROUTINE POICDF !> !!##NAME !! poiplt(3f) - [M_datapac:LINE_PLOT] generate a Poisson probability plot !! (line printer graph) !! !!##SYNOPSIS !! !! SUBROUTINE POIPLT(X,N,Alamba) !! !!##DESCRIPTION !! poiplt(3f) generates a poisson probability plot (with REAL !! tail length parameter = alamba). !! !! the prototype poisson distribution used herein has mean = alamba and !! standard deviation = sqrt(alamba). !! !! this distribution is defined for all discrete non-negative integer !! x--x = 0, 1, 2, ... . !! !! this distribution has the probability function !! !! f(x) = exp(-alamba) * alamba**x / x!. !! !! the poisson distribution is the distribution of the number of events !! in the interval (0,alamba) when the waiting time between events is !! exponentially distributed with mean = 1 and standard deviation = 1. !! !! the prototype distribution restrictions of discreteness and !! non-negativeness mentioned above do not carry over to the input vector !! x of observations to be analyzed. !! !! the input observations in x may be discrete, continuous, non-negative, !! or negative. !! !! as used herein, a probability plot for a distribution is a plot of !! the ordered observations versus the order statistic medians for that !! distribution. the poisson probability plot is useful in graphically !! testing the composite (that is, location and scale parameters need !! not be specified) hypothesis that the underlying distribution from !! which the data have been randomly drawn is the poisson distribution !! with tail length parameter value = alamba. !! !! if the hypothesis is true, the probability plot should be near-linear. !! !! a measure of such linearity is given by the calculated probability !! plot correlation coefficient. !! !!##OPTIONS !! X description of parameter !! Y description of parameter !! !!##EXAMPLES !! !! Sample program: !! !! program demo_poiplt !! use M_datapac, only : poiplt !! implicit none !! ! call poiplt(x,y) !! end program demo_poiplt !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !! !!##REFERENCES !! * FILLIBEN, 'TECHNIQUES FOR TAIL LENGTH ANALYSIS', PROCEEDINGS OF THE !! EIGHTEENTH CONFERENCE ON THE DESIGN OF EXPERIMENTS IN ARMY RESEARCH !! DEVELOPMENT AND TESTING (ABERDEEN, MARYLAND, OCTOBER, 1972), pages !! 425-450. !! * HAHN AND SHAPIRO, STATISTICAL METHODS IN ENGINEERING, 1967, pages !! 260-308. !! * JOHNSON AND KOTZ, DISCRETE DISTRIBUTIONS, 1969, pages 87-121. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE POIPLT(X,N,Alamba) REAL(kind=wp) :: Alamba , an , arg1 , cc , cdf , cutoff , hold , sqalam , & & sum1 , sum2 , sum3 , W , wbar , WS , X , Y , ybar , yint , & & yslope , Z INTEGER :: i , iarg2 , ilamba , imax , irev , iupper , j , & & jm1 , k , N ! ! INPUT ARGUMENTS--X = THE VECTOR OF ! (UNSORTED OR SORTED) OBSERVATIONS. ! --N = THE INTEGER NUMBER OF OBSERVATIONS ! IN THE VECTOR X. ! --ALAMBA = THE VALUE OF THE ! TAIL LENGTH PARAMETER. ! ALAMBA SHOULD BE POSITIVE. ! OUTPUT--A ONE-page POISSON PROBABILITY PLOT. ! PRINTING--YES. ! RESTRICTIONS--THE MAXIMUM ALLOWABLE VALUE OF N ! FOR THIS SUBROUTINE IS 5000. ! --ALAMBA SHOULD BE POSITIVE. ! OTHER DATAPAC SUBROUTINES NEEDED--SORT, UNIMED, PLOT, ! CHSCDF, NORPPF. ! FORTRAN LIBRARY SUBROUTINES NEEDED--SQRT. ! MODE OF INTERNAL OPERATIONS--. ! COMMENT--FOR LARGE VALUES OF ALAMBA (IN EXCESS OF 500.) ! THIS SUBROUTINE USES THE NORMAL APPROXIMATION TO ! THE POISSON. THIS IS DONE TO SAVE EXECUTION TIME ! WHICH INCREASES AS A FUNCTION OF ALAMBA AND WOULD ! BE EXCESSIVE FOR LARGE VALUES OF ALAMBA. ! ORIGINAL VERSION--NOVEMBER 1974. ! UPDATED --AUGUST 1975. ! UPDATED --SEPTEMBER 1975. ! UPDATED --NOVEMBER 1975. ! UPDATED --FEBRUARY 1976. ! !--------------------------------------------------------------------- ! DIMENSION X(:) DIMENSION Y(5000) , W(5000) DIMENSION Z(5000) COMMON /BLOCK2_real32/ WS(15000) EQUIVALENCE (Y(1),WS(1)) EQUIVALENCE (W(1),WS(5001)) EQUIVALENCE (Z(1),WS(10001)) ! iupper = 5000 ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( N<1 .OR. N>iupper ) THEN WRITE (G_IO,99001) iupper 99001 FORMAT (' ', & &'***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE POIPLT SUBROU& &TINE IS OUTSIDE THE ALLOWABLE (1,',I0,') INTERVAL *****') WRITE (G_IO,99002) N 99002 FORMAT (' ','***** THE VALUE OF THE ARGUMENT IS ',I0,' *****') RETURN ELSEIF ( N==1 ) THEN WRITE (G_IO,99003) 99003 FORMAT (' ', & &'***** NON-FATAL DIAGNOSTIC--THE SECOND INPUT ARGUMENT TO THE POIP& < SUBROUTINE HAS THE VALUE 1 *****') RETURN ELSE IF ( Alamba<=0.0_wp ) THEN WRITE (G_IO,99004) 99004 FORMAT (' ', & &'***** FATAL ERROR--THE THIRD INPUT ARGUMENT TO THE POIPLT SUBROU& &TINE IS NON-POSITIVE *****') WRITE (G_IO,99005) Alamba 99005 FORMAT (' ','***** THE VALUE OF THE ARGUMENT IS ',E15.8, & & ' *****') RETURN ELSE hold = X(1) DO i = 2 , N IF ( X(i)/=hold ) GOTO 50 ENDDO WRITE (G_IO,99006) hold 99006 FORMAT (' ', & &'***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT (A VECTOR) & &TO THE POIPLT SUBROUTINE HAS ALL ELEMENTS = ',E15.8,' *****') RETURN ENDIF ! !-----START POINT----------------------------------------------------- ! 50 an = N cutoff = 500.0_wp ! ! SORT THE DATA ! CALL SORT(X,N,Y) ! ! GENERATE UNIFORM ORDER STATISTIC MEDIANS ! CALL UNIMED(N,W) ! ! COMPUTE POISSON ORDER STATISTIC MEDIANS. ! IF THE INPUT ALAMBA VALUE IS LARGE (IN EXCESS OF ! CUTOFF VALUE OF 500.0), THEN USE THE NORMAL APPROXIMATION ! TO THE POISSON. ! IF ( Alamba<=cutoff ) THEN ! ! DETERMINE WHICH UNIFORM ORDER STATISTIC MEDIAN IS ASSOCIATED WITH ! THE CLOSEST INTEGER TO ALAMBA. ! DO i = 1 , N Z(i) = -1.0_wp ENDDO ! ilamba = Alamba + 0.5_wp arg1 = 2.0_wp*Alamba iarg2 = 2*(ilamba+1) CALL CHSCDF(arg1,iarg2,cdf) cdf = 1.0_wp - cdf DO j = 1 , N IF ( W(j)>cdf ) EXIT ENDDO jm1 = j - 1 Z(jm1) = ilamba ! ! FILL IN THE POISSON ORDER STATISTIC MEDIANS BELOW ALAMBA ! imax = 6.0_wp*SQRT(Alamba) DO i = 1 , imax k = ilamba - i IF ( k<0 ) EXIT iarg2 = 2*(k+1) CALL CHSCDF(arg1,iarg2,cdf) cdf = 1.0_wp - cdf DO j = 1 , N IF ( W(j)>cdf ) EXIT ENDDO jm1 = j - 1 IF ( jm1<=0 ) EXIT IF ( Z(jm1)<-0.5_wp ) Z(jm1) = k ENDDO ! ! FILL IN THE POISSON ORDER STATISTIC MEDIANS ABOVE ALAMBA ! DO i = 1 , imax k = ilamba + i iarg2 = 2*(k+1) CALL CHSCDF(arg1,iarg2,cdf) cdf = 1.0_wp - cdf DO j = 1 , N IF ( W(j)>cdf ) GOTO 60 ENDDO Z(N) = k EXIT 60 jm1 = j - 1 IF ( Z(jm1)<-0.5_wp ) Z(jm1) = k ENDDO ! ! FILL IN THE EMPTY HOLES IN THE POISSON ORDER STATISTIC MEDIAN ! Z MATRIX WITH THE PROPER VALUES. ! THEN FOR SAKE OF CONSISTENCY WITH OTHER DATAPAC ! PROBABILITY PLOT SUBROUTINES, COPY THE Z VECTOR ! INTO THE W VECTOR. ! hold = Z(N) DO irev = 1 , N i = N - irev + 1 IF ( Z(i)>=-0.5_wp ) hold = Z(i) IF ( Z(i)<-0.5_wp ) Z(i) = hold ENDDO DO i = 1 , N W(i) = Z(i) ENDDO ELSE sqalam = SQRT(Alamba) DO i = 1 , N CALL NORPPF(W(i),W(i)) W(i) = Alamba + W(i)*sqalam ENDDO ENDIF ! ! PLOT THE ORDERED OBSERVATIONS VERSUS ORDER STATISTICS MEDIANS. ! WRITE OUT THE SAMPLE SIZE. ! CALL PLOT(Y,W,N) WRITE (G_IO,99007) Alamba , N ! 99007 FORMAT (' ','POISSON PROBABILITY PLOT WITH PARAMETER = ',9X, & & E17.10,1X,8X,11X,'THE SAMPLE SIZE N = ',I0) ! ! COMPUTE THE PROBABILITY PLOT CORRELATION COEFFICIENT. ! COMPUTE LOCATION AND SCALE ESTIMATES ! FROM THE INTERCEPT AND SLOPE OF THE PROBABILITY PLOT. ! THEN WRITE THEM OUT. ! sum1 = 0.0_wp sum2 = 0.0_wp DO i = 1 , N sum1 = sum1 + Y(i) sum2 = sum2 + W(i) ENDDO ybar = sum1/an wbar = sum2/an sum1 = 0.0_wp sum2 = 0.0_wp sum3 = 0.0_wp DO i = 1 , N sum1 = sum1 + (Y(i)-ybar)*(Y(i)-ybar) sum2 = sum2 + (Y(i)-ybar)*(W(i)-wbar) sum3 = sum3 + (W(i)-wbar)*(W(i)-wbar) ENDDO cc = sum2/SQRT(sum3*sum1) yslope = sum2/sum3 yint = ybar - yslope*wbar WRITE (G_IO,99008) cc , yint , yslope 99008 FORMAT (' ','PROBABILITY PLOT CORRELATION COEFFICIENT = ',F8.5,& & 5X,'ESTIMATED INTERCEPT = ',E15.8,3X, & & 'ESTIMATED SLOPE = ',E15.8) ENDIF ! END SUBROUTINE POIPLT !> !!##NAME !! poippf(3f) - [M_datapac:PERCENT_POINT] compute the Poisson percent !! point function !! !!##SYNOPSIS !! !! SUBROUTINE POIPPF(P,Alamba,Ppf) !! !!##DESCRIPTION !! POIPPF(3f) computes the percent point function value at the precision !! precision value P for the Poisson distribution with REAL !! tail length parameter = alamba. !! !! the poisson distribution used herein has mean = alamba and standard !! deviation = sqrt(alamba). this distribution is defined for all !! discrete non-negative integer x--x = 0, 1, 2, ... . !! !! this distribution has the probability function !! !! f(x) = exp(-alamba) * alamba**x / x!. !! !! the poisson distribution is the distribution of the number of events !! in the interval (0,alamba) when the waiting time between events is !! exponentially distributed with mean = 1 and standard deviation = 1. !! !! note that the percent point function of a distribution is identically !! the same as the inverse cumulative distribution function of the !! distribution. !! !!##OPTIONS !! X description of parameter !! Y description of parameter !! !!##EXAMPLES !! !! Sample program: !! !! program demo_poippf !! use M_datapac, only : poippf !! implicit none !! ! call poippf(x,y) !! end program demo_poippf !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the Statistical !! Engineering Division, National Institute of Standards and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !! !!##REFERENCES !! * Johnson and Kotz, Discrete Distributions, 1969, pages 87-121, !! especially page 102, Formula 36.1. --Hastings and Peacock, Statistical !! Distributions--A Handbook for Students and Practitioners, 1975, !! pages 108-113. !! * National Bureau of Standards Applied Mathematics Series 55, 1964, !! page 929. --Feller, An Introduction to Probability Theory and Its !! Applications, Volume 1, Edition 2, 1957, pages 146-154. !! * Cox and Miller, The Theory of Stochastic Processes, 1965, page 7. !! * General Electric Company, Tables of the Individual and Cumulative !! Terms of Poisson Distribution, 1962. !! * Owen, Handbook of Statistical Tables, 1962, pages 259-261. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE POIPPF(P,Alamba,Ppf) REAL(kind=wp) :: Alamba, amean, P, p0, p1, p2, pf0, Ppf, sd, x0, x1, x2, zppf INTEGER :: i, isd, ix0, ix0p1, ix1, ix2 ! ! INPUT ARGUMENTS--P = THE VALUE ! (BETWEEN 0.0 (INCLUSIVELY) ! AND 1.0 (EXCLUSIVELY)) ! AT WHICH THE PERCENT POINT ! FUNCTION IS TO BE EVALUATED. ! --ALAMBA = THE VALUE ! OF THE TAIL LENGTH PARAMETER. ! ALAMBA SHOULD BE POSITIVE. ! OUTPUT ARGUMENTS--PPF = THE PERCENT ! POINT FUNCTION VALUE. ! OUTPUT--THE PERCENT POINT . ! FUNCTION VALUE PPF ! FOR THE POISSON DISTRIBUTION ! WITH TAIL LENGTH PARAMETER = ALAMBA. ! PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. ! RESTRICTIONS--ALAMBA SHOULD BE POSITIVE. ! --P SHOULD BE BETWEEN 0.0 (INCLUSIVELY) ! AND 1.0 (EXCLUSIVELY). ! OTHER DATAPAC SUBROUTINES NEEDED--NORPPF, POICDF. ! FORTRAN LIBRARY SUBROUTINES NEEDED--SQRT, DEXP. ! MODE OF INTERNAL OPERATIONS-- AND DOUBLE PRECISION. ! COMMENT--THE TAIL LENGTH ! PARAMETER ALAMBA IS NOT RESTRICTED ! TO ONLY INTEGER VALUES. ! ALAMBA CAN BE SET TO ANY POSITIVE REAL ! VALUE--INTEGER OR NON-INTEGER. ! --NOTE THAT EVEN THOUGH THE OUTPUT ! FROM THIS DISCRETE DISTRIBUTION ! PERCENT POINT FUNCTION ! SUBROUTINE MUST NECESSARILY BE A ! DISCRETE INTEGER VALUE, ! THE OUTPUT VARIABLE PPF IS SINGLE ! PRECISION IN MODE. ! PPF HAS BEEN SPECIFIED AS SINGLE ! PRECISION SO AS TO CONFORM WITH THE DATAPAC ! CONVENTION THAT ALL OUTPUT VARIABLES FROM ALL ! DATAPAC SUBROUTINES ARE . ! THIS CONVENTION IS BASED ON THE BELIEF THAT ! 1) A MIXTURE OF MODES (FLOATING POINT ! VERSUS INTEGER) IS INCONSISTENT AND ! AN UNNECESSARY COMPLICATION ! IN A DATA ANALYSIS; AND ! 2) FLOATING POINT MACHINE ARITHMETIC ! (AS OPPOSED TO INTEGER ARITHMETIC) ! IS THE MORE NATURAL MODE FOR DOING ! DATA ANALYSIS. ! ORIGINAL VERSION--NOVEMBER 1975. ! !--------------------------------------------------------------------- ! DOUBLE PRECISION dlamba ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( P<0.0_wp .OR. P>=1.0_wp ) THEN WRITE (G_IO,99001) 99001 FORMAT (' ***** FATAL ERROR--THE FIRST INPUT ARGUMENT TO POIPPF(3f) IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL *****') WRITE (G_IO,99017) P Ppf = 0.0_wp RETURN ELSE IF ( Alamba<=0.0_wp ) THEN WRITE (G_IO,99002) 99002 FORMAT (' ***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO POIPPF(3f) IS NON-POSITIVE *****') WRITE (G_IO,99017) Alamba Ppf = 0.0_wp RETURN ELSE ! !-----START POINT----------------------------------------------------- ! dlamba = Alamba Ppf = 0.0_wp ix0 = 0 ix1 = 0 ix2 = 0 p0 = 0.0_wp p1 = 0.0_wp p2 = 0.0_wp ! ! TREAT CERTAIN SPECIAL CASES IMMEDIATELY-- ! 1) P = 0.0_wp ! 2) PPF = 0 ! IF ( P/=0.0_wp ) THEN pf0 = DEXP(-dlamba) IF ( P>pf0 ) THEN ! ! DETERMINE AN INITIAL APPROXIMATION TO THE POISSON ! PERCENT POINT BY USE OF THE NORMAL APPROXIMATION ! TO THE POISSON. ! (SEE JOHNSON AND KOTZ, DISCRETE DISTRIBUTIONS, ! page 102, FORMULA 36.1). ! amean = Alamba sd = SQRT(Alamba) CALL NORPPF(P,zppf) x2 = amean - 1.0_wp + zppf*sd ix2 = x2 ! ! CHECK AND MODIFY (IF NECESSARY) THIS INITIAL ! ESTIMATE OF THE PERCENT POINT ! TO ASSURE THAT IT BE NON-NEGATIVE. ! IF ( ix2<0 ) ix2 = 0 ! ! DETERMINE UPPER AND LOWER BOUNDS ON THE DESIRED ! PERCENT POINT BY ITERATING OUT (BOTH BELOW AND ABOVE) ! FROM THE ORIGINAL APPROXIMATION AT STEPS ! OF 1 STANDARD DEVIATION. ! THE RESULTING BOUNDS WILL BE AT MOST ! 1 STANDARD DEVIATION APART. ! ix0 = 0 ix1 = huge(0) ! = 10**10 isd = sd + 1.0_wp x2 = ix2 CALL POICDF(x2,Alamba,p2) IF ( p2<P ) THEN ix0 = ix2 DO i = 1, 100000 ix2 = ix0 + isd IF ( ix2>=ix1 ) GOTO 200 x2 = ix2 CALL POICDF(x2,Alamba,p2) IF ( p2>=P ) GOTO 50 ix0 = ix2 ENDDO WRITE (G_IO,99018) WRITE (G_IO,99003) 99003 FORMAT (' NO UPPER BOUND FOUND AFTER 10**7 ITERATIONS') ELSE ix1 = ix2 DO i = 1, 100000 ix2 = ix1 - isd IF ( ix2<=ix0 ) GOTO 200 x2 = ix2 CALL POICDF(x2,Alamba,p2) IF ( p2<P ) GOTO 100 ix1 = ix2 ENDDO WRITE (G_IO,99018) WRITE (G_IO,99004) 99004 FORMAT (' NO LOWER BOUND FOUND AFTER 10**7 ITERATIONS') ENDIF GOTO 400 ENDIF ENDIF Ppf = 0.0_wp RETURN ENDIF 50 ix1 = ix2 GOTO 200 ENDIF 100 ix0 = ix2 ! 200 IF ( ix0==ix1 ) THEN IF ( ix0==0 ) THEN ix1 = ix1 + 1 GOTO 300 ix0 = ix0 - 1 ELSE WRITE (G_IO,99018) WRITE (G_IO,99005) 99005 FORMAT (' ','LOWER AND UPPER BOUND IDENTICAL') GOTO 400 ENDIF ENDIF ! ! COMPUTE POISSON PROBABILITIES FOR THE ! DERIVED LOWER AND UPPER BOUNDS. ! 300 x0 = ix0 x1 = ix1 CALL POICDF(x0,Alamba,p0) CALL POICDF(x1,Alamba,p1) ! ! CHECK THE PROBABILITIES FOR PROPER ORDERING ! IF ( p0<P .AND. P<=p1 ) THEN DO ! ! THE STOPPING CRITERION IS THAT THE LOWER BOUND ! AND UPPER BOUND ARE EXACTLY 1 UNIT APART. ! CHECK TO SEE IF IX1 = IX0 + 1; ! IF SO, THE ITERATIONS ARE COMPLETE; ! IF NOT, THEN BISECT, COMPUTE PROBABILIIES, ! CHECK PROBABILITIES, AND CONTINUE ITERATING ! UNTIL IX1 = IX0 + 1. ! ix0p1 = ix0 + 1 IF ( ix1==ix0p1 ) THEN Ppf = ix1 IF ( p0==P ) Ppf = ix0 RETURN ELSE ix2 = (ix0+ix1)/2 IF ( ix2/=ix0 ) THEN IF ( ix2==ix1 ) THEN WRITE (G_IO,99018) WRITE (G_IO,99019) EXIT ELSE x2 = ix2 CALL POICDF(x2,Alamba,p2) IF ( p0<p2 .AND. p2<p1 ) THEN IF ( p2<=P ) THEN ix0 = ix2 p0 = p2 ELSE ix1 = ix2 p1 = p2 ENDIF CYCLE ELSEIF ( p2<=p0 ) THEN WRITE (G_IO,99018) WRITE (G_IO,99006) 99006 FORMAT (' BISECTION VALUE PROBABILITY (P2) LESS THAN LOWER BOUND PROBABILITY (P0)') EXIT ELSEIF ( p2>=p1 ) THEN WRITE (G_IO,99018) WRITE (G_IO,99007) 99007 FORMAT (' BISECTION VALUE PROBABILITY (P2) GREATER THAN UPPER BOUND PROBABILITY (P1)') EXIT ENDIF ENDIF ENDIF WRITE (G_IO,99018) WRITE (G_IO,99019) EXIT ENDIF ENDDO ELSEIF ( p0==P ) THEN Ppf = ix0 RETURN ELSEIF ( p1==P ) THEN Ppf = ix1 RETURN ELSEIF ( p0>p1 ) THEN WRITE (G_IO,99018) WRITE (G_IO,99008) 99008 FORMAT (' ','LOWER BOUND PROBABILITY (P0) GREATER THAN UPPER BOUND PROBABILITY (P1)') ELSEIF ( p0>P ) THEN WRITE (G_IO,99018) WRITE (G_IO,99009) 99009 FORMAT (' ','LOWER BOUND PROBABILITY (P0) GREATER THAN INPUT PROBABILITY (P)') ELSEIF ( p1<P ) THEN WRITE (G_IO,99018) WRITE (G_IO,99010) 99010 FORMAT (' ','UPPER BOUND PROBABILITY (P1) LESS THAN INPUT PROBABILITY (P)') ELSE WRITE (G_IO,99018) WRITE (G_IO,99011) 99011 FORMAT (' ','IMPOSSIBLE BRANCH CONDITION ENCOUNTERED') ENDIF ! 400 WRITE (G_IO,99012) ix0, p0 99012 FORMAT (' ','IX0 = ',I8,10X,'P0 = ',F14.7) WRITE (G_IO,99013) ix1, p1 99013 FORMAT (' ','IX1 = ',I8,10X,'P1 = ',F14.7) WRITE (G_IO,99014) ix2, p2 99014 FORMAT (' ','IX2 = ',I8,10X,'P2 = ',F14.7) WRITE (G_IO,99015) P 99015 FORMAT (' ','P = ',F14.7) WRITE (G_IO,99016) Alamba 99016 FORMAT (' ','ALAMBA = ',F14.7) RETURN 99017 FORMAT (' ','***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') 99018 FORMAT (' ','***** INTERNAL ERROR IN POIPPF SUBROUTINE *****') 99019 FORMAT (' ','BISECTION VALUE (X2) = LOWER BOUND (X0)') 99020 FORMAT (' ','BISECTION VALUE (X2) = UPPER BOUND (X1)') ! END SUBROUTINE POIPPF !> !!##NAME !! poiran(3f) - [M_datapac:RANDOM] generate Poisson random numbers !! !!##SYNOPSIS !! !! SUBROUTINE POIRAN(N,Alamba,Iseed,X) !! !! INTEGER,intent(in) :: N !! REAL(kind=wp),intent(in) :: Alamba !! INTEGER,intent(inout) :: Iseed !! REAL(kind=wp),intent(out) :: X(:) !! !!##DESCRIPTION !! POIRAN(3f) generates a random sample of size N from the Poisson !! distribution with REAL tail length parameter = ALAMBA. !! !! The Poisson distribution used herein has mean = ALAMBA and standard !! deviation = sqrt(ALAMBA). !! !! This distribution is defined for all discrete non-negative integer !! X where X = 0, 1, 2, ... . !! !! This distribution has the probability function !! !! f(X) = exp(-ALAMBA) * ALAMBA**X / X! !! !! The Poisson distribution is the distribution of the number of events !! in the interval (0,ALAMBA) when the waiting time between events is !! exponentially distributed with mean = 1 and standard deviation = 1. !! !! Note that even though the output from this discrete random number !! generator must necessarily be a sequence of ***integer*** values, !! the output vector X is REAL in mode. !! !! X has been specified as REAL so as to conform with the DATAPAC !! convention that all output vectors from all DATAPAC subroutines !! are REAL. this convention is based on the belief that !! !! 1. A mixture of modes (floating point versus integer) is inconsistent !! and an unnecessary complication in a data analysis; and !! !! 2. Floating point machine arithmetic (as opposed to integer arithmetic) !! is the more natural mode for doing data analysis. !! !!##INPUT ARGUMENTS !! !! N The desired integer number of random numbers to be generated. !! !! ISEED An integer seed value. Should be set to a non-negative value !! to start a new sequence of values. Will be set to -1 on return !! to indicate the next call should continue the current random !! sequence walk. !! !! ALAMBA The value of the tail length parameter. Note the tail length !! parameter ALAMBA is not restricted to only integer values. ALAMBA !! can be set to any positive real value--integer or non-integer. !! !!##OUTPUT ARGUMENTS !! !! X A vector (of dimension at least N) into which the generated !! random sample of size N from the poisson distribution will !! be placed. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_poiran !! use m_datapac, only : poiran, plott, label, plotxt, sort !! implicit none !! integer,parameter :: n=500 !! real :: x(n) !! integer :: iseed !! real :: alamba !! call label('poiran') !! alamba=2.0 !! iseed=12345 !! call poiran(N,Alamba,Iseed,X) !! call plotxt(x,n) !! call sort(x,n,x) ! sort to show distribution !! call plotxt(x,n) !! end program demo_poiran !! !! Results: !! !! !! THE FOLLOWING IS A PLOT OF X(I) (VERTICALLY) VERSUS I (HORIZONTALLY !! I-----------I-----------I-----------I-----------I !! 0.7000000E+01 - X !! 0.6708333E+01 I !! 0.6416667E+01 I !! 0.6125000E+01 I X XX X X X X !! 0.5833333E+01 I !! 0.5541667E+01 I !! 0.5250000E+01 - !! 0.4958333E+01 I XX XXXX X X X X X XX X !! 0.4666667E+01 I !! 0.4375000E+01 I !! 0.4083333E+01 I XXXX XXX X XXXXXXX XX XXXX XXXXXX X X XX XX !! 0.3791667E+01 I !! 0.3500000E+01 - !! 0.3208333E+01 I !! 0.2916667E+01 I XXX XXXXXX X XX XX XXX XXXXXXXXXXX X XXXXXXX !! 0.2625000E+01 I !! 0.2333333E+01 I !! 0.2041667E+01 I XXXXXXXXXXXXXXXX XXXXXXXXXXXXXXXXX XXXXXXXXXXXXXX !! 0.1750000E+01 - !! 0.1458333E+01 I !! 0.1166667E+01 I !! 0.8750000E+00 I XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX !! 0.5833335E+00 I !! 0.2916670E+00 I !! 0.0000000E+00 - XXXXXXXXXXXXXXX XX XX XXXXXXXXXXXXX XX XXXXXX X !! I-----------I-----------I-----------I-----------I !! 0.1000E+01 0.1258E+03 0.2505E+03 0.3752E+03 0.5000E+03 !! !! THE FOLLOWING IS A PLOT OF X(I) (VERTICALLY) VERSUS I (HORIZONTALLY !! I-----------I-----------I-----------I-----------I !! 0.7000000E+01 - X !! 0.6708333E+01 I !! 0.6416667E+01 I !! 0.6125000E+01 I XX !! 0.5833333E+01 I !! 0.5541667E+01 I !! 0.5250000E+01 - !! 0.4958333E+01 I XX !! 0.4666667E+01 I !! 0.4375000E+01 I !! 0.4083333E+01 I XXXX !! 0.3791667E+01 I !! 0.3500000E+01 - !! 0.3208333E+01 I !! 0.2916667E+01 I XXXXXXXXX !! 0.2625000E+01 I !! 0.2333333E+01 I !! 0.2041667E+01 I XXXXXXXXXXXXX !! 0.1750000E+01 - !! 0.1458333E+01 I !! 0.1166667E+01 I !! 0.8750000E+00 I XXXXXXXXXXXXXXXX !! 0.5833335E+00 I !! 0.2916670E+00 I !! 0.0000000E+00 - XXXXXXXX !! !! I-----------I-----------I-----------I-----------I !! 0.1000E+01 0.1258E+03 0.2505E+03 0.3752E+03 0.5000E+03 !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !! !!##REFERENCES !! * Cox and Miller, The Theory of Stochastic Processes, 1965, page 7. !! * Tocher, The Art of Simulation, 1963, pages 36-37. !! * Johnson and Kotz, Discrete Distributions, 1969, pages 87-121. !! * Hastings and Peacock, Statistical Distributions--A Handbook for !! Students and Practitioners, 1975, pages 108-113. !! * Feller, An Introduction to Probability Theory and Its Applications, !! Volume 1, Edition 2, 1957, pages 146-154. !! * National Bureau of Standards Applied Mathematics Series 55, 1964, !! page 929. ! VERSION NUMBER--82.6 ! ORIGINAL VERSION--NOVEMBER 1975. ! UPDATED --DECEMBER 1981. ! UPDATED --MAY 1982. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE POIRAN(N,Alamba,Iseed,X) INTEGER,intent(in) :: N REAL(kind=wp),intent(in) :: Alamba INTEGER,intent(inout) :: Iseed REAL(kind=wp),intent(out) :: X(:) INTEGER :: i , j REAL(kind=wp) :: e , sum , u(1) !--------------------------------------------------------------------- ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( N<1 ) THEN WRITE (G_IO,99001) 99001 FORMAT (' ***** FATAL ERROR--The first input argument to POIRAN(3f) is non-positive *****') WRITE (G_IO,99002) N 99002 FORMAT (' ','***** The value of the argument is ',I0,' *****') RETURN ELSEIF ( Alamba<=0.0_wp ) THEN WRITE (G_IO,99003) 99003 FORMAT (' ***** FATAL ERROR--The second input argument to POIRAN(3f) is non-positive *****') WRITE (G_IO,99004) Alamba 99004 FORMAT (' ','***** The value of the argument is ',E15.8,' *****') RETURN ELSE ! ! GENERATE N POISSON RANDOM NUMBERS USING THE FACT THAT THE DISTRIBUTION ! OF EXPONENTIAL WAITING TIMES IS POISSON. ! DO i = 1 , N sum = 0.0_wp j = 1 DO CALL UNIRAN(1,Iseed,u) e = -LOG(1.0_wp-u(1)) sum = sum + e IF ( sum>Alamba ) THEN X(i) = j - 1 EXIT ELSE j = j + 1 ENDIF ENDDO ENDDO ENDIF END SUBROUTINE POIRAN !> !!##NAME !! propor(3f) - [M_datapac:STATISTICS] compute the sample proportion !! !!##SYNOPSIS !! !! SUBROUTINE PROPOR(X,N,Xmin,Xmax,Iwrite,Xprop) !! !!##DESCRIPTION !! propor(3f) computes the the sample proportion which is the proportion !! of data between xmin and xmax (inclusively) in the input vector x. !! !! the sample proportion = (the number of observations in the sample !! between xmin and xmax, inclusively) / n. The sample proportion will !! be a REAL value between 0.0 and 1.0 (inclusively). !! !!##OPTIONS !! X description of parameter !! Y description of parameter !! !!##EXAMPLES !! !! Sample program: !! !! program demo_propor !! use M_datapac, only : propor !! implicit none !! ! call propor(x,y) !! end program demo_propor !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the Statistical !! Engineering Division, National Institute of Standards and Technology. !!##MAINTAINER !! John Urban, 2022.05.31 !!##LICENSE !! CC0-1.0 !!##REFERENCES !! * SNEDECOR AND COCHRAN, STATISTICAL METHODS, EDITION 6, 1967, pages !! 207-213. !! * DIXON AND MASSEY, INTRODUCTION TO STATISTICAL ANALYSIS, EDITION 2, !! 1957, pages 81-82, 228-231. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE PROPOR(X,N,Xmin,Xmax,Iwrite,Xprop) REAL(kind=wp) :: an , hold , sum , X , Xmax , Xmin , Xprop INTEGER :: i , isum , Iwrite , N ! ! INPUT ARGUMENTS--X = THE VECTOR OF ! (UNSORTED OR SORTED) OBSERVATIONS. ! --N = THE INTEGER NUMBER OF OBSERVATIONS ! IN THE VECTOR X. ! --XMIN = THE VALUE ! WHICH DEFINES THE LOWER LIMIT ! (INCLUSIVELY) OF THE REGION ! OF INTEREST. ! --XMAX = THE VALUE ! WHICH DEFINES THE UPPER LIMIT ! (INCLUSIVELY) OF THE REGION ! OF INTEREST. ! --IWRITE = AN INTEGER FLAG CODE WHICH ! (IF SET TO 0) WILL SUPPRESS ! THE PRINTING OF THE ! SAMPLE PROPORTION ! AS IT IS COMPUTED; ! OR (IF SET TO SOME INTEGER ! VALUE NOT EQUAL TO 0), ! LIKE, SAY, 1) WILL CAUSE ! THE PRINTING OF THE ! SAMPLE PROPORTION ! AT THE TIME IT IS COMPUTED. ! OUTPUT ARGUMENTS--XPROP = THE VALUE OF THE ! COMPUTED SAMPLE PROPORTION. ! THIS WILL BE A VALUE BETWEEN ! 0.0 AND 1.0 (INCLUSIVELY). ! OUTPUT--THE COMPUTED VALUE OF THE ! SAMPLE PROPORTION. ! PRINTING--NONE, UNLESS IWRITE HAS BEEN SET TO A NON-ZERO ! INTEGER, OR UNLESS AN INPUT ARGUMENT ERROR ! CONDITION EXISTS. ! RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE ! OF N FOR THIS SUBROUTINE. ! MODE OF INTERNAL OPERATIONS--. ! ORIGINAL VERSION--JUNE 1974. ! UPDATED --SEPTEMBER 1975. ! UPDATED --NOVEMBER 1975. ! !--------------------------------------------------------------------- ! DIMENSION X(:) ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( N<1 ) THEN WRITE (G_IO,99001) 99001 FORMAT (' ', & &'***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE PROPOR SUBROU& &TINE IS NON-POSITIVE *****') WRITE (G_IO,99002) N 99002 FORMAT (' ','***** THE VALUE OF THE ARGUMENT IS ',I0,' *****') RETURN ELSEIF ( N==1 ) THEN WRITE (G_IO,99003) 99003 FORMAT (' ', & &'***** NON-FATAL DIAGNOSTIC--THE SECOND INPUT ARGUMENT TO THE PROP& &OR SUBROUTINE HAS THE VALUE 1 *****') Xprop = 0.0_wp RETURN ELSE IF ( Xmin==Xmax ) THEN WRITE (G_IO,99004) 99004 FORMAT (' ','***** FATAL ERROR--THE THIRD AND FOURTH INPUT '& & ,'ARGUMENTS TO THE PROPOR SUBROUTINE ARE IDENTICAL') WRITE (G_IO,99005) Xmin 99005 FORMAT (' ','***** THE VALUE OF THE ARGUMENTS ARE ',E15.7, & & ' *****') Xprop = 0.0_wp RETURN ELSE hold = X(1) DO i = 2 , N IF ( X(i)/=hold ) GOTO 50 ENDDO WRITE (G_IO,99006) hold 99006 FORMAT (' ', & &'***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT (A VECTOR) & &TO THE PROPOR SUBROUTINE HAS ALL ELEMENTS =',E15.8,' *****') Xprop = 0.0_wp RETURN ENDIF ! !-----START POINT----------------------------------------------------- ! 50 an = N Xprop = 0.0_wp isum = 0 DO i = 1 , N IF ( X(i)>=Xmin .AND. Xmax>=X(i) ) isum = isum + 1 ENDDO sum = isum Xprop = sum/an ! IF ( Iwrite==0 ) RETURN WRITE (G_IO,99007) 99007 FORMAT (' ') WRITE (G_IO,99008) N , Xmin , Xmax , Xprop 99008 FORMAT (' ','THE PROPORTION OF THE ',I0, & & ' OBSERVATIONS IN THE INTERVAL ',E15.7,' TO ',E15.7, & & ' IS ',E15.7) ENDIF END SUBROUTINE PROPOR !> !!##NAME !! range(3f) - [M_datapac:STATISTICS] compute the sample range !! !!##SYNOPSIS !! !! SUBROUTINE RANGE(X,N,Iwrite,Xrange) !! !!##DESCRIPTION !! RANGE(3f) computes the sample range of the data in the input vector X. !! the sample range = sample max - sample min. !! !!##OPTIONS !! X description of parameter !! Y description of parameter !! !!##EXAMPLES !! !! Sample program: !! !! program demo_range !! use M_datapac, only : range !! implicit none !! ! call range(x,y) !! end program demo_range !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !! !!##REFERENCES !! * Kendall and Stuart, The Advanced Theory of Statistics, Volume 1, !! Edition 2, 1963, page 338. !! * David, Order Statistics, 1970, page 10-11. !! * Snedecor and Cochran, Statistical Methods, Edition 6, 1967, page 39. !! * Dixon and Massey, Introduction to Statistical Analysis, Edition 2, !! 1957, page 21. ! MODE OF INTERNAL OPERATIONS--. ! ORIGINAL VERSION--JUNE 1972. ! UPDATED --JUNE 1974. ! UPDATED --APRIL 1975. ! UPDATED --SEPTEMBER 1975. ! UPDATED --NOVEMBER 1975. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE RANGE(X,N,Iwrite,Xrange) REAL(kind=wp) :: hold , X , xmax , xmin , xramge , Xrange INTEGER :: i , Iwrite , N ! ! INPUT ARGUMENTS--X = THE VECTOR OF ! (UNSORTED OR SORTED) OBSERVATIONS. ! --N = THE INTEGER NUMBER OF OBSERVATIONS ! IN THE VECTOR X. ! --IWRITE = AN INTEGER FLAG CODE WHICH ! (IF SET TO 0) WILL SUPPRESS ! THE PRINTING OF THE ! SAMPLE RANGE ! AS IT IS COMPUTED; ! OR (IF SET TO SOME INTEGER ! VALUE NOT EQUAL TO 0), ! LIKE, SAY, 1) WILL CAUSE ! THE PRINTING OF THE ! SAMPLE RANGE ! AT THE TIME IT IS COMPUTED. ! OUTPUT ARGUMENTS--XRANGE = THE VALUE OF THE ! COMPUTED SAMPLE RANGE. ! OUTPUT--THE COMPUTED VALUE OF THE ! SAMPLE RANGE. ! PRINTING--NONE, UNLESS IWRITE HAS BEEN SET TO A NON-ZERO ! INTEGER, OR UNLESS AN INPUT ARGUMENT ERROR ! CONDITION EXISTS. ! RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE ! OF N FOR THIS SUBROUTINE. ! !--------------------------------------------------------------------- ! DIMENSION X(:) ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS IF ( N<1 ) THEN WRITE (G_IO,99001) 99001 FORMAT (' ', & &'***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE RANGE SUBROU& &TINE IS NON-POSITIVE *****') WRITE (G_IO,99002) N 99002 FORMAT (' ','***** THE VALUE OF THE ARGUMENT IS ',I0,' *****') RETURN ELSE ! IF ( N==1 ) THEN WRITE (G_IO,99003) 99003 FORMAT (' ', & &'***** NON-FATAL DIAGNOSTIC--THE SECOND INPUT ARGUMENT TO THE RANG& &E SUBROUTINE HAS THE VALUE 1 *****') xramge = 0.0_wp ELSE hold = X(1) DO i = 2 , N IF ( X(i)/=hold ) GOTO 50 ENDDO WRITE (G_IO,99004) hold 99004 FORMAT (' ', & &'***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT (A VECTOR) & &TO THE RANGE SUBROUTINE HAS ALL ELEMENTS = ',E15.8,' *****') Xrange = 0.0_wp ENDIF GOTO 100 ! !-----START POINT----------------------------------------------------- ! 50 xmin = X(1) xmax = X(1) DO i = 1 , N IF ( X(i)<xmin ) xmin = X(i) IF ( X(i)>xmax ) xmax = X(i) ENDDO Xrange = xmax - xmin ENDIF ! 100 IF ( Iwrite==0 ) RETURN WRITE (G_IO,99005) 99005 FORMAT (' ') WRITE (G_IO,99006) N , Xrange 99006 FORMAT (' ','THE SAMPLE RANGE OF THE ',I0,' OBSERVATIONS IS ', & & E15.8) END SUBROUTINE RANGE !> !!##NAME !! rank(3f) - [M_datapac:SORT] rank a vector of sample observations !! !!##SYNOPSIS !! !! SUBROUTINE RANK(X,N,Xr) !! !! REAL(kind=wp),intent(in) :: X(:) !! INTEGER,intent(in) :: N !! REAL(kind=wp),intent(out) :: Xr(:) !! !!##DESCRIPTION !! RANK(3f) ranks (in ascending order) the N elements of the precision !! precision vector X, and puts the resulting N ranks into the precision !! precision vector XR. !! !! RANK(3f) gives the data analyst the ability to (for example) rank !! the data preliminary to certain distribution-free analyses. !! !!##NOTES !! The rank of the first element of the vector X will be placed in the !! first position of the vector XR, the rank of the second element of the !! vector X will be placed in the second position of the vector XR, etc. !! !! The smallest element in the vector X will have a rank of 1 (unless !! ties exist). the largest element in the vector X will have a rank of N !! (unless ties exist). !! !! Although ranks are usually (unless ties exist) integral values from !! 1 to N, it is to be noted that they are outputted as REAL values in !! the vector XR. XR is so as to be consistent with the fact that all !! vector arguments in all other datapac subroutines are REAL; but more !! importantly, because ties frequently do exist in data sets and so some !! of the resulting ranks will be non-integral and so the output vector !! of ranks must necessarily be REAL and not INTEGER. !! !! The input vector X remains unaltered. !! !! Due to conflicting use of labeled common /block2_real32/ by this !! rank subroutine and the SPCORR (Spearman rank correlation coefficient) !! subroutine, the vector XS of this rank subroutine has been placed in !! labeled common /block4_real32/ !! !! The first and third arguments in the calling sequence may be identical; !! that is, an 'in place' ranking is permitted. The calling sequence !! call RANK(X,N,X) is valid, if desired. !! !! The sorting algorthm used herein is the binary sort. This algorthim !! is extremely fast as the following time trials indicate. These time !! trials were carried out on the UNIVAC 1108 EXEC 8 system at NBS in !! August of 1974. by way of comparison, the time trial values for the !! easy-to-program but extremely inefficient bubble sort algorithm have !! also been included-- !! !! Number of random Binary sort Bubble sort !! numbers sorted !! n = 10 .002 sec .002 sec !! n = 100 .011 sec .045 sec !! n = 1000 .141 sec 4.332 sec !! n = 3000 .476 sec 37.683 sec !! n = 10000 1.887 sec not computed !! !!##INPUT ARGUMENTS !! !! X The vector of observations to be ranked. !! N The integer number of observations in the vector X. !! The maximum allowable value of N for this subroutine is 7500. !! !!##OUTPUT ARGUMENTS !! !! XR The vector into which the ranks of the X values will be placed !! (in ascending order) !! !!##EXAMPLES !! !! Sample program: !! !! program demo_rank !! use M_datapac, only : rank !! implicit none !! ! call rank(x,y) !! end program demo_rank !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !! !!##REFERENCES !! * CACM March 1969, page 186 (Binary Sort Algorithm by Richard !! C. Singleton). !! * CACM January 1970, page 54. !! * CACM October 1970, page 624. !! * JACM January 1961, page 41. ! ORIGINAL VERSION--JUNE 1972. ! UPDATED --JANUARY 1975. ! UPDATED --NOVEMBER 1975. ! UPDATED --JANUARY 1977. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE RANK(X,N,Xr) REAL(kind=wp),intent(in) :: X(:) INTEGER,intent(in) :: N REAL(kind=wp),intent(out) :: Xr(:) REAL(kind=wp) :: an , avrank , hold , rprev , xprev , XS INTEGER :: i , ibran , iupper , j , jmin , jp1 , k , nm1 COMMON /BLOCK4_real32/ XS(7500) !--------------------------------------------------------------------- an = N iupper = 7500 ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( N<1 .OR. N>iupper ) THEN WRITE (G_IO,99001) iupper 99001 FORMAT(& & ' ***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO RANK(3f) IS OUTSIDE THE ALLOWABLE (1,',I0,') INTERVAL *****') WRITE (G_IO,99002) N 99002 FORMAT (' ','***** THE VALUE OF THE ARGUMENT IS ',I0,' *****') RETURN ELSE IF ( N==1 ) THEN WRITE (G_IO,99003) 99003 FORMAT (' ***** NON-FATAL DIAGNOSTIC--THE SECOND INPUT ARGUMENT TO RANK(3f) HAS THE VALUE 1 *****') Xr(1) = 1.0_wp RETURN ELSE hold = X(1) DO i = 2 , N IF ( X(i)/=hold ) GOTO 50 ENDDO WRITE (G_IO,99004) hold 99004 FORMAT (' ***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT (A VECTOR) TO RANK(3f) HAS ALL ELEMENTS = ', & & E15.8,' *****') avrank = (an+1.0_wp)/2.0_wp DO i = 1 , N Xr(i) = avrank ENDDO RETURN ENDIF ! !-----START POINT----------------------------------------------------- ! ! FIRST SORT THE DATA FROM THE INPUT VECTOR X ! INTO THE INTERMEDIATE STORAGE VECTOR XS. ! 50 CALL SORT(X,N,XS) ! ! NOW DETERMINE THE RANKS. ! THE BASIC ALGORITHM IS TO TAKE A GIVEN ELEMENT ! IN THE ORIGINAL INPUT VECTOR X, ! AND SCAN THE SORTED VALUES IN THE XS VECTOR ! UNTIL A MATCH IS FOUND; ! WHEN A MATCH IS FOUND, THEN THE RANK FOR THAT ! VALUE IN THE XS VECTOR IS DETERMINED. ! THAT RANK IS THEN WRITTEN INTO THAT POSITION ! IN THE OUTPUT Y VECTOR WHICH CORRESPONDS TO THE POSITION OF THE ! GIVEN ELEMENT OF INTEREST IN THE ORIGINAL X VECTOR. ! THE CODE IS LENGTHENED FROM THIS BASIC ALGORITHM ! BY A SECTION WHICH CUTS DOWN THE SEARCH IN THE XS VECTOR, ! AND BY A SECTION WHICH OBVIATES (UNDER CERTAIN CIRCUMSTANCES) ! THE NEED FOR RECALCULATING THE RANK OF AN ELEMENT IN XS. ! nm1 = N - 1 xprev = X(1) DO i = 1 , N jmin = 1 IF ( X(i)>xprev ) THEN jmin = k IF ( jmin>=N ) THEN IF ( jmin==N ) GOTO 60 ibran = 1 WRITE (G_IO,99007) ibran WRITE (G_IO,99005) jmin 99005 FORMAT (' ','JMIN = ',I0) STOP ENDIF ELSEIF ( i/=1 ) THEN IF ( X(i)==xprev ) THEN Xr(i) = rprev GOTO 80 ENDIF ENDIF DO j = jmin , nm1 IF ( X(i)==XS(j) ) THEN jp1 = j + 1 DO k = jp1 , N IF ( XS(k)/=XS(j) ) GOTO 55 ENDDO k = N + 1 55 avrank = j + k - 1 avrank = avrank/2.0_wp Xr(i) = avrank GOTO 80 ENDIF ENDDO 60 j = N k = N + 1 IF ( X(i)==XS(j) ) THEN Xr(i) = N ELSE ibran = 2 WRITE (G_IO,99007) ibran WRITE (G_IO,99006) X(i) , XS(j) 99006 FORMAT (' ','X(I) = ',F15.7,' XS(J) = ',F15.7) STOP ENDIF 80 xprev = X(i) rprev = Xr(i) ENDDO ENDIF 99007 FORMAT (' ','*****INTERNAL ERROR IN RANK SUBROUTINE-- IMPOSSIBLE BRANCH CONDITION AT BRANCH POINT = ',I0) END SUBROUTINE RANK !> !!##NAME !! ranper(3f) - [M_datapac:RANDOM] generates a random permutation !! !!##SYNOPSIS !! !! SUBROUTINE RANPER(N,Istart,X) !! !! INTEGER,intent(in) :: N !! INTEGER,intent(inout) :: Istart !! REAL(kind=wp) :: X(:) !! !!##DESCRIPTION !! RANPER(3f) generates a random permutation of size N of the values 1.0, !! 2.0, 3.0, ..., N-1, N. !! !!##INPUT ARGUMENTS !! !! N The desired integer size of the random 1 to N permutation. !! !! ISTART An integer flag code which (if set to 0) will start the !! generator over and hence produce the same random permutation !! over and over again upon successive calls to this subroutine !! within a run; or (if set to some integer value not equal to 0, !! like, say, 1) will allow the generator to continue from where !! it stopped and hence produce different random permutations !! upon successive calls to this subroutine within a run. !! !!##OUTPUT ARGUMENTS !! !! X A vector (of dimension at least N) into which the generated !! random permutation will be placed of size N of the values 1.0, !! 2.0, 3.0, ..., n-1, n. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_ranper !! use M_datapac, only : ranper !! implicit none !! integer,parameter :: n=10 !! integer :: istart !! real :: x(n) !! integer :: i !! do i=1,3 !! istart=i !! call RANPER(N,Istart,X) !! write(*,*)istart !! write(*,'(*(g0.2,1x))')x !! enddo !! end program demo_ranper !! !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !! Algorithm suggested by Dan Lozier, National Bureau of Standards !! (205.01). !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 ! ORIGINAL VERSION--JUNE 1972. ! UPDATED --MAY 1974. ! UPDATED --SEPTEMBER 1975. ! UPDATED --NOVEMBER 1975. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE RANPER(N,Istart,X) INTEGER,intent(in) :: N INTEGER,intent(inout) :: Istart REAL(kind=wp) :: X(:) INTEGER :: i , iadd , j REAL(kind=wp) :: add , an , hold , u(1) INTEGER :: iseed ! an = N ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( N<1 ) THEN WRITE (G_IO,99001) 99001 FORMAT (' ***** FATAL ERROR--The first input argument to RANPER(3f) is non-positive *****') WRITE (G_IO,99002) N 99002 FORMAT (' ***** The value of the argument is ',I0,' *****') RETURN ELSEIF ( N==1 ) THEN WRITE (G_IO,99003) 99003 FORMAT (' ***** NON-FATAL DIAGNOSTIC--The first input argument to RANPER(3f) has the value 1 *****') X(1) = 1 RETURN ELSE CALL UNIRAN(1,Istart,u) DO i = 1 , N X(i) = i ENDDO Iseed=1 DO i = 1 , N CALL UNIRAN(1,iseed,u) add = an*u(1) + 1.0_wp iadd = add IF ( iadd<1 ) iadd = 1 IF ( iadd>N ) iadd = N j = i + iadd IF ( j>N ) j = j - N hold = X(j) X(j) = X(i) X(i) = hold ENDDO ENDIF END SUBROUTINE RANPER !> !!##NAME !! relsd(3f) - [M_datapac:STATISTICS] compute the relative standard !! deviation of a vector of observations !! !!##SYNOPSIS !! !! SUBROUTINE RELSD(X,N,Iwrite,Xrelsd) !! !!##DESCRIPTION !! RELSD(3f) computes the sample relative standard deviation of the data !! in the input vector X. !! !! The sample relative standard deviation = (the sample standard !! deviation)/(the sample mean). !! !! The denominator N-1 is used in computing the sample standard deviation. !! !! The sample relative standard deviation is alternatively referred to !! as the sample coefficient of variation. !! !!##OPTIONS !! X description of parameter !! Y description of parameter !! !!##EXAMPLES !! !! Sample program: !! !! program demo_relsd !! use M_datapac, only : relsd !! implicit none !! ! call relsd(x,y) !! end program demo_relsd !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the Statistical !! Engineering Division, National Institute of Standards and Technology. !!##MAINTAINER !! John Urban, 2022.05.31 !!##LICENSE !! CC0-1.0 !!##REFERENCES !! * KENDALL AND STUART, THE ADVANCED THEORY OF STATISTICS, VOLUME 1, !! EDITION 2, 1963, pages 47, 233. !! * SNEDECOR AND COCHRAN, STATISTICAL METHODS, EDITION 6, 1967, pages !! 62-65. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE RELSD(X,N,Iwrite,Xrelsd) REAL(kind=wp) :: an , hold , sd , sum , var , X , xmean , Xrelsd INTEGER :: i , Iwrite , N ! ! INPUT ARGUMENTS--X = THE VECTOR OF ! (UNSORTED OR SORTED) OBSERVATIONS. ! --N = THE INTEGER NUMBER OF OBSERVATIONS ! IN THE VECTOR X. ! --IWRITE = AN INTEGER FLAG CODE WHICH ! (IF SET TO 0) WILL SUPPRESS ! THE PRINTING OF THE ! SAMPLE RELATIVE STANDARD DEVIATION ! AS IT IS COMPUTED; ! OR (IF SET TO SOME INTEGER ! VALUE NOT EQUAL TO 0), ! LIKE, SAY, 1) WILL CAUSE ! THE PRINTING OF THE ! SAMPLE RELATIVE STANDARD DEVIATION ! AT THE TIME IT IS COMPUTED. ! OUTPUT ARGUMENTS--XRELSD = THE VALUE OF THE ! COMPUTED SAMPLE RELATIVE ! STANDARD DEVIATION. ! OUTPUT--THE COMPUTED VALUE OF THE ! SAMPLE RELATIVE STANDARD DEVIATION. ! PRINTING--NONE, UNLESS IWRITE HAS BEEN SET TO A NON-ZERO ! INTEGER, OR UNLESS AN INPUT ARGUMENT ERROR ! CONDITION EXISTS. ! RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE ! OF N FOR THIS SUBROUTINE. ! FORTRAN LIBRARY SUBROUTINES NEEDED--SQRT. ! MODE OF INTERNAL OPERATIONS--. ! ORIGINAL VERSION--JUNE 1972. ! UPDATED --MARCH 1975. ! UPDATED --SEPTEMBER 1975. ! UPDATED --NOVEMBER 1975. ! !--------------------------------------------------------------------- ! DIMENSION X(:) ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! an = N IF ( N<1 ) THEN WRITE (G_IO,99001) 99001 FORMAT (' ', & &'***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE RELSD SUBROU& &TINE IS NON-POSITIVE *****') WRITE (G_IO,99002) N 99002 FORMAT (' ','***** THE VALUE OF THE ARGUMENT IS ',I0,' *****') RETURN ELSE IF ( N==1 ) THEN WRITE (G_IO,99003) 99003 FORMAT (' ', & &'***** NON-FATAL DIAGNOSTIC--THE SECOND INPUT ARGUMENT TO THE RELS& &D SUBROUTINE HAS THE VALUE 1 *****') Xrelsd = 0.0_wp ELSE hold = X(1) DO i = 2 , N IF ( X(i)/=hold ) GOTO 50 ENDDO WRITE (G_IO,99004) hold 99004 FORMAT (' ', & &'***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT (A VECTOR) & &TO THE RELSD SUBROUTINE HAS ALL ELEMENTS = ',E15.8,' *****') Xrelsd = 0.0_wp ENDIF GOTO 100 ! !-----START POINT----------------------------------------------------- ! 50 sum = 0.0_wp DO i = 1 , N sum = sum + X(i) ENDDO xmean = sum/an sum = 0.0_wp DO i = 1 , N sum = sum + (X(i)-xmean)**2 ENDDO var = sum/(an-1.0_wp) sd = SQRT(var) Xrelsd = 100.0_wp*sd/xmean ENDIF ! 100 IF ( Iwrite==0 ) RETURN WRITE (G_IO,99005) 99005 FORMAT (' ') WRITE (G_IO,99006) N , Xrelsd 99006 FORMAT (' THE RELATIVE STANDARD DEVIATION (= STANDARD ', & & 'DEVIATION/MEAN) FOR THE ',I0,' OBSERVATIONS IS ',E12.8, & & ' PERCENT') END SUBROUTINE RELSD !> !!##NAME !! replac(3f) - [M_datapac:VECTOR_OPERATION] replace all observations !! in a vector within a given interval with a user-specified constant !! !!##SYNOPSIS !! !! SUBROUTINE REPLAC(X,N,Xmin,Xmax,Xnew) !! !!##DESCRIPTION !! REPLAC(3f) replaces (with the value XNEW) all observations in the REAL !! vector X which are inside the closed (inclusive) interval defined by !! XMIN and XMAX. !! !! All observations outside of this interval are left unchanged. !! Thus all observations in X which are equal to or larger than XMIN !! and equal to or smaller than XMAX, will be replaced by XNEW. !! !! REPLAC(3f) (and the RETAIN(3f) and DELETE(3f) subroutines) gives !! the data analyst the ability to easily 'clean up' a data set which !! has missing and/or outlying observations so that a more appropriate !! subsequent data analysis may be performed. For example, replacement !! of an outlier with a more appropriate value can easily be done by !! REPLAC(3f). !! !!##OPTIONS !! X description of parameter !! Y description of parameter !! !!##EXAMPLES !! !! Sample program: !! !! program demo_replac !! use M_datapac, only : replac !! implicit none !! ! call replac(x,y) !! end program demo_replac !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !!##MAINTAINER !! John Urban, 2022.05.31 !!##LICENSE !! CC0-1.0 ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE REPLAC(X,N,Xmin,Xmax,Xnew) REAL(kind=wp) :: hold , pointl , pointu , X , Xmax , Xmin , Xnew INTEGER :: i , k , N , ndel ! ! INPUT ARGUMENTS--X = THE VECTOR OF ! (UNSORTED OR SORTED) OBSERVATIONS. ! --N = THE INTEGER NUMBER OF OBSERVATIONS ! IN THE VECTOR X. ! --XMIN = THE VALUE ! WHICH DEFINES THE LOWER LIMIT ! (INCLUSIVELY) OF THE PARTICULAR ! INTERVAL OF INTEREST FOR REPLACEMENT. ! --XMAX = THE VALUE ! WHICH DEFINES THE UPPER LIMIT ! (INCLUSIVELY) OF THE PARTICULAR ! INTERVAL OF INTEREST FOR REPLACEMENT. ! --XNEW = THE VALUE ! WITH WHICH ALL OF THE ! OBSERVATIONS IN THE INTERVAL ! OF INTEREST ! WILL BE REPLACED. ! OUTPUT--THE VECTOR X ! IN WHICH ONLY THOSE VALUES INSIDE ! (INCLUSIVELY) THE INTERVAL OF INTEREST ! HAVE BEEN REPLACED BY XNEW. ! ALSO, 6 LINES OF SUMMARY INFORMATION ! WILL BE GENERATED INDICATING ! 1) WHAT THE INTERVAL OF INTEREST WAS; ! 2) WHAT THE REPLACEMENT VALUE WAS; ! 3) HOW MANY OBSERVATIONS WERE REPLACED; ! 4) WHAT THE SAMPLE SIZE WAS (N); ! PRINTING--YES. ! RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE ! OF N FOR THIS SUBROUTINE. ! MODE OF INTERNAL OPERATIONS--. ! COMMENT--THIS SUBROUTINE MAY BE USEFULLY EMPLOYED ! IN CONJUNCTION WITH THE DATAPAC ! PLOTTING SUBROUTINES INASMUCH ! AS THE LATTER HAVE BEEN ! SET UP WITH THE CONVENTION ! THAT ALL VALUES IN THE VERTICAL AXIS ! VECTOR OR HORIZONTAL AXIS VECTOR ! WHICH ARE EQUAL TO OR IN EXCESS OF 10.0**10 ! WILL BE AUTOMATICALLY IGNORED ! IN THE PLOT (THAT IS, NOT PLOTTED). ! THIS CONVENTION GREATLY SIMPLIFIES THE PROBLEM ! OF PLOTTING WHEN SOME ELEMENTS IN THE VERTICAL ! OR HORIZONTAL AXIS VECTORS ! ARE 'MISSING DATA', OR WHEN WE PURPOSELY ! WANT TO IGNORE CERTAIN ELEMENTS IN THESE VECTORS ! FOR PLOTTING PURPOSES (THAT IS, WE DO NOT ! WANT CERTAIN ELEMENTS TO BE PLOTTED). ! TO CAUSE SPECIFIC ELEMENTS IN THE VERTICAL ! OR HORIZONTAL AXIS VECTORS TO BE ! IGNORED, WE REPLACE THE ELEMENTS BEFOREHAND ! (BY USE OF THE REPLAC SUBROUTINE) ! BY SOME LARGE VALUE (LIKE, SAY, 10.0**10) AND ! THEY WILL SUBSEQUENTLY BE IGNORED IN THE PLOTTING ! SUBROUTINES. ! COMMENT--THIS IS ONE OF THE FEW SUBRUTINES IN DATAPAC ! IN WHICH THE INPUT VECTOR X IS ALTERED. ! ORIGINAL VERSION--NOVEMBER 1972. ! UPDATED --NOVEMBER 1975. ! !--------------------------------------------------------------------- ! DIMENSION X(:) ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( N<1 ) THEN WRITE (G_IO,99001) 99001 FORMAT (' ***** FATAL ERROR--The second input argument to REPLAC(3f) is non-positive *****') WRITE (G_IO,99002) N 99002 FORMAT (' ','***** The value of the argument is ',I0,' *****') RETURN ELSE IF ( N==1 ) THEN WRITE (G_IO,99003) 99003 FORMAT (' ***** NON-FATAL DIAGNOSTIC--The second input argument to REPLAC(3f) has the value 1 *****') ELSE hold = X(1) DO i = 2 , N IF ( X(i)/=hold ) GOTO 50 ENDDO WRITE (G_IO,99004) hold 99004 FORMAT (' ***** NON-FATAL DIAGNOSTIC--The first input argument (a vector) to REPLAC(3f) has all elements =',& & E15.8,' *****') ENDIF ! !-----START POINT----------------------------------------------------- ! 50 pointl = Xmin pointu = Xmax IF ( Xmin>Xmax ) pointl = Xmax IF ( Xmin>Xmax ) pointu = Xmin ! k = 0 DO i = 1 , N IF ( X(i)>=pointl .AND. X(i)<=pointu ) THEN k = k + 1 X(i) = Xnew ENDIF ENDDO ndel = N - k ! ! WRITE OUT A BRIEF SUMMARY ! WRITE (G_IO,99005) 99005 FORMAT (' ') WRITE (G_IO,99006) 99006 FORMAT (' ','output from the REPLAC subroutine--') WRITE (G_IO,99007) pointl , pointu 99007 FORMAT (' ',7X,'only observations between ',E15.8,' and ', E15.8) WRITE (G_IO,99008) 99008 FORMAT (' ',7X,'(inclusive) have been replaced.') WRITE (G_IO,99009) 99009 FORMAT (' ',7X,'all observations outside of this interval') WRITE (G_IO,99010) 99010 FORMAT (' ',7X,'have been left unchanged.') WRITE (G_IO,99011) Xnew 99011 FORMAT (' ',7X,'The replacement value is ',E15.8) WRITE (G_IO,99012) N 99012 FORMAT (' ',7X,'The input number of observations is ',I0) WRITE (G_IO,99013) k 99013 FORMAT (' ',7X,'The number of observations replaced is ',I0) WRITE (G_IO,99014) ndel 99014 FORMAT (' ',7X,'The number of observations unchanged is ',I0) ENDIF ! END SUBROUTINE REPLAC !> !!##NAME !! retain(3f) - [M_datapac:VECTOR_OPERATION] retain all observations in a !! vector within a user-specified interval !! !!##SYNOPSIS !! !! SUBROUTINE RETAIN(X,N,Xmin,Xmax,Newn) !! !!##DESCRIPTION !! RETAIN(3f) retains all observations in the REAL vector X which are !! inside the closed (inclusive) interval defined by XMIN and XMAX, !! while deleting all observations outside of this interval. !! !! Thus all observations in X which are smaller than XMIN or larger !! than XMAX are deleted from X. RETAIN(3f) (and the REPLAC and DELETE !! subroutines) gives the data analyst the ability to easily 'clean up' a !! data set which has missing and/or outlying observations so that a more !! appropriate subsequent data analysis may be performed. For example, !! a trimmed sample can easily be constructed by use of RETAIN(3f). !! !!##OPTIONS !! X description of parameter !! Y description of parameter !! !!##EXAMPLES !! !! Sample program: !! !! program demo_retain !! use M_datapac, only : retain !! implicit none !! ! call retain(x,y) !! end program demo_retain !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !!##MAINTAINER !! John Urban, 2022.05.31 !!##LICENSE !! CC0-1.0 ! ORIGINAL VERSION--NOVEMBER 1972. ! UPDATED --JULY 1974. ! UPDATED --NOVEMBER 1975. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE RETAIN(X,N,Xmin,Xmax,Newn) REAL(kind=wp) :: hold , pointl , pointu , X , Xmax , Xmin INTEGER :: i , k , N , ndel , Newn , newnp1 , nold ! ! INPUT ARGUMENTS--X = THE VECTOR OF ! (UNSORTED OR SORTED) OBSERVATIONS. ! --N = THE INTEGER NUMBER OF OBSERVATIONS ! IN THE VECTOR X. ! --XMIN = THE VALUE ! WHICH DEFINES THE LOWER LIMIT ! (INCLUSIVELY) OF THE PARTICULAR ! INTERVAL OF INTEREST TO BE RETAINED. ! --XMAX = THE VALUE ! WHICH DEFINES THE UPPER LIMIT ! (INCLUSIVELY) OF THE PARTICULAR ! INTERVAL OF INTEREST TO BE RETAINED. ! OUTPUT ARGUMENTS--NEWN = THE INTEGER NUMBER OF OBSERVATIONS ! REMAINING (RETAINED) IN X AFTER ALL ! OF THE OBSERVATIONS OUTSIDE THE ! INTERVAL OF INTEREST HAVE BEEN ! DELETED. ! OUTPUT--THE VECTOR X ! IN WHICH ONLY THOSE VALUES INSIDE ! (INCLUSIVELY) THE INTERVAL OF INTEREST ! HAVE BEEN RETAINED, AND ! THE INTEGER VALUE NEWN ! WHICH GIVES THE NUMBER OF ! OBSERVATIONS RETAINED IN X. ! ALSO, 6 LINES OF SUMMARY INFORMATION ! WILL BE GENERATED INDICATING ! 1) WHAT THE INTERVAL OF INTEREST WAS; ! 2) HOW MANY OBSERVATIONS WERE DELETED; ! 3) WHAT THE OLD (ORIGINAL) SAMPLE SIZE WAS (N); ! 4) WHAT THE NEW SAMPLE SIZE IS (NEWN). ! PRINTING--YES. ! RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE ! OF N FOR THIS SUBROUTINE. ! MODE OF INTERNAL OPERATIONS--. ! COMMENT--IN THE END, AFTER THIS SUBROUTINE HAS ! MADE WHATEVER DELETIONS ARE APPROPRIATE, ! THE OUTPUT VECTOR X WILL BE 'PACKED'; ! THAT IS, NO 'HOLES' WILL EXIST IN THE ! VECTOR X--ALL OF THE RETAINED ELEMENTS ! OF X WILL BE PACKED INTO THE FIRST AVAILABLE ! LOCATIONS IN X, WHILE THE REMAINDER ! OF THE N LOCATIONS IN X WILL BE ZERO-FILLED. ! COMMENT--IN THE MAIN (CALLING) ROUTINE, IT IS ! PERMISSABLE (IF THE ANALYST SO DESIRES) ! TO USE THE SAME VARIABLE NAME ! IN THE FIFTH ARGUMENT AS USED IN THE SECOND ! ARGUMENT IN THE CALLING SEQUENCE TO THIS ! RETAIN SUBROUTINE--NO CONFLICT WILL RESULT ! IN THE INTERNAL OPERATION OF THE RETAIN ! SUBROUTINE. FOR EXAMPLE, IT IS PERMISSIBLE ! TO HAVE CALL RETAIN(X,N,-10.0,10.0,N) ! IN WHICH THE VARIABLE NAME N IS USED ! AS BOTH THE SECOND AND FIFTH ARGUMENTS. ! COMMENT--THIS IS ONE OF THE FEW SUBROUTINES IN DATAPAC ! IN WHICH THE INPUT VECTOR X IS ALTERED. ! !--------------------------------------------------------------------- ! DIMENSION X(:) ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( N<1 ) THEN WRITE (G_IO,99001) 99001 FORMAT (' ***** FATAL ERROR--The second input argument to RETAIN(3f) is non-positive *****') WRITE (G_IO,99002) N 99002 FORMAT (' ***** The value of the argument is ',I0,' *****') RETURN ELSE IF ( N==1 ) THEN WRITE (G_IO,99003) 99003 FORMAT (' ***** NON-FATAL DIAGNOSTIC--The second input argument to RETAIN(3f) has the value 1 *****') ELSE hold = X(1) DO i = 2 , N IF ( X(i)/=hold ) GOTO 50 ENDDO WRITE (G_IO,99004) hold 99004 FORMAT (' ***** NON-FATAL DIAGNOSTIC--The first input argument (a vector) to RETAIN(3f) has all elements =', & & E15.8,' *****') ENDIF ! !-----START POINT----------------------------------------------------- ! 50 continue pointl = Xmin pointu = Xmax IF ( Xmin>Xmax ) pointl = Xmax IF ( Xmin>Xmax ) pointu = Xmin nold = N k = 0 DO i = 1 , nold IF ( X(i)>=pointl .AND. X(i)<=pointu ) THEN k = k + 1 X(k) = X(i) ENDIF ENDDO Newn = k ndel = nold - Newn newnp1 = Newn + 1 IF ( newnp1<=nold ) THEN DO i = newnp1 , nold X(i) = 0.0_wp ENDDO ENDIF ! ! WRITE OUT A BRIEF SUMMARY ! WRITE(G_IO, "(' ')" ) WRITE(G_IO, "(' ','Output from the RETAIN subroutine--')" ) WRITE(G_IO, "(' ',7X,'Only observations between ',E15.8,' AND ', E15.8)" ) pointl , pointu WRITE(G_IO, "(' ',7X,'(inclusive) have been retained.')" ) WRITE(G_IO, "(' ',7X,'All observations outside of this interval')" ) WRITE(G_IO, "(' ',7X,'have been deleted.')" ) WRITE(G_IO, "(' ',7X,'The input number of observations (in X) is ', I0)") nold WRITE(G_IO, "(' ',7X,'The output number of observations (in X) is ', I0)") Newn WRITE(G_IO, "(' ',7X,'The number of observations deleted is ', I0)") ndel ENDIF END SUBROUTINE RETAIN !> !!##NAME !! runs(3f) - [M_datapac:ANALYSIS] perform a runs test !! !!##SYNOPSIS !! !! SUBROUTINE RUNS(X,N) !! !! REAL(kind=wp),intent(in) :: X(:) !! INTEGER,intent(in) :: N !! !!##DESCRIPTION !! !! RUNS(3f) performs a runs analysis of the data in the input vector x. !! !! This runs analysis is a useful distribution-free test of the randomness !! of a data set. !! !! The analysis consists of first determining the observed number of !! runs from the data, and then computing the expected number of runs, !! the standard deviation of the number of runs, and the resulting !! standardized statistic for the number of runs for runs of various !! lengths. !! !! This is done for runs up, runs down, and runs up and down. !! !!##INPUT ARGUMENTS !! !! X The precision vector of (unsorted or sorted) observations. !! !! N The integer number of observations in the vector x. !! !! restrictions-- The maximum allowable value of n for this subroutine !! is 15000. !!##OUTPUT !! !! 4 pages of automatic printout consisting of the observed number, !! expected number, standard deviation and resulting standardized !! statistic for runs of various lengths, and the cumulative frequency. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_runs !! use M_datapac, only : runs !! implicit none !! ! call runs(x,y) !! end program demo_runs !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the Statistical !! Engineering Division, National Institute of Standards and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !! !!##REFERENCES !! * Levene and Wolfowitz, Annals of Mathematical Statistics, 1944, pages !! 58-69; especially pages 60, 63, and 64. !! * Bradley, Distribution-free Statistical Tests, 1968, Chapter 12, !! pages 271-282. ! ORIGINAL VERSION--JUNE 1972. ! UPDATED --NOVEMBER 1975. ! UPDATED --FEBRUARY 1976. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE RUNS(X,N) REAL(kind=wp),intent(in) :: X(:) INTEGER,intent(in) :: N REAL(kind=wp) :: ai, an, anrdl, anrdlg, anrtl, anrtlg, anrul, anrulg REAL(kind=wp) :: c1, c2, c3, c4, den, enrtl, enrtlg, enrul, enrulg, hold, snrtl, snrtlg REAL(kind=wp) :: snrul, snrulg, stat, WS, Y, znrdl, znrdlg, znrtl, znrtlg, znrul, znrulg INTEGER :: i, imax, ip1, iupper, j, jp1, lendn, lenup, maxlnd, maxlnt, maxlnu, nm1, nneg, npos, nrdl, nrdlg, nrtl, nrtlg INTEGER :: nrul, nrulg, nzer DIMENSION Y(15000) DIMENSION nrul(16) , nrdl(16) , nrtl(16) , nrulg(16) , nrdlg(16) DIMENSION nrtlg(16) DIMENSION enrul(16) , enrtl(16) , enrulg(16) , enrtlg(16) DIMENSION snrul(16) , snrtl(16) , snrulg(16) , snrtlg(16) DIMENSION znrul(16) , znrdl(16) , znrtl(16) , znrulg(16) , znrdlg(16) DIMENSION znrtlg(16) DIMENSION c1(15) , c2(15) , c3(15) , c4(15) DIMENSION anrul(16) , anrdl(16) , anrtl(16) DIMENSION anrulg(16) , anrdlg(16) , anrtlg(16) COMMON /BLOCK2_real32/ WS(15000) EQUIVALENCE (Y(1),WS(1)) DATA c1(1) , c1(2) , c1(3) , c1(4) , c1(5) , c1(6) , c1(7) , & & c1(8) , c1(9) , c1(10) , c1(11) , c1(12) , c1(13) , c1(14) , & & c1(15)/0.4236111111E+00_wp , .1126675485E+00_wp , .4191688713E-01_wp , & & .1076912487E-01_wp , .2003959238E-02_wp , .3023235799E-03_wp , & & .3911555473E-04_wp , .4459038843E-05_wp , .4551105210E-06_wp , & & .4207466837E-07_wp , .3555930927E-08_wp , .2768273257E-09_wp , & & .1997821524E-10_wp , .1343876568E-11_wp , .8465610177E-13_wp/ DATA c2(1) , c2(2) , c2(3) , c2(4) , c2(5) , c2(6) , c2(7) , & & c2(8) , c2(9) , c2(10) , c2(11) , c2(12) , c2(13) , c2(14) , & & c2(15)/ - .4819444444E+00_wp , -.1628284832E+00_wp , & & -.9690696649E-01_wp , -.3778106786E-01_wp , -.9289228716E-02_wp , & & -.1724429252E-02_wp , -.2638557888E-03_wp , -.3466965096E-04_wp , & & -.4004129153E-05_wp , -.4130382587E-06_wp , -.3851876069E-07_wp , & & -.3279103786E-08_wp , -.2568491117E-09_wp , -.1863433868E-10_wp , & & -.1259220466E-11_wp/ DATA c3(1) , c3(2) , c3(3) , c3(4) , c3(5) , c3(6) , c3(7) , & & c3(8) , c3(9) , c3(10) , c3(11) , c3(12) , c3(13) , c3(14) , & & c3(15)/.1777777778E+00_wp , .7916666667E-01_wp , .4738977072E-01_wp , & & .1274801587E-01_wp , .2338606059E-02_wp , .3461358734E-03_wp , & & .4407121770E-04_wp , .4960020603E-05_wp , .5010387575E-06_wp , & & .4592883352E-07_wp , .3854170274E-08_wp , .2982393839E-09_wp , & & .2141205844E-10_wp , .1433843200E-11_wp , .8996663214E-13_wp/ DATA c4(1) , c4(2) , c4(3) , c4(4) , c4(5) , c4(6) , c4(7) , & & c4(8) , c4(9) , c4(10) , c4(11) , c4(12) , c4(13) , c4(14) , & & c4(15)/ - .3222222222E+00_wp , -.5972222222E-01_wp , & & -.1130268959E+00_wp , -.4696428571E-01_wp , -.1123273065E-01_wp , & & -.2025170849E-02_wp , -.3029410411E-03_wp , -.3912824548E-04_wp , & & -.4459234519E-05_wp , -.4551128785E-06_wp , -.4207469124E-07_wp , & & -.3555931110E-08_wp , -.2768273269E-09_wp , -.1997821525E-10_wp , & & -.1343876568E-11_wp/ ! iupper = 15000 ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( N<1 .OR. N>iupper ) THEN WRITE (G_IO,99001) iupper 99001 FORMAT (' ***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO RUNS(3f) IS OUTSIDE THE ALLOWABLE (1,',I0,') INTERVAL *****') WRITE (G_IO,99002) N 99002 FORMAT (' ','***** THE VALUE OF THE ARGUMENT IS ',I0,' *****') RETURN ELSEIF ( N==1 ) THEN WRITE (G_IO,99003) 99003 FORMAT (' ***** FATAL ERROR-- THE SECOND INPUT ARGUMENT TO THE RUNS SUBROUTINE HAS THE VALUE 1 *****') RETURN ELSE hold = X(1) DO i = 2 , N IF ( X(i)/=hold ) GOTO 50 ENDDO WRITE (G_IO,99004) hold 99004 FORMAT (' ***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT (A VECTOR) TO RUNS(3f) HAS ALL ELEMENTS = ',E15.8,' *****') ! !-----START POINT----------------------------------------------------- ! 50 an = N ! ! FORM THE SEQUENTIAL DIFFERENCE TABLE ! nm1 = N - 1 DO i = 1 , nm1 ip1 = i + 1 Y(i) = X(ip1) - X(i) ENDDO ! ! ZERO-OUT THE 6 'NUMBER OF RUNS' VECTORS ! DO i = 1 , 16 nrul(i) = 0 nrdl(i) = 0 nrtl(i) = 0 nrulg(i) = 0 nrdlg(i) = 0 nrtlg(i) = 0 ENDDO ! ! DETERMINE THE NUMBER OF RUNS UP OF LENGTH EXACTLY I ! AND THE NUMBER OF RUNS DOWN OF LENGTH EXACTLY I ! DETERMINE THE LENGTH OF THE LONGEST RUN UP ! AND THE LENGTH OF THE LONGEST RUN DOWN ! lenup = 0 lendn = 0 maxlnu = 0 maxlnd = 0 DO i = 1 , nm1 IF ( Y(i)==0.0_wp .AND. lenup>=1 ) lenup = lenup + 1 IF ( Y(i)==0.0_wp .AND. lendn>=1 ) lendn = lendn + 1 IF ( Y(i)==0.0_wp .AND. lenup==0 .AND. lendn==0 ) lenup = lenup + 1 IF ( Y(i)>0.0_wp .AND. lendn>=1 .AND. lendn<=15 ) nrdl(lendn) = nrdl(lendn) + 1 IF ( Y(i)>0.0_wp .AND. lendn>=1 .AND. lendn>=16 ) nrdl(16) = nrdl(16) + 1 IF ( Y(i)>0.0_wp ) lendn = 0 IF ( Y(i)>0.0_wp ) lenup = lenup + 1 IF ( Y(i)<0.0_wp .AND. lenup>=1 .AND. lenup<=15 ) nrul(lenup) = nrul(lenup) + 1 IF ( Y(i)<0.0 .AND. lenup>=1 .AND. lenup>=16 ) nrul(16) = nrul(16) + 1 IF ( Y(i)<0.0 ) lenup = 0 IF ( Y(i)<0.0 ) lendn = lendn + 1 IF ( i==nm1 .AND. lendn>=1 .AND. lendn<=15 ) nrdl(lendn) = nrdl(lendn) + 1 IF ( i==nm1 .AND. lendn>=1 .AND. lendn>=16 ) nrdl(16) = nrdl(16) + 1 IF ( i==nm1 .AND. lenup>=1 .AND. lenup<=15 ) nrul(lenup) = nrul(lenup) + 1 IF ( i==nm1 .AND. lenup>=1 .AND. lenup>=16 ) nrul(16) = nrul(16) + 1 IF ( lenup>maxlnu ) maxlnu = lenup IF ( lendn>maxlnd ) maxlnd = lendn ENDDO ! ! DETERMINE THE NUMBER OF RUNS TOTAL OF LENGTH EXACTLY I ! AND THE LENGTH OF THE LONGEST RUN UP OR DOWN ! DO i = 1 , 16 nrtl(i) = nrul(i) + nrdl(i) ENDDO maxlnt = maxlnu IF ( maxlnd>maxlnu ) maxlnt = maxlnd ! ! DETERMINE THE NUMBER OF RUNS UP OF LENGTH I OR MORE ! AND THE NUMBER OF RUNS DOWN OF LENGTH I OR MORE ! AND THE NUMBER OF RUNS TOTAL OF LENGTH I OR MORE ! nrulg(16) = nrul(16) nrdlg(16) = nrdl(16) nrtlg(16) = nrtl(16) DO i = 1 , 15 j = 16 - i jp1 = j + 1 nrulg(j) = nrulg(jp1) + nrul(j) nrdlg(j) = nrdlg(jp1) + nrdl(j) nrtlg(j) = nrtlg(jp1) + nrtl(j) ENDDO ! ! DETERMINE THE NUMBER OF POSITIVE, ZERO, AND NEGATIVE ENTRIES ! IN THE DIFFERENCE TABLE. IF RANDOM, THE NUMBER OF POSITIVE SHOULD BE ! APPROXIMATELY EQUAL TO THE NUMBER OF NEGATIVE ! nneg = 0 nzer = 0 npos = 0 DO i = 1 , nm1 IF ( Y(i)<0.0_wp ) nneg = nneg + 1 IF ( Y(i)==0.0_wp ) nzer = nzer + 1 IF ( Y(i)>0.0_wp ) npos = npos + 1 ENDDO ! ! COMPUTE THE EXPECTED NUMBER OF RUNS UP OF LENGTH EXACTLY I = ! THE EXPECTED NUMBER OF RUNS DOWN OF LENGTH EXACTLY I = ! ONE HALF THE EXPECTED NUMBER OF RUNS TOTAL OF LENGTH EXACTLY I ! den = 6.0_wp DO i = 1 , 15 ai = i enrul(i) = an*(ai*ai+3.0_wp*ai+1.0_wp) - (ai*ai*ai+3.0_wp*ai*ai-ai-4.0_wp) den = den*(ai+3.0_wp) enrul(i) = enrul(i)/den enrtl(i) = 2.0_wp*enrul(i) ENDDO ! ! COMPUTE THE EXPECTED NUMBER OF RUNS UP OF LENGTH I OR MORE = ! THE EXPECTED NUMBER OF RUNS DOWN OF LENGTH I OR MORE = ! ONE HALF THE EXPECTED NUMBER OF RUNS TOTAL OF LENGTH I OR MORE ! den = 2.0_wp DO i = 1 , 15 ai = i enrulg(i) = an*(ai+1.0_wp) - (ai*ai+ai-1.0_wp) den = den*(ai+2.0_wp) enrulg(i) = enrulg(i)/den enrtlg(i) = 2.0_wp*enrulg(i) ENDDO ! ! COMPUTE THE STANDARD DEV. OF THE NUMBER OF RUNS UP OF LENGTH EXACTLY I = ! THE STANDARD DEV. OF THE NUMBER OF RUNS DOWN OF LENGTH EXACTLY I = ! SQRT(0.5)* THE STAND. DEV. OF THE NUMBER OF RUNS TOTAL OF LENGTH EXACTLY I ! DO i = 1 , 15 snrtl(i) = SQRT(c1(i)*an+c2(i)) snrul(i) = SQRT(0.5_wp)*snrtl(i) ENDDO ! ! COMPUTE THE STAND. DEV. OF THE NUMBER OF RUNS UP OF LENGTH I OR MORE = ! THE STAND. DEV. OF THE NUMBER OF RUNS DOWN OF LENGTH I OR MORE = ! SQRT(0.5)* THE STAND. DEV. OF THE NUMBER OF RUNS TOTAL OF LENGTH I OR MORE ! DO i = 1 , 15 snrtlg(i) = SQRT(c3(i)*an+c4(i)) snrulg(i) = SQRT(0.5_wp)*snrtlg(i) ENDDO ! ! FORM Z STATISTICS ! DO i = 1 , 15 stat = nrul(i) znrul(i) = (stat-enrul(i))/snrul(i) stat = nrdl(i) znrdl(i) = (stat-enrul(i))/snrul(i) stat = nrtl(i) znrtl(i) = (stat-enrtl(i))/snrtl(i) stat = nrulg(i) znrulg(i) = (stat-enrulg(i))/snrulg(i) stat = nrdlg(i) znrdlg(i) = (stat-enrulg(i))/snrulg(i) stat = nrtlg(i) znrtlg(i) = (stat-enrtlg(i))/snrtlg(i) ENDDO ! DO i = 1 , 15 anrul(i) = nrul(i) anrdl(i) = nrdl(i) anrtl(i) = nrtl(i) anrulg(i) = nrulg(i) anrdlg(i) = nrdlg(i) anrtlg(i) = nrtlg(i) ENDDO ! ! WRITE EVERYTHING OUT ! imax = 15 WRITE (G_IO,99024) WRITE (G_IO,99005) 99005 FORMAT (' ',48X,'RUNS UP') WRITE (6,99025) WRITE (6,99025) WRITE (6,99025) WRITE (6,99025) WRITE (6,99025) WRITE (G_IO,99006) 99006 FORMAT (' ',27X, 'STATISTIC = NUMBER OF RUNS UP OF LENGTH EXACTLY I') WRITE (6,99025) WRITE (6,99025) WRITE (G_IO,99022) WRITE (G_IO,99025) DO i = 1 , imax WRITE (G_IO,99023) i , anrul(i) , enrul(i) , snrul(i) , znrul(i) ENDDO WRITE (6,99025) WRITE (6,99025) WRITE (6,99025) WRITE (6,99025) WRITE (6,99025) WRITE (G_IO,99007) 99007 FORMAT (' ',27X, 'STATISTIC = NUMBER OF RUNS UP OF LENGTH I OR MORE') WRITE (6,99025) WRITE (6,99025) WRITE (G_IO,99022) WRITE (G_IO,99025) DO i = 1 , imax WRITE (G_IO,99023) i , anrulg(i) , enrulg(i) , snrulg(i) , znrulg(i) ENDDO WRITE (G_IO,99024) WRITE (G_IO,99008) 99008 FORMAT (' ',48X,'RUNS DOWN') WRITE (6,99025) WRITE (6,99025) WRITE (6,99025) WRITE (6,99025) WRITE (6,99025) WRITE (G_IO,99009) 99009 FORMAT (' ',27X, 'STATISTIC = NUMBER OF RUNS DOWN OF LENGTH EXACTLY I') WRITE (6,99025) WRITE (6,99025) WRITE (G_IO,99022) WRITE (G_IO,99025) DO i = 1 , imax WRITE (G_IO,99023) i , anrdl(i) , enrul(i) , snrul(i) , znrdl(i) ENDDO WRITE (6,99025) WRITE (6,99025) WRITE (6,99025) WRITE (6,99025) WRITE (6,99025) WRITE (G_IO,99010) 99010 FORMAT (' ',27X, 'STATISTIC = NUMBER OF RUNS DOWN OF LENGTH I OR MORE') WRITE (6,99025) WRITE (6,99025) WRITE (G_IO,99022) WRITE (G_IO,99025) DO i = 1 , imax WRITE (G_IO,99023) i , anrdlg(i) , enrulg(i) , snrulg(i) , znrdlg(i) ENDDO WRITE (G_IO,99024) WRITE (G_IO,99011) 99011 FORMAT (' ',40X,'RUNS TOTAL = RUNS UP + RUNS DOWN') WRITE (6,99025) WRITE (6,99025) WRITE (6,99025) WRITE (6,99025) WRITE (6,99025) WRITE (G_IO,99012) 99012 FORMAT (' ',27X, 'STATISTIC = NUMBER OF RUNS TOTAL OF LENGTH EXACTLY I') WRITE (6,99025) WRITE (6,99025) WRITE (G_IO,99022) WRITE (G_IO,99025) DO i = 1 , imax WRITE (G_IO,99023) i , anrtl(i) , enrtl(i) , snrtl(i) , znrtl(i) ENDDO WRITE (6,99025) WRITE (6,99025) WRITE (6,99025) WRITE (6,99025) WRITE (6,99025) WRITE (G_IO,99013) 99013 FORMAT (' ',27X,'STATISTIC = NUMBER OF RUNS TOTAL OF LENGTH I OR MORE') WRITE (6,99025) WRITE (6,99025) WRITE (G_IO,99022) WRITE (G_IO,99025) DO i = 1 , imax WRITE (G_IO,99023) i , anrtlg(i) , enrtlg(i) , snrtlg(i) , znrtlg(i) ENDDO WRITE (G_IO,99024) WRITE (G_IO,99014) maxlnu 99014 FORMAT (' ','LENGTH OF THE LONGEST RUN UP = ',I0) WRITE (G_IO,99015) maxlnd 99015 FORMAT (' ','LENGTH OF THE LONGEST RUN DOWN = ',I0) WRITE (G_IO,99016) maxlnt 99016 FORMAT (' ','LENGTH OF THE LONGEST RUN UP OR DOWN = ',I0) WRITE (G_IO,99025) WRITE (G_IO,99017) npos 99017 FORMAT (' ','NUMBER OF POSITIVE DIFFERENCES = ',I0) WRITE (G_IO,99018) nneg 99018 FORMAT (' ','NUMBER OF NEGATIVE DIFFERENCES = ',I0) WRITE (G_IO,99019) nzer 99019 FORMAT (' ','NUMBER OF ZERO DIFFERENCES = ',I0) 99020 FORMAT (' ',2(I4,2X,F7.1,2X,F8.4,2X,F8.4,2X,F8.2,8X)) 99021 FORMAT (' ',I0,2X,I0,2X,I0) ENDIF 99022 FORMAT (' ', 'I = LENGTH OF RUN VALUE OF STAT EXP(STAT) SD(STAT) (STAT-EXP(STAT))/SD(STAT)') 99023 FORMAT (' ',4X,I4,13X,6X,F7.1,13X,F8.4,12X,F8.4,11X,F8.2) 99024 FORMAT ('1') 99025 FORMAT (' ') END SUBROUTINE RUNS !> !!##NAME !! sampp(3f) - [M_datapac:PERCENT_POINT] compute the sample 100P percent !! point (i.e., percentile) !! !!##SYNOPSIS !! !! SUBROUTINE SAMPP(X,N,P,Iwrite,Pp) !! !!##DESCRIPTION !! SAMPP(3f) computes the sample 100p percent point (where p is between !! 0.0 and 1.0, exclusively) of the data in the input vector X. !! !! the sample 100p percent point = is that point in which 100p percent !! of the data in the sample is below. !! !!##OPTIONS !! X description of parameter !! Y description of parameter !! !!##EXAMPLES !! !! Sample program: !! !! program demo_sampp !! use M_datapac, only : sampp !! implicit none !! ! call sampp(x,y) !! end program demo_sampp !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !! !!##REFERENCES !! * Kendall and Stuart, The Advanced Theory of Statistics, Volume 1, !! Edition 2, 1963, pages 236-239, 243. !! * Mood and Grable, 'Introduction to the Theory of Statistics, Edition 2, !! 1963, pages 406-407. !! * Snedecor and Cochran, Statistical Methods, Edition 6, 1967, page 125. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE SAMPP(X,N,P,Iwrite,Pp) REAL(kind=wp) :: aj , ajint , an , anp1 , hold , hunp , P , Pp , w , WS , X , Y INTEGER :: i , iupper , Iwrite , j , jp1 , N ! ! INPUT ARGUMENTS--X = THE VECTOR OF ! (UNSORTED OR SORTED) OBSERVATIONS. ! --N = THE INTEGER NUMBER OF OBSERVATIONS ! IN THE VECTOR X. ! --P = THE FRACTION VALUE ! (BETWEEN 0.0 AND 1.0, EXCLUSIVELY) ! WHICH DEFINES THE DESIRED PERCENT ! POINT TO BE COMPUTED. ! --IWRITE = AN INTEGER FLAG CODE WHICH ! (IF SET TO 0) WILL SUPPRESS ! THE PRINTING OF THE ! SAMPLE 100P PERCENT POINT ! AS IT IS COMPUTED; ! OR (IF SET TO SOME INTEGER ! VALUE NOT EQUAL TO 0), ! LIKE, SAY, 1) WILL CAUSE ! THE PRINTING OF THE ! SAMPLE 100P PERCENT POINT ! AT THE TIME IT IS COMPUTED. ! OUTPUT ARGUMENTS--PP = THE VALUE OF THE ! COMPUTED SAMPLE 100P PERCENT POINT. ! OUTPUT--THE COMPUTED VALUE OF THE ! SAMPLE 100P PERCENT POINT. ! PRINTING--NONE, UNLESS IWRITE HAS BEEN SET TO A NON-ZERO ! INTEGER, OR UNLESS AN INPUT ARGUMENT ERROR ! CONDITION EXISTS. ! RESTRICTIONS--THE MAXIMUM ALLOWABLE VALUE OF N ! FOR THIS SUBROUTINE IS 15000. ! --THE INPUT ARGUMENTS N AND P SHOULD BE SUCH THAT ! THE PRODUCT OF N+1 AND P IS NOT SMALLER THAN 1 NOR ! LARGER THAN N. THIS RESTRICTION IS DUE TO THE ! INTRINSIC DIFFICULTY OF ESTIMATING ! SAMPLE PERCENT POINTS SMALLER THAN THE OBSERVED ! SAMPLE MINIMUM OR LARGER THAN THE OBSERVED ! SAMPLE MAXIMUM. ! IF (N+1)P IS SMALLER THAN 1, AN ERROR MESSAGE WILL ! BE PRINTED OUT AND PP WILL BE SET TO -999999999.0 ! IF(N+1)P IS LARGER THAN N, AN ERROR MESSAGE WILL ! BE PRINTED OUT AND PP WILL BE SET TO 999999999.0. ! MODE OF INTERNAL OPERATIONS--. ! ORIGINAL VERSION--DECEMBER 1974. ! UPDATED --SEPTEMBER 1975. ! UPDATED --NOVEMBER 1975. ! UPDATED --FEBRUARY 1976. ! !--------------------------------------------------------------------- ! DIMENSION X(:) DIMENSION Y(15000) COMMON /BLOCK2_real32/ WS(15000) EQUIVALENCE (Y(1),WS(1)) ! iupper = 15000 ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! an = N anp1 = N + 1 aj = P*anp1 j = aj jp1 = j + 1 IF ( N<1 .OR. N>iupper ) THEN WRITE (G_IO,99001) iupper 99001 FORMAT (' ', & &'***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE SAMPP SUBROU& &TINE IS OUTSIDE THE ALLOWABLE (1,',I0,') INTERVAL *****') WRITE (G_IO,99002) N 99002 FORMAT (' ','***** THE VALUE OF THE ARGUMENT IS ',I0,' *****') RETURN ELSEIF ( N==1 ) THEN WRITE (G_IO,99003) 99003 FORMAT (' ', & &'***** NON-FATAL DIAGNOSTIC--THE SECOND INPUT ARGUMENT TO THE SAMP& &P SUBROUTINE HAS THE VALUE 1 *****') Pp = X(1) RETURN ELSEIF ( j<1 ) THEN WRITE (G_IO,99004) 99004 FORMAT (' ','THE THIRD INPUT ARGUMENT IS SMALLER THAN 1/(N+1)',& & ' = 1/(SECOND INPUT ARGUMENT + 1)') WRITE (G_IO,99008) N , P Pp = -999999999.0_wp RETURN ELSEIF ( jp1>N ) THEN WRITE (G_IO,99005) 99005 FORMAT (' ','THE THIRD INPUT ARGUMENT IS LARGER THAN N/(N+1)', & & ' = (SECOND INPUT ARGUMENT)/(SECOND INPUT ARGUMENT + 1)'& & ) WRITE (G_IO,99008) N , P Pp = 999999999.0_wp RETURN ELSE hold = X(1) DO i = 2 , N IF ( X(i)/=hold ) GOTO 50 ENDDO WRITE (G_IO,99006) hold 99006 FORMAT (' ', & &'***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT (A VECTOR) & &TO THE SAMPP SUBROUTINE HAS ALL ELEMENTS =',E15.8,' *****') ! !-----START POINT----------------------------------------------------- ! 50 CALL SORT(X,N,Y) ! ajint = j w = 1.0_wp - (aj-ajint) Pp = w*Y(j) + (1.0_wp-w)*Y(jp1) ! hunp = 100.0*P IF ( Iwrite==0 ) RETURN WRITE (G_IO,99007) hunp , N , Pp 99007 FORMAT (' ','THE EMPIRICAL ',F9.5,' PERCENT POINT OF THE ',I0, & & ' OBSERVATIONS IS ',F16.7) ENDIF 99008 FORMAT (' ','*****THE VALUE OF THE SECOND INPUT ARGUMENT = ',I0, & & ' THE VALUE OF THE THIRD INPUT ARGUMENT = ',E20.10, & & '*****') ! END SUBROUTINE SAMPP !> !!##NAME !! scale(3f) - [M_datapac:STATISTICS] compute the sample range, sample !! standard deviation, sample relative standard deviation, and sample !! variance !! !!##SYNOPSIS !! !! SUBROUTINE SCALE(X,N) !! !!##DESCRIPTION !! scale(3f) computes 4 estimates of the scale (variation, scatter, !! dispersion) of the data in the input vector x. !! !! the 4 estimators employed are-- !! !! 1. the sample range; !! 2. the sample standard deviation; !! 3. the sample relative standard deviation; and !! 4. the sample variance. !! !! note that n-1 (rather than n) is used in the divisor in the computation !! of the sample standard deviation, the sample relative standard !! deviation, and the sample variance. !! !!##OPTIONS !! X description of parameter !! Y description of parameter !! !!##EXAMPLES !! !! Sample program: !! !! program demo_scale !! use M_datapac, only : scale !! implicit none !! ! call scale(x,y) !! end program demo_scale !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the Statistical !! Engineering Division, National Institute of Standards and Technology. !!##MAINTAINER !! John Urban, 2022.05.31 !!##LICENSE !! CC0-1.0 !!##REFERENCES !! * DIXON AND MASSEY, pages 19 AND 21 !! * SNEDECOR AND COCHRAN, page 62 !! * DIXON AND MASSEY, pages 14, 70, AND 71 !! * CROW, JOURNAL OF THE AMERICAN STATISTICAL ASSOCIATION, pages 357 !! AND 387 !! * KENDALL AND STUART, THE ADVANCED THEORY OF STATISTICS, VOLUME 1, !! EDITION 2, 1963, page 8. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE SCALE(X,N) REAL(kind=wp) :: an , hold , sum , X , xmax , xmean , xmin , xrange , xrelsd , xsd , xvar INTEGER i , N ! ! INPUT ARGUMENTS--X = THE VECTOR OF ! (UNSORTED OR SORTED) OBSERVATIONS. ! N = THE INTEGER NUMBER OF OBSERVATIONS ! IN THE VECTOR X. ! OUTPUT--1/4 page OF AUTOMATIC OUTPUT ! CONSISTING OF THE FOLLOWING 4 ! ESTIMATES OF SCALE ! FOR THE DATA IN THE INPUT VECTOR X-- ! 1) THE SAMPLE RANGE; ! 2) THE SAMPLE STANDARD DEVIATION; ! 3) THE SAMPLE RELATIVE STANDARD DEVIATION; AND ! 4) THE SAMPLE VARIANCE. ! PRINTING--YES. ! RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE ! OF N FOR THIS SUBROUTINE. ! FORTRAN LIBRARY SUBROUTINES NEEDED--SQRT. ! MODE OF INTERNAL OPERATIONS--. ! COMMENT--THE SAMPLE RELATIVE STANDARD DEVIATION ! IS THE SAMPLE STANDARD DEVIATION RELATIVE ! TO THE MAGNITUDE OF THE SAMPLE MEAN. ! THE RELATIVE SAMPLE STANDARD DEVIATION ! IS EXPRESSED AS A PERCENT. ! THE RELATIVE SAMPLE STANDARD DEVIATION ! IS EQUIVALENTLY CALLED THE ! SAMPLE COEFFICIENT OF VARIATION. ! ORIGINAL VERSION--JUNE 1972. ! UPDATED --NOVEMBER 1975. ! !--------------------------------------------------------------------- ! DIMENSION X(:) ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! xrange = 0.0_wp xsd = 0.0_wp xrelsd = 0.0_wp xvar = 0.0_wp IF ( N<1 ) THEN WRITE (G_IO,99001) 99001 FORMAT (' ', & &'***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE SCALE SUBROU& &TINE IS NON-POSITIVE *****') WRITE (G_IO,99002) N 99002 FORMAT (' ','***** THE VALUE OF THE ARGUMENT IS ',I0,' *****') RETURN ELSE IF ( N==1 ) THEN WRITE (G_IO,99003) 99003 FORMAT (' ', & &'***** NON-FATAL DIAGNOSTIC--THE SECOND INPUT ARGUMENT TO THE SCAL& &E SUBROUTINE HAS THE VALUE 1 *****') xrange = 0.0_wp xsd = 0.0_wp xrelsd = 0.0_wp ELSE hold = X(1) DO i = 2 , N IF ( X(i)/=hold ) GOTO 20 ENDDO WRITE (G_IO,99004) hold 99004 FORMAT (' ', & &'***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT (A VECTOR) & &TO THE SCALE SUBROUTINE HAS ALL ELEMENTS = ',E15.8,' *****') ! !-----START POINT----------------------------------------------------- ! 20 an = N ! ! DETERMINE THE SAMPLE MINIMUM AND THE SAMPLE MAXIMUM, ! THEN COMPUTE THE SAMPLE RANGE. ! xmin = X(1) xmax = X(1) DO i = 1 , N IF ( X(i)<xmin ) xmin = X(i) IF ( X(i)>xmax ) xmax = X(i) ENDDO xrange = xmax - xmin ! ! COMPUTE THE SAMPLE VARIANCE, ! AND THEN THE SAMPLE STANDARDD DEVIATION. ! sum = 0.0_wp DO i = 1 , N sum = sum + X(i) ENDDO xmean = sum/an sum = 0.0_wp DO i = 1 , N sum = sum + (X(i)-xmean)**2 ENDDO xvar = sum/(an-1.0_wp) xsd = SQRT(xvar) ! ! COMPUTE THE SAMPLE RELATIVE STANDARD DEVIATION; ! THAT IS, THE SAMPLE STANDARD DEVIATION RELATIVE ! TO THE MAGNITUDE OF THE SAMPLE MEAN. ! THE RESULTING SAMPLE STANDARD DEVIATION IS EXPRESSED ! AS A PERCENT. ! xrelsd = 100.0_wp*xsd/xmean IF ( xrelsd<0.0_wp ) xrelsd = -xrelsd ENDIF ! ! WRITE EVERYTHING OUT ! DO i = 1 , 5 WRITE (G_IO,99011) ENDDO WRITE (G_IO,99005) ! 99005 FORMAT (' ',30X,'ESTIMATES OF THE SCALE PARAMETER') WRITE (G_IO,99011) WRITE (G_IO,99006) N 99006 FORMAT (' ',34X,'(THE SAMPLE SIZE N = ',I0,')') WRITE (G_IO,99011) WRITE (G_IO,99011) WRITE (G_IO,99007) xrange 99007 FORMAT (' ','THE SAMPLE RANGE IS ',E15.8) WRITE (G_IO,99008) xsd 99008 FORMAT (' ','THE SAMPLE STANDARD DEVIATION IS ',E15.8) WRITE (G_IO,99009) xvar 99009 FORMAT (' ','THE SAMPLE VARIANCE IS ',E15.8) WRITE (G_IO,99010) xrelsd 99010 FORMAT (' ','THE SAMPLE RELATIVE STANDARD DEVIATION IS ',E15.8,& & ' PERCENT') ENDIF 99011 FORMAT (' ') ! END SUBROUTINE SCALE !> !!##NAME !! sd(3f) - [M_datapac:STATISTICS] compute the standard deviation of a !! vector of observations !! !!##SYNOPSIS !! !! SUBROUTINE SD(X,N,Iwrite,Xsd) !! !!##DESCRIPTION !! sd(3f) computes the sample standard deviation (with denominator n-1) !! of the data in the input vector x. !! !! the sample standard deviation = sqrt((the sum of the squared deviations !! about the sample mean)/(n-1)). !! !!##OPTIONS !! X description of parameter !! Y description of parameter !! !!##EXAMPLES !! !! Sample program: !! !! program demo_sd !! use M_datapac, only : sd !! implicit none !! ! call sd(x,y) !! end program demo_sd !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !! !!##REFERENCES !! * Snedecor and Cochran, Statistical Methods, Edition 6, 1967, page 44. !! * Dixon and Massey, Introduction to Statistical Analysis, Edition 2, !! 1957, pages 19, 76. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE SD(X,N,Iwrite,Xsd) REAL(kind=wp) :: an , hold , sum , var , X , xmean , Xsd INTEGER :: i , Iwrite , N ! ! INPUT ARGUMENTS--X = THE VECTOR OF ! (UNSORTED OR SORTED) OBSERVATIONS. ! --N = THE INTEGER NUMBER OF OBSERVATIONS ! IN THE VECTOR X. ! --IWRITE = AN INTEGER FLAG CODE WHICH ! (IF SET TO 0) WILL SUPPRESS ! THE PRINTING OF THE ! SAMPLE STANDARD DEVIATION ! AS IT IS COMPUTED; ! OR (IF SET TO SOME INTEGER ! VALUE NOT EQUAL TO 0), ! LIKE, SAY, 1) WILL CAUSE ! THE PRINTING OF THE ! SAMPLE STANDARD DEVIATION ! AT THE TIME IT IS COMPUTED. ! OUTPUT ARGUMENTS--XSD = THE VALUE OF THE ! COMPUTED SAMPLE STANDARD DEVIATION. ! OUTPUT--THE COMPUTED VALUE OF THE ! SAMPLE STANDARD DEVIATION (WITH DENOMINATOR N-1). ! PRINTING--NONE, UNLESS IWRITE HAS BEEN SET TO A NON-ZERO ! INTEGER, OR UNLESS AN INPUT ARGUMENT ERROR ! CONDITION EXISTS. ! RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE ! OF N FOR THIS SUBROUTINE. ! FORTRAN LIBRARY SUBROUTINES NEEDED--SQRT. ! MODE OF INTERNAL OPERATIONS--. ! ORIGINAL VERSION--JUNE 1972. ! UPDATED --SEPTEMBER 1975. ! UPDATED --NOVEMBER 1975. ! !--------------------------------------------------------------------- ! DIMENSION X(:) ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! an = N IF ( N<1 ) THEN WRITE (G_IO,99001) 99001 FORMAT (' ', & &'***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE SD SUBROU& &TINE IS NON-POSITIVE *****') WRITE (G_IO,99002) N 99002 FORMAT (' ','***** THE VALUE OF THE ARGUMENT IS ',I0,' *****') RETURN ELSE IF ( N==1 ) THEN WRITE (G_IO,99003) 99003 FORMAT (' ', & &'***** NON-FATAL DIAGNOSTIC--THE SECOND INPUT ARGUMENT TO THE SD & & SUBROUTINE HAS THE VALUE 1 *****') Xsd = 0.0_wp ELSE hold = X(1) DO i = 2 , N IF ( X(i)/=hold ) GOTO 50 ENDDO WRITE (G_IO,99004) hold 99004 FORMAT (' ', & &'***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT (A VECTOR) & &TO THE SD SUBROUTINE HAS ALL ELEMENTS = ',E15.8,' *****') Xsd = 0.0_wp ENDIF GOTO 100 ! !-----START POINT----------------------------------------------------- ! 50 sum = 0.0_wp DO i = 1 , N sum = sum + X(i) ENDDO xmean = sum/an sum = 0.0_wp DO i = 1 , N sum = sum + (X(i)-xmean)**2 ENDDO var = sum/(an-1.0_wp) Xsd = SQRT(var) ENDIF ! 100 IF ( Iwrite==0 ) RETURN WRITE (G_IO,99005) 99005 FORMAT (' ') WRITE (G_IO,99006) N , Xsd 99006 FORMAT (' ','THE SAMPLE STANDARD DEVIATION OF THE ',I0, & & ' OBSERVATIONS IS ',E15.8) END SUBROUTINE SD !> !!##NAME !! sortc(3f) - [M_datapac:SORT] sort a vector of sample !! observations and "carry" a second vector !! !!##SYNOPSIS !! !! Subroutine sortc(X,Y,N,Xs,Yc) !! !! Real(kind=wp), Intent (In) :: X !! Real(kind=wp), Intent (In) :: Y !! Integer, Intent (In) :: N !! Real(kind=wp), Intent (Out) :: Xs !! Real(kind=wp), Intent (Out) :: Yc !! !!##DESCRIPTION !! !! SORTC(3f) sorts (in ascending order) the N elements of the vector X, !! puts the resulting N sorted values into the vector XS, !! rearranges the elements of the vector Y (according to the sort on X), !! and puts the rearranged Y values into the vector YC. !! This subroutine gives the data analyst the ability to sort one data !! vector while 'carrying along' the elements of a second data vector. !! !! The smallest element of the vector X will be placed in the first !! position of the vector XS, the second smallest element in the vector !! X will be placed in the second position of the vector XS, etc. !! !! The element in the vector Y corresponding to the smallest element in !! X will be placed in the first position of the vector YC, the element !! in the vector Y corresponding to the second smallest element in X !! will be placed in the second position of the vector YC, etc. !! !! The input vector X remains unaltered. !! !! If the analyst desires a sort 'in place', this is done by having the !! same output vector as input vector in the calling sequence. Thus, !! for example, the calling sequence CALL SORTC(X,Y,N,X,YC) is allowable !! and will result in the desired 'in-place' sort. !! !! The sorting algorithm used herein is the binary sort. This algorithm !! is extremely fast as the following time trials indicate. These time !! trials were carried out on the UNIVAC 1108 EXEC 8 system at NBS in !! August of 1974. By way of comparison, the time trial values for the !! easy-to-program but extremely inefficient bubble sort algorithm have !! also been included-- !! !! Number of Random Binary Sort Bubble Sort !! Numbers Sorted !! N = 10 .002 sec .002 sec !! N = 100 .011 sec .045 sec !! N = 1000 .141 sec 4.332 sec !! N = 3000 .476 sec 37.683 sec !! N = 10000 1.887 sec NOT COMPUTED !! !!##INPUT ARGUMENTS !! X The vector of observations to be sorted. !! !! Y The vector of !! observations to be 'carried along', that is, to be rearranged !! according to the sort on X. !! !! N The integer number of observations in the vector X. !! !!##OUTPUT ARGUMENTS !! !! XS The vector into which the sorted data values from X will be !! placed in ascending order. !! !! YC The vector into which the rearranged (according to the sort of !! the vector X) values of the vector Y will be placed. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_sortc !! use M_datapac, only : sortc, label !! implicit none !! integer,parameter :: isz=20 !! real :: aa(isz) !! real :: bb(isz) !! real :: cc(isz) !! real :: dd(isz) !! integer :: i !! call label('sortc') !! write(*,*)'initializing array with ',isz,' random numbers' !! call random_seed() !! CALL RANDOM_NUMBER(aa) !! aa=aa*450000.0 !! bb=real([(i,i=1,isz)]) !! call sortc(aa,bb,size(aa),cc,dd) !! !! write(*,*)'checking if real values are sorted(3f)' !! do i=1,isz-1 !! if(cc(i).gt.cc(i+1))then !! write(*,*)'Error in sorting reals small to large ',i,cc(i),cc(i+1) !! endif !! enddo !! write(*,*)'test of sortc(3f) complete' !! write(*,'(4(g0,1x))')(aa(i),bb(i),cc(i),dd(i),i=1,isz) !! write(*,'(*(g0,1x))')sum(aa),sum(cc) ! should be the same if no truncation !! write(*,'(*(g0,1x))')sum(bb),sum(dd) !! !! end program demo_sortc !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the Statistical !! Engineering Division, National Institute of Standards and Technology. !!##MAINTAINER !! John Urban, 2022.05.31 !!##REFERENCES !! 1. CACM MARCH 1969, page 186 (BINARY SORT ALGORITHM BY RICHARD C. SINGLETON). !! 2. CACM JANUARY 1970, page 54. !! 3. CACM OCTOBER 1970, page 624. !! 4. JACM JANUARY 1961, page 41. !!##LICENSE !! CC0-1.0 ! ORIGINAL VERSION--JUNE 1972. ! UPDATED --NOVEMBER 1975. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE SORTC(X,Y,N,Xs,Yc) REAL(kind=wp) :: amed, bmed, hold, tx, ty, X(:), Xs(:), Y(:), Yc(:) INTEGER i, il(36), ip1, iu(36), j, jmi, jmk, k, l, lmi, m, mid, N, nm1 ! ! RESTRICTIONS--THE DIMENSIONS OF THE VECTORS IL AND IU ! (DEFINED AND USED INTERNALLY WITHIN ! THIS SUBROUTINE) DICTATE THE MAXIMUM ! ALLOWABLE VALUE OF N FOR THIS SUBROUTINE. ! IF IL AND IU EACH HAVE DIMENSION K, ! THEN N MAY NOT EXCEED 2**(K+1) - 1. ! FOR THIS SUBROUTINE AS WRITTEN, THE DIMENSIONS ! OF IL AND IU HAVE BEEN SET TO 36, ! THUS THE MAXIMUM ALLOWABLE VALUE OF N IS ! APPROXIMATELY 137 BILLION. ! SINCE THIS EXCEEDS THE MAXIMUM ALLOWABLE ! VALUE FOR AN INTEGER VARIABLE IN MANY COMPUTERS, ! AND SINCE A SORT OF 137 BILLION ELEMENTS ! IS PRESENTLY IMPRACTICAL AND UNLIKELY, ! THEN THERE IS NO PRACTICAL RESTRICTION ! ON THE MAXIMUM VALUE OF N FOR THIS SUBROUTINE. ! (IN LIGHT OF THE ABOVE, NO CHECK OF THE ! UPPER LIMIT OF N HAS BEEN INCORPORATED ! INTO THIS SUBROUTINE.) !--------------------------------------------------------------------- ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( N<1 ) THEN WRITE (G_IO,99001) 99001 FORMAT (' ','***** FATAL ERROR--The second input argument to SORTC(3f) is non-positive *****') WRITE (G_IO,99002) N 99002 FORMAT (' ','***** The value of the argument is ',I0,' *****') RETURN ELSE IF ( N==1 ) THEN WRITE (G_IO,99003) 99003 FORMAT (' ','***** NON-FATAL DIAGNOSTIC--The second input argument to SORTC(3f) has the value 1 *****') Xs(1) = X(1) Yc(1) = Y(1) RETURN ELSE hold = X(1) DO i = 2 , N IF ( X(i)/=hold ) GOTO 50 ENDDO WRITE (G_IO,99004) hold 99004 FORMAT (' ', & & '***** NON-FATAL DIAGNOSTIC--The first input argument (a vector) to SORTC(3f) has all elements =', & & E15.8, & & ' *****') DO i = 1 , N Xs(i) = X(i) Yc(i) = Y(i) ENDDO RETURN ENDIF ! !-----START POINT----------------------------------------------------- ! ! COPY THE VECTOR X INTO THE VECTOR XS 50 continue DO i = 1 , N Xs(i) = X(i) ENDDO ! ! COPY THE VECTOR Y INTO THE VECTOR YS ! DO i = 1 , N Yc(i) = Y(i) ENDDO ! ! CHECK TO SEE IF THE INPUT VECTOR IS ALREADY SORTED ! nm1 = N - 1 DO i = 1 , nm1 ip1 = i + 1 IF ( Xs(i)>Xs(ip1) ) GOTO 100 ENDDO RETURN ENDIF 100 continue m = 1 i = 1 j = N 200 continue IF ( i>=j ) GOTO 400 300 continue k = i mid = (i+j)/2 amed = Xs(mid) bmed = Yc(mid) IF ( Xs(i)>amed ) THEN Xs(mid) = Xs(i) Yc(mid) = Yc(i) Xs(i) = amed Yc(i) = bmed amed = Xs(mid) bmed = Yc(mid) ENDIF l = j IF ( Xs(j)<amed ) THEN Xs(mid) = Xs(j) Yc(mid) = Yc(j) Xs(j) = amed Yc(j) = bmed amed = Xs(mid) bmed = Yc(mid) IF ( Xs(i)>amed ) THEN Xs(mid) = Xs(i) Yc(mid) = Yc(i) Xs(i) = amed Yc(i) = bmed amed = Xs(mid) bmed = Yc(mid) ENDIF ENDIF DO l = l - 1 IF ( Xs(l)<=amed ) THEN tx = Xs(l) ty = Yc(l) DO k = k + 1 IF ( Xs(k)>=amed ) THEN IF ( k<=l ) THEN Xs(l) = Xs(k) Yc(l) = Yc(k) Xs(k) = tx Yc(k) = ty EXIT ELSE lmi = l - i jmk = j - k IF ( lmi<=jmk ) THEN il(m) = k iu(m) = j j = l m = m + 1 ELSE il(m) = i iu(m) = l i = k m = m + 1 ENDIF GOTO 500 ENDIF ENDIF ENDDO ENDIF ENDDO 400 continue m = m - 1 IF ( m==0 ) RETURN i = il(m) j = iu(m) 500 continue jmi = j - i IF ( jmi>=11 ) GOTO 300 IF ( i==1 ) GOTO 200 i = i - 1 DO i = i + 1 IF ( i==j ) GOTO 400 amed = Xs(i+1) bmed = Yc(i+1) IF ( Xs(i)>amed ) THEN k = i DO Xs(k+1) = Xs(k) Yc(k+1) = Yc(k) k = k - 1 IF ( amed>=Xs(k) ) THEN Xs(k+1) = amed Yc(k+1) = bmed EXIT ENDIF ENDDO ENDIF ENDDO END SUBROUTINE SORTC !> !!##NAME !! sort(3f) - [M_datapac:SORT] sort a vector of sample !! observations, also return the positions in the original vector !! !!##SYNOPSIS !! !! SUBROUTINE SORT(X,N,Y) !! !! real,intent(in) :: x(:) !! integer,intent(in) :: n !! real,intent(out) :: y(:) !! !!##DESCRIPTION !! !! This subroutine sorts (in ascending order) the N elements of the !! REAL vector X using the binary sort algorithm and puts !! the resulting N sorted values into the REAL vector Y. !! !!##OPTIONS !!##INPUT !! X The REAL vector of observations to be sorted. !! The input vector X remains unaltered. !! !! N The integer number of observations in the vector X. !! !!##OUTPUT !! !! Y The REAL vector into which the sorted data values from X will be !! placed in ascending order. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_sort !! use M_datapac, only : sort !! implicit none !! integer,parameter :: isz=20 !! real :: aa(isz) !! real :: bb(isz) !! integer :: i !! write(*,*)'initializing array with ',isz,' random numbers' !! call random_seed() !! CALL RANDOM_NUMBER(aa) !! aa=aa*450000.0 !! bb=real([(i,i=1,isz)]) !! !! call sort(aa,isz,bb) ! sort data !! !! write(*,*)'checking if real values are sorted(3f)' !! do i=1,isz-1 !! if(bb(i).gt.bb(i+1))then !! write(*,*)'Error in sorting reals small to large ',i,bb(i),bb(i+1) !! endif !! enddo !! write(*,'(2(g0,1x))')'ORIGINAL','SORTED',(aa(i),bb(i),i=1,isz) !! !! end program demo_sort !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the Statistical !! Engineering Division, National Institute of Standards and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##REFERENCES !! 1. CACM MARCH 1969, page 186 (BINARY SORT ALGORITHM BY RICHARD C. SINGLETON). !! 2. CACM JANUARY 1970, page 54. !! 3. CACM OCTOBER 1970, page 624. !! 1. JACM JANUARY 1961, page 41. !! !!##LICENSE !! CC0-1.0 ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE SORT(X,N,Y) REAL(kind=wp) :: amed, hold, tt, X, Y integer i, il, ip1, iu, j, jmi, jmk, k, l, lmi, m, mid, n, nm1 DIMENSION X(:), Y(:) DIMENSION iu(36), il(36) ! RESTRICTIONS--THE DIMENSIONS OF THE VECTORS IL AND IU ! (DEFINED AND USED INTERNALLY WITHIN ! THIS SUBROUTINE) DICTATE THE MAXIMUM ! ALLOWABLE VALUE OF N FOR THIS SUBROUTINE. ! IF IL AND IU EACH HAVE DIMENSION K, ! THEN N MAY NOT EXCEED 2**(K+1) - 1. ! FOR THIS SUBROUTINE AS WRITTEN, THE DIMENSIONS ! OF IL AND IU HAVE BEEN SET TO 36, ! THUS THE MAXIMUM ALLOWABLE VALUE OF N IS ! APPROXIMATELY 137 BILLION. ! SINCE THIS EXCEEDS THE MAXIMUM ALLOWABLE ! VALUE FOR AN INTEGER VARIABLE IN MANY COMPUTERS, ! AND SINCE A SORT OF 137 BILLION ELEMENTS ! IS PRESENTLY IMPRACTICAL AND UNLIKELY, ! THEN THERE IS NO PRACTICAL RESTRICTION ! ON THE MAXIMUM VALUE OF N FOR THIS SUBROUTINE. ! (IN LIGHT OF THE ABOVE, NO CHECK OF THE ! UPPER LIMIT OF N HAS BEEN INCORPORATED ! INTO THIS SUBROUTINE.) ! COMMENT--THE SMALLEST ELEMENT OF THE VECTOR X ! WILL BE PLACED IN THE FIRST POSITION ! OF THE VECTOR Y, ! THE SECOND SMALLEST ELEMENT IN THE VECTOR X ! WILL BE PLACED IN THE SECOND POSITION ! OF THE VECTOR Y, ETC. ! COMMENT--IF THE ANALYST DESIRES A SORT 'IN PLACE', ! THIS IS DONE BY HAVING THE SAME ! OUTPUT VECTOR AS INPUT VECTOR IN THE CALLING SEQUENCE. ! THUS, FOR EXAMPLE, THE CALLING SEQUENCE ! CALL SORT(X,N,X) ! IS ALLOWABLE AND WILL RESULT IN ! THE DESIRED 'IN-PLACE' SORT. ! COMMENT--THE SORTING ALGORTHM USED HEREIN ! IS THE BINARY SORT. ! THIS ALGORTHIM IS EXTREMELY FAST AS THE ! FOLLOWING TIME TRIALS INDICATE. ! THESE TIME TRIALS WERE CARRIED OUT ON THE ! UNIVAC 1108 EXEC 8 SYSTEM AT NBS ! IN AUGUST OF 1974. ! BY WAY OF COMPARISON, THE TIME TRIAL VALUES ! FOR THE EASY-TO-PROGRAM BUT EXTREMELY ! INEFFICIENT BUBBLE SORT ALGORITHM HAVE ! ALSO BEEN INCLUDED-- ! NUMBER OF RANDOM BINARY SORT BUBBLE SORT ! NUMBERS SORTED ! N = 10 .002 SEC .002 SEC ! N = 100 .011 SEC .045 SEC ! N = 1000 .141 SEC 4.332 SEC ! N = 3000 .476 SEC 37.683 SEC ! N = 10000 1.887 SEC NOT COMPUTED ! ORIGINAL VERSION--JUNE 1972. ! UPDATED --NOVEMBER 1975. ! !--------------------------------------------------------------------- ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( N<1 ) THEN WRITE (G_IO,99001) 99001 FORMAT (' ', & &'***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE SORT SUBROU& &TINE IS NON-POSITIVE *****') WRITE (G_IO,99002) N 99002 FORMAT (' ','***** THE VALUE OF THE ARGUMENT IS ',I0,' *****') RETURN ELSE IF ( N==1 ) THEN WRITE (G_IO,99003) 99003 FORMAT (' ','***** NON-FATAL DIAGNOSTIC--THE SECOND INPUT ARGUMENT TO THE SORT SUBROUTINE HAS THE VALUE 1 *****') Y(1) = X(1) RETURN ELSE hold = X(1) DO i = 2 , N IF ( X(i)/=hold ) GOTO 50 ENDDO WRITE (G_IO,99004) hold 99004 FORMAT (' ',& & '***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT (A VECTOR) TO THE SORT SUBROUTINE HAS ALL ELEMENTS =',& & E15.8,& & ' *****') DO i = 1 , N Y(i) = X(i) ENDDO RETURN ENDIF ! !-----START POINT----------------------------------------------------- ! ! COPY THE VECTOR X INTO THE VECTOR Y 50 DO i = 1 , N Y(i) = X(i) ENDDO ! ! CHECK TO SEE IF THE INPUT VECTOR IS ALREADY SORTED ! nm1 = N - 1 DO i = 1 , nm1 ip1 = i + 1 IF ( Y(i)>Y(ip1) ) GOTO 100 ENDDO RETURN ENDIF 100 m = 1 i = 1 j = N 200 IF ( i>=j ) GOTO 400 300 k = i mid = (i+j)/2 amed = Y(mid) IF ( Y(i)>amed ) THEN Y(mid) = Y(i) Y(i) = amed amed = Y(mid) ENDIF l = j IF ( Y(j)<amed ) THEN Y(mid) = Y(j) Y(j) = amed amed = Y(mid) IF ( Y(i)>amed ) THEN Y(mid) = Y(i) Y(i) = amed amed = Y(mid) ENDIF ENDIF DO l = l - 1 IF ( Y(l)<=amed ) THEN tt = Y(l) DO k = k + 1 IF ( Y(k)>=amed ) THEN IF ( k<=l ) THEN Y(l) = Y(k) Y(k) = tt EXIT ELSE lmi = l - i jmk = j - k IF ( lmi<=jmk ) THEN il(m) = k iu(m) = j j = l m = m + 1 ELSE il(m) = i iu(m) = l i = k m = m + 1 ENDIF GOTO 500 ENDIF ENDIF ENDDO ENDIF ENDDO 400 m = m - 1 IF ( m==0 ) RETURN i = il(m) j = iu(m) 500 jmi = j - i IF ( jmi>=11 ) GOTO 300 IF ( i==1 ) GOTO 200 i = i - 1 DO i = i + 1 IF ( i==j ) GOTO 400 amed = Y(i+1) IF ( Y(i)>amed ) THEN k = i DO Y(k+1) = Y(k) k = k - 1 IF ( amed>=Y(k) ) THEN Y(k+1) = amed EXIT ENDIF ENDDO ENDIF ENDDO END SUBROUTINE SORT !> !!##NAME !! sortp(3f) - [M_datapac:SORT] sorts and ranks a numeric !! vector X !! !!##SYNOPSIS !! !! SUBROUTINE SORTP(X,N,Y,Xpos) !! !! Real(kind=wp) :: (In) :: X(N) !! Integer, Intent (In) :: N !! Real(kind=wp) :: (Out) :: Y(N) !! Real(kind=wp) :: (Out) :: XPOS(N) !! !!##DESCRIPTION !! !! SORTP(3f) sorts (in ascending order) the N elements of the precision !! precision vector X, puts the resulting N sorted values into the precision !! precision vector Y; and puts the position (in the original vector X) !! of each of the sorted values into the REAL vector XPOS. !! !! This subroutine gives the data analyst not only the ability to determine !! what the MIN and MAX (for example) of the data set are, but also where !! in the original data set the MIN and MAX occur. !! !! This is especially useful for large data sets. !! !!##OPTIONS !! X description of parameter !! Y description of parameter !! !!##EXAMPLES !! !! Sample program: !! !! program demo_sortp !! use M_datapac, only : sortp !! implicit none !! ! call sortp(x,y) !! end program demo_sortp !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the Statistical !! Engineering Division, National Institute of Standards and Technology. !!##MAINTAINER !! John Urban, 2022.05.31 !!##LICENSE !! CC0-1.0 !!##REFERENCES !! * CACM March 1969, page 186 (Binary Sort Algorithm by Richard C. Singleton). !! * CACM January 1970, page 54. !! * CACM October 1970, page 624. !! * JACM January 1961, page 41. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE SORTP(X,N,Y,Xpos) REAL(kind=wp) :: amed , bmed , hold , tt , X , Xpos , Y INTEGER :: i , il , ip1 , itt , iu , j , jmi , jmk , k , l ,lmi , m , mid , N , nm1 ! INPUT ARGUMENTS--X = THE VECTOR OF ! OBSERVATIONS TO BE SORTED. ! --N = THE INTEGER NUMBER OF OBSERVATIONS ! IN THE VECTOR X. ! OUTPUT ARGUMENTS--Y = THE VECTOR ! INTO WHICH THE SORTED DATA VALUES ! FROM X WILL BE PLACED. ! --XPOS = THE VECTOR ! INTO WHICH THE POSITIONS ! (IN THE ORIGINAL VECTOR X) ! OF THE SORTED VALUES ! WILL BE PLACED. ! OUTPUT--THE VECTOR XS ! CONTAINING THE SORTED ! (IN ASCENDING ORDER) VALUES ! OF THE VECTOR X, AND ! THE VECTOR XPOS ! CONTAINING THE POSITIONS ! (IN THE ORIGINAL VECTOR X) ! OF THE SORTED VALUES. ! PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. ! RESTRICTIONS--THE DIMENSIONS OF THE VECTORS IL AND IU ! (DEFINED AND USED INTERNALLY WITHIN ! THIS SUBROUTINE) DICTATE THE MAXIMUM ! ALLOWABLE VALUE OF N FOR THIS SUBROUTINE. ! IF IL AND IU EACH HAVE DIMENSION K, ! THEN N MAY NOT EXCEED 2**(K+1) - 1. ! FOR THIS SUBROUTINE AS WRITTEN, THE DIMENSIONS ! OF IL AND IU HAVE BEEN SET TO 36, ! THUS THE MAXIMUM ALLOWABLE VALUE OF N IS ! APPROXIMATELY 137 BILLION. ! SINCE THIS EXCEEDS THE MAXIMUM ALLOWABLE ! VALUE FOR AN INTEGER VARIABLE IN MANY COMPUTERS, ! AND SINCE A SORT OF 137 BILLION ELEMENTS ! IS PRESENTLY IMPRACTICAL AND UNLIKELY, ! THEN THERE IS NO PRACTICAL RESTRICTION ! ON THE MAXIMUM VALUE OF N FOR THIS SUBROUTINE. ! (IN LIGHT OF THE ABOVE, NO CHECK OF THE ! UPPER LIMIT OF N HAS BEEN INCORPORATED ! INTO THIS SUBROUTINE.) ! COMMENT--THE SMALLEST ELEMENT OF THE VECTOR X ! WILL BE PLACED IN THE FIRST POSITION ! OF THE VECTOR Y, ! THE SECOND SMALLEST ELEMENT IN THE VECTOR X ! WILL BE PLACED IN THE SECOND POSITION ! OF THE VECTOR Y, ! ETC. ! COMMENT--THE POSITION (1 THROUGH N) IN X ! OF THE SMALLEST ELEMENT IN X ! WILL BE PLACED IN THE FIRST POSITION ! OF THE VECTOR XPOS, ! THE POSITION (1 THROUGH N) IN X ! OF THE SECOND SMALLEST ELEMENT IN X ! WILL BE PLACED IN THE SECOND POSITION ! OF THE VECTOR XPOS, ! ETC. ! ALTHOUGH THESE POSITIONS ARE NECESSARILY ! INTEGRAL VALUES FROM 1 TO N, IT IS TO BE ! NOTED THAT THEY ARE OUTPUTED AS SINGLE ! PRECISION INTEGERS IN THE ! VECTOR XPOS. ! XPOS IS SO AS TO BE ! CONSISTENT WITH THE FACT THAT ALL ! VECTOR ARGUMENTS IN ALL OTHER ! DATAPAC SUBROUTINES ARE . ! COMMENT--THE INPUT VECTOR X REMAINS UNALTERED. ! COMMENT--IF THE ANALYST DESIRES A SORT 'IN PLACE', ! THIS IS DONE BY HAVING THE SAME ! OUTPUT VECTOR AS INPUT VECTOR IN THE CALLING SEQUENCE. ! THUS, FOR EXAMPLE, THE CALLING SEQUENCE ! CALL SORTP(X,N,X,XPOS) ! IS ALLOWABLE AND WILL RESULT IN ! THE DESIRED 'IN-PLACE' SORT. ! COMMENT--THE SORTING ALGORTHM USED HEREIN ! IS THE BINARY SORT. ! THIS ALGORTHIM IS EXTREMELY FAST AS THE ! FOLLOWING TIME TRIALS INDICATE. ! THESE TIME TRIALS WERE CARRIED OUT ON THE ! UNIVAC 1108 EXEC 8 SYSTEM AT NBS ! IN AUGUST OF 1974. ! BY WAY OF COMPARISON, THE TIME TRIAL VALUES ! FOR THE EASY-TO-PROGRAM BUT EXTREMELY ! INEFFICIENT BUBBLE SORT ALGORITHM HAVE ! ALSO BEEN INCLUDED-- ! NUMBER OF RANDOM BINARY SORT BUBBLE SORT ! NUMBERS SORTED ! N = 10 .002 SEC .002 SEC ! N = 100 .011 SEC .045 SEC ! N = 1000 .141 SEC 4.332 SEC ! N = 3000 .476 SEC 37.683 SEC ! N = 10000 1.887 SEC NOT COMPUTED ! ORIGINAL VERSION--JUNE 1972. ! UPDATED --NOVEMBER 1975. ! !--------------------------------------------------------------------- ! DIMENSION X(:) , Y(:) , Xpos(:) DIMENSION iu(36) , il(36) ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( N<1 ) THEN WRITE (G_IO,99001) 99001 FORMAT (' ','***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE SORTP SUBROUTINE IS NON-POSITIVE *****') WRITE (G_IO,99002) N 99002 FORMAT (' ','***** THE VALUE OF THE ARGUMENT IS ',I0,' *****') RETURN ELSE IF ( N==1 ) THEN WRITE (G_IO,99003) 99003 FORMAT (' ','***** NON-FATAL DIAGNOSTIC--THE SECOND INPUT ARGUMENT TO THE SORTP SUBROUTINE HAS THE VALUE 1 *****') Y(1) = X(1) Xpos(1) = 1.0_wp RETURN ELSE hold = X(1) DO i = 2 , N IF ( X(i)/=hold ) GOTO 50 ENDDO WRITE (G_IO,99004) hold 99004 FORMAT (' ',& & '***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT (A VECTOR) TO THE SORTP SUBROUTINE HAS ALL ELEMENTS =',& & E15.8,& & ' *****') DO i = 1 , N Y(i) = X(i) Xpos(i) = i ENDDO RETURN ENDIF ! !-----START POINT----------------------------------------------------- ! ! COPY THE VECTOR X INTO THE VECTOR Y 50 DO i = 1 , N Y(i) = X(i) ENDDO ! ! DEFINE THE XPOS (POSITION) VECTOR. BEFORE SORTING, THIS WILL ! BE A VECTOR WHOSE I-TH ELEMENT IS EQUAL TO I. ! DO i = 1 , N Xpos(i) = i ENDDO ! ! CHECK TO SEE IF THE INPUT VECTOR IS ALREADY SORTED ! nm1 = N - 1 DO i = 1 , nm1 ip1 = i + 1 IF ( Y(i)>Y(ip1) ) GOTO 100 ENDDO RETURN ENDIF 100 m = 1 i = 1 j = N 200 IF ( i>=j ) GOTO 400 300 k = i mid = (i+j)/2 amed = Y(mid) bmed = Xpos(mid) IF ( Y(i)>amed ) THEN Y(mid) = Y(i) Xpos(mid) = Xpos(i) Y(i) = amed Xpos(i) = bmed amed = Y(mid) bmed = Xpos(mid) ENDIF l = j IF ( Y(j)<amed ) THEN Y(mid) = Y(j) Xpos(mid) = Xpos(j) Y(j) = amed Xpos(j) = bmed amed = Y(mid) bmed = Xpos(mid) IF ( Y(i)>amed ) THEN Y(mid) = Y(i) Xpos(mid) = Xpos(i) Y(i) = amed Xpos(i) = bmed amed = Y(mid) bmed = Xpos(mid) ENDIF ENDIF DO l = l - 1 IF ( Y(l)<=amed ) THEN tt = Y(l) itt = Xpos(l) DO k = k + 1 IF ( Y(k)>=amed ) THEN IF ( k<=l ) THEN Y(l) = Y(k) Xpos(l) = Xpos(k) Y(k) = tt Xpos(k) = itt EXIT ELSE lmi = l - i jmk = j - k IF ( lmi<=jmk ) THEN il(m) = k iu(m) = j j = l m = m + 1 ELSE il(m) = i iu(m) = l i = k m = m + 1 ENDIF GOTO 500 ENDIF ENDIF ENDDO ENDIF ENDDO 400 m = m - 1 IF ( m==0 ) RETURN i = il(m) j = iu(m) 500 jmi = j - i IF ( jmi>=11 ) GOTO 300 IF ( i==1 ) GOTO 200 i = i - 1 DO i = i + 1 IF ( i==j ) GOTO 400 amed = Y(i+1) bmed = Xpos(i+1) IF ( Y(i)>amed ) THEN k = i DO Y(k+1) = Y(k) Xpos(k+1) = Xpos(k) k = k - 1 IF ( amed>=Y(k) ) THEN Y(k+1) = amed Xpos(k+1) = bmed EXIT ENDIF ENDDO ENDIF ENDDO END SUBROUTINE SORTP !> !!##NAME !! spcorr(3f) - [M_datapac:STATISTICS] compute the sample Spearman rank !! correlation coefficient between two vectors of observations !! !!##SYNOPSIS !! !! SUBROUTINE SPCORR(X,Y,N,Iwrite,Spc) !! !!##DESCRIPTION !! spcorr(3f) computes the spearman rank correlation coefficient between !! the 2 sets of data in the input vectors x and y. !! !! the spearman rank correlation coefficient will be a REAL !! value between -1.0 and 1.0 (inclusively). !! !!##OPTIONS !! X description of parameter !! Y description of parameter !! !!##EXAMPLES !! !! Sample program: !! !! program demo_spcorr !! use M_datapac, only : spcorr !! implicit none !! ! call spcorr(x,y) !! end program demo_spcorr !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the Statistical !! Engineering Division, National Institute of Standards and Technology. !!##MAINTAINER !! John Urban, 2022.05.31 !!##LICENSE !! CC0-1.0 !!##REFERENCES !! * KENDALL AND STUART, THE ADVANCED THEORY OF STATISTICS, VOLUME 2, EDITION 1, 1961, pages 476-477. !! * SNEDECOR AND COCHRAN, STATISTICAL METHODS, EDITION 6, 1967, pages 193-195. !! * DIXON AND MASSEY, INTRODUCTION TO STATISTICAL ANALYSIS, EDITION 2, 1957, pages 294-295. !! * MOOD AND GRABLE, 'INTRODUCTION TO THE THEORY OF STATISTICS, EDITION 2, 1963, page 424. ! ORIGINAL VERSION--JUNE 1972. ! UPDATED --OCTOBER 1974. ! UPDATED --JANUARY 1975. ! UPDATED --SEPTEMBER 1975. ! UPDATED --NOVEMBER 1975. ! UPDATED --FEBRUARY 1976. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE SPCORR(X,Y,N,Iwrite,Spc) REAL(kind=wp) :: an, hold, Spc, sum, WS, X, XR, Y, YR INTEGER :: i, iflag, iupper, Iwrite, N ! ! INPUT ARGUMENTS--X = THE VECTOR OF ! (UNSORTED OR SORTED) OBSERVATIONS ! WHICH CONSTITUTE THE FIRST SET ! OF DATA. ! --Y = THE VECTOR OF ! (UNSORTED OR SORTED) OBSERVATIONS ! WHICH CONSTITUTE THE SECOND SET ! OF DATA. ! --N = THE INTEGER NUMBER OF OBSERVATIONS ! IN THE VECTOR X, OR EQUIVALENTLY, ! THE INTEGER NUMBER OF OBSERVATIONS ! IN THE VECTOR Y. ! --IWRITE = AN INTEGER FLAG CODE WHICH ! (IF SET TO 0) WILL SUPPRESS ! THE PRINTING OF THE ! SPEARMAN RANK CORRELATION COEFFICIENT ! AS IT IS COMPUTED; ! OR (IF SET TO SOME INTEGER ! VALUE NOT EQUAL TO 0), ! LIKE, SAY, 1) WILL CAUSE ! THE PRINTING OF THE ! SPEARMAN CORRELATION COEFFICIENT ! AT THE TIME IT IS COMPUTED. ! OUTPUT ARGUMENTS--SPC = THE VALUE OF THE ! COMPUTED SPEARMAN RANK CORRELATION ! COEFFICIENT BETWEEN THE 2 SETS OF DATA ! IN THE INPUT VECTORS X AND Y. ! THIS VALUE ! WILL BE BETWEEN -1.0 AND 1.0 ! (INCLUSIVELY). ! OUTPUT--THE COMPUTED VALUE OF THE ! SPEARMAN RANK CORRELATION COEFFICIENT BETWEEN THE 2 SETS ! OF DATA IN THE INPUT VECTORS X AND Y. ! RESTRICTIONS--THE MAXIMUM ALLOWABLE VALUE OF N FOR THIS SUBROUTINE IS 7500. ! !--------------------------------------------------------------------- ! DIMENSION X(:) , Y(:) DIMENSION XR(7500) , YR(7500) COMMON /BLOCK2_real32/ WS(15000) EQUIVALENCE (XR(1),WS(1)) EQUIVALENCE (YR(1),WS(7501)) ! iupper = 7500 ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! an = N Spc = 0.0_wp iflag = 0 IF ( N<1 .OR. N>iupper ) THEN WRITE (G_IO,99001) iupper 99001 FORMAT (' ***** FATAL ERROR--THE THIRD INPUT ARGUMENT TO SPCORR(3f) IS OUTSIDE THE ALLOWABLE (1,',& & I0,' INTERVAL *****') WRITE (G_IO,99002) N 99002 FORMAT (' ***** THE VALUE OF THE ARGUMENT IS ',I0,' *****') RETURN ELSEIF ( N==1 ) THEN WRITE (G_IO,99003) 99003 FORMAT (' ***** NON-FATAL DIAGNOSTIC--THE THIRD INPUT ARGUMENT TO SPCORR(3f) HAS THE VALUE 1 *****') RETURN ELSE hold = X(1) DO i = 2 , N IF ( X(i)/=hold ) GOTO 50 ENDDO WRITE (G_IO,99004) hold 99004 FORMAT (' ***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT (A VECTOR) TO SPCORR(3f) HAS ALL ELEMENTS =',& & E15.8,' *****') iflag = 1 50 hold = Y(1) DO i = 2 , N IF ( Y(i)/=hold ) GOTO 100 ENDDO WRITE (G_IO,99005) hold 99005 FORMAT (' ***** NON-FATAL DIAGNOSTIC--THE SECOND INPUT ARGUMENT (A VECTOR) TO SPCORR(3f) HAS ALL ELEMENTS =',& & E15.8,' *****') iflag = 1 100 IF ( iflag==1 ) RETURN ! !-----START POINT----------------------------------------------------- ! CALL RANK(X,N,XR) CALL RANK(Y,N,YR) sum = 0.0_wp DO i = 1 , N sum = sum + (XR(i)-YR(i))**2 ENDDO Spc = 1.0_wp - (6.0_wp*sum/((an-1.0_wp)*an*(an+1.0_wp))) ! IF ( Iwrite/=0 ) WRITE (G_IO,99006) N , Spc 99006 FORMAT (' THE SPEARMAN RANK CORRELATION COEFFICIENT OF THE 2 SETS OF '& & ,I0,' OBSERVATIONS IS ',F14.5) ENDIF END SUBROUTINE SPCORR !> !!##NAME !! stmom3(3f) - [M_datapac:STATISTICS] compute the third central moment !! (i.e., the skewness) of a vector of observations !! !!##SYNOPSIS !! !! SUBROUTINE STMOM3(X,N,Iwrite,Xsmom3) !! !!##DESCRIPTION !! stmom3(3f) computes the sample standardized third central moment of !! the data in the input vector x. !! !! the sample standardized third central moment = (the sample third !! central moment)/((the sample standard deviation)**3). !! !! n (rather than n-1) has been used in the denominator in the calculation !! of both the sample third central moment and the sample standard !! deviation. !! !!##OPTIONS !! X description of parameter !! Y description of parameter !! !!##EXAMPLES !! !! Sample program: !! !! program demo_stmom3 !! use M_datapac, only : stmom3 !! implicit none !! ! call stmom3(x,y) !! end program demo_stmom3 !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !! !!##REFERENCES !! * Kendall and Stuart, the Advanced Theory of Statistics, Volume 1, !! Edition 2, 1963, pages 85, 234, 243, 297-298, 305. !! * Snedecor and Cochran, Statistical Methods, Edition 6, 1967, pages !! 86-90. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE STMOM3(X,N,Iwrite,Xsmom3) REAL(kind=wp) :: an , hold , sum , sum2 , sum3 , vb , X , xmean , Xsmom3 INTEGER :: i , Iwrite , N ! ! INPUT ARGUMENTS--X = THE VECTOR OF ! (UNSORTED OR SORTED) OBSERVATIONS. ! --N = THE INTEGER NUMBER OF OBSERVATIONS ! IN THE VECTOR X. ! --IWRITE = AN INTEGER FLAG CODE WHICH ! (IF SET TO 0) WILL SUPPRESS ! THE PRINTING OF THE ! SAMPLE STANDARDIZED THIRD CENTRAL ! MOMENT AS IT IS COMPUTED; ! OR (IF SET TO SOME INTEGER ! VALUE NOT EQUAL TO 0), ! LIKE, SAY, 1) WILL CAUSE ! THE PRINTING OF THE ! SAMPLE STANDARDIZED THIRD CENTRAL ! MOMENT AT THE TIME IT IS COMPUTED. ! OUTPUT ARGUMENTS--XSMOM3 = THE VALUE OF THE ! COMPUTED SAMPLE STANDARDIZED THIRD ! CENTRAL MOMENT. ! OUTPUT--THE COMPUTED VALUE OF THE ! SAMPLE STANDARDIZED THIRD CENTRAL MOMENT. ! PRINTING--NONE, UNLESS IWRITE HAS BEEN SET TO A NON-ZERO ! INTEGER, OR UNLESS AN INPUT ARGUMENT ERROR ! CONDITION EXISTS. ! RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE ! OF N FOR THIS SUBROUTINE. ! MODE OF INTERNAL OPERATIONS--. ! ORIGINAL VERSION--JUNE 1972. ! UPDATED --SEPTEMBER 1975. ! UPDATED --NOVEMBER 1975. ! !--------------------------------------------------------------------- ! DIMENSION X(:) ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! an = N IF ( N<1 ) THEN WRITE (G_IO,99001) 99001 FORMAT (' ', & &'***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE STMOM3 SUBROU& &TINE IS NON-POSITIVE *****') WRITE (G_IO,99002) N 99002 FORMAT (' ','***** THE VALUE OF THE ARGUMENT IS ',I0,' *****') RETURN ELSE IF ( N==1 ) THEN WRITE (G_IO,99003) 99003 FORMAT (' ', & &'***** NON-FATAL DIAGNOSTIC--THE SECOND INPUT ARGUMENT TO THE STMO& &M3 SUBROUTINE HAS THE VALUE 1 *****') Xsmom3 = 0.0_wp ELSE hold = X(1) DO i = 2 , N IF ( X(i)/=hold ) GOTO 50 ENDDO WRITE (G_IO,99004) hold 99004 FORMAT (' ', & &'***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT (A VECTOR) & &TO THE STMOM3 SUBROUTINE HAS ALL ELEMENTS = ',E15.8,' *****') Xsmom3 = 0.0_wp ENDIF GOTO 100 ! !-----START POINT----------------------------------------------------- ! 50 sum = 0.0_wp DO i = 1 , N sum = sum + X(i) ENDDO xmean = sum/an sum2 = 0.0_wp sum3 = 0.0_wp DO i = 1 , N sum2 = sum2 + (X(i)-xmean)**2 sum3 = sum3 + (X(i)-xmean)**3 ENDDO sum3 = sum3/an vb = sum2/an Xsmom3 = sum3/(vb**1.5_wp) ENDIF ! 100 IF ( Iwrite==0 ) RETURN WRITE (G_IO,99005) 99005 FORMAT (' ') WRITE (G_IO,99006) N , Xsmom3 99006 FORMAT (' ', & & 'THE SAMPLE STANDARDIZED THIRD CENTRAL MOMENT FOR THE ', & & I0,' OBSERVATIONS IS ',E15.8) END SUBROUTINE STMOM3 !> !!##NAME !! stmom4(3f) - [M_datapac:STATISTICS] compute the fourth central moment !! (i.e., the kurtosis) of a vector of observations !! !!##SYNOPSIS !! !! SUBROUTINE STMOM4(X,N,Iwrite,Xsmom4) !! !!##DESCRIPTION !! !! stmom4(3f) computes the sample standardized fourth central moment of !! the data in the input vector x. !! !! the sample standardized fourth central moment = (the sample fourth !! central moment)/((the sample standard deviation)**4). !! !! n (rather than n-1) has been used in the denominator in the calculation !! of both the sample fourth central moment and the sample standard !! deviation. !! !!##OPTIONS !! X description of parameter !! Y description of parameter !! !!##EXAMPLES !! !! Sample program: !! !! program demo_stmom4 !! use M_datapac, only : stmom4 !! implicit none !! ! call stmom4(x,y) !! end program demo_stmom4 !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !! !!##REFERENCES !! * Kendall and Stuart, The Advanced Theory of Statistics, Volume 1, !! Edition 2, 1963, pages 85, 243. !! * Snedecor and Cochran, Statistical Methods, Edition 6, 1967, pages !! 86-90. ! ORIGINAL VERSION--JUNE 1972. ! UPDATED --SEPTEMBER 1975. ! UPDATED --NOVEMBER 1975. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE STMOM4(X,N,Iwrite,Xsmom4) REAL(kind=wp) :: an , hold , sum , sum2 , sum4 , vb , X , xmean , Xsmom4 INTEGER :: i , Iwrite , N ! ! INPUT ARGUMENTS--X = THE VECTOR OF ! (UNSORTED OR SORTED) OBSERVATIONS. ! --N = THE INTEGER NUMBER OF OBSERVATIONS ! IN THE VECTOR X. ! --IWRITE = AN INTEGER FLAG CODE WHICH ! (IF SET TO 0) WILL SUPPRESS ! THE PRINTING OF THE ! SAMPLE STANDARDIZED FOURTH CENTRAL ! MOMENT AS IT IS COMPUTED; ! OR (IF SET TO SOME INTEGER ! VALUE NOT EQUAL TO 0), ! LIKE, SAY, 1) WILL CAUSE ! THE PRINTING OF THE ! SAMPLE STANDARDIZED FOURTH CENTRAL ! MOMENT AT THE TIME IT IS COMPUTED. ! OUTPUT ARGUMENTS--XSMOM4 = THE VALUE OF THE ! COMPUTED SAMPLE STANDARDIZED FOURTH ! CENTRAL MOMENT. ! OUTPUT--THE COMPUTED VALUE OF THE ! SAMPLE STANDARDIZED FOURTH CENTRAL MOMENT. ! PRINTING--NONE, UNLESS IWRITE HAS BEEN SET TO A NON-ZERO ! INTEGER, OR UNLESS AN INPUT ARGUMENT ERROR ! CONDITION EXISTS. ! RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE ! OF N FOR THIS SUBROUTINE. ! MODE OF INTERNAL OPERATIONS--. ! !--------------------------------------------------------------------- ! DIMENSION X(:) ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! an = N IF ( N<1 ) THEN WRITE (G_IO,99001) 99001 FORMAT (' ', & &'***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE STMOM4 SUBROU& &TINE IS NON-POSITIVE *****') WRITE (G_IO,99002) N 99002 FORMAT (' ','***** THE VALUE OF THE ARGUMENT IS ',I0,' *****') RETURN ELSE IF ( N==1 ) THEN WRITE (G_IO,99003) 99003 FORMAT (' ', & &'***** NON-FATAL DIAGNOSTIC--THE SECOND INPUT ARGUMENT TO THE STMO& &M4 SUBROUTINE HAS THE VALUE 1 *****') Xsmom4 = 0.0_wp ELSE hold = X(1) DO i = 2 , N IF ( X(i)/=hold ) GOTO 50 ENDDO WRITE (G_IO,99004) hold 99004 FORMAT (' ', & &'***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT (A VECTOR) & &TO THE STMOM4 SUBROUTINE HAS ALL ELEMENTS = ',E15.8,' *****') Xsmom4 = 0.0_wp ENDIF GOTO 100 ! !-----START POINT----------------------------------------------------- ! 50 sum = 0.0_wp DO i = 1 , N sum = sum + X(i) ENDDO xmean = sum/an sum2 = 0.0_wp sum4 = 0.0_wp DO i = 1 , N sum2 = sum2 + (X(i)-xmean)**2 sum4 = sum4 + (X(i)-xmean)**4 ENDDO vb = sum2/an sum4 = sum4/an Xsmom4 = sum4/(vb*vb) ENDIF ! 100 IF ( Iwrite==0 ) RETURN WRITE (G_IO,99005) 99005 FORMAT (' ') WRITE (G_IO,99006) N , Xsmom4 99006 FORMAT (' ', & & 'THE SAMPLE STANDARDIZED FOURTH CENTRAL MOMENT FOR THE ', & & I0,' OBSERVATIONS IS ',E15.8) END SUBROUTINE STMOM4 !> !!##NAME !! !! subse1(3f) - [M_datapac:VECTOR_OPERATION] extract the elements of a vector !! which fall into a user-specified subset (one subset variable) !! !!##SYNOPSIS !! !! !! SUBROUTINE SUBSE1(X,N,D,Dmin,Dmax,Y,Ny) !! !! REAL(kind=wp) :: D(:), Dmax, Dmin, X(:), Y(:) !! INTEGER :: N, Ny !! !!##DESCRIPTION !! !! This subroutine carries over into Y all observations of the precision !! precision vector X for which the corresponding elements in the precision !! precision vector D are inside the closed (inclusive) interval defined !! by DMIN and DMAX, while not carrying over any observations of X !! corresponding to elements of D outside of this interval. !! !! the input vector X is itself unaltered; those elements of X to be !! retained are copied over into the output vector Y. !! !! thus all observations of X which correspond to elements in D which !! are smaller than DMIN or larger than DMAX are not copied over into Y. !! !! the use of subse1(3f) gives the data analyst the capability !! to easily extract subsets of the data prior to data analysis on !! each subset. !! !!##INPUT ARGUMENTS !! !! X The vector of (unsorted or sorted) observations. !! !! n The integer number of observations in the vector x. !! !! d The vector which 'defines' the various possible subsets of x. !! !! dmin The value which defines the lower limit (inclusively) of the !! particular subset of interest to be retained. !! !! dmax The value which defines the upper limit (inclusively) of the !! particular subset of interest to be retained. !! !!##OUTPUT ARGUMENTS !! !! y the vector containing only those elements !! of x corresponding to values of the d vector !! in the interval dmin to dmax (inclusive). !! !! ny the integer number of retained observations copied into !! the vector y. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_subse1 !! use M_datapac, only : subse1 !! implicit none !! ! call subse1(x,y) !! end program demo_subse1 !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the Statistical !! Engineering Division, National Institute of Standards and Technology. !!##MAINTAINER !! John Urban, 2022.05.31 !!##LICENSE !! CC0-1.0 ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE SUBSE1(X,N,D,Dmin,Dmax,Y,Ny) REAL(kind=wp) :: D(:) , Dmax , Dmin , hold , pointl , pointu , X(:) , Y(:) INTEGER i , k , N , ndel , Ny ! OUTPUT--THE VECTOR Y ! INTO WHICH HAVE BEEN COPIED ! ONLY THOSE VALUES OF X WHICH ! CORRESPOND TO VALUES ! IN THE D VECTOR INSIDE ! (INCLUSIVELY) THE INTERVAL OF ! INTEREST, AND ! THE INTEGER VALUE NY ! WHICH GIVES THE NUMBER OF ! OBSERVATIONS COPIED INTO Y. ! ALSO, 12 LINES OF SUMMARY INFORMATION ! WILL BE GENERATED INDICATING ! 1) WHAT THE INTERVAL OF INTEREST WAS ! IN THE D VECTOR; ! 2) HOW MANY OBSERVATIONS WERE DELETED; ! 3) WHAT THE SAMPLE SIZE OF X WAS (N); ! 4) WHAT THE SAMPLE SIZE OF Y WAS (NY); ! PRINTING--YES. ! COMMENT--THE INPUT VECTOR X IS NOT ALTERED ! BY APPLICATION OF THIS SUBROUTINE. ! THIS IS THE MAJOR DISTINCTION ! BETWEEN THIS SUBROUTINE AND, SAY, ! THE SUBSET SUBROUTINE. ! IT IS THUS SEEN THAT THIS (SUBSE1) ! SUBROUTINE IS THE PREFERABLE OF THE 2 ! (SUBSET VERSUS SUBSE1) ! FOR HANDLING THE PROBLEM OF ! SEQUENTIALLY EXTRACTING EACH POSSIBLE ! SUBSET OF X (FOR THE PURPOSE OF ! ANALYZING EACH INDIVIDUAL SUBSET). ! INASMUCH AS THE ORIGINAL X VECTOR ! REMAINS UNCHANGED, THE ANALYST ! CAN ALWAYS OPERATE ON IT WITH ! SUBSE1 IN SEQUENTIALLY EXTRACTING ! SUBSETS OF INTEREST. ! COMMENT--IN THE END, AFTER THIS SUBROUTINE HAS ! MADE WHATEVER DELETIONS ARE APPROPRIATE, ! THE OUTPUT VECTOR Y WILL BE 'PACKED'; ! THAT IS, NO 'HOLES' WILL EXIST IN THE ! VECTOR Y--ALL OF THE RETAINED ELEMENTS ! OF Y WILL BE PACKED INTO THE FIRST AVAILABLE ! LOCATIONS IN Y, WHILE THE REMAINDER ! OF THE N LOCATIONS IN Y WILL BE ZERO-FILLED. ! COMMENT--ALTHOUGH THERE ! MAY BE A CORRESPONDANCE BETWEEN THE ! ELEMENTS OF THE X AND D VECTORS ! BEFORE APPLICATION OF ! THIS SUBROUTINE, THERE WILL ! BE NO CORRESPONDANCE BETWEEN ! Y AND D (DUE TO THE PACKING OF ! THE RETAINED ELEMENTS IN Y) ! AFTER APPLICATION OF THIS SUBROUTINE. ! ORIGINAL VERSION--APRIL 1975. ! UPDATED --NOVEMBER 1975. !--------------------------------------------------------------------- ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( N<1 ) THEN WRITE (G_IO,99001) 99001 FORMAT (' ', & &'***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE SUBSE1 SUBROU& &TINE IS NON-POSITIVE *****') WRITE (G_IO,99002) N 99002 FORMAT (' ','***** THE VALUE OF THE ARGUMENT IS ',I0,' *****') RETURN ELSE IF ( N==1 ) THEN WRITE (G_IO,99003) 99003 FORMAT (' ', & &'***** NON-FATAL DIAGNOSTIC--THE SECOND INPUT ARGUMENT TO THE SUBS& &E1 SUBROUTINE HAS THE VALUE 1 *****') ELSE hold = X(1) DO i = 2 , N IF ( X(i)/=hold ) GOTO 50 ENDDO WRITE (G_IO,99004) hold 99004 FORMAT (' ', & &'***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT (A VECTOR) & &TO THE SUBSE1 SUBROUTINE HAS ALL ELEMENTS =',E15.8,' *****') ENDIF ! !-----START POINT----------------------------------------------------- ! 50 pointl = Dmin pointu = Dmax IF ( Dmin>Dmax ) pointl = Dmax IF ( Dmin>Dmax ) pointu = Dmin ! k = 0 DO i = 1 , N IF ( D(i)>=pointl .AND. D(i)<=pointu ) THEN k = k + 1 Y(k) = X(i) ENDIF ENDDO Ny = k ndel = N - Ny ! ! WRITE OUT A BRIEF SUMMARY ! WRITE (G_IO,99005) 99005 FORMAT (' ') WRITE (G_IO,99006) 99006 FORMAT (' ','OUTPUT FROM THE SUBSE1 SUBROUTINE--') WRITE (G_IO,99007) pointl , pointu 99007 FORMAT (' ',7X,'D1 LIMITS (INCLUSIVE)-- ',E15.8,' AND ', E15.8) WRITE (G_IO,99008) 99008 FORMAT (' ',7X,'ONLY THOSE OBSERVATIONS IN X') WRITE (G_IO,99009) 99009 FORMAT (' ',7X,'WILL BE CARRIED OVER INTO Y') WRITE (G_IO,99010) 99010 FORMAT (' ',7X,'FOR WHICH THE CORRESPONDING ELEMENTS OF ','D1') WRITE (G_IO,99011) 99011 FORMAT (' ',7X,'ARE SIMULTANEOUSLY WITHIN (INCLUSIVE)') WRITE (G_IO,99012) 99012 FORMAT (' ',7X,'EACH SPECIFIED LIMIT.') WRITE (G_IO,99013) 99013 FORMAT (' ',7X,'NO OBSERVATIONS OUTSIDE OF THIS INTERVAL') WRITE (G_IO,99014) 99014 FORMAT (' ',7X,'HAVE BEEN CARRIED OVER INTO Y.') WRITE (G_IO,99015) N 99015 FORMAT (' ',7X,'THE INPUT NUMBER OF OBSERVATIONS (IN X) IS ', I0) WRITE (G_IO,99016) Ny 99016 FORMAT (' ',7X,'THE OUTPUT NUMBER OF OBSERVATIONS (IN Y) IS ', I0) WRITE (G_IO,99017) ndel 99017 FORMAT (' ',7X,'THE NUMBER OF OBSERVATIONS DELETED IS ', I0) ENDIF ! END SUBROUTINE SUBSE1 !> !!##NAME !! subse2(3f) - [M_datapac:VECTOR_OPERATION] extract the elements of a vector !! which fall into a user-specified subset (two subset variables) !! !!##SYNOPSIS !! !! SUBROUTINE SUBSE2(X,N,D1,D1min,D1max,D2,D2min,D2max,Y,Ny) !! !! REAL(kind=wp) :: D1(:), D1max, D1min, D2(:), D2max, D2min, X(:), Y(:) !! INTEGER :: N, Ny !! !!##DESCRIPTION !! !! This subroutine carries over into Y all observations of the precision !! precision vector X for which the corresponding elements in the precision !! precision vector D1 are inside the closed (inclusive) interval defined !! by D1MIN and D1MAX, and also for which the corresponding elements !! in the vector D2 are inside the closed (inclusive) !! interval defined by D2MIN and D2MAX. !! !! No observations in X corresponding to elements of D1 or D2 outside !! of their respective intervals are carried over into Y. !! !! The input vector X is itself unaltered; those elements of X to be !! retained are copied over into the output vector Y. !! !! Thus all observations of X which correspond to elements in D1 which !! are smaller than D1MIN or larger than D1MAX, or which correspond to !! elements in D2 which are smaller than D2MIN or larger than D2MAX, !! are not copied over into Y. !! !! The use of subse2(3f) gives the data analyst the capability !! to easily extract subsets of the data prior to data analysis on !! each subset. !! !!##INPUT ARGUMENTS !! !! X the vector of (unsorted or sorted) observations. !! !! N The integer number of observations in the vector x. !! !! D1 A vector which (in conjunction with d2) "defines" the various !! possible subsets of x. !! !! D1MIN The value which defines in d1 the lower limit !! (inclusively) of the particular subset of interest to be !! retained. !! !! D1MAX The value which defines in d1 the upper limit !! (inclusively) of the particular subset of interest to be !! retained. !! !! D2 A vector which (in conjunction with d2) "defines" the various !! possible subsets of x. !! !! D2MIN The value which defines in d2 the lower limit !! (inclusively) of the particular subset of interest to be retained. !! !! D2MAX The value which defines in d2 the upper limit !! (inclusively) of the particular subset of interest to be retained. !! !!##OUTPUT ARGUMENTS !! !! Y The vector containing only those elements !! of X simultaneously corresponding to values of the D1 vector !! in the interval D1MIN to D1MAX (inclusive), and values of the !! D2 vector in the interval D2MIN to D2MAX (inclusive). !! !! NY The integer number of retained observations copied into !! the vector Y. !! !!##EXAMPLES !! !! !! Sample program: !! !! program demo_subse2 !! use M_datapac, only : subse2 !! implicit none !! ! call subse2(x,y) !! end program demo_subse2 !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the Statistical !! Engineering Division, National Institute of Standards and Technology. !!##MAINTAINER !! John Urban, 2022.05.31 !!##LICENSE !! CC0-1.0 ! ORIGINAL VERSION--FEBRUARY 1976. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE SUBSE2(X,N,D1,D1min,D1max,D2,D2min,D2max,Y,Ny) REAL(kind=wp) :: D1(:), D1max, D1min, D2(:), D2max, D2min, hold, poin1l, poin1u, poin2l, poin2u, X(:), Y(:) INTEGER :: i, k, N, ndel, Ny ! OUTPUT--THE VECTOR Y ! INTO WHICH HAVE BEEN COPIED ! ONLY THOSE VALUES OF X WHICH ! SIMULTANEOUSLY CORRESPOND TO VALUES ! IN THE D1 AND D2 VECTORS INSIDE ! (INCLUSIVELY) THE RESPECTIVE ! INTERVALS OF INTEREST, AND ! THE INTEGER VALUE NY ! WHICH GIVES THE NUMBER OF ! OBSERVATIONS COPIED INTO Y. ! ALSO, 13 LINES OF SUMMARY INFORMATION ! WILL BE GENERATED INDICATING ! 1) WHAT THE INTERVAL OF INTEREST WAS ! IN THE D1 VECTOR; ! 2) WHAT THE INTERVAL OF INTEREST WAS ! IN THE D2 VECTOR; ! 3) HOW MANY OBSERVATIONS WERE DELETED; ! 4) WHAT THE SAMPLE SIZE OF X WAS (N); ! 5) WHAT THE SAMPLE SIZE OF Y WAS (NY); ! PRINTING--YES. ! RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE ! OF N FOR THIS SUBROUTINE. ! COMMENT--THE INPUT VECTOR X IS NOT ALTERED ! BY APPLICATION OF THIS SUBROUTINE. ! THIS IS A MAJOR DISTINCTION ! BETWEEN THIS SUBROUTINE AND, SAY, ! THE SUBSET SUBROUTINE. ! COMMENT--IN THE END, AFTER THIS SUBROUTINE HAS ! MADE WHATEVER DELETIONS ARE APPROPRIATE, ! THE OUTPUT VECTOR Y WILL BE 'PACKED'; ! THAT IS, NO 'HOLES' WILL EXIST IN THE ! VECTOR Y--ALL OF THE RETAINED ELEMENTS ! OF Y WILL BE PACKED INTO THE FIRST AVAILABLE ! LOCATIONS IN Y, WHILE THE REMAINDER ! OF THE N LOCATIONS IN Y WILL BE ZERO-FILLED. ! COMMENT--ALTHOUGH THERE ! MAY BE A CORRESPONDANCE BETWEEN ! THE ELEMENTS OF THE X AND D1 VECTORS ! AND ELEMENTS OF THE X AND D2 VECTORS ! BEFORE APPLICATION OF ! THIS SUBROUTINE, THERE WILL ! BE NO CORRESPONDANCE BETWEEN ! Y AND D1, AND Y AND D2 ! (DUE TO THE PACKING OF ! THE RETAINED ELEMENTS IN Y) ! AFTER APPLICATION OF THIS SUBROUTINE. ! !--------------------------------------------------------------------- ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( N<1 ) THEN WRITE (G_IO,99001) 99001 FORMAT (' ', & &'***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE SUBSE2 SUBROUTINE IS NON-POSITIVE *****') WRITE (G_IO,99002) N 99002 FORMAT (' ','***** THE VALUE OF THE ARGUMENT IS ',I0,' *****') RETURN ELSE IF ( N==1 ) THEN WRITE (G_IO,99003) 99003 FORMAT (' ', & &'***** NON-FATAL DIAGNOSTIC--THE SECOND INPUT ARGUMENT TO THE SUBSE2 SUBROUTINE HAS THE VALUE 1 *****') ELSE hold = X(1) DO i = 2 , N IF ( X(i)/=hold ) GOTO 50 ENDDO WRITE (G_IO,99004) hold 99004 FORMAT (' ', & &'***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT (A VECTOR) TO THE SUBSE2 SUBROUTINE HAS ALL ELEMENTS =',E15.8,' *****') ENDIF ! !-----START POINT----------------------------------------------------- ! 50 continue poin1l = D1min poin1u = D1max IF ( D1min>D1max ) poin1l = D1max IF ( D1min>D1max ) poin1u = D1min ! poin2l = D2min poin2u = D2max IF ( D2min>D2max ) poin2l = D2max IF ( D2min>D2max ) poin2u = D2min k = 0 DO i = 1 , N IF ( D1(i)>=poin1l .AND. D1(i)<=poin1u ) THEN IF ( D2(i)>=poin2l .AND. D2(i)<=poin2u ) THEN k = k + 1 Y(k) = X(i) ENDIF ENDIF ENDDO Ny = k ndel = N - Ny ! ! WRITE OUT A BRIEF SUMMARY ! WRITE (G_IO,99005) 99005 FORMAT (' ') WRITE (G_IO,99006) 99006 FORMAT (' ','OUTPUT FROM THE SUBSE2 SUBROUTINE--') WRITE (G_IO,99007) poin1l , poin1u 99007 FORMAT (' ',7X,'D1 LIMITS (INCLUSIVE)-- ',E15.8,' AND ', E15.8) WRITE (G_IO,99008) poin2l , poin2u 99008 FORMAT (' ',7X,'D2 LIMITS (INCLUSIVE)-- ',E15.8,' AND ', E15.8) WRITE (G_IO,99009) 99009 FORMAT (' ',7X,'ONLY THOSE OBSERVATIONS IN X') WRITE (G_IO,99010) 99010 FORMAT (' ',7X,'WILL BE CARRIED OVER INTO Y') WRITE (G_IO,99011) 99011 FORMAT (' ',7X,'FOR WHICH THE CORRESPONDING ELEMENTS OF ', 'D1 AND D2') WRITE (G_IO,99012) 99012 FORMAT (' ',7X,'ARE SIMULTANEOUSLY WITHIN (INCLUSIVE)') WRITE (G_IO,99013) 99013 FORMAT (' ',7X,'EACH SPECIFIED LIMIT.') WRITE (G_IO,99014) 99014 FORMAT (' ',7X,'NO OBSERVATIONS OUTSIDE OF THIS INTERVAL') WRITE (G_IO,99015) 99015 FORMAT (' ',7X,'HAVE BEEN CARRIED OVER INTO Y.') WRITE (G_IO,99016) N 99016 FORMAT (' ',7X,'THE INPUT NUMBER OF OBSERVATIONS (IN X) IS ', I0) WRITE (G_IO,99017) Ny 99017 FORMAT (' ',7X,'THE OUTPUT NUMBER OF OBSERVATIONS (IN Y) IS ', I0) WRITE (G_IO,99018) ndel 99018 FORMAT (' ',7X,'THE NUMBER OF OBSERVATIONS DELETED IS ', I0) ENDIF ! END SUBROUTINE SUBSE2 !> !!##NAME !! subset(3f) - [M_datapac:VECTOR_OPERATION] extract the elements of a vector !! which fall into a user-specified subset (one subset variable) !! !!##SYNOPSIS !! !! SUBROUTINE SUBSET(X,N,D,Dmin,Dmax,Newn) !! !! REAL(kind=wp) :: D(:), Dmax ,Dmin, X(:) !! INTEGER :: N , Newn !! !!##DESCRIPTION !! !! This subroutine retains all observations in the vector X for which !! the corresponding elements in the vector D are inside the closed !! (inclusive) interval defined by DMIN and DMAX, while deleting all !! observations in X corresponding to elements of D outside of this !! interval. !! !! Thus all observations in X which correspond to elements in D which !! are smaller than DMIN or larger than DMAX are deleted from X. !! !! The use of subset(3f) gives the data analyst the capability !! to easily extract subsets of the data prior to data analysis on !! each subset. !! !!##INPUT ARGUMENTS !! x the vector of !! (unsorted or sorted) observations. !! n the integer number of observations !! in the vector x. !! d the vector !! which 'defines' the various !! possible subsets of x. !! dmin the value !! which defines the lower limit !! (inclusively) of the particular !! subset of interest to be retained. !! dmax the value !! which defines the upper limit !! (inclusively) of the particular !! subset of interest to be retained. !! !!##OUTPUT ARGUMENTS !! !! newn the integer number of observations !! remaining (retained) in x after all !! of the observations in x !! have been deleted which !! correspond to values in the !! vector d outside the !! interval of interest. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_subset !! use M_datapac, only : subset !! implicit none !! ! call subset(x,y) !! end program demo_subset !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the Statistical !! Engineering Division, National Institute of Standards and Technology. !!##MAINTAINER !! John Urban, 2022.05.31 !!##LICENSE !! CC0-1.0 ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE SUBSET(X,N,D,Dmin,Dmax,Newn) REAL(kind=wp) :: D , Dmax , Dmin , hold , pointl , pointu , X INTEGER :: i , k , N , ndel , Newn , newnp1 , nold DIMENSION X(:) DIMENSION D(:) ! ! OUTPUT--THE VECTOR X ! IN WHICH ONLY THOSE VALUES ! HAVE BEEN RETAINED WHICH ! CORRESPOND TO VALUES ! IN THE D VECTOR INSIDE ! (INCLUSIVELY) THE INTERVAL OF ! INTEREST, AND ! THE INTEGER VALUE NEWN ! WHICH GIVES THE NUMBER OF ! OBSERVATIONS RETAINED IN X. ! ALSO, 12 LINES OF SUMMARY INFORMATION ! WILL BE GENERATED INDICATING ! 1) WHAT THE INTERVAL OF INTEREST WAS ! IN THE D VECTOR; ! 2) HOW MANY OBSERVATIONS WERE DELETED; ! 3) WHAT THE OLD (ORIGINAL) SAMPLE SIZE WAS (N); ! 4) WHAT THE NEW SAMPLE SIZE IS (NEWN). ! PRINTING--YES. ! RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE ! OF N FOR THIS SUBROUTINE. ! COMMENT--IN THE END, AFTER THIS SUBROUTINE HAS ! MADE WHATEVER DELETIONS ARE APPROPRIATE, ! THE OUTPUT VECTOR X WILL BE 'PACKED'; ! THAT IS, NO 'HOLES' WILL EXIST IN THE ! VECTOR X--ALL OF THE RETAINED ELEMENTS ! OF X WILL BE PACKED INTO THE FIRST AVAILABLE ! LOCATIONS IN X, WHILE THE REMAINDER ! OF THE N LOCATIONS IN X WILL BE ZERO-FILLED. ! COMMENT--CAUTION IS TO BE EXERCISED IN ! USING THIS SUBROUTINE FOR THE ! FOLLOWING REASON--THE INPUT VECTOR X ! IS IRREVOCABLY ALTERED BY APPLICATION ! OF THIS SUBROUTINE. ALTHOUGH THERE ! MAY BE A CORRESPONDANCE BETWEEN THE ! ELEMENTS OF THE X AND D VECTORS ! BEFORE APPLICATION OF ! THIS SUBROUTINE, THERE WILL ! BE NO CORRESPONDANCE BETWEEN ! X AND D (DUE TO THE PACKING OF ! THE RETAINED ELEMENTS OF X) ! AFTER APPLICATION OF THIS SUBROUTINE. ! TO SUCCESSIVELY EXTRACT EACH POSSIBLE ! SUBSET OF X, IT IS ! RECOMMENDED THAT THE ! ANALYST USE THE SUBSA2 ! SUBROUTINE WHICH LEAVES ! THE ORIGINAL INPUT VECTOR X ! UNALTERED AND OUTPUTS THE ! RETAINED ELEMENTS IN A ! SEPARATE SECOND VECTOR Y. ! COMMENT--IN THE MAIN (CALLING) ROUTINE, IT IS ! PERMISSABLE (IF THE ANALYST SO DESIRES) ! TO USE THE SAME VARIABLE NAME ! IN THE SIXTH ARGUMENT AS USED IN THE SECOND ! ARGUMENT IN THE CALLING SEQUENCE TO THIS ! SUBSET SUBROUTINE--NO CONFLICT WILL RESULT ! IN THE INTERNAL OPERATION OF THE SUBSET ! SUBROUTINE. FOR EXAMPLE, IT IS PERMISSIBLE ! TO HAVE CALL SUBSET(X,N,D,0.5,1.5,N) ! IN WHICH THE VARIABLE NAME N IS USED ! AS BOTH THE SECOND AND SIXTH ARGUMENTS. ! COMMENT--THIS IS ONE OF THE FEW SUBROUTINES IN DATAPAC ! IN WHICH THE INPUT VECTOR X IS ALTERED. ! ORIGINAL VERSION--NOVEMBER 1975. ! UPDATED --FEBRUARY 1976. ! !--------------------------------------------------------------------- ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( N<1 ) THEN WRITE (G_IO,99001) 99001 FORMAT (' ', & &'***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE SUBSET SUBROU& &TINE IS NON-POSITIVE *****') WRITE (G_IO,99002) N 99002 FORMAT (' ','***** THE VALUE OF THE ARGUMENT IS ',I0,' *****') RETURN ELSE IF ( N==1 ) THEN WRITE (G_IO,99003) 99003 FORMAT (' ', & &'***** NON-FATAL DIAGNOSTIC--THE SECOND INPUT ARGUMENT TO THE SUBS& &ET SUBROUTINE HAS THE VALUE 1 *****') ELSE hold = X(1) DO i = 2 , N IF ( X(i)/=hold ) GOTO 50 ENDDO WRITE (G_IO,99004) hold 99004 FORMAT (' ', & &'***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT (A VECTOR) & &TO THE SUBSET SUBROUTINE HAS ALL ELEMENTS =',E15.8,' *****') ENDIF ! !-----START POINT----------------------------------------------------- ! 50 continue pointl = Dmin pointu = Dmax IF ( Dmin>Dmax ) pointl = Dmax IF ( Dmin>Dmax ) pointu = Dmin ! nold = N k = 0 DO i = 1 , nold IF ( D(i)>=pointl .AND. D(i)<=pointu ) THEN k = k + 1 X(k) = X(i) ENDIF ENDDO Newn = k ndel = nold - Newn ! newnp1 = Newn + 1 IF ( newnp1<=nold ) THEN DO i = newnp1 , nold X(i) = 0.0_wp ENDDO ENDIF ! ! WRITE OUT A BRIEF SUMMARY ! WRITE (G_IO,99005) 99005 FORMAT (' ') WRITE (G_IO,99006) 99006 FORMAT (' ','OUTPUT FROM THE SUBSET SUBROUTINE--') WRITE (G_IO,99007) pointl , pointu 99007 FORMAT (' ',7X,'D LIMITS (INCLUSIVE)-- ',E15.8,' AND ', E15.8) WRITE (G_IO,99008) 99008 FORMAT (' ',7X,'ONLY THOSE OBSERVATIONS IN X') WRITE (G_IO,99009) 99009 FORMAT (' ',7X,'WILL BE RETAINED') WRITE (G_IO,99010) 99010 FORMAT (' ',7X,'FOR WHICH THECORRESPONDING ELEMENTS OF D') WRITE (G_IO,99011) 99011 FORMAT (' ',7X,'ARE WITHIN (INCLUSIVE)') WRITE (G_IO,99012) 99012 FORMAT (' ',7X,'THE SPECIFIED LIMITS.') WRITE (G_IO,99013) 99013 FORMAT (' ',7X,'ALL OBSERVATIONS OUTSIDE OF THIS INTERVAL') WRITE (G_IO,99014) 99014 FORMAT (' ',7X,'HAVE BEEN DELETED IN X.') WRITE (G_IO,99015) nold 99015 FORMAT (' ',7X,'THE INPUT NUMBER OF OBSERVATIONS (IN X) IS ', I0) WRITE (G_IO,99016) Newn 99016 FORMAT (' ',7X,'THE OUTPUT NUMBER OF OBSERVATIONS (IN X) IS ', I0) WRITE (G_IO,99017) ndel 99017 FORMAT (' ',7X,'THE NUMBER OF OBSERVATIONS DELETED IS ', I0) ENDIF ! END SUBROUTINE SUBSET !> !!##NAME !! tail(3f) - [M_datapac:ANALYSIS] performs a symmetric distribution !! tail length analysis !! !!##SYNOPSIS !! !! SUBROUTINE TAIL(X,N) !! !! REAL(kind=wp) :: X(:) !! INTEGER :: N !! !!##DESCRIPTION !! TAIL(3f) performs a symmetric distribution tail length analysis on !! the data in the input vector X. !! !! The analysis consists of the following-- !! !! 1. Various test statistics to test !! the specific hypothesis of normality; !! 2. A uniform probability plot !! (a short-tailed distribution); !! 3. A normal probability plot !! (a moderate-tailed distribution); !! 4. A tukey lambda = -0.5 probability plot !! (a moderate-long-tailed distribution); !! 5. A cauchy probability plot !! (a long-tailed distribution); !! 6. A determination of the best-fit !! symmetric distribution !! to the data set from an !! admissible set consisting of !! 43 symmetric distributions. !! !! The admissible set of symmetric distributions considered includes !! the uniform, normal, logistic, double exponential, cauchy, and 37 !! distributions drawn from the the tukey lambda distributional family. !! !! The goodness of fit criterion is the maximum probability plot !! correlation coefficient criterion. !! !! !!##INPUT ARGUMENTS !! !! X The vector of unsorted or sorted) observations. !! !! N The integer number of observations in the vector X. !! The maximum allowable value of N for this subroutine is 3000. !!##OUTPUT !! 6 pages of automatic printout-- !! !! 1. various test statistics for normality; !! 2. a uniform probability plot; !! 3. a normal probability plot; !! 4. a tukey lambda = -0.5 probability plot; !! 5. a cauchy probability plot; !! 6. a determination of the best-fit symmetric distribution to the !! data set. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_tail !! use M_datapac, only : tail, label !! implicit none !! real,allocatable :: x(:) !! integer :: i !! call label('tail') !! x=[(real(i)/10.0,i=1,2000)] !! x=x**3.78-6*x**2.52+9*x**1.26 !! call tail(x,size(x)) !! end program demo_tail !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !! !!##REFERENCE !! * Filliben (1972), 'Techniques for Tail Length Analysis', Proceedings !! of the Eighteenth Conference on the Design of Experiments in Army !! Research and Testing, pages 425-450. !! * Filliben, 'The Percent Point Function', Unpublished Manuscript. !! * Johnson and Kotz (1970), Continuous Univariate Distributions-1, !! pages 250-271. ! ORIGINAL VERSION--JUNE 1972. ! UPDATED --NOVEMBER 1975. ! UPDATED --FEBRUARY 1976. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE TAIL(X,N) REAL(kind=wp) :: X(:) INTEGER :: N REAL(kind=wp) :: a2, a3, a4, aa, ai, al, alamba, am2, am3, am4, an, arg, asub1, asubn, b1, b2, bb, bs, cc, coef REAL(kind=wp) :: coefi, constn, corr, corrmx, cox1xn, dd, del, eandev, eb1, eb2, ecc, ee, egeary, ei, er, ers, ersq, erssq, es, essq REAL(kind=wp) :: ewilks, ex1, ex1xn, exn, exnsq, g, gamma, geary, hold, P, p1, pi, picons, pn, ppfnor, PTEnth, q, rp1, rpn, rs REAL(kind=wp) :: s, sdb1, sdb2, sdcc, sdgear, sdrs, sdwilk, sfp1, sfpn, sum, sum1, sum2, sum3, sum4, varrs, varxn, wilksh, WS REAL(kind=wp) :: xbar REAL(kind=wp) :: xline, Y, YM, Z, zb1, zb2, zcc, zgeary, zrs, zwilks INTEGER :: i, icount, idis, idis2, idismx, ievodd, imax, imin, irev, iupper, mx, nhalf, nhalfp, nm1, numdis CHARACTER(len=4) :: iflag1 CHARACTER(len=4) :: iflag2 CHARACTER(len=4) :: iflag3 CHARACTER(len=4) :: iline1 CHARACTER(len=4) :: iline2 ! CHARACTER(len=4) :: alpham CHARACTER(len=4) :: alphaa CHARACTER(len=4) :: blank CHARACTER(len=4) :: hyphen CHARACTER(len=4) :: alphai CHARACTER(len=4) :: alphax character(len=256) :: message integer :: ios ! DIMENSION Y(3000) , Z(3000) , YM(3000) DIMENSION P(3000) , PTEnth(3000) DIMENSION corr(50) , iflag1(50) , iflag2(50) , iflag3(50) DIMENSION iline1(130) , iline2(130) DIMENSION xline(13) COMMON /BLOCK2_real32/ WS(15000) EQUIVALENCE (Y(1),WS(1)) EQUIVALENCE (Z(1),WS(3001)) EQUIVALENCE (YM(1),WS(6001)) EQUIVALENCE (P(1),WS(9001)) EQUIVALENCE (PTEnth(1),WS(12001)) ! DATA alpham , alphaa/'M' , 'A'/ DATA blank , hyphen , alphai , alphax/' ' , '-' , 'I' , 'X'/ DATA picons/3.14159265358979_wp/ DATA constn/.3989422804_wp/ ! iupper = 3000 ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( N<1 .OR. N>iupper ) THEN WRITE (G_IO,99001) iupper 99001 FORMAT (' ***** FATAL ERROR--The second input argument to TAIL(3f) is outside the allowable (1,',I0,& & ') INTERVAL *****') WRITE (G_IO,99002) N 99002 FORMAT (' ','***** The value of the argument is ',I0,' *****') RETURN ELSE IF ( N==1 ) THEN WRITE (G_IO,99003) 99003 FORMAT (' ***** NON-FATAL DIAGNOSTIC--The second input argument to TAIL(3f) has the value 1 *****') RETURN ELSE hold = X(1) DO i = 2 , N IF ( X(i)/=hold ) GOTO 50 ENDDO WRITE (G_IO,99004) hold 99004 FORMAT (' ***** NON-FATAL DIAGNOSTIC--The first input argument (a vector) to TAIL(3f) has all elements = ', & & E15.8,' *****') RETURN ENDIF ! !-----START POINT----------------------------------------------------- ! 50 an = N ! ! COMPUTE THE SAMPLE MEAN ! sum = 0.0_wp DO i = 1 , N sum = sum + X(i) ENDDO xbar = sum/an ! ! COMPUTE S, BIASED S, B1, AND B2 ! sum2 = 0.0_wp sum3 = 0.0_wp sum4 = 0.0_wp DO i = 1 , N del = X(i) - xbar a2 = del*del a3 = del*a2 a4 = a2*a2 sum2 = sum2 + a2 sum3 = sum3 + a3 sum4 = sum4 + a4 ENDDO am2 = sum2/an am3 = sum3/an am4 = sum4/an s = SQRT(sum2/(an-1.0_wp)) bs = SQRT(am2) b1 = am3/(bs**3) b2 = am4/(bs**4) ! ! COMPUTE THE EXPECTED VALUE AND STANDARD DEVIATION OF B1 AND B2 ! UNDER THE NORMALITY ASSUMPTION ! REFERENCE--CRAMER, page 386 ! eb1 = 0.0_wp sdb1 = 6.0_wp*(an-2.0_wp)/((an+1.0_wp)*(an+3.0_wp)) sdb1 = SQRT(sdb1) zb1 = (b1-eb1)/sdb1 eb2 = 3.0_wp - 6.0_wp/(an+1.0_wp) sdb2 = 24.0_wp*an*(an-2.0_wp)*(an-3.0_wp) / ((an+1.0_wp)*(an+1.0_wp)*(an+3.0_wp)*(an+5.0_wp)) zb2 = (b2-eb2)/sdb2 ! ! COMPUTE GEARY'S STATISTIC ! sum = 0.0_wp DO i = 1 , N sum = sum + ABS(X(i)-xbar) ENDDO eandev = sum/an geary = eandev/bs ! ! COMPUTE THE EXPECTED VALUE AND STANDARD DEVIATION ! OF GEARY'S STATISTIC UNDER THE NORMALITY ASSUMPTION ! REFERENCE--BIOMETRIKA, 1936, page 296 ! aa = SQRT(2.0_wp/picons) bb = SQRT(2.0_wp/(an-1.0)) IF ( N>=100 ) cc = SQRT(an/2.0_wp) * (1.0_wp-(1.0_wp/(8.0_wp*an/2.0_wp))+(1.0_wp/(128.0_wp*an*an/ 4.0_wp))) IF ( N<100 ) THEN coef = 1.0 imax = N - 1 ievodd = N - 2*(N/2) imin = 2 IF ( ievodd==0 ) imin = 3 IF ( imin<=imax ) THEN DO i = imin , imax , 2 ai = i coef = ((ai-1.0_wp)/ai)*coef ENDDO ENDIF coef = coef*(an-1.0_wp) IF ( ievodd==0 ) THEN coef = coef/SQRT(picons) ELSE coef = coef*(SQRT(picons)/2.0_wp) ENDIF cc = coef ENDIF egeary = aa/(bb*cc) dd = (2.0_wp/picons)*SQRT(an*(an-2.0_wp)) arg = 1.0_wp/(an-1.0_wp) arg = arg/SQRT(1.0_wp-arg*arg) ee = ATAN(arg) sdgear = (1.0_wp/an)*(1.0_wp+dd+ee) sdgear = sdgear - egeary*egeary sdgear = SQRT(sdgear) zgeary = (geary-egeary)/sdgear ! ! SORT THE DATA, ! THEN COMPUTE RANGE/S. ! CALL SORT(X,N,Y) rs = (Y(N)-Y(1))/s ! ! COMPUTE THE EXPECTED VALUE AND STANDARD DEVIATION OF THE RANGE/S ! UNDER THE NORMALITY ASSUMPTION ! REFERENCE--BIOMETRIKA, 1954, page 483 ! g = .33000598_wp + ((an-2.0_wp)**.16_wp)/41.785_wp pn = (an-g)/(an-2.0_wp*g+1.0_wp) p1 = 1.0_wp - pn CALL NORPPF(pn,rpn) CALL NORPPF(p1,rp1) exn = rpn ex1 = rp1 er = exn - ex1 CALL NORPPF(p1,ppfnor) sfp1 = 1.0_wp/(constn*EXP(-(ppfnor*ppfnor)/2.0_wp)) CALL NORPPF(pn,ppfnor) sfpn = 1.0_wp/(constn*EXP(-(ppfnor*ppfnor)/2.0_wp)) varxn = pn*(1.0_wp-pn)*sfpn*sfpn/(an+2.0_wp) exnsq = varxn + exn*exn cox1xn = p1*p1*sfp1*sfpn/(an+2.0_wp) ex1xn = cox1xn + ex1*exn ersq = 2.0_wp*(exnsq-ex1xn) es = bb*cc essq = 1.0_wp ers = er/es erssq = ersq/essq varrs = erssq - ers*ers sdrs = SQRT(varrs) zrs = (rs-ers)/sdrs ! ! COMPUTE THE WILK-SHAPIRO STATISTIC ! al = LOG10(an) gamma = .327511_wp + .058212_wp*al - .009776_wp*al*al sum = 0.0_wp IF ( N<=20 ) arg = N IF ( N>20 ) arg = N + 1 asubn = SQRT((1.0_wp+(1.0_wp/(4.0_wp*arg)))/SQRT(arg)) asub1 = -asubn sum = sum + asub1*Y(1) + asubn*Y(N) IF ( N>2 ) THEN nm1 = N - 1 DO i = 2 , nm1 ai = i pi = (ai-gamma)/(an-2.0_wp*gamma+1.0_wp) CALL NORPPF(pi,ei) coefi = 2.0_wp*ei/SQRT(-2.722_wp+4.083_wp*an) sum = sum + coefi*Y(i) ENDDO ENDIF wilksh = sum*sum/(an*bs*bs) ! ! COMPUTE THE EXPECTED VALUE AND STANDARD DEVIATION OF THE WILK-SHAPIRO ! STATISTIC UNDER THE NORMALITY ASSUMPTION ! REFERENCE--JJF APPROXIMATION TO MOMENTS ON page 601 OF BIOMETRIKA (1965) ! IF ( N==3 ) ewilks = .9135_wp IF ( N==4 ) ewilks = .9012_wp IF ( N>=5 ) ewilks = .9026_wp + (an-5.0_wp)/(44.608_wp+13.593_wp*SQRT(an)+10.267_wp*an) IF ( N==3 ) sdwilk = .0755_wp IF ( N==4 ) sdwilk = .0719_wp IF ( N>=5 ) sdwilk = .0670_wp + (an-5.0_wp)/(-42.368_wp-5.026_wp*SQRT(an)-14.925_wp*an) zwilks = (wilksh-ewilks)/sdwilk ! ! COMPUTE THE CORRELATION COEFFICIENT BETWEEN THE ORDERED OBSERVATIONS ! AND THE ORDER STATISIC MEDIANS FROM 44 DIFFERENT SYMMETRIC DISTRIBUTIONS ! numdis = 44 nhalf = N/2 nhalfp = nhalf + 1 ievodd = N - 2*(N/2) CALL UNIMED(N,Z) DO i = 1 , N PTEnth(i) = Z(i)**(0.1_wp) ENDDO DO idis = 1 , numdis IF ( idis==20 ) THEN DO i = 1 , nhalf irev = N - i + 1 CALL NORPPF(Z(i),YM(i)) YM(irev) = -YM(i) ENDDO IF ( ievodd==1 ) YM(nhalfp) = 0.0_wp ELSEIF ( idis==22 ) THEN DO i = 1 , nhalf irev = N - i + 1 YM(i) = LOG(Z(i)/(1.0_wp-Z(i))) YM(irev) = -YM(i) ENDDO IF ( ievodd==1 ) YM(nhalfp) = 0.0_wp ELSEIF ( idis==23 ) THEN DO i = 1 , nhalf irev = N - i + 1 IF ( Z(i)<=0.5_wp ) YM(i) = LOG(2.0_wp*Z(i)) IF ( Z(i)>0.5_wp ) YM(i) = -LOG(2.0_wp*(1.0_wp-Z(i))) YM(irev) = -YM(i) ENDDO IF ( ievodd==1 ) YM(nhalfp) = 0.0_wp ELSEIF ( idis==33 ) THEN DO i = 1 , nhalf irev = N - i + 1 arg = picons*Z(i) YM(i) = -COS(arg)/SIN(arg) YM(irev) = -YM(i) ENDDO IF ( ievodd==1 ) YM(nhalfp) = 0.0_wp ELSE IF ( idis<20 ) idis2 = idis IF ( idis==21 ) idis2 = idis - 1 IF ( 23<idis .AND. idis<33 ) idis2 = idis - 2 IF ( 33<idis ) idis2 = idis - 3 alamba = -(0.1_wp)*FLOAT(idis2) + 2.1_wp IF ( idis==1 ) THEN DO i = 1 , nhalf irev = N - i + 1 P(i) = Z(i)*Z(i) P(irev) = Z(irev)*Z(irev) YM(i) = (P(i)-P(irev))/alamba YM(irev) = -YM(i) ENDDO IF ( ievodd==1 ) YM(nhalfp) = 0.0_wp ELSEIF ( idis==11 ) THEN DO i = 1 , nhalf irev = N - i + 1 P(i) = Z(i) P(irev) = Z(irev) YM(i) = (P(i)-P(irev))/alamba YM(irev) = -YM(i) ENDDO IF ( ievodd==1 ) YM(nhalfp) = 0.0_wp ELSEIF ( idis==24 ) THEN DO i = 1 , nhalf irev = N - i + 1 P(i) = Z(i)**(-0.1_wp) P(irev) = Z(irev)**(-0.1_wp) YM(i) = (P(i)-P(irev))/alamba YM(irev) = -YM(i) ENDDO IF ( ievodd==1 ) YM(nhalfp) = 0.0_wp ELSEIF ( idis==34 ) THEN DO i = 1 , nhalf P(irev) = 1.0_wp/Z(irev) P(i) = 1.0_wp/Z(i) irev = N - i + 1 YM(i) = (P(i)-P(irev))/alamba YM(irev) = -YM(i) ENDDO IF ( ievodd==1 ) YM(nhalfp) = 0.0_wp ELSEIF ( idis==44 ) THEN DO i = 1 , nhalf irev = N - i + 1 P(i) = 1.0_wp/(Z(i)*Z(i)) P(irev) = 1.0_wp/(Z(irev)*Z(irev)) YM(i) = (P(i)-P(irev))/alamba YM(irev) = -YM(i) ENDDO IF ( ievodd==1 ) YM(nhalfp) = 0.0_wp ELSE DO i = 1 , nhalf irev = N - i + 1 P(i) = P(i)/PTEnth(i) P(irev) = P(irev)/PTEnth(irev) YM(i) = (P(i)-P(irev))/alamba YM(irev) = -YM(i) ENDDO IF ( ievodd==1 ) YM(nhalfp) = 0.0_wp ENDIF ENDIF sum1 = 0.0_wp sum2 = 0.0_wp DO i = 1 , N sum1 = sum1 + Y(i)*YM(i) sum2 = sum2 + YM(i)*YM(i) ENDDO sum2 = SQRT(sum2) sum3 = s*SQRT(an-1.0_wp) corr(idis) = sum1/(sum2*sum3) ENDDO ! ! DETERMINE THAT DISTRIBUTION WITH THE MAXIMUM PROB PLOT CORR COEFFICIENT ! idismx = 1 corrmx = corr(1) DO idis = 1 , numdis IF ( corr(idis)>corrmx ) idismx = idis IF ( corr(idis)>corrmx ) corrmx = corr(idis) ENDDO DO idis = 1 , numdis iflag1(idis) = blank iflag2(idis) = blank iflag3(idis) = blank IF ( idis==idismx ) THEN iflag1(idis) = alpham iflag2(idis) = alphaa iflag3(idis) = alphax ENDIF ENDDO cc = corr(20) ! ! COMPUTE THE EXPECTED VALUE AND STANDARD DEVIATION OF THE PROBABILITY PLOT ! CORRELATION COEFFICIENT UNDER THE NORMALITY ASSUMPTION ! REFERENCE--JJF UNPUBLISHED MANUSCRIPT ! IF ( N==2 ) ecc = 1.0_wp IF ( N==3 ) ecc = .95492958_wp IF ( N>=4 ) ecc = .94947355_wp + (an-4.0_wp)/(196.815_wp-2.9418_wp*SQRT(an)+19.7916_wp*an) IF ( N==2 ) sdcc = 99999999.9999_wp IF ( N==3 ) sdcc = .04007697_wp IF ( N>=4 ) sdcc = .039492_wp + (an-4.0_wp)/(-127.0_wp-25.3_wp*an) zcc = (cc-ecc)/sdcc ! ! WRITE OUT THE NORMAL TAIL LENGTH STATISTICS page ! WRITE (G_IO,99044) WRITE (G_IO,99005) ! 99005 FORMAT (' ',48X,'TAIL LENGTH ANALYSIS') WRITE (G_IO,99045) WRITE (G_IO,99006) N 99006 FORMAT (' ',46X,'(THE SAMPLE SIZE N = ',I0,')') WRITE (G_IO,99007) xbar 99007 FORMAT (' ',40X,'(THE SAMPLE MEAN = ',E15.8,')') WRITE (G_IO,99008) s 99008 FORMAT (' ',35X,'(THE SAMPLE STANDARD DEVIATION = ',E15.8,')') WRITE (G_IO,99045) WRITE (G_IO,99009) 99009 FORMAT (' ',35X,'REFERENCE--SHAPIRO, WILK, AND CHEN, JASA, 1968, pages 1343-1372') WRITE (G_IO,99010) 99010 FORMAT (' ',35X,'REFERENCE--CRAMER, pages 386-387') WRITE (G_IO,99011) 99011 FORMAT (' ',35X,'REFERENCE--GEARY, BIOMETRIKA, 1947, pages 209-242') WRITE (G_IO,99012) 99012 FORMAT (' ',35X,'REFERENCE--BIOMETRIKA TABLES, VOLUME 1, pages 67-69, 59-60, 207-208, AND 200') WRITE (G_IO,99013) 99013 FORMAT (' ',35X,'REFERENCE--SHAPIRO AND WILK, BIOMETRIKA, 1965, pages 591-611') DO i = 1 , 6 WRITE (G_IO,99045) ENDDO WRITE (G_IO,99014) 99014 FORMAT (' ',49X,'TAIL LENGTH STATISTICS') WRITE (G_IO,99015) 99015 FORMAT (' ',5X,& & 'THE EXPECTED VALUE AND STANDARD DEVIATION OF STATISTICS ON THIS page ARE BASED ON THE NORMALITY ASSUMPTION') WRITE (G_IO,99045) WRITE (G_IO,99045) WRITE (G_IO,99016) 99016 FORMAT (' ',& & 'FORM OF STATISTIC VALUE OF STAT EXP(STAT) SD(STAT) (STAT-EXP(STAT))/SD(STAT) TABLE REFERENCE') WRITE (G_IO,99045) WRITE (G_IO,99017) b1 , eb1 , sdb1 , zb1 99017 FORMAT (' ','STANDARDIZED THIRD CENTRAL MOMENT ',F10.5,6X,F10.5,2X,F10.5,9X,F10.5,13X,'BIOMETRIKA TABLES') WRITE (G_IO,99018) 99018 FORMAT (' ',111X,'VOL. 1, page 207') WRITE (G_IO,99019) b2 , eb2 , sdb2 , zb2 99019 FORMAT (' ','STANDARDIZED FOURTH CENTRAL MOMENT ',F10.5,6X,F10.5,2X,F10.5,9X,F10.5,13X,'BIOMETRIKA TABLES') WRITE (G_IO,99020) 99020 FORMAT (' ',111X,'VOL. 1, page 208') WRITE (G_IO,99021) geary , egeary , sdgear , zgeary 99021 FORMAT (' ','GEARY STATISTIC (MEAN DEVIATION/S) ',F10.5,6X,F10.5,2X,F10.5,9X,F10.5,13X,'BIOMETRIKA TABLES') WRITE (G_IO,99022) 99022 FORMAT (' ',111X,'VOL. 1, page 207') WRITE (G_IO,99023) rs , ers , sdrs , zrs 99023 FORMAT (' ','RANGE/S ',F10.5,6X,F10.5,2X,F10.5,9X,F10.5,13X,'BIOMETRIKA TABLES') WRITE (G_IO,99024) 99024 FORMAT (' ',111X,'VOL. 1, page 200') WRITE (G_IO,99025) wilksh , ewilks , sdwilk , zwilks 99025 FORMAT (' ','WILK-SHAPIRO STATISTIC (BLUE FOR SCALE/S)',F10.5,6X,F10.5,2X,F10.5,9X,F10.5,13X,'BIOMETRIKA (1965)') WRITE (G_IO,99026) 99026 FORMAT (' ',111X,'page 605') WRITE (G_IO,99027) cc , ecc , sdcc , zcc 99027 FORMAT (' ','PROBABILITY PLOT CORRELATION COEFFICIENT ',F10.5, & & 6X,F10.5,2X,F10.5,9X,F10.5,13X,'UNPUBLISHED JJF') WRITE (G_IO,99028) 99028 FORMAT (' ',111X,'MANUSCRIPT') ! ! COMPUTE THE LINE PLOT WHICH SHOWS THE DISTRIBUTION OF THE OBSERVED ! VALUES IN TERMS OF MULTIPLES OF SAMPLE STANDARD DEVIATIONS AWAY FROM ! THE SAMPLE MEAN ! DO i = 1 , 130 iline1(i) = blank iline2(i) = blank ENDDO icount = 0 DO i = 1 , N mx = 10.0_wp*(((X(i)-xbar)/s)+6.0_wp) + 0.5_wp mx = mx + 7 IF ( mx<7 .OR. mx>127 ) icount = icount + 1 IF ( mx>=7 .AND. mx<=127 ) iline1(mx) = alphax ENDDO DO i = 7 , 127 iline2(i) = hyphen ENDDO DO i = 7 , 127 , 10 iline2(i) = alphai ENDDO xline(7) = xbar DO i = 1 , 6 irev = 13 - i + 1 ai = i xline(i) = xbar - (7.0_wp-ai)*s xline(irev) = xbar + (7.0_wp-ai)*s ENDDO ! ! WRITE OUT THE LINE PLOT SHOWING THE DEVIATIONS OF THE OBSERVATIONS ! ABOUT THE SAMPLE MEAN IN TERMS OF MULTIPLES OF THE SAMPLE STANDARD ! DEVIATION ! DO i = 1 , 8 WRITE (G_IO,99045) ENDDO WRITE (G_IO,99029) 99029 FORMAT (& & ' LINE PLOT SHOWING THE DISTRIBUTION OF THE OBSERVATIONS ABOUT THE SAMPLE MEAN ',& & 'IN TERMS OF MULTIPLES OF THE SAMPLE STANDARD DEVIATION') WRITE (G_IO,99045) WRITE (G_IO,99045) WRITE (G_IO,99042) (iline1(i),i=1,130) WRITE (G_IO,99042) (iline2(i),i=1,130) WRITE (G_IO,99030) 99030 FORMAT (' ', & &' -6 -5 -4 -3 -2 -1 & & 0 1 2 3 4 5 6') WRITE (G_IO,99031,iostat=ios,iomsg=message) (xline(i),i=1,13) 99031 FORMAT (' ',13F10.4) if(ios.ne.0)write(G_IO,'(A)')message(:len_trim(message)) WRITE (G_IO,99045) WRITE (G_IO,99032) icount 99032 FORMAT (' ',10X,I0, & &' OBSERVATIONS WERE IN EXCESS OF 6 SAMPLE STANDARD DEVIATIONS FROM& & THE SAMPLE MEAN AND SO WERE NOT PLOTTED') ! ! GENERATE UNIFORM, NORMAL, LAMBDA = -0.5, AND CAUCHY PROBABILITY PLOTS ! nhalf = (N/2) + 1 CALL PLOT(Y,Z,N) WRITE (G_IO,99033) N 99033 FORMAT (' ',35X,'UNIFORM PROBABILITY PLOT (THE SAMPLE SIZE N = ',I0,')') WRITE (G_IO,99043) corr(11) DO i = 1 , nhalf irev = N - i + 1 CALL NORPPF(Z(i),YM(i)) YM(irev) = -YM(i) ENDDO CALL PLOT(Y,YM,N) WRITE (G_IO,99034) N 99034 FORMAT (' ',35X,& & 'NORMAL PROBABILITY PLOT (THE SAMPLE SIZE N = ',I0, & & ')') WRITE (G_IO,99043) corr(20) alamba = -0.5_wp DO i = 1 , nhalf irev = N - i + 1 q = Z(i) YM(i) = (q**alamba-(1.0_wp-q)**alamba)/alamba YM(irev) = -YM(i) ENDDO CALL PLOT(Y,YM,N) WRITE (G_IO,99035) alamba , N 99035 FORMAT (' ',35X,'LAMBDA = ',F4.1,' PROBABILITY PLOT (THE SAMPLE SIZE N = ',I0,')') WRITE (G_IO,99043) corr(28) DO i = 1 , nhalf irev = N - i + 1 arg = picons*Z(i) YM(i) = -COS(arg)/SIN(arg) YM(irev) = -YM(i) ENDDO CALL PLOT(Y,YM,N) WRITE (G_IO,99036) N 99036 FORMAT (' ',35X,'CAUCHY PROBABILITY PLOT (THE SAMPLE SIZE N = ',I0,')') WRITE (G_IO,99043) corr(33) ! ! WRITE OUT THE PROBABILITY PLOT CORRELATION COEFFICIENT page ! WRITE (G_IO,99044) DO idis = 1 , numdis IF ( idis==20 ) THEN WRITE (G_IO,99037) N , corr(idis) , iflag1(idis) , iflag2(idis) , iflag3(idis) 99037 FORMAT (' ','THE CORRELATION BETWEEN THE ',I0, & &' ORDERED OBS. AND THE ORDER STAT. MEDIANS FROM THE NORMAL DISTRIBUTION IS ',F8.5,1X,3A1) ELSEIF ( idis==22 ) THEN WRITE (G_IO,99038) N , corr(idis) , iflag1(idis) , iflag2(idis) , iflag3(idis) 99038 FORMAT (' ','THE CORRELATION BETWEEN THE ',I0, & &' ORDERED OBS. AND THE ORDER STAT. MEDIANS FROM THE LOGISTIC DIST. IS ',F8.5,1X,3A1) ELSEIF ( idis==23 ) THEN WRITE (G_IO,99039) N , corr(idis) , iflag1(idis) , iflag2(idis) , iflag3(idis) 99039 FORMAT (' THE CORRELATION BETWEEN THE ',I0, & & ' ORDERED OBS. AND THE ORDER STAT. MEDIANS FROM THE DOUBLE EXP. DIST. IS ',F8.5,1X,3A1) ELSEIF ( idis==33 ) THEN WRITE (G_IO,99040) N , corr(idis) , iflag1(idis) , iflag2(idis) , iflag3(idis) 99040 FORMAT (' ','THE CORRELATION BETWEEN THE ',I0, & &' ORDERED OBS. AND THE ORDER STAT. MEDIANS FROM THE CAUCHY DISTRIBUTION IS ',F8.5,1X,3A1) ELSE IF ( idis<20 ) idis2 = idis IF ( idis==21 ) idis2 = idis - 1 IF ( 23<idis .AND. idis<33 ) idis2 = idis - 2 IF ( 33<idis ) idis2 = idis - 3 alamba = -(0.1)*FLOAT(idis2) + 2.1 WRITE (G_IO,99041) N, alamba, corr(idis), iflag1(idis), iflag2(idis), iflag3(idis) 99041 FORMAT (' ','THE CORRELATION BETWEEN THE ',I0, & & ' ORDERED OBS. AND THE ORDER STAT. MEDIANS FROM THE LAMBDA = '& & ,F4.1,' DIST. IS ',F8.5,1X,3A1) ENDIF ENDDO ENDIF 99042 FORMAT (' ',130A1) 99043 FORMAT (' ',34X,'(PROBABILITY PLOT CORRELATION COEFFICIENT = ', & & F8.5,')') 99044 FORMAT ('1') 99045 FORMAT (' ') ! END SUBROUTINE TAIL !> !!##NAME !! tcdf(3f) - [M_datapac:CUMULATIVE_DISTRIBUTION] computes the cumulative !! distribution function value for student's t distribution with integer !! degrees of freedom NU. !! !!##SYNOPSIS !! !! SUBROUTINE TCDF(X,Nu,Cdf) !! !! REAL(kind=wp) :: X !! INTEGER :: Nu !! REAL(kind=wp) :: Cdf !! !!##DESCRIPTION !! TCDF(3f) computes the cumulative distribution function value for !! Student's T distribution with integer degrees of freedom parameter !! = NU. This distribution is defined for all X. !! !! The probability density function is given in the references below. !! !! Note the mode of internal operations is double precision. !! !!##INPUT ARGUMENTS !! !! X The value at which the cumulative distribution function is to !! be evaluated. X should be non-negative. !! !! NU The integer number of degrees of freedom. NU should be positive. !! !!##OUTPUT ARGUMENTS !! !! CDF The cumulative distribution function value for the Student's !! T distribution !! !!##EXAMPLES !! !! Sample program: !! !! program demo_tcdf !! !@(#) line plotter graph of cumulative distribution function !! use M_datapac, only : tcdf, plott, label !! implicit none !! real,allocatable :: x(:), y(:) !! integer :: nu !! integer :: i !! call label('tcdf') !! x=[(real(i)/20.0,i=0,100,1)] !! if(allocated(y))deallocate(y) !! allocate(y(size(x))) !! nu=12 !! do i=1,size(x) !! call tcdf(X(i),Nu,y(i)) !! enddo !! call plott(x,y,size(x)) !! end program demo_tcdf !! !! Results: !! !! The following is a plot of Y(I) (vertically) versus X(I) (horizontally) !! I-----------I-----------I-----------I-----------I !! 0.5000000E+01 - X !! 0.4791667E+01 I X !! 0.4583333E+01 I X !! 0.4375000E+01 I X !! 0.4166667E+01 I X !! 0.3958333E+01 I X !! 0.3750000E+01 - X !! 0.3541667E+01 I X !! 0.3333333E+01 I X !! 0.3125000E+01 I X !! 0.2916667E+01 I X !! 0.2708333E+01 I X !! 0.2500000E+01 - XX !! 0.2291667E+01 I X !! 0.2083333E+01 I X !! 0.1875000E+01 I XX !! 0.1666667E+01 I XX !! 0.1458333E+01 I XXX !! 0.1250000E+01 - XXXX !! 0.1041667E+01 I XXXX !! 0.8333335E+00 I XXXX !! 0.6250000E+00 I XX XX !! 0.4166670E+00 I X XX X !! 0.2083335E+00 I XX X X !! 0.0000000E+00 - X X X !! I-----------I-----------I-----------I-----------I !! 0.5000E+00 0.6250E+00 0.7499E+00 0.8749E+00 0.9998E+00 !! !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !! !!##REFERENCES !! !! * National Bureau of Standards Applied Mathematics Series 55, 1964, !! page 948, Formulae 26.7.3 and 26.7.4. !! * Johnson and Kotz, Continuous Univariate Distributions--2, 1970, !! pages 94-129. !! * Federighi, Extended Tables of the Percentage Points Of Student'S !! T-Distribution, Journal of the American Statistical Association, 1959, !! pages 683-688. !! * Owen, Handbook of Statistical Tables, 1962, pages 27-30. !! * Pearson and Hartley, Biometrika Tables for Statisticians, Volume 1, !! 1954, pages 132-134. ! ORIGINAL VERSION--JUNE 1972. ! UPDATED --MAY 1974. ! UPDATED --SEPTEMBER 1975. ! UPDATED --NOVEMBER 1975. ! UPDATED --OCTOBER 1976. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE TCDF(X,Nu,Cdf) REAL(kind=wp) :: X INTEGER :: Nu REAL(kind=wp) :: Cdf REAL(kind=wp) :: anu , cdfn , sd , z INTEGER :: i , ievodd , imax , imin , nucut DOUBLE PRECISION dx , dnu , pi , c , csq , s , sum , term , ai DOUBLE PRECISION DSQRT , DATAN DOUBLE PRECISION dconst DOUBLE PRECISION term1 , term2 , term3 DOUBLE PRECISION dcdfn DOUBLE PRECISION dcdf DOUBLE PRECISION b11 DOUBLE PRECISION b21 , b22 , b23 , b24 , b25 DOUBLE PRECISION b31 , b32 , b33 , b34 , b35 , b36 , b37 DOUBLE PRECISION d1 , d3 , d5 , d7 , d9 , d11 DATA nucut/1000/ DATA pi/3.14159265358979D0/ DATA dconst/0.3989422804D0/ DATA b11/0.25D0/ DATA b21/0.01041666666667D0/ DATA b22 , b23 , b24 , b25/3.0D0 , -7.0D0 , -5.0D0 , -3.0D0/ DATA b31/0.00260416666667D0/ DATA b32 , b33 , b34 , b35 , b36 , b37/1.0D0 , -11.0D0 , 14.0D0 , & & 6.0D0 , -3.0D0 , -15.0D0/ ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( Nu<=0 ) THEN WRITE (G_IO,99001) 99001 FORMAT (' ***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO TCDF(3f) IS NON-POSITIVE *****') WRITE (G_IO,99002) Nu 99002 FORMAT (' ***** THE VALUE OF THE ARGUMENT IS ',I0,' *****') Cdf = 0.0_wp RETURN ELSE ! !-----START POINT----------------------------------------------------- ! dx = X anu = Nu dnu = Nu ! ! IF NU IS 3 THROUGH 9 AND X IS MORE THAN 3000 STANDARD DEVIATIONS BELOW THE MEAN, SET CDF = 0.0 AND RETURN. ! IF NU IS 10 OR LARGER AND X IS MORE THAN 150 STANDARD DEVIATIONS BELOW THE MEAN, SET CDF = 0.0 AND RETURN. ! IF NU IS 3 THROUGH 9 AND X IS MORE THAN 3000 STANDARD DEVIATIONS ABOVE THE MEAN, SET CDF = 1.0 AND RETURN. ! IF NU IS 10 OR LARGER AND X IS MORE THAN 150 STANDARD DEVIATIONS ABOVE THE MEAN, SET CDF = 1.0 AND RETURN. ! IF ( Nu<=2 ) GOTO 100 sd = SQRT(anu/(anu-2.0_wp)) z = X/sd IF ( Nu>=10 .OR. z>=-3000.0_wp ) THEN IF ( Nu<10 .OR. z>=-150.0_wp ) THEN IF ( Nu<10 .AND. z>3000.0_wp ) GOTO 50 IF ( Nu<10 .OR. z<=150.0_wp ) GOTO 100 GOTO 50 ENDIF ENDIF Cdf = 0.0_wp RETURN 50 continue Cdf = 1.0_wp RETURN ENDIF ! ! DISTINGUISH BETWEEN THE SMALL AND MODERATE ! DEGREES OF FREEDOM CASE VERSUS THE ! LARGE DEGREES OF FREEDOM CASE ! 100 continue IF ( Nu<nucut ) THEN ! ! TREAT THE SMALL AND MODERATE DEGREES OF FREEDOM CASE ! METHOD UTILIZED--EXACT FINITE SUM ! (SEE AMS 55, page 948, FORMULAE 26.7.3 AND 26.7.4). ! c = DSQRT(dnu/(dx*dx+dnu)) csq = dnu/(dx*dx+dnu) s = dx/DSQRT(dx*dx+dnu) imax = Nu - 2 ievodd = Nu - 2*(Nu/2) IF ( ievodd==0 ) THEN ! sum = 1.0D0 term = 1.0D0 imin = 2 ELSE ! sum = c IF ( Nu==1 ) sum = 0.0D0 term = c imin = 3 ENDIF ! IF ( imin<=imax ) THEN DO i = imin , imax , 2 ai = i term = term*((ai-1.0D0)/ai)*csq sum = sum + term ENDDO ENDIF ! sum = sum*s IF ( ievodd/=0 ) sum = (2.0D0/pi)*(DATAN(dx/DSQRT(dnu))+sum) Cdf = 0.5D0 + sum/2.0D0 RETURN ELSE ! ! TREAT THE LARGE DEGREES OF FREEDOM CASE. ! METHOD UTILIZED--TRUNCATED ASYMPTOTIC EXPANSION ! (SEE JOHNSON AND KOTZ, VOLUME 2, page 102, FORMULA 10; ! SEE FEDERIGHI, page 687). ! CALL NORCDF(X,cdfn) dcdfn = cdfn d1 = dx d3 = dx**3 d5 = dx**5 d7 = dx**7 d9 = dx**9 d11 = dx**11 term1 = b11*(d3+d1)/dnu term2 = b21*(b22*d7+b23*d5+b24*d3+b25*d1)/(dnu**2) term3 = b31*(b32*d11+b33*d9+b34*d7+b35*d5+b36*d3+b37*d1)/(dnu**3) dcdf = term1 + term2 + term3 dcdf = dcdfn - (dconst*(DEXP(-dx*dx/2.0D0)))*dcdf Cdf = dcdf ENDIF ! END SUBROUTINE TCDF !> !!##NAME !! time(3f) - [M_datapac:ANALYSIS] perform a time series analysis !! (autocorrelation plot, a test for white noise, a "pilot" spectrum, !! and 4 other estimated spectra based on differing bandwidth) !! !!##SYNOPSIS !! !! SUBROUTINE TIME(X,N) !! !!##DESCRIPTION !! time(3f) performs a time series analysis on the data in the input !! vector x. !! !! the analysis consists of the following-- !! !! 1. a plot of autocorrelation versus lag number; !! 2. a test for white noise (assuming normality); !! 3. a 'pilot' spectrum; and !! 4. 4 other estimated spectra--each based !! on a differing bandwidth. !! !! in order that the results of the time series analysis be valid and !! properly interpreted, the input data in x should be equi-spaced in time !! (or whatever variable corresponds to time). !! !! the horizontal axis of the spectra produced by time(3f) is frequency. !! !! this frequency is measured in units of cycles per 'data point' or, !! more precisely, in cycles per unit time where 'unit time' is defined !! as the elapsed time between adjacent observations. !! !! the range of the frequency axis is 0.0 to 0.5. !! !!##OPTIONS !! X description of parameter !! Y description of parameter !! !!##EXAMPLES !! !! Sample program: !! !! program demo_time !! use M_datapac, only : time !! implicit none !! ! call time(x,y) !! end program demo_time !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !! !!##REFERENCES !! * Jenkins and Watts, especially page 290. ! ORIGINAL VERSION--JUNE 1972. ! UPDATED --NOVEMBER 1975. ! UPDATED --FEBRUARY 1977. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE TIME(X,N) REAL(kind=wp) :: absr, ak, al, all, almax, an, an2, arg1, arg2, bw, df, dfroun, hold, p, perout, pi, pmsq, ps, pssq, r REAL(kind=wp) :: r025, r975, rk, rmax, s, sd, sdr, ssq, sum, sum1, sum2, var, varb, wk, X, xbar INTEGER :: i, i2, iarg1, iarg2, idf, ilower, imin, irev, j, jmax, jmin, k, kmax, krev, l, ll, llp1, lm1, lmax INTEGER :: maxlag, N, n2, ndiv, nmk, numout, numsp ! ! INPUT ARGUMENTS--X = THE VECTOR OF ! (UNSORTED) OBSERVATIONS. ! N = THE INTEGER NUMBER OF OBSERVATIONS ! IN THE VECTOR X. ! OUTPUT--7 TO 11 pages (DEPENDING ON ! THE INPUT SAMPLE SIZE) OF ! AUTOMATIC PRINTOUT-- ! 1) A PLOT OF AUTOCORRELATION VERSUS LAG NUMBER; ! THIS PLOT MAY TAKE AS LITTLE AS 1 ! OR AS MANY AS 5 pages ! (THE EXACT NUMBER DEPENDING ON ! THE INPUT SAMPLE SIZE N); ! 2) A TEST FOR WHITE NOISE (ASSUMING NORMALITY); ! 3) A 'PILOT' SPECTRUM; AND ! 4) AN ESTIMATED SPECTRUM BASED ON A ! BANDWIDTH DERIVED FROM THE DATA SET; ! 5) AN ESTIMATED SPECTRUM BASED ON A ! BANDWIDTH ONLY 1/2 AS WIDE AS IN 4; ! 6) AN ESTIMATED SPECTRUM BASED ON A ! BANDWIDTH ONLY 1/4 AS WIDE AS IN 4; ! 7) AN ESTIMATED SPECTRUM BASED ON A ! BANDWIDTH ONLY 1/8 AS WIDE AS IN 4; ! PRINTING--YES. ! RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE ! OF N FOR THIS SUBROUTINE. ! --THE SAMPLE SIZE N MUST BE GREATER ! THAN OR EQUAL TO 3. ! COMMENT--THE 'FAST FOURIER TRANSFORM' IS NOT USED ! IN THIS VERSION OF TIME, BUT WILL BE ! IMPLEMENTED IN A FUTURE VERSION. ! --THE USUAL MAXIMUM NUMBER OF LAGS ! FOR WHICH THE AUTOCORRELATION IS ! COMPUTED IS N/4 WHERE N IS ! THE SAMPLE SIZE (LENGTH OF THE ! DATA RECORD IN THE VECTOR X). ! THIS RULE IS OVERRIDDEN IN ! LARGE DATA SETS AND IS REPLACED ! BY THE RULE THAT THE MAXIMUM ! NUMBER OF LAGS = 500 ! (WHICH CORRESPONDS TO AN ! AUTOCORRELATION PLOT COVERING ! 5 COMPUTER pages). ! IF MORE LAGS ARE DESIRED, ! CHANGE THE VALUE OF THE ! VARIABLE MAXLAG ! WITHIN THIS SUBROUTINE ! FROM 500 TO WHATEVER DESIRED, ! AND ALSO CHANGE THE DIMENSION OF ! THE VECTOR R FROM ITS PRESENT 500 TO HOWEVER ! MANY LAGS ARE DESIRED. ! --IF THE INPUT OBSERVATIONS IN X ARE CONSIDERED ! TO HAVE BEEN COLLECTED 1 SECOND APART IN TIME, ! THEN THE FREQUENCY AXIS OF THE RESULTING ! SPECTRA WOULD BE IN UNITS OF HERTZ ! (= CYCLES PER SECOND). ! --THE FREQUENCY OF 0.0 CORRESPONDS TO A CYCLE ! IN THE DATA OF INFINITE (= 1/(0.0)) ! LENGTH OR PERIOD. ! THE FREQUENCY OF 0.5 CORRESPONDS TO A CYCLE ! IN THE DATA OF LENGTH = 1/(0.5) = 2 DATA POINTS. ! --ANY EQUI-SPACED TIME SERIES ANALYSIS IS ! INTRINSICALLY LIMITED TO DETECTING FREQUENCIES ! NO LARGER THAN 0.5 CYCLES PER DATA POINT; ! THIS CORRESPONDS TO THE FACT THAT THE ! SMALLEST DETECTABLE CYCLE IN THE DATA ! IS 2 DATA POINTS PER CYCLE. ! !--------------------------------------------------------------------- ! DIMENSION X(:) DIMENSION r(500) DIMENSION s(125) DIMENSION pssq(6) , pmsq(6) , ps(6) , p(5) , l(4) DATA pi/3.14159265358979_wp/ ! ilower = 3 maxlag = 500 ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( N<ilower ) THEN WRITE (G_IO,99001) ilower 99001 FORMAT (' ', & &'***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE TIME SUBROU& &TINE IS OUTSIDE THE ALLOWABLE (',I0,',INFINITY) ', & &'INTERVAL *****') WRITE (G_IO,99002) N 99002 FORMAT (' ','***** THE VALUE OF THE ARGUMENT IS ',I0,' *****') RETURN ELSE hold = X(1) DO i = 2 , N IF ( X(i)/=hold ) GOTO 100 ENDDO WRITE (G_IO,99003) hold 99003 FORMAT (' ', & &'***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT (A VECTOR) & &TO THE TIME SUBROUTINE HAS ALL ELEMENTS = ',E15.8,' *****') RETURN ENDIF ! !-----START POINT----------------------------------------------------- ! 100 an = N ! ! COMPUTE THE SAMPLE MEAN ! sum = 0.0_wp DO i = 1 , N sum = sum + X(i) ENDDO xbar = sum/an ! ! COMPUTE THE SAMPLE VARIANCE AND THE SUM OF SQUARED DEVIATIONS ! sum = 0.0_wp DO i = 1 , N sum = sum + (X(i)-xbar)*(X(i)-xbar) ENDDO ssq = sum varb = ssq/an var = ssq/(an-1.0_wp) sd = SQRT(var) ! ! COMPUTE THE SAMPLE AUTOCORRELATIONS ! REFERENCE--JENKINS AND WATTS, pages 290 AND 259 (7.1.6) ! kmax = N/4 IF ( N<=32 ) kmax = N/2 IF ( N<=16 ) kmax = N IF ( kmax>maxlag ) kmax = maxlag DO k = 1 , kmax sum = 0.0_wp nmk = N - k DO i = 1 , nmk j = i + k sum = sum + (X(i)-xbar)*(X(j)-xbar) ENDDO r(k) = sum/ssq ENDDO ! ! PLOT THE SAMPLE AUTOCORRELATIONS ! CALL PLOTCO(r,kmax) WRITE (G_IO,99004) 99004 FORMAT (' ',30X, & & 'AUTOCORRELATION PLOT--PLOT OF SAMPLE AUTOCORRELATION VERSUS LAG'& & ) WRITE (G_IO,99005) N , kmax 99005 FORMAT (' ',10X,'THE NUMBER OF OBSERVATIONS = ',I0,10X, & & 'THE NUMBER OF COMPUTED (AND PLOTTED) AUTOCORRELATIONS = '& & ,I0) ! ! DO A WHITE NOISE ANALYSIS ! sdr = 1.0_wp/SQRT(an) r975 = 1.96_wp*sdr IF ( r975>1.0_wp ) r975 = 1.0_wp r025 = -r975 numout = 0 DO k = 1 , kmax absr = r(k) IF ( absr<0.0_wp ) absr = -absr IF ( absr>r975 ) numout = numout + 1 ENDDO perout = FLOAT(numout)/FLOAT(kmax) perout = 100.0_wp*perout WRITE (G_IO,99017) WRITE (G_IO,99006) r025 , r975 ! 99006 FORMAT (' ', & &'UNDER THE NULL HYPOTHESIS OF WHITE NOISE (AND NORMALITY), A 2-SID& &ED 95 PERCENT ACCEPTANCE INTERVAL IS (',F6.4,',',F6.4,')') WRITE (G_IO,99007) 99007 FORMAT (' ', & &'UNDER THE NULL HYPOTHESIS, ONLY 5 PERCENT (ON THE AVERAGE) OF THE& & OBSERVED AUTOCORRELATIONS SHOULD FALL OUTSIDE THIS INTERVAL') WRITE (G_IO,99008) numout , kmax , perout 99008 FORMAT (' ','IT IS OBSERVED THAT ',I5,' OUT OF THE ',I5, & & ' (THAT IS, ',F5.1, & &' PERCENT) OF THE COMPUTED AUTOCORRELATIONS FALL OUTSIDE OF THIS I& &NTERVAL') DO i = 1 , 5 WRITE (G_IO,99017) ENDDO WRITE (G_IO,99009) N 99009 FORMAT (' ','THE SAMPLE SIZE = ',I0) WRITE (G_IO,99010) xbar 99010 FORMAT (' ','THE SAMPLE MEAN = ',E15.8) WRITE (G_IO,99011) var 99011 FORMAT (' ','THE SAMPLE VARIANCE = ',E15.8) WRITE (G_IO,99012) sd 99012 FORMAT (' ','THE SAMPLE STANDARD DEVIATION = ',E15.8) WRITE (G_IO,99013) varb 99013 FORMAT (' ','THE BIASED SAMPLE VARIANCE = ',E15.8) ! ! COMPUTE THE PILOT SPECTRUM FOR THE REDUCED (2**J) SAMPLE ! REFERENCE--JENKINS AND WATTS, page 288 ! DO i = 1 , 20 ndiv = N/(2**i) IF ( ndiv==0 ) i2 = i - 1 IF ( ndiv==0 ) EXIT ENDDO IF ( 7<i2 ) i2 = 7 n2 = 2**i2 an2 = n2 DO k = 1 , i2 sum = 0.0_wp imin = 2**k jmax = imin/2 DO i = imin , n2 , imin sum1 = 0.0_wp sum2 = 0.0_wp DO j = 1 , jmax iarg1 = i + j - jmax iarg2 = iarg1 - jmax sum1 = sum1 + X(iarg1) sum2 = sum2 + X(iarg2) ENDDO sum = sum + (sum1-sum2)*(sum1-sum2) ENDDO pssq(k) = sum/FLOAT(imin) pmsq(k) = pssq(k)/an2 ps(k) = FLOAT(2*imin)*pmsq(k) ps(k) = ps(k)/varb ENDDO ! ! FORM THE PILOT SPECTRUM PLOT ! DO i = 1 , i2 irev = i2 - i + 1 jmin = (120/(2**i)) + 1 IF ( i==i2 ) jmin = 1 jmax = 120/(2**(i-1)) DO j = jmin , jmax s(j) = ps(i) ENDDO ENDDO CALL PLOTSP(s,120,0) WRITE (G_IO,99017) WRITE (G_IO,99014) 99014 FORMAT (' ',50X,'PILOT SPECTRUM') ! ! DEFINE 4 LAG WINDOW TRUNCATION POINTS ! REFERENCE--JENKINS AND WATTS, pages 290 AND 260 ! p(1) = 0.2_wp p(2) = 0.1_wp p(3) = 0.05_wp p(4) = 0.025_wp p(5) = 0.01_wp lmax = 0 DO i = 1 , 5 DO k = 1 , kmax krev = kmax - k + 1 rk = r(krev) IF ( rk<0.0_wp ) rk = -rk IF ( rk>=p(i) ) lmax = krev IF ( rk>=p(i) ) GOTO 200 ENDDO ENDDO IF ( lmax==0 ) THEN rmax = ABS(r(1)) DO k = 1 , kmax rk = r(k) IF ( rk<0.0_wp ) rk = -rk IF ( rk>=rmax ) lmax = k IF ( rk>=rmax ) rmax = rk ENDDO ENDIF 200 almax = lmax l(1) = (3.0_wp/2.0_wp)*almax IF ( l(1)<=32 ) lmax = 32 IF ( l(1)<=32 ) almax = 32.0_wp IF ( l(1)<=32 ) l(1) = 32 IF ( l(1)>=kmax ) lmax = kmax IF ( l(1)>=kmax ) almax = kmax IF ( l(1)>=kmax ) l(1) = kmax l(2) = (almax/2.0_wp) + 0.1_wp l(3) = (almax/4.0_wp) + 0.1_wp l(4) = (almax/8.0_wp) + 0.1_wp IF ( l(4)>=3 ) numsp = 4 IF ( l(4)<3 ) THEN IF ( l(3)>=3 ) numsp = 3 IF ( l(3)<3 ) THEN IF ( l(2)>=3 ) numsp = 2 IF ( l(2)<3 ) THEN IF ( l(1)>=3 ) numsp = 1 IF ( l(1)<3 ) THEN WRITE (G_IO,99015) N 99015 FORMAT (' ', & & 'DUE TO THE SMALL NUMBER OF OBSERVATIONS (N = '& & ,I0, & & '), THERE ARE NOT ENOUGH LAGS TO PRODUCE A RELIABLE SPECTRUM'& & ) RETURN ENDIF ENDIF ENDIF ENDIF ! ! COMPUTE THE 4 SPECTRUM ESTIMATES ! REFERENCE--JENKINS AND WATTS, pages 260 AND 244 ! ! COMPUTE BANDWIDTHS ! REFERENCE--JENKINS AND WATTS, pages 257 AND 252 ! ! COMPUTE DEGREES OF FREEDOM FOR THE SPECTAL DENSITY ESTIMATE AT INDIVIDUAL ! FREQUENCIES ! REFERENCE--JENKINS AND WATTS, pages 254 AND 252 ! ! COMPUTE 95 PERCENT CONFIDENCE INTERVAL LENGTHS FOR THE LOG SPECTRAL ! DENSITY ESTIMATES ! REFERENCE--JENKINS AND WATTS, pages 255 AND 252 ! ! WRITE OUT THE 4 SPECTRUM PLOTS ! DO i = 1 , numsp al = l(i) lm1 = l(i) - 1 DO llp1 = 1 , 121 ll = llp1 - 1 all = ll sum = 0.0_wp DO k = 1 , lm1 ak = k arg1 = pi*ak/al arg2 = pi*ak*all/120.0_wp wk = 0.0_wp IF ( k<=l(i) ) wk = 0.5_wp*(1.0_wp+COS(arg1)) sum = sum + r(k)*wk*COS(arg2) ENDDO sum = 2.0_wp + 4.0_wp*sum s(llp1) = sum ENDDO bw = (4.0_wp/3.0_wp)/FLOAT(l(i)) df = (8.0_wp/3.0_wp)*an/FLOAT(l(i)) idf = df + 0.5 CALL PLOTSP(s,121,idf) dfroun = idf WRITE (G_IO,99017) WRITE (G_IO,99016) l(i) , bw , dfroun 99016 FORMAT (' NUMBER OF LAGS = ',I5,10X,'BANDWIDTH =',F10.3,10X,'DEGREES OF FREEDOM = ',F10.3) ENDDO 99017 FORMAT (' ') ! END SUBROUTINE TIME !> !!##NAME !! tol(3f) - [M_datapac:STATISTICS] compute normal and distribution-free !! tolerance limits !! !!##SYNOPSIS !! !! SUBROUTINE TOL(X,N) !! !!##DESCRIPTION !! tol(3f) computes normal and distribution-free tolerance limits for !! the data in the input vector x. !! !! 15 normal tolerance limits are computed; and 30 distribution-free !! tolerance limits are computed. !! !!##OPTIONS !! X description of parameter !! Y description of parameter !! !!##EXAMPLES !! !! Sample program: !! !! program demo_tol !! use M_datapac, only : tol !! implicit none !! ! call tol(x,y) !! end program demo_tol !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the Statistical !! Engineering Division, National Institute of Standards and Technology. !!##MAINTAINER !! John Urban, 2022.05.31 !!##LICENSE !! CC0-1.0 !!##REFERENCES !! * GARDINER AND HULL, TECHNOMETRICS, 1966, pages 115-122 !! * WILKS, ANNALS OF MATHEMATICAL STATISTICS, 1941, page 92 !! * MOOD AND GRABLE, pages 416-417 ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE TOL(X,N) REAL(kind=wp) :: a , a0 , a1 , a2 , a3 , a4 , a5 , ak , an , an1 , an2 , an3 ,& & an4 , an5 , an6 , b , c , c1 , c2 , c3 REAL(kind=wp) :: d , d1 , d2 , d3 , d4 , d5 , d6 , d7 , f , hold , p , pa , & & pc , q , r , rsmall , sd , t , tmax , tmin REAL(kind=wp) :: u , univ , usmall , var , X , xbar , xmax , xmax2 , xmax3 , & & xmin , xmin2 , xmin3 , z , z1 INTEGER :: i , j , k , locmax , locmin , locmn2 , locmn3 , & & locmx2 , locmx3 , N , numsec ! ! INPUT ARGUMENTS--X = THE VECTOR OF ! (UNSORTED OR SORTED) OBSERVATIONS. ! N = THE INTEGER NUMBER OF OBSERVATIONS ! IN THE VECTOR X. ! OUTPUT--2 pages OF AUTOMATIC PRINTOUT-- ! 1 page GIVING NORMAL TOLERANCE LIMITS; AND ! 1 page GIVING DISTRIBUTION-FREE TOLERANCE LIMITS. ! PRINTING--YES. ! RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE ! OF N FOR THIS SUBROUTINE. ! FORTRAN LIBRARY SUBROUTINES NEEDED--SQRT. ! MODE OF INTERNAL OPERATIONS--. ! ORIGINAL VERSION--JUNE 1972. ! UPDATED --NOVEMBER 1975. ! !--------------------------------------------------------------------- ! DIMENSION X(:) DIMENSION pa(6) , pc(6) , z1(3) , a(6) , b(6) , c(6) , rsmall(5,6), usmall(6,6) DIMENSION tmin(3,6) , tmax(3,6) DIMENSION p(10) , c1(10) , c2(10) , c3(10) ! DATA pa(1) , pa(2) , pa(3) , pa(4) , pa(5) , pa(6)/50.0_wp , 75.0_wp , 90.0_wp , 95.0_wp , 99.0_wp , 99.9_wp/ DATA pc(1) , pc(2) , pc(3)/90.0_wp , 95.0_wp , 99.0_wp/ DATA z1(1) , z1(2) , z1(3)/ - 1.28155157_wp , -1.64485363_wp , & & -2.32634787_wp/ DATA a(1) , a(2) , a(3) , a(4) , a(5) , a(6)/.6745_wp , 1.1504_wp , & & 1.6449_wp , 1.9600_wp , 2.5758_wp , 3.2905_wp/ DATA b(1) , b(2) , b(3) , b(4) , b(5) , b(6)/.33734_wp , .57335_wp , & & .82140_wp , .97910_wp , 1.2889_wp , 1.64038_wp/ DATA c(1) , c(2) , c(3) , c(4) , c(5) , c(6)/ - 0.15460_wp , & & -0.02991_wp , .22044_wp , .40675_wp , .85514_wp , 1.42601_wp/ DATA rsmall(1,1) , rsmall(1,2) , rsmall(1,3) , rsmall(1,4) , & & rsmall(1,5) , rsmall(1,6)/1.0505_wp , 1.6859_wp , 2.2844_wp , 2.6463_wp ,& & 3.3266_wp , 4.0903_wp/ DATA rsmall(2,1) , rsmall(2,2) , rsmall(2,3) , rsmall(2,4) , & & rsmall(2,5) , rsmall(2,6)/0.8557_wp , 1.4333_wp , 2.0078_wp , 2.3624_wp ,& & 3.0368_wp , 3.7983_wp/ DATA rsmall(3,1) , rsmall(3,2) , rsmall(3,3) , rsmall(3,4) , & & rsmall(3,5) , rsmall(3,6)/0.7929_wp , 1.3412_wp , 1.8979_wp , 2.2457_wp ,& & 2.9128_wp , 3.6708_wp/ DATA rsmall(4,1) , rsmall(4,2) , rsmall(4,3) , rsmall(4,4) , & & rsmall(4,5) , rsmall(4,6)/0.7622_wp , 1.2940_wp , 1.8388_wp , 2.1815_wp ,& & 2.8422_wp , 3.5965_wp/ DATA rsmall(5,1) , rsmall(5,2) , rsmall(5,3) , rsmall(5,4) , & & rsmall(5,5) , rsmall(5,6)/0.7442_wp , 1.2654_wp , 1.8019_wp , 2.1408_wp ,& & 2.7963_wp , 3.5472_wp/ DATA usmall(1,1) , usmall(1,2) , usmall(1,3)/0.0_wp , 0.0_wp , 0._wp/ DATA usmall(2,1) , usmall(2,2) , usmall(2,3)/7.9579_wp , 15.9472_wp , & & 79.7863_wp/ DATA usmall(3,1) , usmall(3,2) , usmall(3,3)/3.0808_wp , 4.4154_wp , & & 9.9749_wp/ DATA usmall(4,1) , usmall(4,2) , usmall(4,3)/2.2658_wp , 2.9200_wp , & & 5.1113_wp/ DATA usmall(5,1) , usmall(5,2) , usmall(5,3)/1.9393_wp , 2.3724_wp , & & 3.6692_wp/ DATA usmall(6,1) , usmall(6,2) , usmall(6,3)/1.7621_wp , 2.0893_wp , & & 3.0034_wp/ DATA p(1) , p(2) , p(3) , p(4) , p(5) , p(6) , p(7) , p(8) , & & p(9) , p(10)/50.0_wp , 75.0_wp , 90.0_wp , 95.0_wp , 97.5 , 99.0_wp , 99.5_wp , & & 99.9_wp , 99.95_wp , 99.99_wp/ ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( N<1 ) THEN WRITE (G_IO,99001) 99001 FORMAT (' ', & &'***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE TOL SUBROU& &TINE IS NON-POSITIVE *****') WRITE (G_IO,99002) N 99002 FORMAT (' ','***** THE VALUE OF THE ARGUMENT IS ',I0,' *****') RETURN ELSE IF ( N==1 ) THEN WRITE (G_IO,99003) 99003 FORMAT (' ', & &'***** NON-FATAL DIAGNOSTIC--THE SECOND INPUT ARGUMENT TO THE TOL & & SUBROUTINE HAS THE VALUE 1 *****') RETURN ELSE hold = X(1) DO i = 2 , N IF ( X(i)/=hold ) GOTO 50 ENDDO WRITE (G_IO,99004) hold 99004 FORMAT (' ', & &'***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT (A VECTOR) & &TO THE TOL SUBROUTINE HAS ALL ELEMENTS = ',E15.8,' *****') RETURN ENDIF ! !-----START POINT----------------------------------------------------- ! 50 an = N ! ! COMPUTE NORMAL TOLERANCE LIMITS ! ! COMPUTE THE SAMPLE MEAN ! xbar = 0.0_wp DO i = 1 , N xbar = xbar + X(i) ENDDO xbar = xbar/an ! ! COMPUTE THE SAMPLE STANDARD DEVIATION ! var = 0.0_wp DO i = 1 , N var = var + (X(i)-xbar)**2 ENDDO var = var/(an-1.0_wp) sd = SQRT(var) ! ! COMPUTE THE NORMAL TOLERANCE LIMITS ! DO i = 1 , 3 z = z1(i) f = N - 1 IF ( N<=6 ) u = usmall(N,i) IF ( N>6 ) THEN d1 = 1.0_wp + z*SQRT(2.0_wp)/SQRT(f) d2 = 2.0_wp*(z**2-1.0_wp)/(3.0_wp*f) d3 = (z**3-7.0_wp*z)/(9.0_wp*SQRT(2.0_wp)*f**1.5_wp) d4 = (6.0_wp*z**4+14.0_wp*z**2-32.0_wp)/(405.0_wp*f**2.0_wp) d5 = (9.0_wp*z**5+256.0_wp*z**3-433.0_wp*z) & & /(4860.0_wp*SQRT(2.0_wp)*f**2.5_wp) d6 = (12.0_wp*z**6-243.0_wp*z**4-923.0_wp*z**2+1472.0_wp) & & /(25515.0_wp*f**3.0_wp) d7 = (3753.0_wp*z**7+4353.0_wp*z**5-289517.0_wp*z**3-289717.0_wp*z) & & /(9185400.0_wp*SQRT(2.0_wp)*f**3.5_wp) univ = d1 + d2 + d3 - d4 + d5 + d6 - d7 u = 1.0_wp/univ u = SQRT(u) ENDIF DO j = 1 , 6 r = a(j) + (b(j)/(c(j)+an)) IF ( N<=5 ) r = rsmall(N,j) ak = r*u tmin(i,j) = xbar - ak*sd tmax(i,j) = xbar + ak*sd ENDDO ENDDO ! ! WRITE OUT THE NORMAL TOLERANCE LIMITS ! WRITE (G_IO,99016) WRITE (G_IO,99005) N ! 99005 FORMAT (' ',' NORMAL TOLERANCE LIMITS FOR THE ',I0,& & ' OBSERVATIONS') WRITE (G_IO,99017) WRITE (G_IO,99006) 99006 FORMAT (' ',' REFERENCE--CRC HANDBOOK, pages 32-35'& & ) WRITE (G_IO,99007) 99007 FORMAT (' ', & &' REFERENCE--GARDINER AND HULL, TECHNOMETRICS, 1966, P& &AGES 115-122') WRITE (G_IO,99017) WRITE (G_IO,99008) xbar , sd 99008 FORMAT (' ',' SAMPLE MEAN = ',E15.8, & & ' SAMPLE STANDARD DEVIATION = ',E15.8) WRITE (G_IO,99017) WRITE (G_IO,99017) DO i = 1 , 3 DO j = 1 , 6 WRITE (G_IO,99009) pc(i) , pa(j) , tmin(i,j) , tmax(i,j) 99009 FORMAT (' ','WE ARE ',F6.2,' PERCENT CONFIDENT THAT ', & & F5.2, & & ' PERCENT OF THE POPULATION IS BETWEEN XBAR-K*S = '& & ,E12.5,' AND XBAR+K*S = ',E12.5) ENDDO WRITE (G_IO,99017) ENDDO ! ! ! ! ! COMPUTE DISTRIBUTION-FREE TOLERANCE LIMITS ! k = N/2 numsec = 3 IF ( k<numsec ) numsec = k ! ! DETERMINE THE SMALLEST 3 AND LARGEST 3 OBSERVATIONS ! locmin = 1 xmin = X(1) DO i = 1 , N IF ( X(i)<=xmin ) locmin = i IF ( X(i)<=xmin ) xmin = X(i) ENDDO locmax = 1 xmax = X(1) DO i = 1 , N IF ( X(i)>=xmax ) locmax = i IF ( X(i)>=xmax ) xmax = X(i) ENDDO DO i = 1 , N IF ( i/=locmin ) EXIT ENDDO locmn2 = i xmin2 = X(i) DO i = 1 , N IF ( i/=locmin ) THEN IF ( X(i)<=xmin2 ) locmn2 = i IF ( X(i)<=xmin2 ) xmin2 = X(i) ENDIF ENDDO DO i = 1 , N IF ( i/=locmax ) EXIT ENDDO locmx2 = i xmax2 = X(i) DO i = 1 , N IF ( i/=locmax ) THEN IF ( X(i)>=xmax2 ) locmx2 = i IF ( X(i)>=xmax2 ) xmax2 = X(i) ENDIF ENDDO DO i = 1 , N IF ( i/=locmin .AND. i/=locmn2 ) EXIT ENDDO locmn3 = i xmin3 = X(i) DO i = 1 , N IF ( i/=locmin .AND. i/=locmn2 ) THEN IF ( X(i)<=xmin3 ) locmn3 = i IF ( X(i)<=xmin3 ) xmin3 = X(i) ENDIF ENDDO DO i = 1 , N IF ( i/=locmax .AND. i/=locmx2 ) EXIT ENDDO locmx3 = i xmax3 = X(i) DO i = 1 , N IF ( i/=locmax .AND. i/=locmx2 ) THEN IF ( X(i)>=xmax3 ) locmx3 = i IF ( X(i)>=xmax3 ) xmax3 = X(i) ENDIF ENDDO an1 = an - 1.0_wp an2 = an - 2.0_wp an3 = an - 3.0_wp an4 = an - 4.0_wp an5 = an - 5.0_wp an6 = an - 6.0_wp DO i = 1 , 10 d = p(i)/100.0_wp c1(i) = (d**an1)*(-an+an1*d) c1(i) = 1.0_wp - c1(i) q = 1.0_wp - d t = q*an c1(i) = 1.0_wp + an1*q c1(i) = 1.0_wp - (d**an1)*c1(i) c1(i) = c1(i)*100.0_wp IF ( numsec/=1 ) THEN a0 = 6.0_wp*d*d*d a1 = 2.0_wp - 7.0_wp*d + 11.0_wp*d*d a2 = -3.0_wp + 6.0_wp*d a3 = 1.0_wp c2(i) = a0 + a1*t + a2*t*t + a3*t*t*t c2(i) = 1.0_wp - (d**an3)*c2(i)/6.0_wp c2(i) = c2(i)*100.0_wp IF ( numsec/=2 ) THEN a0 = 120.0_wp*d*d*d*d*d a1 = 24.0_wp - 126.0_wp*d + 274.0_wp*d*d - 326.0_wp*d*d*d + & & 274.0_wp*d*d*d*d a2 = -50.0_wp + 205.0_wp*d - 320.0_wp*d*d + 225.0_wp*d*d*d a3 = 35.0_wp - 100.0_wp*d + 85.0_wp*d*d a4 = -10.0_wp + 15.0_wp*d a5 = 1.0D0 c3(i) = a0 + a1*t + a2*t*t + a3*t*t*t + a4*t*t*t*t + & & a5*t*t*t*t*t c3(i) = 1.0_wp - (d**an5)*c3(i)/120.0_wp c3(i) = c3(i)*100.0_wp ENDIF ENDIF ENDDO ! ! WRITE OUT THE DISTRIBUTION-FREE TOLERANCE LIMITS ! WRITE (G_IO,99016) WRITE (G_IO,99010) N 99010 FORMAT (' ', & & ' DISTRIBUTION-FREE TOLERANCE LIMITS FOR THE '& & ,I0,' OBSERVATIONS') WRITE (G_IO,99017) WRITE (G_IO,99011) 99011 FORMAT (' ', & & ' REFERENCE--WILKS, ANNALS, 1941, page 92') WRITE (G_IO,99012) 99012 FORMAT (' ', & & ' REFERENCE--MOOD AND GRABLE, pages 416-417'& & ) WRITE (G_IO,99017) WRITE (G_IO,99017) IF ( numsec/=1 ) THEN IF ( numsec/=2 ) THEN DO i = 1 , 10 WRITE (G_IO,99013) c3(i) , p(i) , xmin3 , xmax3 99013 FORMAT (' ','WE ARE ',F6.2,' PERCENT CONFIDENT THAT ',& & F5.2, & & ' PERCENT OF THE POPULATION IS BETWEEN X3 = '& & ,F8.3,' AND X(N-2) = ',F8.3) ENDDO WRITE (G_IO,99017) ENDIF DO i = 1 , 10 WRITE (G_IO,99014) c2(i) , p(i) , xmin2 , xmax2 99014 FORMAT (' ','WE ARE ',F6.2,' PERCENT CONFIDENT THAT ', & & F5.2, & & ' PERCENT OF THE POPULATION IS BETWEEN X2 = ', & & F8.3,' AND X(N-1) = ',F8.3) ENDDO WRITE (G_IO,99017) ENDIF DO i = 1 , 10 WRITE (G_IO,99015) c1(i) , p(i) , xmin , xmax 99015 FORMAT (' ','WE ARE ',F6.2,' PERCENT CONFIDENT THAT ',F5.2, & & ' PERCENT OF THE POPULATION IS BETWEEN XMIN = ', & & F8.3,' AND XMAX = ',F8.3) ENDDO ENDIF 99016 FORMAT ('1') 99017 FORMAT (' ') ! END SUBROUTINE TOL !> !!##NAME !! tplt(3f) - [M_datapac:LINE_PLOT] generates a Student's T probability !! plot (with integer degrees of freedom parameter value NU). !! !!##SYNOPSIS !! !! SUBROUTINE TPLT(X,N,Nu) !! !! REAL(kind=wp),intent(in) :: X(:) !! INTEGER,intent(in) :: N !! INTEGER,intent(in) :: Nu !! !!##DESCRIPTION !! TPLT(3f) generates a Student's T probability plot (with integer !! degrees of freedom parameter value = NU). !! !! The prototype Student's T distribution used herein is defined for all !! X, and its probability density function is given in the references !! below. !! !! As used herein, a probability plot for a distribution is a plot !! of the ordered observations versus the order statistic medians for !! that distribution. !! !! The Student's T probability plot is useful in graphically testing !! the composite (that is, location and scale parameters need not be !! specified) hypothesis that the underlying distribution from which !! the data have been randomly drawn is the Student's T distribution !! with degrees of freedom parameter value = NU. !! !! If the hypothesis is true, the probability plot should be near-linear. !! !! A measure of such linearity is given by the calculated probability !! plot correlation coefficient. !! !!##INPUT ARGUMENTS !! X The vector of (unsorted or sorted) observations. !! N The integer number of observations in the vector X. !! The maximum allowable value of N for this subroutine is 7500. !! NU The integer number of degrees of freedom. !! NU should be positive. !! !!##OUTPUT !! A one-page Student's T probability plot. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_tplt !! use M_datapac, only : tplt !! implicit none !! ! call tplt(x,y) !! end program demo_tplt !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !!##MAINTAINER !! John Urban, 2022.05.31 !!##LICENSE !! CC0-1.0 !!##REFERENCES !! * Filliben, 'Techniques for Tail Length Analysis', Proceedings of the !! Eighteenth Conference on the Design of Experiments in Army Research !! Development and Testing (Aberdeen, Maryland, October, 1972), pages !! 425-450. !! * Hahn and Shapiro, Statistical Methods in Engineering, 1967, pages !! 260-308. !! * National Bureau of Standards Applied Mathematics Series 55, 1964, !! page 949, FormulA 26.7.5. !! * Johnson and Kotz, Continuous Univariate Distributions--2, 1970, !! page 102, Formula 11. !! * Federighi, 'Extended Tables of the Percentage Points of Student's !! T Distribution, Journal of the American Statistical Association, !! 1969, pages 683-688. !! * Hastings and Peacock, Statistical Distributions--A Handbook for !! Students and Practitioners, 1975, pages 120-123. ! ORIGINAL VERSION--NOVEMBER 1975. ! UPDATED --FEBRUARY 1976. ! UPDATED --FEBRUARY 1977. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE TPLT(X,N,Nu) REAL(kind=wp),intent(in) :: X(:) INTEGER,intent(in) :: N INTEGER,intent(in) :: Nu REAL(kind=wp) :: W(7500), Y(7500) REAL(kind=wp) :: an, cc, hold, pp0025, pp025, pp975, pp9975, q, sum1, sum2, sum3, tau, wbar, WS, ybar, yint, yslope INTEGER :: i, iupper COMMON /BLOCK2_real32/ WS(15000) EQUIVALENCE (Y(1),WS(1)) EQUIVALENCE (W(1),WS(7501)) ! iupper = 7500 ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( N<1 .OR. N>iupper ) THEN WRITE (G_IO,99001) iupper 99001 FORMAT ( & & ' ***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO TPLT(3f) IS OUTSIDE THE ALLOWABLE (1,',I0,') INTERVAL *****') WRITE (G_IO,99007) N RETURN ELSEIF ( N==1 ) THEN WRITE (G_IO,99002) 99002 FORMAT (' ***** NON-FATAL DIAGNOSTIC--THE SECOND INPUT ARGUMENT TO TPLT(3f) HAS THE VALUE 1 *****') RETURN ELSE IF ( Nu<=0 ) THEN WRITE (G_IO,99003) 99003 FORMAT (' ***** FATAL ERROR--THE THIRD INPUT ARGUMENT TO TPLT(3f) IS NON-POSITIVE *****') WRITE (G_IO,99007) Nu RETURN ELSE hold = X(1) DO i = 2 , N IF ( X(i)/=hold ) GOTO 50 ENDDO WRITE (G_IO,99004) hold 99004 FORMAT (' ',& &'***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT (A VECTOR) TO TPLT(3f) HAS ALL ELEMENTS = ',E15.8,' *****') RETURN ENDIF ! !-----START POINT----------------------------------------------------- ! 50 continue an = N ! ! SORT THE DATA ! CALL SORT(X,N,Y) ! ! GENERATE UNIFORM ORDER STATISTIC MEDIANS ! CALL UNIMED(N,W) ! ! COMPUTE STUDENT'S T DISTRIBUTION ORDER STATISTIC MEDIANS ! DO i = 1 , N CALL TPPF(W(i),Nu,W(i)) ENDDO ! ! PLOT THE ORDERED OBSERVATIONS VERSUS ORDER STATISTICS MEDIANS. ! COMPUTE THE TAIL LENGTH MEASURE OF THE DISTRIBUTION. ! WRITE OUT THE TAIL LENGTH MEASURE OF THE DISTRIBUTION ! AND THE SAMPLE SIZE. ! CALL PLOT(Y,W,N) q = .9975_wp CALL TPPF(q,Nu,pp9975) q = .0025_wp CALL TPPF(q,Nu,pp0025) q = .975_wp CALL TPPF(q,Nu,pp975) q = .025_wp CALL TPPF(q,Nu,pp025) tau = (pp9975-pp0025)/(pp975-pp025) WRITE (G_IO,99005) Nu , tau , N ! 99005 FORMAT (' STUDENT''S T PROBABILITY PLOT WITH DEGREES OF FREEDOM = '& & ,I0,1X,'(TAU = ',E15.8,')',11X,'THE SAMPLE SIZE N = ',I0) ! ! COMPUTE THE PROBABILITY PLOT CORRELATION COEFFICIENT. ! COMPUTE LOCATION AND SCALE ESTIMATES ! FROM THE INTERCEPT AND SLOPE OF THE PROBABILITY PLOT. ! THEN WRITE THEM OUT. ! sum1 = 0.0_wp sum2 = 0.0_wp DO i = 1 , N sum1 = sum1 + Y(i) sum2 = sum2 + W(i) ENDDO ybar = sum1/an wbar = sum2/an sum1 = 0.0_wp sum2 = 0.0_wp sum3 = 0.0_wp DO i = 1 , N sum1 = sum1 + (Y(i)-ybar)*(Y(i)-ybar) sum2 = sum2 + (Y(i)-ybar)*(W(i)-wbar) sum3 = sum3 + (W(i)-wbar)*(W(i)-wbar) ENDDO cc = sum2/SQRT(sum3*sum1) yslope = sum2/sum3 yint = ybar - yslope*wbar WRITE (G_IO,99006) cc , yint , yslope 99006 FORMAT (' PROBABILITY PLOT CORRELATION COEFFICIENT = ',F8.5,& & 5X,'ESTIMATED INTERCEPT = ',E15.8,3X, & & 'ESTIMATED SLOPE = ',E15.8) ENDIF 99007 FORMAT (' ***** THE VALUE OF THE ARGUMENT IS ',I0,' *****') ! END SUBROUTINE TPLT !> !!##NAME !! tppf(3f) - [M_datapac:PERCENT_POINT] computes the percent !! point function value for the student's T distribution !! !!##SYNOPSIS !! !! SUBROUTINE TPPF(P,Nu,Ppf) !! !!##DESCRIPTION !! !! tppf(3f) computes the percent point function value for the student's !! t distribution with integer degrees of freedom parameter = nu. !! the student's t distribution used herein is defined for all x, and !! its probability density function is given in the references below. !! !! note that the percent point function of a distribution is identically !! the same as the inverse cumulative distribution function of the !! distribution. !! !!##OPTIONS !! X description of parameter !! Y description of parameter !! !!##EXAMPLES !! !! Sample program: !! !! program demo_tppf !! use M_datapac, only : tppf !! implicit none !! ! call tppf(x,y) !! end program demo_tppf !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !! !!##REFERENCES !! * National Bureau of Standards Applied Mathematics Series 55, 1964, !! page 949, Formula 26.7.5. !! * Johnson and Kotz, Continuous Univariate Distributions--2, 1970, !! page 102, Formula 11. !! * Federighi, 'Extended Tables of the Percentage Points of Student's T !! Distribution, Journal of the American Statistical Association, 1969, !! pages 683-688. !! * Hastings and Peacock, Statistical Distributions--A Handbook for !! Students and Practitioners, 1975, pages 120-123. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE TPPF(P,Nu,Ppf) INTEGER ipass , maxit , Nu REAL(kind=wp) :: P , Ppf , ppfn ! ! INPUT ARGUMENTS--P = THE VALUE ! (BETWEEN 0.0 (EXCLUSIVELY) ! AND 1.0 (EXCLUSIVELY)) ! AT WHICH THE PERCENT POINT ! FUNCTION IS TO BE EVALUATED. ! --NU = THE INTEGER NUMBER OF DEGREES ! OF FREEDOM. ! NU SHOULD BE POSITIVE. ! OUTPUT ARGUMENTS--PPF = THE PERCENT ! POINT FUNCTION VALUE. ! OUTPUT--THE PERCENT POINT FUNCTION . ! VALUE PPF FOR THE STUDENT'S T DISTRIBUTION ! WITH DEGREES OF FREEDOM PARAMETER = NU. ! PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. ! RESTRICTIONS--NU SHOULD BE A POSITIVE INTEGER VARIABLE. ! --P SHOULD BE BETWEEN 0.0 (EXCLUSIVELY) ! AND 1.0 (EXCLUSIVELY). ! OTHER DATAPAC SUBROUTINES NEEDED--NORPPF. ! MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. ! COMMENT--FOR NU = 1 AND NU = 2, THE PERCENT POINT FUNCTION ! FOR THE T DISTRIBUTION EXISTS IN SIMPLE CLOSED FORM ! AND SO THE COMPUTED PERCENT POINTS ARE EXACT. ! --FOR OTHER SMALL VALUES OF NU (NU BETWEEN 3 AND 6, ! INCLUSIVELY), THE APPROXIMATION ! OF THE T PERCENT POINT BY THE FORMULA ! GIVEN IN THE REFERENCE BELOW IS AUGMENTED ! BY 3 ITERATIONS OF NEWTON'S METHOD FOR ! ROOT DETERMINATION. ! THIS IMPROVES THE ACCURACY--ESPECIALLY FOR ! VALUES OF P NEAR 0 OR 1. ! ORIGINAL VERSION--OCTOBER 1975. ! UPDATED --NOVEMBER 1975. ! !--------------------------------------------------------------------- ! DOUBLE PRECISION pi DOUBLE PRECISION sqrt2 DOUBLE PRECISION dp DOUBLE PRECISION dnu DOUBLE PRECISION term1 , term2 , term3 , term4 , term5 DOUBLE PRECISION dppfn DOUBLE PRECISION dppf , dcon , darg , z , s , c DOUBLE PRECISION b21 DOUBLE PRECISION b31 , b32 , b33 , b34 DOUBLE PRECISION b41 , b42 , b43 , b44 , b45 DOUBLE PRECISION b51 , b52 , b53 , b54 , b55 , b56 DOUBLE PRECISION d1 , d3 , d5 , d7 , d9 DATA pi/3.14159265358979D0/ DATA sqrt2/1.414213562D0/ DATA b21/0.25D0/ DATA b31 , b32 , b33 , b34/0.01041666666667D0 , 5.0D0 , 16.0D0 , & & 3.0D0/ DATA b41 , b42 , b43 , b44 , b45/0.00260416666667D0 , 3.0D0 , & & 19.0D0 , 17.0D0 , -15.0D0/ DATA b51 , b52 , b53 , b54 , b55 , b56/0.00001085069444D0 , & & 79.0D0 , 776.0D0 , 1482.0D0 , -1920.0D0 , -945.0D0/ ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( P<=0.0_wp .OR. P>=1.0_wp ) THEN WRITE (G_IO,99001) 99001 FORMAT (' ', & &'***** FATAL ERROR--THE FIRST INPUT ARGUMENT TO THE TPPF SUBROU& &TINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL *****') WRITE (G_IO,99002) P 99002 FORMAT (' ','***** THE VALUE OF THE ARGUMENT IS ',E15.8, & & ' *****') RETURN ELSE ! !-----START POINT----------------------------------------------------- ! dnu = Nu dp = P maxit = 5 ! IF ( Nu>=3 ) THEN ! ! TREAT THE NU GREATER THAN OR EQUAL TO 3 CASE ! CALL NORPPF(P,ppfn) dppfn = ppfn d1 = dppfn d3 = dppfn**3 d5 = dppfn**5 d7 = dppfn**7 d9 = dppfn**9 term1 = d1 term2 = b21*(d3+d1)/dnu term3 = b31*(b32*d5+b33*d3+b34*d1)/(dnu**2) term4 = b41*(b42*d7+b43*d5+b44*d3+b45*d1)/(dnu**3) term5 = b51*(b52*d9+b53*d7+b54*d5+b55*d3+b56*d1)/(dnu**4) dppf = term1 + term2 + term3 + term4 + term5 Ppf = dppf IF ( Nu>=7 ) RETURN IF ( Nu==3 ) THEN ! ! AUGMENT THE RESULTS FOR THE NU = 3 CASE ! dcon = pi*(dp-0.5D0) darg = dppf/DSQRT(dnu) z = DATAN(darg) DO ipass = 1 , maxit s = DSIN(z) c = DCOS(z) z = z - (z+s*c-dcon)/(2.0D0*c*c) ENDDO Ppf = DSQRT(dnu)*s/c RETURN ELSEIF ( Nu==4 ) THEN ! ! AUGMENT THE RESULTS FOR THE NU = 4 CASE ! dcon = 2.0D0*(dp-0.5D0) darg = dppf/DSQRT(dnu) z = DATAN(darg) DO ipass = 1 , maxit s = DSIN(z) c = DCOS(z) z = z - ((1.0D0+0.5D0*c*c)*s-dcon)/(1.5D0*c*c*c) ENDDO Ppf = DSQRT(dnu)*s/c RETURN ELSEIF ( Nu==5 ) THEN ! ! AUGMENT THE RESULTS FOR THE NU = 5 CASE ! dcon = pi*(dp-0.5D0) darg = dppf/DSQRT(dnu) z = DATAN(darg) DO ipass = 1 , maxit s = DSIN(z) c = DCOS(z) z = z - (z+(c+(2.0D0/3.0D0)*c*c*c)*s-dcon) & & /((8.0D0/3.0D0)*c**4) ENDDO Ppf = DSQRT(dnu)*s/c RETURN ELSEIF ( Nu==6 ) THEN ! ! AUGMENT THE RESULTS FOR THE NU = 6 CASE ! dcon = 2.0D0*(dp-0.5D0) darg = dppf/DSQRT(dnu) z = DATAN(darg) DO ipass = 1 , maxit s = DSIN(z) c = DCOS(z) z = z - ((1.0D0+0.5D0*c*c+0.375D0*c**4)*s-dcon) & & /((15.0D0/8.0D0)*c**5) ENDDO Ppf = DSQRT(dnu)*s/c GOTO 99999 ENDIF ELSEIF ( Nu==1 ) THEN ! ! TREAT THE NU = 1 (CAUCHY) CASE ! darg = pi*dp Ppf = -DCOS(darg)/DSIN(darg) RETURN ELSEIF ( Nu==2 ) THEN ! ! TREAT THE NU = 2 CASE ! term1 = sqrt2/2.0D0 term2 = 2.0D0*dp - 1.0D0 term3 = DSQRT(dp*(1.0D0-dp)) Ppf = term1*term2/term3 RETURN ELSE WRITE (G_IO,99003) 99003 FORMAT (' ','INTERNAL ERROR IN TPPF SUBROUTINE') Ppf = 0.0_wp RETURN ENDIF ENDIF RETURN ! 99999 END SUBROUTINE TPPF !> !!##NAME !! tran(3f) - [M_datapac:RANDOM] a random sample of size n from the !! Student's t distribution with integer degrees of freedom parameter NU. !! !!##SYNOPSIS !! !! SUBROUTINE TRAN(N,Nu,Iseed,X) !! !! INTEGER,intent(in) :: N !! INTEGER,intent(in) :: Nu !! INTEGER,intent(inout) :: Iseed !! REAL(kind=wp),intent(out) :: X(:) !! !!##DESCRIPTION !! !! This subroutine generates a random sample of size N from the Student's !! T distribution with integer degrees of freedom parameter = NU. !! !!##INPUT ARGUMENTS !! !! N The desired integer number of random numbers to be generated. !! !! NU The integer degrees of freedom (parameter) for the T !! distribution. NU should be a positive integer variable. !! !! ISEED An integer seed value. Should be set to a non-negative value !! to start a new sequence of values. Will be set to -1 on return !! to indicate the next call should continue the current random !! !!##OUTPUT ARGUMENTS !! !! X A vector (of dimension at least N) into which the generated !! random sample of size N from the Student's T distribution !! will be placed. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_tran !! use m_datapac, only : tran, plott, label, plotxt, sort !! implicit none !! integer,parameter :: n=400 !! real :: x(n) !! integer :: iseed !! integer :: nu !! call label('tran') !! nu=3 !! iseed=12345 !! call tran(N,Nu,Iseed,X) !! call plotxt(x,n) !! call sort(x,n,x) ! sort to show distribution !! call plotxt(x,n) !! end program demo_tran !! !! Results: !! !! THE FOLLOWING IS A PLOT OF X(I) (VERTICALLY) VERSUS I (HORIZONTALLY !! I-----------I-----------I-----------I-----------I !! 0.1029407E+02 - X !! 0.9486016E+01 I !! 0.8677961E+01 I !! 0.7869905E+01 I !! 0.7061851E+01 I X !! 0.6253795E+01 I X !! 0.5445739E+01 - !! 0.4637684E+01 I !! 0.3829628E+01 I X X X X !! 0.3021573E+01 I X X X XX X X X X !! 0.2213517E+01 I X XX XX X X X X X X !! 0.1405462E+01 I X XXXX XXXXXXXXXXXX XX XXX XXX XXXXXX !! 0.5974064E+00 - XX XXXXXXXXXXXXXXXXXXXXXXXX XXX XXXXXXXXXXXX XXX !! -0.2106485E+00 I XXXXXXXXXXXXXX XXXXXXXXXXXXXXXXXXXXXX XXXXXXXXXX !! -0.1018704E+01 I XX XX XX X XXX XX XXXXXXXXXXXX XX XXXX XX XXX X !! -0.1826759E+01 I XXXXXX XX XX XX X XX X X X XX XX !! -0.2634815E+01 I X XX X X X XX !! -0.3442871E+01 I X X !! -0.4250926E+01 - X X X X !! -0.5058982E+01 I X X !! -0.5867038E+01 I X !! -0.6675092E+01 I !! -0.7483148E+01 I !! -0.8291203E+01 I !! -0.9099259E+01 - X X !! I-----------I-----------I-----------I-----------I !! 0.1000E+01 0.1008E+03 0.2005E+03 0.3002E+03 0.4000E+03 !! !! THE FOLLOWING IS A PLOT OF X(I) (VERTICALLY) VERSUS I (HORIZONTALLY !! I-----------I-----------I-----------I-----------I !! 0.1029407E+02 - X !! 0.9486016E+01 I !! 0.8677961E+01 I !! 0.7869905E+01 I !! 0.7061851E+01 I X !! 0.6253795E+01 I X !! 0.5445739E+01 - !! 0.4637684E+01 I !! 0.3829628E+01 I XX !! 0.3021573E+01 I XX !! 0.2213517E+01 I XXX !! 0.1405462E+01 I XXXXXX !! 0.5974064E+00 - XXXXXXXXXXXX !! -0.2106485E+00 I XXXXXXXXXXXXXXX !! -0.1018704E+01 I XXXXXXXXX !! -0.1826759E+01 I XXXXX !! -0.2634815E+01 I XX !! -0.3442871E+01 I X !! -0.4250926E+01 - X !! -0.5058982E+01 I X !! -0.5867038E+01 I X !! -0.6675092E+01 I !! -0.7483148E+01 I !! -0.8291203E+01 I !! -0.9099259E+01 - X !! I-----------I-----------I-----------I-----------I !! 0.1000E+01 0.1008E+03 0.2005E+03 0.3002E+03 0.4000E+03 !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !! !!##REFERENCES !! * Mood and Grable, Introduction to the Theory of Statistics, 1963, !! page 233. !! * Johnson and Kotz, Continuous Univariate Distributions--2, 1970, !! page 94. !! * Hastings and Peacock, Statistical Distributions--A Handbook for !! Students and Practitioners, 1975, page 121. ! VERSION NUMBER--82.6 ! ORIGINAL VERSION--NOVEMBER 1975. ! UPDATED --DECEMBER 1981. ! UPDATED --MAY 1982. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE TRAN(N,Nu,Iseed,X) INTEGER,intent(in) :: N INTEGER,intent(in) :: Nu INTEGER,intent(inout) :: Iseed REAL(kind=wp),intent(out) :: X(:) REAL(kind=wp) :: anu, arg1, arg2, sum, y(2), z(2), znorm INTEGER i, j !--------------------------------------------------------------------- ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( N<1 ) THEN WRITE (G_IO,99001) 99001 FORMAT (' ***** FATAL ERROR--The first input argument to TRAN(3f) is non-positive *****') WRITE (G_IO,99003) N RETURN ELSEIF ( Nu<=0 ) THEN WRITE (G_IO,99002) 99002 FORMAT (' ***** FATAL ERROR--The second input argument to TRAN(3f) is non-positive *****') WRITE (G_IO,99003) Nu RETURN ELSE ! ! GENERATE N STUDENT'S T RANDOM NUMBERS USING THE DEFINITION THAT ! A STUDENT'S T VARIATE WITH NU DEGREES OF FREEDOM ! EQUALS A NORMAL VARIATE DIVIDED BY A STANDARDIZED CHI VARIATE ! (WHERE THE LATTER EQUALS SQRT(CHI-SQUARED/NU). ! FIRST GENERATE A NORMAL RANDOM NUMBER, ! THEN GENERATE A STANDARDIZED CHI RANDOM NUMBER, ! THEN FORM THE RATIO OF THE FIRST DIVIDED BY THE SECOND. ! anu = Nu DO i = 1 , N CALL UNIRAN(2,Iseed,y) arg1 = -2.0_wp*LOG(y(1)) arg2 = 2.0_wp*G_pi*y(2) znorm = (SQRT(arg1))*(COS(arg2)) sum = 0.0_wp DO j = 1 , Nu , 2 CALL UNIRAN(2,Iseed,y) arg1 = -2.0_wp*LOG(y(1)) arg2 = 2.0_wp*G_pi*y(2) z(1) = (SQRT(arg1))*(COS(arg2)) z(2) = (SQRT(arg1))*(SIN(arg2)) sum = sum + z(1)*z(1) IF ( j/=Nu ) sum = sum + z(2)*z(2) ENDDO X(i) = znorm/SQRT(sum/anu) ENDDO ENDIF 99003 FORMAT (' ','***** The value of the argument is ',I0,' *****') END SUBROUTINE TRAN !> !!##NAME !! trim(3f) - [M_datapac:STATISTICS] computes the sample trimmed mean !! of the data in the input vector X. !! !!##SYNOPSIS !! !! SUBROUTINE TRIM(X,N,P1,P2,Iwrite,Xtrim) !! !! REAL(kind=wp),intent(in) :: X(:) !! INTEGER,intent(in) :: N !! REAL(kind=wp),intent(in) :: P1 !! REAL(kind=wp),intent(in) :: P2 !! INTEGER,intent(in) :: Iwrite !! REAL(kind=wp),intent(out) :: Xtrim !! !!##DESCRIPTION !! TRIM(3f) computes the sample trimmed mean of the data in the input !! vector X. !! !! The trimming is such that the lower 100*P1 % of the data is trimmed !! off and the upper 100*P2 % of the data is trimmed off. !! !!##INPUT ARGUMENTS !! !! X The vector of (unsorted or sorted) observations. !! !! N The integer number of observations in the vector X. !! The maximum allowable value of N for this subroutine is 15000. !! !! P1 The value (between 0.0 and 1.0) which defines what fraction !! of the lower order statistics is to be trimmed off before !! computing the trimmed mean. P1 should be non-negative. !! P1 should be smaller than 1.0 . !! !! P2 The value (between 0.0 and 1.0) which defines what fraction !! of the upper order statistics is to be trimmed off before !! computing the trimmed mean. P2 should be non-negative. !! P2 should be smaller than 1.0. The sum of P1 and P2 should !! be smaller than 1.0. !! !! IWRITE An integer flag code which (if set to 0) will suppress the !! printing of the sample trimmed mean as it is computed; or !! (if set to some integer value not equal to 0), like, say, !! "1" will cause the printing of the sample trimmed mean at the !! time it is computed. !! !!##OUTPUT ARGUMENTS !! !! XTRIM The value of the computed sample trimmed mean where 100*P1 % !! of the smallest and 100*P2 % of the largest ordered observations !! have been trimmed away before computing the mean of the remaining !! observations in the middle. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_trim !! use M_datapac, only : trim !! implicit none !! ! call trim(x,y) !! end program demo_trim !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !! !!##REFERENCES !! * David, Order Statistics, 1970, pages 126-130, 136. !! * Crow and Siddiqui, 'Robust Estimation of Location', Journal of the !! American Statistical Association, 1967, pages 357, 387. !! * Filliben, Simple and Robust Linear Estimation of the Location !! Parameter of a Symmetric Distribution (Unpublished PH.D. Dissertation, !! Princeton University, 1969). ! ORIGINAL VERSION--NOVEMBER 1975. ! UPDATED --FEBRUARY 1976. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE TRIM(X,N,P1,P2,Iwrite,Xtrim) REAL(kind=wp),intent(in) :: X(:) INTEGER,intent(in) :: N REAL(kind=wp),intent(in) :: P1 REAL(kind=wp),intent(in) :: P2 INTEGER,intent(in) :: Iwrite REAL(kind=wp),intent(out) :: Xtrim REAL(kind=wp) :: ak, an, hold, perp1, perp2, perp3, psum,sum, WS, Y INTEGER i, istart, istop, iupper, k, np1, np2 DIMENSION Y(15000) COMMON /BLOCK2_real32/ WS(15000) EQUIVALENCE (Y(1),WS(1)) !--------------------------------------------------------------------- iupper = 15000 ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! an = N IF ( N<1 .OR. N>iupper ) THEN WRITE (G_IO,99001) iupper 99001 format (' ***** FATAL ERROR--The second input argument to TRIM(3f) is outside the allowable (1,',& & I0,') interval *****') WRITE (G_IO,99002) N 99002 FORMAT (' ','***** The value of the argument is ',I0,' *****') RETURN ELSE IF ( N==1 ) THEN WRITE (G_IO,99003) 99003 FORMAT (' ***** NON-FATAL DIAGNOSTIC--The second input argument to TRIM(3f) has the value 1 *****') Xtrim = X(1) ELSE hold = X(1) DO i = 2 , N IF ( X(i)/=hold ) GOTO 50 ENDDO WRITE (G_IO,99004) hold 99004 FORMAT (' ***** NON-FATAL DIAGNOSTIC--The first input argument (a vector) TO TRIM(3f) has all elements = ',& & E15.8,' *****') Xtrim = X(1) ENDIF GOTO 100 50 IF ( P1<0.0_wp .OR. P1>=1.0_wp ) THEN WRITE (G_IO,99005) 99005 FORMAT (& &' ***** FATAL ERROR--The third input argument to TRIM(3f) is outside the allowable (0.0,1.0) interval *****') WRITE (G_IO,99017) P1 Xtrim = 0.0_wp RETURN ELSEIF ( P2<0.0_wp .OR. P2>=1.0_wp ) THEN WRITE (G_IO,99006) 99006 FORMAT (& & ' ***** FATAL ERROR--The fourth input argument to TRIM(3f) is outside the allowable (0.0,1.0) interval *****') WRITE (G_IO,99017) P2 Xtrim = 0.0_wp RETURN ELSE psum = P1 + P2 IF ( psum<0.0_wp .OR. psum>=1.0_wp ) THEN WRITE (G_IO,99007) 99007 FORMAT (' ', & & '***** FATAL ERROR--THE SUM OF INPUT ARGUMENTS ',& & '3 AND 4 TO THE TRIM SUBROUTINE IS OUTSIDE THE ALLOWABLE '& & ,'(0.0,1.0) INTERVAL *****') WRITE (G_IO,99008) P1 99008 FORMAT (' ',' INPUT ARGUMENT 3 = ',E15.8) WRITE (G_IO,99009) P2 99009 FORMAT (' ',' INPUT ARGUMENT 4 = ',E15.8) WRITE (G_IO,99010) psum 99010 FORMAT (' ',' INPUT ARGUMENT 3 + INPUT ARGUMENT 4 = ',E15.8) Xtrim = 0.0_wp RETURN ELSE ! !-----START POINT----------------------------------------------------- ! CALL SORT(X,N,Y) ! an = N np1 = P1*an + 0.0001_wp istart = np1 + 1 np2 = P2*an + 0.0001_wp istop = N - np2 sum = 0.0_wp k = 0 IF ( istart>istop ) THEN WRITE (G_IO,99011) 99011 FORMAT (' Internal error in TRIM(3f) --the start index is higher than the stop index') Xtrim = 0.0_wp RETURN ELSE DO i = istart , istop k = k + 1 sum = sum + X(i) ENDDO ak = k Xtrim = sum/ak ENDIF ENDIF ENDIF ENDIF ! 100 IF ( Iwrite==0 ) RETURN perp1 = 100.0_wp*P1 perp2 = 100.0_wp*P2 perp3 = 100.0_wp - perp1 - perp2 WRITE (G_IO,99012) 99012 FORMAT (' ') WRITE (G_IO,99013) N , Xtrim 99013 FORMAT (' ','The sample trimmed mean of the ',I0,' observations is ',E15.8) WRITE (G_IO,99014) perp1 , np1 99014 FORMAT (' ',8X,F10.4,' Percent (= ',i0,' observations) of the data were trimmed from below') WRITE (G_IO,99015) perp2 , np2 99015 FORMAT (' ',8X,F10.4,' Percent (= ',i0,' observations) of the data were trimmed from above') WRITE (G_IO,99016) perp3 , k 99016 FORMAT (' ',8X,F10.4,' percent (= ',i0,' observations) of the data remain in the middle after the trimming') 99017 FORMAT (' ','***** The value of the argument is ',E15.8,' *****') ! END SUBROUTINE TRIM !> !!##NAME !! unicdf(3f) - [M_datapac:CUMULATIVE_DISTRIBUTION] trivially compute the Uniform !! cumulative distribution function !! !!##SYNOPSIS !! !! subroutine unicdf(X,Cdf) !! !! real(kind=wp), intent(in) :: X !! real(kind=wp), intent(out) :: Cdf !! !!##DESCRIPTION !! UNICDF(3f) computes the cumulative distribution function value for !! the uniform (rectangular) distribution on the unit interval (0,1). !! !! This distribution has mean = 0.5 and standard deviation = sqrt(1/12) !! = 0.28867513. !! !! This distribution has the probability density function f(x) = x. !! !! That is, this is a trivial function as the output equals the input. !! !!##INPUT ARGUMENTS !! !! X The value at which the cumulative distribution function is to !! be evaluated. X should be between 0 and 1, inclusively. !! !!##OUTPUT ARGUMENTS !! !! CDF the REAL cumulative distribution function value. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_unicdf !! !@(#) line plotter graph of function !! use M_datapac, only : unicdf, plott, label !! implicit none !! integer,parameter :: n=40 !! real :: x(0:n), y(0:n) !! integer :: i !! call label('unicdf') !! x=[(real(i)/real(n),i=0,n)] !! do i=0,n !! call unicdf(x(i),y(i)) !! enddo !! call plott(x,y,n+1) !! end program demo_unicdf !! !! Result: !! !! The following is a plot of Y(I) (vertically) versus X(I) (horizontally) !! I-----------I-----------I-----------I-----------I !! 0.1000000E+01 - X !! 0.9583333E+00 I XX !! 0.9166667E+00 I XX !! 0.8750000E+00 I X !! 0.8333333E+00 I XX !! 0.7916666E+00 I XX !! 0.7500000E+00 - X !! 0.7083333E+00 I XX !! 0.6666666E+00 I XX !! 0.6250000E+00 I X !! 0.5833333E+00 I XX !! 0.5416666E+00 I XX !! 0.5000000E+00 - X !! 0.4583333E+00 I XX !! 0.4166666E+00 I XX !! 0.3750000E+00 I X !! 0.3333333E+00 I XX !! 0.2916666E+00 I XX !! 0.2500000E+00 - X !! 0.2083333E+00 I XX !! 0.1666666E+00 I XX !! 0.1250000E+00 I X !! 0.8333331E-01 I XX !! 0.4166663E-01 I XX !! 0.0000000E+00 - X !! I-----------I-----------I-----------I-----------I !! 0.0000E+00 0.2500E+00 0.5000E+00 0.7500E+00 0.1000E+01 !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !! !!##REFERENCES !! * Johnson and Kotz, Continuous Univariate Distributions -- 2, 1970, !! pages 57-74. ! ORIGINAL VERSION--JUNE 1972. ! UPDATED --SEPTEMBER 1975. ! UPDATED --NOVEMBER 1975. ! UPDATED --JUNE 2022. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 subroutine unicdf(X,Cdf) real(kind=wp), intent(in) :: X real(kind=wp), intent(out) :: Cdf if ( X < 0.0_wp .or. X > 1.0_wp ) then ! CHECK THE INPUT ARGUMENTS FOR ERRORS write (g_io,99001) 99001 format (' ***** NON-FATAL DIAGNOSTIC--The first input argument to UNICDF(3f) is outside the usual (0,1) interval *****') write (g_io,99002) X 99002 format (' ***** The value of the argument is ',E15.8,' *****') if ( X < 0.0_wp ) then Cdf = 0.0_wp else if ( X > 1.0_wp ) then Cdf = 1.0_wp else stop '**unicdf** should not get here' endif else Cdf = X endif end subroutine unicdf !> !!##NAME !! unimed(3f) - [M_datapac:STATISTICS] generates the N order statistic !! medians from the uniform (rectangular) distribution on the unit !! interval (0,1). !! !!##SYNOPSIS !! !! SUBROUTINE UNIMED(N,X) !! !! INTEGER,intent(in) :: N !! REAL(kind=wp),intent(out) :: X(:) !! !!##DESCRIPTION !! !! UNIMED(3f) generates the N order statistic medians from the uniform !! (rectangular) distribution on the unit interval (0,1). !! !! This distribution has mean = 0.5 and standard deviation = sqrt(1/12) !! = 0.28867513. This distribution has the probability density function !! f(X) = 1. !! !! UNIMED(3f) is a support subroutine for all of the probability plot !! subroutines in datapac; it is rarely used by the data analyst directly. !! !! A probability plot for a general distribution is a plot of the ordered !! observations versus the order statistic medians for that distribution. !! !! The i-th order statistic median for a general distribution is obtained !! by transforming the i-th uniform order statistic median by the percent !! point function of the desired distribution--hence the importance of !! being able to generate uniform order statistic medians. !! !! It is of theoretical interest to note that the i-th uniform order !! statistic median in a sample of size N is identically the median of !! the beta distribution with parameters i and N-i+1. !! !!##INPUT ARGUMENTS !! !! N The desired integer number of uniform order statistic medians !! to be generated. !! !!##OUTPUT ARGUMENTS !! !! X A vector (of dimension at least N) into which the generated !! uniform order statistic medians will be placed. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_unimed !! use M_datapac, only : unimed, label, plotxt !! implicit none !! integer,parameter :: N=100 !! real :: X(N) !! call label('unimed') !! call unimed(N,X) !! call plotxt(x,n) !! end program demo_unimed !! !! Results: !! !! THE FOLLOWING IS A PLOT OF X(I) (VERTICALLY) VERSUS I (HORIZONTALLY !! I-----------I-----------I-----------I-----------I !! 0.9930925E+00 - XX !! 0.9520015E+00 I XXX !! 0.9109104E+00 I XXX !! 0.8698193E+00 I XXX !! 0.8287283E+00 I XXX !! 0.7876373E+00 I XXX !! 0.7465463E+00 - XXX !! 0.7054552E+00 I XXX !! 0.6643642E+00 I XXX !! 0.6232731E+00 I XXX !! 0.5821820E+00 I XXX !! 0.5410910E+00 I XXX !! 0.5000000E+00 - XXX !! 0.4589090E+00 I XXX !! 0.4178179E+00 I XXX !! 0.3767269E+00 I XXX !! 0.3356358E+00 I XXX !! 0.2945448E+00 I XXX !! 0.2534538E+00 - XXX !! 0.2123627E+00 I XXX !! 0.1712717E+00 I XXX !! 0.1301807E+00 I XXX !! 0.8908957E-01 I XXX !! 0.4799855E-01 I XXX !! 0.6907523E-02 - XX !! I-----------I-----------I-----------I-----------I !! 0.1000E+01 0.2575E+02 0.5050E+02 0.7525E+02 0.1000E+03 !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !! !!##REFERENCES !! * Filliben, 'The Probability Plot Correlation Coefficient Test for !! Normality', Technometrics, 1975, pages 111-117. ! ORIGINAL VERSION--JUNE 1972. ! UPDATED --SEPTEMBER 1975. ! UPDATED --NOVEMBER 1975. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE UNIMED(N,X) INTEGER,intent(in) :: N REAL(kind=wp),intent(out) :: X(:) REAL(kind=wp) :: ai, an, gam INTEGER :: i, imax, irev, nevodd, nhalf !--------------------------------------------------------------------- ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( N<1 ) THEN WRITE (G_IO,99001) 99001 FORMAT (' ***** FATAL ERROR--The first input argument to UNIMED(3f) is non-positive *****') WRITE (G_IO,99002) N 99002 FORMAT (' ***** The value of the argument is ',I0,' *****') RETURN ELSE IF ( N==1 ) THEN WRITE (G_IO,99003) 99003 FORMAT (' ***** NON-FATAL DIAGNOSTIC--The first input argument to UNIMED(3f) has the value 1 *****') ENDIF an = N ! ! COMPUTE THE MEDIANS FOR THE FIRST AND LAST ORDER STATISTICS ! X(N) = 0.5_wp**(1.0_wp/an) X(1) = 1.0_wp - X(N) ! ! DETERMINE IF AN ODD OR EVEN SAMPLE SIZE ! nhalf = (N/2) + 1 nevodd = 2*(N/2) IF ( N/=nevodd ) X(nhalf) = 0.5_wp IF ( N<=3 ) RETURN ! ! COMPUTE THE MEDIANS FOR THE OTHER ORDER STATISTICS ! gam = 0.3175_wp imax = N/2 DO i = 2 , imax ai = i irev = N - i + 1 X(i) = (ai-gam)/(an-2.0_wp*gam+1.0_wp) X(irev) = 1.0_wp - X(i) ENDDO ENDIF END SUBROUTINE UNIMED !> !!##NAME !! unipdf(3f) - [M_datapac:PROBABILITY_DENSITY] trivially compute the !! Uniform probability density function !! !!##SYNOPSIS !! !! SUBROUTINE UNIPDF(X,Pdf) !! !! REAL(kind=wp),intent(in) :: X !! REAL(kind=wp),intent(out) :: Pdf !! !!##DESCRIPTION !! UNIPDF(3f) computes the probability density function value for the !! uniform (rectangular) distribution on the unit interval (0,1). !! !! This distribution has mean = 0.5 and standard deviation = sqrt(1/12) !! = 0.28867513. this distribution has the probability density function !! !! f(X) = 1 !! !! That is, trivially no matter what the input the output is 1. !! !!##INPUT ARGUMENTS !! !! X The REAL value at which the probability density !! function is to be evaluated. X should be between 0 and 1, !! inclusively. !! !!##OUTPUT ARGUMENTS !! !! PDF The REAL probability density function value. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_unipdf !! !@(#) line plotter graph of probability density function !! use M_datapac, only : unipdf, label !! implicit none !! real,allocatable :: x(:), y(:) !! integer :: i !! call label('unipdf') !! x=[(real(i)/10.0,i=0,10,1)] !! if(allocated(y))deallocate(y) !! allocate(y(size(x))) !! do i=1,size(x) !! call unipdf( x(i), y(i) ) !! enddo !! write(*,*)y !! end program demo_unipdf !! !! Results: !! !! 1.00 1.000000 1.000000 1.000000 1.000000 !! 1.00 1.000000 1.000000 1.000000 1.000000 !! 1.00 !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !! !!##REFERENCES !! * Johnson and Kotz, Continuous Univariate Distributions--2, 1970, pages 57-74. ! ORIGINAL VERSION--JUNE 1972. ! UPDATED --SEPTEMBER 1975. ! UPDATED --NOVEMBER 1975. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE UNIPDF(X,Pdf) REAL(kind=wp),intent(in) :: X REAL(kind=wp),intent(out) :: Pdf ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( X<0.0_wp .OR. X>1.0_wp ) THEN WRITE (G_IO,99001) 99001 FORMAT(& & ' ***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT TO UNIPDF(3f) IS OUTSIDE THE USUAL (0,1) INTERVAL *****') WRITE (G_IO,99002) X 99002 FORMAT(' ','***** THE VALUE OF THE ARGUMENT IS ',E15.8, ' *****') Pdf = 0.0_wp RETURN ELSE Pdf = 1.0_wp ENDIF ! END SUBROUTINE UNIPDF !> !!##NAME !! uniplt(3f) - [M_datapac:LINE_PLOT] generate a Uniform probability plot !! (line printer graph) !! !!##SYNOPSIS !! !! SUBROUTINE UNIPLT(X,N) !! !! REAL(kind=wp),intent(in) :: X(:) !! INTEGER,intent(in) :: N !! !!##DESCRIPTION !! UNIPLT(3f) generates a uniform probability plot. !! !! The prototype uniform distribution used herein is defined on the !! unit interval (0,1). This distribution has mean = 0.5 and standard !! deviation = sqrt(1/12) = 0.28867513. !! !! This distribution has the probability density function !! !! f(X) = 1 !! !! As used herein, a probability plot for a distribution is a plot !! of the ordered observations versus the order statistic medians for !! that distribution. !! !! The uniform probability plot is useful in graphically testing !! the composite (that is, location and scale parameters need not be !! specified) hypothesis that the underlying distribution from which !! the data have been randomly drawn is the uniform distribution. !! !! If the hypothesis is true, the probability plot should be near-linear. !! !! A measure of such linearity is given by the calculated probability !! plot correlation coefficient. !! !!##INPUT ARGUMENTS !! !! X The vector of (unsorted or sorted) observations. !! !! N The integer number of observations in the vector X. !! The maximum allowable value of N for this subroutine is 7500. !! !!##OUTPUT !! A one-page uniform probability plot. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_uniplt !! use M_datapac, only : uniplt, label !! implicit none !! call label('uniplt') !! ! call uniplt(x,y) !! end program demo_uniplt !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !! !!##REFERENCES !! * Filliben, 'Techniques for Tail Length Analysis', Proceedings of the !! Eighteenth Conference on the Design of Experiments in Army REsearch !! Development and Testing (Aberdeen, Maryland, October, 1972), pages !! 425-450. !! * Hahn and Shapiro, Statistical Methods in Engineering, 1967, pages !! 260-308. !! * Johnson and Kotz, Continuous Univariate Distributions--2, 1970, !! pages 57-74. ! ORIGINAL VERSION--JUNE 1972. ! UPDATED --SEPTEMBER 1975. ! UPDATED --NOVEMBER 1975. ! UPDATED --FEBRUARY 1976. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE UNIPLT(X,N) REAL(kind=wp),intent(in) :: X(:) INTEGER,intent(in) :: N REAL(kind=wp) :: an, cc, hold, sum1, sum2, sum3, tau, W, wbar, WS, Y, ybar, yint, yslope INTEGER :: i, iupper DIMENSION Y(7500) , W(7500) COMMON /BLOCK2_real32/ WS(15000) EQUIVALENCE (Y(1),WS(1)) EQUIVALENCE (W(1),WS(7501)) ! DATA tau/1.04736842_wp/ ! iupper = 7500 ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( N<1 .OR. N>iupper ) THEN WRITE (G_IO,99001) iupper 99001 FORMAT (' ***** FATAL ERROR--The second input argument to UNIPLT(3f) is outside the allowable (1,',& & I0,') interval *****') WRITE (G_IO,99002) N 99002 FORMAT (' ','***** The value of the argument is ',I0,' *****') RETURN ELSEIF ( N==1 ) THEN WRITE (G_IO,99003) 99003 FORMAT (' ***** NON-FATAL DIAGNOSTIC--The second input argument to UNIPLT(3f) has the value 1 *****') RETURN ELSE hold = X(1) DO i = 2 , N IF ( X(i)/=hold ) GOTO 50 ENDDO WRITE (G_IO,99004) hold 99004 FORMAT (' ***** NON-FATAL DIAGNOSTIC--The first input argument (a vector) to UNIPLT(3f) has all elements = ', & & E15.8,' *****') ! !-----START POINT----------------------------------------------------- ! 50 an = N ! ! SORT THE DATA ! CALL SORT(X,N,Y) ! ! GENERATE UNIFORM ORDER STATISTIC MEDIANS ! CALL UNIMED(N,W) ! ! PLOT THE ORDERED OBSERVATIONS VERSUS ORDER STATISTICS MEDIANS. ! WRITE OUT THE TAIL LENGTH MEASURE OF THE DISTRIBUTION ! AND THE SAMPLE SIZE. ! CALL PLOT(Y,W,N) WRITE (G_IO,99005) tau , N 99005 FORMAT (' ','Uniform probability plot (TAU = ',E15.8,')',55X,'The sample size N = ',I0) ! ! COMPUTE THE PROBABILITY PLOT CORRELATION COEFFICIENT. ! COMPUTE LOCATION AND SCALE ESTIMATES ! FROM THE INTERCEPT AND SLOPE OF THE PROBABILITY PLOT. ! THEN WRITE THEM OUT. ! sum1 = 0.0_wp DO i = 1 , N sum1 = sum1 + Y(i) ENDDO ybar = sum1/an wbar = 0.5_wp sum1 = 0.0_wp sum2 = 0.0_wp sum3 = 0.0_wp DO i = 1 , N sum1 = sum1 + (Y(i)-ybar)*(Y(i)-ybar) sum2 = sum2 + (W(i)-0.5_wp)*(Y(i)-ybar) sum3 = sum3 + (W(i)-0.5_wp)*(W(i)-0.5_wp) ENDDO cc = sum2/SQRT(sum3*sum1) yslope = sum2/sum3 yint = ybar - yslope*wbar WRITE (G_IO,99006) cc , yint , yslope 99006 FORMAT (' ','Probability plot correlation coefficient = ',F8.5,& & 5X,'Estimated intercept = ',E15.8,3X,'Estimated slope = ',E15.8) ENDIF END SUBROUTINE UNIPLT !> !!##NAME !! unippf(3f) - [M_datapac:PERCENT_POINT] compute the Uniform percent !! point function !! !!##SYNOPSIS !! !! SUBROUTINE UNIPPF(P,Ppf) !! !! REAL(kind=wp),intent(in) :: P !! REAL(kind=wp),intent(out) :: Ppf !! !!##DESCRIPTION !! UNIPPF(3f) computes the percent point function value for the uniform !! (rectangular) distribution on the unit interval (0,1). !! !! This distribution has mean = 0.5 and standard deviation = sqrt(1/12) !! = 0.28867513. This distribution has the probability density function !! !! f(X) = 1 !! !! Note that the percent point function of a distribution is identically !! the same as the inverse cumulative distribution function of the !! distribution. !! !!##INPUT ARGUMENTS !! !! P The value (between 0.0 and 1.0) at which the percent point !! function is to be evaluated. !! !!##OUTPUT ARGUMENTS !! !! PPF The percent point function value. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_unippf !! use M_datapac, only : unippf, label !! implicit none !! call label('unippf') !! ! call unippf(x,y) !! end program demo_unippf !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !! !!##REFERENCES !! * Filliben, Simple and Robust Linear Estimation of the Location Parameter !! of a Symmetric Distribution (Unpublished PH.D. Dissertation, Princeton !! University), 1969, pages 21-44, 229-231. !! * Filliben, 'The Percent Point Function', (Unpublished Manuscript), !! 1970, pages 28-31. !! * Johnson and Kotz, Continuous Univariate Distributions--2, 1970, !! pages 57-74. ! ORIGINAL VERSION--JUNE 1972. ! UPDATED --SEPTEMBER 1975. ! UPDATED --NOVEMBER 1975. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE UNIPPF(P,Ppf) REAL(kind=wp),intent(in) :: P REAL(kind=wp),intent(out) :: Ppf ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( P<0.0_wp .OR. P>1.0_wp ) THEN WRITE (G_IO,99001) 99001 FORMAT (' ***** FATAL ERROR--The first input argument to UNIPPF(3f) is outside the allowable (0,1) interval *****') WRITE (G_IO,99002) P 99002 FORMAT (' ','***** The value of the argument is ',E15.8,' *****') RETURN ELSE Ppf = P ENDIF END SUBROUTINE UNIPPF !> !!##NAME !! uniran(3f) - [M_datapac:RANDOM] generate Uniform random numbers !! !!##SYNOPSIS !! !! SUBROUTINE UNIRAN(N,Iseed,X) !! !! INTEGER,intent(in) :: N !! INTEGER,intent(inout) :: Iseed !! REAL(kind=wp),intent(out) :: X(:) !! !!##DESCRIPTION !! UNIRAN(3f) generates a random sample of size N from the uniform !! (rectangular) distribution on the unit interval (0,1). !! !! This distribution has mean = 0.5 and standard deviation = sqrt(1/12) !! = 0.28867513. This distribution has the probability density function !! !! f(X) = 1 !! !!##INPUT ARGUMENTS !! !! N The desired integer number of random numbers to be generated. !! !! ISEED An integer iseed value. Should be set to a non-negative value !! to start a new sequence of values. Will be set to -1 on return !! to indicate the next call should continue the current random !! sequence walk. !! !!##OUTPUT ARGUMENTS !! !! X A vector (of dimension at least N) into which the generated !! random sample of size N from the rectangular distribution on !! (0,1) will be placed. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_uniran !! use M_datapac, only : uniran, plotxt, sort, label !! implicit none !! integer,parameter :: n=400 !! real :: x(n) !! integer :: iseed !! call label('uniran') !! iseed=1234 !! call UNIRAN(n,Iseed,X) !! call plotxt(x,n) ! plot random values !! call sort(x,n,x) ! sort values !! call plotxt(x,n) ! should display the f(x)=1 nature !! ! of the distribution !! end program demo_uniran !! !! Results: !! !! THE FOLLOWING IS A PLOT OF X(I) (VERTICALLY) VERSUS I (HORIZONTALLY !! I-----------I-----------I-----------I-----------I !! 0.9982013E+00 - X X X X X X X !! 0.9566447E+00 I X XX X XX XXXX X XX !! 0.9150882E+00 I X XXXX X XXXX X X X X X XX X X !! 0.8735316E+00 I XX XXX XX XXXXXX X X X X X !! 0.8319750E+00 I XXX X X X X X XX X X X !! 0.7904184E+00 I XXX XX X X X X X XXX !! 0.7488618E+00 - X XX X X X X X X X X X XXX X !! 0.7073053E+00 I X X X X X X X X X X X X !! 0.6657487E+00 I X XXX X XX XXX X X X X X X X !! 0.6241921E+00 I X X X X XX X X X X !! 0.5826355E+00 I X X X XX X X X X X !! 0.5410789E+00 I XX X XX X X XXX XX X X !! 0.4995224E+00 - X X XX X XXX XX !! 0.4579658E+00 I XXX X XXX X X X XX XX X X X X !! 0.4164092E+00 I XX X X X X X X X X X !! 0.3748527E+00 I XX XX XX X X XX XX XX X X !! 0.3332961E+00 I X XXX X X X X X XXXX X X !! 0.2917395E+00 I X X X X X X XX XX XX X !! 0.2501829E+00 - XX XXX X X X X XX XXXX X !! 0.2086263E+00 I X X X X X X XX X X XX !! 0.1670697E+00 I X X X XX X XX XX XXX X X XXX X !! 0.1255132E+00 I X XXX X X X X XX X !! 0.8395660E-01 I X X X X XX X X X X X X X XX !! 0.4240000E-01 I X XX X X X X X X X X X !! 0.8433913E-03 - X X X X X !! I-----------I-----------I-----------I-----------I !! 0.1000E+01 0.1008E+03 0.2005E+03 0.3002E+03 0.4000E+03 !! !! THE FOLLOWING IS A PLOT OF X(I) (VERTICALLY) VERSUS I (HORIZONTALLY !! I-----------I-----------I-----------I-----------I !! 0.9982013E+00 - XX !! 0.9566447E+00 I XXX !! 0.9150882E+00 I XXXX !! 0.8735316E+00 I XXX !! 0.8319750E+00 I XXX !! 0.7904184E+00 I XXX !! 0.7488618E+00 - XXX !! 0.7073053E+00 I XXX !! 0.6657487E+00 I XXX !! 0.6241921E+00 I XX !! 0.5826355E+00 I XXX !! 0.5410789E+00 I XXX !! 0.4995224E+00 - XX !! 0.4579658E+00 I XXXX !! 0.4164092E+00 I XX !! 0.3748527E+00 I XXX !! 0.3332961E+00 I XXX !! 0.2917395E+00 I XX !! 0.2501829E+00 - XXXX !! 0.2086263E+00 I XX !! 0.1670697E+00 I XXXX !! 0.1255132E+00 I XXX !! 0.8395660E-01 I XXX !! 0.4240000E-01 I XX !! 0.8433913E-03 - X !! I-----------I-----------I-----------I-----------I !! 0.1000E+01 0.1008E+03 0.2005E+03 0.3002E+03 0.4000E+03 !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##WRITTEN BY !! * James Blue !! !! Scientific Computing Division !! Center for Applied Mathematics !! National Bureau of Standards !! Washington, D. C. 20234 !! !! * David Kahaner !! !! Scientific Computing Division !! Center for Applied Mathematics !! National Bureau of Standards !! !! * George Marsaglia !! !! Computer Science Department !! Washington State University !! !! * James J. Filliben !! !! Statistical Engineering Division !! Center for Applied Mathematics !! National Bureau of Standards !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !! !!##REFERENCES !! * Marsaglia G., "Comments on the Perfect Uniform Random Number !! Generator", Unpublished Notes, Wash S. U. !! * Johnson and Kotz, Continuous Univariate Distributions--2, 1970, !! pages 57-74. ! ORIGINAL VERSION--JUNE 1972. ! UPDATED --AUGUST 1974. ! UPDATED --SEPTEMBER 1975. ! UPDATED --NOVEMBER 1975. ! UPDATED --NOVEMBER 1981. ! UPDATED --MAY 1982. ! UPDATED --MARCH 1984. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE UNIRAN(N,Iseed,X) INTEGER,intent(in) :: N INTEGER,intent(inout) :: Iseed REAL(kind=wp),intent(out) :: X(:) REAL(kind=wp) :: ak , am1 INTEGER i, iseed3, j, j0, j1, k, k0, k1, l, m1, m2, mdig INTEGER m(17) ! MODE OF INTERNAL OPERATIONS--. ! ! ALGORITHM--FIBONACCI GENERATOR AS DEFINED BY GEORGE MARSAGLIA. ! ! NOTE--THIS GENERATOR IS TRANSPORTABLE. ! IT IS NOT MACHINE-INDEPENDENT ! IN THE SENSE THAT FOR A GIVEN VALUE ! OF THE INPUT SEED ISEED AND FOR A GIVEN VALUE ! OF MDIG (TO BE DEFINED BELOW), ! THE SAME SEQUENCE OF UNIFORM RANDOM ! NUMBERS WILL RESULT ON DIFFERENT COMPUTERS ! (VAX, PRIME, PERKIN-ELMER, IBM, UNIVAC, HONEYWELL, ETC.) ! ! NOTE--IF MDIG = 32 AND IF ISEED = 305, ! THEN THE OUTPUT FROM THIS GENERATOR SHOULD BE AS FOLLOWS-- ! THE FIRST NUMBER TO RESULT IS .4771580... ! THE SECOND NUMBER TO RESULT IS .4219293... ! THE THIRD NUMBER TO RESULT IS .6646181... ! ... ! THE THOUSANDTH NUMBER TO RESULT IS .2036834... ! ! NOTE--IF MDIG = 16 AND IF ISEED = 305, ! THEN THE OUTPUT FROM THIS GENERATOR SHOULD BE AS FOLLOWS-- ! THE FIRST NUMBER TO RESULT IS .027832881... ! THE SECOND NUMBER TO RESULT IS .56102176... ! THE THIRD NUMBER TO RESULT IS .41456343... ! ... ! THE THOUSANDTH NUMBER TO RESULT IS .19797357... ! ! NOTE--IT IS RECOMMENDED THAT UPON ! IMPLEMENTATION OF DATAPLOT, THE OUTPUT ! FROM UNIRAN BE CHECKED FOR AGREEMENT ! WITH THE ABOVE SAMPLE OUTPUT. ! ALSO, THERE ARE MANY ANALYSIS AND DIAGNOSTIC ! TOOLS IN DATAPLOT THAT WILL ALLOW THE ! TESTING OF THE RANDOMNESS AND UNIFORMITY ! OF THIS GENERATOR. ! SUCH CHECKING IS ESPECIALLY IMPORTANT ! IN LIGHT OF THE FACT THAT OTHER DATAPLOT RANDOM ! NUMBER GENERATOR SUBROUTINES (NORRAN--NORMAL, ! LOGRAN--LOGISTIC, ETC.) ALL MAKE USE OF INTERMEDIATE ! OUTPUT FROM UNIRAN. ! ! NOTE--THE OUTPUT FROM THIS SUBROUTINE DEPENDS ! ON THE INPUT SEED (ISEED) AND ON THE ! VALUE OF MDIG. ! MDIG MAY NOT BE SMALLER THAN 16. ! MDIG MAY NOT BE LARGER THAN MAX INTEGER ON YOUR COMPUTER. ! ! NOTE--BECAUSE OF THE PREPONDERANCE OF MAINFRAMES ! WHICH HAVE WORDS OF 32 BITS AND LARGER ! (E.G, VAX (= 32 BITS), UNIVAC (= 36 BITS), CDC (= 60 BITS), ETC.) ! MDIG HAS BEEN SET TO 32. ! THUS THE SAME SEQUENCE OF RANDOM NUMBERS SHOULD RESULT ! ON ALL OF THESE COMPUTERS. ! ! NOTE--FOR SMALLER WORD SIZE COMPUTERS (E.G., 24-BIT AND 16-BIT), ! THE VALUE OF MDIG SHOULD BE CHANGED TO 24 OR 16. ! IN SUCH CASE, THE OUTPUT WILL NOT BE IDENTICAL TO ! THE OUTPUT WHEN MDIG = 32. ! ! NOTE--THE CYCLE OF THE RANDOM NUMBERS DEPENDS ON MDIG. ! THE CYCLE FROM MDIG = 32 IS LONG ENOUGH FOR MOST ! PRACTICAL APPLICATIONS. ! IF A LONGER CYCLE IS DESIRED, THEN INCREASE MDIG. ! ! NOTE--THE SEED MAY BE ANY POSITIVE INTEGER. ! NO APPRECIABLE DIFFERENCE IN THE QUALITY ! OF THE RANDOM NUMBERS HAS BEEN NOTED ! BY THE CHOICE OF THE SEED. THERE IS NO ! NEED TO USE PRIMES, NOR TO USE EXCEPTIONALLY ! LARGE NUMBERS, ETC. ! !-----SAVE STATEMENTS------------------------------------------------- ! SAVE i , j , m , m1 , m2 ! !-----DATA STATEMENTS------------------------------------------------- ! DATA m(1) , m(2) , m(3) , m(4) , m(5) , m(6) , m(7) , m(8) , & & m(9) , m(10) , m(11) , m(12) , m(13) , m(14) , m(15) , & & m(16) , m(17)/30788 , 23052 , 2053 , 19346 , 10646 , 19427 , & & 23975 , 19049 , 10949 , 19693 , 29746 , 26748 , 2796 , & & 23890 , 29168 , 31924 , 16499/ DATA m1 , m2 , i , j/32767 , 256 , 5 , 17/ ! !-----START POINT----------------------------------------------------- ! ! ******************************************** ! ** STEP 1-- ** ! ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** ! ******************************************** ! IF ( N>=1 ) THEN ! ! ******************************************************* ! ** STEP 2-- ** ! ** IF A POSITIVE INPUT SEED HAS BEEN GIVEN, ** ! ** THEN THIS INDICATES THAT THE GENERATOR ** ! ** SHOULD HAVE ITS INTERNAL M(.) ARRAY REDEFINED-- ** ! ** DO SO IN THIS SECTION. ** ! ** IF A NON-POSITIVE INPUT SEED HAS BEEN GIVEN, ** ! ** THEN THIS INDICATES THAT THE GENERATOR ** ! ** SHOULD CONTINUE ON FROM WHERE IT LEFT OFF, ** ! ** AND THEREFORE THIS SECTION IS SKIPPED. ** ! ******************************************************* ! IF ( Iseed>0 ) THEN ! mdig = 32 ! m1 = 2**(mdig-2) + (2**(mdig-2)-1) m2 = 2**(mdig/2) iseed3 = IABS(Iseed) IF ( m1<IABS(Iseed) ) iseed3 = m1 IF ( MOD(iseed3,2)==0 ) iseed3 = iseed3 - 1 k0 = MOD(9069,m2) k1 = 9069/m2 j0 = MOD(iseed3,m2) j1 = iseed3/m2 ! DO i = 1 , 17 iseed3 = j0*k0 j1 = MOD(iseed3/m2+j0*k1+j1*k0,m2/2) j0 = MOD(iseed3,m2) m(i) = j0 + m2*j1 ENDDO ! i = 5 j = 17 ENDIF ! ! ! ************************************* ! ** STEP 3-- ** ! ** GENERATE THE N RANDOM NUMBERS ** ! ************************************* ! DO l = 1 , N k = m(i) - m(j) IF ( k<0 ) k = k + m1 m(j) = k i = i - 1 IF ( i==0 ) i = 17 j = j - 1 IF ( j==0 ) j = 17 ak = k am1 = m1 X(l) = ak/am1 ENDDO ! ! ***************************************************** ! ** STEP 4-- ** ! ** REGARDLESS OF THE VALUE OF THE INPUT SEED, ** ! ** REDEFINE THE VALUE OF ISEED UPON EXIT HERE ** ! ** TO -1 WITH THE NET EFFECT THAT ** ! ** IF THE USER DOES NOT REDEFINE THE SEED ** ! ** VALUE BEFORE THE NEXT CALL TO THIS GENERATOR, ** ! ** THEN THIS GENERATOR WILL PICK UP ** ! ** WHERE IT LEFT OFF. ** ! ***************************************************** ! Iseed = (-1) ELSE WRITE (G_IO,99001) 99001 FORMAT (' ') WRITE (G_IO,99002) 99002 FORMAT (' ','***** Error in UNIRAN--') WRITE (G_IO,99003) 99003 FORMAT (' ',' The input number of observations is non-positive.') WRITE (G_IO,99004) N 99004 FORMAT (' ',' N = ',I0) ENDIF ! ! ***************** ! ** STEP 90-- ** ! ** EXIT ** ! ***************** ! END SUBROUTINE UNIRAN !> !!##NAME !! unisf(3f) - [M_datapac:SPARSITY] compute the Uniform sparsity function !! !!##SYNOPSIS !! !! SUBROUTINE UNISF(P,Sf) !! !! REAL(kind=wp),intent(in) :: P !! REAL(kind=wp),intent(out) :: Sf !! !!##DESCRIPTION !! UNISF(3f) computes the sparsity function value for the uniform !! (rectangular) distribution on the unit interval (0,1). !! !! This distribution has mean = 0.5 and standard deviation = sqrt(1/12) !! = 0.28867513. !! !! This distribution has the probability density function f(X) = 1. !! !! Note that the sparsity function of a distribution is the derivative !! of the percent point function, and also is the reciprocal of the !! probability density function (but in units of P rather than X). !! !!##INPUT ARGUMENTS !! !! P The value (between 0.0 and 1.0) at which the sparsity function !! is to be evaluated. !! !!##OUTPUT ARGUMENTS !! !! SF The sparsity function value. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_unisf !! use M_datapac, only : unisf, label !! implicit none !! call label('unisf') !! ! call unisf(x,y) !! end program demo_unisf !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !! !!##REFERENCES !! * Filliben, Simple and Robust Linear Estimation of the Location !! Parameter of a Symmetric Distribution (Unpublished PH.D. DIssertation, !! Princeton University), 1969, pages 21-44, 229-231. !! * Filliben, 'The Percent Point Function', (Unpublished Manuscript), !! 1970, pages 28-31. !! * Johnson and Kotz, Continuous Univariate Distributions--2, 1970, !! pages 57-74. ! ORIGINAL VERSION--JUNE 1972. ! UPDATED --SEPTEMBER 1975. ! UPDATED --NOVEMBER 1975. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE UNISF(P,Sf) REAL(kind=wp),intent(in) :: P REAL(kind=wp),intent(out) :: Sf !--------------------------------------------------------------------- ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( P<0.0_wp .OR. P>1.0_wp ) THEN WRITE (G_IO,99001) 99001 FORMAT (' ***** FATAL ERROR--The first input argument to UNISF(3f) is outside the allowable (0,1) interval *****') WRITE (G_IO,99002) P 99002 FORMAT (' ***** The value of the argument is ',E15.8,' *****') RETURN ELSE Sf = 1.0_wp ENDIF END SUBROUTINE UNISF !> !!##NAME !! var(3f) - [M_datapac:STATISTICS] compute the sample variance of a !! vector of observations !! !!##SYNOPSIS !! !! SUBROUTINE VAR(X,N,Iwrite,Xvar) !! !! REAL(kind=wp),intent(in) :: X(:) !! INTEGER,intent(in) :: N !! INTEGER,intent(in) :: Iwrite !! REAL(kind=wp),intent(out) :: Xvar !! !!##DESCRIPTION !! VAR(3f) computes the sample variance (with denominator N-1) of the !! data in the input vector X. !! !! The sample variance = (the sum of the squared deviations about the !! sample mean)/(N-1). !! !! Variance is the expectation of the squared deviation of a random !! variable from its population mean or sample mean. Variance is a !! measure of dispersion, meaning it is a measure of how far a set of !! numbers is spread out from their average value. !! !!##INPUT ARGUMENTS !! !! X The vector of (unsorted or sorted) observations. !! !! N The integer number of observations in the vector X. !! !! IWRITE An integer flag code which (if set to 0) will suppress the !! printing of the sample variance as it is computed; or (if set !! to some integer value not equal to 0), like, say, 1) will cause !! the printing of the sample variance at the time it is computed. !! !!##OUTPUT ARGUMENTS !! !! XVAR The value of the computed sample variance (with denominator !! N-1). !! !!##EXAMPLES !! !! Sample program: !! !! program demo_var !! use M_datapac, only : var, label !! implicit none !! real,allocatable :: x(:) !! real :: Xvar !! call label('var') !! x = [46.0, 69.0, 32.0, 60.0, 52.0, 41.0] !! call VAR(X,size(x),1,Xvar) !! write(*,*)merge('GOOD','BAD ',Xvar == 177.2), Xvar !! end program demo_var !! !! Results: !! !! The sample variance of the 6 observations is 0.17720000E+03 !! GOOD 177.2000 !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !!##MAINTAINER !! John Urban, 2022.05.31 !!##LICENSE !! CC0-1.0 !!##REFERENCES !! * Snedecor and Cochran, Statistical Methods, Edition 6, 1967, page 44. !! * Dixon and Massey, Introduction to Statistical Analysis, Edition 2, !! 1957, page 38. !! * Mood and Grable, 'Introduction to the Theory of Statistics, Edition 2, !! 1963, page 171. ! ORIGINAL VERSION--JUNE 1972. ! UPDATED --SEPTEMBER 1975. ! UPDATED --NOVEMBER 1975. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE VAR(X,N,Iwrite,Xvar) REAL(kind=wp),intent(in) :: X(:) INTEGER,intent(in) :: N INTEGER,intent(in) :: Iwrite REAL(kind=wp),intent(out) :: Xvar REAL(kind=wp) :: an , hold , sum , xmean INTEGER i ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! an = N IF ( N<1 ) THEN WRITE (G_IO,99001) 99001 FORMAT (' ***** FATAL ERROR--The second input argument to VAR(3f) is non-positive *****') WRITE (G_IO,99002) N 99002 FORMAT (' ','***** The value of the argument is ',I0,' *****') RETURN ELSE IF ( N==1 ) THEN WRITE (G_IO,99003) 99003 FORMAT (' ***** NON-FATAL DIAGNOSTIC--The second input argument to VAR(3f) has the value 1 *****') Xvar = 0.0_wp ELSE hold = X(1) DO i = 2 , N IF ( X(i)/=hold ) GOTO 50 ENDDO WRITE (G_IO,99004) hold 99004 FORMAT (& & ' ***** NON-FATAL DIAGNOSTIC--The first input argument (a vector) to VAR(3f) has all elements = ',E15.8,' *****') Xvar = 0.0_wp ENDIF GOTO 100 ! !-----START POINT----------------------------------------------------- ! 50 sum = 0.0_wp DO i = 1 , N sum = sum + X(i) ENDDO xmean = sum/an sum = 0.0_wp DO i = 1 , N sum = sum + (X(i)-xmean)**2 ENDDO Xvar = sum/(an-1.0_wp) ENDIF ! 100 IF ( Iwrite==0 ) RETURN WRITE (G_IO,99005) 99005 FORMAT (' ') WRITE (G_IO,99006) N , Xvar 99006 FORMAT (' ','The sample variance of the ',I0,' observations is ', E15.8) END SUBROUTINE VAR !> !!##NAME !! weib(3f) - [M_datapac:ANALYSIS] perform a Weibull distribution !! analysis (Weibull PPCC analysis) !! !!##SYNOPSIS !! !! SUBROUTINE WEIB(X,N) !! !!##DESCRIPTION !! WEIB(3f) performs a Weibull distribution analysis on the data in the !! input vector X. !! !! This analysis consists of determining that particular Weibull !! distribution which best fits the data set. !! !! The goodness of fit criterion is the maximum probability plot !! correlation coefficient criterion. !! !! After the best-fit distribution is determined, estimates are computed !! and printed out for the location and scale parameters. !! !! Two probability plots are also printed out-- the best-fit Weibull !! probability plot and an extreme value type 1 probability plot (this !! is due to the fact that as the Weibull parameter gamma approaches !! infinity, the Weibull distribution approaches the extreme value type !! 1 distribution). !! !!##OPTIONS !! X description of parameter !! Y description of parameter !! !!##EXAMPLES !! !! Sample program: !! !! program demo_weib !! use M_datapac, only : weib !! implicit none !! ! call weib(x,y) !! end program demo_weib !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !! !!##REFERENCE !! * Filliben (1972), 'Techniques for Tail Length Analysis', Proceedings !! of the Eighteenth Conference on the Design of Experiments in Army !! Research and Testing, pages 425-450. !! * Filliben, 'The Percent Point Function', UNpublished Manuscript. !! * Johnson and Kotz (1970), Continuous Univariate Distributions-1, !! pages 250-271. ! ORIGINAL VERSION--JUNE 1972. ! UPDATED --AUGUST 1975. ! UPDATED --NOVEMBER 1975. ! UPDATED --MAY 1976. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE WEIB(X,N) REAL(kind=wp) :: a , aindex , an , cc , corr , corrmx , gamtab , hold , sum1 ,& & sum2 , sum3 , sy , t , w , wbar , WS , X , xmax , xmin , Y REAL(kind=wp) :: ybar , yi , yint , ys , yslope , Z INTEGER i , idis , idismx , iupper , N , numdis , numdm1 ! ! INPUT ARGUMENTS--X = THE VECTOR OF ! (UNSORTED OR SORTED) OBSERVATIONS. ! N = THE INTEGER NUMBER OF OBSERVATIONS ! IN THE VECTOR X. ! OUTPUT--4 pages OF AUTOMATIC PRINTOUT. ! PRINTING--YES. ! RESTRICTIONS--THE MAXIMUM ALLOWABLE VALUE OF N ! FOR THIS SUBROUTINE IS 7500. ! !--------------------------------------------------------------------- ! CHARACTER(len=4) :: iflag1 CHARACTER(len=4) :: iflag2 CHARACTER(len=4) :: iflag3 ! CHARACTER(len=4) :: blank CHARACTER(len=4) :: alpham CHARACTER(len=4) :: alphaa CHARACTER(len=4) :: alphax CHARACTER(len=4) :: alphai CHARACTER(len=4) :: alphan CHARACTER(len=4) :: alphaf CHARACTER(len=4) :: alphat CHARACTER(len=4) :: alphay CHARACTER(len=4) :: alphag CHARACTER(len=4) :: equal ! DIMENSION w(3000) DIMENSION X(:) DIMENSION Y(7500) , Z(7500) DIMENSION gamtab(50) , corr(50) DIMENSION yi(50) , ys(50) , t(50) DIMENSION iflag1(50) , iflag2(50) , iflag3(50) DIMENSION aindex(50) COMMON /BLOCK2_real32/ WS(15000) EQUIVALENCE (Y(1),WS(1)) EQUIVALENCE (Z(1),WS(7501)) DATA blank , alpham , alphaa , alphax/' ' , 'M' , 'A' , 'X'/ DATA alphai , alphan , alphaf , alphat , alphay/'I' , 'N' , 'F' , & & 'T' , 'Y'/ DATA alphag , equal/'G' , '='/ DATA gamtab(1) , gamtab(2) , gamtab(3) , gamtab(4) , gamtab(5) , & & gamtab(6) , gamtab(7) , gamtab(8) , gamtab(9) , gamtab(10) , & & gamtab(11) , gamtab(12) , gamtab(13) , gamtab(14) , & & gamtab(15) , gamtab(16) , gamtab(17) , gamtab(18) , & & gamtab(19) , gamtab(20) , gamtab(21) , gamtab(22) , & & gamtab(23), gamtab(24), gamtab(25)/1.0_wp, 2.0_wp, 3.0_wp, 4.0_wp, 5.0_wp,& & 6.0_wp, 7.0_wp, 8.0_wp, 9.0_wp, 10.0_wp, 11.0_wp, 12.0_wp, 13.0_wp, 14.0_wp, 15.0_wp, 16.0_wp,& & 17.0_wp, 18.0_wp, 19.0_wp, 20.0_wp, 21.0_wp, 22.0_wp, 23.0_wp, 24.0_wp, 25.0_wp/ DATA gamtab(26) , gamtab(27) , gamtab(28) , gamtab(29) , & & gamtab(30) , gamtab(31) , gamtab(32) , gamtab(33) , & & gamtab(34) , gamtab(35) , gamtab(36) , gamtab(37) , & & gamtab(38) , gamtab(39) , gamtab(40) , gamtab(41) , & & gamtab(42)/30.0_wp, 35.0_wp, 40.0_wp, 45.0_wp, 50.0_wp, 60.0_wp, 70.0_wp, 80.0_wp, & & 90.0_wp, 100.0_wp, 150.0_wp, 200.0_wp, 250.0_wp, 350.0_wp, 500.0_wp, 750.0_wp, 1000.0_wp/ DATA t(1) , t(2) , t(3) , t(4) , t(5) , t(6) , t(7) , t(8) , & & t(9) , t(10) , t(11) , t(12) , t(13) , t(14) , t(15) , & & t(16) , t(17) , t(18) , t(19) , t(20)/1.63474 , 1.36116 , & & 1.34278_wp , 1.35854_wp , 1.37836_wp , 1.39657_wp , 1.41225_wp , 1.42557_wp , & & 1.43690_wp , 1.44660_wp , 1.45496_wp , 1.46223_wp , 1.46860_wp , 1.47422_wp , & & 1.47921_wp , 1.48368_wp , 1.48769_wp , 1.49132_wp , 1.49461_wp , 1.49761_wp/ DATA t(21) , t(22) , t(23) , t(24) , t(25) , t(26) , t(27) , & & t(28) , t(29) , t(30) , t(31) , t(32) , t(33) , t(34) , & & t(35) , t(36) , t(37) , t(38) , t(39) , t(40) , t(41) , & & t(42) , t(43)/1.50036_wp , 1.50288_wp , 1.50521_wp , 1.50736_wp , & & 1.50935_wp , 1.51748_wp , 1.52344_wp , 1.52798_wp , 1.53157_wp , 1.53447_wp , & & 1.53888_wp , 1.54206_wp , 1.54447_wp , 1.54636_wp , 1.54788_wp , 1.55248_wp , & & 1.55480_wp , 1.55620_wp , 1.55781_wp , 1.55902_wp , 1.55997_wp , 1.56044_wp , & & 1.62391_wp/ DATA aindex(1) , aindex(2) , aindex(3) , aindex(4) , aindex(5) , & & aindex(6) , aindex(7) , aindex(8) , aindex(9) , aindex(10) , & & aindex(11) , aindex(12) , aindex(13) , aindex(14) , & & aindex(15) , aindex(16) , aindex(17) , aindex(18) , & & aindex(19) , aindex(20) , aindex(21) , aindex(22) , & & aindex(23), aindex(24), aindex(25)/1.0_wp, 2.0_wp, 3.0_wp, 4.0_wp, 5.0_wp,& & 6.0_wp, 7.0_wp, 8.0_wp, 9.0_wp, 10.0_wp, 11.0_wp, 12.0_wp, 13.0_wp, 14.0_wp, 15.0_wp, 16.0_wp,& & 17.0_wp, 18.0_wp, 19.0_wp, 20.0_wp, 21.0_wp, 22.0_wp, 23.0_wp, 24.0_wp, 25.0_wp/ DATA aindex(26) , aindex(27) , aindex(28) , aindex(29) , & & aindex(30) , aindex(31) , aindex(32) , aindex(33) , & & aindex(34) , aindex(35) , aindex(36) , aindex(37) , & & aindex(38) , aindex(39) , aindex(40) , aindex(41) , & & aindex(42) , aindex(43) , aindex(44) , aindex(45) , & & aindex(46) , aindex(47) , aindex(48) , aindex(49) , & & aindex(50)/26.0_wp, 27.0_wp, 28.0_wp, 29.0_wp, 30.0_wp, 31.0_wp, 32.0_wp, 33.0_wp, & & 34.0_wp, 35.0_wp, 36.0_wp, 37.0_wp, 38.0_wp, 39.0_wp, 40.0_wp, 41.0_wp, 42.0_wp, 43.0_wp, & & 44.0_wp, 45.0_wp, 46.0_wp, 47.0_wp, 48.0_wp, 49.0_wp, 50.0_wp/ ! iupper = 7500 numdis = 43 ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( N<1 .OR. N>iupper ) THEN WRITE (G_IO,99001) iupper 99001 FORMAT (' ', & &'***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE WEIB SUBROU& &TINE IS OUTSIDE THE ALLOWABLE (1,',I0,') INTERVAL *****') WRITE (G_IO,99002) N 99002 FORMAT (' ','***** THE VALUE OF THE ARGUMENT IS ',I0,' *****') RETURN ELSE IF ( N==1 ) THEN WRITE (G_IO,99003) 99003 FORMAT (' ', & &'***** NON-FATAL DIAGNOSTIC--THE SECOND INPUT ARGUMENT TO THE WEIB& & SUBROUTINE HAS THE VALUE 1 *****') RETURN ELSE hold = X(1) DO i = 2 , N IF ( X(i)/=hold ) GOTO 50 ENDDO WRITE (G_IO,99004) hold 99004 FORMAT (' ', & &'***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT (A VECTOR) & &TO THE WEIB SUBROUTINE HAS ALL ELEMENTS = ',E15.8,' *****') RETURN ENDIF ! !-----START POINT----------------------------------------------------- ! 50 an = N ! ! COMPUTE THE SAMPLE MINIMUM AND SAMPLE MAXIMUM ! xmin = X(1) xmax = X(1) DO i = 2 , N IF ( X(i)<xmin ) xmin = X(i) IF ( X(i)>xmax ) xmax = X(i) ENDDO ! ! COMPUTE THE PROB PLOT CORRELATION COEFFICIENTS FOR THE VARIOUS VALUES ! OF GAMMA ! CALL SORT(X,N,Y) CALL UNIMED(N,Z) ! DO idis = 1 , numdis IF ( idis==numdis ) THEN DO i = 1 , N w(i) = -LOG(LOG(1.0_wp/Z(i))) ENDDO ELSE a = gamtab(idis) DO i = 1 , N w(i) = (-LOG(1.0_wp-Z(i)))**(1.0_wp/a) ENDDO ENDIF ! sum1 = 0.0_wp sum2 = 0.0_wp DO i = 1 , N sum1 = sum1 + Y(i) sum2 = sum2 + w(i) ENDDO ybar = sum1/an wbar = sum2/an sum1 = 0.0_wp sum2 = 0.0_wp sum3 = 0.0_wp DO i = 1 , N sum2 = sum2 + (Y(i)-ybar)*(w(i)-wbar) sum1 = sum1 + (Y(i)-ybar)*(Y(i)-ybar) sum3 = sum3 + (w(i)-wbar)*(w(i)-wbar) ENDDO sy = SQRT(sum1/(an-1.0_wp)) cc = sum2/SQRT(sum3*sum1) yslope = sum2/sum3 yint = ybar - yslope*wbar corr(idis) = cc yi(idis) = yint ys(idis) = yslope ENDDO ! ! DETERMINE THAT DISTRIBUTION WITH THE MAX PROB PLOT CORR COEFFICIENT ! idismx = 1 corrmx = corr(1) DO idis = 1 , numdis IF ( corr(idis)>corrmx ) idismx = idis IF ( corr(idis)>corrmx ) corrmx = corr(idis) ENDDO DO idis = 1 , numdis iflag1(idis) = blank iflag2(idis) = blank iflag3(idis) = blank IF ( idis==idismx ) THEN iflag1(idis) = alpham iflag2(idis) = alphaa iflag3(idis) = alphax ENDIF ENDDO ! ! WRITE OUT THE TABLE OF PROB PLOT CORR COEFFICIENTS FOR VARIOUS GAMMA ! WRITE (G_IO,99005) ! 99005 FORMAT ('1') WRITE (G_IO,99006) 99006 FORMAT (' ',40X,'WEIBULL ANALYSIS') WRITE (G_IO,99020) WRITE (G_IO,99007) N 99007 FORMAT (' ',37X,'THE SAMPLE SIZE N = ',I0) WRITE (G_IO,99008) ybar 99008 FORMAT (' ',34X,'THE SAMPLE MEAN = ',F14.7) WRITE (G_IO,99009) sy 99009 FORMAT (' ',28X,'THE SAMPLE STANDARD DEVIATION = ',F14.7) WRITE (G_IO,99010) xmin 99010 FORMAT (' ',32X,'THE SAMPLE MINIMUM = ',F14.7) WRITE (G_IO,99011) xmax 99011 FORMAT (' ',32X,'THE SAMPLE MAXIMUM = ',F14.7) WRITE (G_IO,99020) WRITE (G_IO,99012) 99012 FORMAT (' ', & &' WEIBULL PROBABILITY PLOT LOCATION SCA& &LE TAIL LENGTH') WRITE (G_IO,99013) 99013 FORMAT (' ', & &' TAIL LENGTH CORRELATION ESTIMATE ESTI& &MATE MEASURE') WRITE (G_IO,99014) 99014 FORMAT (' ',' PARAMETER (GAMMA) COEFFICIENT') WRITE (G_IO,99020) ! numdm1 = numdis - 1 IF ( numdm1>=1 ) THEN DO i = 1 , numdm1 WRITE (G_IO,99015) gamtab(i) , corr(i) , iflag1(i) , & & iflag2(i) , iflag3(i) , yi(i) , ys(i) ,& & t(i) 99015 FORMAT (' ',3X,F10.2,13X,F8.5,1X,3A1,2X,F14.7,2X,F14.7, & & 3X,F10.5) ENDDO ENDIF i = numdis WRITE (G_IO,99016) alphai , alphan , alphaf , alphai , alphan , & & alphai , alphat , alphay , corr(i) , & & iflag1(i) , iflag2(i) , iflag3(i) , yi(i) , & & ys(i) , t(i) 99016 FORMAT (' ',5X,8A1,13X,F8.5,1X,3A1,2X,F14.7,2X,F14.7,3X,F10.5) ! ! PLOT THE PROB PLOT CORR COEFFICIENT VERSUS GAMMA VALUE INDEX ! CALL PLOT(corr,aindex,numdis) WRITE (G_IO,99017) alphag , alphaa , alpham , alpham , alphaa , & & equal , gamtab(1) , gamtab(12) , gamtab(23) ,& & gamtab(34) , alphai , alphan , alphaf , & & alphai , alphan , alphai , alphat , alphay 99017 FORMAT (' ',12X,5A1,1X,A1,F14.7,11X,F14.7,11X,F14.7,11X,F14.7, & & 15X,8A1) WRITE (G_IO,99020) WRITE (G_IO,99018) 99018 FORMAT (' ', & &'THE ABOVE IS A PLOT OF THE 46 PROBABILITY PLOT CORRELATION COEFFI& &CIENTS (FROM THE PREVIOUS page)') WRITE (G_IO,99019) 99019 FORMAT (' ',16X,'VERSUS THE 46 WEIBULL DISTRIBUTIONS') ! ! IF THE OPTIMAL GAMMA IS FINITE, PLOT OUT THE WEIBULL ! PROBABILITY PLOT FOR THE OPTIMAL VALUE ! OF GAMMA. ! IF ( idismx<numdis ) CALL WEIPLT(X,N,gamtab(idismx)) ! ! PLOT OUT AN EXTREM VALUE TYPE 1 PROBABILITY PLOT ! (WHICH IS IDENTICALLY A WEIBULL PROBABILITY ! WITH GAMMA = INFINITY) ! CALL EV1PLT(X,N) ENDIF 99020 FORMAT (' ') ! END SUBROUTINE WEIB !> !!##NAME !! weicdf(3f) - [M_datapac:CUMULATIVE_DISTRIBUTION] compute the Weibull cumulative !! distribution function !! !!##SYNOPSIS !! !! SUBROUTINE WEICDF(X,Gamma,Cdf) !! !! REAL(kind=wp),intent(in) :: X !! REAL(kind=wp),intent(in) :: Gamma !! REAL(kind=wp),intent(out) :: Cdf !! !!##DESCRIPTION !! WEICDF(3f) computes the cumulative distribution function value for !! the Weibull distribution with REAL tail length parameter !! = GAMMA. !! !! The Weibull distribution used herein is defined for all positive X, !! and has the probability density function !! !! f(X) = GAMMA * (X**(GAMMA-1)) * exp(-(X**GAMMA)) !! !!##INPUT ARGUMENTS !! !! X The value at which the cumulative distribution function is to !! be evaluated. X should be positive ( >0 ) !! !! GAMMA The value of the tail length parameter. GAMMA should be !! positive. !! !!##OUTPUT ARGUMENTS !! !! CDF The cumulative distribution function value for the Weibull !! distribution !! !!##EXAMPLES !! !! Sample program: !! !! program demo_weicdf !! !@(#) line plotter graph of cumulative distribution function !! use M_datapac, only : weicdf, plott, label !! implicit none !! real,allocatable :: x(:), y(:) !! real :: gamma !! integer :: i !! call label('weicdf') !! x=[((real(i)+epsilon(0.0))/30.0,i=0,100,1)] !! if(allocated(y))deallocate(y) !! allocate(y(size(x))) !! gamma=12.2 !! do i=1,size(x) !! call weicdf(X(i),Gamma,y(i)) !! enddo !! call plott(x,y,size(x)) !! end program demo_weicdf !! !! Results: !! !! The following is a plot of Y(I) (vertically) versus X(I) (horizontally) !! I-----------I-----------I-----------I-----------I !! 0.3333333E+01 - X !! 0.3194444E+01 I X !! 0.3055556E+01 I X !! 0.2916667E+01 I X !! 0.2777778E+01 I X !! 0.2638889E+01 I X !! 0.2500000E+01 - X !! 0.2361111E+01 I X !! 0.2222222E+01 I X !! 0.2083333E+01 I X !! 0.1944444E+01 I X !! 0.1805556E+01 I X !! 0.1666667E+01 - X !! 0.1527778E+01 I X !! 0.1388889E+01 I X !! 0.1250000E+01 I X !! 0.1111111E+01 I X X X !! 0.9722223E+00 I X X X X !! 0.8333335E+00 - XX X X X !! 0.6944444E+00 I XX !! 0.5555556E+00 I X !! 0.4166667E+00 I X !! 0.2777779E+00 I X !! 0.1388891E+00 I X !! 0.3973643E-08 - X !! I-----------I-----------I-----------I-----------I !! 0.0000E+00 0.2500E+00 0.5000E+00 0.7500E+00 0.1000E+01 !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !! !!##REFERENCES !! * Johnson and Kotz, Continuous Univariate Distributions--1, 1970, !! pages 250-271. !! * Hastings and Peacock, Statistical Distributions--A Handbook for !! Students and Practitioners, 1975, page 124. ! ORIGINAL VERSION--NOVEMBER 1975. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE WEICDF(X,Gamma,Cdf) REAL(kind=wp),intent(in) :: X REAL(kind=wp),intent(in) :: Gamma REAL(kind=wp),intent(out) :: Cdf !--------------------------------------------------------------------- ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( X<=0.0_wp ) THEN WRITE (G_IO,99001) 99001 FORMAT (' ***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT TO WEICDF(3f) IS NON-POSITIVE *****') WRITE (G_IO,99003) X Cdf = 0.0_wp RETURN ELSEIF ( Gamma<=0.0_wp ) THEN WRITE (G_IO,99002) 99002 FORMAT (' ***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO WEICDF(3f) IS NON-POSITIVE *****') WRITE (G_IO,99003) Gamma Cdf = 0.0_wp RETURN ELSE Cdf = 1.0_wp - (EXP(-(X**Gamma))) ENDIF 99003 FORMAT (' ','***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') ! END SUBROUTINE WEICDF !> !!##NAME !! weiplt(3f) - [M_datapac:LINE_PLOT] generate a Weibull probability plot !! (line printer graph) !! !!##SYNOPSIS !! !! SUBROUTINE WEIPLT(X,N,Gamma) !! !!##DESCRIPTION !! WEIPLT(3f) generates a weibull probability plot (with tail length !! parameter value = GAMMA). !! !! The prototype weibull distribution used herein is defined for all !! positive X, and has the probability density function !! !! f(x) = gamma * (x**(gamma-1)) * exp(-(x**gamma)) !! !! As used herein, a probability plot for a distribution is a plot !! of the ordered observations versus the order statistic medians for !! that distribution. !! !! The Weibull probability plot is useful in graphically testing !! the composite (that is, location and scale parameters need not be !! specified) hypothesis that the underlying distribution from which the !! data have been randomly drawn is the Weibull distribution with tail !! length parameter value = GAMMA. !! !! If the hypothesis is true, the probability plot should be near-linear. !! !! A measure of such linearity is given by the calculated probability !! plot correlation coefficient. !! !!##OPTIONS !! X description of parameter !! Y description of parameter !! !!##EXAMPLES !! !! Sample program: !! !! program demo_weiplt !! use M_datapac, only : weiplt !! implicit none !! ! call weiplt(x,y) !! end program demo_weiplt !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !! !!##REFERENCES !! * Filliben, 'Techniques for Tail Length Analysis', Proceedings of the !! Eighteenth Conference on the Design of Experiments in Army Research !! Development and Testing (Aberdeen, Maryland, October, 1972), pages !! 425-450. !! * Hahn and Shapiro, Statistical Methods in Engineering, 1967, pages !! 260-308. !! * Johnson and Kotz, Continuous Univariate Distributions--1, 1970, !! pages 250-271. ! MODE OF INTERNAL OPERATIONS--. ! ORIGINAL VERSION--DECEMBER 1972. ! UPDATED --MARCH 1975. ! UPDATED --SEPTEMBER 1975. ! UPDATED --NOVEMBER 1975. ! UPDATED --FEBRUARY 1976. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE WEIPLT(X,N,Gamma) REAL(kind=wp) :: an , cc , Gamma , hold , pp0025 , pp025 , pp975 , pp9975 , & & q , sum1 , sum2 , sum3 , tau , W , wbar , WS , X , Y , ybar ,& & yint REAL(kind=wp) :: yslope INTEGER i , iupper , N ! ! INPUT ARGUMENTS--X = THE VECTOR OF ! (UNSORTED OR SORTED) OBSERVATIONS. ! --N = THE INTEGER NUMBER OF OBSERVATIONS ! IN THE VECTOR X. ! --GAMMA = THE VALUE OF THE ! TAIL LENGTH PARAMETER. ! GAMMA SHOULD BE POSITIVE. ! OUTPUT--A ONE-page WEIBULL PROBABILITY PLOT. ! RESTRICTIONS--THE MAXIMUM ALLOWABLE VALUE OF N ! FOR THIS SUBROUTINE IS 7500. ! !--------------------------------------------------------------------- ! DIMENSION X(:) DIMENSION Y(7500) , W(7500) COMMON /BLOCK2_real32/ WS(15000) EQUIVALENCE (Y(1),WS(1)) EQUIVALENCE (W(1),WS(7501)) ! iupper = 7500 ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( N<1 .OR. N>iupper ) THEN WRITE (G_IO,99001) iupper 99001 FORMAT (' ', & &'***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE WEIPLT SUBROU& &TINE IS OUTSIDE THE ALLOWABLE (1,',I0,') INTERVAL *****') WRITE (G_IO,99002) N 99002 FORMAT (' ','***** THE VALUE OF THE ARGUMENT IS ',I0,' *****') RETURN ELSEIF ( N==1 ) THEN WRITE (G_IO,99003) 99003 FORMAT (' ', & &'***** NON-FATAL DIAGNOSTIC--THE SECOND INPUT ARGUMENT TO THE WEIP& < SUBROUTINE HAS THE VALUE 1 *****') RETURN ELSE IF ( Gamma<=0.0_wp ) THEN WRITE (G_IO,99004) 99004 FORMAT (' ', & &'***** FATAL ERROR--THE THIRD INPUT ARGUMENT TO THE WEIPLT SUBROU& &TINE IS NON-POSITIVE *****') WRITE (G_IO,99005) Gamma 99005 FORMAT (' ','***** THE VALUE OF THE ARGUMENT IS ',E15.8, & & ' *****') RETURN ELSE hold = X(1) DO i = 2 , N IF ( X(i)/=hold ) GOTO 50 ENDDO WRITE (G_IO,99006) hold 99006 FORMAT (' ', & &'***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT (A VECTOR) & &TO THE WEIPLT SUBROUTINE HAS ALL ELEMENTS = ',E15.8,' *****') RETURN ENDIF ! !-----START POINT----------------------------------------------------- ! 50 an = N ! ! SORT THE DATA ! CALL SORT(X,N,Y) ! ! GENERATE UNIFORM ORDER STATISTIC MEDIANS ! CALL UNIMED(N,W) ! ! COMPUTE WEIBULL DISTRIBUTION ORDER STATISTIC MEDIANS ! DO i = 1 , N W(i) = (-LOG(1.0_wp-W(i)))**(1.0_wp/Gamma) ENDDO ! ! PLOT THE ORDERED OBSERVATIONS VERSUS ORDER STATISTICS MEDIANS. ! COMPUTE THE TAIL LENGTH MEASURE OF THE DISTRIBUTION. ! WRITE OUT THE TAIL LENGTH MEASURE OF THE DISTRIBUTION ! AND THE SAMPLE SIZE. ! CALL PLOT(Y,W,N) q = 0.9975_wp pp9975 = (-LOG(1.0_wp-q))**(1.0_wp/Gamma) q = 0.0025_wp pp0025 = (-LOG(1.0_wp-q))**(1.0_wp/Gamma) q = 0.975_wp pp975 = (-LOG(1.0_wp-q))**(1.0_wp/Gamma) q = 0.025_wp pp025 = (-LOG(1.0_wp-q))**(1.0_wp/Gamma) tau = (pp9975-pp0025)/(pp975-pp025) WRITE (G_IO,99007) Gamma , tau , N ! 99007 FORMAT (' ', & & 'WEIBULL PROBABILITY PLOT WITH EXPONENT PARAMETER = ', & & E17.10,1X,'(TAU = ',E15.8,')',11X, & & 'THE SAMPLE SIZE N = ',I0) ! ! COMPUTE THE PROBABILITY PLOT CORRELATION COEFFICIENT. ! COMPUTE LOCATION AND SCALE ESTIMATES ! FROM THE INTERCEPT AND SLOPE OF THE PROBABILITY PLOT. ! THEN WRITE THEM OUT. ! sum1 = 0.0_wp sum2 = 0.0_wp DO i = 1 , N sum1 = sum1 + Y(i) sum2 = sum2 + W(i) ENDDO ybar = sum1/an wbar = sum2/an sum1 = 0.0_wp sum2 = 0.0_wp sum3 = 0.0_wp DO i = 1 , N sum1 = sum1 + (Y(i)-ybar)*(Y(i)-ybar) sum2 = sum2 + (Y(i)-ybar)*(W(i)-wbar) sum3 = sum3 + (W(i)-wbar)*(W(i)-wbar) ENDDO cc = sum2/SQRT(sum3*sum1) yslope = sum2/sum3 yint = ybar - yslope*wbar WRITE (G_IO,99008) cc , yint , yslope 99008 FORMAT (' ','PROBABILITY PLOT CORRELATION COEFFICIENT = ',F8.5,& & 5X,'ESTIMATED INTERCEPT = ',E15.8,3X, & & 'ESTIMATED SLOPE = ',E15.8) ENDIF ! END SUBROUTINE WEIPLT !> !!##NAME !! weippf(3f) - [M_datapac:PERCENT_POINT] compute the Weibull percent !! point function !! !!##SYNOPSIS !! !! SUBROUTINE WEIPPF(P,Gamma,Ppf) !! !! REAL(kind=wp),intent(in) :: P !! REAL(kind=wp),intent(in) :: Gamma !! REAL(kind=wp),intent(out) :: Ppf !! !!##DESCRIPTION !! WEIPPf(3f) computes the percent point function value for the Weibull !! distribution with REAL tail length parameter = GAMMA. !! !! The Weibull distribution used herein is defined for all positive X, !! and has the probability density function !! !! f(X) = GAMMA * (X**(GAMMA-1)) * exp(-(X**GAMMA)) !! !! Note that the percent point function of a distribution is identically !! the same as the inverse cumulative distribution function of the !! distribution. !! !!##INPUT ARGUMENTS !! !! P The value (between 0.0 (inclusively) and 1.0 (exclusively)) !! at which the percent point function is to be evaluated. !! !! GAMMA The value of the tail length parameter. GAMMA should be positive. !! !!##OUTPUT ARGUMENTS !! PPF The percent point function value for the Weibull distribution !! !!##EXAMPLES !! !! Sample program: !! !! program demo_weippf !! !@(#) line plotter graph of function !! use M_datapac, only : weippf, plott, label !! implicit none !! integer,parameter :: n=200 !! real :: x(n), y(n) !! real :: gamma !! integer :: i !! gamma=2.0 !! call label('weippf') !! x=[(real(i)/real(n+1),i=1,n)] !! do i=1,n !! call weippf(x(i),gamma,y(i)) !! enddo !! call plott(x,y,n) !! end program demo_weippf !! !! Results: !! !! The following is a plot of Y(I) (vertically) versus X(I) (horizontally) !! I-----------I-----------I-----------I-----------I !! 0.9950249E+00 - XX X X X !! 0.9537728E+00 I XXXXXX !! 0.9125207E+00 I XXXX !! 0.8712686E+00 I XXX !! 0.8300166E+00 I XXX !! 0.7887645E+00 I XX !! 0.7475125E+00 - XX !! 0.7062603E+00 I XX !! 0.6650083E+00 I XX !! 0.6237562E+00 I XX !! 0.5825042E+00 I XX !! 0.5412520E+00 I XX !! 0.5000000E+00 - XX !! 0.4587479E+00 I XX !! 0.4174958E+00 I XX !! 0.3762438E+00 I XX !! 0.3349917E+00 I XX !! 0.2937396E+00 I XX !! 0.2524875E+00 - XX !! 0.2112355E+00 I XX !! 0.1699834E+00 I XX !! 0.1287313E+00 I XX !! 0.8747923E-01 I XXX !! 0.4622716E-01 I XXX !! 0.4975124E-02 - XXX !! I-----------I-----------I-----------I-----------I !! 0.7062E-01 0.6287E+00 0.1187E+01 0.1745E+01 0.2303E+01 !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !! !!##REFERENCES !! * Johnson and Kotz, Continuous Univariate Distributions--1, 1970, !! pages 250-271. !! * Hastings and Peacock, Statistical Distributions--A Handbook for !! Students and Practitioners, 1975, page 124. ! ORIGINAL VERSION--NOVEMBER 1975. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE WEIPPF(P,Gamma,Ppf) REAL(kind=wp),intent(in) :: P REAL(kind=wp),intent(in) :: Gamma REAL(kind=wp),intent(out) :: Ppf !--------------------------------------------------------------------- ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( P<0.0_wp .OR. P>=1.0_wp ) THEN WRITE (G_IO,99001) 99001 FORMAT (' ***** FATAL ERROR--The first input argument TO WEIPPF(3f) is outside the allowable (0,1) interval *****') WRITE (G_IO,99003) P Ppf = 0.0_wp RETURN ELSEIF ( Gamma<=0.0_wp ) THEN WRITE (G_IO,99002) 99002 FORMAT (' ***** FATAL ERROR--The second input argument to WEIPPF(3f) is non-positive *****') WRITE (G_IO,99003) Gamma Ppf = 0.0_wp RETURN ELSE Ppf = (-LOG(1.0_wp-P))**(1.0_wp/Gamma) ENDIF 99003 FORMAT (' ***** The value of the argument is ',E15.8,' *****') ! END SUBROUTINE WEIPPF !> !!##NAME !! weiran(3f) - [M_datapac:RANDOM] generate Weibull random numbers !! !!##SYNOPSIS !! !! SUBROUTINE WEIRAN(N,Gamma,Iseed,X) !! !! INTEGER :: N !! REAL(kind=wp) :: Gamma !! INTEGER :: Iseed !! REAL(kind=wp) :: X(:) !! !!##DESCRIPTION !! WEIRAN(3f) generates a random sample of size N from the Weibull !! distribution with tail length parameter value = GAMMA. !! !! The prototype Weibull distribution used herein is defined for all !! positive X, and has the probability density function !! !! f(X) = GAMMA * (X**(GAMMA-1)) * exp(-(X**GAMMA)). !! !!##INPUT ARGUMENTS !! !! N The desired integer number of random numbers to be generated. !! GAMMA The value of the tail length parameter. gamma should !! be positive. !! ISEED An integer iseed value. Should be set to a non-negative value !! to start a new sequence of values. Will be set to -1 on return !! to indicate the next call should continue the current random !! sequence walk. !! !!##OUTPUT ARGUMENTS !! !! X A vector (of dimension at least N) into which the generated !! random sample will be placed. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_weiran !! use M_datapac, only : weiran !! implicit none !! ! call weiran(x,y) !! end program demo_weiran !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !! !!##REFERENCES !! * Tocher, the Art of Simulation, 1963, pages 14-15. !! * Hammersley and Handscomb, Monte Carlo Methods, 1964, page 36. !! * Johnson and Kotz, Continuous Univariate Distributions--1, 1970, !! pages 250-271. !! * Hastings and Peacock, Statistical Distributions--A Handbook for !! Students and Practitioners, 1975, page 128. ! VERSION NUMBER--82.6 ! ORIGINAL VERSION--NOVEMBER 1975. ! UPDATED --DECEMBER 1981. ! UPDATED --MAY 1982. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE WEIRAN(N,Gamma,Iseed,X) INTEGER :: N REAL(kind=wp) :: Gamma INTEGER :: Iseed REAL(kind=wp) :: X(:) INTEGER :: i ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! IF ( N<1 ) THEN WRITE (G_IO,99001) 99001 FORMAT (' ***** FATAL ERROR--THE FIRST INPUT ARGUMENT TO WEIRAN(3f) IS NON-POSITIVE *****') WRITE (G_IO,99002) N 99002 FORMAT (' ','***** THE VALUE OF THE ARGUMENT IS ',I0,' *****') RETURN ELSEIF ( Gamma<=0.0_wp ) THEN WRITE (G_IO,99003) 99003 FORMAT (' ***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO WEIRAN(3f) IS NON-POSITIVE *****') WRITE (G_IO,99004) Gamma 99004 FORMAT (' ','***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') RETURN ELSE ! ! GENERATE N UNIFORM (0,1) RANDOM NUMBERS; ! CALL UNIRAN(N,Iseed,X) ! ! GENERATE N WEIBULL DISTRIBUTION RANDOM NUMBERS ! USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD. ! DO i = 1 , N X(i) = (-LOG(1.0_wp-X(i)))**(1.0_wp/Gamma) ENDDO ENDIF ! END SUBROUTINE WEIRAN !> !!##NAME !! wind(3f) - [M_datapac:STATISTICS] compute the sample Winsorized mean !! of a vector of observations !! !!##SYNOPSIS !! !! SUBROUTINE WIND(X,N,P1,P2,Iwrite,Xwind) !! !!##DESCRIPTION !! !! WIND(3f) computes the sample windsorized mean of the data in the !! input vector X. !! !! The windsorizing is such that the lower 100*p1 % of the data is !! replaced by the smallest non-windsorized value, and the upper 100*p2 % !! of the data is windsorized. replaced by the largest non-windsorized !! value. !! !!##OPTIONS !! X description of parameter !! Y description of parameter !! !!##EXAMPLES !! !! Sample program: !! !! program demo_wind !! use M_datapac, only : wind !! implicit none !! ! call wind(x,y) !! end program demo_wind !! !! Results: !! !!##AUTHOR !! The original DATAPAC library was written by James Filliben of the !! Statistical Engineering Division, National Institute of Standards !! and Technology. !! !!##MAINTAINER !! John Urban, 2022.05.31 !! !!##LICENSE !! CC0-1.0 !! !!##REFERENCES !! * David, Order Statistics, 1970, pages 126-130, 136. !! * Crow and Siddiqui, 'Robust Estimation of Location', Journal of the !! American Statistical Association, 1967, pages 357, 387. !! * Filliben, Simple and Robust Linear Estimation of the Location !! Parameter of a Symmetric Distribution (Unpublished PH.D. Dissertation, !! Princeton University, 1969). ! ORIGINAL VERSION--NOVEMBER 1975. ! UPDATED --FEBRUARY 1976. ! processed by SPAG 7.51RB at 12:54 on 18 Mar 2022 SUBROUTINE WIND(X,N,P1,P2,Iwrite,Xwind) REAL(kind=wp) :: ak , an , anp1 , anp2 , hold , P1 , P2 , perp1 , perp2 , perp3 , psum , sum , WS , X , Xwind , Y INTEGER i , istart , istop , iupper , Iwrite , k , N , np1 , np2 ! ! INPUT ARGUMENTS--X = THE VECTOR OF ! (UNSORTED OR SORTED) OBSERVATIONS. ! --N = THE INTEGER NUMBER OF OBSERVATIONS ! IN THE VECTOR X. ! --P1 = THE VALUE ! (BETWEEN 0.0 AND 1.0) ! WHICH DEFINES WHAT FRACTION ! OF THE LOWER ORDER STATISTICS ! IS TO BE WINDSORIZED ! BEFORE COMPUTING THE WINDSORIZED MEAN. ! --P2 = THE VALUE ! (BETWEEN 0.0 AND 1.0) ! WHICH DEFINES WHAT FRACTION ! OF THE UPPER ORDER STATISTICS ! IS TO BE WINDSORIZED ! BEFORE COMPUTING THE WINDSORIZED MEAN. ! --IWRITE = AN INTEGER FLAG CODE WHICH ! (IF SET TO 0) WILL SUPPRESS ! THE PRINTING OF THE ! SAMPLE WINDSORIZED MEAN ! AS IT IS COMPUTED; ! OR (IF SET TO SOME INTEGER ! VALUE NOT EQUAL TO 0), ! LIKE, SAY, 1) WILL CAUSE ! THE PRINTING OF THE ! SAMPLE WINDSORIZED MEAN ! AT THE TIME IT IS COMPUTED. ! OUTPUT ARGUMENTS--XWIND = THE VALUE OF THE ! COMPUTED SAMPLE WINDSORIZED MEAN ! WHERE 100*P1 % OF THE SMALLEST ! AND 100*P2 % OF THE LARGEST ! ORDERED OBSERVATIONS HAVE BEEN ! WINSORIZED BEFORE COMPUTING THE ! MEAN. ! OUTPUT--THE COMPUTED VALUE OF THE ! SAMPLE WINDSORIZED MEAN ! WHERE 100*P1 % OF THE SMALLEST ! AND 100*P2 % OF THE LARGEST ! ORDERED OBSERVATIONS HAVE BEEN WINDSORIZED. ! PRINTING--NONE, UNLESS IWRITE HAS BEEN SET TO A NON-ZERO ! INTEGER, OR UNLESS AN INPUT ARGUMENT ERROR ! CONDITION EXISTS. ! RESTRICTIONS--THE MAXIMUM ALLOWABLE VALUE OF N ! FOR THIS SUBROUTINE IS 15000. ! --P1 SHOULD BE NON-NEGATIVE. ! --P1 SHOULD BE SMALLER THAN 1.0 ! --P2 SHOULD BE NON-NEGATIVE. ! --P2 SHOULD BE SMALLER THAN 1.0 ! --THE SUM OF P1 AND P2 SHOULD BE ! SMALLER THAN 1.0. ! OTHER DATAPAC SUBROUTINES NEEDED--SORT. ! !--------------------------------------------------------------------- ! DIMENSION X(:) DIMENSION Y(15000) COMMON /BLOCK2_real32/ WS(15000) EQUIVALENCE (Y(1),WS(1)) ! iupper = 15000 ! ! CHECK THE INPUT ARGUMENTS FOR ERRORS ! an = N IF ( N<1 .OR. N>iupper ) THEN WRITE (G_IO,99001) iupper 99001 FORMAT (' ',& & '***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO WIND(3f) IS OUTSIDE THE ALLOWABLE (1,',I0,') INTERVAL *****') WRITE (G_IO,99002) N 99002 FORMAT (' ','***** THE VALUE OF THE ARGUMENT IS ',I0,' *****') RETURN ELSE IF ( N==1 ) THEN WRITE (G_IO,99003) 99003 FORMAT (' ***** NON-FATAL DIAGNOSTIC--THE SECOND INPUT ARGUMENT TO WIND(3f) HAS THE VALUE 1 *****') Xwind = X(1) ELSE hold = X(1) DO i = 2 , N IF ( X(i)/=hold ) GOTO 50 ENDDO WRITE (G_IO,99004) hold 99004 FORMAT (' ***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT (A VECTOR) TO WIND(3f) HAS ALL ELEMENTS = ',& & E15.8,' *****') Xwind = X(1) ENDIF GOTO 100 50 IF ( P1<0.0_wp .OR. P1>=1.0_wp ) THEN WRITE (G_IO,99005) 99005 FORMAT (& & ' ***** FATAL ERROR--THE THIRD INPUT ARGUMENT TO WIND(3f) IS OUTSIDE THE ALLOWABLE (0.0,1.0) INTERVAL *****') WRITE (G_IO,99017) P1 Xwind = 0.0_wp RETURN ELSEIF ( P2<0.0_wp .OR. P2>=1.0_wp ) THEN WRITE (G_IO,99006) 99006 FORMAT (' ', & &'***** FATAL ERROR--THE FOURTH INPUT ARGUMENT TO THE WIND SUBROU& &TINE IS OUTSIDE THE ALLOWABLE (0.0,1.0) INTERVAL *****') WRITE (G_IO,99017) P2 Xwind = 0.0_wp RETURN ELSE psum = P1 + P2 IF ( psum<0.0_wp .OR. psum>=1.0_wp ) THEN WRITE (G_IO,99007) 99007 FORMAT (' ', & & '***** FATAL ERROR--THE SUM OF INPUT ARGUMENTS ',& & '3 AND 4 TO THE WIND SUBROUTINE IS OUTSIDE THE ALLOWABLE '& & ,'(0.0,1.0) INTERVAL *****') WRITE (G_IO,99008) P1 99008 FORMAT (' ',' INPUT ARGUMENT 3 ', & & ' = ',E15.8) WRITE (G_IO,99009) P2 99009 FORMAT (' ',' INPUT ARGUMENT 4 ', & & ' = ',E15.8) WRITE (G_IO,99010) psum 99010 FORMAT (' ',' INPUT ARGUMENT 3 + ', & & 'INPUT ARGUMENT 4 = ',E15.8) Xwind = 0.0_wp RETURN ELSE ! !-----START POINT----------------------------------------------------- ! CALL SORT(X,N,Y) ! an = N np1 = P1*an + 0.0001_wp istart = np1 + 1 np2 = P2*an + 0.0001_wp istop = N - np2 sum = 0.0_wp k = 0 IF ( istart>istop ) THEN WRITE (G_IO,99011) 99011 FORMAT (' ','INTERNAL ERROR IN WIND SUBROUTINE--', & & 'THE START INDEX IS HIGHER THAN THE STOP INDEX'& & ) Xwind = 0.0_wp RETURN ELSE DO i = istart , istop k = k + 1 sum = sum + X(i) ENDDO ak = k anp1 = np1 anp2 = np2 sum = sum + anp1*X(istart) sum = sum + anp2*X(istop) Xwind = sum/an ENDIF ENDIF ENDIF ENDIF ! 100 IF ( Iwrite==0 ) RETURN perp1 = 100.0_wp*P1 perp2 = 100.0_wp*P2 perp3 = 100.0_wp - perp1 - perp2 WRITE (G_IO,99012) 99012 FORMAT (' ') WRITE (G_IO,99013) N , Xwind 99013 FORMAT (' ','THE SAMPLE WINDSORIZED MEAN OF THE ',I0, ' OBSERVATIONS IS ',E15.8) WRITE (G_IO,99014) perp1 , np1 99014 FORMAT (' ',8X,F10.4,' PERCENT (= ',I0,' OBSERVATIONS) OF THE DATA WERE WINDSORIZED BELOW') WRITE (G_IO,99015) perp2 , np2 99015 FORMAT (' ',8X,F10.4,' PERCENT (= ',I0,' OBSERVATIONS) OF THE DATA WERE WINDSORIZED ABOVE') WRITE (G_IO,99016) perp3 , k 99016 FORMAT (' ',8X,F10.4,' PERCENT (= ',I0,' OBSERVATIONS) OF THE DATA WERE UNWINDSORIZED IN THE MIDDLE') 99017 FORMAT (' ','***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') ! END SUBROUTINE WIND end module M_datapac__s