SUBROUTINE MATI50(X,N,Y) C C THIS PROGRAM COMPUTES THE INVERSE OF A SINGLE PRECISION SYMMETRIC C MATRIX WHOSE ORDER DOES NOT EXCEED 50 C THE MODIFIED NO-SQUARE-ROOT CHOLESKI DECOMPOSITION IS USED C N IS THE ORDER OF THE SYMMETRIC MATRIX--N DOES NOT EXCEED 50 C THE INPUT MATRIX IS THE LOWER LEFT TRIANGLE OF ARRAY X C OR, IF AVAILABLE, ALL OF THE ARRAY X C OUTPUT MATRIX--Y. C NOTE--THE DIMENSIONS OF X AND Y MUST BE THE SAME C IN THE CALLING ROUTINE AS IN THIS SUBROUTINE. C THEY HAVE BEEN SET HEREIN TO 50 BY 50, C AND HENCE THE 50 IN THE NAME OF THIS SUBROUTINE (MATI50). C NOTE--MATI50 IS IDENTICAL TO MATI25 AND MATINV C EXCEPT FOR THE DIMENSIONS. C C REFERENCE-- C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82.6 C ORIGINAL VERSION--THESIS C UPDATED --AUGUST 1976. C UPDATED --MARCH 1981. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C CCCCC DOUBLE PRECISION SUM C DIMENSION X(50,50) DIMENSION Y(50,50) C C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='MATI' ISUBN2='50 ' C IF(N-1)115,106,115 106 Y(1,1)=1.0D0/X(1,1) GOTO111 C C WE KNOW THAT A = L TIMES D TIMES L TRANSPOSE WHERE L IS A C LOWER TRIANGULAR MATRIX AND D IS A DIAGONAL MATRIX C THE DIAGONAL ELEMENTS OF L ARE ALL ONES, THEREFORE WE SAVE SPACE C AND OVERWRITE THIS DIAGONAL WITH THE DIAGONAL ELEMENTS OF D C FIND L AND D C 115 Y(1,1)=X(1,1) DO20I=2,N Y(I,1)=X(I,1)/X(1,1) DO30J=2,I SUM=0. JM1=J-1 DO40K=1,JM1 SUM=SUM+Y(K,K)*Y(I,K)*Y(J,K) 40 CONTINUE Y(I,J)=X(I,J)-SUM IF(J-I)41,30,41 41 Y(I,J)=Y(I,J)/Y(J,J) 30 CONTINUE 20 CONTINUE C C FIND L INVERSE AND STORE IT IN THE UPPER RIGHT TRIANGLE OF L C DO60I=2,N IM1=I-1 DO70J=1,IM1 JJ=I-J SUM=0. JJP1=JJ+1 DO80K=JJP1,I IF(K-I)64,65,64 65 SUM=SUM+Y(K,JJ) GOTO80 64 SUM=SUM+Y(K,I)*Y(K,JJ) 80 CONTINUE Y(JJ,I)=-SUM 70 CONTINUE 60 CONTINUE C C FIND A INVERSE=L INVERSE TRANSPOSE TIMES D INVERSE TIMES L INVERSE C STORE THIS IN THE LOWER LEFT TRIANGLE OF L C DO100I=1,N DO110J=1,I SUM=0. DO120K=I,N IF(K-I)91,92,91 91 IF(K-J)93,94,93 93 SUM=SUM+Y(I,K)*Y(J,K)/Y(K,K) GOTO120 94 SUM=SUM+Y(I,K)/Y(K,K) GOTO120 92 IF(K-J)95,96,95 95 SUM=SUM+Y(J,K)/Y(K,K) GOTO120 96 SUM=SUM+1.0D0/Y(K,K) 120 CONTINUE Y(I,J)=SUM 110 CONTINUE 100 CONTINUE C C FILL IN THE UPPER RIGHT TRIANGLE OF THE INVERSE MATRIX C THIS IS NEEDED ONLY BECAUSE OF THE BLUE SUBROUTINE WHICH FOLLOWS C NM1=N-1 DO10I=1,NM1 JMIN=I+1 DO21J=JMIN,N Y(I,J)=Y(J,I) 21 CONTINUE 10 CONTINUE 111 RETURN END SUBROUTINE MATSCA(AMAT,AMAT2,MAXROM,MAXCOM,NR1,NC1,Y1,Y2,Y3, 1IMATSC,ICASE,IWRITE, 1IBUGA3,IERROR) C C PURPOSE--THIS SUBROUTINE SCALES A MATRIX BY C EITHER A SD, RANGE, MEAN, OR Z-SCORE. C INPUT ARGUMENTS--AMAT = THE SINGLE PRECISION MATRIX C --MAXROM = THE INTEGER ROW DIMENSION OF AMAT C --MAXCOM = THE INTEGER COUMN DIMENSION OF AMAT C --NR1 = THE INTEGER NUMBER OF ROWS OF AMAT C --NC1 = THE INTEGER NUMBER OF COLUMNS OF AMAT C OUTPUT ARGUMENTS--AMAT2 = THE SINGLE PRECISION VALUE OF THE C SCALED MATRIX. C OUTPUT--SCALED MATRIX. C NOTE--THIS ROUTINE ASSUMES THE ERROR CHECKING (FOR EQUAL C ROWS AND COLUMNS, MATCHING DIMENSIONS FOR X AND AMAT) C IS DONE BT THE CALLING SUBROUTINE. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C LANGUAGE--ANSI FORTRAN (1977) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--98.6 C ORIGINAL VERSION--JUNE 1998. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C EXTERNAL RANGE C CHARACTER*4 IMATSC CHARACTER*4 ICASE CHARACTER*4 IWRITE CHARACTER*4 IBUGA3 CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C DIMENSION Y1(*) DIMENSION Y2(*) DIMENSION Y3(*) DIMENSION AMAT(MAXROM,MAXCOM) DIMENSION AMAT2(MAXROM,MAXCOM) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='MATS' ISUBN2='CA ' C IERROR='NO' C IF(IBUGA3.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF MATSCA--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA3 52 FORMAT('IBUGA3 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)NR1,NC1 53 FORMAT('NR1, NC1 = ',2I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)ICASE 54 FORMAT('ICASE = ',A4) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C ******************************** C ** SCALE THE MATRIX * C ******************************** C IWRITE='OFF' C IF(IMATSC.EQ.'NONE')THEN DO110J=1,NC1 DO120I=1,NR1 AMAT2(I,J)=AMAT(I,J) 120 CONTINUE 110 CONTINUE GOTO9000 ENDIF C IF(IMATSC.EQ.'MEAN')THEN IF(ICASE.EQ.'ROW ')THEN DO210I=1,NR1 DO215J=1,NC1 Y1(J)=AMAT(I,J) 215 CONTINUE CALL MEAN(Y1,NC1,IWRITE,ASTAT,IBUGA3,IERROR) Y2(I)=ASTAT 210 CONTINUE DO220I=1,NR1 DO225J=1,NC1 AMAT2(I,J)=AMAT(I,J)/Y2(I) 225 CONTINUE 220 CONTINUE ELSE DO230J=1,NC1 DO235I=1,NR1 Y1(I)=AMAT(I,J) 235 CONTINUE CALL MEAN(Y1,NR1,IWRITE,ASTAT,IBUGA3,IERROR) Y2(J)=ASTAT 230 CONTINUE DO240J=1,NC1 DO245I=1,NR1 AMAT2(I,J)=AMAT(I,J)/Y2(J) 245 CONTINUE 240 CONTINUE ENDIF ENDIF C IF(IMATSC.EQ.'RANG')THEN IF(ICASE.EQ.'ROW ')THEN DO310I=1,NR1 DO315J=1,NC1 Y1(J)=AMAT(I,J) 315 CONTINUE CALL RANGE(Y1,NC1,IWRITE,ASTAT,IBUGA3,IERROR) Y2(I)=ASTAT 310 CONTINUE DO320I=1,NR1 DO325J=1,NC1 AMAT2(I,J)=AMAT(I,J)/Y2(I) 325 CONTINUE 320 CONTINUE ELSE DO330J=1,NC1 DO335I=1,NR1 Y1(I)=AMAT(I,J) 335 CONTINUE CALL RANGE(Y1,NR1,IWRITE,ASTAT,IBUGA3,IERROR) Y2(J)=ASTAT 330 CONTINUE DO340J=1,NC1 DO345I=1,NR1 AMAT2(I,J)=AMAT(I,J)/Y2(J) 345 CONTINUE 340 CONTINUE ENDIF ENDIF C IF(IMATSC.EQ.'Z-SC')THEN IF(ICASE.EQ.'ROW ')THEN DO410I=1,NR1 DO415J=1,NC1 Y1(J)=AMAT(I,J) 415 CONTINUE CALL SD(Y1,NC1,IWRITE,ASTAT,IBUGA3,IERROR) Y2(I)=ASTAT CALL MEAN(Y1,NC1,IWRITE,ASTAT,IBUGA3,IERROR) Y3(I)=ASTAT 410 CONTINUE DO420I=1,NR1 DO425J=1,NC1 AMAT2(I,J)=(AMAT(I,J)-Y3(I))/Y2(I) 425 CONTINUE 420 CONTINUE ELSE DO430J=1,NC1 DO435I=1,NR1 Y1(I)=AMAT(I,J) 435 CONTINUE CALL SD(Y1,NR1,IWRITE,ASTAT,IBUGA3,IERROR) Y2(J)=ASTAT CALL MEAN(Y1,NR1,IWRITE,ASTAT,IBUGA3,IERROR) Y3(J)=ASTAT 430 CONTINUE DO440J=1,NC1 DO445I=1,NR1 AMAT2(I,J)=(AMAT(I,J)-Y3(J))/Y2(J) 445 CONTINUE 440 CONTINUE ENDIF ENDIF C IF(IMATSC.EQ.'SD ')THEN IF(ICASE.EQ.'ROW ')THEN DO510I=1,NR1 DO515J=1,NC1 Y1(J)=AMAT(I,J) 515 CONTINUE CALL SD(Y1,NC1,IWRITE,ASTAT,IBUGA3,IERROR) Y3(I)=ASTAT 510 CONTINUE DO520I=1,NR1 DO525J=1,NC1 AMAT2(I,J)=AMAT(I,J)/Y2(I) 525 CONTINUE 520 CONTINUE ELSE DO530J=1,NC1 DO535I=1,NR1 Y1(I)=AMAT(I,J) 535 CONTINUE CALL SD(Y1,NR1,IWRITE,ASTAT,IBUGA3,IERROR) Y3(J)=ASTAT 530 CONTINUE DO540J=1,NC1 DO545I=1,NR1 AMAT2(I,J)=AMAT(I,J)/Y2(J) 545 CONTINUE 540 CONTINUE ENDIF ENDIF C C C ******************************* C ** STEP 3-- ** C ** WRITE OUT A LINE ** C ** OF SUMMARY INFORMATION. ** C ******************************* C IF(IFEEDB.EQ.'OFF')GOTO890 IF(IWRITE.EQ.'OFF')GOTO890 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,811) 811 FORMAT('THE EUCLIDEN DISTANCE MATRIX HAS BEEN CALCULATED.') CALL DPWRST('XXX','BUG ') 890 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE IF(IBUGA3.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF MATSCA--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGA3,IERROR 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)IMATSC 9015 FORMAT('IMATSC = ',A4) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE MAXIM(X,N,IWRITE,XMAX,IBUGA3,IERROR) C C PURPOSE--THIS SUBROUTINE COMPUTES THE C SAMPLE MAXIMUM C OF THE DATA IN THE INPUT VECTOR X. C INPUT ARGUMENTS--X = THE SINGLE PRECISION VECTOR OF C (UNSORTED OR SORTED) OBSERVATIONS. C --N = THE INTEGER NUMBER OF OBSERVATIONS C IN THE VECTOR X. C OUTPUT ARGUMENTS--XMAX = THE SINGLE PRECISION VALUE OF THE C COMPUTED SAMPLE MAXIMUM. C OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE C SAMPLE MAXIMUM. C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--DAVID, ORDER STATISTICS, 1970, PAGE 7. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--82.6 C ORIGINAL VERSION--JUNE 1972. C UPDATED --SEPTEMBER 1975. C UPDATED --NOVEMBER 1975. C UPDATED --JUNE 1979. C UPDATED --AUGUST 1981. C UPDATED --MAY 1982. C UPDATED --FEBRUARY 1988. (SUPPRESS SOME DIAGNOSTIC MESSAGES) C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IWRITE CHARACTER*4 IBUGA3 CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C DIMENSION X(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='MAXI' ISUBN2='M ' C IERROR='NO' C IF(IBUGA3.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF MAXIM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA3 52 FORMAT('IBUGA3 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)N 53 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') DO55I=1,N WRITE(ICOUT,56)I,X(I) 56 FORMAT('I,X(I) = ',I8,E15.7) CALL DPWRST('XXX','BUG ') 55 CONTINUE 90 CONTINUE C C *********************** C ** COMPUTE MAXIMUM ** C *********************** C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C AN=N C IF(N.GE.1)GOTO119 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,111) 111 FORMAT('***** ERROR IN MAXIM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,112) 112 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,113) 113 FORMAT(' IN THE VARIABLE FOR WHICH') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,114) 114 FORMAT(' THE MAXIMUM IS TO BE COMPUTED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,115) 115 FORMAT(' MUST BE 1 OR LARGER.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,116) 116 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,117)N 117 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8, 1'.') CALL DPWRST('XXX','BUG ') GOTO9000 119 CONTINUE C IF(N.EQ.1)GOTO120 GOTO129 120 CONTINUE CCCCC WRITE(ICOUT,999) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,121) CC121 FORMAT('***** NON-FATAL DIAGNOSTIC IN MAXIM--', CCCCC1'THE 2ND INPUT ARGUMENT (N) HAS THE VALUE 1') CCCCC CALL DPWRST('XXX','BUG ') XMAX=X(1) GOTO9000 129 CONTINUE C HOLD=X(1) DO135I=2,N IF(X(I).NE.HOLD)GOTO139 135 CONTINUE CCCCC WRITE(ICOUT,999) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,136)HOLD CC136 FORMAT('***** NON-FATAL DIAGNOSTIC IN MAXIM--', CCCCC1'THE FIRST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7) CCCCC CALL DPWRST('XXX','BUG ') XMAX=HOLD GOTO9000 139 CONTINUE C 190 CONTINUE C C **************************** C ** STEP 2-- ** C ** COMPUTE THE MAXIMUM. ** C **************************** C XMAX=X(1) DO200I=2,N IF(X(I).GT.XMAX)XMAX=X(I) 200 CONTINUE C C ******************************* C ** STEP 3-- ** C ** WRITE OUT A LINE ** C ** OF SUMMARY INFORMATION. ** C ******************************* C IF(IFEEDB.EQ.'OFF')GOTO890 IF(IWRITE.EQ.'OFF')GOTO890 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,811)N,XMAX 811 FORMAT('THE MAXIMUM OF THE ',I8,' OBSERVATIONS = ',E15.7) CALL DPWRST('XXX','BUG ') 890 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE IF(IBUGA3.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF MAXIM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGA3,IERROR 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)N 9013 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)XMAX 9015 FORMAT('XMAX = ',E15.7) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE MAXCDF(X,SIGMA,CDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION C FUNCTION VALUE FOR THE MAXWELL DISTRIBUTION C THIS DISTRIBUTION IS DEFINED FOR NON-NEGATIVE X AND C HAS THE CUMULATIVE DISTRIBUTION FUNCTION C F(X) = 2*IG(3/2,0.5*(1/SIGMA**2)*X**2)/SQRT(PI) C WITH IG DENOTING THE IMCOMPLETE GAMMA FUNCTION. C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE AT C WHICH THE CUMULATIVE DISTRIBUTION C FUNCTION IS TO BE EVALUATED. C X SHOULD BE NON-NEGATIVE. C --SIGMA = THE SINGLE PRECISION VALUE THAT IS C THE SHAPE PARAMETER C OUTPUT ARGUMENTS--CDF = THE SINGLE PRECISION CUMULATIVE C DISTRIBUTION FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION FUNCTION C VALUE CDF FOR THE MAXWELL DISTRIBUTION C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--NONE. C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--DGAMI, DSQRT. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C REFERENCE--JOHNSON, KOTZ, AND BALAKRISHNAN (1994). C "CONTINUOUS UNIVARIATE DISTRIBUTIONS--VOLUME 1", C SECOND EDITION, WILEY, P. 453. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2004.6 C ORIGINAL VERSION--JUNE 2004. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DX DOUBLE PRECISION DS DOUBLE PRECISION DCDF DOUBLE PRECISION DPI DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 DOUBLE PRECISION DTERM3 DOUBLE PRECISION DGAMI C EXTERNAL DGAMI C INCLUDE 'DPCOMC.INC' C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C DATA DPI / 3.1415926535 8979323846 2643383279 503 D0 / C C-----DATA STATEMENTS------------------------------------------------- C C-----START POINT----------------------------------------------------- C C ************************************ C ** STEP 1-- ** C ** COMPUTE THE DENSITY FUNCTION ** C ************************************ C CCCCC IF(X.LT.0.0)THEN CCCCC WRITE(ICOUT,8) CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,48)X CCCCC CALL DPWRST('XXX','WRIT') CCCCC CDF=0.0 CCCCC GOTO9000 CCCCC ENDIF IF(SIGMA.LE.0.0)THEN WRITE(ICOUT,18) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,48)SIGMA CALL DPWRST('XXX','WRIT') CDF=0.0 GOTO9000 ENDIF CCCC8 FORMAT('***** ERROR: VALUE OF THE FIRST ARGUMENT TO MAXCDF ', CCCCC1 'IS NEGATIVE.') 18 FORMAT('***** ERROR: VALUE OF THE SECOND ARGUMENT TO MAXCDF ', 1 'IS NON-POSITIVE.') 48 FORMAT(' VALUE OF ARGUMENT IS: ',G15.7) C IF(X.LE.0.0)THEN CDF=0.0 ELSE DX=DBLE(X) DS=DBLE(SIGMA)**2 IF(DX.GE.DSQRT(D1MACH(2)))THEN CDF=1.0 GOTO9000 ENDIF C DTERM3=2.0D0/DSQRT(DPI) DTERM1=1.5D0 DTERM2=0.5D0*DX*DX/DS DCDF=DTERM3*DGAMI(DTERM1,DTERM2) CDF=REAL(DCDF) ENDIF C 9000 CONTINUE RETURN END SUBROUTINE MAXCD2(DX,DSIGMA,DCDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION C FUNCTION VALUE FOR THE MAXWELL DISTRIBUTION C THIS DISTRIBUTION IS DEFINED FOR NON-NEGATIVE X AND C HAS THE CUMULATIVE DISTRIBUTION FUNCTION C F(X) = 2*IG(3/2,0.5*(1/SIGMA**2)*X**2)/SQRT(PI) C WITH IG DENOTING THE IMCOMPLETE GAMMA FUNCTION. C NOTE--THIS IS A COPY OF MAXCDF USED BY MAXPPF ROUTINE C TO OBTAIN HIGHER ACCURACY IN NUMERICAL INVERSION C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE AT C WHICH THE CUMULATIVE DISTRIBUTION C FUNCTION IS TO BE EVALUATED. C X SHOULD BE NON-NEGATIVE. C --SIGMA = THE SINGLE PRECISION VALUE THAT IS C THE SHAPE PARAMETER C OUTPUT ARGUMENTS--CDF = THE SINGLE PRECISION CUMULATIVE C DISTRIBUTION FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION FUNCTION C VALUE CDF FOR THE MAXWELL DISTRIBUTION C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--NONE. C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--DGAMI, DSQRT. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C REFERENCE--JOHNSON, KOTZ, AND BALAKRISHNAN (1994). C "CONTINUOUS UNIVARIATE DISTRIBUTIONS--VOLUME 1", C SECOND EDITION, WILEY, P. 453. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2004.6 C ORIGINAL VERSION--JUNE 2004. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DX DOUBLE PRECISION DSIGMA DOUBLE PRECISION DS DOUBLE PRECISION DCDF DOUBLE PRECISION DPI DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 DOUBLE PRECISION DTERM3 DOUBLE PRECISION DGAMI C EXTERNAL DGAMI C INCLUDE 'DPCOMC.INC' C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C DATA DPI / 3.1415926535 8979323846 2643383279 503 D0 / C C-----DATA STATEMENTS------------------------------------------------- C C-----START POINT----------------------------------------------------- C C ************************************ C ** STEP 1-- ** C ** COMPUTE THE DENSITY FUNCTION ** C ************************************ C CCCCC IF(X.LT.0.0)THEN CCCCC WRITE(ICOUT,8) CCCCC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,48)X CCCCC CALL DPWRST('XXX','WRIT') CCCCC CDF=0.0 CCCCC GOTO9000 CCCCC ENDIF IF(DSIGMA.LE.0.0D0)THEN WRITE(ICOUT,18) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,48)SIGMA CALL DPWRST('XXX','WRIT') DCDF=0.0D0 GOTO9000 ENDIF CCCC8 FORMAT('***** ERROR: VALUE OF THE FIRST ARGUMENT TO MAXCDF ', CCCCC1 'IS NEGATIVE.') 18 FORMAT('***** ERROR: VALUE OF THE SECOND ARGUMENT TO MAXCDF ', 1 'IS NON-POSITIVE.') 48 FORMAT(' VALUE OF ARGUMENT IS: ',G15.7) C IF(DX.LE.0.0D0)THEN DCDF=0.0D0 ELSE DS=DSIGMA**2 IF(DX.GE.DSQRT(D1MACH(2)))THEN DCDF=1.0D0 GOTO9000 ENDIF C DTERM3=2.0D0/DSQRT(DPI) DTERM1=1.5D0 DTERM2=0.5D0*DX*DX/DS DCDF=DTERM3*DGAMI(DTERM1,DTERM2) ENDIF C 9000 CONTINUE RETURN END subroutine maxofq c c NOTE: This subroutine used in computing the consensus mean c using the Iyer and Wang generalized tolerance interval c approach. c c Modified for Dataplot 3/2006. c implicit none c integer kk double precision aa, ybar, cc, bb(100), yy(100) common /cmn1/ kk common /cmn2/ aa, ybar, cc, bb, yy c integer i double precision sx2, sx1, s1b c sx2 = 0.0d0 sx1 = 0.0d0 s1b = 0.0d0 c do 10 i = 1, kk sx2 = sx2 + yy(i)**2/bb(i) sx1 = sx1 + yy(i)/bb(i) s1b = s1b + 1.0d0/bb(i) 10 continue c aa = sx2 - 2.0d0*ybar*sx1 + ybar**2 * s1b - 1 (sx1 - ybar*s1b)**2/s1b c return end SUBROUTINE MAXPDF(X,SIGMA,PDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY C FUNCTION VALUE FOR THE MAXWELL DISTRIBUTION. C THIS DISTRIBUTION IS DEFINED FOR NON-NEGATIVE X AND C HAS THE PROBABILITY DENSITY FUNCTION C F(X) = SQRT(2/PI)*(1/SIGMA**2)**(3/2)*X**2* C EXP(-(X**2)/(2*SIGMA**2)) C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE AT C WHICH THE PROBABILITY DENSITY C FUNCTION IS TO BE EVALUATED. C X SHOULD BE NON-NEGATIVE. C --SIGMA = THE SINGLE PRECISION VALUE WHICH C DEFINES THE SHAPE PARAMETER C OUTPUT ARGUMENTS--PDF = THE SINGLE PRECISION PROBABILITY C DENSITY FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY FUNCTION C VALUE PDF FOR THE MAXWELL DISTRIBUTION C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--NONE. C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--EXP, LOG. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C REFERENCE--JOHNSON, KOTZ, AND BALAKRISHNAN (1994). C "CONTINUOUS UNIVARIATE DISTRIBUTIONS--VOLUME 1", C SECOND EDITION, WILEY, P. 453. C LANGUAGE--ANSI FORTRAN (1977) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2004.6 C ORIGINAL VERSION--JUNE 2004. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DX DOUBLE PRECISION DS DOUBLE PRECISION DPDF DOUBLE PRECISION DPI DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 DOUBLE PRECISION DTERM3 DOUBLE PRECISION DTERM4 C INCLUDE 'DPCOMC.INC' C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C DATA DPI / 3.1415926535 8979323846 2643383279 503 D0 / C C-----DATA STATEMENTS------------------------------------------------- C C-----START POINT----------------------------------------------------- C C ************************************ C ** STEP 1-- ** C ** COMPUTE THE DENSITY FUNCTION ** C ************************************ C IF(X.LT.0.0)THEN WRITE(ICOUT,8) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,48)X CALL DPWRST('XXX','WRIT') PDF=0.0 GOTO9000 ENDIF IF(SIGMA.LE.0.0)THEN WRITE(ICOUT,18) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,48)SIGMA CALL DPWRST('XXX','WRIT') PDF=0.0 GOTO9000 ENDIF 8 FORMAT('***** ERROR: VALUE OF THE FIRST ARGUMENT TO MAXPDF ', 1 'IS NEGATIVE.') 18 FORMAT('***** ERROR: VALUE OF THE SECOND ARGUMENT TO MAXPDF ', 1 'IS NON-POSITIVE.') 48 FORMAT(' VALUE OF ARGUMENT IS: ',G15.7) C IF(X.EQ.0.0)THEN PDF=0.0 ELSE DX=DBLE(X) DS=DBLE(SIGMA) IF(DX.GE.DSQRT(D1MACH(2)))THEN PDF=0.0 GOTO9000 ENDIF C DTERM1=DLOG(DSQRT(2.0D0/DPI)) DTERM2=1.5D0*DLOG(1.0D0/DS**2) DTERM3=2.0D0*DLOG(DX) DTERM4=-(DX*DX)/(2.0D0*DS**2) DPDF=DTERM1 + DTERM2 + DTERM3 + DTERM4 DPDF=DEXP(DPDF) PDF=REAL(DPDF) ENDIF C 9000 CONTINUE RETURN END SUBROUTINE MAXPPF(P,SIGMA,PPF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT C FUNCTION VALUE FOR THE MAXWELL DISTRIBUTION C THIS DISTRIBUTION IS DEFINED FOR NON-NEGATIVE X AND C HAS THE CUMULATIVE DISTRIBUTION FUNCTION C F(X) = 2*IG(3/2,0.5*(1/SIGMA)*X**2)/SQRT(PI) C WITH IG DENOTING THE IMCOMPLETE GAMMA FUNCTION. C DATAPLOT COMPUTES THE PERCENT POINT FUNCTION BY C NUMERICALLY INVERTING THE CUMULATIVE DISTRIBUTION C FUNCTION. C INPUT ARGUMENTS--P = THE SINGLE PRECISION VALUE AT C WHICH THE PERCENT POINT C FUNCTION IS TO BE EVALUATED. C P SHOULD BE IN THE INTERVAL (0,1]. C --SIGMA = THE SINGLE PRECISION VALUE THAT IS C THE SHAPE PARAMETER C OUTPUT ARGUMENTS--PPF = THE SINGLE PRECISION PERCENT POINT C FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION PERCENT POINT FUNCTION C VALUE PPF FOR THE MAXWELL DISTRIBUTION C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--NONE. C OTHER DATAPAC SUBROUTINES NEEDED--MAXCDF. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCE--JOHNSON, KOTZ, AND BALAKRISHNAN (1994). C "CONTINUOUS UNIVARIATE DISTRIBUTIONS--VOLUME 1", C SECOND EDITION, WILEY, P. 453. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2004.6 C ORIGINAL VERSION--JUNE 2004. C UPDATED --OCTOBER 2006. UPDATE TO DOUBLE PRECISION C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C DOUBLE PRECISION DSIGMA DOUBLE PRECISION DPI DOUBLE PRECISION DP DOUBLE PRECISION EPS DOUBLE PRECISION SIG DOUBLE PRECISION ZERO DOUBLE PRECISION DMEAN DOUBLE PRECISION DSD DOUBLE PRECISION XL DOUBLE PRECISION XR DOUBLE PRECISION XINC DOUBLE PRECISION CDFL DOUBLE PRECISION CDFR DOUBLE PRECISION FXL DOUBLE PRECISION FXR DOUBLE PRECISION FCS DOUBLE PRECISION P1 DOUBLE PRECISION DX DOUBLE PRECISION DCDF C DOUBLE PRECISION DGAMMA EXTERNAL DGAMMA C DATA DPI / 3.1415926535 8979323846 2643383279 503 D0 / DATA EPS /0.000001D0/ DATA SIG /1.0E-7/ DATA ZERO /0.0D0/ DATA MAXIT /3000/ C C-----DATA STATEMENTS------------------------------------------------- C C-----START POINT----------------------------------------------------- C C ************************************ C ** STEP 1-- ** C ** COMPUTE THE DENSITY FUNCTION ** C ************************************ C IF(P.LT.0.0 .OR. P.GE.1.0)THEN WRITE(ICOUT,8) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,48)P CALL DPWRST('XXX','WRIT') PPF=0.0 GOTO9000 ENDIF IF(SIGMA.LE.0.0)THEN WRITE(ICOUT,18) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,48)SIGMA CALL DPWRST('XXX','WRIT') PDF=0.0 GOTO9000 ENDIF 8 FORMAT('***** ERROR: VALUE OF THE FIRST ARGUMENT TO MAXPPF ', 1 'IS OUTSIDE THE [0,1) INTERVAL.') 18 FORMAT('***** ERROR: VALUE OF THE SECOND ARGUMENT TO MAXPDF ', 1 'IS NON-POSITIVE.') 48 FORMAT(' VALUE OF ARGUMENT IS: ',G15.7) C IF(P.EQ.0.0)THEN PPF=0.0 GOTO9000 ENDIF C C FIND BRACKETING INTERVAL. C C 1) LOWER LIMIT = 0 C 2) MEAN = 2*SQRT(2*SIGMA/PI) C SD = SQRT(SIGMA**2*(3*PI-8)/PI) C 3) START RIGHT LIMIT AT MEAN, INCREMENT IN UNITS OF C ONE STANDARD DEVIATION C DSIGMA=DBLE(SIGMA) DP=DBLE(P) DMEAN=2.0D0*DSQRT(2.0D0*DSIGMA/DPI) DSD=DSIGMA**2*(3.0D0*DPI - 8.0D0)/DPI DSD=DSQRT(DSD) C XL=0.0D0 XR=DMEAN XINC=DSD ICOUNT=0 MAXCNT=1000 C 91 CONTINUE IF(XL.LE.0.0D0)XL=0.0D0 IF(XR.LE.0.0D0)XR=XL+XINC CALL MAXCD2(XL,DSIGMA,CDFL) CALL MAXCD2(XR,DSIGMA,CDFR) IF(CDFL.LT.DP .AND. CDFR.LT.DP)THEN XL=XR XR=XL+XINC ELSEIF(CDFL.GT.DP .AND. CDFR.GT.DP)THEN XL=XL-XINC IF(XL.LT.0.0D0)XL=0.0D0 ELSE GOTO99 ENDIF ICOUNT=ICOUNT+1 IF(ICOUNT.GT.MAXCNT)THEN WRITE(ICOUT,96) CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9000 ENDIF 96 FORMAT('***** ERROR--MAXPPF UNABLE TO FIND BRACKETING ', * 'INTERVAL.') GOTO91 C C BISECTION METHOD C 99 CONTINUE IC = 0 FXL = -DP FXR = 1.0D0 - DP 105 CONTINUE DX = (XL+XR)*0.5D0 CALL MAXCD2(DX,DSIGMA,DCDF) P1=DCDF PPF=REAL(DX) FCS = P1 - DP IF(FCS*FXL.GT.ZERO)THEN XL = DX FXL = FCS ELSE XR = DX FXR = FCS ENDIF XRML = XR - XL IF(XRML.LE.SIG .AND. ABS(FCS).LE.EPS)GOTO9000 IC = IC + 1 IF(IC.LE.MAXIT)GOTO105 WRITE(ICOUT,130) CALL DPWRST('XXX','BUG ') 130 FORMAT('***** ERROR--MAXPPF ROUTINE DID NOT CONVERGE.') GOTO9000 C 9000 CONTINUE RETURN END SUBROUTINE MAXRAN(N,SIGMA,ISEED,X) C C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N C FROM THE MAXWELL DISTRIBUTION. C THIS DISTRIBUTION IS DEFINED FOR NON-NEGATIVE X AND HAS C THE PROBABILITY DENSITY FUNCTION C F(X) = SQRT(2/PI)*(1/SIGMA)**(3/2)X**2* C EXP(-X**2/(2*SIGMA)) C INPUT ARGUMENTS--N = THE DESIRED INTEGER NUMBER C OF RANDOM NUMBERS TO BE C GENERATED. C --SIGMA = THE SINGLE PRECISION VALUE THAT IS C THE SHAPE PARAMETER C OUTPUT ARGUMENTS--X = A SINGLE PRECISION VECTOR C (OF DIMENSION AT LEAST N) C INTO WHICH THE GENERATED C RANDOM SAMPLE WILL BE PLACED. C OUTPUT--A RANDOM SAMPLE OF SIZE N C FROM THE MAXWELL DISTRIBUTION C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C OTHER DATAPAC SUBROUTINES NEEDED--UNIRAN, MAXPPF. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCE--JOHNSON, KOTZ, AND BALAKRISHNAN (1994). C "CONTINUOUS UNIVARIATE DISTRIBUTIONS--VOLUME 1", C SECOND EDITION, WILEY, P. 453. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATION INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRMAXMARK C OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2004.6 C ORIGINAL VERSION--JUNE 2004. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DIMENSION X(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----DATA STATEMENTS------------------------------------------------- C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(N.LT.1)THEN WRITE(ICOUT,5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,6) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)N CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF C 5 FORMAT('***** ERROR--FOR THE MAXWELL DISTRIBUTION, THE') 6 FORMAT(' REQUESTED NUMBER OF RANDOM NUMBERS WAS ', 1 'NON-POSITIVE.') 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,'.') 48 FORMAT(' VALUE OF ARGUMENT IS: ',G15.7) C C USE PERCENT POINT TRANSFORMATION METHOD. C CALL UNIRAN(N,ISEED,X) DO100I=1,N ATEMP=X(I) CALL MAXPPF(ATEMP,SIGMA,PPF) X(I)=PPF 100 CONTINUE C 9999 CONTINUE RETURN END SUBROUTINE MCLCDF(X,ALPHA,DCDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION C FUNCTION VALUE FOR THE MCLEISH C DISTRIBUTION WITH SHAPE PARAMETER ALPHA. C THE CUMULATIVE DISTRIBUTION IS COMPUTED BY C NUMERICALLY INTEGRATING THE PDF FUNCTION. C INPUT ARGUMENTS--X = THE DOUBLE PRECISION VALUE AT C WHICH THE CUMULATIVE DISTRIBUTION C FUNCTION IS TO BE EVALUATED. C --ALPHA = THE FIRST SHAPE PARAMETER C OUTPUT ARGUMENTS--CDF = THE DOUBLE PRECISION CUMULATIVE C DISTRIBUTION FUNCTION VALUE. C OUTPUT--THE DOUBLE PRECISION CUMULATIVE DISTRIBUTION C FUNCTION VALUE FOR THE MCLEISH C DISTRIBUTION WITH SHAPE PARAMETERS ALPHA. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--NONE. C OTHER DATAPAC SUBROUTINES NEEDED--DQAG. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, (1994), "CONTINUOUS C UNIVARIATE DISTRIBUTIONS--VOLUME 1", SECOND EDITION, C WILEY, PP. 50-53. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2004.8 C ORIGINAL VERSION--AUGUST 2004. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C INTEGER LIMIT INTEGER LENW PARAMETER(LIMIT=100) PARAMETER(LENW=4*LIMIT) INTEGER INF INTEGER NEVAL INTEGER IER INTEGER LAST INTEGER IWORK(LIMIT) DOUBLE PRECISION ALPHA DOUBLE PRECISION EPSABS DOUBLE PRECISION EPSREL DOUBLE PRECISION RESULT DOUBLE PRECISION DCDF DOUBLE PRECISION X DOUBLE PRECISION DX DOUBLE PRECISION DB DOUBLE PRECISION DC DOUBLE PRECISION DM DOUBLE PRECISION ABSERR DOUBLE PRECISION WORK(LENW) C DOUBLE PRECISION MCLFUN EXTERNAL MCLFUN C DOUBLE PRECISION DALPHA COMMON/MCLCOM/DALPHA C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,AKMBPC,AKMCPW,AKMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----DATA STATEMENTS------------------------------------------------- C C-----START POINT----------------------------------------------------- C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C IF(ALPHA.LE.0.0D0)THEN WRITE(ICOUT,5) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,48)ALPHA CALL DPWRST('XXX','WRIT') CDF=0.0D0 GOTO9000 ENDIF 5 FORMAT('***** ERROR: VALUE OF SHAPE PARAMETER (ALPHA)', 1 ' IN MCLCDF ROUTINE IS NON-POSITIVE.') 48 FORMAT(' VALUE OF ARGUMENT IS: ',G15.7) C C ************************************ C ** STEP 1-- ** C ** COMPUTE THE DENSITY FUNCTION ** C ************************************ C IF(X.EQ.0.0D0)THEN DCDF=0.5D0 GOTO9000 ELSEIF(X.LT.0.0D0)THEN ICASE=0 DX=-X ELSE ICASE=1 DX=X ENDIF C INF=+1 IKEY=3 EPSABS=0.0D0 EPSREL=1.0D-7 DA=0.0D0 IER=0 DCDF=0.0D0 DALPHA=ALPHA C CALL DQAG(MCLFUN,DA,DX,EPSABS,EPSREL,IKEY,DCDF,ABSERR,NEVAL, 1 IER,LIMIT,LENW,LAST,IWORK,WORK) C IF(ICASE.EQ.1)THEN DCDF=0.5D0 + DCDF ELSE DCDF=0.50D0 - DCDF ENDIF C IF(IER.EQ.1)THEN WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,111) 111 FORMAT('***** ERROR FROM MCLCDF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,113) 113 FORMAT(' MAXIMUM NUMBER OF SUBDIVISIONS EXCEEDED.') CALL DPWRST('XXX','BUG ') ELSEIF(IER.EQ.2)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,121) 121 FORMAT('***** ERROR FROM MCLCDF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,123) 123 FORMAT(' ROUNDOFF ERROR PREVENTS REQUESTED TOLERANCE ', 1 'FROM BEING ACHIEVED.') CALL DPWRST('XXX','BUG ') ELSEIF(IER.EQ.3)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,131) 131 FORMAT('***** ERROR FROM MCLCDF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,133) 133 FORMAT(' BAD INTEGRAND BEHAVIOUR DETECTED.') CALL DPWRST('XXX','BUG ') ELSEIF(IER.EQ.4)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,141) 141 FORMAT('***** ERROR FROM MCLCDF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,143) 143 FORMAT(' INTEGRATION DID NOT CONVERGE.') CALL DPWRST('XXX','BUG ') ELSEIF(IER.EQ.5)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,151) 151 FORMAT('***** ERROR FROM MCLCDF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,153) 153 FORMAT(' THE INTEGRATION IS PROBABLY DIVERGENT.') CALL DPWRST('XXX','BUG ') ELSEIF(IER.EQ.6)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,161) 161 FORMAT('***** ERROR FROM MCLCDF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,163) 163 FORMAT(' INVALID INPUT TO THE INTEGRATION ROUTINE.') CALL DPWRST('XXX','BUG ') ENDIF C 9000 CONTINUE RETURN END DOUBLE PRECISION FUNCTION MCLFUN(DX) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY C FUNCTION VALUE FOR THE MCLEISH C DISTRIBUTION WITH SHAPE PARAMETER ALPHA. C THIS DISTRIBUTION IS DEFINED FOR ALL REAL X C AND HAS THE PROBABILITY DENSITY FUNCTION C C MCLPDF(X,ALPHA) = [1/(SQRT(PI)*GAMMA(ALPHA))]* C (ABS(X)/2)**(ALPHA-1/2)* C K(X,ALPHA-1/2) C WHERE C K(X,N) IS THE MODIFIED BESSEL FUNCTION OF THE C SECOND KIND C GAMMA IS THE GAMMA FUNCTION C C THE MCLPDF ROUTINE IS CALLED TO COMPUTE THE C PROBABILITY DENSITY. DEFINE AS FUNCTION TO BE USED FOR C INTEGRATION CODE CALLED BY MCLCDF. THIS ROUTINE USES C DOUBLE PRECISION ARITHMETIC. C INPUT ARGUMENTS--DX = THE DOUBLE PRECISION VALUE AT C WHICH THE PROBABILITY DENSITY C FUNCTION IS TO BE EVALUATED. C OUTPUT ARGUMENTS--MCLFUN = THE DOUBLE PRECISION PROBABILITY C DENSITY FUNCTION VALUE. C OUTPUT--THE DOUBLE PRECISION PROBABILITY DENSITY C FUNCTION VALUE PDF FOR THE MCLEISH C DISTRIBUTION WITH SHAPE PARAMETER ALPHA. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--NONE. C OTHER DATAPAC SUBROUTINES NEEDED--MCLPDF. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, (1994), "CONTINUOUS C UNIVARIATE DISTRIBUTIONS--VOLUME 1", SECOND EDITION, C WILEY, PP. 50-53. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2004.8 C ORIGINAL VERSION--AUGUST 2004. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DTERM C DOUBLE PRECISION DX DOUBLE PRECISION DALPHA COMMON/MCLCOM/DALPHA C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----DATA STATEMENTS------------------------------------------------- C C-----START POINT----------------------------------------------------- C C ************************************ C ** STEP 1-- ** C ** COMPUTE THE DENSITY FUNCTION ** C ************************************ C CALL MCLPDF(DX,DALPHA,DTERM) MCLFUN=DTERM C 9000 CONTINUE RETURN END DOUBLE PRECISION FUNCTION MCLFU2(DX) C C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION C FUNCTION VALUE FOR THE MCLEISH C DISTRIBUTION WITH SHAPE PARAMETER ALPHA. C THIS DISTRIBUTION IS DEFINED FOR ALL REAL X C AND HAS THE PROBABILITY DENSITY FUNCTION C C MCLPDF(X,ALPHA) = [1/(SQRT(PI)*GAMMA(ALPHA))]* C (ABS(X)/2)**(ALPHA-1/2)* C K(X,ALPHA-1/2) C WHERE C K(X,N) IS THE MODIFIED BESSEL FUNCTION OF THE C SECOND KIND C GAMMA IS THE GAMMA FUNCTION C C THE MCLCDF ROUTINE IS CALLED TO COMPUTE THE C CUMULATIVE DISTRIBUTION. DEFINE AS FUNCTION TO BE USED C FOR INTEGRATION CODE CALLED BY MCLCDF. THIS ROUTINE C USES DOUBLE PRECISION ARITHMETIC. C INPUT ARGUMENTS--DX = THE DOUBLE PRECISION VALUE AT C WHICH THE CUMULATIVE DISTRIBUTION C FUNCTION IS TO BE EVALUATED. C OUTPUT ARGUMENTS--MCLFU2 = THE DOUBLE PRECISION CUMULATIVE C DISTRIBUTION FUNCTION VALUE. C OUTPUT--THE DOUBLE PRECISION CUMULATIVE DISTRIBUTION C FUNCTION VALUE CDF FOR THE MCLEISH C DISTRIBUTION WITH SHAPE PARAMETER ALPHA. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--NONE. C OTHER DATAPAC SUBROUTINES NEEDED--MCLCDF. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, (1994), "CONTINUOUS C UNIVARIATE DISTRIBUTIONS--VOLUME 1", SECOND EDITION, C WILEY, PP. 50-53. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2004.8 C ORIGINAL VERSION--AUGUST 2004. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DCDF DOUBLE PRECISION DX C DOUBLE PRECISION DP COMMON/MC2COM/DP C DOUBLE PRECISION DALPHA COMMON/MCLCOM/DALPHA C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----DATA STATEMENTS------------------------------------------------- C C-----START POINT----------------------------------------------------- C C ************************************ C ** STEP 1-- ** C ** COMPUTE THE DENSITY FUNCTION ** C ************************************ C CALL MCLCDF(DX,DALPHA,DCDF) MCLFU2=DP - DCDF C 9000 CONTINUE RETURN END SUBROUTINE MCLPDF(X,ALPHA,PDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY C FUNCTION VALUE FOR THE MCLEISH BESSEL K-FUNCTION C DISTRIBUTION. IT HAS SHAPE PARAMETER ALPHA. C THIS DISTRIBUTION IS SYMMETRIC AND IS DEFINED C FOR ALL REAL X AND HAS THE PROBABILITY DENSITY FUNCTION C C MCLPDF(X,ALPHA) = [1/(SQRT(PI)*GAMMA(ALPHA))]* C (ABS(X)/2)**(ALPHA-1/2)* C K(X,ALPHA-1/2) C WHERE C K(X,N) IS THE MODIFIED BESSEL FUNCTION OF THE C SECOND KIND C GAMMA IS THE GAMMA FUNCTION C C NOTE--ARGUMENTS TO THIS ROUTINE ARE IN DOUBLE PRECISION. C INPUT ARGUMENTS--X = THE DOUBLE PRECISION VALUE AT C WHICH THE PROBABILITY DENSITY C FUNCTION IS TO BE EVALUATED. C X SHOULD BE POSITIVE C --ALPHA = THE FIRST SHAPE PARAMETER C OUTPUT ARGUMENTS--PDF = THE DOUBLE PRECISION PROBABILITY C DENSITY FUNCTION VALUE. C OUTPUT--THE DOUBLE PRECISION PROBABILITY DENSITY FUNCTION C VALUE PDF FOR THE MCLEISH DISTRIBUTION C WITH SHAPE PARAMETER ALPHA. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--NONE. C OTHER DATAPAC SUBROUTINES NEEDED--DBESK. C FORTRAN LIBRARY SUBROUTINES NEEDED--DEXP, DLOG. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--JOHNSON, KOTZ, AND BALAKRISNAN, "CONTINUOUS C UNIVARIATE DISTRIBUTIONS--VOLUME I", SECOND EDITION, C WILEY, 1994, PP. 50-53. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2004.8 C ORIGINAL VERSION--AUGUST 2004. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION X DOUBLE PRECISION DX DOUBLE PRECISION ALPHA DOUBLE PRECISION PDF DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 DOUBLE PRECISION DTERM3 DOUBLE PRECISION DTERM4 DOUBLE PRECISION DORD DOUBLE PRECISION DPI DOUBLE PRECISION DEPS DOUBLE PRECISION DLNGAM EXTERNAL DLNGAM C DOUBLE PRECISION DTEMP1(1000) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----DATA STATEMENTS------------------------------------------------- C DATA DPI / 3.14159265358979D+00/ C C-----START POINT----------------------------------------------------- C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C IF(ALPHA.LE.0.0D0)THEN WRITE(ICOUT,5) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,48)ALPHA CALL DPWRST('XXX','WRIT') PDF=0.0D0 GOTO9000 ENDIF 5 FORMAT('***** ERROR: VALUE OF SHAPE PARAMETER (ALPHA)', 1 ' IN MCLPDF ROUTINE IS NON-POSITIVE.') 48 FORMAT(' VALUE OF ARGUMENT IS: ',G15.7) C C ***************************************** C ** STEP 2-- ** C ** COMPUTE THE DENSITY FUNCTION. FOR ** C ** BETTER NUMERICAL STABILITY, ** C ** COMPUTE LOGARIGHMS. ** C ***************************************** C C C COMPUTE BESSEL FUNCTION FIRST. IF THIS IS 0, SET PDF TO C 0 AND RETURN. C DEPS=1.0D-12 IF(ALPHA.GT.25.0)DEPS=1.0D-10 DX=X DX=DABS(DX) IF(DX.EQ.0.0D0)DX=DEPS DORD=DABS(ALPHA-0.5D0) IARG1=1 ISCALE=1 CALL DBESK(DX,DORD,ISCALE,IARG1,DTEMP1,NZERO) DTERM3=DTEMP1(IARG1) IF(DTERM3.LE.0.0D0)THEN PDF=0.0D0 GOTO9000 ENDIF DTERM3=DLOG(DTERM3) C DTERM1=0.5D0*DLOG(DPI) + DLNGAM(ALPHA) DTERM2=(ALPHA-0.5D0)*DLOG(DX/2.0D0) DTERM4 = -DTERM1+DTERM2+DTERM3 PDF=DEXP(DTERM4) C 9000 CONTINUE RETURN END SUBROUTINE MCLPPF(P,ALPHA,PPF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT C FUNCTION VALUE FOR THE MCLEISH DISTRIBUTION. IT HAS C SHAPE PARAMETERS ALPHA. THIS DISTRIBUTION IS DEFINED C FOR ALL REAL X AND HAS THE PROBABILITY DENSITY FUNCTION C C MCLPDF(X,ALPHA) = [1/(SQRT(PI)*GAMMA(ALPHA))]* C (ABS(X)/2)**(ALPHA-1/2)* C K(X,ALPHA-1/2) C WHERE C K(X,N) IS THE MODIFIED BESSEL FUNCTION OF THE C SECOND KIND C GAMMA IS THE GAMMA FUNCTION C C THE PERCENT POINT FUNCTION IS COMPUTED BY NUMERICALLY C INVERTING THE MCLEISH CUMULATIVE C DISTRIBUTION FUNCTION (WHICH IN TURN IS COMPUTED BY C NUMERICAL INTEGRATION OF THE PROBABILITYT DENSITY. C C INPUT ARGUMENTS--P = THE DOUBLE PRECISION VALUE AT C WHICH THE PERCENT POINT C FUNCTION IS TO BE EVALUATED. C 0 < P < 1 C --ALPHA = THE FIRST SHAPE PARAMETER C OUTPUT ARGUMENTS--PPF = THE SINGLE PRECISION PERCENT POINT C FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION PERCENT POINT FUNCTION C VALUE PPF FOR THE MCLEISH C DISTRIBUTION WITH SHAPE PARAMETER = ALPHA. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--NONE. C OTHER DATAPAC SUBROUTINES NEEDED--DFZERO. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, (1994), "CONTINUOUS C UNIVARIATE DISTRIBUTIONS--VOLUME 1", SECOND EDITION, C WILEY, PP. 50-53. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2004.8 C ORIGINAL VERSION--AUGUST 2004. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION P DOUBLE PRECISION PTEMPL DOUBLE PRECISION PTEMPU DOUBLE PRECISION ALPHA DOUBLE PRECISION PPF DOUBLE PRECISION DINC DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 DOUBLE PRECISION DTERM3 C DOUBLE PRECISION DTEMP1(1000) C DOUBLE PRECISION XUP DOUBLE PRECISION XUP2 DOUBLE PRECISION XLOW DOUBLE PRECISION RE DOUBLE PRECISION AE C DOUBLE PRECISION MCLFU2 EXTERNAL MCLFU2 C DOUBLE PRECISION DP COMMON/MC2COM/DP C DOUBLE PRECISION DALPHA COMMON/MCLCOM/DALPHA C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C ***************************************** C ** STEP 1-- ** C ** CHECK FOR VALID PARAMETERS ** C ***************************************** C IF(P.LE.0.0D0 .OR. P.GE.1.0D0)THEN WRITE(ICOUT,4) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,14) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,48)P CALL DPWRST('XXX','WRIT') PPF=0.0D0 GOTO9000 ENDIF 4 FORMAT('***** ERROR: VALUE OF INPUT ARGUMENT (P) IN ', 1 'MCLPPF ROUTINE') 14 FORMAT(' IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL.') IF(ALPHA.LE.0.0D0)THEN WRITE(ICOUT,5) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,48)ALPHA CALL DPWRST('XXX','WRIT') PPF=0.0D0 GOTO9000 ENDIF 5 FORMAT('***** ERROR: VALUE OF SHAPE PARAMETER (ALPHA)', 1 ' IN MCLPPF ROUTINE IS NON-POSITIVE.') C 48 FORMAT(' VALUE OF ARGUMENT IS: ',G15.7) C IF(P.EQ.0.5D0)THEN PPF=0.0D0 GOTO9000 ENDIF C C ***************************************** C ** STEP 2-- ** C ** COMPUTE THE PERCENT POINT FUNCTION.** C ***************************************** C C STEP 1: FIND BRACKETING INTERVAL. START WITH -10 AND +10, C INCREMENT BY 10. C XLOW=-10.0D0 XUP2=10.0D0 CALL MCLCDF(XLOW,ALPHA,PTEMPL) CALL MCLCDF(XUP2,ALPHA,PTEMPU) DINC=10.0D0 C MAXIT=1000 NIT=0 C 200 CONTINUE IF(NIT.GT.MAXIT)THEN PPF=0.0D0 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,131) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,133) CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF CALL MCLCDF(XLOW,ALPHA,PTEMPL) CALL MCLCDF(XUP2,ALPHA,PTEMPU) IF(PTEMPL.LE.P .AND. P.LE.PTEMPU)THEN XUP=XUP2 GOTO300 ELSEIF(P.GT.PTEMPU)THEN XLOW=XUP2 XUP2=XUP2 + DINC NIT=NIT+1 GOTO200 ELSEIF(P.LT.PTEMPL)THEN XUP2=XLOW XLOW=XLOW - DINC NIT=NIT+1 GOTO200 ENDIF C 300 CONTINUE AE=1.D-7 RE=1.D-7 DALPHA=ALPHA DP=P CALL DFZERO(MCLFU2,XLOW,XUP,XUP,RE,AE,IFLAG) C PPF=XLOW C IF(IFLAG.EQ.2)THEN C C NOTE: SUPPRESS THIS MESSAGE FOR NOW. CCCCC WRITE(ICOUT,999) 999 FORMAT(1X) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,111) CC111 FORMAT('***** WARNING FROM MCLPPF--') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,113) CC113 FORMAT(' PPF VALUE MAY NOT BE COMPUTED TO DESIRED ', CCCCC1 'TOLERANCE.') CCCCC CALL DPWRST('XXX','BUG ') ELSEIF(IFLAG.EQ.3)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,121) 121 FORMAT('***** WARNING FROM MCLPPF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,123) 123 FORMAT(' PPF VALUE MAY BE NEAR A SINGULAR POINT.') CALL DPWRST('XXX','BUG ') ELSEIF(IFLAG.EQ.4)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,131) 131 FORMAT('***** ERROR FROM MCLPPF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,133) 133 FORMAT(' APPROPRIATE BRACKETING INTERVAL NOT FOUND.') CALL DPWRST('XXX','BUG ') ELSEIF(IFLAG.EQ.5)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,141) 141 FORMAT('***** WARNING FROM MCLPPF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,143) 143 FORMAT(' MAXIMUM ITERATIONS EXCEEDED.') CALL DPWRST('XXX','BUG ') ENDIF C C 9000 CONTINUE RETURN END SUBROUTINE MCLRAN(N,ALPHA,ISEED,X) C C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N C FROM THE MCLEISH DISTRIBUTION WITH SHAPE C PARAMETER = ALPHA. THIS DISTRIBUTION IS DEFINED C FOR ALL X AND HAS THE PROBABILITY DENSITY FUNCTION C C MCLPDF(X,ALPHA) = [1/(SQRT(PI)*GAMMA(ALPHA))]* C (ABS(X)/2)**(ALPHA-1/2)* C K(X,ALPHA-1/2) C WHERE C K(X,N) IS THE MODIFIED BESSEL FUNCTION OF THE C SECOND KIND C GAMMA IS THE GAMMA FUNCTION C C TO GENERATE RANDOM NUMBERS, USE THE RELATIONSHIP C C Y = SQRT(G)*Z C C WITH G DENOTING A GAMMA RANDOM VARIABLE WITH SHAPE C ALPHA AND SCALE PARAMETER 2 AND Z A STANDARD NORMAL C RANDOM VARIABLE. C C INPUT ARGUMENTS--N = THE DESIRED INTEGER NUMBER C OF RANDOM NUMBERS TO BE C GENERATED. C --ALPHA = THE SHAPE PARAMETER FOR THE C MCLEISH DISTRIBUTION C OUTPUT ARGUMENTS--X = A SINGLE PRECISION VECTOR C (OF DIMENSION AT LEAST N) C INTO WHICH THE GENERATED C RANDOM SAMPLE WILL BE PLACED. C OUTPUT--A RANDOM SAMPLE OF SIZE N FROM THE MCLEISH DISTRIBUTION C WITH SHAPE PARAMETER ALPHA. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C OTHER DATAPAC SUBROUTINES NEEDED--UNIRAN, NORRAN, GAMRAN. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--JOHNSON, KOTZ, AND BALAKRISNAN, "CONTINUOUS C UNIVARIATE DISTRIBUTIONS--VOLUME I", SECOND EDITION, C WILEY, 1994, PP. 50-51. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATION INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2004.8 C ORIGINAL VERSION--AUGUST 2004. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DIMENSION X(*) DIMENSION Y(2) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----DATA STATEMENTS------------------------------------------------- C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(N.LT.1)THEN WRITE(ICOUT,5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,6) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)N CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF C 5 FORMAT('***** ERROR--FOR THE MCLEISH DISTRIBUTION, THE REQUESTED') 6 FORMAT(' NUMBER OF RANDOM NUMBERS WAS NON-POSITIVE.') 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,'.') CCC48 FORMAT(' VALUE OF ARGUMENT IS: ',G15.7) C C MCLEISH IS DISTRIBUTION OF SQRT(G)*Z WHERE G IS A GAMMA C DISTRIBUTION WITH SHAPE PARAMETER ALPHA AND SCALE PARAMETER 2 C T IS A STANDARD NORMAL DISTRIBUTION. C CALL GAMRAN(N,ALPHA,ISEED,X) NTEMP=1 DO100I=1,N G1=SQRT(2.0*X(I)) CALL NORRAN(NTEMP,ISEED,Y) G2=Y(1) X(I)=G1*G2 100 CONTINUE C 9999 CONTINUE RETURN END SUBROUTINE MEAN(X,N,IWRITE,XMEAN,IBUGA3,IERROR) C C PURPOSE--THIS SUBROUTINE COMPUTES THE C SAMPLE MEAN C OF THE DATA IN THE INPUT VECTOR X. C THE SAMPLE MEAN = (SUM OF THE OBSERVATIONS)/N. C INPUT ARGUMENTS--X = THE SINGLE PRECISION VECTOR OF C (UNSORTED OR SORTED) OBSERVATIONS. C --N = THE INTEGER NUMBER OF OBSERVATIONS C IN THE VECTOR X. C OUTPUT ARGUMENTS--XMEAN = THE SINGLE PRECISION VALUE OF THE C COMPUTED SAMPLE MEAN. C OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE C SAMPLE MEAN. C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--KENDALL AND STUART, THE ADVANCED THEORY OF C STATISTICS, VOLUME 2, EDITION 1, 1961, PAGE 4. C --MOOD AND GRABLE, INTRODUCTION TO THE THEORY C OF STATISTICS, EDITION 2, 1963, PAGE 146. C --DIXON AND MASSEY, INTRODUCTION TO STATISTICAL C ANALYSIS, EDITION 2, 1957, PAGE 14. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--82.6 C ORIGINAL VERSION--JUNE 1972. C UPDATED --SEPTEMBER 1975. C UPDATED --NOVEMBER 1975. C UPDATED --JUNE 1979. C UPDATED --JULY 1981. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IWRITE CHARACTER*4 IBUGA3 CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C DOUBLE PRECISION DN DOUBLE PRECISION DX DOUBLE PRECISION DSUM C DIMENSION X(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='MEAN' ISUBN2=' ' C IERROR='NO' C IF(IBUGA3.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF MEAN--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA3 52 FORMAT('IBUGA3 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)N 53 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') DO55I=1,N WRITE(ICOUT,56)I,X(I) 56 FORMAT('I,X(I) = ',I8,E15.7) CALL DPWRST('XXX','BUG ') 55 CONTINUE 90 CONTINUE C C ******************** C ** COMPUTE MEAN ** C ******************** C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C AN=N C IF(N.GE.1)GOTO119 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,111) 111 FORMAT('***** ERROR IN MEAN--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,112) 112 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,113) 113 FORMAT(' IN THE VARIABLE FOR WHICH') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,114) 114 FORMAT(' THE MEAN IS TO BE COMPUTED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,115) 115 FORMAT(' MUST BE 1 OR LARGER.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,116) 116 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,117)N 117 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8, 1'.') CALL DPWRST('XXX','BUG ') GOTO9000 119 CONTINUE C IF(N.EQ.1)GOTO120 GOTO129 120 CONTINUE CCCCC WRITE(ICOUT,999) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,121) CC121 FORMAT('***** NON-FATAL DIAGNOSTIC IN MEAN--', CCCCC1'THE 2ND INPUT ARGUMENT (N) HAS THE VALUE 1') CCCCC CALL DPWRST('XXX','BUG ') XMEAN=X(1) GOTO9000 129 CONTINUE C HOLD=X(1) DO135I=2,N IF(X(I).NE.HOLD)GOTO139 135 CONTINUE CCCCC WRITE(ICOUT,999) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,136)HOLD CC136 FORMAT('***** NON-FATAL DIAGNOSTIC IN MEAN--', CCCCC1'THE FIRST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7) CCCCC CALL DPWRST('XXX','BUG ') XMEAN=HOLD GOTO9000 139 CONTINUE C 190 CONTINUE C C ************************* C ** STEP 2-- ** C ** COMPUTE THE MEAN. ** C ************************* C DN=N DSUM=0.0D0 DO200I=1,N DX=X(I) DSUM=DSUM+DX 200 CONTINUE XMEAN=DSUM/DN C C ******************************* C ** STEP 3-- ** C ** WRITE OUT A LINE ** C ** OF SUMMARY INFORMATION. ** C ******************************* C IF(IFEEDB.EQ.'OFF')GOTO890 IF(IWRITE.EQ.'OFF')GOTO890 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,811)N,XMEAN 811 FORMAT('THE MEAN OF THE ',I8,' OBSERVATIONS = ',E15.7) CALL DPWRST('XXX','BUG ') 890 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE IF(IBUGA3.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF MEAN--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGA3,IERROR 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)N 9013 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)XMEAN 9015 FORMAT('XMEAN = ',E15.7) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE MEBLOC(ISUBN1,ISUBN2,IBRANCH,MINN2,IANS,IWIDTH, 1NUMARG,NUMV2,IHLEFT,NLEFT,IHHOR,NHOR) C C PURPOSE--MESSAGE SUBROUTINE FOR DPBLOC--BLOCK PLOT ROUTINE C C WRITTEN BY--JAMES J. FILLIBEN C NATIONAL INSTITUTE OF STANDARDS & TECHNOLOGY C GAITHERSBURG, MARYLAND 20899 C PHONE--301-975-2855 C ORIGINAL VERSION--MAY 1992. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 IANS CHARACTER*4 IHLEFT CHARACTER*4 IHHOR C DIMENSION IANS(*) C-----COMMON VARIABLES (GENERAL)-------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT------------------------------------------------ C WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,110)IBRANCH,ISUBN1,ISUBN2 110 FORMAT('***** ERROR ',I6,'IN ',A4,A4,'--') CALL DPWRST('XXX','BUG ') C IF(IBRANCH.EQ.310)GOTO310 IF(IBRANCH.EQ.480)GOTO480 IF(IBRANCH.EQ.510)GOTO510 IF(IBRANCH.EQ.540)GOTO540 GOTO9000 C 310 CONTINUE WRITE(ICOUT,312) 312 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,321) 321 FORMAT(' (FOR WHICH A BLOCK PLOT ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,314) 314 FORMAT(' WAS TO HAVE BEEN FORMED)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,315)MINN2 315 FORMAT(' MUST BE ',I8,' OR LARGER;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,316) 316 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') GOTO8000 C 480 CONTINUE WRITE(ICOUT,482) 482 FORMAT(' AT BRANCH POINT 481--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,483) 483 FORMAT(' NUMARG LESS THAN 1 EVEN THOUGH') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,484) 484 FORMAT(' NUMARG HAD PREVIOUSLY PASSED THIS TEST') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,485)NUMARG 485 FORMAT(' ONCE ALREADY. VALUE OF NUMARG = ',I8) CALL DPWRST('XXX','BUG ') GOTO8000 C 510 CONTINUE WRITE(ICOUT,512) 512 FORMAT(' FOR A BLOCK PLOT, ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,518) 518 FORMAT(' THE NUMBER OF VARIABLES ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,519) 519 FORMAT(' MUST BE 3 OR MORE;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,520) 520 FORMAT(' SUCH WAS NOT THE CASE HERE;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,521) 521 FORMAT(' THE SPECIFIED NUMBER') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,522)NUMV2 522 FORMAT(' OF VARIABLES WAS ',I8) CALL DPWRST('XXX','BUG ') GOTO8000 C 540 CONTINUE WRITE(ICOUT,542) 542 FORMAT(' FOR A BLOCK PLOT, ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,543) 543 FORMAT(' THE NUMBER OF ELEMENTS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,544) 544 FORMAT(' IN ALL THE VARIABLES ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,545) 545 FORMAT(' MUST BE THE SAME; ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,546) 546 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,547) 547 FORMAT(' THE FIRST VARIABLE (RESPONSE VALUES)--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,548)IHLEFT,NLEFT 548 FORMAT(' ',A4,' HAS ',I8,' ELEMENTS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,549)I 549 FORMAT(' VARIABLE ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,550)IHHOR,NHOR 550 FORMAT(' ',A4,' HAS ',I8,' ELEMENTS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') GOTO8000 C 8000 CONTINUE WRITE(ICOUT,8011) 8011 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,8012)(IANS(I),I=1,IWIDTH) 8012 FORMAT(' ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') GOTO9000 C 9000 CONTINUE RETURN END SUBROUTINE MEDIA2(X,N,IWRITE,XMED,IBUGA3,IERROR) C C NOTE--THIS SUBROUTINE IS IDENTICAL TO THE MEDIAN SUBROUTINE C AND WAS CREATED ONLY TO ACHIEVE ECONOMY OF MAPPING. C C PURPOSE--THIS SUBROUTINE COMPUTES THE C SAMPLE MEDIAN C OF THE DATA IN THE INPUT VECTOR X. C THE SAMPLE MEDIAN = THAT VALUE SUCH THAT HALF THE C DATA SET IS BELOW IT AND HALF ABOVE IT. C INPUT ARGUMENTS--X = THE SINGLE PRECISION VECTOR OF C (UNSORTED OR SORTED) OBSERVATIONS. C --N = THE INTEGER NUMBER OF OBSERVATIONS C IN THE VECTOR X. C OUTPUT ARGUMENTS--XMED = THE SINGLE PRECISION VALUE OF THE C COMPUTED SAMPLE MEDIAN. C OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE C SAMPLE MEDIAN. C RESTRICTIONS--THE MAXIMUM ALLOWABLE VALUE OF N C FOR THIS SUBROUTINE IS 15000. C OTHER DATAPAC SUBROUTINES NEEDED--SORT. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--KENDALL AND STUART, THE ADVANCED THEORY OF C STATISTICS, VOLUME 1, EDITION 2, 1963, PAGE 326. C --KENDALL AND STUART, THE ADVANCED THEORY OF C STATISTICS, VOLUME 2, EDITION 1, 1961, PAGE 49. C --DAVID, ORDER STATISTICS, 1970, PAGE 139. C --SNEDECOR AND COCHRAN, STATISTICAL METHODS, C EDITION 6, 1967, PAGE 123. C --DIXON AND MASSEY, INTRODUCTION TO STATISTICAL C ANALYSIS, EDITION 2, 1957, PAGE 70. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--82.6 C ORIGINAL VERSION--JUNE 1972. C UPDATED --SEPTEMBER 1975. C UPDATED --NOVEMBER 1975. C UPDATED --FEBRUARY 1976. C UPDATED --JUNE 1979. C UPDATED --AUGUST 1981. C UPDATED --DECEMBER 1981. C UPDATED --MAY 1982. C UPDATED --JUNE 1990. TEMPORARY ARRAYS TO GARBAGE COMMON C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IWRITE CHARACTER*4 IBUGA3 CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C INCLUDE 'DPCOPA.INC' C DIMENSION X(*) DIMENSION Y(MAXOBV) CCCCC FOLLOWING LINES ADDED JUNE, 1990 INCLUDE 'DPCOZ2.INC' EQUIVALENCE (G2RBAG(IGAR45),Y(1)) CCCCC END CHANGE C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='MEDI' ISUBN2='AN ' C IERROR='NO' IUPPER=MAXOBV C IF(IBUGA3.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF MEDIA2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA3 52 FORMAT('IBUGA3 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)N 53 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') DO55I=1,N WRITE(ICOUT,56)I,X(I) 56 FORMAT('I,X(I) = ',I8,E15.7) CALL DPWRST('XXX','BUG ') 55 CONTINUE 90 CONTINUE C C ********************** C ** COMPUTE MEDIAN ** C ********************** C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C AN=N C IF(1.LE.N.AND.N.LE.IUPPER)GOTO119 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,111) 111 FORMAT('***** ERROR IN MEDIA2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,112) 112 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,113) 113 FORMAT(' IN THE VARIABLE FOR WHICH') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,114) 114 FORMAT(' THE MEDIAN IS TO BE COMPUTED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,115)IUPPER 115 FORMAT(' MUST BE BETWEEN 1 AND ',I8,' (INCLUSIVELY).') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,116) 116 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,117)N 117 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8, 1'.') CALL DPWRST('XXX','BUG ') GOTO9000 119 CONTINUE C IF(N.EQ.1)GOTO120 GOTO129 120 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,121) 121 FORMAT('***** NON-FATAL DIAGNOSTIC IN MEDIA2--', 1'THE 2ND INPUT ARGUMENT (N) HAS THE VALUE 1') CALL DPWRST('XXX','BUG ') XMED=X(1) GOTO9000 129 CONTINUE C GOTO139 CCCCC HOLD=X(1) CCCCC DO135I=2,N CCCCC IF(X(I).NE.HOLD)GOTO139 CC135 CONTINUE CCCCC WRITE(ICOUT,999) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,136)HOLD CC136 FORMAT('***** NON-FATAL DIAGNOSTIC IN MEDIA2--', CCCCC1'THE FIRST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7) CCCCC CALL DPWRST('XXX','BUG ') CCCCC XMED=HOLD CCCCC GOTO9000 139 CONTINUE C 190 CONTINUE C C *************************** C ** STEP 2-- ** C ** COMPUTE THE MEDIAN. ** C *************************** C CALL SORT(X,N,Y) C IEVODD=N-(N/2)*2 NMID=N/2 NMIDP1=NMID+1 IF(IEVODD.EQ.0)XMED=(Y(NMID)+Y(NMIDP1))/2.0 IF(IEVODD.EQ.1)XMED=Y(NMIDP1) C C ******************************* C ** STEP 3-- ** C ** WRITE OUT A LINE ** C ** OF SUMMARY INFORMATION. ** C ******************************* C IF(IFEEDB.EQ.'OFF')GOTO890 IF(IWRITE.EQ.'OFF')GOTO890 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,811)N,XMED 811 FORMAT('THE MEDIAN OF THE ',I8,' OBSERVATIONS = ',E15.7) CALL DPWRST('XXX','BUG ') 890 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE IF(IBUGA3.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF MEDIA2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGA3,IERROR 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)N 9013 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)XMED 9015 FORMAT('XMED = ',E15.7) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE MEDIAN(X,N,IWRITE,XTEMP,MAXNXT,XMED,IBUGA3,IERROR) C C PURPOSE--THIS SUBROUTINE COMPUTES THE C SAMPLE MEDIAN C OF THE DATA IN THE INPUT VECTOR X. C THE SAMPLE MEDIAN = THAT VALUE SUCH THAT HALF THE C DATA SET IS BELOW IT AND HALF ABOVE IT. C INPUT ARGUMENTS--X = THE SINGLE PRECISION VECTOR OF C (UNSORTED OR SORTED) OBSERVATIONS. C --N = THE INTEGER NUMBER OF OBSERVATIONS C IN THE VECTOR X. C OUTPUT ARGUMENTS--XMED = THE SINGLE PRECISION VALUE OF THE C COMPUTED SAMPLE MEDIAN. C OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE C SAMPLE MEDIAN. C OTHER DATAPAC SUBROUTINES NEEDED--SORT. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--KENDALL AND STUART, THE ADVANCED THEORY OF C STATISTICS, VOLUME 1, EDITION 2, 1963, PAGE 326. C --KENDALL AND STUART, THE ADVANCED THEORY OF C STATISTICS, VOLUME 2, EDITION 1, 1961, PAGE 49. C --DAVID, ORDER STATISTICS, 1970, PAGE 139. C --SNEDECOR AND COCHRAN, STATISTICAL METHODS, C EDITION 6, 1967, PAGE 123. C --DIXON AND MASSEY, INTRODUCTION TO STATISTICAL C ANALYSIS, EDITION 2, 1957, PAGE 70. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--82.6 C ORIGINAL VERSION--JUNE 1972. C UPDATED --SEPTEMBER 1975. C UPDATED --NOVEMBER 1975. C UPDATED --FEBRUARY 1976. C UPDATED --JUNE 1979. C UPDATED --AUGUST 1981. C UPDATED --MAY 1982. C UPDATED --FEBRUARY 1988. (COMMENTED OUT INPUT ERROR MESSAGES) C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IWRITE CHARACTER*4 IBUGA3 CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C DIMENSION X(*) DIMENSION XTEMP(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='MEDI' ISUBN2='AN ' C IERROR='NO' C IF(IBUGA3.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF MEDIAN--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA3 52 FORMAT('IBUGA3 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)N 53 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') DO55I=1,N WRITE(ICOUT,56)I,X(I) 56 FORMAT('I,X(I) = ',I8,E15.7) CALL DPWRST('XXX','BUG ') 55 CONTINUE 90 CONTINUE C C ********************** C ** COMPUTE MEDIAN ** C ********************** C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C AN=N C IF(1.LE.N.AND.N.LE.MAXNXT)GOTO119 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,111) 111 FORMAT('***** ERROR IN MEDIAN--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,112) 112 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,113) 113 FORMAT(' IN THE VARIABLE FOR WHICH') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,114) 114 FORMAT(' THE MEDIAN IS TO BE COMPUTED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,115)MAXNXT 115 FORMAT(' MUST BE BETWEEN 1 AND ',I8,' (INCLUSIVELY).') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,116) 116 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,117)N 117 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8, 1'.') CALL DPWRST('XXX','BUG ') GOTO9000 119 CONTINUE C IF(N.EQ.1)GOTO120 GOTO129 120 CONTINUE CCCCC WRITE(ICOUT,999) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,121) CC121 FORMAT('***** NON-FATAL DIAGNOSTIC IN MEDIAN--', CCCCC1'THE 2ND INPUT ARGUMENT (N) HAS THE VALUE 1') CCCCC CALL DPWRST('XXX','BUG ') XMED=X(1) GOTO9000 129 CONTINUE C HOLD=X(1) DO135I=2,N IF(X(I).NE.HOLD)GOTO139 135 CONTINUE CCCCC WRITE(ICOUT,999) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,136)HOLD CC136 FORMAT('***** NON-FATAL DIAGNOSTIC IN MEDIAN--', CCCCC1'THE FIRST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7) CCCCC CALL DPWRST('XXX','BUG ') XMED=HOLD GOTO9000 139 CONTINUE C 190 CONTINUE C C *************************** C ** STEP 2-- ** C ** COMPUTE THE MEDIAN. ** C *************************** C CALL SORT(X,N,XTEMP) C IEVODD=N-(N/2)*2 NMID=N/2 NMIDP1=NMID+1 IF(IEVODD.EQ.0)XMED=(XTEMP(NMID)+XTEMP(NMIDP1))/2.0 IF(IEVODD.EQ.1)XMED=XTEMP(NMIDP1) C C ******************************* C ** STEP 3-- ** C ** WRITE OUT A LINE ** C ** OF SUMMARY INFORMATION. ** C ******************************* C IF(IFEEDB.EQ.'OFF')GOTO890 IF(IWRITE.EQ.'OFF')GOTO890 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,811)N,XMED 811 FORMAT('THE MEDIAN OF THE ',I8,' OBSERVATIONS = ',E15.7) CALL DPWRST('XXX','BUG ') 890 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE IF(IBUGA3.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF MEDIAN--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGA3,IERROR 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)N 9013 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)XMED 9015 FORMAT('XMED = ',E15.7) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE MIDMEA(X,N,IWRITE,XTEMP,MAXNXT,XMIDM,IBUGA3,IERROR) C C PURPOSE--THIS SUBROUTINE COMPUTES THE C SAMPLE MIDMEAN = THE C SAMPLE 25% (ON EACH SIDE) TRIMMED MEAN C OF THE DATA IN THE INPUT VECTOR X. C INPUT ARGUMENTS--X = THE SINGLE PRECISION VECTOR OF C (UNSORTED OR SORTED) OBSERVATIONS. C --N = THE INTEGER NUMBER OF OBSERVATIONS C IN THE VECTOR X. C OUTPUT ARGUMENTS--XMIDM = THE SINGLE PRECISION VALUE OF THE C COMPUTED SAMPLE MIDMEAN. C OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE C SAMPLE MIDMEAN. C OTHER DATAPAC SUBROUTINES NEEDED--SORT. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--DAVID, ORDER STATISTICS, 1970, PAGES 129, 136. C --CROW AND SIDDIQUI, 'ROBUST ESTIMATION OF LOCATION', C JOURNAL OF THE AMERICAN STATISTICAL ASSOCIATION, C 1967, PAGES 357, 387. C --FILLIBEN, SIMPLE AND ROBUST LINEAR ESTIMATION C OF THE LOCATION PARAMETER OF A SYMMETRIC C DISTRIBUTION (UNPUBLISHED PH.D. DISSERTATION, C PRINCETON UNIVERSITY, 1969). C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--82.6 C ORIGINAL VERSION--JUNE 1972. C UPDATED --SEPTEMBER 1975. C UPDATED --NOVEMBER 1975. C UPDATED --FEBRUARY 1976. C UPDATED --JUNE 1979. C UPDATED --AUGUST 1981. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IWRITE CHARACTER*4 IBUGA3 CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DK DOUBLE PRECISION DX DOUBLE PRECISION DSUM C DIMENSION X(*) DIMENSION XTEMP(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='MIDM' ISUBN2='EA ' C IERROR='NO' C IF(IBUGA3.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF MIDMEA--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA3 52 FORMAT('IBUGA3 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)N 53 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') DO55I=1,N WRITE(ICOUT,56)I,X(I) 56 FORMAT('I,X(I) = ',I8,E15.7) CALL DPWRST('XXX','BUG ') 55 CONTINUE 90 CONTINUE C C *********************** C ** COMPUTE MIDMEAN ** C *********************** C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C AN=N C IF(1.LE.N.AND.N.LE.MAXNXT)GOTO119 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,111) 111 FORMAT('***** ERROR IN MIDMEA--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,112) 112 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,113) 113 FORMAT(' IN THE VARIABLE FOR WHICH') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,114) 114 FORMAT(' THE MIDMEAN IS TO BE COMPUTED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,115)MAXNXT 115 FORMAT(' MUST BE BETWEEN 1 AND ',I8,' (INCLUSIVELY).') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,116) 116 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,117)N 117 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8, 1'.') CALL DPWRST('XXX','BUG ') GOTO9000 119 CONTINUE C IF(N.EQ.1)GOTO120 GOTO129 120 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,121) 121 FORMAT('***** NON-FATAL DIAGNOSTIC IN MIDMEA--', 1'THE 2ND INPUT ARGUMENT (N) HAS THE VALUE 1') CALL DPWRST('XXX','BUG ') XMIDM=X(1) GOTO9000 129 CONTINUE C HOLD=X(1) DO135I=2,N IF(X(I).NE.HOLD)GOTO139 135 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,136)HOLD 136 FORMAT('***** NON-FATAL DIAGNOSTIC IN MIDMEA--', 1'THE FIRST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7) CALL DPWRST('XXX','BUG ') XMIDM=HOLD GOTO9000 139 CONTINUE C 190 CONTINUE C C **************************** C ** STEP 2-- ** C ** COMPUTE THE MIDMEAN. ** C **************************** C CALL SORT(X,N,XTEMP) C P1=0.25 NP1=P1*AN+0.0001 ISTART=NP1+1 C P2=0.25 NP2=P2*AN+0.0001 ISTOP=N-NP2 C DSUM=0.0 K=0 IF(ISTART.GT.ISTOP)GOTO250 DO200I=ISTART,ISTOP K=K+1 DX=X(I) DSUM=DSUM+DX 200 CONTINUE DK=K XMIDM=DSUM/DK GOTO290 C 250 CONTINUE IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,251) 251 FORMAT('***** INTERNAL ERROR IN MIDMEA--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,252) 252 FORMAT(' START INDEX IS HIGHER THAN STOP INDEX.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,253)ISTART,ISTOP 253 FORMAT(' ISTART,ISTOP = ',2I8) CALL DPWRST('XXX','BUG ') GOTO9000 290 CONTINUE C C ******************************* C ** STEP 3-- ** C ** WRITE OUT A LINE ** C ** OF SUMMARY INFORMATION. ** C ******************************* C IF(IFEEDB.EQ.'OFF')GOTO890 IF(IWRITE.EQ.'OFF')GOTO890 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') PERP1=100.0*P1 PERP2=100.0*P2 PERP3=100.0*(1.0-P1-P2) WRITE(ICOUT,811)PERP1,NP1 811 FORMAT(8X,F10.4,' PERCENT (= ',I8,' OBSERVATIONS) ', 1'OF THE DATA WERE TRIMMED FROM BELOW') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,812)PERP2,NP2 812 FORMAT(8X,F10.4,' PERCENT (= ',I8,' OBSERVATIONS) ', 1'OF THE DATA WERE TRIMMED FROM ABOVE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,813)PERP3,K 813 FORMAT(8X,F10.4,' PERCENT (= ',I8,' OBSERVATIONS) ', 1'OF THE DATA REMAIN IN MIDDLE AFTER TRIMMING') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,821)N,XMIDM 821 FORMAT('THE MIDMEAN OF THE ',I8,' OBSERVATIONS = ',E15.7) CALL DPWRST('XXX','BUG ') 890 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE IF(IBUGA3.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF MIDMEA--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGA3,IERROR 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)N 9013 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)XMIDM 9015 FORMAT('XMIDM = ',E15.7) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE MIDRAN(X,N,IWRITE,XMIDR,IBUGA3,IERROR) C C PURPOSE--THIS SUBROUTINE COMPUTES THE C SAMPLE MIDRANGE C OF THE DATA IN THE INPUT VECTOR X. C THE SAMPLE MIDRANGE = (SAMPLE MIN + SAMPLE MAX)/2. C INPUT ARGUMENTS--X = THE SINGLE PRECISION VECTOR OF C (UNSORTED OR SORTED) OBSERVATIONS. C --N = THE INTEGER NUMBER OF OBSERVATIONS C IN THE VECTOR X. C OUTPUT ARGUMENTS--XMIDR = THE SINGLE PRECISION VALUE OF THE C COMPUTED SAMPLE MIDRANGE. C OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE C SAMPLE MIDRANGE. C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--KENDALL AND STUART, THE ADVANCED THEORY OF C STATISTICS, VOLUME 1, EDITION 2, 1963, PAGE 338. C --KENDALL AND STUART, THE ADVANCED THEORY OF C STATISTICS, VOLUME 2, EDITION 1, 1961, PAGE 91. C --DAVID, ORDER STATISTICS, 1970, PAGE 97. C --DIXON AND MASSEY, INTRODUCTION TO STATISTICAL C ANALYSIS, EDITION 2, 1957, PAGE 71. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--82.6 C ORIGINAL VERSION--JUNE 1972. C UPDATED --SEPTEMBER 1975. C UPDATED --NOVEMBER 1975. C UPDATED --JUNE 1979. C UPDATED --AUGUST 1981. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IWRITE CHARACTER*4 IBUGA3 CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C DIMENSION X(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='MIDR' ISUBN2='AN ' C IERROR='NO' C IF(IBUGA3.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF MIDRAN--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA3 52 FORMAT('IBUGA3 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)N 53 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') DO55I=1,N WRITE(ICOUT,56)I,X(I) 56 FORMAT('I,X(I) = ',I8,E15.7) CALL DPWRST('XXX','BUG ') 55 CONTINUE 90 CONTINUE C C ************************ C ** COMPUTE MIDRANGE ** C ************************ C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C AN=N C IF(N.GE.1)GOTO119 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,111) 111 FORMAT('***** ERROR IN MIDRAN--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,112) 112 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,113) 113 FORMAT(' IN THE VARIABLE FOR WHICH') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,114) 114 FORMAT(' THE MIDRANGE IS TO BE COMPUTED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,115) 115 FORMAT(' MUST BE 1 OR LARGER.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,116) 116 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,117)N 117 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8, 1'.') CALL DPWRST('XXX','BUG ') GOTO9000 119 CONTINUE C IF(N.EQ.1)GOTO120 GOTO129 120 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,121) 121 FORMAT('***** NON-FATAL DIAGNOSTIC IN MIDRAN--', 1'THE 2ND INPUT ARGUMENT (N) HAS THE VALUE 1') CALL DPWRST('XXX','BUG ') XMIDR=X(1) GOTO9000 129 CONTINUE C HOLD=X(1) DO135I=2,N IF(X(I).NE.HOLD)GOTO139 135 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,136)HOLD 136 FORMAT('***** NON-FATAL DIAGNOSTIC IN MIDRAN--', 1'THE FIRST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7) CALL DPWRST('XXX','BUG ') XMIDR=HOLD GOTO9000 139 CONTINUE C 190 CONTINUE C C ***************************** C ** STEP 2-- ** C ** COMPUTE THE MIDRANGE. ** C ***************************** C XMIN=X(1) XMAX=X(1) DO200I=1,N IF(X(I).LT.XMIN)XMIN=X(I) IF(X(I).GT.XMAX)XMAX=X(I) 200 CONTINUE XMIDR=(XMIN+XMAX)/2.0 C C ******************************* C ** STEP 3-- ** C ** WRITE OUT A LINE ** C ** OF SUMMARY INFORMATION. ** C ******************************* C IF(IFEEDB.EQ.'OFF')GOTO890 IF(IWRITE.EQ.'OFF')GOTO890 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,811)N,XMIDR 811 FORMAT('THE MIDRANGE OF THE ',I8,' OBSERVATIONS = ',E15.7) CALL DPWRST('XXX','BUG ') 890 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE IF(IBUGA3.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF MIDRAN--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGA3,IERROR 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)N 9013 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)XMIDR 9015 FORMAT('XMIDR = ',E15.7) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE MINDIS(AMAT,AMAT2,MAXROM,MAXCOM,NR1,NC1,P,ICASE, 1IWRITE,IBUGA3,IERROR) C C PURPOSE--THIS SUBROUTINE COMPUTES THE C MINKOWSKI DISTANCE OF A MATRIX. THE FORMULA IS: C Dij=SUM(ABS|(Xik - Xjk)|**P)**(1/P) C THE SUM IS FROM K = 1 TO P (WHERE THERE ARE P C COLUMNS IN THE MATRIX). FOR EXAMPLE, D23 IS C THE DISTANCE BETWEEN THE SECOND AND THIRD ROWS. C (ALTERNATIVELY, THE DISTANCE CAN BE CALCULATED C ACROSS COLUMNS). C INPUT ARGUMENTS--AMAT = THE SINGLE PRECISION MATRIX C --MAXROM = THE INTEGER ROW DIMENSION OF AMAT C --MAXCOM = THE INTEGER COUMN DIMENSION OF AMAT C --NR1 = THE INTEGER NUMBER OF ROWS OF AMAT C --NC1 = THE INTEGER NUMBER OF COLUMNS OF AMAT C OUTPUT ARGUMENTS--AMAT2 = THE SINGLE PRECISION VALUE OF THE C COMPUTED SAMPLE MINKOWSKI DISTANCES. C OUTPUT--MATRIX OF MINKOWSKI DISTANCES C NOTE--THIS ROUTINE ASSUMES THE ERROR CHECKING (FOR EQUAL C ROWS AND COLUMNS, MATCHING DIMENSIONS FOR X AND AMAT) C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C LANGUAGE--ANSI FORTRAN (1977) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--98.7 C ORIGINAL VERSION--JULY 1998. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICASE CHARACTER*4 IWRITE CHARACTER*4 IBUGA3 CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C DOUBLE PRECISION DSUM DOUBLE PRECISION DYM1 DOUBLE PRECISION DYM2 C DIMENSION AMAT(MAXROM,MAXCOM) DIMENSION AMAT2(MAXROM,MAXCOM) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='CHED' ISUBN2='IS ' C IERROR='NO' C IF(IBUGA3.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF MINDIS--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA3 52 FORMAT('IBUGA3 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)NR1,NC1 53 FORMAT('NR1, NC1 = ',2I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)ICASE 54 FORMAT('ICASE = ',A4) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C ******************************** C ** COMPUTE MINKOWSKI DISTANCE * C ******************************** C IF(ICASE.EQ.'ROW ')THEN DO5861I=1,NR1 DO5863J=1,I IF(I.EQ.1)THEN AMAT2(I,I)=0.0 ELSE DSUM=0.0D0 DO5865K=1,NC1 DYM1=AMAT(I,K) DYM2=AMAT(J,K) DSUM=DSUM + DABS(DYM1-DYM2)**DBLE(P) 5865 CONTINUE AMAT2(I,J)=REAL(DSUM**(1.0D0/DBLE(P))) AMAT2(J,I)=AMAT2(I,J) ENDIF 5863 CONTINUE 5861 CONTINUE ELSEIF(ICASE.EQ.'COLU')THEN DO5961I=1,NC1 DO5963J=1,I IF(I.EQ.J)THEN AMAT2(I,I)=0.0 ELSE DSUM=0.0D0 DO5965K=1,NR1 DYM1=AMAT(K,I) DYM2=AMAT(K,J) DSUM=DSUM + DABS(DYM1-DYM2)**DBLE(P) 5965 CONTINUE AMAT2(I,J)=REAL(DSUM**(1.0D0/DBLE(P))) AMAT2(J,I)=AMAT2(I,J) ENDIF 5963 CONTINUE 5961 CONTINUE ENDIF C C ******************************* C ** STEP 3-- ** C ** WRITE OUT A LINE ** C ** OF SUMMARY INFORMATION. ** C ******************************* C IF(IFEEDB.EQ.'OFF')GOTO890 IF(IWRITE.EQ.'OFF')GOTO890 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,811) 811 FORMAT('THE MINKOWSKI DISTANCE MATRIX HAS BEEN CALCULATED.') CALL DPWRST('XXX','BUG ') 890 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE IF(IBUGA3.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF MINDIS--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGA3,IERROR 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE MINIM(X,N,IWRITE,XMIN,IBUGA3,IERROR) C C PURPOSE--THIS SUBROUTINE COMPUTES THE C SAMPLE MINIMUM C OF THE DATA IN THE INPUT VECTOR X. C INPUT ARGUMENTS--X = THE SINGLE PRECISION VECTOR OF C (UNSORTED OR SORTED) OBSERVATIONS. C --N = THE INTEGER NUMBER OF OBSERVATIONS C IN THE VECTOR X. C OUTPUT ARGUMENTS--XMIN = THE SINGLE PRECISION VALUE OF THE C COMPUTED SAMPLE MINIMUM. C OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE C SAMPLE MINIMUM. C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--DAVID, ORDER STATISTICS, 1970, PAGE 7. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--82.6 C ORIGINAL VERSION--JUNE 1972. C UPDATED --SEPTEMBER 1975. C UPDATED --NOVEMBER 1975. C UPDATED --JUNE 1979. C UPDATED --AUGUST 1981. C UPDATED --MAY 1982. C UPDATED --FEBRUARY 1988. (SUPPRESS SOME DIAGNOSTIC MESSAGES) C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IWRITE CHARACTER*4 IBUGA3 CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C DIMENSION X(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='MINI' ISUBN2='M ' C IERROR='NO' C IF(IBUGA3.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF MINIM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA3 52 FORMAT('IBUGA3 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)N 53 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') DO55I=1,N WRITE(ICOUT,56)I,X(I) 56 FORMAT('I,X(I) = ',I8,E15.7) CALL DPWRST('XXX','BUG ') 55 CONTINUE 90 CONTINUE C C *********************** C ** COMPUTE MINIMUM ** C *********************** C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C AN=N C IF(N.GE.1)GOTO119 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,111) 111 FORMAT('***** ERROR IN MINIM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,112) 112 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,113) 113 FORMAT(' IN THE VARIABLE FOR WHICH') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,114) 114 FORMAT(' THE MINIMUM IS TO BE COMPUTED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,115) 115 FORMAT(' MUST BE 1 OR LARGER.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,116) 116 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,117)N 117 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8, 1'.') CALL DPWRST('XXX','BUG ') GOTO9000 119 CONTINUE C IF(N.EQ.1)GOTO120 GOTO129 120 CONTINUE CCCCC WRITE(ICOUT,999) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,121) CC121 FORMAT('***** NON-FATAL DIAGNOSTIC IN MINIM--', CCCCC1'THE 2ND INPUT ARGUMENT (N) HAS THE VALUE 1') CCCCC CALL DPWRST('XXX','BUG ') XMIN=X(1) GOTO9000 129 CONTINUE C HOLD=X(1) DO135I=2,N IF(X(I).NE.HOLD)GOTO139 135 CONTINUE CCCCC WRITE(ICOUT,999) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,136)HOLD CC136 FORMAT('***** NON-FATAL DIAGNOSTIC IN MINIM--', CCCCC1'THE FIRST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7) CCCCC CALL DPWRST('XXX','BUG ') XMIN=HOLD GOTO9000 139 CONTINUE C 190 CONTINUE C C **************************** C ** STEP 2-- ** C ** COMPUTE THE MINIMUM. ** C **************************** C XMIN=X(1) DO200I=2,N IF(X(I).LT.XMIN)XMIN=X(I) 200 CONTINUE C C ******************************* C ** STEP 3-- ** C ** WRITE OUT A LINE ** C ** OF SUMMARY INFORMATION. ** C ******************************* C IF(IFEEDB.EQ.'OFF')GOTO890 IF(IWRITE.EQ.'OFF')GOTO890 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,811)N,XMIN 811 FORMAT('THE MINIMUM OF THE ',I8,' OBSERVATIONS = ',E15.7) CALL DPWRST('XXX','BUG ') 890 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE IF(IBUGA3.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF MINIM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGA3,IERROR 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)N 9013 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)XMIN 9015 FORMAT('XMIN = ',E15.7) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END subroutine mixtur(a, k, m, c, x, n, + alpha, mean, sd, tol, nobvs, + newalp,newmea,newsd,dt,nt,vt,g,f,kmax,mmax, + logl, counter, ifault) c c Translation from Algol 60 by Alan Miller of AS 203. c c ALGORITHM AS 203 APPL. STATIST. (1984) VOL.33, NO. 3 c c This algorithm calculates the maximum likelihood estimates of the c parameters of a mixture of normal or exponential or Poisson or c binomial distributions. These parameters are the mixing c proportions, the means and (in the normal distribution case) c standard deviations. It also calculates the log-likelihood c function and the number of iterations taken to satisfy the c tolerance value. c c Users must provide their own routine `putout' which prints the c estimated parameter values after each iteration. The form of c this routine is: c subroutine putout(k, alpha, mean, sd, logl) c integer k c real alpha(k), mean(k), sd(k), logl c c Notes: c The original (Algol) variable names have been retained. This c means that some variable names have more than 6 characters, such c as `counter', `newalp', etc. c c NOTE: For Dataplot, variable names have been modified to be c six characters or less. c c The authors treat the normal distribution as if it were a discrete c distribution. c In Fortran 77 it is necessary to give explicit dimensions to some c of the temporary arrays which are not passed as arguments. c Maximum values have been set for k and m (kmax and mmax) in the c parameter statement under `Local variables' below. c c NOTE: For Dataplot, dimension in calling routine and pass c in to this routine. c integer a, k, m, c, n(m), nobvs, icount, ifault real x(m), alpha(k), mean(k), sd(k), tol, logl ccccc external putout c c Local variables c integer kmax, mmax, i, j ccccc parameter (kmax = 20, mmax = 100) logical test real sumalp, part, oldlgl real zero, one, half c real newalp(kmax) real newmea(kmax) real newsd(kmax) real dt(kmax) real nt(kmax) real vt(kmax) c real g(mmax) real f(mmax, kmax) c data zero /0.0/, one /1.0/, half /0.5/ c if (a .lt. 1 .or. a .gt. 4) then ifault = 1 return else ifault = 0 end if do 10 i = 1, m-1 if (x(i) .gt. x(i+1)) then ifault = 5 return end if 10 continue if (nobvs .lt. 2 * m) then ifault = 6 return end if do 20 i = 1, m if (n(i) .lt. 0) then ifault = 6 return end if if (a .ne. 1) then if (x(i) .lt. zero) then ifault = 7 return end if end if 20 continue oldlgl = zero icount = 0 c c Start of iterative cycle c 30 icount = icount + 1 do 40 j = 1, k if (alpha(j) .gt. one .or. alpha(j) .lt. zero) then ifault = 2 return end if if (mean(j) .ge. x(m) .or. mean(j) .le. x(1)) then ifault = 3 return end if if (a .eq. 1) then if (sd(j) .le. zero) then ifault = 4 return end if end if 40 continue do 60 i = 1, k-1 do 50 j = i+1, k if (mean(i) .eq. mean(j)) then if (a .eq. 1) then if (sd(i) .eq. sd(j)) then ifault = 9 return end if else ifault = 8 return end if end if 50 continue 60 continue logl = zero do 80 i = 1, m g(i) = zero do 70 j = 1, k c c a = 1 denotes normal mixture c a = 2 denotes exponential mixture c a = 3 denotes Poisson mixture c a = 4 denotes binomial mixture c if (a .eq. 1) then f(i,j) = exp(-half*((x(i) - mean(j))/sd(j))**2) / sd(j) else if (a .eq. 2) then f(i,j) = exp(-x(i)/mean(j)) / mean(j) else if (a .eq. 3) then if (x(i) .eq. x(1)) then f(i,j) = exp(-mean(j)) * mean(j)**x(i) else f(i,j) = f(i-1,j) * mean(j) end if else if (x(i) .eq. x(1)) then f(i,j) = (one - mean(j) / x(m))**x(m) * (mean(j) / + (x(m) - mean(j)))**x(i) else f(i,j) = f(i-1,j) * (mean(j) / (x(m) - mean(j))) end if end if g(i) = g(i) + alpha(j) * f(i,j) 70 continue logl = logl + n(i) * log(g(i)) 80 continue c c Calculation of the probability densities of the sub-populations c which form the mixture, and the log-likelihood function. c test = .false. sumalp = zero do 100 j = 1, k nt(j) = zero dt(j) = zero vt(j) = zero do 90 i = 1, m part = f(i,j) * n(i) / g(i) dt(j) = dt(j) + part nt(j) = nt(j) + part * x(i) if (a .eq. 1) vt(j) = vt(j) + part * (x(i) - mean(j))**2 90 continue c c Calculation of denominators and numerators of new estimates. c newmea(j) = nt(j) / dt(j) if (j .ne. k) then newalp(j) = alpha(j) * dt(j) / nobvs sumalp = sumalp + newalp(j) else newalp(k) = one - sumalp end if if (a .eq. 1) newsd(j) = sqrt(vt(j) / dt(j)) c c Convergence test. c if (abs(oldlgl - logl) .gt. tol) test = .true. oldlgl = logl alpha(j) = newalp(j) mean(j) = newmea(j) if (a .eq. 1) sd(j) = newsd(j) 100 continue c if (c .gt. 0) then if ((icount/c)*c .eq. icount) then ccccc call putout(k, alpha, mean, sd, logl) end if end if if (test) go to 30 return end SUBROUTINE MLEGEV(X, N, PARA, VCOV, MONIT, IFAULT) C ALGORITHM AS215 APPL. STATIST. (1985) VOL. 34, NO. 3 C Modifications in AS R76 (1989) have been incorporated. C C MAXIMUM-LIKELIHOOD ESTIMATION OF GENERALIZED EXTREME-VALUE C DISTRIBUTION C DOUBLE PRECISION PARA(3), VCOV(6), X(N) DOUBLE PRECISION A, ACCA, ACCG, ACCU, AI, AIGI, AN, D, DA, DAA, * DAG, DELA, DELG, DELU, DG, DGG, DU, DUA, DUG, DUU, E, F, FOLD, * G, GAI, GG, GI, GIPQ, GNORM, H, HALF, HE, HH, ONE, P, PA, PQ, * PQG, PU, Q, QA, QU, R, RA, RATIO, RG, RU, SE, SH, SHE, SHH, * SHHE, SMALL, SRF, STEPA, STEPG, STEPU, SY, SYE, SYHE, SYYE, * TEMP1, TEMP2, U, VLNEG, XMAX, XMIN, Y, YE, Z, ZERO CHARACTER*8 ACTI1, ACTI2, ACTI3, ACTI4, ACTI5, ACTI6, ACTI7, * ACTI8, ACTI9 C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C DATA ACTI1/' NEWTON'/, ACTI2/' ST.ASC'/, ACTI3/' RESETK'/, * ACTI4/' SR.INF'/, ACTI5/' SR.LIK'/, ACTI6/' MAX.SR'/, * ACTI7/' MAX.EV'/, ACTI8/' MAX.IT'/, ACTI9/' CONVGD'/ DATA ZERO /0.0D0/, HALF /0.5D0/, ONE/1.0D0/ C C ADDU,ACCA,ACCG ARE ACCURACY CRITERIA FOR TESTING CONVERGENCE C STEPU,STEPA,STEPG ARE MAXIMUM STEPLENGTHS FOR ITERATIONS C ACCU,ACCA,STEPU,STEPA ARE SCALED BY CURRENT VALUE OF A WHEN C USED IN PROGRAM C CCCCC DATA ACCU, ACCA, ACCG /3 * 1.0D-5/, STEPU, STEPA, STEPG / DATA ACCU /0.00001D0/ DATA ACCA /0.00001D0/ DATA ACCG /0.00001D0/ DATA STEPU /0.5D0/ DATA STEPA /0.25D0/ DATA STEPG /0.01D0/ C C MAXIT IS MAX. NO. OF ITERATIONS C MAXEV IS MAX. NO. OF EVALUATIONS OF LIKELIHOOD FUNCTION C SRF IS STEPLENGTH REDUCTION FACTOR C MAXSR IS MAX. NO. OF STEPLENGTH REDUCTIONS PERMITTED PER C ITERATION C CCCCC DATA MAXIT /30/, MAXEV /50/, SRF /0.25D0/, MAXSR /30/ DATA MAXIT /300/, MAXEV /500/, SRF /0.25D0/, MAXSR /30/ C C SMALL IS A SMALL NUMBER, USED TO ADJUST THE SHAPE PARAMETER TO C AVOID AN EXACT ZERO VALUE OR BORDERLINE INFEASIBILITY C ALNEG IS A LARGE NEGATIVE NUMBER, USED TO INITIALIZE C LOG-LIKELIHOOD C DATA SMALL /1.D-3/, VLNEG /-1.D37/ C C FIND MIN AND MAX DATA VALUE C DO 10 I = 1, 6 10 VCOV(I) = ZERO IFAULT = 1 IF (N .LE. 2) GOTO 170 XMIN = X(1) XMAX = X(1) DO 20 I = 2, N IF (X(I) .LT. XMIN) XMIN = X(I) IF (X(I) .GT. XMAX) XMAX = X(I) 20 CONTINUE C C INITIALIZATION C U IS LOCATION PARAMETER C A IS SCALE PARAMETER C G IS SHAPE PARAMETER C IF (MONIT .GT. 0) THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE (ICOUT, 6000) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE (ICOUT, 6003) CALL DPWRST('XXX','BUG ') ENDIF 999 FORMAT(1X) 6000 FORMAT(' MAXIMUM-LIKELIHOOD ESTIMATION OF GENERALIZED EXTREME', * 1X, 'VALUE DISTRIBUTION') 6003 FORMAT(' ITER EVAL', 8X, 'XI', 5X, 'ALPHA', * 9X, 'K ACTION', 6X, 'LOG-L', 7X, 'GNORM') C IFAULT = 0 NITER = 0 NEVAL =0 FOLD = VLNEG U = PARA(1) A = PARA(2) G = PARA(3) IF (G .EQ. ZERO) G = SMALL IF (Z .LE. ZERO) A = ONE AN = DBLE(FLOAT(N)) C C CHECK WHETHER ALL DATA POINTS LIE WITHIN THE RANGE OF THE GEV C DISTRIBUTION WITH THE INITIAL PARAMETERS - IF NOT, ADJUST THE C SHAPE PARAMETER SO AS TO BRING ALL POINTS WITHIN RANGE C IF (G .GT. ZERO) GOTO 30 IF (XMIN .GE. U) GOTO 40 Z = A / (XMIN - U) IF (MONIT .GT. 0) THEN WRITE (ICOUT, 6010) NITER, NEVAL, U, A, G, ACTI3 CALL DPWRST('XXX','BUG ') ENDIF 6010 FORMAT(1X, I4, I5, 3F10.4, 1X, A, F11.3, 1PD12.2) C G = Z + SMALL IF (G .GE. ZERO) G = HALF * Z GOTO 40 30 IF (XMAX .LE. U) GOTO 40 Z = A / (XMAX - U) IF (G .LT. Z) GOTO 40 IF(MONIT .GT. 0) THEN WRITE (ICOUT, 6010) NITER, NEVAL, U, A, G, ACTI3 CALL DPWRST('XXX','BUG ') ENDIF C G = Z - SMALL IF (G .LE. ZERO) G = HALF * Z C C START OF MAIN LOOP C 40 DO 140 NITER = 1, MAXIT C NSR = 0 50 IF (NEVAL .GE. MAXEV) GOTO 150 NEVAL = NEVAL + 1 AI = ONE / A GI = ONE /G GAI = G * AI AIGI = AI * GI GG = ONE - G C C ACCUMULATE SUMS OF QUANTITIES OCCURRING IN LIKELIHOOD C DERIVATIVES C C IN PRESCOTT AND WALDEN'S NOTATION: C Z IS 1 - K * (X(I)-U) / A C Y IS THE REDUCED VARIATE - (1/K) * LOG(Z) C E IS EXP(-Y) C H IS EXP(K*Y) C SY = ZERO SE = ZERO SYE = ZERO SYYE = ZERO SH = ZERO SHE = ZERO SYHE = ZERO SHHE = ZERO SHH = ZERO DO 60 I = 1, N Z = ONE -GAI * (X(I) - U) Y = -GI * LOG(Z) E = EXP(-Y) H = ONE / Z YE = Y * E HE = H * E HH = H * H SY = SY + Y SY = SY + E SYE = SYE + YE SYYE = SYYE + Y * YE SH = SH + H SHE = SHE + HE SYHE = SYHE + Y * HE SHHE = SHHE + HH * E SHH = SHH + HH 60 CONTINUE C C F IS CURRENT VALUE OF LIKELIHOOD FUNCTIONN C F = -AN * LOG(A) - GG * SY - SE IF (F .GT. FOLD) GOTO 90 C C LIKELIHOOD HAS NOT INCREASED - REDUCE STEPLENGTH AND TRY AGAIN C IF (MONIT .GT. 0) THEN WRITE(ICOUT, 6010) NITER, NEVAL, U, A, G, ACTI5, F CALL DPWRST('XXX','BUG ') ENDIF C IF (NSR .EQ. MAXSR) GOTO 80 70 NSR = NSR + 1 U = U - DELU A = A - DELA G = G - DELG DELU = SRF * DELU DELA = SRF * DELA DELG = SRF * DELG U = U + DELU A = A + DELA G = G + DELG IF (A .GT. G * (XMIN - U) .AND. A .GT. G * (XMAX - U) .AND. G .NE. * ZERO) GO TO 50 IF (MONIT .GT. 0) THEN WRITE (ICOUT, 6010) NITER, NEVAL, U, A, G, ACTI4 CALL DPWRST('XXX','BUG ') ENDIF C IF (NSR .LT. MAXSR) GOTO 70 C C MAX. NO. OF STEPLENGTH REDUCTIONS REACHED C IF CURRENT ITERATION IS NEWTON-RAPHSON, TRY STEEPEST ASCENT C INSTEAD. IF CURRENT ITERATION IS STEEPEST ASCENT, GIVE UP. C 80 U = U - DELU A = A - DELA G = G - DELG IF (MONIT .GT. 0) THEN WRITE(ICOUT, 6010) NITER, NEVAL, U, A, G, ACTI6 CALL DPWRST('XXX','BUG ') ENDIF C IF (ITYPE .EQ. 1) GOTO 100 IFAULT = 4 GOTO 160 C C P,Q,R, ARE AS DEFINED IN FLOOD STUDIES REPORT C 90 FOLD = F P = AN - SE Q = SHE - GG * SH R = AN - SY + SYE PQ = P + Q GIPQ = GI * PQ C C FIRST DERIVATIVES OF LOG-LIKELIHOOD C DU = -AI * Q DA = -AIGI * PQ DG = -GI * (R - GIPQ) IF (MONIT .GT. 0) GNORM = SQRT(DU * DU + DA * DA + DG * DG) C C DERIVATIVES OF P,Q,R C PU = -AI * SHE PA = GI * PU + AIGI * SE QU = GG * AI * (SHHE + G * SHH) RU = AI * (SH - SHE + SYHE) RA = GI * RU - AIGI * (AN - SE + SYE) RG = GI * (SY - SYE + SYYE - A * RA) QA = AI * Q + GI * (PU + QU) PQG = GIPQ + A * (RA - GI * (PA + QA)) C C MINUS SECOND DERIVATIVE OF LOG-LIKELIHOOD (HESSIAN MATRIX) C DUU = AI * QU DUA = AIGI * (PU + QU) DAA = -AIGI * (AI * PQ - PA - QA) DUG = GI * (RU - GI * (PU + QU)) DAG = -AIGI * (GIPQ - PQG) DGG = GI * (RG - GI * (PQG + R - GIPQ - GIPQ)) C C INVERT HESSIAN MATRIX C DO 95 KK = 1, 3 IF (DUU .LE. ZERO) GO TO 100 D = ONE / DUU TEMP1 = -DUA * D IF (KK .GT. 2) TEMP1 = -TEMP1 TEMP2 = -DUG * D IF (KK .GT. 1) TEMP2 = -TEMP2 DUU = DAA + TEMP1 * DUA DUA = DAG + TEMP1 * DUG DAA = DGG + TEMP2 * DUG DUG = TEMP1 DAG = TEMP2 DGG = D 95 CONTINUE C C CALCULATE STEPLENGTHS C ITYPE = 1 IF (MONIT .GT. 0) THEN WRITE(ICOUT, 6010) NITER, NEVAL, U, A, G, ACTI1, F, GNORM CALL DPWRST('XXX','BUG ') ENDIF C DELU = DUU * DU + DUA * DA + DUG * DG DELA = DUA * DU + DAA * DA + DAG * DG DELG = DUG * DU + DAG * DA + DGG * DG RATIO = DMAX1(ABS(DELU) / (STEPU * A), ABS(DELA) / (STEPA * A), * ABS(DELG) / STEPG) IF (RATIO .LT. ONE) GOTO 110 RATIO = ONE / RATIO DELU = DELU * RATIO DELA = DELA * RATIO DELG = DELG * RATIO GOTO 110 C C HESSIAN IS NOT POSITIVE DEFINITE - MAKE A LARGE STEP IN THE C DIRECTION OF STEEPEST ASCENT C 100 ITYPE = 2 IF (MONIT .GT. 0) THEN WRITE(ICOUT, 6010) NITER, NEVAL, U, A, G, ACTI2, F, GNORM CALL DPWRST('XXX','BUG ') ENDIF C D = ABS(VLNEG) TEMP1 = D IF (DU .NE. ZERO) TEMP1 = STEPU * A / ABS(DU) TEMP2 = D IF (DA .NE. ZERO) TEMP2 = STEPA * A / ABS(DA) Z = D IF (DG .NE. ZERO) Z = STEPG / ABS(DG) RATIO = MIN(TEMP1, TEMP2, Z) DELU = RATIO * DU DELA = RATIO * DA DELG = RATIO * DG C C ADJUST PARAMETERS C 110 U = U + DELU A = A + DELA G = G + DELG C C TEST FOR FEASIBILITY C IF (A .GT. F * (XMIN - U) .AND. A .GT. G * (XMAX - U) .AND. G .NE. * ZERO) GOTO 130 DO 120 NSR = 1, MAXSR IF (MONIT .GT. 0) THEN WRITE(ICOUT, 6010) NITER, NEVAL, U, A, G, ACTI4 CALL DPWRST('XXX','BUG ') ENDIF C U = U - DELU A = A - DELA G = G - DELG DELU = SRF * DELU DELA = SRF * DELA DELG = SRF * DELG U = U + DELU A = A + DELA G = G + DELG IF (A .GT. G * (XMIN - U) .AND. A .GT. G * (XMAX - Y) .AND. * G .NE. ZERO) GOTO 140 120 CONTINUE GOTO 80 C C TEST FOR CONVERGENCE C 130 IF (ABS(DELU) .GT. ACCU * A) GOTO 140 IF (ABS(DELA) .GT. ACCA * A) GOTO 140 IF (ABS(DELG) .GT. ACCG) GOTO 140 IF (MONIT .GT. 0) THEN WRITE(ICOUT, 6010) NITER, NEVAL, U, A, G, ACTI9 CALL DPWRST('XXX','BUG ') ENDIF C VCOV(1) = DUU VCOV(2) = DUA VCOV(3) = DAA VCOV(4) = DUG VCOV(5) = DAG VCOV(6) = DGG GOTO 160 C C END OF MAIN LOOP C 140 CONTINUE C C ITERATIONS NOT CONVERGED - SET FAULT FLAG C IFAULT = 2 IF (MONIT .GT. 0) THEN WRITE(ICOUT, 6010) MAXIT, NEVAL, U, A, G, ACTI8 CALL DPWRST('XXX','BUG ') ENDIF C GOTO 160 150 IFAULT = 3 IF (MONIT .GT. 0) THEN WRITE(ICOUT, 6010) NITER, MAXEV, U, A, G, ACTI7 CALL DPWRST('XXX','BUG ') ENDIF C C C ITERATION FINISHED -COPY RESULTS INTO ARRAY PARA C 160 IF (MONIT .GT. 0) THEN WRITE(ICOUT, 6020) CALL DPWRST('XXX','BUG ') ENDIF 6020 FORMAT('0') C PARA(1) = U PARA(2) = A PARA(3) = G RETURN C 170 DO 180 I = 1, 3 180 PARA(I) = ZERO RETURN C END SUBROUTINE MOM(G, D, A, FAULT) C C ALGORITHM AS 99.3 APPL. STATIST. (1976) VOL.25, P.180 C C EVALUATES FIRST SIX MOMENTS OF A JOHNSON C SB DISTRIBUTION, USING GOODWIN METHOD C REAL A(6), B(6), C(6), G, D, ZZ, VV, RTTWO, RRTPI, W, E, R, $ H, T, U, Y, X, V, F, Z, S, P, Q, AA, AB, EXPA, EXPB, $ ZERO, QUART, HALF, P75, ONE, TWO, THREE, ZABS, ZEXP LOGICAL L, FAULT C DATA ZZ, VV, LIMIT /1.0E-5, 1.0E-8, 500/ C C RTTWO IS SQRT(2.0) C RRTPI IS RECIPROCAL OF SQRT(PI) C EXPA IS A VALUE SUCH THAT EXP(EXPA) DOES NOT QUITE C CAUSE OVERFLOW C EXPB IS A VALUE SUCH THAT 1.0 + EXP(-EXPB) MAY BE C TAKEN TO BE 1.0 C DATA RTTWO, RRTPI, EXPA, EXPB $ /1.414213562, 0.5641895835, 80.0, 23.7/ DATA ZERO, QUART, HALF, P75, ONE, TWO, THREE $ /0.0, 0.25, 0.5, 0.75, 1.0, 2.0, 3.0/ C ZABS(X) = ABS(X) ZEXP(X) = EXP(X) C FAULT = .FALSE. DO 10 I = 1, 6 10 C(I) = ZERO W = G / D C C TRIAL VALUE OF H C IF (W .GT. EXPA) GOTO 140 E = ZEXP(W) + ONE R = RTTWO / D H = P75 IF (D .LT. THREE) H = QUART * D K = 1 GOTO 40 C C START OF OUTER LOOP C 20 K = K + 1 IF (K .GT. LIMIT) GOTO 140 DO 30 I = 1, 6 30 C(I) = A(I) C C NO CONVERGENCE YET - TRY SMALLER H C H = HALF * H 40 T = W U = T Y = H * H X = TWO * Y A(1) = ONE / E DO 50 I = 2, 6 50 A(I) = A(I - 1) / E V = Y F = R * H M = 0 C C START OF INNER LOOP C TO EVALUATE INFINITE SERIES C 60 M = M + 1 IF (M .GT. LIMIT) GOTO 140 DO 70 I = 1, 6 70 B(I) = A(I) U = U - F Z = ONE IF (U .GT. -EXPB) Z = ZEXP(U) + Z T = T + F L = T .GT. EXPB IF (.NOT. L) S = ZEXP(T) + ONE P = ZEXP(-V) Q = P DO 90 I = 1, 6 AA = A(I) P = P / Z AB = AA AA = AA + P IF (AA .EQ. AB) GOTO 100 IF (L) GOTO 80 Q = Q / S AB = AA AA = AA + Q L = AA .EQ. AB 80 A(I) = AA 90 CONTINUE 100 Y = Y + X V = V + Y DO 110 I = 1, 6 IF (A(I) .EQ. ZERO) GOTO 140 IF (ZABS((A(I) - B(I)) / A(I)) .GT. VV) GOTO 60 110 CONTINUE C C END OF INNER LOOP C V = RRTPI * H DO 120 I = 1, 6 120 A(I) = V * A(I) DO 130 I = 1, 6 IF (A(I) .EQ. ZERO) GOTO 140 IF (ZABS((A(I) - C(I)) / A(I)) .GT. ZZ) GOTO 20 130 CONTINUE C C END OF OUTER LOOP C RETURN 140 FAULT =.TRUE. RETURN END SUBROUTINE MOMENT(X, Y, N, R, W) C C ALGORITHM AS 258.3 APPL.STATIST. (1990), VOL.39, NO.3 C C For k=0,...,n, computes the integral from x to C infinity of the quantity C C R(k+1) = ( t - y )**k z(t) dt, C where C z(t) = 1/sqrt(2 pi) exp( -t**2 / 2 ) . C INTEGER N DOUBLE PRECISION X, Y, R( * ), W( * ) INTEGER I, K DOUBLE PRECISION ALNORM DOUBLE PRECISION XMY, SQR2PI, FACT(19) EXTERNAL ALNORM DATA SQR2PI / 2.506628274631000502415765D0 / DATA FACT / 2 * 1.D0, 2.D0, 6.D0, 24.D0, 120.D0, 720.D0, 5040.D0, * 40320.D0, 362880.D0, 3628800.D0, 39916800.D0, 479001600.D0, * 6227020800.D0, 87178291200.D0, 1307674368000.D0, * 20922789888000.D0, 355687428096000.D0, 6402373705728000.D0 / C C Compute first term of R. C W(1) = EXP(-X * X / 2.0) / SQR2PI W(2) = ALNORM(-X, .FALSE.) R(1) = W(2) IF (N .GT. 0) THEN DO 10 I = 1, N W(I + 2) = (W(I) - X * W(I + 1)) / I R(I + 1) = W(I + 2) * FACT(I + 1) 10 CONTINUE C C If X=Y, then R is already computed. C IF (X .NE. Y) THEN C C Compute R. C DO 30 K = 0, N R(K + 1) = W(2) / FACT(K + 1) XMY = X - Y DO 20 I = 1, K R(K + 1) = R(K + 1) * XMY + W(I + 2) / FACT(K - I + 1) 20 CONTINUE R(K + 1) = R(K + 1) * FACT(K + 1) 30 CONTINUE END IF END IF RETURN END double precision function mpf(x, t, nlab, y) implicit double precision (a-h, o-z) dimension x(*), t(*) c c -- Calculate the mean estimate wsum = 0.0d0 xhat = 0.0d0 do 10 i=1, nlab wght = 1.0d0/(t(i)+y) wsum = wsum +wght xhat = xhat +x(i)*wght 10 continue xhat = xhat /wsum c c -- Evaluate the function mpf = 0.0d0 do 20 i=1, nlab mpf = mpf + 1.0d0/(t(i) +y) *(x(i) -xhat)**2 20 continue return end double precision function mpfder(x, t, nlab, y, wsum) implicit double precision (a-h, o-z) dimension x(*), t(*) c c -- Calculate the mean estimate wsum = 0.0d0 xhat = 0.0d0 do 10 i=1, nlab wght = 1.0d0/(t(i)+y) wsum = wsum + wght xhat = xhat + x(i)*wght 10 continue xhat = xhat /wsum c c -- Evaluate the function mpfder = 0.0d0 do 20 i=1, nlab mpfder = mpfder + 1.0d0/(t(i) +y)**2 *(x(i) -xhat)**2 20 continue return end subroutine mpinit (dat, n, ieq2, nlab, x, t) c c Initialization for Mandel-Paule estimation c c Routine supplied by Mark Vangel: 10/2000 c c 2/2005: Modification by Alan Heckert. If a lab has a single c observation, the within lab variance is zero and c code below blows up. As an alternative, check for c this case and set the resulting variance to the c maximum variance of all the labs. c implicit double precision (a-h, o-z) real dat dimension dat(*), n(*), x(*), t(*) c c -- Calculate batch means and variances of these means ntot = 0 timax=0.0 do 10 i=1, nlab x(i) = 0.0d0 if (ieq2 .eq. 1) then ntot = ntot +n(1) ni = n(1) n(i) = ni else ntot = ntot +n(i) ni = n(i) end if do 20 j=ntot-ni+1, ntot x(i) = x(i) + dat(j) 20 continue x(i) = x(i)/dble(ni) t(i) = 0.0d0 do 30 j=ntot-ni+1, ntot t (i) = t(i) +(dat(j)-x(i))**2 30 continue if(ni .eq. 1)then t(i) = -1.0 else t(i) = t(i) /dble(((ni-1)*ni)) if(t(i).gt.timax)timax=t(i) endif 10 continue c do 40 i=1, nlab if (t(i) .le. 0.0) t(i)=timax 40 continue c Return end subroutine mpintl(nlab,n,x,t,xm,s2b,w,maxit,dlik,ibuga3,ierror) c c --Mandel-Paule Interlab subroutine c --This subroutine is driver routine for generating maximum c --likelihood estimates c --Code provided by Mark Vangel (10/2000) c --Adapted to Dataplot by Alan Heckert c implicit double precision (a-h, o-z) double precision mplglk, mpwmea, mps2bf dimension n(*), t(*), w(*), x(*) character*4 ibuga3 character*4 ierror dimension q(3), xl(3) C common /mpcom/ t0, t1 C C-------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT REAL CPUMIN, CPUMAX C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT------------------------------------------------ C do 5 i=1,3 q(i)=0.0d0 xl(i)=0.0d0 5 continue tol = 1.d-12 iter = 0 dlik = mplglk (nlab, n, x, t, xm, s2b, w, ibuga3) 10 continue c if(ibuga3.eq.'ON')then WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1001)ITER,S2B,XM,DLIK 1001 FORMAT('ITER,S2B,XM,DLIK=',I8,3G15.7) CALL DPWRST('XXX','BUG ') endif c dlt = 0.0d0 iter = iter +1 mltwgt = 0 do 20 i=1, nlab a = s2b /(x(i) - xm)**2 b = t(i) /(x(i) - xm)**2 ss = dble(n(i)*(n(i)-1))*t(i) if (a .eq. 0.0d0) then w(i) = dble(n(i))/((x(i)-xm)**2 +dble(n(i)-1)*t(i)) q(1) = w(i) nwght = 1 else call mpweig(a, b, dble(n(i)-1), nwght, q, ibuga3, ierror) if(ierror.eq.'YES')return end if if (nwght .gt. 1) mltwgt = 1 if (nwght .eq. 1) then wtmp = q(1) jwgt = 1 else do 15 j=1,3 xl(j) = dble(n(i))*log(q(j)) - $ q(j)*(1.0d0/a +dble(n(i)-1)*t(i)/(1.0d0-q(j))) - $ dble(n(i)-1)*log(1.0d0-q(j)) 15 continue if (xl(2) .gt. xl(1) .and. xl(2) .gt. xl(3)) then wtmp = q(2) jwgt = 2 else if (xl(3) .gt. xl(1) .and. xl(3) .gt. xl(2)) then wtmp = q(3) jwgt = 3 else wtmp = q(1) jwgt = 1 end if end if dtmp = abs(wtmp - w(i)) if (dtmp .gt. dlt) dlt = dtmp w(i) = wtmp if(ibuga3.eq.'ON')then WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1011)XM,S2B,I,NWGHT,JWGT 1011 FORMAT('XM,S2B,I,NWGHT,JWGT=',2G15.7,3I8) CALL DPWRST('XXX','BUG ') endif 20 continue c dlik = mplglk (nlab, n, x, t, xm, s2b, w, ibuga3) IF(IBUGA3.EQ.'ON')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1021)iter,t0 +(t1-t0)*xm,(t1-t0)**2*s2b, dlik 1021 FORMAT('ITER,T0+(T1-T0)*XM,(T1-T0**2*S2B,DLIK=',I8,3G16.8) CALL DPWRST('XXX','BUG ') ENDIF s2b = mps2bf(x, w, xm, nlab) xm = mpwmea(x, w, nlab, ibuga3) if (dlt .gt. tol .and. iter .lt. maxit) go to 10 if (iter .gt. maxit) then WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1041) 1041 FORMAT('***** ERROR FROM MPINTL:: CONVERGENCE FAILED.') CALL DPWRST('XXX','BUG ') ENDIF return end double precision function mplglk $ (nlab, n, x, t, xm, s2b, w, ibuga3) c c --log-likelihood function used by CONSESUS MEANS code c --provided by Mark Vangel (10/2000) c implicit double precision (a-h, o-z) character*4 ibuga3 dimension n(*), x(*), t(*), w(*) C C-------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT REAL CPUMIN, CPUMAX C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT------------------------------------------------ C mplglk = 0.0d0 if (s2b .gt. 0.0d0) then do 10 i=1, nlab prtlik = dble(n(i))*log(w(i)/s2b) - $ (w(i)/s2b)*((x(i)-xm)**2 + $ dble(n(i)-1)*t(i)/(1.0d0-w(i))) - $ dble(n(i)-1)*log(1.0d0 - w(i)) mplglk = mplglk + prtlik IF(IBUGA3.EQ.'ON')THEN WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,101)PRTLIK 101 FORMAT('***** FROM MPLGLK (s2b > 0): PRTLIK = ',G15.7) CALL DPWRST('XXX','BUG ') ENDIF 10 continue else do 20 i=1, nlab prtlik = -w(i) *((x(i)-xm)**2 + dble(n(i)-1)*t(i)) + $ dble(n(i))*log(w(i)) mplglk = mplglk + prtlik IF(IBUGA3.EQ.'ON')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,103)PRTLIK 103 FORMAT('***** FROM MPLGLK (s2b <= 0): PRTLIK = ',G15.7) ENDIF 20 continue end if c return end subroutine mppoly(x, fx) c c --Compute cubic polynomial function for root finder in c --Consensus Means code. c --Code provided by Mark Vangel c implicit double precision (a-h, o-z) double precision c(0:3) common /mpfnc/ c c fx = c(0)+x*(c(1)+x*(c(2)+x*c(3))) c return end subroutine mpprep (nlab, x, t, t0, t1) c c Mark Vangel, NIST, Nov 1995 c c Added to Dataplot: 10/2000 c c Scale the sufficient statistics so that the c means are in [0,1]. c implicit double precision (a-h, o-z) dimension x(*), t(*) c t0 = x(1) t1 = x(1) do 10 j=1, nlab if (x(j) .lt. t0) t0 = x(j) if (x(j) .gt. t1) t1 = x(j) 10 continue do 20 j=1, nlab x(j) = (x(j)-t0)/(t1-t0) t(j) = t(j)/(t1-t0)**2 20 continue return end double precision function mprhs (x, t, that, n, nlab) implicit double precision (a-h, o-z) dimension x(*), t(*), that(*), n(*) mprhs = 0.0d0 do 10 i=1, nlab mprhs = mprhs + dble(n(i)-1) * (1.0d0 - t(i)/that(i)) + 1.0d0 10 continue return end subroutine mproot $ (x, t, nlab, tol, rhs, root, maxit, niter, ier) implicit double precision (a-h, o-z) double precision mpf, mpfder dimension x(*), t(*) C C-------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT REAL CPUMIN, CPUMAX C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT------------------------------------------------ C c c -- If root is negative or nonexistent, set it to c zero. c y = 0.0d0 f0 = mpf(x, t, nlab, y) if (f0 .lt. rhs) then root = 0.0d0 ier = 1 return end if c c -- Loop until convergence niter = 0 30 continue niter = niter +1 fd = mpfder(x, t, nlab, y, wsum) ynew = y +(mpf(x, t, nlab, y)-rhs)/fd if (abs (ynew-y) .le. tol .and. $ niter .le. maxit) then root = ynew ier = 0 return else if (niter .gt. maxit) then root = ynew WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1001) 1001 FORMAT('***** ERROR: FAILURE IN MPROOT: YNEW = ',G15.7) CALL DPWRST('XXX','BUG ') DO1010I=1,NLAB WRITE(ICOUT,1011) 1011 FORMAT(' I,T(I) = ',I8,G15.7) 1010 CONTINUE ier = 2 return else y = ynew go to 30 end if return end double precision function mps2bf (x, w, xbar, nlab) c c --Code for consensus mean c --Provided by Mark Vangel c implicit double precision (a-h, o-z) dimension x(*), w(*) mps2bf = 0.0d0 wsum = 0.0d0 do 10 i=1, nlab mps2bf = mps2bf + w(i)**2 *(x(i) -xbar)**2 wsum = wsum + w(i) 10 continue if (wsum .ne. 0.0d0) then mps2bf = mps2bf /wsum else mps2bf = 0.0d0 end if return end subroutine mpsub (nlab, n, x, t, xmp, s2bmp, imanpa, ibuga3) c c Initialization for Mandel-Paule estimation c c Routine supplied by Mark Vangel: 10/2000 c implicit double precision (a-h, o-z) ccccc double precision mprhs double precision mpxbar dimension x(*), n(*), t(*) character*4 imanpa character*4 ibuga3 C C-------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT REAL CPUMIN, CPUMAX C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT------------------------------------------------ C maxit = 1000 tol = 1.d-7 c c -- Initialize with Mandel-Paule s2b = 0.d0 CCCCC USE NLAB FOR MANDEL-PAULE, NLAB-1 FOR MODIFIED MANDEL-PAULE if(imanpa.eq.'MODI')then xrhs=dble(nlab) else xrhs=dble(nlab-1) endif CCCCC xrhs = mprhs (x, t, t, n, nlab) call mproot $ (x, t, nlab, tol, xrhs, s2b, maxit, niter, ier) xmp = mpxbar (x, t, s2b, nlab) s2bmp = s2b WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') IF(IBUGA3.NE.'ON')GOTO1099 WRITE(ICOUT,1001) 1001 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1011) 1011 FORMAT('FROM ROUTINE MPSUB') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1021)XRHS,XMP,S2BMP 1021 FORMAT('RHS, XMP, S2BMP = ',3G15.7) CALL DPWRST('XXX','BUG ') 1099 CONTINUE return end double precision function mpwmea (x, w, nlab, ibuga3) c c --Compute a weighted mean for the consensus means code c --provided by Mark Vangel. c implicit double precision (a-h, o-z) dimension w(*), x(*) character*4 ibuga3 C C-------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT REAL CPUMIN, CPUMAX C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT------------------------------------------------ C dtemp = 0.0d0 wsum = 0.0d0 do 10 i=1, nlab dtemp = dtemp + x(i)*w(i) wsum = wsum + w(i) 10 continue IF(IBUGA3.EQ.'ON')THEN WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') DO1010I=1,NLAB WRITE(ICOUT,1001)I,X(I),W(I) 1001 FORMAT('***** MPWMEA: I,X(I),W(I)=',I8,2G15.7) CALL DPWRST('XXX','BUG ') 1010 CONTINUE ENDIF mpwmea = dtemp/wsum return end subroutine mpweig (a, b, gnu, nwght, w, ibuga3, ierror) implicit double precision (a-h, o-z) c c Concensus Means Code c Mark Vangel, NIST, Oct. 1995 c c Find weight by solving cubic equation. c character*4 ibuga3 character*4 ierror real dwarf, precis double precision w(*) double precision c(0:3) common /mpfnc/ c external mppoly C C-------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT REAL CPUMIN, CPUMAX C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT------------------------------------------------ C c IERROR='NO' c(3) = 1.0d0 c(2) = 1.0d0 - a c(1) = gnu *(a+b) c(0) = gnu *b precis = 1.e-14 dwarf = 1.e-14 x0 = -1.0d0 x1 = 0.0d0 ndeg = 11 zero=0.0d0 c call mpzero(mppoly, x0, x1, ndeg, precis, dwarf, zero, ier) nwght = 1 w(1) = zero + 1.0d0 disc = (1.0d0-a+zero)**2 +4.0d0*b*gnu/zero if (disc .gt. 0.0d0) then z1 = zero disc = sqrt(disc) z2 = (-(1.0d0-a+zero) +disc)/2.0d0 z3 = (-(1.0d0-a+zero) -disc)/2.0d0 if ((-1.0d0 .le. z2 .and. z2 .le. 0.0d0) .or. $ ((-1.0d0 .le. z3 .and. z3 .le. 0.0d0))) then nwght = 3 w(2) = z2 +1.0d0 w(3) = z3 +1.0d0 end if end if IF(IBUGA3.EQ.'ON')THEN WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1001)W(1),W(2),W(3) 1001 FORMAT('FROM MPWEIG: W = ',3G15.7) CALL DPWRST('XXX','BUG ') ENDIF if (ier .ne. 0) then WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1011)IER 1011 FORMAT('FROM MPWEIG: IER = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1021)A,B,GNU 1021 FORMAT('FROM MPWEIG: A,B,GNU = ',3G15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1026)W(1),W(2),W(3) 1026 FORMAT('FROM MPWEIG: W = ',3G15.7) CALL DPWRST('XXX','BUG ') IERROR='YES' end if if (nwght .eq. 3) then CCCCC write(ICOUT,1031) W(1),W(2),W(3) C1031 FORMAT('FROM MPWEIG (NWGHT=3): W = ',3G15.7) CCCCC CALL DPWRST('XXX','BUG ') endif return end double precision function mpxbar (x, t, s2b, nlab) implicit double precision (a-h, o-z) dimension x(*), t(*) c mpxbar = 0.0d0 wsum = 0.0d0 do 10 i=1, nlab wi = 1.0d0/(s2b+t(i)) wsum = wsum + wi mpxbar = mpxbar + x(i)*wi 10 continue mpxbar = mpxbar /wsum c return end SUBROUTINE MPZERO(EVF,A,B,NDEG,PRECIS,DWARF,ZERO,IER) C----------------------------------------------------------------------- C C PURPOSE - FIND A ZERO OF A FUNCTION WHICH CHANGES C SIGN IN A GIVEN INTERVAL BY LARKIN'S C METHOD OF RATIONAL INTERPOLATION. C C PRECISION - DOUBLE. C C ARGUMENTS EVF - AN EXTERNAL SUBROUTINE EVF(X,FX) WITH C DOUBLE PRECISION ARBUMENTS X,FX WHICH C COMPUTES F(X) FOR ANY X IN THE INTERVAL C (A,B) INCLUSIVE. (INPUT) C EVF MUST APPEAR IN AN EXTERNAL STATEMENT C IN THE CALLING PROGRAM. C A,B - DOUBLE PRECISION BOUNDARY POINTS. C (INPUT/OUTPUT) C ON INPUT, F(A) AND F(B) SHOULD HAVE OPPOSITE C SIGNS UNLESS ONE EQUALS 0. C ON OUTPUT, BOTH A AND B ARE ALTERED BUT F(A) C AND F(B) REMAIN OPPOSITELY SIGNED UNLESS C ONE EQUALS 0. IF NEITHER F(A) NOR F(B) C EQUALS 0, THEN C ABS(A-B) .LE. 4*PRECIS*ABS(A)+2*DWARF. C NDEG - MAXIMUM TOTAL DEGREE OF RATIONAL INTER- C POLATION. (INPUT) C IF NDEG.LT.2 THEN 2 IS USED IN PLACE OF C NDEG. IF NDEG.GT.11 THEN 11 IS USED IN C PLACE OF NDEG. C PRECIS - REAL RELATIVE CONVERGENCE PARAMETER. (INPUT) C PRECIS SHOULD BE AT LEAST MACHINE PRE- C CISION, I.E. 1+PRECIS.GT.1 IN DOUBLE C PRECISION ARITHMETIC. C DWARF - REAL ABSOLUTE CONVERGENCE PARAMETER. (INPUT) C DWARF SHOULD BE AT LEAST AS LARGE AS THE C SMALLEST POSITIVE NORMALIZED REAL NUMBER C REPRESENTABLE IN THE COMPUTER. C ZERO - DOUBLE PRECISION APPROXIMATE ZERO OF F(X). C (OUTPUT) C ZERO EQUALS WHICHEVER OF OUTPUT A OR B HAS C SMALLER F MAGNITUDE. C IER - ERROR INDICATOR. (OUTPUT) C NO ERROR: IER=0 . C TERMINAL ERROR: C IER=129 INDICATES THAT F HAS THE SAME C SIGN ON INPUT A AND B. C C----------------------------------------------------------------------- C C SPECIFICATIONS FOR ARGUMENTS. C INTEGER NDEG,IER REAL PRECIS,DWARF DOUBLE PRECISION A,B,ZERO C C SPECIFICATIONS FOR LOCAL VARIABLES. C INTEGER MAXDEG,NN,N,NLAST,I,J REAL TOL,C,D,E,D0,D1 DOUBLE PRECISION X(11),U(11),X0,F0,F1,F2,Z,FZ,H,HLAST,R,S,T DATA MAXDEG/11/ C C REMARK: IN THIS SUBROUTINE THE MAXIMUM ALLOWABLE DEGREE OF C RATIONAL INTERPOLATION HAS BEEN ARBITRARILY SET AT 11. C (SEE DESCRIPTION OF NDEG.) TO INCREASE THE MAXIMUM C ALLOWABLE DEGREE TO M: C 1. DIMENSION X AND U AT M (RATHER THAN 11), C 2. INITIALIZE MAXDEG AT M (RATHER THAN 11), C IN THE ABOVE LINES OF CODE. C C FIRST EXECUTABLE STATEMENT. C X0 = A X(1) = B CALL EVF(A,F0) CALL EVF(B,F1) IF (F0.EQ.0. .OR. F1.EQ.0.) GO TO 120 IF (F0.GT.0. .AND. F1.GT.0.) GO TO 140 IF (F0.LT.0. .AND. F1.LT.0.) GO TO 140 NN = NDEG IF (NN.LT.2) NN = 2 IF (NN.GT.MAXDEG) NN = MAXDEG R = X(1) - X0 E = 0. F2 = F0 C C MAIN LOOP. C 10 CONTINUE TOL = 2.*PRECIS*DABS(X0) + DWARF IF (DABS(R).LE.2.*TOL) GO TO 120 U(1) = R* (F0/ (F0-F1)) IF (E.LT.TOL .OR. DABS(F0).GE.DABS(F2)) GO TO 60 C C INTERPOLATE. C H = U(1) HLAST = H NLAST = 1 S = R DO 30 I = 2,N S = S + U(I) - U(I-1) T = X(I) - X0 - S IF (T.EQ.0.) GO TO 40 U(I) = H* (S/T) H = H + U(I) D1 = DABS(U(I)) IF (I.EQ.2) GO TO 20 IF (D1.GE.D0) GO TO 40 T = H/R IF (T.LE.0. .OR. T.GE.1.) GO TO 40 20 HLAST = H NLAST = I D0 = D1 30 CONTINUE 40 Z = X0 + HLAST D0 = DABS(HLAST) D1 = DABS(Z-X(1)) C = E E = D D = AMIN1(D0,D1) IF (D.GE..5*C) GO TO 60 IF (D.GE.TOL) GO TO 70 IF (D0.LT.TOL) GO TO 50 IF (R.LT.0.) TOL = -TOL Z = X(1) - TOL GO TO 70 50 IF (R.LT.0.) TOL = -TOL Z = X0 + TOL GO TO 70 C C END INTERPOLATE. C 60 CONTINUE C C BISECT. C H = .5*R Z = X0 + H NLAST = 1 D = DABS(H) E = D C C END BISECT. C 70 CONTINUE C C EVALUATE AND ORGANIZE. C CALL EVF(Z,FZ) IF (FZ.NE.0.) GO TO 80 X0 = Z F0 = FZ GO TO 120 80 N = MIN0(NLAST+1,NN) J = N + 1 DO 90 I = 2,N J = J - 1 X(J) = X(J-1) U(J) = U(J-1) 90 CONTINUE IF (FZ.GT.0. .AND. F1.GT.0.) GO TO 100 IF (FZ.LT.0. .AND. F1.LT.0.) GO TO 100 X(2) = X0 F2 = F0 U(2) = U(2) - R GO TO 110 100 X(1) = X0 F2 = F1 F1 = F0 110 CONTINUE X0 = Z F0 = FZ R = X(1) - X0 C C END EVALUATE AND ORGANIZE. C GO TO 10 C C END MAIN LOOP. C 120 CONTINUE C C RETURN WITHOUT ERROR. C IER = 0 A = X0 B = X(1) IF (DABS(F1).LT.DABS(F0)) GO TO 130 ZERO = A RETURN 130 ZERO = B RETURN 140 CONTINUE C C RETURN WITH ERROR. C IER = 129 RETURN END INTEGER FUNCTION MSTA1(X,MP) C C =================================================== C Purpose: Determine the starting point for backward C recurrence such that the magnitude of C Jn(x) at that point is about 10^(-MP) C Input : x --- Argument of Jn(x) C MP --- Value of magnitude C Output: MSTA1 --- Starting point C =================================================== C IMPLICIT DOUBLE PRECISION (A-H,O-Z) A0=DABS(X) N0=INT(1.1*A0)+1 F0=ENVJ(N0,A0)-MP N1=N0+5 F1=ENVJ(N1,A0)-MP DO 10 IT=1,20 NN=N1-(N1-N0)/(1.0D0-F0/F1) F=ENVJ(NN,A0)-MP IF(ABS(NN-N1).LT.1) GO TO 20 N0=N1 F0=F1 N1=NN 10 F1=F 20 MSTA1=NN RETURN END INTEGER FUNCTION MSTA2(X,N,MP) C C =================================================== C Purpose: Determine the starting point for backward C recurrence such that all Jn(x) has MP C significant digits C Input : x --- Argument of Jn(x) C n --- Order of Jn(x) C MP --- Significant digit C Output: MSTA2 --- Starting point C =================================================== C IMPLICIT DOUBLE PRECISION (A-H,O-Z) A0=DABS(X) HMP=0.5D0*MP EJN=ENVJ(N,A0) IF (EJN.LE.HMP) THEN OBJ=MP N0=INT(1.1*A0) ELSE OBJ=HMP+EJN N0=N ENDIF F0=ENVJ(N0,A0)-OBJ N1=N0+5 F1=ENVJ(N1,A0)-OBJ DO 10 IT=1,20 NN=N1-(N1-N0)/(1.0D0-F0/F1) F=ENVJ(NN,A0)-OBJ IF (ABS(NN-N1).LT.1) GO TO 20 N0=N1 F0=F1 N1=NN 10 F1=F 20 MSTA2=NN+10 RETURN END SUBROUTINE MULRAN(n,p,ncat,ix,iseed,ierror) C********************************************************************** C C SUBROUTINE GENMUL( N, P, NCAT, IX ) C GENerate an observation from the MULtinomial distribution C C C Arguments C C C N --> Number of events that will be classified into one of C the categories 1..NCAT C INTEGER N C C P --> Vector of probabilities. P(i) is the probability that C an event will be classified into category i. Thus, P(i) C must be [0,1]. Only the first NCAT-1 P(i) must be defined C since P(NCAT) is 1.0 minus the sum of the first C NCAT-1 P(i). C REAL P(NCAT-1) C C NCAT --> Number of categories. Length of P and IX. C INTEGER NCAT C C IX <-- Observation from multinomial distribution. All IX(i) C will be nonnegative and their sum will be N. C INTEGER IX(NCAT) C C C Method C C C Algorithm from page 559 of C C Devroye, Luc C C Non-Uniform Random Variate Generation. Springer-Verlag, C New York, 1986. C C DATAPLOT NOTE: CODE FROM RANLIB LIBRARY OF BROWN AND LAVATO. C Department of Biomathematics, Box 237 C The University of Texas, M.D. Anderson Cancer Center C 1515 Holcombe Boulevard C Houston, TX 77030 C C FOLLOWING CHANGES: C 1) RENAMED FROM GENMUL TO MULRAN C 2) REPLACE THEIR IGBNM ROUTINE WITH DATAPLOT BINRAN C 3) I/O CHANGED AND ERROR FLAG ADDED. C C********************************************************************** C .. Scalar Arguments .. INTEGER n,ncat C .. C .. Array Arguments .. REAL p(*) INTEGER ix(*) C .. C .. Local Scalars .. REAL prob,ptot,sum INTEGER i,icat,ntot C .. C .. External Functions .. CCCCC INTEGER ignbin CCCCC EXTERNAL ignbin C .. C .. Intrinsic Functions .. INTRINSIC abs C .. C .. Executable Statements .. C C--------------------------------------------------------------------- C REAL XTEMP(1) C CHARACTER*4 IERROR C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C C Check Arguments C IF (n.LT.0) THEN WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1001)N 1001 FORMAT('***** ERROR IN MULRAN: N IS NOT POSITIVE, VALUE = ',I8) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9999 ENDIF IF (ncat.LE.1) THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1003)NCAT 1003 FORMAT('***** ERROR IN MULRAN: NUMBER OF CATEGORIES IS <= 1, ', 1 'VALUE = ',I8) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9999 ENDIF ptot = 0.0 DO 10,i = 1,ncat - 1 IF (p(i).LT.0.0 .or. p(i).gt.1.0) THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1011)i,p(i) 1011 FORMAT('***** ERROR IN MULRAN: FOR CATEGORY ',I8,' P(I) IS ', 1 'NOT IN THE INTERVAL (0,1). THE VALUE = ',G15.7) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9999 ENDIF ptot = ptot + p(i) 10 CONTINUE IF (ptot.GT.0.999999) THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1021) 1021 FORMAT('***** ERROR IN MULRAN: SUM OF PROBABILITIES IS ', 1 'GREATER THAN 1.') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9999 ENDIF C C Initialize variables C ntot = n sum = 1.0 DO 20,i = 1,ncat ix(i) = 0 20 CONTINUE C Generate the observation NPAR=1 DO 30,icat = 1,ncat - 1 prob = p(icat)/sum CCCCC ix(icat) = ignbin(ntot,prob) CALL BINRAN(NPAR,PROB,NTOT,ISEED,XTEMP) IX(ICAT) = INT(XTEMP(1)+0.1) ntot = ntot - ix(icat) IF (ntot.LE.0) goto9999 sum = sum - p(icat) 30 CONTINUE ix(ncat) = ntot C C Finished C 9999 CONTINUE RETURN END SUBROUTINE MVMLTL(NR,N,A,X,Y) IMPLICIT DOUBLE PRECISION (A-H,O-Z) C C PURPOSE C ------- C COMPUTE Y=LX C WHERE L IS A LOWER TRIANGULAR MATRIX STORED IN A C C PARAMETERS C ---------- C NR --> ROW DIMENSION OF MATRIX C N --> DIMENSION OF PROBLEM C A(N,N) --> LOWER TRIANGULAR (N*N) MATRIX C X(N) --> OPERAND VECTOR C Y(N) <-- RESULT VECTOR C C NOTE C ---- C X AND Y CANNOT SHARE STORAGE C DIMENSION A(NR,1),X(N),Y(N) DO 30 I=1,N SUM=0. DO 10 J=1,I SUM=SUM+A(I,J)*X(J) 10 CONTINUE Y(I)=SUM 30 CONTINUE RETURN END SUBROUTINE MVMLTS(NR,N,A,X,Y) IMPLICIT DOUBLE PRECISION (A-H,O-Z) C C PURPOSE C ------- C COMPUTE Y=AX C WHERE "A" IS A SYMMETRIC (N*N) MATRIX STORED IN ITS LOWER C TRIANGULAR PART AND X,Y ARE N-VECTORS C C PARAMETERS C ---------- C NR --> ROW DIMENSION OF MATRIX C N --> DIMENSION OF PROBLEM C A(N,N) --> SYMMETRIC (N*N) MATRIX STORED IN C LOWER TRIANGULAR PART AND DIAGONAL C X(N) --> OPERAND VECTOR C Y(N) <-- RESULT VECTOR C C NOTE C ---- C X AND Y CANNOT SHARE STORAGE. C DIMENSION A(NR,1),X(N),Y(N) DO 30 I=1,N SUM=0. DO 10 J=1,I SUM=SUM+A(I,J)*X(J) 10 CONTINUE IF(I.EQ.N) GO TO 25 IP1=I+1 DO 20 J=IP1,N SUM=SUM+A(J,I)*X(J) 20 CONTINUE 25 Y(I)=SUM 30 CONTINUE RETURN END SUBROUTINE MVMLTU(NR,N,A,X,Y) IMPLICIT DOUBLE PRECISION (A-H,O-Z) C C PURPOSE C ------- C COMPUTE Y=(L+)X C WHERE L IS A LOWER TRIANGULAR MATRIX STORED IN A C (L-TRANSPOSE (L+) IS TAKEN IMPLICITLY) C C PARAMETERS C ---------- C NR --> ROW DIMENSION OF MATRIX C N --> DIMENSION OF PROBLEM C A(NR,1) --> LOWER TRIANGULAR (N*N) MATRIX C X(N) --> OPERAND VECTOR C Y(N) <-- RESULT VECTOR C C NOTE C ---- C X AND Y CANNOT SHARE STORAGE C DIMENSION A(NR,1),X(N),Y(N) DO 30 I=1,N SUM=0. DO 10 J=I,N SUM=SUM+A(J,I)*X(J) 10 CONTINUE Y(I)=SUM 30 CONTINUE RETURN END DOUBLE PRECISION FUNCTION MVNFNC(N, W) * * Integrand subroutine * INTEGER N, INFIN(*), INFIS DOUBLE PRECISION W(*), LOWER(*), UPPER(*), CORREL(*), ONE INTEGER NL, IJ, I, J PARAMETER ( NL = 100, ONE = 1.0D0 ) DOUBLE PRECISION COV((NL*(NL+1))/2), A(NL), B(NL), Y(NL), BVN INTEGER INFI(NL) DOUBLE PRECISION PROD, D1, E1, DI, EI, SUM, PHINV, D, E, MVNNIT SAVE D1, E1, A, B, INFI, COV DI = D1 EI = E1 PROD = E1 - D1 IJ = 1 DO 100 I = 1,N Y(I) = PHINV( DI + W(I)*(EI-DI) ) SUM = 0.0D0 DO 200 J = 1,I IJ = IJ + 1 SUM = SUM + COV(IJ)*Y(J) 200 CONTINUE IJ = IJ + 1 IF ( COV(IJ) .GT. 0.0D0 ) THEN CALL LIMITS( A(I+1)-SUM, B(I+1)-SUM, INFI(I+1), DI, EI ) ELSE DI = ( 1.0D0 + SIGN( ONE, A(I+1)-SUM ) )/2.0D0 EI = ( 1.0D0 + SIGN( ONE, B(I+1)-SUM ) )/2.0D0 ENDIF PROD = PROD*(EI-DI) 100 CONTINUE MVNFNC = PROD RETURN * * Entry point for intialization. * ENTRY MVNNIT(N, CORREL, LOWER, UPPER, INFIN, INFIS, D, E) MVNNIT = 0 * * Initialization and computation of covariance Cholesky factor. * CALL NCVSRT(N, LOWER,UPPER,CORREL,INFIN,Y, INFIS,A,B,INFI,COV,D,E) D1 = D E1 = E IF ( N - INFIS .EQ. 2 ) THEN D = SQRT( 1.0D0 + COV(2)**2 ) A(2) = A(2)/D B(2) = B(2)/D E = BVN( A, B, INFI, COV(2)/D ) D = 0.0D0 INFIS = INFIS + 1 END IF C RETURN END SUBROUTINE MVTLMS( NU, A, B, INFIN, LOWER, UPPER ) DOUBLE PRECISION A, B, LOWER, UPPER, STUDNT INTEGER NU, INFIN LOWER = 0.0D0 UPPER = 1.0D0 IF ( INFIN .GE. 0 ) THEN IF ( INFIN .NE. 0 ) LOWER = STUDNT( NU, A ) IF ( INFIN .NE. 1 ) UPPER = STUDNT( NU, B ) ENDIF C RETURN END SUBROUTINE MVTSRT( N, NU, LOWER, UPPER, CORREL, INFIN, Y, INFIS, & A, B, INFI, COV, D, E ) * * Sort limits * INTEGER N, NU, INFI(*), INFIN(*), INFIS DOUBLE PRECISION & A(*), B(*), COV(*), LOWER(*), UPPER(*), CORREL(*), Y(*), D, E INTEGER I, J, K, IJ, II, JMIN DOUBLE PRECISION SUMSQ, ZERO, TWO, PI, CVDIAG DOUBLE PRECISION AI, BI, SUM, YL, YU, YD DOUBLE PRECISION AMIN, BMIN, DMIN, EMIN, CON, CONODD, CONEVN PARAMETER ( ZERO = 0, TWO = 2, PI = 3.14159 26535 89793 23844 ) IJ = 0 II = 0 INFIS = 0 DO 100 I = 1, N INFI(I) = INFIN(I) IF ( INFI(I) .LT. 0 ) THEN INFIS = INFIS + 1 ELSE A(I) = 0.0D0 B(I) = 0.0D0 IF ( INFI(I) .NE. 0 ) A(I) = LOWER(I) IF ( INFI(I) .NE. 1 ) B(I) = UPPER(I) ENDIF DO 200 J = 1,I-1 IJ = IJ + 1 II = II + 1 COV(IJ) = CORREL(II) 200 CONTINUE IJ = IJ + 1 COV(IJ) = 1 100 CONTINUE CONODD = 1.0D0/PI CONEVN = 1.0D0/TWO DO 300 I = 1, NU - 1 IF ( MOD(I,2) .EQ. 0 ) THEN IF ( I .GT. 2 ) CONEVN = CONEVN*DBLE(I-1)/DBLE(I-2) ELSE IF ( I .GT. 2 ) CONODD = CONODD*DBLE(I-1)/DBLE(I-2) ENDIF 300 CONTINUE * * First move any doubly infinite limits to innermost positions * IF ( INFIS .LT. N ) THEN DO 400 I = N, N-INFIS+1, -1 IF ( INFI(I) .GE. 0 ) THEN DO 500 J = 1, I-1 IF ( INFI(J) .LT. 0 ) THEN CALL RCSWAP( J, I, A, B, INFI, N, COV ) GOTO 400 ENDIF 500 CONTINUE ENDIF 400 CONTINUE * * Sort remaining limits and determine Cholesky decomposition * II = 0 YD = 1.0D0 DO 900 I = 1, N-INFIS * * Determine the integration limits for variable with minimum * expected probability and interchange that variable with Ith. * EMIN = 1 DMIN = 0 JMIN = I CVDIAG = 0 IJ = II DO 600 J = I, N-INFIS SUM = 0 SUMSQ = 0 DO 650 K = 1, I-1 SUM = SUM + COV(IJ+K)*Y(K) SUMSQ = SUMSQ + COV(IJ+K)**2 650 CONTINUE IJ = IJ + J SUMSQ = SQRT( MAX( COV(IJ)-SUMSQ, ZERO ) ) IF ( SUMSQ .GT. 0 ) THEN AI = YD*( A(J) - SUM )/SUMSQ BI = YD*( B(J) - SUM )/SUMSQ CALL MVTLMS( NU+J-1, AI, BI, INFI(J), D, E ) IF ( EMIN - DMIN .GE. E - D ) THEN JMIN = J AMIN = AI BMIN = BI DMIN = D EMIN = E CVDIAG = SUMSQ ENDIF ENDIF 600 CONTINUE IF ( JMIN .NE. I ) CALL RCSWAP( I, JMIN, A,B, INFI, N,COV ) * * Compute Ith column of Cholesky factor. * IJ = II + I COV(IJ) = CVDIAG DO 700 J = I+1, N-INFIS IF ( CVDIAG .GT. 0.0D0 ) THEN SUM = COV(IJ+I) DO 750 K = 1, I-1 SUM = SUM - COV(II+K)*COV(IJ+K) 750 CONTINUE COV(IJ+I) = SUM/CVDIAG ELSE COV(IJ+I) = 0.0D0 ENDIF IJ = IJ + J 700 CONTINUE * * Compute expected value for Ith integration variable and * scale Ith covariance matrix row and limits. * IF ( MOD(NU+I-1,2) .EQ. 0 ) THEN IF ( NU+I-3 .GT. 0 ) CONEVN = & CONEVN*DBLE(NU+I-2)/DBLE(NU+I-3) CON = CONEVN ELSE IF ( NU+I-3 .GT. 0 ) CONODD = & CONODD*DBLE(NU+I-2)/DBLE(NU+I-3) CON = CONODD ENDIF IF ( CVDIAG .GT. 0.0D0 ) THEN YL = 0.0D0 YU = 0.0D0 IF ( INFI(I) .NE. 0 .AND. NU+I-2 .GT. 0 ) & YL = -CON*DBLE(NU+I-1)/DBLE(NU+I-2) & /( 1.0D0 + AMIN**2/DBLE(NU+I-1) )**((NU+I-2)/TWO) IF ( INFI(I) .NE. 1 .AND. NU+I-2 .GT. 0 ) & YU = -CON*DBLE(NU+I-1)/DBLE(NU+I-2) & /( 1.0D0 + BMIN**2/(NU+I-1) )**( (NU+I-2)/TWO ) Y(I) = ( YU - YL )/( EMIN - DMIN )/YD DO 800 J = 1,I II = II + 1 COV(II) = COV(II)/CVDIAG 800 CONTINUE IF ( INFI(I) .NE. 0 ) A(I) = A(I)/CVDIAG IF ( INFI(I) .NE. 1 ) B(I) = B(I)/CVDIAG ELSE Y(I) = 0.0D0 II = II + I ENDIF YD = YD/SQRT( 1 + ( Y(I)*YD + 1 )*( Y(I)*YD - 1 )/(NU+I) ) 900 CONTINUE CALL MVTLMS( NU, A(1), B(1), INFI(1), D, E) ENDIF C RETURN END SUBROUTINE NBCDF(X,P,AN,CDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION C FUNCTION VALUE AT THE SINGLE PRECISION VALUE X C FOR THE NEGATIVE BINOMIAL DISTRIBUTION C WITH SINGLE PRECISION 'BERNOULLI PROBABILITY' C PARAMETER = P, C AND INTEGER 'NUMBER OF SUCCESSES IN BERNOULLI TRIALS' C PARAMETER = N. C THE NEGATIVE BINOMIAL DISTRIBUTION USED C HEREIN HAS MEAN = N*(1-P)/P C AND STANDARD DEVIATION = SQRT(N*(1-P)/(P*P))). C THIS DISTRIBUTION IS DEFINED FOR C ALL NON-NEGATIVE INTEGER X--X = 0, 1, 2, ... . C THIS DISTRIBUTION HAS THE PROBABILITY FUNCTION C F(X) = C(N+X-1,N) * P**N * (1-P)**X. C WHERE C(N+X-1,N) IS THE COMBINATORIAL FUNCTION C EQUALING THE NUMBER OF COMBINATIONS OF N+X-1 ITEMS C TAKEN N AT A TIME. C THE NEGATIVE BINOMIAL DISTRIBUTION IS THE C DISTRIBUTION OF THE NUMBER OF FAILURES C BEFORE OBTAINING N SUCCESSES IN AN C INDEFINITE SEQUENCE OF BERNOULLI (0,1) C TRIALS WHERE THE PROBABILITY OF SUCCESS C IN A SINGLE TRIAL = P. C C THE NEGATIVE BINOMIAL CAN BE EXTENDED TO THE C CASE WHERE N IS POSITIVE REAL NUMBER (I.E., NOT C RESTRICTED TO AN INTEGER). IN THAT CASE, THE C PROBABILITY FUNCTION IS: C C F(X) = P**N * (1-P)**X * GAMMA(N+X)/(GAMMA(N)*X!) C C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE C AT WHICH THE CUMULATIVE DISTRIBUTION C FUNCTION IS TO BE EVALUATED. C X SHOULD BE NON-NEGATIVE AND C INTEGRAL-VALUED. C --P = THE SINGLE PRECISION VALUE C OF THE 'BERNOULLI PROBABILITY' C PARAMETER FOR THE NEGATIVE BINOMIAL C DISTRIBUTION. C P SHOULD BE BETWEEN C 0.0 (EXCLUSIVELY) AND C 1.0 (EXCLUSIVELY). C --N = THE REAL VALUE C OF THE 'NUMBER OF SUCCESSES C IN BERNOULLI TRIALS' PARAMETER. C N SHOULD BE A POSITIVE NUMBER. C OUTPUT ARGUMENTS--CDF = THE SINGLE PRECISION CUMULATIVE C DISTRIBUTION FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION C FUNCTION VALUE CDF C FOR THE NEGATIVE BINOMIAL DISTRIBUTION C WITH 'BERNOULLI PROBABILITY' PARAMETER = P C AND 'NUMBER OF SUCCESSES IN BERNOULLI TRIALS' C PARAMETER = N. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--X SHOULD BE NON-NEGATIVE AND INTEGRAL-VALUED. C --P SHOULD BE BETWEEN 0.0 (EXCLUSIVELY) C AND 1.0 (EXCLUSIVELY). C --N SHOULD BE POSITIVE. C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--DSQRT, DATAN, LNGAMM. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C COMMENT--NOTE THAT EVEN THOUGH THE INPUT C TO THIS CUMULATIVE C DISTRIBUTION FUNCTION SUBROUTINE C FOR THIS DISCRETE DISTRIBUTION C SHOULD (UNDER NORMAL CIRCUMSTANCES) BE A C DISCRETE INTEGER VALUE, C THE INPUT VARIABLE X IS SINGLE C PRECISION IN MODE. C X HAS BEEN SPECIFIED AS SINGLE C PRECISION SO AS TO CONFORM WITH THE DATAPAC C CONVENTION THAT ALL INPUT ****DATA**** C (AS OPPOSED TO SAMPLE SIZE, FOR EXAMPLE) C VARIABLES TO ALL C DATAPAC SUBROUTINES ARE SINGLE PRECISION. C THIS CONVENTION IS BASED ON THE BELIEF THAT C 1) A MIXTURE OF MODES (FLOATING POINT C VERSUS INTEGER) IS INCONSISTENT AND C AN UNNECESSARY COMPLICATION C IN A DATA ANALYSIS; AND C 2) FLOATING POINT MACHINE ARITHMETIC C (AS OPPOSED TO INTEGER ARITHMETIC) C IS THE MORE NATURAL MODE FOR DOING C DATA ANALYSIS. C REFERENCES--NATIONAL BUREAU OF STANDARDS APPLIED MATHEMATICS C SERIES 55, 1964, PAGE 945, FORMULAE 26.5.24 AND C 26.5.28, AND PAGE 929. C --JOHNSON, KOTZ, AND KEMP, "DISCRETE UNIVARIATE C DISTRIBUTIONS", SECOND EDITION, 1992. C --EVANS, HASTINGS AND PEACOCK, STATISTICAL C DISTRIBUTIONS--THIRD EDITION, 2001. C --FELLER, AN INTRODUCTION TO PROBABILITY C THEORY AND ITS APPLICATIONS, VOLUME 1, C EDITION 2, 1957, PAGES 155-157, 210. C --KENDALL AND STUART, THE ADVANCED THEORY OF C STATISTICS, VOLUME 1, EDITION 2, 1963, PAGES 130-131. C --WILLIAMSON AND BRETHERTON, TABLES OF C THE NEGATIVE BINOMIAL PROBABILITY C DISTRIBUTION, 1963. C --OWEN, HANDBOOK OF STATISTICAL C TABLES, 1962, PAGE 304. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--82.6 C ORIGINAL VERSION--NOVEMBER 1975. C UPDATED --DECEMBER 1981. C UPDATED --MAY 1982. C UPDATED --MARCH 2004. EXTEND TO NON-INTEGER VALUES C FOR N C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C CHARACTER*4 ICASE C DOUBLE PRECISION DX2 DOUBLE PRECISION PI DOUBLE PRECISION ANU1 DOUBLE PRECISION ANU2 DOUBLE PRECISION Z DOUBLE PRECISION SUM DOUBLE PRECISION TERM DOUBLE PRECISION AI DOUBLE PRECISION COEF1 DOUBLE PRECISION COEF2 DOUBLE PRECISION ARG DOUBLE PRECISION COEF DOUBLE PRECISION THETA DOUBLE PRECISION SINTH DOUBLE PRECISION COSTH DOUBLE PRECISION A DOUBLE PRECISION B DOUBLE PRECISION DSQRT DOUBLE PRECISION DATAN DOUBLE PRECISION DBETAI DOUBLE PRECISION DCDF C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----DATA STATEMENTS------------------------------------------------- C DATA PI/3.14159265358979D0/ DATA EPS/0.000001/ C C-----START POINT----------------------------------------------------- C B=0.0 C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(P.LE.0.0.OR.P.GE.1.0)THEN WRITE(ICOUT,11) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)P CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9000 ENDIF 11 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO THE ', 1'NBCDF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL') C IF(X.LT.0.0)THEN WRITE(ICOUT,4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9000 ENDIF 4 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT ', 1'TO THE NBCDF SUBROUTINE IS NEGATIVE *****') C INTN=AN+EPS FINTN=INTN DELN=ABS(AN-FINTX) ICASE='INTE' IF(DELN.GT.EPS)ICASE='REAL' N=INTN IF(ICASE.EQ.'INTE' .AND. N.LT.1)THEN WRITE(ICOUT,25) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)N CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9000 ELSEIF(ICASE.EQ.'REAL' .AND. AN.LE.0.0)THEN WRITE(ICOUT,27) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)AN CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9000 ENDIF 25 FORMAT('***** ERROR--THE THIRD INPUT ARGUMENT TO THE ', 1'NBCDF SUBROUTINE IS A NON-POSITIVE INTEGER *****') 27 FORMAT('***** ERROR--THE THIRD INPUT ARGUMENT TO THE ', 1'NBCDF SUBROUTINE IS A NON-POSITIVE REAL *****') C INTX=X+0.0001 FINTX=INTX DEL=ABS(X-FINTX) IF(DEL.GT.0.001)THEN WRITE(ICOUT,5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') ENDIF 5 FORMAT('***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT ', 1'TO THE NBCDF SUBROUTINE IS NON-INTEGRAL *****') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****') C C SUPPORT NON-INTEGER VALUES FOR N. IN THIS CASE, THE C CDF FUNCTION = 1 - I(1-P)(X+1,AN) C IF(ICASE.EQ.'REAL')THEN DCDF=1.0D0 - DBETAI(DBLE(1.0-P),DBLE(INTX+1),DBLE(AN)) CDF=REAL(DCDF) GOTO9000 ENDIF C C EXPRESS THE NEGATIVE BINOMIAL CUMULATIVE DISTRIBUTION C FUNCTION IN TERMS OF THE EQUIVALENT BINOMIAL C CUMULATIVE DISTRIBUTION FUNCTION, C AND THEN OPERATE ON THE LATTER. C INTX=X+0.0001 K=N-1 N2=N+INTX C C EXPRESS THE BINOMIAL CUMULATIVE DISTRIBUTION C FUNCTION IN TERMS OF THE EQUIVALENT F C CUMULATIVE DISTRIBUTION FUNCTION, C AND THEN EVALUATE THE LATTER. C AK=K AN2=N2 DX2=(P/(1.0-P))*((AN2-AK)/(AK+1.0)) NU1=2*(K+1) NU2=2*(N2-K) ANU1=NU1 ANU2=NU2 Z=ANU2/(ANU2+ANU1*DX2) C C DETERMINE IF NU1 AND NU2 ARE EVEN OR ODD C IFLAG1=NU1-2*(NU1/2) IFLAG2=NU2-2*(NU2/2) IF(IFLAG1.EQ.0)GOTO120 IF(IFLAG2.EQ.0)GOTO150 GOTO250 C C DO THE NU1 EVEN AND NU2 EVEN OR ODD CASE C 120 SUM=0.0D0 TERM=1.0D0 IMAX=(NU1-2)/2 IF(IMAX.LE.0)GOTO110 DO100I=1,IMAX AI=I COEF1=2.0D0*(AI-1.0D0) COEF2=2.0D0*AI TERM=TERM*((ANU2+COEF1)/COEF2)*(1.0D0-Z) SUM=SUM+TERM 100 CONTINUE C 110 SUM=SUM+1.0D0 SUM=(Z**(ANU2/2.0D0))*SUM CDF=1.0D0-SUM GOTO9000 C C DO THE NU1 ODD AND NU2 EVEN CASE C 150 SUM=0.0D0 TERM=1.0D0 IMAX=(NU2-2)/2 IF(IMAX.LE.0)GOTO210 DO200I=1,IMAX AI=I COEF1=2.0D0*(AI-1.0D0) COEF2=2.0D0*AI TERM=TERM*((ANU1+COEF1)/COEF2)*Z SUM=SUM+TERM 200 CONTINUE C 210 SUM=SUM+1.0D0 CDF=((1.0D0-Z)**(ANU1/2.0D0))*SUM GOTO9000 C C DO THE NU1 ODD AND NU2 ODD CASE C 250 SUM=0.0D0 TERM=1.0D0 ARG=DSQRT((ANU1/ANU2)*DX2) THETA=DATAN(ARG) SINTH=ARG/DSQRT(1.0D0+ARG*ARG) COSTH=1.0D0/DSQRT(1.0D0+ARG*ARG) IF(NU2.EQ.1)GOTO320 IF(NU2.EQ.3)GOTO310 IMAX=NU2-2 DO300I=3,IMAX,2 AI=I COEF1=AI-1.0D0 COEF2=AI TERM=TERM*(COEF1/COEF2)*(COSTH*COSTH) SUM=SUM+TERM 300 CONTINUE C 310 SUM=SUM+1.0D0 SUM=SUM*SINTH*COSTH C 320 A=(2.0D0/PI)*(THETA+SUM) 350 SUM=0.0D0 TERM=1.0D0 IF(NU1.EQ.1)B=0.0D0 IF(NU1.EQ.1)GOTO450 IF(NU1.EQ.3)GOTO410 IMAX=NU1-3 DO400I=1,IMAX,2 AI=I COEF1=AI COEF2=AI+2.0D0 TERM=TERM*((ANU2+COEF1)/COEF2)*(SINTH*SINTH) SUM=SUM+TERM 400 CONTINUE C 410 SUM=SUM+1.0D0 SUM=SUM*SINTH*(COSTH**N) COEF=1.0D0 IEVODD=NU2-2*(NU2/2) IMIN=3 IF(IEVODD.EQ.0)IMIN=2 IF(IMIN.GT.NU2)GOTO420 DO430I=IMIN,NU2,2 AI=I COEF=((AI-1.0D0)/AI)*COEF 430 CONTINUE C 420 COEF=COEF*ANU2 IF(IEVODD.EQ.0)GOTO440 COEF=COEF*(2.0D0/PI) C 440 B=COEF*SUM C 450 CDF=A-B C 9000 CONTINUE RETURN C END INTEGER FUNCTION NBPK(M,J) CCCCC INTEGER FUNCTION NBP_K(M,J) IF (M.LT.J) THEN NBPK=0 ELSE IF (J.EQ.1) NBPK=M IF (J.EQ.2) NBPK=(M*(M-1))/2 IF (J.EQ.3) NBPK=(M*(M-1)*(M-2))/6 ENDIF RETURN END INTEGER FUNCTION NBPNCE(M,J) CCCCC CHANGE TO 6-CHARACTER NAME CCCCC INTEGER FUNCTION NBP_NCEIL(M,J) IF (MOD(M,J).EQ.0) THEN NBPNCE=INT(dble(M)/J) ELSE NBPNCE=NINT(dble(M)/J+0.5) ENDIF RETURN END DOUBLE PRECISION FUNCTION NBFUN(DK,DX) C C PURPOSE--DPMLNB CALLS DFZER2 TO FIND A ROOT FOR THE FOLLOWING C FUNCTION: C C LN(KHAT) - LN(XBAR + KHAT) - PSI(KHAT) + C (1/N)*SUM[i=1 to N][PSI(X(I) + KHAT)] = 0 C C WITH C C KHAT = CURRENT ESTIMATE FOR K C N = SAMPLE SIZE C XBAR = SAMPLE MEAN C PSI = PSI FUNCTION C C INPUT ARGUMENTS--DK = THE DOUBLE PRECISION VALUE THAT C SPECIFIES THE K SHAPE PARAMETER FOR C THE NEGATIVE BINOMIAL DISTRIBUTION. C OUTPUT--THE DOUBLE PRECISION FUNCTION VALUE NBFUN. C PRINTING--NONE. C RESTRICTIONS--NONE. C OTHER DATAPAC SUBROUTINES NEEDED--DPSI. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--KARL BURY (1999). "STATISTICAL DISTRIBUTIONS IN C ENGINEERING", CAMBRIDGE UNIVERSITY PRESS, P. 91. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2006.5 C ORIGINAL VERSION--MAY 2006. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DK DOUBLE PRECISION DX(*) C DOUBLE PRECISION DXBAR COMMON/NBCOM/DXBAR,N C EXTERNAL DPSI DOUBLE PRECISION DPSI DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 DOUBLE PRECISION DSUM1 C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C DTERM1=DLOG(DK) - DLOG(DXBAR + DK) - DPSI(DK) DSUM1=0.0D0 DO100I=1,N DTERM2=DX(I) + DK DSUM1=DSUM1 + DPSI(DTERM2) 100 CONTINUE NBFUN=DTERM1 + DSUM1/DBLE(N) C 9999 CONTINUE RETURN END SUBROUTINE NBPDF(X,P,AN,PDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY MASS C FUNCTION VALUE AT THE SINGLE PRECISION VALUE X C FOR THE NEGATIVE BINOMIAL DISTRIBUTION C WITH SINGLE PRECISION 'BERNOULLI PROBABILITY' C PARAMETER = P, C AND INTEGER 'NUMBER OF SUCCESSES IN BERNOULLI TRIALS' C PARAMETER = N. C THE NEGATIVE BINOMIAL DISTRIBUTION USED C HEREIN HAS MEAN = N*(1-P)/P C AND STANDARD DEVIATION = SQRT(N*(1-P)/(P*P))). C THIS DISTRIBUTION IS DEFINED FOR C ALL NON-NEGATIVE INTEGER X--X = 0, 1, 2, ... . C THIS DISTRIBUTION HAS THE PROBABILITY FUNCTION C F(X) = C(N+X-1,N) * P**N * (1-P)**X. C WHERE C(N+X-1,N) IS THE COMBINATORIAL FUNCTION C EQUALING THE NUMBER OF COMBINATIONS OF N+X-1 ITEMS C TAKEN N AT A TIME. C THE NEGATIVE BINOMIAL DISTRIBUTION IS THE C DISTRIBUTION OF THE NUMBER OF FAILURES C BEFORE OBTAINING N SUCCESSES IN AN C INDEFINITE SEQUENCE OF BERNOULLI (0,1) C TRIALS WHERE THE PROBABILITY OF SUCCESS C IN A SINGLE TRIAL = P. C C THE NEGATIVE BINOMIAL CAN BE EXTENDED TO THE C CASE WHERE N IS POSITIVE REAL NUMBER (I.E., NOT C RESTRICTED TO AN INTEGER). IN THAT CASE, THE C PROBABILITY FUNCTION IS: C C F(X) = P**N * (1-P)**X * GAMMA(N+X)/(GAMMA(N)*X!) C C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE C AT WHICH THE PROBABILITY MASS C FUNCTION IS TO BE EVALUATED. C X SHOULD BE NON-NEGATIVE AND C INTEGRAL-VALUED. C --P = THE SINGLE PRECISION VALUE C OF THE 'BERNOULLI PROBABILITY' C PARAMETER FOR THE NEGATIVE BINOMIAL C DISTRIBUTION. C P SHOULD BE BETWEEN C 0.0 (EXCLUSIVELY) AND C 1.0 (EXCLUSIVELY). C --N = THE REAL VALUE C OF THE 'NUMBER OF SUCCESSES C IN BERNOULLI TRIALS' PARAMETER. C N SHOULD BE A POSITIVE NUMBER. C OUTPUT ARGUMENTS--PDF = THE SINGLE PRECISION CUMULATIVE C DISTRIBUTION FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION PROBABILITY MASS C FUNCTION VALUE PDF C FOR THE NEGATIVE BINOMIAL DISTRIBUTION C WITH 'BERNOULLI PROBABILITY' PARAMETER = P C AND 'NUMBER OF SUCCESSES IN BERNOULLI TRIALS' C PARAMETER = N. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--X SHOULD BE NON-NEGATIVE AND INTEGRAL-VALUED. C --P SHOULD BE BETWEEN 0.0 (EXCLUSIVELY) C AND 1.0 (EXCLUSIVELY). C --N SHOULD BE POSITIVE. C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--DSQRT, DATAN, LNGAMM. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C COMMENT--NOTE THAT EVEN THOUGH THE INPUT C TO THIS CUMULATIVE C DISTRIBUTION FUNCTION SUBROUTINE C FOR THIS DISCRETE DISTRIBUTION C SHOULD (UNDER NORMAL CIRCUMSTANCES) BE A C DISCRETE INTEGER VALUE, C THE INPUT VARIABLE X IS SINGLE C PRECISION IN MODE. C X HAS BEEN SPECIFIED AS SINGLE C PRECISION SO AS TO CONFORM WITH THE DATAPAC C CONVENTION THAT ALL INPUT ****DATA**** C (AS OPPOSED TO SAMPLE SIZE, FOR EXAMPLE) C VARIABLES TO ALL C DATAPAC SUBROUTINES ARE SINGLE PRECISION. C THIS CONVENTION IS BASED ON THE BELIEF THAT C 1) A MIXTURE OF MODES (FLOATING POINT C VERSUS INTEGER) IS INCONSISTENT AND C AN UNNECESSARY COMPLICATION C IN A DATA ANALYSIS; AND C 2) FLOATING POINT MACHINE ARITHMETIC C (AS OPPOSED TO INTEGER ARITHMETIC) C IS THE MORE NATURAL MODE FOR DOING C DATA ANALYSIS. C REFERENCES--NATIONAL BUREAU OF STANDARDS APPLIED MATHEMATICS C SERIES 55, 1964, PAGE 945, FORMULAE 26.5.24 AND C 26.5.28, AND PAGE 929. C --JOHNSON, KOTZ, AND KEMP, "DISCRETE UNIVARIATE C DISTRIBUTIONS", SECOND EDITION, 1992. C --EVANS, HASTINGS AND PEACOCK, STATISTICAL C DISTRIBUTIONS--THIRD EDITION, 2001. C --FELLER, AN INTRODUCTION TO PROBABILITY C THEORY AND ITS APPLICATIONS, VOLUME 1, C EDITION 2, 1957, PAGES 155-157, 210. C --KENDALL AND STUART, THE ADVANCED THEORY OF C STATISTICS, VOLUME 1, EDITION 2, 1963, PAGES 130-131. C --WILLIAMSON AND BRETHERTON, TABLES OF C THE NEGATIVE BINOMIAL PROBABILITY C DISTRIBUTION, 1963. C --OWEN, HANDBOOK OF STATISTICAL C TABLES, 1962, PAGE 304. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--2004/3 C ORIGINAL VERSION--MARCH 2004. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C CHARACTER*4 ICASE C DOUBLE PRECISION DX DOUBLE PRECISION DP DOUBLE PRECISION DQ DOUBLE PRECISION DN DOUBLE PRECISION DLNGAM DOUBLE PRECISION DPDF C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----DATA STATEMENTS------------------------------------------------- C DATA EPS/0.000001/ C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(P.LE.0.0.OR.P.GE.1.0)THEN WRITE(ICOUT,11) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)P CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9000 ENDIF 11 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO THE ', 1'NBPDF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL') C IF(X.LT.0.0)THEN WRITE(ICOUT,4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9000 ENDIF 4 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT ', 1'TO THE NBPDF SUBROUTINE IS NEGATIVE *****') C INTN=AN+EPS FINTN=INTN DELN=ABS(AN-FINTX) ICASE='INTE' IF(DELN.GT.EPS)ICASE='REAL' N=INTN IF(ICASE.EQ.'INTE' .AND. N.LT.1)THEN WRITE(ICOUT,25) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)N CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9000 ELSEIF(ICASE.EQ.'REAL' .AND. AN.LE.0.0)THEN WRITE(ICOUT,27) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)AN CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9000 ENDIF 25 FORMAT('***** ERROR--THE THIRD INPUT ARGUMENT TO THE ', 1'NBPDF SUBROUTINE IS A NON-POSITIVE INTEGER *****') 27 FORMAT('***** ERROR--THE THIRD INPUT ARGUMENT TO THE ', 1'NBPDF SUBROUTINE IS A NON-POSITIVE REAL *****') C INTX=X+0.0001 FINTX=INTX DEL=ABS(X-FINTX) IF(DEL.GT.0.001)THEN WRITE(ICOUT,5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') ENDIF 5 FORMAT('***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT ', 1'TO THE NBPDF SUBROUTINE IS NON-INTEGRAL *****') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****') C C SUPPORT NON-INTEGER VALUES FOR N. IN THIS CASE, THE C PDF FUNCTION = 1 - I(1-P)(X+1,AN) C DN=DBLE(N) DP=DBLE(P) DQ=DBLE(1.0-P) DX=DBLE(FINTX) DPDF=DLNGAM(DN+DX) + DN*DLOG(DP) + DX*DLOG(DQ) - DLNGAM(DN) - 1 DLNGAM(DX+1.0D0) DPDF=DEXP(DPDF) PDF=REAL(DPDF) C 9000 CONTINUE RETURN C END SUBROUTINE NBPPF(P,PPAR,AN,PPF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT C FUNCTION VALUE AT THE SINGLE PRECISION VALUE P C FOR THE NEGATIVE BINOMIAL DISTRIBUTION C WITH SINGLE PRECISION 'BERNOULLI PROBABILITY' C PARAMETER = PPAR, C AND INTEGER 'NUMBER OF SUCCESSES IN BERNOULLI TRIALS' C PARAMETER = N. C THE NEGATIVE BINOMIAL DISTRIBUTION USED C HEREIN HAS MEAN = N*(1-PPAR)/PPAR C AND STANDARD DEVIATION = SQRT(N*(1-PPAR)/(PPAR*PPAR))). C THIS DISTRIBUTION IS DEFINED FOR C ALL NON-NEGATIVE INTEGER X--X = 0, 1, 2, ... . C THIS DISTRIBUTION HAS THE PROBABILITY FUNCTION C F(X) = C(N+X-1,N) * PPAR**N * (1-PPAR)**X. C WHERE C(N+X-1,N) IS THE COMBINATORIAL FUNCTION C EQUALING THE NUMBER OF COMBINATIONS OF N+X-1 ITEMS C TAKEN N AT A TIME. C THE NEGATIVE BINOMIAL DISTRIBUTION IS THE C DISTRIBUTION OF THE NUMBER OF FAILURES C BEFORE OBTAINING N SUCCESSES IN AN C INDEFINITE SEQUENCE OF BERNOULLI (0,1) C TRIALS WHERE THE PROBABILITY OF SUCCESS C IN A SINGLE TRIAL = PPAR. C NOTE THAT THE PERCENT POINT FUNCTION OF A DISTRIBUTION C IS IDENTICALLY THE SAME AS THE INVERSE CUMULATIVE C DISTRIBUTION FUNCTION OF THE DISTRIBUTION. C INPUT ARGUMENTS--P = THE SINGLE PRECISION VALUE C (BETWEEN 0.0 (INCLUSIVELY) C AND 1.0 (EXCLUSIVELY)) C AT WHICH THE PERCENT POINT C FUNCTION IS TO BE EVALUATED. C --PPAR = THE SINGLE PRECISION VALUE C OF THE 'BERNOULLI PROBABILITY' C PARAMETER FOR THE NEGATIVE BINOMIAL C DISTRIBUTION. C PPAR SHOULD BE BETWEEN C 0.0 (EXCLUSIVELY) AND C 1.0 (EXCLUSIVELY). C --N = THE INTEGER VALUE C OF THE 'NUMBER OF SUCCESSES C IN BERNOULLI TRIALS' PARAMETER. C N SHOULD BE A POSITIVE INTEGER. C OUTPUT ARGUMENTS--PPF = THE SINGLE PRECISION PERCENT C POINT FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION PERCENT POINT . C FUNCTION VALUE PPF C FOR THE NEGATIVE BINOMIAL DISTRIBUTION C WITH 'BERNOULLI PROBABILITY' PARAMETER = PPAR C AND 'NUMBER OF SUCCESSES IN BERNOULLI TRIALS' C PARAMETER = N. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--PPAR SHOULD BE BETWEEN 0.0 (EXCLUSIVELY) C AND 1.0 (EXCLUSIVELY). C --N SHOULD BE A POSITIVE INTEGER. C --P SHOULD BE BETWEEN 0.0 (INCLUSIVELY) C AND 1.0 (EXCLUSIVELY). C OTHER DATAPAC SUBROUTINES NEEDED--NORPPF, NBCDF. C FORTRAN LIBRARY SUBROUTINES NEEDED--SQRT, EXP, ALOG. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION AND DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C COMMENT--NOTE THAT EVEN THOUGH THE OUTPUT C FROM THIS DISCRETE DISTRIBUTION C PERCENT POINT FUNCTION C SUBROUTINE MUST NECESSARILY BE A C DISCRETE INTEGER VALUE, C THE OUTPUT VARIABLE PPF IS SINGLE C PRECISION IN MODE. C PPF HAS BEEN SPECIFIED AS SINGLE C PRECISION SO AS TO CONFORM WITH THE DATAPAC C CONVENTION THAT ALL OUTPUT VARIABLES FROM ALL C DATAPAC SUBROUTINES ARE SINGLE PRECISION. C THIS CONVENTION IS BASED ON THE BELIEF THAT C 1) A MIXTURE OF MODES (FLOATING POINT C VERSUS INTEGER) IS INCONSISTENT AND C AN UNNECESSARY COMPLICATION C IN A DATA ANALYSIS; AND C 2) FLOATING POINT MACHINE ARITHMETIC C (AS OPPOSED TO INTEGER ARITHMETIC) C IS THE MORE NATURAL MODE FOR DOING C DATA ANALYSIS. C REFERENCES--JOHNSON AND KOTZ, DISCRETE C DISTRIBUTIONS, 1969, PAGES 122-142, C ESPECIALLY PAGE 127, FORMULA 22. C --HASTINGS AND PEACOCK, STATISTICAL C DISTRIBUTIONS--A HANDBOOK FOR C STUDENTS AND PRACTITIONERS, 1975, C PAGES 92-95. C --NATIONAL BUREAU OF STANDARDS APPLIED MATHEMATICS C SERIES 55, 1964, PAGE 929. C --FELLER, AN INTRODUCTION TO PROBABILITY C THEORY AND ITS APPLICATIONS, VOLUME 1, C EDITION 2, 1957, PAGES 155-157, 210. C --KENDALL AND STUART, THE ADVANCED THEORY OF C STATISTICS, VOLUME 1, EDITION 2, 1963, PAGES 130-131. C --WILLIAMSON AND BRETHERTON, TABLES OF C THE NEGATIVE BINOMIAL PROBABILITY C DISTRIBUTION, 1963. C --OWEN, HANDBOOK OF STATISTICAL C TABLES, 1962, PAGE 304. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--82.6 C ORIGINAL VERSION--NOVEMBER 1975. C UPDATED --OCTOBER 1978. C UPDATED --DECEMBER 1981. C UPDATED --DECEMBER 1981. C UPDATED --MAY 1982. C UPDATED --MARCH 2004. EXTENDED TO SUPPORT C NON-INTEGER VALUES FOR N C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DPPAR C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(P.LT.0.0.OR.P.GE.1.0)THEN WRITE(ICOUT,1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)P CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9000 ENDIF IF(PPAR.LE.0.0.OR.PPAR.GE.1.0)THEN WRITE(ICOUT,11) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)PPAR CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9000 ENDIF IF(AN.LE.0.0)THEN WRITE(ICOUT,25) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)AN CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9000 ENDIF 1 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO THE ', 1'NBPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL') 11 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO THE ', 1'NBPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL') 25 FORMAT('***** ERROR--THE THIRD INPUT ARGUMENT TO THE ', 1'NBPPF SUBROUTINE IS NON-POSITIVE *****') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****') C N=INT(AN+0.000001) DPPAR=PPAR PPF=0.0 IX0=0 IX1=0 IX2=0 P0=0.0 P1=0.0 P2=0.0 C C TREAT CERTAIN SPECIAL CASES IMMEDIATELY-- C 1) P = 0.0 C 2) P = 0.5 AND PPAR = 0.5 C 3) PPF = 0 C IF(P.EQ.0.0)THEN PPF=0.0 GOTO9000 ENDIF IF(P.EQ.0.5.AND.PPAR.EQ.0.5)THEN PPF=N-1 GOTO9000 ENDIF PF0=DPPAR**AN IF(P.LE.PF0)THEN PPF=0.0 GOTO9000 ENDIF C C DETERMINE AN INITIAL APPROXIMATION TO THE NEGATIVE BINOMIAL C PERCENT POINT BY USE OF THE HYPERBOLIC ARCSIN C TRANSFORMATION OF THE NEGATIVE BINOMIAL C TO APPROXIMATE NORMALITY. C (SEE JOHNSON AND KOTZ, DISCRETE DISTRIBUTIONS, C PAGE 127, FORMULA 22). C AMEAN=AN*(1.0-PPAR)/PPAR SD=SQRT(AN*(1.0-PPAR)/(PPAR*PPAR)) ARG=SQRT((AMEAN+0.375)/(AN-0.75)) ARCSH=ALOG(ARG+SQRT(ARG*ARG+1.0)) YMEAN=(SQRT(AN-0.5))*ARCSH YSD=0.5 CALL NORPPF(P,ZPPF) YPPF=YMEAN+ZPPF*YSD ARG=YPPF/SQRT(AN-0.5) E=EXP(ARG) SINH=(E-1.0/E)/2.0 X2=-0.375+(AN-0.75)*SINH*SINH X2=X2+0.5 IX2=X2 C C CHECK AND MODIFY (IF NECESSARY) THIS INITIAL C ESTIMATE OF THE PERCENT POINT C TO ASSURE THAT IT BE NON-NEGATIVE. C IF(IX2.LT.0)IX2=0 C C DETERMINE UPPER AND LOWER BOUNDS ON THE DESIRED C PERCENT POINT BY ITERATING OUT (BOTH BELOW AND ABOVE) C FROM THE ORIGINAL APPROXIMATION AT STEPS C OF 1 STANDARD DEVIATION. C THE RESULTING BOUNDS WILL BE AT MOST C 1 STANDARD DEVIATION APART. C IX0=0 IX1=INT(10.0**7 + 0.01) ISD=SD+1.0 X2=IX2 CALL NBCDF(X2,PPAR,AN,P2) C IF(P2.LT.P)GOTO210 GOTO250 C 210 CONTINUE IX0=IX2 I=1 215 CONTINUE IX2=IX0+ISD IF(IX2.GE.IX1)GOTO275 X2=IX2 CALL NBCDF(X2,PPAR,AN,P2) IF(P2.GE.P)GOTO230 IX0=IX2 220 CONTINUE I=I+1 IF(I.LE.1000000)GOTO215 WRITE(ICOUT,249) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,222) CALL DPWRST('XXX','BUG ') GOTO950 230 IX1=IX2 GOTO275 C 250 CONTINUE IX1=IX2 I=1 255 CONTINUE IX2=IX1-ISD IF(IX2.LE.IX0)GOTO275 X2=IX2 CALL NBCDF(X2,PPAR,AN,P2) IF(P2.LT.P)GOTO270 IX1=IX2 260 CONTINUE I=I+1 IF(I.LE.1000000)GOTO255 WRITE(ICOUT,249) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,262) CALL DPWRST('XXX','BUG ') GOTO950 270 IX0=IX2 C 275 IF(IX0.EQ.IX1)GOTO280 GOTO295 280 IF(IX0.EQ.0)GOTO285 IF(IX0.EQ.N)GOTO290 WRITE(ICOUT,249) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,282) CALL DPWRST('XXX','BUG ') GOTO950 285 IX1=IX1+1 GOTO295 290 IX0=IX0-1 295 CONTINUE C C COMPUTE NEGATIVE BINOMIAL PROBABILITIES FOR THE C DERIVED LOWER AND UPPER BOUNDS. C X0=IX0 X1=IX1 CALL NBCDF(X0,PPAR,AN,P0) CALL NBCDF(X1,PPAR,AN,P1) C C CHECK THE PROBABILITIES FOR PROPER ORDERING C IF(P0.LT.P.AND.P.LE.P1)GOTO490 IF(P0.EQ.P)GOTO410 IF(P1.EQ.P)GOTO420 IF(P0.GT.P1)GOTO430 IF(P0.GT.P)GOTO440 IF(P1.LT.P)GOTO450 WRITE(ICOUT,249) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,401) CALL DPWRST('XXX','BUG ') GOTO950 410 PPF=IX0 GOTO9000 420 PPF=IX1 GOTO9000 430 WRITE(ICOUT,249) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,431) CALL DPWRST('XXX','BUG ') GOTO950 440 WRITE(ICOUT,249) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,441) CALL DPWRST('XXX','BUG ') GOTO950 450 WRITE(ICOUT,249) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,451) CALL DPWRST('XXX','BUG ') GOTO950 490 CONTINUE C C THE STOPPING CRITERION IS THAT THE LOWER BOUND C AND UPPER BOUND ARE EXACTLY 1 UNIT APART. C CHECK TO SEE IF IX1 = IX0 + 1; C IF SO, THE ITERATIONS ARE COMPLETE; C IF NOT, THEN BISECT, COMPUTE PROBABILIIES, C CHECK PROBABILITIES, AND CONTINUE ITERATING C UNTIL IX1 = IX0 + 1. C 300 IX0P1=IX0+1 IF(IX1.EQ.IX0P1)GOTO690 IX2=(IX0+IX1)/2 IF(IX2.EQ.IX0)GOTO610 IF(IX2.EQ.IX1)GOTO620 X2=IX2 CALL NBCDF(X2,PPAR,AN,P2) IF(P0.LT.P2.AND.P2.LT.P1)GOTO630 IF(P2.LE.P0)GOTO640 IF(P2.GE.P1)GOTO650 610 WRITE(ICOUT,249) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,611) CALL DPWRST('XXX','BUG ') GOTO950 620 WRITE(ICOUT,249) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,611) CALL DPWRST('XXX','BUG ') GOTO950 630 IF(P2.LE.P)GOTO635 IX1=IX2 P1=P2 GOTO300 635 IX0=IX2 P0=P2 GOTO300 640 WRITE(ICOUT,249) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,641) CALL DPWRST('XXX','BUG ') GOTO950 650 WRITE(ICOUT,249) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,651) CALL DPWRST('XXX','BUG ') GOTO950 690 PPF=IX1 IF(P0.EQ.P)PPF=IX0 GOTO9000 C 950 WRITE(ICOUT,240)IX0,P0 CALL DPWRST('XXX','BUG ') WRITE(ICOUT,241)IX1,P1 CALL DPWRST('XXX','BUG ') WRITE(ICOUT,242)IX2,P2 CALL DPWRST('XXX','BUG ') WRITE(ICOUT,244)P CALL DPWRST('XXX','BUG ') WRITE(ICOUT,245)PPAR,N CALL DPWRST('XXX','BUG ') GOTO9000 C 222 FORMAT('NO UPPER BOUND FOUND AFTER 10**7 ITERATIONS') 240 FORMAT('IX0 = ',I8,10X,'P0 = ',F14.7) 241 FORMAT('IX1 = ',I8,10X,'P1 = ',F14.7) 242 FORMAT('IX2 = ',I8,10X,'P2 = ',F14.7) 244 FORMAT('P = ',F14.7) 245 FORMAT('PPAR = ',F14.7,10X,'N = ',I8) 249 FORMAT('***** INTERNAL ERROR IN NBPPF SUBROUTINE *****') 262 FORMAT('NO LOWER BOUND FOUND AFTER 10**7 ITERATIONS') 282 FORMAT('LOWER AND UPPER BOUND IDENTICAL') 401 FORMAT('IMPOSSIBLE BRANCH CONDITION ENCOUNTERED') 431 FORMAT('LOWER BOUND PROBABILITY (P0) GREATER THAN ', 1 'UPPER BOUND PROBABILITY (P1)') 441 FORMAT('LOWER BOUND PROBABILITY (P0) GREATER THAN ', 1 21HINPUT PROBABILITY (P)) 451 FORMAT('UPPER BOUND PROBABILITY (P1) LESS THAN ', 1 'INPUT PROBABILITY (P)') 611 FORMAT('BISECTION VALUE (X2) = LOWER BOUND (X0)') 621 FORMAT('BISECTION VALUE (X2) = UPPER BOUND (X1)') 641 FORMAT('BISECTION VALUE PROBABILITY (P2) ', 1 'LESS THAN LOWER BOUND PROBABILITY (P0)') 651 FORMAT('BISECTION VALUE PROBABILITY (P2) ', 1 'GREATER THAN UPPER BOUND PROBABILITY (P1)') C 9000 CONTINUE RETURN END SUBROUTINE NBRAN(N,P,AK,ISEED,X) C C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N C FROM THE NEGATIVE BINOMIAL DISTRIBUTION C WITH SINGLE PRECISION 'BERNOULLI PROBABILITY' C PARAMETER = P, C AND INTEGER 'NUMBER OF SUCCESSES IN BERNOULLI TRIALS' C PARAMETER = K. C THE NEGATIVE BINOMIAL DISTRIBUTION USED C HEREIN HAS MEAN = K*(1-P)/P C AND STANDARD DEVIATION = SQRT(K*(1-P)/(P*P))). C THIS DISTRIBUTION IS DEFINED FOR C ALL NON-NEGATIVE INTEGER X--X = 0, 1, 2, ... . C THIS DISTRIBUTION HAS THE PROBABILITY FUNCTION C F(X) = C(K+X-1,K) * P**K * (1-P)**X. C WHERE C(K+X-1,K) IS THE COMBINATORIAL FUNCTION C EQUALING THE NUMBER OF COMBINATIONS OF K+X-1 ITEMS C TAKEN K AT A TIME. C THE NEGATIVE BINOMIAL DISTRIBUTION IS THE C DISTRIBUTION OF THE NUMBER OF FAILURES C BEFORE OBTAINING K SUCCESSES IN AN C INDEFINITE SEQUENCE OF BERNOULLI (0,1) C TRIALS WHERE THE PROBABILITY OF SUCCESS C IN A SINGLE TRIAL = P. C INPUT ARGUMENTS--N = THE DESIRED INTEGER NUMBER C OF RANDOM NUMBERS TO BE C GENERATED. C --P = THE SINGLE PRECISION VALUE C OF THE 'BERNOULLI PROBABILITY' C PARAMETER FOR THE NEGATIVE BINOMIAL C DISTRIBUTION. C P SHOULD BE BETWEEN C 0.0 (EXCLUSIVELY) AND C 1.0 (EXCLUSIVELY). C --K = THE INTEGER VALUE C OF THE 'NUMBER OF SUCCESSES C IN BERNOULLI TRIALS' PARAMETER. C K SHOULD BE A POSITIVE INTEGER. C OUTPUT ARGUMENTS--X = A SINGLE PRECISION VECTOR C (OF DIMENSION AT LEAST N) C INTO WHICH THE GENERATED C RANDOM SAMPLE WILL BE PLACED. C OUTPUT--A RANDOM SAMPLE OF SIZE N C FROM THE NEGATIVE BINOMIAL DISTRIBUTION C WITH 'BERNOULLI PROBABILITY' PARAMETER = P C AND 'NUMBER OF SUCCESSES IN BERNOULLI TRIALS' C PARAMETER = K. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C --P SHOULD BE BETWEEN 0.0 (EXCLUSIVELY) C AND 1.0 (EXCLUSIVELY). C --K SHOULD BE A POSITIVE INTEGER. C OTHER DATAPAC SUBROUTINES NEEDED--UNIRAN, BINRAN, GEORAN. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C COMMENT--NOTE THAT EVEN THOUGH THE OUTPUT C FROM THIS DISCRETE RANDOM NUMBER C GENERATOR MUST NECESSARILY BE A C SEQUENCE OF ***INTEGER*** VALUES, C THE OUTPUT VECTOR X IS SINGLE C PRECISION IN MODE. C X HAS BEEN SPECIFIED AS SINGLE C PRECISION SO AS TO CONFORM WITH THE DATAPAC C CONVENTION THAT ALL OUTPUT VECTORS FROM ALL C DATAPAC SUBROUTINES ARE SINGLE PRECISION. C THIS CONVENTION IS BASED ON THE BELIEF THAT C 1) A MIXTURE OF MODES (FLOATING POINT C VERSUS INTEGER) IS INCONSISTENT AND C AN UNNECESSARY COMPLICATION C IN A DATA ANALYSIS; AND C 2) FLOATING POINT MACHINE ARITHMETIC C (AS OPPOSED TO INTEGER ARITHMETIC) C IS THE MORE NATURAL MODE FOR DOING C DATA ANALYSIS. C REFERENCES--HASTINGS AND PEACOCK, STATISTICAL C DISTRIBUTIONS--A HANDBOOK FOR C STUDENTS AND PRACTITIONERS, 1975, C PAGE 95. C --JOHNSON AND KOTZ, DISCRETE C DISTRIBUTIONS, 1969, PAGES 122-142. C --FELLER, AN INTRODUCTION TO PROBABILITY C THEORY AND ITS APPLICATIONS, VOLUME 1, C EDITION 2, 1957, PAGES 155-157, 210. C --NATIONAL BUREAU OF STANDARDS APPLIED MATHEMATICS C SERIES 55, 1964, PAGE 929. C --KENDALL AND STUART, THE ADVANCED THEORY OF C STATISTICS, VOLUME 1, EDITION 2, 1963, PAGES 130-131. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--82.6 C ORIGINAL VERSION--NOVEMBER 1975. C UPDATED --DECEMBER 1981. C UPDATED --MAY 1982. C UPDATED --MARCH 2004. SUPPORT FOR NON-INTEGER K C UPDATED --MARCH 2004. ALGORITHM FOR MODERATE TO C LARGE K APPEARS WRONG (STARTS C AT X>=K, I.E., BASED ON C ALTERNATIVE DEFINITION OF C NEGATIVE BINOMIAL. C REPLACE CURRENT ALGORITHM C WITH CODE FROM ALAN MILLER C BASED ON J. DAGPUNAR, C "PRINCIPLES OF RANDOM VARIATE C GENERATION", CLARENDON PRESS, C OXFORD, 1988. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C REAL X(*) C COLD DIMENSION B(2) COLD DIMENSION G(2) C REAL H REAL Q REAL XTEMP REAL ST REAL AK REAL ULN REAL V REAL R(1) REAL S REAL Y REAL G INTEGER K INTEGER I INTEGER NTEMP INTEGER NUNI C C--------------------------------------------------------------------- C INCLUDE 'DPCOMC.INC' C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(N.LT.1)THEN WRITE(ICOUT, 5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)N CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF IF(P.LE.0.0.OR.P.GE.1.0)THEN WRITE(ICOUT,11) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)P CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF IF(AK.LE.0.0)THEN WRITE(ICOUT,25) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)K CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF 5 FORMAT('***** ERROR--THE NUMBER OF REQUESTED NEGATIVE ', 1'BINOMIAL RANDOM NUMBERS IS NON-POSITIVE.') 11 FORMAT('***** ERROR--THE FIRST SHAPE PARAMETER FOR THE ', 1'NEGATIVE BINOMIAL IS OUTSIDE THE (0,1) INTERVAL') 25 FORMAT('***** ERROR--THE SECOND SHAPE PARAMETER FOR THE ', 1'NEGATIVE BINOMIAL IS NON-POSITIVE') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****') C C C C REPLACE FOLLOWING ALGORITHM WITH ONE THAT CAN ACCOMODATE C REAL VALUES FOR K. C C CHECK ON THE MAGNITUDE OF P, C AND BRANCH TO THE FASTER C GENERATION METHOD ACCORDINGLY. C COLD IF(P.LT.0.1)GOTO450 C C IF P IS MODERATE OR LARGE, C GENERATE N NEGATIVE BINOMIAL NUMBERS C USING THE FACT THAT THE C WAITING TIME FOR K SUCCESSES IN C BERNOULLI TRIALS HAS A C NEGATIVE BINOMIAL DISTRIBUTION. C COLD DO100I=1,N COLD ISUM=0 COLD J=1 CO150 CALL BINRAN(1,P,1,ISEED,B) COLD IB=B(1)+0.5 COLD ISUM=ISUM+IB COLD IF(ISUM.EQ.K)GOTO250 COLD J=J+1 COLD GOTO150 CO250 X(I)=J CO100 CONTINUE COLD RETURN C C IF P IS SMALL, C GENERATE N NEGATIVE BINOMIAL NUMBERS C BY USING THE FACT THAT THE SUM C OF GEOMETRIC VARIATES IS A C NEGATIVE BINOMIAL VARIATE. C CO450 DO500I=1,N COLD ISUM=0 COLD DO600J=1,K COLD CALL GEORAN(1,P,ISEED,G) COLD IG=G(1)+0.5 COLD ISUM=ISUM+IG CO600 CONTINUE COLD X(I)=ISUM CO500 CONTINUE C C THIS ALGORITHM REVERSES THE ROLE OF P AND Q AS C USED IN DATAPLOT. C NUNI=1 Q=P P2=1.0-Q H=0.7 C DO600I=1,N C XTEMP=0.0 ST=AK C IF(P2.GT.H)THEN V=1.0/LOG(P2) K=ST + 0.0000001 DO610ITEMP=1,K 620 CONTINUE CALL UNIRAN(NUNI,ISEED,R) IF(R(1).LE.0.0)GOTO620 NTEMP=V*LOG(R(1)) XTEMP=XTEMP+NTEMP 610 CONTINUE ST=ST-K ENDIF C S=0.0 ULN=-LOG(R1MACH(1)) IF(ST.GT.-ULN/LOG(Q))THEN WRITE(ICOUT,691) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,692)P2,AK CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF Y=Q**ST G=ST CALL UNIRAN(NUNI,ISEED,R) 630 CONTINUE IF(Y.LE.R(1))THEN R(1)=R(1)-Y S=S+1.0 Y=Y*P2*G/S G=G+1.0 GOTO630 ENDIF X(I)=XTEMP+S 600 CONTINUE C 691 FORMAT('***** ERROR IN NEGATIVE BINOMIAL RANDOM NUMBERS--') 692 FORMAT(' THE VALUE OF P (',F10.5,') IS TOO LARGE FOR THE ', 1 'VALUE OF K (',F10.5,')') C 9000 CONTINUE RETURN END SUBROUTINE NCBCDF(XSNGL, ASNGL, BSNGL, LAMBDS, CDF) C C ALGORITHM AS226 APPL. STATIST. (1987) VOL. 36, NO. 2 C Incorporates modification AS R84 from AS vol. 39, pp311-2, 1990 C C Returns the cumulative probability of X for the non-central beta C distribution with parameters A, B and non-centrality LAMBDA C C Auxiliary routines required: DLNGAM - log-gamma function (ACM C 291 or AS 245), and BETAIN - incomplete-beta function (AS 63) C REAL XSNGL, ASNGL, BSNGL, LAMBDS, CDF DOUBLE PRECISION A, AX, B, BETA, C, ERRBD, ERRMAX, GX, HALF, * LAMBDA, ONE, Q, SUMQ, TEMP, X, XJ, ZERO DOUBLE PRECISION BETANC, A0, X0, UALPHA DOUBLE PRECISION DLNGAM DOUBLE PRECISION DLBETA DOUBLE PRECISION DBETAI C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C C Change ERRMAX and ITRMAX if desired ... C MAY 2004. Increase error criterion and number of iterations C (to get more accuracy for PDF function) C CCCCC DATA ERRMAX, ITRMAX /1.0D-6, 100/, UALPHA /5.0D0/ DATA ERRMAX, ITRMAX /1.0D-8, 300/, UALPHA /5.0D0/ DATA ZERO, HALF, ONE /0.0D0, 0.5D0, 1.0D0/ C A=DBLE(ASNGL) B=DBLE(BSNGL) LAMBDA=DBLE(LAMBDS) X=DBLE(XSNGL) CDF=0.0 C IF(A.LE.0.0 .OR. B.LE.0.0)THEN WRITE(ICOUT,101) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,102) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,103)A CALL DPWRST('XXX','BUG ') WRITE(ICOUT,104)B CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF IF(X.LT.0.D0)THEN WRITE(ICOUT,301) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,302)X CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF IF(X.GT.1.D0)THEN WRITE(ICOUT,401) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,402)X CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF IF(LAMBDA.LT.0.D0)THEN WRITE(ICOUT,501) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,502) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,503)LAMBDS CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF 101 FORMAT('***** FATAL DIAGNOSTIC--EITHER THE ALPHA OR BETA IS') 102 FORMAT(' NON-POSITIVE.') 103 FORMAT(' THE VALUE OF ALPHA IS ',E15.7) 104 FORMAT(' THE VALUE OF BETA IS ',E15.7,' ******') 301 FORMAT('***** FATAL DIAGNOSTIC--THE INPUT ARGUMENT IS ') 302 FORMAT(' NON-POSITIVE. IT HAS THE VALUE ',E15.7) 401 FORMAT('***** FATAL DIAGNOSTIC--THE INPUT ARGUMENT IS GRETATER') 402 FORMAT(' THAN 1. IT HAS THE VALUE ',E15.7) 501 FORMAT('***** FATAL DIAGNOSTIC--THE NON-CENTRALITY PARAMETER') 502 FORMAT(' NEGATIVE.') 503 FORMAT(' THE VALUE OF LAMBDA IS ',E15.7) C BETANC = X CDF=REAL(BETANC) C IF (X .EQ. ZERO .OR. X .EQ. ONE) GOTO9999 C C = LAMBDA * HALF C C Initialize the series ... C X0 = INT(MAX(C - UALPHA*SQRT(C), ZERO)) A0 = A + X0 CCCCC BETA = DLNGAM(A0) + DLNGAM(B) - DLNGAM(A0+B) BETA = DLBETA(A0,B) TEMP = DBETAI(X, A0, B) GX = EXP(A0 * LOG(X) + B * LOG(ONE - X) - BETA - LOG(A0)) IF (A0 .GT. A) THEN Q = EXP(-C + X0*LOG(C) - DLNGAM(X0 + ONE)) ELSE Q = EXP(-C) END IF XJ = ZERO AX = Q * TEMP SUMQ = ONE - Q BETANC = AX C C Recur over subsequent terms until convergence is achieved... C 10 XJ = XJ + ONE TEMP = TEMP - GX GX = X * (A + B + XJ - ONE) * GX / (A + XJ) Q = Q * C / XJ SUMQ = SUMQ - Q AX = TEMP * Q BETANC = BETANC + AX C C Check for convergence and act accordingly... C ERRBD = (TEMP - GX) * SUMQ IF ((INT(XJ) .LT. ITRMAX) .AND. (ERRBD .GT. ERRMAX)) GO TO 10 IF (ERRBD .GT. ERRMAX) THEN WRITE(ICOUT,701) CALL DPWRST('XXX','BUG ') CDF=REAL(BETANC) GOTO9999 ELSE CDF=REAL(BETANC) GOTO9999 ENDIF 701 FORMAT('***** WARNING--THE BETCDF ROUTINE DID NOT CONVERGE. ***') C 9999 CONTINUE RETURN END REAL FUNCTION NCBFU3(X) C C PURPOSE--NCBPDF CALLS DIFF TO FIND A NUMERICAL DERIVATIVE C FOR THE NON-CENTRAL CUMULATIVE DISTRIBUTION FUNCTION. C NCBFU3 IS A FUNCTION THAT CALL NCBCDF. C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE AT C WHICH THE DERIVATIVE C IS TO BE EVALUATED. C OUTPUT--THE SINGLE PRECISION FUNCTION VALUE NCBFU3. C PRINTING--NONE. C RESTRICTIONS--NONE. C OTHER DATAPAC SUBROUTINES NEEDED--NCBCDF. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATION INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2004.3 C ORIGINAL VERSION--APRIL 2004. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C REAL ALPHA REAL BETA REAL ALAMB COMMON/NCBCOM/ALPHA,BETA,ALAMB C C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C CALL NCBCDF(X,ALPHA,BETA,ALAMB,CDF) NCBFU3=CDF C 9999 CONTINUE RETURN END SUBROUTINE NCBPDF(X, A, B, LAMBDA, PDF) C C PURPOSE--PROBABILITY DENSITY FUNCTION FOR THE NON-CENTRAL C BETA DISTRIBUTION. THE PROBABILITY DENSITY FUNCTION C IS COMPUTED BY COMPUTING THE NUMERICAL DERIVATIVE OF C THE CUMULATIVE DISTRIBUTION FUNCTION. C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE AT C WHICH THE PROBABILITY DENSITY C FUNCTION IS TO BE EVALUATED. C --ALPHA = THE FIRST SHAPE PARAMETER C --BETA = THE SECOND SHAPE PARAMETER C --LAMBDS = THE NON-CENTRALITY PARAMETER C OUTPUT ARGUMENTS--PDF = THE SINGLE PRECISION PROBABILITY C DENSITY FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY C FUNCTION VALUE PDF. C PRINTING--NONE. C RESTRICTIONS--NONE. C OTHER DATAPAC SUBROUTINES NEEDED--DIFF. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--LENTH, "COMPUTING NONCENTRAL BETA PROBABILITIES", C APPLIED STATISTICS, VOL. 39, NO. 2, 1987, C PP. 241-244. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2004/4 C ORIGINAL VERSION--APRIL 2004. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C REAL X REAL A REAL B REAL LAMBDA REAL PDF C REAL NCBFU3 EXTERNAL NCBFU3 REAL ALPHA REAL BETA REAL ALAMB COMMON/NCBCOM/ALPHA,BETA,ALAMB C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C PDF=0.0 C IF(A.LE.0.0)THEN WRITE(ICOUT,101) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,104)A CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF IF(B.LE.0.0)THEN WRITE(ICOUT,102) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,104)B CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF IF(LAMBDA.LT.0.0)THEN WRITE(ICOUT,103) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,104)LAMBDA CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF IF(X.LT.0.0 .OR. X.GT.1.0)THEN WRITE(ICOUT,105) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,104)X CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF 101 FORMAT('***** ERROR--THE FIRST SHAPE PARAMETER FOR THE ', 1 'NON-CENTRAL BETA PDF IS NON-POSITIVE.') 102 FORMAT('***** ERROR--THE SECOND SHAPE PARAMETER FOR THE ', 1 'NON-CENTRAL BETA PDF IS NON-POSITIVE.') 103 FORMAT('***** ERROR--THE NON-CENTRALITY PARAMETER FOR THE ', 1 'NON-CENTRAL BETA PDF IS NEGATIVE.') 104 FORMAT(' THE VALUE OF THE PARAMETER IS ',E15.7) 105 FORMAT('***** ERROR--THE INPUT ARGUMENT FOR THE NON-CENTRAL ', 1 'BETA PDF IS OUTSIDE THE (0,1) INTERVAL') C C USE NON-CENTRAL F PDF FUNCTION C C NOTE: THIS RELATIONSHIP APPLIES TO CDF FUNCTION, NOT CLEAR C THAT IT APPLIES TO PDF (DO NOT GET CONSISTENT ANSWERS). C CCCCC DF2=2.0*B CCCCC DF2=2.0*B CCCCC XTEMP=X*DF2/(DF1 - X*DF1) CCCCC CALL NCFPDF(XTEMP,DF1,DF2,ALAMB,PDF) CCCCC GOTO9999 C C FIND NUMERIC DERIVATIVE OF CDF ROUTINE C IFAIL=0 IORD=1 EPS=0.001 ACCUR=0.0 IFAIL=0 X0 = X XMIN=0.0 XMAX=1.0 ALPHA=A BETA=B ALAMB=LAMBDA C CALL DIFF(IORD,X0,XMIN,XMAX,NCBFU3,EPS,ACCUR,PDF,ERROR,IFAIL) C IF(IFAIL.EQ.1)THEN 999 FORMAT(1X) WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,301) 301 FORMAT('***** WARNING IN NUMERICAL DERIVATIVE FOR NCBPDF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,303) 303 FORMAT(' THE ESTIMATED ERROR IN THE RESULT EXCEEDS THE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,305) 305 FORMAT(' REQUESTED ERROR, BUT THE MOST ACCURATE RESULT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,307) 307 FORMAT(' POSSIBLE HAS BEEN RETURNED.') CALL DPWRST('XXX','BUG ') ELSEIF(IFAIL.EQ.2)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,311) 311 FORMAT('***** ERROR IN NUMERICAL DERIVATIVE FOR NCBPDF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,313) 313 FORMAT(' ERROR IN THE INPUT TO THE DIFF ROUTINE.') CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ELSEIF(IFAIL.EQ.3)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,321) 321 FORMAT('***** ERROR IN NUMERICAL DERIVATIVE FOR NCBPDF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,323) 323 FORMAT(' THE INTERVAL FOR DIFFERENTIATION, (',G15.7, 1 ',',G15.7,')') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,325) 325 FORMAT(' IS TOO SMALL.') CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ENDIF C C 9999 CONTINUE RETURN END SUBROUTINE NCBPPF(P,ALPHA,BETA,LAMBDA,PPF) C C PURPOSE --PERCENT POINT FUNCTION FOR THE NON-CENTRAL BETA C DISTRIBUTION. USES A BISECTION METHOD. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--JULY 1981. C UPDATED --FEBRUARY 1982. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CCCCC DOUBLE PRECISION DCDF CCCCC DOUBLE PRECISION DALPHA CCCCC DOUBLE PRECISION DBETA CCCCC DOUBLE PRECISION DX CCCCC DOUBLE PRECISION DBETAI REAL LAMBDA C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C DATA EPS /0.0001/ DATA SIG /1.0E-5/ DATA ZERO /0./ DATA MAXIT /100/ C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(P.LT.0.0.OR.P.GT.1.0)GOTO50 IF(ALPHA.LE.0.0)GOTO55 IF(BETA.LE.0.0)GOTO60 IF(LAMBDA.LT.0.0)GOTO70 GOTO90 50 WRITE(ICOUT,1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)P CALL DPWRST('XXX','BUG ') PPF=0.0 RETURN 55 WRITE(ICOUT,11) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)ALPHA CALL DPWRST('XXX','BUG ') PPF=0.0 RETURN 60 WRITE(ICOUT,25) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)BETA CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9999 70 WRITE(ICOUT,35) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)LAMBDA CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9999 C 1 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ', 1' NCBPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL') 11 FORMAT('***** FATAL ERROR--THE 2ND INPUT ARGUMENT TO THE ', 1' NCBPPF SUBROUTINE IS NON-POSITIVE') 25 FORMAT('***** FATAL ERROR--THE 3RD INPUT ARGUMENT TO THE ', 1' NCBPPF SUBROUTINE IS NON-POSITIVE *****') 35 FORMAT('***** FATAL ERROR--THE FOURTH INPUT ARGUMENT TO THE ', 1' NCBPPF SUBROUTINE IS NEGATIVE *****') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') C 90 CONTINUE C A = ALPHA B = BETA C IERR=0 IC = 0 AB = A/B XL = 0.0 XR = 1.0 FXL = -P FXR = 1.0 - P CCCCC INVALID P EXPLICITLY CHECKED FOR EARLIER. IF(FXL*FXR .GT. ZERO)GOTO50 C C BISECTION METHOD C 105 CONTINUE X = (XL+XR)*0.5 CALL NCBCDF(X,ALPHA,BETA,LAMBDA,CDF) P1=CDF PPF=X FCS = P1 - P IF(FCS*FXL.GT.ZERO)GOTO110 XR = X FXR = FCS GOTO115 110 CONTINUE XL = X FXL = FCS 115 CONTINUE XRML = XR - XL IF(XRML.LE.SIG .AND. ABS(FCS).LE.EPS)GOTO9999 IC = IC + 1 IF(IC.LE.MAXIT)GOTO105 WRITE(ICOUT,130) CALL DPWRST('XXX','BUG ') 130 FORMAT('***** FATAL ERROR--NCBPPF ROUTINE DID NOT CONVERGE. ***') GOTO9999 C 9999 CONTINUE RETURN END SUBROUTINE NCBRAN(N,ALPHA,BETA,ALAMB,ISEED,X) C C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N C FROM THE NON-CENTRAL BETA DISTRIBUTION WITH SHAPE C PARAMETERS ALPHA AND BETA AND NON-CENTRALITY C PARAMETER LAMBDA. C INPUT ARGUMENTS--N = THE DESIRED INTEGER NUMBER C OF RANDOM NUMBERS TO BE C GENERATED. C --ALPHA = THE SINGLE PRECISION VALUE OF THE C FIRST SHAPE PARAMETER. C --BETA = THE SINGLE PRECISION VALUE OF THE C SECOND SHAPE PARAMETER. C --ALAMB = THE SINGLE PRECISION VALUE OF THE C NON-CENTRALITY PARAMETER. C OUTPUT ARGUMENTS--X = A SINGLE PRECISION VECTOR C (OF DIMENSION AT LEAST N) C INTO WHICH THE GENERATED C RANDOM SAMPLE WILL BE PLACED. C OUTPUT--A RANDOM SAMPLE OF SIZE N C FROM THE NON-CENTRAL BETA DISTRIBUTION C WITH SHAPE PARAMETER VALUES = ALPHA, BETA, AND ALAMB. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C --ALPHA AND BETA SHOULD BE POSITIVE. C --ALAMB SHOULD BE NON-NEGATIVE. C OTHER DATAPAC SUBROUTINES NEEDED--NCCRAN, CHSRAN. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS C UNIVARIATE DISTRIBUTIONS VOLUME 2", SECOND EDITION, C 1994, PAGES 502-503. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2004.5 C ORIGINAL VERSION--MAY 2004. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DIMENSION X(*) DIMENSION XTEMP(1) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----DATA STATEMENTS------------------------------------------------- C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(N.LT.1)THEN WRITE(ICOUT, 5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)N CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF 5 FORMAT('***** ERROR--THE REQUESTED NUMBER OF NON-CENTRAL BETA ', 1' RANDOM NUMBERS IS NON-POSITIVE.') IF(ALPHA.LE.0.0)THEN WRITE(ICOUT,16) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)ALPHA CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF 16 FORMAT('***** ERROR--THE SHAPE PARAMETER ALPHA FOR THE ', 1'NON-CENTRAL BETA RANDOM NUMBERS IS NON-POSITIVE.') IF(BETA.LE.0.0)THEN WRITE(ICOUT,26) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)BETA CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF 26 FORMAT('***** ERROR--THE SHAPE PARAMETER BETA FOR THE ', 1'NON-CENTRAL BETA RANDOM NUMBERS IS NON-POSITIVE.') IF(ALAMB.LT.0.0)THEN WRITE(ICOUT,36) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)ALAMB CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF 36 FORMAT('***** ERROR--THE NON-CENTRALITY PARAMETER LAMBDA FOR ', 1'THE NON-CENTRAL BETA RANDOM NUMBERS IS NEGATIVE.') C 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8) 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8) C C USE THE CENTRAL AND NON-CENTRAL CHI-SQUARE RANDOM NUMBER C ROUTINE TO GENERATE NON-CENTRAL BETA RANDOM NUMBERS. C C NCB = NCCHISQ(NU1,LAMBDA)/(NCCHISQ(NU1,LAMBDA)+CHISQUARE(NU2)) C ANU1=ALPHA ANU2=BETA NTEMP=1 DO100I=1,N CALL NCCRAN(NTEMP,ANU1,ALAMB,ISEED,XTEMP) TERM1=XTEMP(1) CALL CHSRAN(NTEMP,ANU2,ISEED,XTEMP) TERM2=XTEMP(1) X(I)=TERM1/(TERM1+TERM2) 100 CONTINUE C 9000 CONTINUE RETURN END SUBROUTINE NCVSRT( N, LOWER, UPPER, CORREL, INFIN, Y, INFIS, & A, B, INFI, COV, D, E ) * * Subroutine to sort integration limits. * INTEGER N, INFI(*), INFIN(*), INFIS DOUBLE PRECISION & A(*), B(*), COV(*), LOWER(*), UPPER(*), CORREL(*), Y(*), D, E INTEGER I, J, K, IJ, II, JMIN DOUBLE PRECISION SUMSQ, ZERO PARAMETER ( ZERO = 0 ) DOUBLE PRECISION AJ, BJ, SUM, SQTWPI DOUBLE PRECISION CVDIAG, AMIN, BMIN, DMIN, EMIN, YL, YU PARAMETER ( SQTWPI = 2.50662 82746 31000 50240 ) IJ = 0 II = 0 INFIS = 0 DO 100 I = 1,N INFI(I) = INFIN(I) IF ( INFI(I) .LT. 0 ) THEN INFIS = INFIS + 1 ELSE A(I) = 0 B(I) = 0 IF ( INFI(I) .NE. 0 ) A(I) = LOWER(I) IF ( INFI(I) .NE. 1 ) B(I) = UPPER(I) ENDIF DO 200 J = 1,I-1 IJ = IJ + 1 II = II + 1 COV(IJ) = CORREL(II) 200 CONTINUE IJ = IJ + 1 COV(IJ) = 1 100 CONTINUE * * First move any doubly infinite limits to innermost positions * IF ( INFIS .LT. N ) THEN DO 300 I = N,N-INFIS+1,-1 IF ( INFI(I) .GE. 0 ) THEN DO 400 J = 1,I-1 IF ( INFI(J) .LT. 0 ) THEN CALL RCSWAP(J, I, A, B, INFI, N, COV) GO TO 300 ENDIF 400 CONTINUE ENDIF 300 CONTINUE * * Sort remaining limits and determine Cholesky decomposition * II = 0 DO 500 I = 1,N-INFIS * * Determine the integration limits for variable with minimum * expected probability and interchange that variable with Ith. * EMIN = 1 DMIN = 0 JMIN = I CVDIAG = 0 IJ = II DO 600 J = I, N-INFIS SUM = 0 SUMSQ = 0 DO 700 K = 1, I-1 SUM = SUM + COV(IJ+K)*Y(K) SUMSQ = SUMSQ + COV(IJ+K)**2 700 CONTINUE IJ = IJ + J SUMSQ = SQRT( MAX( COV(IJ)-SUMSQ, ZERO ) ) IF ( SUMSQ .GT. 0 ) THEN IF ( INFI(J) .NE. 0 ) AJ = ( A(J) - SUM )/SUMSQ IF ( INFI(J) .NE. 1 ) BJ = ( B(J) - SUM )/SUMSQ CALL LIMITS( AJ, BJ, INFI(J), D, E ) IF ( EMIN - DMIN .GE. E - D ) THEN JMIN = J IF ( INFI(J) .NE. 0 ) AMIN = AJ IF ( INFI(J) .NE. 1 ) BMIN = BJ DMIN = D EMIN = E CVDIAG = SUMSQ ENDIF ENDIF 600 CONTINUE IF ( JMIN .NE. I) CALL RCSWAP(I, JMIN, A, B, INFI, N, COV) * * Compute Ith column of Cholesky factor. * IJ = II + I COV(IJ) = CVDIAG DO 800 J = I+1, N-INFIS IF ( CVDIAG .GT. 0 ) THEN SUM = COV(IJ+I) DO 900 K = 1, I-1 SUM = SUM - COV(II+K)*COV(IJ+K) 900 CONTINUE COV(IJ+I) = SUM/CVDIAG ELSE COV(IJ+I) = 0 ENDIF IJ = IJ + J 800 CONTINUE * * Compute expected value for Ith integration variable and * scale Ith covariance matrix row and limits. * IF ( CVDIAG .GT. 0 ) THEN IF ( EMIN .GT. DMIN + 1D-8 ) THEN YL = 0 YU = 0 IF ( INFI(I) .NE. 0 ) YL = -EXP( -AMIN**2/2 )/SQTWPI IF ( INFI(I) .NE. 1 ) YU = -EXP( -BMIN**2/2 )/SQTWPI Y(I) = ( YU - YL )/( EMIN - DMIN ) ELSE IF ( INFI(I) .EQ. 0 ) Y(I) = BMIN IF ( INFI(I) .EQ. 1 ) Y(I) = AMIN IF ( INFI(I) .EQ. 2 ) Y(I) = ( AMIN + BMIN )/2 END IF DO 910 J = 1,I II = II + 1 COV(II) = COV(II)/CVDIAG 910 CONTINUE IF ( INFI(I) .NE. 0 ) A(I) = A(I)/CVDIAG IF ( INFI(I) .NE. 1 ) B(I) = B(I)/CVDIAG ELSE Y(I) = 0 II = II + I ENDIF 500 CONTINUE CALL LIMITS( A(1), B(1), INFI(1), D, E) ENDIF C RETURN END SUBROUTINE NCCCDF(X, DF, FL, CDF) C UKC NETLIB DISTRIBUTION COPYRIGHT 1990 RSS C C C<<<<< Acquired in machine-readable form from 'Applied Statistics' C<<<<< algorithms editor, January 1983. C C C ALGORITHM AS 170 APPL. STATIST. (1981) VOL.30, NO.3 C C The non-central chi-squared distribution. C C Auxiliary routines required: GAMMDS = AS147, ALOGAM = CACM 291. C See AS245 for an alternative to ALOGAM. C C C--------------------------------------------------------------------- C DOUBLE PRECISION DGAMIP DOUBLE PRECISION DARG1 C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C TEST FOR ADMISSIBILITY OF ARGUMENTS C IF (DF.LE.0.0) THEN WRITE(ICOUT,101) CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF IF(X.LT.0.0)THEN WRITE(ICOUT,301) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,302)X CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF IF (FL.LT.0.0)THEN WRITE(ICOUT,401) CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF 101 FORMAT('***** ERROR--THE DEGREES OF FREEDOM PARAMETER FOR NCCCDF ' 1 ,'IS NON-POSITIVE. ****') 301 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO NCCCDF IS ') 302 FORMAT(' NON-POSITIVE. IT HAS THE VALUE ',E15.7) 401 FORMAT('***** ERROR--THE NON-CENTRALITY PARAMETER TO NCCCDF ', 1 'IS NEGATIVE. ****') C C CDF = 0.0 IF(X.EQ.0.0)GOTO9999 DF2 = 0.5*DF X2 = 0.5*X CCCCC FXP = GAMMDS(X2,DF2,IFAULT) DARG1=DGAMIP(DBLE(DF2),DBLE(X2)) FXP=REAL(DARG1) CALL NCCCHI(X2,DF2,FL,FXP,CDF) C 9999 CONTINUE RETURN END SUBROUTINE NCCCHI(X, DF, FL, FXC, CHI) C C ALGORITHM AS 170.2 APPL. STATIST. (1981) VOL.30, NO.3 C C (ROUTINE USED BY NCCCDF AND NCCNCP) PARAMETER (ACC2 = 1.0E-8) DOUBLE PRECISION DGAMIP DOUBLE PRECISION DARG1 C CHI = FXC DF1 = DF FL2 = 0.5*FL C = 1.0 T = 0.0 1 CONTINUE T = T+1.0 C = C*FL2/T DF1 = DF1+1.0 CCCCC TERM = C*GAMMDS(X, DF1, IFAULT) DARG1=DGAMIP(DBLE(DF1),DBLE(X)) TERM = C*REAL(DARG1) CHI = CHI+TERM IF (TERM.GE.ACC2) GO TO 1 CHI = CHI*EXP(-FL2) C RETURN END SUBROUTINE NCCPDF(X, V, FL, PDF) C UKC NETLIB DISTRIBUTION COPYRIGHT 1990 RSS C C C The non-central chi-squared probability density function. C USE THE FOLLOWING FORMULA ON PAGE 436 OF 2ND ED OF C VOL. 2 OF JOHNSON AND KOTZ. C F(X)=EXP(-(L+X)/2)*(1/2)*(X/V)**((V-2)/4)*I((V-2)/2)(SQRT(L*X)) C WHERE I IS THE MODIFIED BESSEL FUNCTION. C C--------------------------------------------------------------------- C INCLUDE 'DPCOMC.INC' C DOUBLE PRECISION DX, DL, DV, DPDF DOUBLE PRECISION DPI DOUBLE PRECISION DTERM1, DTERM2, DTERM3, DTERM4, DTERM5 DOUBLE PRECISION DLNGAM C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C DATA DPI / 3.1415926535 8979323846 2643383279 503 D0 / C C TEST FOR ADMISSIBILITY OF ARGUMENTS C IF(X.LE.0.0)THEN WRITE(ICOUT,301) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF IF (V.LE.0.0) THEN WRITE(ICOUT,101) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)V CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF IF (FL.LT.0.0)THEN WRITE(ICOUT,401) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)FL CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF 101 FORMAT('***** ERROR IN NCCPDF--THE SECOND INPUT ARGUMENT ', 1'IS NON-POSITIVE') 301 FORMAT('***** ERROR IN NCCPDF--THE FIRST INPUT ARGUMENT ', 1'IS NON-POSITIVE') 401 FORMAT('***** ERROR IN NCCPDF--THE THIRD INPUT ARGUMENT ', 1'IS NON-POSITIVE') 46 FORMAT(' THE ARGUMENT HAS THE VALUE ',E15.6) C C PDF = 0.0 DX=DBLE(X) DL=DBLE(FL) DV=DBLE(V) C IF(FL.EQ.0.0)THEN DTERM1=((DV-2.0D0)/2.0D0)*DLOG(DX) DTERM2=-DX/2.0D0 DTERM3=(DV/2.0D0)*DLOG(2.0D0) DTERM4=DLNGAM(DV/2.0D0) DPDF=DEXP(DTERM1+DTERM2-DTERM3-DTERM4) PDF=REAL(DPDF) GOTO9999 ENDIF C IF(DV.LT.2.0D0)GOTO1000 C DTERM1=DSQRT(DL*DX) IF(DTERM1.LE.DLOG(D1MACH(2)))THEN DTERM2=-(DL+DX)/2.0D0+DLOG(0.5D0)+ 1 ((DV-2.0D0)/4.0D0)*DLOG(DX/DL) IARG1=1 ISCALE=1 DTERM5=(DV-2.0D0)/2.0D0 CALL DBESI(DTERM1,DTERM5,ISCALE,IARG1,DTERM3,NZERO) DTERM3=DLOG(DTERM3) DTERM4=DTERM2+DTERM3 IF(DTERM4.LE.-80.D0)THEN PDF=0.0 ELSEIF(DTERM4.GE.80.D0)THEN WRITE(ICOUT,601) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)X CALL DPWRST('XXX','BUG ') PDF=ALOG(R1MACH(2)) ELSE DPDF=DEXP(DTERM4) PDF=SNGL(DPDF) ENDIF ELSE WRITE(ICOUT,501) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)X CALL DPWRST('XXX','BUG ') ENDIF GOTO9999 601 FORMAT('***** ERROR IN NCCPDF--OVERFLOW IN CALCULATION OF PDF' , 1' VALUE, PDF SET TO LOG OF LARGEST NUMBER.') 501 FORMAT('***** ERROR IN NCCPDF--ARGUMENT TO LARGE FOR DBESI ', 1'ROUTINE, PDF SET TO 0') 47 FORMAT(' THE ARGUMENT HAS THE VALUE ',E15.6) C C CASE FOR V < 2 REQUIRE NEGATIVE ORDER OF MODIFIED BESSEL FUNCTION. C USE I(-v) = I(v) + (2/PI)*SIN(V*PI)*K(v) C 1000 CONTINUE DTERM1=DSQRT(DL*DX) IF(DTERM1.LE.DLOG(D1MACH(2)))THEN DTERM2=-(DL+DX)/2.0D0+DLOG(0.5D0)+ 1 ((DV-2.0D0)/4.0D0)*DLOG(DX/DL) IARG1=1 ISCALE=1 DTERM5=(DV-2.0D0)/2.0D0 CALL DBESI(DTERM1,DABS(DTERM5),ISCALE,IARG1,DTERM3,NZERO) CALL BESK(SNGL(DTERM1),SNGL(DABS(DTERM5)),ISCALE,IARG1,TERM3, 1 NZERO) DTERM3=DTERM3+(2.0D0/DPI)*DSIN(DABS(DTERM5)*DPI)*DBLE(TERM3) DTERM3=DLOG(DTERM3) DTERM4=DTERM2+DTERM3 IF(DTERM4.LE.-80.D0)THEN PDF=0.0 ELSEIF(DTERM4.GE.80.D0)THEN WRITE(ICOUT,601) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)X CALL DPWRST('XXX','BUG ') PDF=ALOG(R1MACH(2)) ELSE DPDF=DEXP(DTERM4) PDF=SNGL(DPDF) ENDIF ELSE WRITE(ICOUT,501) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)X CALL DPWRST('XXX','BUG ') ENDIF GOTO9999 9999 CONTINUE RETURN END SUBROUTINE NCCNCP(X, DF, FX, FL) C C ALGORITHM AS 170.1 APPL.STATIST. (1981) VOL.30, NO.3 C C DEFINE ACCURACY AND INITIALIZE C C N SHOULD BE SPECIFIED SUCH THAT ACC IS GREATER THAN C OR EQUAL TO (AU-AL)/2**N C PARAMETER (ACC = 1.0E-6, N = 30) C C--------------------------------------------------------------------- C DOUBLE PRECISION DGAMIP DOUBLE PRECISION DARG1 C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C AL = 0.0 AINC = 80.0 AU = 80.0 C C TEST FOR ADMISSIBILITY OF ARGUMENTS C IF (DF.LE.0.0) THEN WRITE(ICOUT,101) CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF IF(X.LT.0.0)THEN WRITE(ICOUT,301) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,302)X CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF IF (FX.LE.0.0)THEN WRITE(ICOUT,401) CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF 101 FORMAT('***** FATAL DIAGNOSTIC--THE DEGREES OF FREEDOM PARAMETER', 1 ' IS NON-POSITIVE. ****') 301 FORMAT('***** FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT IS ') 302 FORMAT(' NON-POSITIVE. IT HAS THE VALUE ',E15.7) 401 FORMAT('***** FATAL DIAGNOSTIC--THE CDF PARAMETER IS NEGATIVE.') C DF2 = 0.5*DF X2 = 0.5*X CCCCC FX1 = GAMMDS(X2,DF2,IFAULT) DARG1=DGAMIP(DBLE(DF2),DBLE(X2)) FX1 = REAL(DARG1) 1 CONTINUE CCCC1 APROX = CHI(X2,DF2,AU,FX1) CALL NCCCHI (X2,DF2,AU,FX1,APROX) IF (FX.GT.APROX) GOTO 2 IF (FX.LT.APROX) AL = AU AU = AU+AINC GO TO 1 C 2 CONTINUE DO 3 J = 1,N FL = 0.5*(AL+AU) CCCCC APROX = CHI(X2, DF2, FL, FX1) CALL NCCCHI (X2,DF2,FL,FX1,APROX) IF (ABS(FX-APROX).LT.ACC) GO TO 9999 IF (FX.LT.APROX) AL = FL IF (FX.GE.APROX) AU = FL 3 CONTINUE C 9999 CONTINUE RETURN END SUBROUTINE NCCPPF(P,NU,DELTA,PPF) C C PURPOSE --PERCENT POINT FUNCTION FOR THE NON-CENTRAL CHI-SQUARE C DISTRIBUTION. USES A BISECTION METHOD. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--94/9 C ORIGINAL VERSION--SEPTEMBER 1994. C UPDATE --MAY 2004. SOME UPDATES TO SPEED C CONVERGENCE C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C REAL NU DOUBLE PRECISION DGAMIP DOUBLE PRECISION DARG1 C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C CCCCC DATA EPS /0.0001/ CCCCC DATA SIG /1.0E-5/ DATA ZERO /0./ DATA MAXIT /500/ C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(P.LT.0.0.OR.P.GE.1.0)GOTO50 IF(NU.LE.0.0)GOTO55 IF(DELTA.LT.0.0)GOTO70 GOTO90 50 WRITE(ICOUT,1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)P CALL DPWRST('XXX','BUG ') PPF=0.0 RETURN 55 WRITE(ICOUT,11) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)NU CALL DPWRST('XXX','BUG ') PPF=0.0 RETURN 70 WRITE(ICOUT,35) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)DELTA CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9999 C 1 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO THE ', 1' NCCPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL.') 11 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO THE ', 1' NCCPPF SUBROUTINE IS NON-POSITIVE.') 35 FORMAT('***** FATAL ERROR--THE THIRD INPUT ARGUMENT TO THE ', 1' NCCPPF SUBROUTINE IS NEGATIVE *****') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I15,' *****') C 90 CONTINUE C C SPECIAL CASE. FOR INTEGER NU AND DELTA = 0, USE CENTRAL CHI-SQUARE C ROUTINE. C IF(DELTA.EQ.0.0)THEN NUINT=INT(NU+0.1) ANUINT=REAL(NUINT) IF(ABS(NU-ANUINT).LE.0.00001 .AND. NUINT.GE.1)THEN CALL CHSPPF(P,NUINT,PPF) GOTO9999 ENDIF ENDIF C C FIND BRACKETING INTERVAL. USE CORRESPONDING CENTRAL CHI-SQUARE C AS INITIAL GUESS, INCREMENTS OF 1 STANDARD DEVIATION AROUND IT C (SD = SQRT(2*(NU+2*DELTA)) C AFTER SUCCESSFULLY FIND BRACKETING INTERVAL, THEN SWITCH TO C MORE EFFICIENT BISECTION METHOD. C C 5/2004. BETTER BRACKETING INTERVAL. BASE ON MEAN, SD, AND VALUE OF P. C ALSO, FOR LOW VALUES OF NU AND MORE EXTREME VALUES OF P, C LOOSEN THE CONVERGENCE CRITIERION. LEFT INVERVAL IS 0 (OR C 0 + EPS) C EPS=0.0001 SIG=1.0E-5 CCCCC IF(NU.GE.20.0)THEN CCCCC EPS=0.0001 CCCCC SIG=1.0E-5 CCCCC IF(P.GT.0.95 .OR. P.LT.0.05)THEN CCCCC EPS=0.0001 CCCCC SIG=1.0E-4 CCCCC ENDIF CCCCC ELSE CCCCC IF(P.GT.0.99 .OR. P.LT.0.01)THEN CCCCC EPS=0.0001 CCCCC SIG=1.0E-5 CCCCC ENDIF CCCCC ENDIF C CCCCC NUINT=NU+0.5 CCCCC CALL CHSPPF(P,NUINT,XL) AMEAN=NU+DELTA SD=SQRT(2.0*(NU+2.0*DELTA)) XINC=SD C XL=0.0 IF(P.LE.0.25)THEN XL=0.0 ELSEIF(P.GT.0.25 .AND. P.LE.0.75)THEN XL=AMEAN ELSEIF(P.GT.0.75 .AND. P.LE.0.95)THEN XL=AMEAN+SD ELSE XL=AMEAN+2.0*SD ENDIF C ICOUNT=0 MAXCNT=100 C 91 CONTINUE XR=XL+XINC IF(XL.LE.0.0)XL=0.0 IF(XR.LE.0.0)XR=XL+XINC C DF2 = 0.5*NU FL=DELTA IF(XL.LE.0.0000001)THEN CDFL=0.0 ELSE X2 = 0.5*XL DARG1=DGAMIP(DBLE(DF2),DBLE(X2)) FXP=REAL(DARG1) CALL NCCCHI(X2,DF2,FL,FXP,CDFL) ENDIF X2 = 0.5*XR DARG1=DGAMIP(DBLE(DF2),DBLE(X2)) FXP=REAL(DARG1) CALL NCCCHI(X2,DF2,FL,FXP,CDFR) C CCCCC CALL NCCCDF(XL,NU,DELTA,CDFL) CCCCC CALL NCCCDF(XR,NU,DELTA,CDFR) IF(CDFL.LT.P .AND. CDFR.LT.P)THEN XL=XR ELSEIF(CDFL.GT.P .AND. CDFR.GT.P)THEN XL=XL-XINC ELSE GOTO99 ENDIF ICOUNT=ICOUNT+1 IF(ICOUNT.GT.MAXCNT)THEN WRITE(ICOUT,96) CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9999 ENDIF 96 FORMAT('***** FATAL ERROR--NCCPPF UNABLE TO FIND BRACKETING ', * 'INTERVAL. *****') GOTO91 C C BISECTION METHOD C 99 CONTINUE IC = 0 FXL = -P FXR = 1.0 - P 105 CONTINUE X = (XL+XR)*0.5 C IF(X.LE.0.0000001)THEN CDF=0.0 ELSE X2 = 0.5*X DARG1=DGAMIP(DBLE(DF2),DBLE(X2)) FXP=REAL(DARG1) CALL NCCCHI(X2,DF2,FL,FXP,CDF) ENDIF CCCCC CALL NCCCDF(X,NU,DELTA,CDF) P1=CDF PPF=X FCS = P1 - P IF(FCS*FXL.GT.ZERO)GOTO110 XR = X FXR = FCS GOTO115 110 CONTINUE XL = X FXL = FCS 115 CONTINUE XRML = XR - XL IF(XRML.LE.SIG .AND. ABS(FCS).LE.EPS)GOTO9999 IC = IC + 1 IF(IC.LE.MAXIT)GOTO105 WRITE(ICOUT,130) CALL DPWRST('XXX','BUG ') 130 FORMAT('***** ERROR--NCCPPF ROUTINE DID NOT CONVERGE. ***') GOTO9999 C 9999 CONTINUE RETURN END SUBROUTINE NCCRAN(N,ANU,ALAMB,ISEED,X) C C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N C FROM THE NON-CENTRAL CHI-SQUARED DISTRIBUTION C WITH DEGREES OF FREEDOM PARAMETER NU AND C NON-CENTRALITY PARAMETER LAMBDA. C INPUT ARGUMENTS--N = THE DESIRED INTEGER NUMBER C OF RANDOM NUMBERS TO BE C GENERATED. C --ANU = THE DEGREES OF FREEDOM PARAMETER C --ALAMB = THE NON-CENTRALITY PARAMETER C OUTPUT ARGUMENTS--X = A SINGLE PRECISION VECTOR C (OF DIMENSION AT LEAST N) C INTO WHICH THE GENERATED C RANDOM SAMPLE WILL BE PLACED. C OUTPUT--A RANDOM SAMPLE OF SIZE N C FROM THE NON-CENTRAL CHI-SQUARED DISTRIBUTION C WITH SHAPE PARAMETERS NU AND LANBDA. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C --ANU SHOULD BE POSITIVE. C --ALAMB SHOULD BE NON-NEGATIVE. C OTHER DATAPAC SUBROUTINES NEEDED--NORRAN, GAMRAN. C FORTRAN LIBRARY SUBROUTINES NEEDED--SQRT. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2004/5 C ORIGINAL VERSION--MAY 2004. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DIMENSION X(*) DIMENSION XTEMP(1) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(N.LT.1)THEN WRITE(ICOUT,5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)N CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF 5 FORMAT('***** ERROR--THE REQUESTED NUMBER OF NON-CENTRAL ', 1 'CHI-SQUARE RANDOM NUMBERS IS NON-POSITIVE.') IF(ANU.LE.0.0)THEN WRITE(ICOUT,15) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,48)ANU CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF 15 FORMAT('***** ERROR--THE DEGREES OF FREEDOM PARAMETER FOR ', 1'NON-CENTRAL CHI-SQUARE RANDOM NUMBERS IS NON-POSITIVE.') IF(ALAMB.LT.0.0)THEN WRITE(ICOUT,25) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,48)ALAMB CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF 25 FORMAT('***** ERROR--THE NON-CENTRALITY PARAMETER FOR ', 1'NON-CENTRAL CHI-SQUARE RANDOM NUMBERS IS NON-POSITIVE.') 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8) 48 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7) C IF(ALAMB.EQ.0.0)THEN CALL CHSRAN(N,ANU,ISEED,X) ELSE IF(ANU.LE.1.0)THEN CALL UNIRAN(N,ISEED,X) DO1367II=1,N ATEMP=X(II) CALL NCCPPF(ATEMP,ANU,ALAMB,PPF) X(II)=PPF 1367 CONTINUE ELSE CCCCC NOTE: 5/2004. USING PERCENT POINT METHOD SEEMS TO CCCCC GENERATE BETTER RANDOM NUMBERS THAN THE SUM OF CCCCC NORMALS METHOD. IT IS SLOWER, BUT IT SEEMS TO CCCCC BE MORE ACCURATE. ALSO, IT CAN HANDLE NON-INTEGER CCCCC VALUES OF NU. C CALL UNIRAN(N,ISEED,X) DO1369II=1,N ATEMP=X(II) CALL NCCPPF(ATEMP,ANU,ALAMB,PPF) X(II)=PPF 1369 CONTINUE CCCCC NUINT=INT(NU+0.5) CCCCC IF(NUINT.LT.1)NUINT=1 CCCCC NTEMP=1 CCCCC DO1365II=1,N CCCCC ASUM=0.0 CCCCC DO1366J=1,NUINT CCCCC CALL NORRAN(NTEMP,ISEED,XTEMP) CCCCC ASUM=ASUM + (XTEMP(1) + (ALAMB/REAL(NUINT)))**2 C1365 CONTINUE CCCCC X(II)=ASUM C1365 CONTINUE ENDIF ENDIF C 9000 CONTINUE RETURN END SUBROUTINE NCFCDF(X,NU1,NU2,LAMBDA,CDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION C FUNCTION VALUE FOR THE NON-CENTRAL F DISTRIBUTION C WITH INTEGER DEGREES OF FREEDOM C PARAMETERS = NU1 AND NU2. C THIS DISTRIBUTION IS DEFINED FOR ALL NON-NEGATIVE X. C THE PROBABILITY DENSITY FUNCTION IS GIVEN C IN THE REFERENCES BELOW. C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE AT C WHICH THE CUMULATIVE DISTRIBUTION C FUNCTION IS TO BE EVALUATED. C X SHOULD BE NON-NEGATIVE. C --NU1 = THE INTEGER DEGREES OF FREEDOM C FOR THE NUMERATOR OF THE F RATIO. C NU1 SHOULD BE POSITIVE. C --NU2 = THE INTEGER DEGREES OF FREEDOM C FOR THE DENOMINATOR OF THE F RATIO. C NU2 SHOULD BE POSITIVE. C --LAMBDA NON-NEGATIVE NON-CENTRALITY PARAMETER. C OUTPUT ARGUMENTS--CDF = THE SINGLE PRECISION CUMULATIVE C DISTRIBUTION FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION C FUNCTION VALUE CDF FOR THE NON-CENTRAL F DISTRIBUTION C WITH DEGREES OF FREEDOM PARAMETERS = NU1 AND NU2. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--X SHOULD BE NON-NEGATIVE. C --NU1 SHOULD BE A POSITIVE INTEGER VARIABLE. C --NU2 SHOULD BE A POSITIVE INTEGER VARIABLE. C --LAMBDA SHOULD BE GREATER THAN OR EQUAL TO 0. C OTHER SUBROUTINES NEEDED--NCBCDF,CHSCDF. C FORTRAN LIBRARY SUBROUTINES NEEDED--DSQRT, DATAN. C LANGUAGE--ANSI FORTRAN (1977) C ALGORITHM --USES THE NON-CENTRAL BETA DISTRIBUTION. C REFERENCES--"COMPUTING NON-CENTRAL BETA PROBABILITIES" C RUSSELL LENTH, ALGORITHM AS 226 FROM APPLIED C STATISTICS JOURNAL. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--94/9 C ORIGINAL VERSION--SEPTEMBER 1994. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C REAL NU1 REAL NU2 REAL LAMBDA CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(NU1.LE.0.0)GOTO50 IF(NU2.LE.0.0)GOTO55 IF(X.LT.0.0)GOTO60 IF(LAMBDA.LT.0.0)GOTO70 GOTO90 50 WRITE(ICOUT,15) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)NU1 CALL DPWRST('XXX','BUG ') CDF=0.0 RETURN 55 WRITE(ICOUT,23) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)NU2 CALL DPWRST('XXX','BUG ') CDF=0.0 RETURN 60 WRITE(ICOUT,4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') CDF=0.0 RETURN 70 WRITE(ICOUT,24) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)LAMBDA CALL DPWRST('XXX','BUG ') CDF=0.0 RETURN 4 FORMAT('***** NON-FATAL DIAGNOSTIC--THE 1ST INPUT ARGUMENT ', 1'TO THE NCFCDF SUBROUTINE IS NEGATIVE *****') 15 FORMAT('***** FATAL ERROR--THE 2ND INPUT ARGUMENT TO THE ', 1'NCFCDF SUBROUTINE IS NON-POSITIVE *****') 23 FORMAT('***** FATAL ERROR--THE 3RD INPUT ARGUMENT TO THE ', 1'NCFCDF SUBROUTINE IS NON-POSITIVE *****') 24 FORMAT('***** FATAL ERROR--THE FOURTH INPUT ARGUMENT TO THE ', 1'NCFCDF SUBROUTINE IS NEGATIVE *****') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****') C 90 CONTINUE C TERM1=NU1*0.5 TERM2=NU2*0.5 TERM3=NU1*X/(NU1*X+NU2) CALL NCBCDF(TERM3,TERM1,TERM2,LAMBDA,CDF) C 9999 CONTINUE RETURN END REAL FUNCTION NCFFU3(X) C C PURPOSE--NCFPDF CALLS DIFF TO FIND A NUMERICAL DERIVATIVE C FOR THE NON-CENTRAL CUMULATIVE DISTRIBUTION FUNCTION. C NCFFU3 IS A FUNCTION THAT CALL NCFCDF. C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE AT C WHICH THE DERIVATIVE C IS TO BE EVALUATED. C OUTPUT--THE SINGLE PRECISION FUNCTION VALUE NCFFU3. C PRINTING--NONE. C RESTRICTIONS--NONE. C OTHER DATAPAC SUBROUTINES NEEDED--NCBCDF. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2004.5 C ORIGINAL VERSION--MAY 2004. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C REAL ANU1 REAL ANU2 REAL ALAMB COMMON/NCFCOM/ANU1,ANU2,ALAMB C C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C NOTE: NCFCDF CALLS NCBCDF. PERFORM THE NEEDED PARAMETER TRANSLATION C AND CALL NCBCDF (I.E., SAVE A SUBROUTINE CALL). C CCCCC CALL NCFCDF(X,ANU1,ANU2,,ALAMB,CDF) TERM1=ANU1*0.5 TERM2=ANU2*0.5 TERM3=ANU1*X/(ANU1*X+ANU2) CALL NCBCDF(TERM3,TERM1,TERM2,ALAMB,CDF) NCFFU3=CDF C 9999 CONTINUE RETURN END SUBROUTINE NCFPDF(X,NU1,NU2,LAMBDA,PDF) C C PURPOSE--PROBABILITY DENSITY FUNCTION FOR THE NON-CENTRAL C T DISTRIBUTION. THE PROBABILITY DENSITY FUNCTION C IS COMPUTED BY COMPUTING THE NUMERICAL DERIVATIVE OF C THE CUMULATIVE DISTRIBUTION FUNCTION. C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE AT C WHICH THE PROBABILITY DENSITY C FUNCTION IS TO BE EVALUATED. C --ANU = THE DEGREES OF FREEDOM SHAPE PARAMETER C --DELTA = THE FIRST NON-CENTRALITY SHAPE PARAMETER C --LAMBDA = THE SECOND NON-CENTRALITY PARAMETER C OUTPUT ARGUMENTS--PDF = THE SINGLE PRECISION PROBABILITY C DENSITY FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY FUNCTION VALUE PDF. C PRINTING--NONE. C RESTRICTIONS--NONE. C OTHER DATAPAC SUBROUTINES NEEDED--DIFF. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2004/5 C ORIGINAL VERSION--MAY 2004. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C REAL X REAL NU1 REAL NU2 REAL LAMBDA REAL PDF C REAL NCFFU3 EXTERNAL NCFFU3 REAL ANU1 REAL ANU2 REAL ALAMB COMMON/NCFCOM/ANU1,ANU2,ALAMB C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C PDF=0.0 C IF(NU1.LE.0.0)THEN WRITE(ICOUT,101) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,102)NU1 CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF 101 FORMAT('**** ERROR--THE FIRST DEGREES OF FREEDOM PARAMETER') 102 FORMAT(' FOR NCFPDF IS NON-POSITIVE. IT HAS THE VALUE ', 1 E15.7) C IF(NU2.LE.0.0)THEN WRITE(ICOUT,103) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,104)NU2 CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF 103 FORMAT('**** ERROR--THE SECOND DEGREES OF FREEDOM PARAMETER') 104 FORMAT(' FOR NCFPDF IS NON-POSITIVE. IT HAS THE VALUE ', 1 E15.7) C IF(ALAMB.LT.0.0)THEN WRITE(ICOUT,303) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,304)ALAMB CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF 303 FORMAT('**** ERROR--THE NON-CENTRALITY PARAMETER IS NEGATIVE.') 304 FORMAT(' IT HAS THE VALUE ',E15.7) C C FIND NUMERIC DERIVATIVE OF CDF ROUTINE C IORD=1 EPS=0.0001 ACCUR=0.0 IFAIL=0 X0 = X XMIN=MAX(X0 - 50.0,0.0) XMAX=X0 + 50.0 ANU1=NU1 ANU2=NU2 ALAMB=LAMBDA C CALL DIFF(IORD,X0,XMIN,XMAX,NCFFU3,EPS,ACCUR,PDF,ERROR,IFAIL) C IF(IFAIL.EQ.1)THEN 999 FORMAT(1X) WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,401) 401 FORMAT('***** WARNING IN NUMERICAL DERIVATIVE FOR NCFPDF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,403) 403 FORMAT(' THE ESTIMATED ERROR IN THE RESULT EXCEEDS THE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,405) 405 FORMAT(' REQUESTED ERROR, BUT THE MOST ACCURATE RESULT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,407) 407 FORMAT(' POSSIBLE HAS BEEN RETURNED.') CALL DPWRST('XXX','BUG ') ELSEIF(IFAIL.EQ.2)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,411) 411 FORMAT('***** ERROR IN NUMERICAL DERIVATIVE FOR NCFPDF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,413) 413 FORMAT(' ERROR IN THE INPUT TO THE DIFF ROUTINE.') CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ELSEIF(IFAIL.EQ.3)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,421) 421 FORMAT('***** ERROR IN NUMERICAL DERIVATIVE FOR NCFPDF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,423) 423 FORMAT(' THE INTERVAL FOR DIFFERENTIATION, (',G15.7, 1 ',',G15.7,')') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,425) 425 FORMAT(' IS TOO SMALL.') CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ENDIF C 9999 CONTINUE RETURN END SUBROUTINE NCFPPF(P,NU1,NU2,DELTA,PPF) C C PURPOSE --PERCENT POINT FUNCTION FOR THE NON-CENTRAL F C DISTRIBUTION. USES A BISECTION METHOD. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--94/9 C ORIGINAL VERSION--SEPTEMBER 1994. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C REAL NU1 REAL NU2 C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C DATA EPS /0.0001/ DATA SIG /1.0E-5/ DATA ZERO /0./ DATA MAXIT /500/ C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(P.LE.0.0.OR.P.GE.1.0)GOTO50 IF(NU1.LT.0.0)GOTO55 IF(NU2.LT.0.0)GOTO65 IF(DELTA.LT.0.0)GOTO70 GOTO90 50 WRITE(ICOUT,1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)P CALL DPWRST('XXX','BUG ') PPF=0.0 RETURN 55 WRITE(ICOUT,11) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)NU1 CALL DPWRST('XXX','BUG ') PPF=0.0 RETURN 65 WRITE(ICOUT,12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)NU2 CALL DPWRST('XXX','BUG ') PPF=0.0 RETURN 70 WRITE(ICOUT,35) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)DELTA CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9999 C 1 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ', 1' NCFPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL') 11 FORMAT('***** FATAL ERROR--THE 2ND INPUT ARGUMENT TO THE ', 1' NCFPPF SUBROUTINE IS NON-POSITIVE.') 12 FORMAT('***** FATAL ERROR--THE THIRD INPUT ARGUMENT TO THE ', 1' NCFPPF SUBROUTINE IS NON-POSITIVE.') 35 FORMAT('***** FATAL ERROR--THE FOURTH INPUT ARGUMENT TO THE ', 1' NCFPPF SUBROUTINE IS NEGATIVE *****') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I15,' *****') C 90 CONTINUE C C FIND BRACKETING INTERVAL. USE CORRESPONDING CENTRAL F C AS INITIAL GUESS, INCREMENTS OF 100 AROUND IT. C AFTER SUCCESSFULLY FIND BRACKETING INTERVAL, THEN SWITCH TO C MORE EFFICIENT BISECTION METHOD. C XINC=50.0 NU1INT=NU1+0.5 NU2INT=NU2+0.5 CALL FPPF(P,NU1INT,NU2INT,XL) ICOUNT=0 MAXCNT=10000 C 91 CONTINUE XR=XL+XINC IF(XL.LE.0.0)XL=0.0 IF(XR.LE.0.0)XR=XL+1.0 CALL NCFCDF(XL,NU1,NU2,DELTA,CDFL) CALL NCFCDF(XR,NU1,NU2,DELTA,CDFR) IF(CDFL.LT.P .AND. CDFR.LT.P)THEN XL=XR ELSEIF(CDFL.GT.P .AND. CDFR.GT.P)THEN XL=XL-XINC ELSE GOTO99 ENDIF ICOUNT=ICOUNT+1 IF(ICOUNT.GT.MAXCNT)THEN WRITE(ICOUT,96) CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9999 ENDIF 96 FORMAT('***** FATAL ERROR--NCFPPF UNABLE TO FIND BRACKETING ', * 'INTERVAL. *****') GOTO91 C C BISECTION METHOD C 99 CONTINUE IC = 0 FXL = -P FXR = 1.0 - P 105 CONTINUE X = (XL+XR)*0.5 CALL NCFCDF(X,NU1,NU2,DELTA,CDF) P1=CDF PPF=X FCS = P1 - P IF(FCS*FXL.GT.ZERO)GOTO110 XR = X FXR = FCS GOTO115 110 CONTINUE XL = X FXL = FCS 115 CONTINUE XRML = XR - XL IF(XRML.LE.SIG .AND. ABS(FCS).LE.EPS)GOTO9999 IC = IC + 1 IF(IC.LE.MAXIT)GOTO105 WRITE(ICOUT,130) CALL DPWRST('XXX','BUG ') 130 FORMAT('***** FATAL ERROR--NCFPPF ROUTINE DID NOT CONVERGE. ***') GOTO9999 C 9999 CONTINUE RETURN END SUBROUTINE NCFRAN(N,ANU1,ANU2,ALAMB1,ISEED,X) C C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N C FROM THE NON-CENTRAL F DISTRIBUTION WITH SHAPE C PARAMETERS ANU1 AND ANU2 AND NON-CENTRALITY C PARAMETER LAMBDA. C INPUT ARGUMENTS--N = THE DESIRED INTEGER NUMBER C OF RANDOM NUMBERS TO BE C GENERATED. C --ANU1 = THE SINGLE PRECISION VALUE OF THE C FIRST SHAPE PARAMETER. C --ANU2 = THE SINGLE PRECISION VALUE OF THE C SECOND SHAPE PARAMETER. C --ALAMB1 = THE SINGLE PRECISION VALUE OF THE C NON-CENTRALITY PARAMETER. C OUTPUT ARGUMENTS--X = A SINGLE PRECISION VECTOR C (OF DIMENSION AT LEAST N) C INTO WHICH THE GENERATED C RANDOM SAMPLE WILL BE PLACED. C OUTPUT--A RANDOM SAMPLE OF SIZE N C FROM THE NON-CENTRAL F DISTRIBUTION C WITH SHAPE PARAMETER VALUES = ANU1, ANU2, AND ALAMB1. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C --ANU1 AND ANU2 SHOULD BE POSITIVE. C --ALAMB1 SHOULD BE NON-NEGATIVE. C OTHER DATAPAC SUBROUTINES NEEDED--NORRAN, CHSRAN. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS C UNIVARIATE DISTRIBUTIONS VOLUME 2", SECOND EDITION, C 1994, PAGES 502-503. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2004.5 C ORIGINAL VERSION--MAY 2004. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DIMENSION X(*) DIMENSION XTEMP(1) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----DATA STATEMENTS------------------------------------------------- C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(N.LT.1)THEN WRITE(ICOUT, 5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)N CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF 5 FORMAT('***** ERROR--THE REQUESTED NUMBER OF NON-CENTRAL F ', 1' RANDOM NUMBERS IS NON-POSITIVE.') IF(ANU1.LE.0.0)THEN WRITE(ICOUT,16) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)ANU1 CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF 16 FORMAT('***** ERROR--THE SHAPE PARAMETER NU1 FOR THE ', 1'NON-CENTRAL F RANDOM NUMBERS IS NON-POSITIVE.') IF(ANU2.LE.0.0)THEN WRITE(ICOUT,26) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)ANU2 CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF 26 FORMAT('***** ERROR--THE SHAPE PARAMETER NU2 FOR THE ', 1'NON-CENTRAL F RANDOM NUMBERS IS NON-POSITIVE.') IF(ALAMB1.LT.0.0)THEN WRITE(ICOUT,36) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)ALAMB1 CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF 36 FORMAT('***** ERROR--THE NON-CENTRALITY PARAMETER LAMBDA FOR ', 1'THE NON-CENTRAL F RANDOM NUMBERS IS NEGATIVE.') C 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8) 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8) C C IF DEGREES OF FREEDOM ARE LESS THAN 1, THEN USE PERCENT C POINT METHOD (PROBABLY NOT MOST EFFICIENT METHOD, BUT LEAVE C UNTIL FIND A BETTER ALGORITHM). C ALAMB2=0.0 C IF(ANU1.LE.1.0 .OR. ANU2.LE.1.0)THEN CALL UNIRAN(N,ISEED,X) DO1378II=1,N ATEMP=X(II) CALL NCFPPF(ATEMP,ANU1,ANU2,ALAMB1,PPF) X(II)=PPF 1378 CONTINUE ELSE NTEMP=1 DO100II=1,N CALL NORRAN(NTEMP,ISEED,XTEMP) X1=(XTEMP(1) + SQRT(ALAMB1))**2 IF(ANU1.GT.1.0)THEN CALL CHSRAN(NTEMP,ANU1-1.0,ISEED,XTEMP) X1=X1+XTEMP(1) ENDIF CALL NORRAN(NTEMP,ISEED,XTEMP) X2=(XTEMP(1) + SQRT(ALAMB2))**2 IF(ANU2.GT.1.0)THEN CALL CHSRAN(NTEMP,ANU2-1.0,ISEED,XTEMP) X2=X2+XTEMP(1) ENDIF X(II)=ANU2*X1/(ANU1*X2) 100 CONTINUE ENDIF C 9000 CONTINUE RETURN END SUBROUTINE NCTCDF(T2, DF2, DELTA2, CDF) C C ALGORITHM AS 243 APPL. STATIST. (1989), VOL.38, NO. 1 C C Cumulative probability at T of the non-central t-distribution C with DF degrees of freedom (may be fractional) and non-centrality C parameter DELTA. C C Note - requires the following auxiliary routines C ALOGAM (X) - ACM 291 or AS 245 C BETAIN (X, A, B, ALBETA, IFAULT) - AS 63 (updated in ASR 19) C ALNORM (X, UPPER) - AS 66 C REAL T2, DF2, DELTA2 DOUBLE PRECISION A, DLBETA, ALNRPI, B, DEL, DELTA, DF, EN, ERRBD DOUBLE PRECISION ERRMAX, GEVEN, GODD, HALF, ITRMAX, LAMBDA, ONE DOUBLE PRECISION P, Q, R2PI, RXB, S, T, TT, TWO, X, XEVEN, XODD DOUBLE PRECISION ZERO, DBETAI, TNC LOGICAL NEGDEL C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C C Note - ITRMAX and ERRMAX may be changed to suit one's needs. C DATA ITRMAX/500.1D0/, ERRMAX/1.D-06/ C C Constants - R2PI = 1/ {GAMMA(1.5) * SQRT(2)} = SQRT(2 / PI) C ALNRPI = LN(SQRT(PI)) C DATA ZERO/0.D0/ DATA HALF/0.5D0/ DATA ONE/1.0D0/ DATA TWO/2.0D0/ DATA R2PI/0.79788 45608 02865 35588D0/ DATA ALNRPI/0.57236 49429 24700 08707D0/ C T=DBLE(T2) DF=DBLE(DF2) DELTA=DBLE(DELTA2) C IF(DF.LE.ZERO)THEN WRITE(ICOUT,101) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,102)DF2 CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF 101 FORMAT('***** FATAL DIAGNOSTIC--THE DEGREES OF FREEDOM PARAMETER') 102 FORMAT(' IS NON-POSITIVE. IT HAS THE VALUE ',E15.7) C TNC = ZERO C TT = T DEL = DELTA NEGDEL = .FALSE. IF (T .GE. ZERO) GO TO 1 NEGDEL = .TRUE. TT = -TT DEL = -DEL 1 CONTINUE C C Initialize twin series (Guenther, J. Statist. Computn. Simuln. C vol.6, 199, 1978). C EN = ONE X = T * T / (T* T + DF) IF (X .LE. ZERO) GO TO 20 LAMBDA = DEL * DEL P = HALF * DEXP(-HALF * LAMBDA) Q = R2PI * P * DEL S = HALF - P A = HALF B = HALF * DF RXB = (ONE - X) ** B CCCCC ALBETA = ALNRPI + ALOGAM(B, IFAULT) - ALOGAM(A + B, IFAULT) CCCCC XODD = BETAIN(X, A, B, ALBETA, IFAULT) ALBETA=DLBETA(A,B) XODD = DBETAI(X,A,B) C GODD = TWO * RXB * EXP(A * LOG(X) - ALBETA) XEVEN = ONE - RXB GEVEN = B * X * RXB TNC = P * XODD + Q * XEVEN C C Repeat until convergence C 10 A = A + ONE XODD = XODD - GODD XEVEN = XEVEN - GEVEN GODD = GODD * X * (A + B - ONE) / A GEVEN = GEVEN * X * (A + B - HALF) / (A + HALF) P = P * LAMBDA / (TWO * EN) Q = Q * LAMBDA / (TWO * EN + ONE) S = S - P EN = EN + ONE TNC = TNC + P * XODD + Q * XEVEN ERRBD = TWO * S * (XODD - GODD) IF (ERRBD .GT. ERRMAX .AND. EN .LE. ITRMAX) GO TO 10 C CCCCC APRIL 1995. IF NO CONVERGENCE, CALL DOUBLY NON-CENTRAL T CCCCC ROUTINE. C 20 CONTINUE IF (EN .GT. ITRMAX) THEN CCCCC WRITE(ICOUT,701) CCCCC CALL DPWRST('XXX','BUG ') ALAMB=0.0 CALL DNTCDF(T2,DF2,DELTA2,ALAMB,CDF) RETURN ENDIF 701 FORMAT('*** WARNING--THE NCTCDF ROUTINE DID NOT CONVERGE. ***') C CCCCC TNC = TNC + ALNORM(DEL, .TRUE.) ARG1=REAL(DEL) CALL NORCDF(ARG1,ARG2) TNC = TNC + DBLE(1.0-ARG2) IF (NEGDEL) TNC = ONE - TNC GOTO9999 C 9999 CONTINUE CDF=REAL(TNC) RETURN END SUBROUTINE NCTCD2(T2, DF2, DELTA2, CDF) C C This is a copy of NCTCDF. Distinction is that this version C returns a double precision result (used by the NCTPDF C routine) and inputs double precision arguments. C C ALGORITHM AS 243 APPL. STATIST. (1989), VOL.38, NO. 1 C C Cumulative probability at T of the non-central t-distribution C with DF degrees of freedom (may be fractional) and non-centrality C parameter DELTA. C C Note - requires the following auxiliary routines C ALOGAM (X) - ACM 291 or AS 245 C BETAIN (X, A, B, ALBETA, IFAULT) - AS 63 (updated in ASR 19) C ALNORM (X, UPPER) - AS 66 C DOUBLE PRECISION T2, DF2, DELTA2, ARG2, CDF DOUBLE PRECISION A, DLBETA, ALNRPI, B, DEL, DELTA, DF, EN, ERRBD DOUBLE PRECISION ERRMAX, GEVEN, GODD, HALF, ITRMAX, LAMBDA, ONE DOUBLE PRECISION P, Q, R2PI, RXB, S, T, TT, TWO, X, XEVEN, XODD DOUBLE PRECISION ZERO, DBETAI, TNC LOGICAL NEGDEL C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C C Note - ITRMAX and ERRMAX may be changed to suit one's needs. C DATA ITRMAX/1000.1D0/, ERRMAX/1.D-08/ C C Constants - R2PI = 1/ {GAMMA(1.5) * SQRT(2)} = SQRT(2 / PI) C ALNRPI = LN(SQRT(PI)) C DATA ZERO/0.D0/ DATA HALF/0.5D0/ DATA ONE/1.0D0/ DATA TWO/2.0D0/ DATA R2PI/0.79788 45608 02865 35588D0/ DATA ALNRPI/0.57236 49429 24700 08707D0/ C T=T2 DF=DF2 DELTA=DELTA2 C IF(DF.LE.ZERO)THEN WRITE(ICOUT,101) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,102)DF2 CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF 101 FORMAT('***** FATAL DIAGNOSTIC--THE DEGREES OF FREEDOM PARAMETER') 102 FORMAT(' IS NON-POSITIVE. IT HAS THE VALUE ',D15.7) C TNC = ZERO C TT = T DEL = DELTA NEGDEL = .FALSE. IF (T .GE. ZERO) GO TO 1 NEGDEL = .TRUE. TT = -TT DEL = -DEL 1 CONTINUE C C Initialize twin series (Guenther, J. Statist. Computn. Simuln. C vol.6, 199, 1978). C EN = ONE X = T * T / (T* T + DF) IF (X .LE. ZERO) GO TO 20 LAMBDA = DEL * DEL P = HALF * DEXP(-HALF * LAMBDA) Q = R2PI * P * DEL S = HALF - P A = HALF B = HALF * DF RXB = (ONE - X) ** B CCCCC ALBETA = ALNRPI + ALOGAM(B, IFAULT) - ALOGAM(A + B, IFAULT) CCCCC XODD = BETAIN(X, A, B, ALBETA, IFAULT) ALBETA=DLBETA(A,B) XODD = DBETAI(X,A,B) C GODD = TWO * RXB * EXP(A * LOG(X) - ALBETA) XEVEN = ONE - RXB GEVEN = B * X * RXB TNC = P * XODD + Q * XEVEN C C Repeat until convergence C 10 A = A + ONE XODD = XODD - GODD XEVEN = XEVEN - GEVEN GODD = GODD * X * (A + B - ONE) / A GEVEN = GEVEN * X * (A + B - HALF) / (A + HALF) P = P * LAMBDA / (TWO * EN) Q = Q * LAMBDA / (TWO * EN + ONE) S = S - P EN = EN + ONE TNC = TNC + P * XODD + Q * XEVEN ERRBD = TWO * S * (XODD - GODD) IF (ERRBD .GT. ERRMAX .AND. EN .LE. ITRMAX) GO TO 10 C CCCCC APRIL 1995. IF NO CONVERGENCE, CALL DOUBLY NON-CENTRAL T CCCCC ROUTINE. C 20 CONTINUE IF (EN .GT. ITRMAX) THEN CCCCC WRITE(ICOUT,701) CCCCC CALL DPWRST('XXX','BUG ') ALAMB=0.0 CALL DNTCDF(REAL(T2),REAL(DF2),REAL(DELTA2),ALAMB,CDF2) CDF=DBLE(CDF2) RETURN ENDIF 701 FORMAT('*** WARNING--THE NCTCD2 ROUTINE DID NOT CONVERGE. ***') C CCCCC TNC = TNC + ALNORM(DEL, .TRUE.) ARG1=REAL(DEL) CALL NODCDF(DEL,ARG2) TNC = TNC + (1.0D0-ARG2) IF (NEGDEL) TNC = ONE - TNC GOTO9999 C 9999 CONTINUE CDF=TNC RETURN END SUBROUTINE NCTPDF(T, DF, DELTA, PDF) C C COMPUTE NON-CENTRAL PDF BASED ON NON-CENTRAL CDF. C C--------------------------------------------------------------------- C DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 DOUBLE PRECISION DTERM3 DOUBLE PRECISION DCDF DOUBLE PRECISION DPDF DOUBLE PRECISION DPDF1 DOUBLE PRECISION DPDF2 C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C T = 0 IS A SPECIAL CASE. C CCCCC EPS=0.000001 EPS=1.0E-8 IF(ABS(T).LE.EPS)THEN C C THIS ALGORITHM DOES NOT RETURN A CORRECT RESULT. AS TEMPORARY C FIX, COMPUTE FOR +EPS AND -EPS, THEN AVERAGE RESULT. C CCCCC TX=EPS CCCCC TERM1=DF/TX CCCCC DF2=DF+2.0 CCCCC TX2=SQRT((DF+2.0)/DF)*TX CCCCC CALL NCTCDF(TX2,DF2,DELTA,TERM2) CCCCC CALL NCTCDF(TX,DF,DELTA,TERM3) CCCCC PDF=TERM1*(TERM2-TERM3) C TTEMP=EPS DTERM1=DBLE(DF/TTEMP) DF2=DF+2.0 T2=SQRT((DF+2.0)/DF)*TTEMP CALL NCTCD2(DBLE(T2),DBLE(DF2),DBLE(DELTA),DTERM2) CALL NCTCD2(DBLE(TTEMP),DBLE(DF),DBLE(DELTA),DTERM3) DPDF1=DTERM1*(DTERM2-DTERM3) C TTEMP=-EPS DTERM1=DBLE(DF/TTEMP) DF2=DF+2.0 T2=SQRT((DF+2.0)/DF)*TTEMP CALL NCTCD2(DBLE(T2),DBLE(DF2),DBLE(DELTA),DTERM2) CALL NCTCD2(DBLE(TTEMP),DBLE(DF),DBLE(DELTA),DTERM3) DPDF2=DTERM1*(DTERM2-DTERM3) C DPDF=(DPDF1+DPDF2)/2.0D0 PDF=REAL(DPDF) ELSE DTERM1=DBLE(DF/T) DF2=DF+2.0 T2=SQRT((DF+2.0)/DF)*T CALL NCTCD2(DBLE(T2),DBLE(DF2),DBLE(DELTA),DTERM2) CALL NCTCD2(DBLE(T),DBLE(DF),DBLE(DELTA),DTERM3) DPDF=DTERM1*(DTERM2-DTERM3) PDF=REAL(DPDF) ENDIF C 9999 CONTINUE RETURN END SUBROUTINE NCTPPF(P,NU,DELTA,PPF) C C PURPOSE --PERCENT POINT FUNCTION FOR THE NON-CENTRAL T C DISTRIBUTION. USES A BISECTION METHOD. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--94/9 C ORIGINAL VERSION--SEPTEMBER 1994. C UPDATED --OCTOBER 2006. CALL LIST TO TPPF C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C REAL NU DOUBLE PRECISION DLNGAM DOUBLE PRECISION FCT DOUBLE PRECISION C0 DOUBLE PRECISION C1 C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C CCCCC DATA EPS /0.0001/ CCCCC DATA SIG /1.0E-5/ DATA ZERO /0./ DATA MAXIT /500/ C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(P.LE.0.0.OR.P.GE.1.0)GOTO50 IF(NU.LT.0.0)GOTO55 IF(DELTA.LT.0.0)GOTO70 GOTO90 50 WRITE(ICOUT,1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)P CALL DPWRST('XXX','BUG ') PPF=0.0 RETURN 55 WRITE(ICOUT,11) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)NU CALL DPWRST('XXX','BUG ') PPF=0.0 RETURN 70 WRITE(ICOUT,35) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)DELTA CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9999 C 1 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ', 1' NCTPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL.') 11 FORMAT('***** FATAL ERROR--THE 2ND INPUT ARGUMENT TO THE ', 1' NCTPPF SUBROUTINE IS LESS THAN 1.') 35 FORMAT('***** FATAL ERROR--THE THIRD INPUT ARGUMENT TO THE ', 1' NCTPPF SUBROUTINE IS NEGATIVE *****') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I15,' *****') C 90 CONTINUE C C DELTA = 0 AND NU INTEGER, USE CENTRAL T C IF(DELTA.EQ.0.0)THEN NUINT=INT(NU+0.1) ANUINT=REAL(NUINT) IF(ABS(NU-ANUINT).LE.0.00001)THEN CALL TPPF(P,REAL(NUINT),PPF) GOTO9999 ENDIF ENDIF C C FIND BRACKETING INTERVAL. USE CORRESPONDING CENTRAL T C AS INITIAL GUESS, INCREMENTS OF 100 AROUND IT. C AFTER SUCCESSFULLY FIND BRACKETING INTERVAL, THEN SWITCH TO C MORE EFFICIENT BISECTION METHOD. C C 8/97. BASE XINC ON NON_CENTRAL T STANDARD DEVIATION C (FROM MARK VANGEL'S INVNCT ALGORITHM) C 5/2004. BETTER BRACKETING INTERVAL. BASE ON MEAN, SD, AND VALUE OF P. C ALSO, FOR LOW VALUES OF NU AND MORE EXTREME VALUES OF P, C LOOSEN THE CONVERGENCE CRITIERION. C EPS=0.0001 SIG=1.0E-5 IF(NU.LT.3.0)THEN IF(P.GT.0.90 .OR. P.LT.0.10)THEN EPS=0.0001 SIG=1.0E-4 ENDIF ENDIF IF(ABS(DELTA).GE.10.0)THEN EPS=0.0001 SIG=1.0E-4 ENDIF C NUINT=NU+0.5 CCCCC CALL TPPF(P,REAL(NUINT),XL) CCCCC XINC=50.0 IF(NU.LE.1.5)THEN AMEAN=DELTA ELSE FCT=DEXP(DLNGAM(DBLE(0.5*(NU-1.0)))-DLNGAM(DBLE(0.5*NU))) C1=DBLE(NU)*DSQRT(DBLE(NU)/2.0D0) AMEAN=SNGL(C1*FCT) ENDIF IF(NU.LE.2.5)THEN SD=100.0 ELSE FCT=DEXP(DLNGAM(DBLE(0.5*(NU-1.0)))-DLNGAM(DBLE(0.5*NU))) C1=DBLE(NU/(NU-2.0) - 0.5*NU*FCT**2) C0=DBLE(NU/(NU-2.0)) SD=SNGL(DSQRT(C1*DELTA**2+C0)) ENDIF XINC=SD C IF(P.GE.0.25 .AND. P.LE.0.75)THEN XL=AMEAN-XINC XINC=2.0*SD ELSEIF(P.GT.0.75)THEN XL=AMEAN ELSE XL=AMEAN-3.0*XINC XINC=2.9*SD ENDIF C ICOUNT=0 MAXCNT=100 IF(NU.LT.3.0)MAXCNT=200 C 91 CONTINUE XR=XL+XINC CALL NCTCDF(XL,NU,DELTA,CDFL) CALL NCTCDF(XR,NU,DELTA,CDFR) IF(CDFL.LT.P .AND. CDFR.LT.P)THEN XL=XR ELSEIF(CDFL.GT.P .AND. CDFR.GT.P)THEN XL=XL-XINC ELSE GOTO99 ENDIF ICOUNT=ICOUNT+1 IF(ICOUNT.GT.MAXCNT)THEN WRITE(ICOUT,96) CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9999 ENDIF 96 FORMAT('***** FATAL ERROR--NCTPPF UNABLE TO FIND BRACKETING ', * 'INTERVAL. *****') GOTO91 C C BISECTION METHOD C 99 CONTINUE IC = 0 FXL = -P FXR = 1.0 - P 105 CONTINUE X = (XL+XR)*0.5 CALL NCTCDF(X,NU,DELTA,CDF) P1=CDF PPF=X FCS = P1 - P IF(FCS*FXL.GT.ZERO)GOTO110 XR = X FXR = FCS GOTO115 110 CONTINUE XL = X FXL = FCS 115 CONTINUE XRML = XR - XL IF(XRML.LE.SIG .AND. ABS(FCS).LE.EPS)GOTO9999 IC = IC + 1 IF(IC.LE.MAXIT)GOTO105 WRITE(ICOUT,130) CALL DPWRST('XXX','BUG ') 130 FORMAT('***** FATAL ERROR--NCTPPF ROUTINE DID NOT CONVERGE. ***') GOTO9999 C 9999 CONTINUE RETURN END SUBROUTINE NCTRAN(N,ANU,DELTA,ISEED,X) C C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N C FROM THE STUDENT'S NON-CENTRAL T DISTRIBUTION C WITH DEGREES OF FREEDOM PARAMETER NU AND C NON-CENTRALITY PARAMETER DELTA. C INPUT ARGUMENTS--N = THE DESIRED INTEGER NUMBER C OF RANDOM NUMBERS TO BE C GENERATED. C --NU = THE INTEGER DEGREES OF FREEDOM C PARAMETER. C --DELTA = THE REAL NON-CENTRALITY PARAMETER DELTA. C OUTPUT ARGUMENTS--X = A SINGLE PRECISION VECTOR C (OF DIMENSION AT LEAST N) C INTO WHICH THE GENERATED C RANDOM SAMPLE WILL BE PLACED. C OUTPUT--A RANDOM SAMPLE OF SIZE N C FROM THE STUDENT'S NON-CENTRAL T DISTRIBUTION C WITH DEGREES OF FREEDOM PARAMETER = NU AND C NON-CENTRALITY PARAMETER DELTA. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C --NU SHOULD BE A POSITIVE INTEGER VARIABLE. C OTHER DATAPAC SUBROUTINES NEEDED--UNIRAN. C FORNCTRAN LIBRARY SUBROUTINES NEEDED--ALOG, SQRT, SIN, COS. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORNCTRAN (1977) C REFERENCES--MOOD AND GRABLE, INTRODUCTION TO THE C THEORY OF STATISTICS, 1963, PAGE 233. C --JOHNSON, KOTZ, AND BALAKRISHNAN, CONTINUOUS C UNIVARIATE DISTRIBUTIONS--VOLUME 2, SECOND EDITION, C 1994, CHAPTER 31. C --HASTINGS, EVANS, AND PEACOCK, STATISTICAL C DISTRIBUTIONS--THIRD EDITION, WILEY, 2001, C PP. 184-186. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-921-3651 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--2004.3 C ORIGINAL VERSION--MARCH 2004. C UPDATED --MAY 2004. SUPPORT FOR REAL VALUES OF NU C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C REAL DELTA REAL ANU DIMENSION X(*) DIMENSION Y(1) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----DATA STATEMENTS------------------------------------------------- C DATA PI/3.14159265359/ DATA EPS/0.00001/ C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(N.LT.1)THEN WRITE(ICOUT,5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)N CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF IF(ANU.LE.0.0)THEN WRITE(ICOUT,15) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,48)ANU CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF 5 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO THE ', 1'NCTRAN SUBROUTINE IS NON-POSITIVE *****') 15 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO THE ', 1'NCTRAN SUBROUTINE IS NON-POSITIVE *****') 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8) 48 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7) C C GENERATE N STUDENT'S NON-CENTRAL T RANDOM NUMBERS C USING THE DEFINITION THAT A STUDENT'S NON-CENTRAL T VARIATE C WITH NU DEGREES OF FREEDOM AND NON-CENTRALITY PARAMETER C DELTA EQUALS A NORMAL VARIATE WITH LOCATION PARAMETER DELTA C DIVIDED BY A STANDARDIZED CHI VARIATE C (WHERE THE LATTER EQUALS SQRT(CHI-SQUARED/NU). C FIRST GENERATE A NORMAL RANDOM NUMBER WITH LOCATION PARAMETER C DELTA, THEN GENERATE A STANDARDIZED CHI RANDOM NUMBER, C THEN FORM THE RATIO OF THE FIRST DIVIDED BY C THE SECOND. C CALL NORRAN(N,ISEED,X) NTEMP=1 C DO100I=1,N C X(I)=X(I) + DELTA CALL CHSRAN(NTEMP,ANU,ISEED,Y) X(I)=X(I)/SQRT(Y(1)/ANU) C 100 CONTINUE C 9000 CONTINUE RETURN END SUBROUTINE NEIGH(IT,NN,XS,N,I1,I2,ISUBRO,IBUGA3,IERROR) C C PURPOSE--FOR THE IT-TH HORIZONTAL ORDERED DATA POINT XS(IT), C DETERMINE THE INDICES I1 AND I2 WHICH DEFINE C THE NN NEAREST NEIGHBORS OF XS(IT). C NOTE--XS(IT) IS CONSIDERED A NEIGHBOR OF ITSELF. C REFERENCE--CHAMBERS, ET AL. GRAPHICAL METHODS FOR DATA ANALYSIS. C WADSWORTH, 1983, PAGES 94-98, 121-122. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--88/2 C ORIGINAL VERSION--FEBRUARY 1988 C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ISUBRO CHARACTER*4 IBUGA3 CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C DIMENSION XS(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='EIGH' ISUBN2='H ' C I1=(-999) I2=(-999) IERROR='NO' C IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'EIGH')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF NEIGH--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)ISUBRO,IBUGA3,IERROR 52 FORMAT('ISUBRO,IBUGA3,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)IT,NN,N 53 FORMAT('IT,NN,N = ',3I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)I1,I2 54 FORMAT('I1,I2 = ',2I8) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C IF(N.GE.1)GOTO119 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,111) 111 FORMAT('***** ERROR IN NEIGH--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,112) 112 FORMAT(' THE INPUT FULL SAMPLE SIZE,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,113) 113 FORMAT(' FOR WHICH LOWESS NEIGHBORHOODS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,114) 114 FORMAT(' ARE TO BE COMPUTED, MUST BE 1 OR LARGER.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,115) 115 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,116)N 116 FORMAT(' THE FULL SAMPLE SIZE N = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 119 CONTINUE C IF(IT.GE.1)GOTO129 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,121) 121 FORMAT('***** ERROR IN NEIGH--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,122) 122 FORMAT(' THE INPUT TARGET OBSERVATION INDEX') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,123) 123 FORMAT(' FOR WHICH A LOWESS IS TO BE CARRIED OUT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,124)N 124 FORMAT(' MUST BE BETWEEN 1 AND ',I8,' (INCLUSIVE).') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,125) 125 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,126)IT 126 FORMAT(' THE TARGET OBSERVATION INDEX IT = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 129 CONTINUE C IF(NN.GE.1)GOTO139 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,131) 131 FORMAT('***** ERROR IN NEIGH--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,132) 132 FORMAT(' THE INPUT NEIGHBORHOOD SIZE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,133) 133 FORMAT(' FOR WHICH A LOWESS IS TO BE CARRIED OUT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,134)N 134 FORMAT(' MUST BE BETWEEN 1 AND ',I8,' (INCLUSIVE).') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,135) 135 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,136)NN 136 FORMAT(' THE NEIGHBORHOOD SIZE NN = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 139 CONTINUE C C *********************************************** C ** STEP 11-- ** C ** COMPUTE THE INDICES OF THE NEIGHBORHOOD ** C *********************************************** C I1=IT I2=IT NNI=1 C IF(NN.LE.1)GOTO1190 DO1100I=2,NN C IF(I1.LE.1)GOTO1110 IF(I2.GE.N)GOTO1120 GOTO1130 C 1110 CONTINUE I2=I2+1 NNI=NNI+1 GOTO1100 C 1120 CONTINUE I1=I1-1 NNI=NNI+1 GOTO1100 C 1130 CONTINUE I1M1=I1-1 I2P1=I2+1 DEL1=ABS(XS(IT)-XS(I1M1)) DEL2=ABS(XS(I2P1)-XS(IT)) IF(DEL1.LT.DEL2)I1=I1M1 IF(DEL1.GE.DEL2)I2=I2P1 NNI=NNI+1 GOTO1100 C 1100 CONTINUE 1190 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'EIGH')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF NEIGH--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)ISUBRO,IBUGA3,IERROR 9012 FORMAT('ISUBRO,IBUGA3,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)IT,NN,N 9013 FORMAT('IT,NN,N = ',3I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)I1,I2 9014 FORMAT('I1,I2 = ',2I8) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE NMXCDF(X,U1,SD1,U2,SD2,P,CDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION C FUNCTION VALUE FOR THE MIXTUURE NORMAL (GAUSSIAN) C DISTRIBUTION. C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE AT C WHICH THE CUMULATIVE DISTRIBUTION C FUNCTION IS TO BE EVALUATED. C OUTPUT ARGUMENTS--CDF = THE DOUBLE PRECISION CUMULATIVE C DISTRIBUTION FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION C FUNCTION VALUE CDF. C PRINTING--NONE. C RESTRICTIONS--NONE. C OTHER DATAPAC SUBROUTINES NEEDED--NODCDF. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE C DISTRIBUTIONS, 2ND. ED.--1, 1994, CHAPTER 12. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--98.5 C ORIGINAL VERSION--MAY 1998. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C DOUBLE PRECISION DARG1 DOUBLE PRECISION DCDF1 DOUBLE PRECISION DCDF2 C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IF(SD1.LE.0.0)THEN WRITE(ICOUT,101) CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9000 ENDIF 101 FORMAT('*****ERROR FROM NMXCDF--FIRST SCALE PARAMETER IS ', 1 'NOT POSITVE.') IF(SD2.LE.0.0)THEN WRITE(ICOUT,103) CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9000 ENDIF 103 FORMAT('*****ERROR FROM NMXCDF--SECOND SCALE PARAMETER IS ', 1 'NOT POSITIVE.') C DARG1=DBLE((X-U1)/SD1) CALL NODCDF(DARG1,DCDF1) DARG1=DBLE((X-U2)/SD2) CALL NODCDF(DARG1,DCDF2) C CDF=REAL(DBLE(P)*DCDF1 + DBLE(1.0-P)*DCDF2) C 9000 CONTINUE C RETURN END SUBROUTINE NMDCDF(X,U1,SD1,U2,SD2,P,CDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION C FUNCTION VALUE FOR THE MIXTUURE NORMAL (GAUSSIAN) C DISTRIBUTION. SAME AS NMXCDF EXCEPT THAT THE C CDF RETURNED IS DOUBLE PRECISION. C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE AT C WHICH THE CUMULATIVE DISTRIBUTION C FUNCTION IS TO BE EVALUATED. C OUTPUT ARGUMENTS--CDF = THE DOUBLE PRECISION CUMULATIVE C DISTRIBUTION FUNCTION VALUE. C OUTPUT--THE DOUBLE PRECISION CUMULATIVE DISTRIBUTION C FUNCTION VALUE CDF. C PRINTING--NONE. C RESTRICTIONS--NONE. C OTHER DATAPAC SUBROUTINES NEEDED--NODCDF. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE C DISTRIBUTIONS, 2ND. ED.--1, 1994, CHAPTER 12. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--98.5 C ORIGINAL VERSION--MAY 1998. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C DOUBLE PRECISION DARG1 DOUBLE PRECISION DCDF1 DOUBLE PRECISION DCDF2 DOUBLE PRECISION CDF C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IF(SD1.LE.0.0)THEN WRITE(ICOUT,101) CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9000 ENDIF 101 FORMAT('*****ERROR FROM NMXCDF--FIRST SCALE PARAMETER IS ', 1 'NOT POSITVE.') IF(SD2.LE.0.0)THEN WRITE(ICOUT,103) CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9000 ENDIF 103 FORMAT('*****ERROR FROM NMXCDF--SECOND SCALE PARAMETER IS ', 1 'NOT POSITIVE.') C DARG1=DBLE((X-U1)/SD1) CALL NODCDF(DARG1,DCDF1) DARG1=DBLE((X-U2)/SD2) CALL NODCDF(DARG1,DCDF2) C CDF=DBLE(P)*DCDF1 + DBLE(1.0-P)*DCDF2 C 9000 CONTINUE C RETURN END SUBROUTINE NMXPPF(P,U1,SD1,U2,SD2,PMIX,PPF) C C PURPOSE --PERCENT POINT FUNCTION FOR THE NORMAL MIXTURE C DISTRIBUTION. USES A BISECTION METHOD. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--98/5 C ORIGINAL VERSION--MAY 1998. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DCDF DOUBLE PRECISION FXL DOUBLE PRECISION FXR DOUBLE PRECISION XLD DOUBLE PRECISION XRD DOUBLE PRECISION P1 DOUBLE PRECISION X DOUBLE PRECISION PPFD DOUBLE PRECISION FCS DOUBLE PRECISION XRML DOUBLE PRECISION SIG DOUBLE PRECISION EPS DOUBLE PRECISION ZERO C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C DATA EPS /0.00001D0/ DATA SIG /1.0D-6/ DATA ZERO /0.D0/ DATA MAXIT /20000/ C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(P.LE.0.0.OR.P.GE.1.0)THEN WRITE(ICOUT,1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)P CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9999 ENDIF 1 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ', 1' NMXPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL.') IF(SD1.LE.0.0)THEN WRITE(ICOUT,11) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)SD1 CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9999 ENDIF 11 FORMAT('***** FATAL ERROR--THE FIRST SCALE PARAMETER TO THE ', 1' NMXPPF SUBROUTINE IS LESS THAN OR EQUAL TO 0.') IF(SD2.LE.0.0)THEN WRITE(ICOUT,13) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)SD2 CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9999 ENDIF 13 FORMAT('***** FATAL ERROR--THE SECOND SCALE PARAMETER TO THE ', 1' NMXPPF SUBROUTINE IS LESS THAN OR EQUAL TO 0.') C IF(PMIX.LT.0.0 .OR. PMIX.GT.1.0)THEN WRITE(ICOUT,15) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)PMIX CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9999 ENDIF 15 FORMAT('***** FATAL ERROR--THE MIXING PARAMETER TO THE ', 1' NMXPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL.') C 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I15,' *****') C 90 CONTINUE C C FIND BRACKETING INTERVAL. C XMEAN=PMIX*U1 + (1.0-PMIX)*U2 XVAR=PMIX*SD1*SD1 + (1.0-PMIX)*SD2*SD2 + 1 PMIX*(1.0-PMIX)*(U1-U2)*(U1-U2) XSD=SQRT(XVAR) C ICOUNT=0 MAXCNT=100 C XL=XMEAN XINC=XSD C 91 CONTINUE XR=XL+XINC CALL NMXCDF(XL,U1,SD1,U2,SD2,PMIX,CDFL) CALL NMXCDF(XR,U1,SD1,U2,SD2,PMIX,CDFR) IF(CDFL.LT.P .AND. CDFR.LT.P)THEN XL=XR ELSEIF(CDFL.GT.P .AND. CDFR.GT.P)THEN XL=XL-XINC ELSE GOTO99 ENDIF ICOUNT=ICOUNT+1 IF(ICOUNT.GT.MAXCNT)THEN WRITE(ICOUT,96) CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9999 ENDIF 96 FORMAT('***** FATAL ERROR--NMXPPF UNABLE TO FIND BRACKETING ', * 'INTERVAL. *****') GOTO91 C C BISECTION METHOD C 99 CONTINUE XLD=DBLE(XL) XRD=DBLE(XR) IC = 0 FXL = DBLE(-P) FXR = DBLE(1.0 - P) 105 CONTINUE X = (XLD+XRD)*0.5D0 CALL NMDCDF(REAL(X),U1,SD1,U2,SD2,PMIX,DCDF) P1=DCDF PPFD=X PPF=REAL(PPFD) FCS = P1 - DBLE(P) IF(FCS*FXL.GT.ZERO)GOTO110 XRD = X FXR = FCS GOTO115 110 CONTINUE XLD = X FXL = FCS 115 CONTINUE XRML = XRD - XLD IF(XRML.LE.SIG .AND. ABS(FCS).LE.EPS)GOTO9999 IC = IC + 1 IF(IC.LE.MAXIT)GOTO105 WRITE(ICOUT,130) CALL DPWRST('XXX','BUG ') 130 FORMAT('***** FATAL ERROR--NMXPPF ROUTINE DID NOT CONVERGE. ***') GOTO9999 C 9999 CONTINUE RETURN END SUBROUTINE NMXRAN(N,U1,SD1,U2,SD2,P,ISEED,X) C C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N C FROM THE THE NORMAL (GAUSSIAN) MIXTURE C DISTRIBUTION. C INPUT ARGUMENTS--N = THE DESIRED INTEGER NUMBER C OF RANDOM NUMBERS TO BE C GENERATED. C OUTPUT ARGUMENTS--X = A SINGLE PRECISION VECTOR C (OF DIMENSION AT LEAST N) C INTO WHICH THE GENERATED C RANDOM SAMPLE WILL BE PLACED. C OUTPUT--A RANDOM SAMPLE OF SIZE N C FROM THE NORMAL MIXTURE DISTRIBUTION C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C OTHER DATAPAC SUBROUTINES NEEDED--UNIRAN. C FORTRAN LIBRARY SUBROUTINES NEEDED--ALOG, SQRT, SIN, COS. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C METHOD--1) CALCULATE UNIFORM RAND NUMBER. C 2) IF LESS THAN OR EQUAL TO P, CALCULATE RAND NUMBER C FROM NORMAL WITH U1, SD1 C 3) IF GREATER THAN P, CALCULATE RAND NUMBER C FROM NORMAL WITH U2, SD2 C REFERENCES--FOWLKES, "SOME METHODS FOR STUDYING THE MIXTURE C OF TWO NORMAL (LOGNORMAL) DSITRIBUTIONS', C JOURNAL OF THE AMERICAN STATISTICAL ASSOCIATION, C SEPTEMBER, 1979. PAGES 561-575. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--98.5 C ORIGINAL VERSION--MAY 1998. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DIMENSION X(*) DIMENSION Y(1) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(N.LT.1)GOTO50 GOTO90 50 WRITE(ICOUT, 5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)N CALL DPWRST('XXX','BUG ') RETURN 90 CONTINUE 5 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ', 1'NMXRAN SUBROUTINE IS NON-POSITIVE *****') 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****') C CALL UNIRAN(N,ISEED,X) C NTEMP=1 DO200I=1,N CALL NORRAN(NTEMP,ISEED,Y) IF(X(I).LE.P)THEN X(I)=U1 + SD1*Y(1) ELSE X(I)=U2 + SD2*Y(1) ENDIF 200 CONTINUE C RETURN END SUBROUTINE NORCDF(X,CDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION C FUNCTION VALUE FOR THE NORMAL (GAUSSIAN) C DISTRIBUTION WITH MEAN = 0 AND STANDARD DEVIATION = 1. C THIS DISTRIBUTION IS DEFINED FOR ALL X AND HAS C THE PROBABILITY DENSITY FUNCTION C F(X) = (1/SQRT(2*PI))*EXP(-X*X/2). C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE AT C WHICH THE CUMULATIVE DISTRIBUTION C FUNCTION IS TO BE EVALUATED. C OUTPUT ARGUMENTS--CDF = THE SINGLE PRECISION CUMULATIVE C DISTRIBUTION FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION C FUNCTION VALUE CDF. C PRINTING--NONE. C RESTRICTIONS--NONE. C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--EXP. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--NATIONAL BUREAU OF STANDARDS APPLIED MATHEMATICS C SERIES 55, 1964, PAGE 932, FORMULA 26.2.17. C --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE C DISTRIBUTIONS--1, 1970, PAGES 40-111. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--82.6 C ORIGINAL VERSION--JUNE 1972. C UPDATED --SEPTEMBER 1975. C UPDATED --NOVEMBER 1975. C UPDATED --OCTOBER 1981. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----DATA STATEMENTS------------------------------------------------- C DATA B1,B2,B3,B4,B5,P/.319381530,-0.356563782,1.781477937,-1.82125 15978,1.330274429,.2316419/ C C-----START POINT----------------------------------------------------- C Z=X IF(X.LT.0.0)Z=-Z T=1.0/(1.0+P*Z) CDF=1.0-((0.39894228040143 )*EXP(-0.5*Z*Z))*(B1*T+B2*T**2+B3*T**3 1+B4*T**4+B5*T**5) IF(X.LT.0.0)CDF=1.0-CDF C RETURN END SUBROUTINE NORFUN (N, X, FVEC, IFLAG, XDATA, NOBS) C C PURPOSE--THIS ROUTINE COMPUTES THE FUNCTIONS FOR THE C CENSORED NORMAL MAXIMUM LIKELIHOOD EQUATIONS. C C SUM[i=1 to r][Z(I)] + SUM[j=1 to m][h(y(i)] = 0 C SUM[i=1 to r][Z(I)**2] + SUM[j=1 to m][y(i)*h(y(i)] - r = 0 C C WITH C C r = NUMBER OF FAILURE TIMES C m = NUMBER OF CENSORED ITEMS C C Z(I) = (X(i) - muhat)/sigmahat C Y(I) = (C(j) - muhat)/sigmahat C C h IS THE NORMAL HAZARD FUNCTION. C C WITH C AND K DENOTING THE SHAPE PARAMETERS, C RESPECTIVELY. THE muhat AND sigmahat PARAMETERS ARE C THE QUANTITIES BEING ESTIMATED. USE THE MEAN AND C STANDARD DEVIATION OF THE FAILURE TIMES DATA AS C STARTING VALUES. C C TO SIMPLIFY THE INTERFACE, SORT THE INPUT DATA C ARRAY, X, SO THAT THE r FAILURE TIMES COME FIRST C AND THEN THE M CENSOR TIMES. C C CALLED BY DNSQE ROUTINE FOR SOLVING SIMULTANEOUS C NONLINEAR EQUATIONS. NOTE THAT THE CALLING SEQUENCE C DID NOT ACCOMODATE A DATA ARRAY (AND ASSCIATED NUMBER OF C OBSERVATIONS), SO THESE WERE ADDED TO THE CALL LIST. C EXAMPLE--NORMAL MAXIMUM LIKELIHOOD Y CENSOR C REFERENCE--KARL BURY, "STATISTICAL DISTRIBUTIONS IN ENGINEERING", C CAMBRIDGE UNIVERSITY PRESS, 1999, CHAPTER 10. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBUG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2003/11 C ORIGINAL VERSION--NOVEMBER 2003. C C--------------------------------------------------------------------- C DOUBLE PRECISION X(*) DOUBLE PRECISION FVEC(*) REAL XDATA(*) C DOUBLE PRECISION MU DOUBLE PRECISION SIGMA DOUBLE PRECISION DN DOUBLE PRECISION DX DOUBLE PRECISION DR DOUBLE PRECISION DSUM1 DOUBLE PRECISION DSUM2 DOUBLE PRECISION DSUM3 DOUBLE PRECISION DSUM4 DOUBLE PRECISION DHAZ DOUBLE PRECISION DPDF DOUBLE PRECISION DCDF C C--------------------------------------------------------------------- C COMMON/NORCML/IR C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C COMPUTE SOME SUMS C MU=X(1) SIGMA=X(2) DN=DBLE(NOBS) DR=DBLE(IR) C DSUM1=0.0D0 DSUM2=0.0D0 DO200I=1,IR DX=DBLE(XDATA(I)) DX=(DX - MU)/SIGMA DSUM1=DSUM1 + DX DSUM2=DSUM2 + DX*DX 200 CONTINUE C DSUM3=0.0D0 DSUM4=0.0D0 IF(IR.LT.NOBS)THEN DO300I=IR+1,NOBS DX=DBLE(XDATA(I)) DX=(DX - MU)/SIGMA CALL NODPDF(DX,DPDF) CALL NODCDF(DX,DCDF) DHAZ=DPDF/(1.0D0 - DCDF) DSUM3=DSUM3 + DHAZ DSUM4=DSUM4 + DX*DHAZ 300 CONTINUE ENDIF C FVEC(1)=DSUM1 + DSUM3 FVEC(2)=DSUM2 + DSUM4 - DR C RETURN END SUBROUTINE NORPDF(X,PDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY C FUNCTION VALUE FOR THE NORMAL (GAUSSIAN) C DISTRIBUTION WITH MEAN = 0 AND STANDARD DEVIATION = 1. C THIS DISTRIBUTION IS DEFINED FOR ALL X AND HAS C THE PROBABILITY DENSITY FUNCTION C F(X) = (1/SQRT(2*PI))*EXP(-X*X/2). C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE AT C WHICH THE PROBABILITY DENSITY C FUNCTION IS TO BE EVALUATED. C OUTPUT ARGUMENTS--PDF = THE SINGLE PRECISION PROBABILITY C DENSITY FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY C FUNCTION VALUE PDF. C PRINTING--NONE. C RESTRICTIONS--NONE. C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--EXP. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--NATIONAL BUREAU OF STANDARDS APPLIED MATHEMATICS C SERIES 55, 1964, PAGE 931, FORMULA 26.2.1. C --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE C DENSITYS--1, 1970, PAGES 40-111. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--82.6 C ORIGINAL VERSION--JUNE 1972. C UPDATED --SEPTEMBER 1975. C UPDATED --NOVEMBER 1975. C UPDATED --OCTOBER 1981. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----DATA STATEMENTS------------------------------------------------- C DATA PI/3.14159265/ C C-----START POINT----------------------------------------------------- C CONST=1/SQRT(2.0*PI) TERM=EXP(-0.5*X**2) PDF=CONST*TERM C RETURN END SUBROUTINE NORPPC(X,N,IWRITE,Y,W,MAXNYW,PPCC,IBUGA3,IERROR) C C PURPOSE--THIS SUBROUTINE COMPUTES THE NORMAL C PROBABILITY PLOT CORRELATION COEFFICIENT. C THE PROTOTYPE NORMAL DISTRIBUTION USED HEREIN C HAS MEAN = 0 AND STANDARD DEVIATION = 1. C THIS DISTRIBUTION IS DEFINED FOR ALL X AND HAS C THE PROBABILITY DENSITY FUNCTION C F(X) = (1/SQRT(2*PI)) * EXP(-X*X/2). C AS USED HEREIN, A PROBABILITY PLOT FOR A DISTRIBUTION C IS A PLOT OF THE ORDERED OBSERVATIONS VERSUS C THE ORDER STATISTIC MEDIANS FOR THAT DISTRIBUTION. C THE NORMAL PROBABILITY PLOT IS USEFUL IN C GRAPHICALLY TESTING THE COMPOSITE (THAT IS, C LOCATION AND SCALE PARAMETERS NEED NOT BE SPECIFIED) C HYPOTHESIS THAT THE UNDERLYING DISTRIBUTION C FROM WHICH THE DATA HAVE BEEN RANDOMLY DRAWN C IS THE NORMAL DISTRIBUTION. C IF THE HYPOTHESIS IS TRUE, THE PROBABILITY PLOT C SHOULD BE NEAR-LINEAR. C A MEASURE OF SUCH LINEARITY IS GIVEN BY THE C CALCULATED PROBABILITY PLOT CORRELATION COEFFICIENT. C INPUT ARGUMENTS--X = THE SINGLE PRECISION VECTOR OF C (UNSORTED OR SORTED) OBSERVATIONS. C --N = THE INTEGER NUMBER OF OBSERVATIONS C IN THE VECTOR X. C OUTPUT ARGUMENTS--PPCC = THE SINGLE PRECISION VALUE OF THE C COMPUTED NORMAL PPCC. C OUTPUT--NONE. C PRINTING--YES. C OTHER DATAPAC SUBROUTINES NEEDED--SORT, UNIMED, NORPPF. C FORTRAN LIBRARY SUBROUTINES NEEDED--SQRT. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--FILLIBEN, 'TECHNIQUES FOR TAIL LENGTH ANALYSIS', C PROCEEDINGS OF THE EIGHTEENTH CONFERENCE C ON THE DESIGN OF EXPERIMENTS IN ARMY RESEARCH C DEVELOPMENT AND TESTING (ABERDEEN, MARYLAND, C OCTOBER, 1972), PAGES 425-450. C --FILLIBEN, 'THE PROBABILITY PLOT CORRELATION COEFFICIENT C TEST FOR NORMALITY', TECHNOMETRICS, 1975, PAGES 111-117. C --RYAN AND JOINER, 'NORMAL PROBABILITY PLOTS AND TESTS C FOR NORMALITY' PENNSYLVANIA C STATE UNIVERSITY REPORT. C --HAHN AND SHAPIRO, STATISTICAL METHODS IN ENGINEERING, C 1967, PAGES 260-308. C --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE C DISTRIBUTIONS--1, 1970, PAGES 40-111. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--82.6 C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--JULY 1972. C UPDATED --JULY 1981. C UPDATED --AUGUST 1981. C UPDATED --NOVEMBER 1981. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IWRITE CHARACTER*4 IBUGA3 CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C DIMENSION X(*) DIMENSION Y(*) DIMENSION W(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C INCLUDE 'DPCOPA.INC' C ISUBN1='NORP' ISUBN2='PC ' C IERROR='NO' IUPPER=MAXOBV C SUM1=0.0 SUM2=0.0 SUM3=0.0 C IF(IBUGA3.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF NORPPC--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA3 52 FORMAT('IBUGA3 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)N 53 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') DO55I=1,N WRITE(ICOUT,56)I,X(I) 56 FORMAT('I,X(I) = ',I8,E15.7) CALL DPWRST('XXX','BUG ') 55 CONTINUE 90 CONTINUE C C ************************************************ C ** COMPUTE NORMAL ** C ** PROBABILITY PLOT CORRELATION COEFFICIENT ** C ************************************************ C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C AN=N C IF(1.LE.N.AND.N.LE.IUPPER)GOTO119 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,111) 111 FORMAT('***** ERROR IN NORPPC--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,112) 112 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,113) 113 FORMAT(' IN THE VARIABLE FOR WHICH') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,114) 114 FORMAT(' THE NORMAL PROBABILITY PLOT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,115) 115 FORMAT(' CORRELATION COEFFICIENT IS TO BE COMPUTED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,116)IUPPER 116 FORMAT(' MUST BE BETWEEN 1 AND ',I8,' (INCLUSIVELY).') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,117) 117 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,118)N 118 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8, 1'.') CALL DPWRST('XXX','BUG ') GOTO9000 119 CONTINUE C IF(N.EQ.1)GOTO120 GOTO129 120 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,121) 121 FORMAT('***** NON-FATAL DIAGNOSTIC IN NORPPC--', 1'THE 2ND INPUT ARGUMENT (N) HAS THE VALUE 1') CALL DPWRST('XXX','BUG ') PPCC=0.0 GOTO9000 129 CONTINUE C HOLD=X(1) DO135I=2,N IF(X(I).NE.HOLD)GOTO139 135 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,136)HOLD 136 FORMAT('***** NON-FATAL DIAGNOSTIC IN NORPPC--', 1'THE FIRST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7) CALL DPWRST('XXX','BUG ') PPCC=0.0 GOTO9000 139 CONTINUE C 190 CONTINUE C C ************************************************* C ** STEP 2-- ** C ** COMPUTE THE NORMAL ** C ** PROBABILITY PLOT CORRELATION COEFFICIENT. ** C ************************************************* C CALL SORT(X,N,Y) C CALL UNIMED(N,W) C DO200I=1,N CALL NORPPF(W(I),WOUT) W(I)=WOUT 200 CONTINUE C SUM1=0.0 DO300I=1,N SUM1=SUM1+Y(I) 300 CONTINUE YBAR=SUM1/AN WBAR=0.0 C SUM1=0.0 SUM2=0.0 SUM3=0.0 DO400I=1,N SUM1=SUM1+(Y(I)-YBAR)*(Y(I)-YBAR) SUM2=SUM2+(W(I)-WBAR)*(Y(I)-YBAR) SUM3=SUM3+(W(I)-WBAR)*(W(I)-WBAR) 400 CONTINUE PPCC=SUM2/SQRT(SUM3*SUM1) C C ******************************* C ** STEP 3-- ** C ** WRITE OUT A LINE ** C ** OF SUMMARY INFORMATION. ** C ******************************* C IF(IFEEDB.EQ.'OFF')GOTO890 IF(IWRITE.EQ.'OFF')GOTO890 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,811) 811 FORMAT('THE NORMAL PROBABILITY PLOT CORRELATION COEFFICIENT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,812)N,PPCC 812 FORMAT('OF THE ',I8,' OBSERVATIONS = ',E15.7) CALL DPWRST('XXX','BUG ') 890 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE IF(IBUGA3.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF NORPPC--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGA3,IERROR 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)N 9013 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)SUM1,SUM2,SUM3 9014 FORMAT('SUM1,SUM2,SUM3 = ',3E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)PPCC 9015 FORMAT('PPCC = ',E15.7) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE NODCDF(X,CDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION C FUNCTION VALUE FOR THE NORMAL (GAUSSIAN) C DISTRIBUTION WITH MEAN = 0 AND STANDARD DEVIATION = 1. C THIS DISTRIBUTION IS DEFINED FOR ALL X AND HAS C THE PROBABILITY DENSITY FUNCTION C F(X) = (1/SQRT(2*PI))*EXP(-X*X/2). C THIS IS THE DOUBLE PRECISION VERSION. C INPUT ARGUMENTS--X = THE DOUBLE PRECISION VALUE AT C WHICH THE CUMULATIVE DISTRIBUTION C FUNCTION IS TO BE EVALUATED. C OUTPUT ARGUMENTS--CDF = THE DOUBLE PRECISION CUMULATIVE C DISTRIBUTION FUNCTION VALUE. C OUTPUT--THE DOUBLE PRECISION CUMULATIVE DISTRIBUTION C FUNCTION VALUE CDF. C PRINTING--NONE. C RESTRICTIONS--NONE. C OTHER DATAPAC SUBROUTINES NEEDED--ALNORM. C FORTRAN LIBRARY SUBROUTINES NEEDED--EXP. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--NATIONAL BUREAU OF STANDARDS APPLIED MATHEMATICS C SERIES 55, 1964, PAGE 932, FORMULA 26.2.17. C --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE C DISTRIBUTIONS--1, 1970, PAGES 40-111. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--97.8 C ORIGINAL VERSION--AUGUST 1997. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C DOUBLE PRECISION X DOUBLE PRECISION CDF DOUBLE PRECISION ALNORM LOGICAL UPPER C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IF(X.LT.0.0D0)THEN UPPER=.FALSE. CDF=ALNORM(X,UPPER) ELSEIF(X.GT.0.0D0)THEN UPPER=.TRUE. CDF=1.0D0 - ALNORM(X,UPPER) ELSE CDF=0.5D0 ENDIF C RETURN END SUBROUTINE NODPDF(Z, PDF) CCCCC SUBROUTINE NODPDF(Z, P, Q, PDF) C C Normal distribution probabilities accurate to 1.e-15. C Z = no. of standard deviations from the mean. C P, Q = probabilities to the left & right of Z. P + Q = 1. C PDF = the probability density. C C Based upon algorithm 5666 for the error function, from: C Hart, J.F. et al, 'Computer Approximations', Wiley 1968 C C Programmer: Alan Miller C C Latest revision - 30 March 1986 C IMPLICIT DOUBLE PRECISION (A-H, O-Z) DATA P0, P1, P2, P3, P4, P5, P6/220.20 68679 12376 1D0, * 221.21 35961 69931 1D0, 112.07 92914 97870 9D0, * 33.912 86607 83830 0D0, 6.3739 62203 53165 0D0, * .70038 30644 43688 1D0, .35262 49659 98910 9D-01/, * Q0, Q1, Q2, Q3, Q4, Q5, Q6, Q7/440.41 37358 24752 2D0, * 793.82 65125 19948 4D0, 637.33 36333 78831 1D0, * 296.56 42487 79673 7D0, 86.780 73220 29460 8D0, * 16.064 17757 92069 5D0, 1.7556 67163 18264 2D0, * .88388 34764 83184 4D-1/, * CUTOFF/7.071D0/, ROOT2PI/2.5066 28274 63100 1D0/ C ZABS = ABS(Z) C C |Z| > 37. C IF (ZABS .GT. 37.D0) THEN PDF = 0.D0 IF (Z .GT. 0.D0) THEN P = 1.D0 Q = 0.D0 ELSE P = 0.D0 Q = 1.D0 END IF RETURN END IF C C |Z| <= 37. C EXPNTL = EXP(-0.5D0*ZABS**2) PDF = EXPNTL/ROOT2PI C C |Z| < CUTOFF = 10/sqrt(2). C IF (ZABS .LT. CUTOFF) THEN P = EXPNTL*((((((P6*ZABS + P5)*ZABS + P4)*ZABS + P3)*ZABS + * P2)*ZABS + P1)*ZABS + P0)/(((((((Q7*ZABS + Q6)*ZABS + * Q5)*ZABS + Q4)*ZABS + Q3)*ZABS + Q2)*ZABS + Q1)*ZABS + * Q0) C C |Z| >= CUTOFF. C ELSE P = PDF/(ZABS + 1.D0/(ZABS + 2.D0/(ZABS + 3.D0/(ZABS + 4.D0/ * (ZABS + 0.65D0))))) END IF C IF (Z .LT. 0.D0) THEN Q = 1.D0 - P ELSE Q = P P = 1.D0 - Q END IF RETURN END SUBROUTINE NODPPF(P,PPF) C C PURPOSE--THIS SUBROUTINE COMPUTES C THE PERCENT POINT C FUNCTION VALUE FOR THE NORMAL (GAUSSIAN) C DISTRIBUTION WITH MEAN = 0 AND STANDARD DEVIATION = 1. C THIS DISTRIBUTION IS DEFINED FOR ALL X AND HAS C THE PROBABILITY DENSITY FUNCTION C F(X) = (1/SQRT(2*PI))*EXP(-X*X/2). C NOTE THAT THE PERCENT POINT FUNCTION OF A DISTRIBUTION C IS IDENTICALLY THE SAME AS THE INVERSE CUMULATIVE C DISTRIBUTION FUNCTION OF THE DISTRIBUTION. C NOTE--THIS ROUTINE IS IDENTICAL IN LOGIC TO NORPPF C EXCEPT NORPPF HAS INTERNAL CALUCLATIONS C IN SINGLE PRECISION, C WHILE NODPPF HAS INTERNAL CALUCLATIONS C IN DOUBLE PRECISION. C INPUT ARGUMENTS--P = THE SINGLE PRECISION VALUE C (BETWEEN 0.0 AND 1.0) C AT WHICH THE PERCENT POINT C FUNCTION IS TO BE EVALUATED. C OUTPUT ARGUMENTS--PPF = THE SINGLE PRECISION PERCENT C POINT FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION PERCENT POINT C FUNCTION VALUE PPF. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--P SHOULD BE BETWEEN 0.0 AND 1.0, EXCLUSIVELY. C C ALGORITHM AS241 APPL. STATIST. (1988) VOL. 37, NO. 3 C C Produces the normal deviate Z corresponding to a given lower C tail area of P; Z is accurate to about 1 part in 10**16. C C The hash sums below are the sums of the mantissas of the C coefficients. They are included for use in checking C transcription. C C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C VERSION NUMBER--95.7 C ORIGINAL VERSION--JULY 1995. C UPDATED --AUGUST 1997. REPLACE CURRENT ALGORITHM WITH C AS 243 (HAS HIGHER ACCURACY) C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION P DOUBLE PRECISION PPF DOUBLE PRECISION ZERO, ONE, HALF, SPLIT1, SPLIT2, CONST1, * CONST2, A0, A1, A2, A3, A4, A5, A6, A7, B1, B2, B3, * B4, B5, B6, B7, * C0, C1, C2, C3, C4, C5, C6, C7, D1, D2, D3, D4, D5, * D6, D7, E0, E1, E2, E3, E4, E5, E6, E7, F1, F2, F3, * F4, F5, F6, F7, Q, R PARAMETER (ZERO = 0.D0, ONE = 1.D0, HALF = 0.5D0, * SPLIT1 = 0.425D0, SPLIT2 = 5.D0, * CONST1 = 0.180625D0, CONST2 = 1.6D0) C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C Coefficients for P close to 0.5 C PARAMETER (A0 = 3.38713 28727 96366 6080D0, * A1 = 1.33141 66789 17843 7745D+2, * A2 = 1.97159 09503 06551 4427D+3, * A3 = 1.37316 93765 50946 1125D+4, * A4 = 4.59219 53931 54987 1457D+4, * A5 = 6.72657 70927 00870 0853D+4, * A6 = 3.34305 75583 58812 8105D+4, * A7 = 2.50908 09287 30122 6727D+3, * B1 = 4.23133 30701 60091 1252D+1, * B2 = 6.87187 00749 20579 0830D+2, * B3 = 5.39419 60214 24751 1077D+3, * B4 = 2.12137 94301 58659 5867D+4, * B5 = 3.93078 95800 09271 0610D+4, * B6 = 2.87290 85735 72194 2674D+4, * B7 = 5.22649 52788 52854 5610D+3) C HASH SUM AB 55.88319 28806 14901 4439 C C Coefficients for P not close to 0, 0.5 or 1. C PARAMETER (C0 = 1.42343 71107 49683 57734D0, * C1 = 4.63033 78461 56545 29590D0, * C2 = 5.76949 72214 60691 40550D0, * C3 = 3.64784 83247 63204 60504D0, * C4 = 1.27045 82524 52368 38258D0, * C5 = 2.41780 72517 74506 11770D-1, * C6 = 2.27238 44989 26918 45833D-2, * C7 = 7.74545 01427 83414 07640D-4, * D1 = 2.05319 16266 37758 82187D0, * D2 = 1.67638 48301 83803 84940D0, * D3 = 6.89767 33498 51000 04550D-1, * D4 = 1.48103 97642 74800 74590D-1, * D5 = 1.51986 66563 61645 71966D-2, * D6 = 5.47593 80849 95344 94600D-4, * D7 = 1.05075 00716 44416 84324D-9) C HASH SUM CD 49.33206 50330 16102 89036 C C Coefficients for P near 0 or 1. C PARAMETER (E0 = 6.65790 46435 01103 77720D0, * E1 = 5.46378 49111 64114 36990D0, * E2 = 1.78482 65399 17291 33580D0, * E3 = 2.96560 57182 85048 91230D-1, * E4 = 2.65321 89526 57612 30930D-2, * E5 = 1.24266 09473 88078 43860D-3, * E6 = 2.71155 55687 43487 57815D-5, * E7 = 2.01033 43992 92288 13265D-7, * F1 = 5.99832 20655 58879 37690D-1, * F2 = 1.36929 88092 27358 05310D-1, * F3 = 1.48753 61290 85061 48525D-2, * F4 = 7.86869 13114 56132 59100D-4, * F5 = 1.84631 83175 10054 68180D-5, * F6 = 1.42151 17583 16445 88870D-7, * F7 = 2.04426 31033 89939 78564D-15) C HASH SUM EF 47.52583 31754 92896 71629 C C-----START POINT----------------------------------------------------- C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C PPF=0.0D0 IF(P.LE.0.0D0.OR.P.GE.1.0D0)GOTO50 GOTO90 50 WRITE(ICOUT,1) 1 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ', 1'NODPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)P 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',D15.7,'*****') CALL DPWRST('XXX','BUG ') GOTO9000 90 CONTINUE C C ************************************************ C ** STEP 2-- ** C ** COMPUTE THE PERCENT POINT FUNCTION VALUE ** C ************************************************ C IF(P.EQ.0.5D0)THEN PPF=0.0D0 GOTO9000 ENDIF C Q = P - HALF IF (ABS(Q) .LE. SPLIT1) THEN R = CONST1 - Q * Q PPF = Q * (((((((A7 * R + A6) * R + A5) * R + A4) * R + A3) * * R + A2) * R + A1) * R + A0) / * (((((((B7 * R + B6) * R + B5) * R + B4) * R + B3) * * R + B2) * R + B1) * R + ONE) RETURN ELSE IF (Q .LT. ZERO) THEN R = P ELSE R = ONE - P END IF IF (R .LE. ZERO) THEN WRITE(ICOUT,47) CALL DPWRST('XXX','BUG ') PPF = ZERO RETURN END IF 47 FORMAT('***** INTERNAL ERROR FROM NODPPF ******') R = SQRT(-LOG(R)) IF (R .LE. SPLIT2) THEN R = R - CONST2 PPF = (((((((C7 * R + C6) * R + C5) * R + C4) * R + C3) * * R + C2) * R + C1) * R + C0) / * (((((((D7 * R + D6) * R + D5) * R + D4) * R + D3) * * R + D2) * R + D1) * R + ONE) ELSE R = R - SPLIT2 PPF = (((((((E7 * R + E6) * R + E5) * R + E4) * R + E3) * * R + E2) * R + E1) * R + E0) / * (((((((F7 * R + F6) * R + F5) * R + F4) * R + F3) * * R + F2) * R + F1) * R + ONE) END IF IF (Q .LT. ZERO) PPF = - PPF RETURN END IF C 9000 CONTINUE RETURN END SUBROUTINE NORPPF(P,PPF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT C FUNCTION VALUE FOR THE NORMAL (GAUSSIAN) C DISTRIBUTION WITH MEAN = 0 AND STANDARD DEVIATION = 1. C THIS DISTRIBUTION IS DEFINED FOR ALL X AND HAS C THE PROBABILITY DENSITY FUNCTION C F(X) = (1/SQRT(2*PI))*EXP(-X*X/2). C NOTE THAT THE PERCENT POINT FUNCTION OF A DISTRIBUTION C IS IDENTICALLY THE SAME AS THE INVERSE CUMULATIVE C DISTRIBUTION FUNCTION OF THE DISTRIBUTION. C INPUT ARGUMENTS--P = THE SINGLE PRECISION VALUE C (BETWEEN 0.0 AND 1.0) C AT WHICH THE PERCENT POINT C FUNCTION IS TO BE EVALUATED. C OUTPUT ARGUMENTS--PPF = THE SINGLE PRECISION PERCENT C POINT FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION PERCENT POINT C FUNCTION VALUE PPF. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--P SHOULD BE BETWEEN 0.0 AND 1.0, EXCLUSIVELY. C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--SQRT, ALOG. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--ODEH AND EVANS, THE PERCENTAGE POINTS C OF THE NORMAL DISTRIBUTION, ALGORTIHM 70, C APPLIED STATISTICS, 1974, PAGES 96-97. C --EVANS, ALGORITHMS FOR MINIMAL DEGREE C POLYNOMIAL AND RATIONAL APPROXIMATION, C M. SC. THESIS, 1972, UNIVERSITY C OF VICTORIA, B. C., CANADA. C --HASTINGS, APPROXIMATIONS FOR DIGITAL C COMPUTERS, 1955, PAGES 113, 191, 192. C --NATIONAL BUREAU OF STANDARDS APPLIED MATHEMATICS C SERIES 55, 1964, PAGE 933, FORMULA 26.2.23. C --FILLIBEN, SIMPLE AND ROBUST LINEAR ESTIMATION C OF THE LOCATION PARAMETER OF A SYMMETRIC C DISTRIBUTION (UNPUBLISHED PH.D. DISSERTATION, C PRINCETON UNIVERSITY), 1969, PAGES 21-44, 229-231. C --FILLIBEN, 'THE PERCENT POINT FUNCTION', C (UNPUBLISHED MANUSCRIPT), 1970, PAGES 28-31. C --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE C DISTRIBUTIONS--1, 1970, PAGES 40-111. C --THE KELLEY STATISTICAL TABLES, 1948. C --OWEN, HANDBOOK OF STATISTICAL TABLES, C 1962, PAGES 3-16. C --PEARSON AND HARTLEY, BIOMETRIKA TABLES C FOR STATISTICIANS, VOLUME 1, 1954, C PAGES 104-113. C COMMENTS--THE CODING AS PRESENTED BELOW C IS ESSENTIALLY IDENTICAL TO THAT C PRESENTED BY ODEH AND EVANS C AS ALGORTIHM 70 OF APPLIED STATISTICS. C THE PRESENT AUTHOR HAS MODIFIED THE C ORIGINAL ODEH AND EVANS CODE WITH ONLY C MINOR STYLISTIC CHANGES. C --AS POINTED OUT BY ODEH AND EVANS C IN APPLIED STATISTICS, C THEIR ALGORITHM REPRESENTES A C SUBSTANTIAL IMPROVEMENT OVER THE C PREVIOUSLY EMPLOYED C HASTINGS APPROXIMATION FOR THE C NORMAL PERCENT POINT FUNCTION-- C THE ACCURACY OF APPROXIMATION C BEING IMPROVED FROM 4.5*(10**-4) C TO 1.5*(10**-8). C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--82.6 C ORIGINAL VERSION--JUNE 1972. C UPDATED --SEPTEMBER 1975. C UPDATED --NOVEMBER 1975. C UPDATED --OCTOBER 1976. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----DATA STATEMENTS------------------------------------------------- C DATA P0,P1,P2,P3,P4 1/-.322232431088,-1.0, 1 -.342242088547,-.204231210245E-1, 1 -.453642210148E-4/ DATA Q0,Q1,Q2,Q3,Q4 1/.993484626060E-1,.588581570495, 1 .531103462366,.103537752850, 1 .38560700634E-2/ C C-----START POINT----------------------------------------------------- C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C IF(P.LE.0.0.OR.P.GE.1.0)GOTO50 GOTO90 50 WRITE(ICOUT,1) 1 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ', 1'NORPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)P 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,'*****') CALL DPWRST('XXX','BUG ') GOTO9000 90 CONTINUE C C ************************************************ C ** STEP 2-- ** C ** COMPUTE THE PERCENT POINT FUNCTION VALUE ** C ************************************************ C IF(P.EQ.0.5)GOTO120 GOTO129 120 CONTINUE PPF=0.0 GOTO9000 129 CONTINUE C PHOLD=P R=P IF(PHOLD.GT.0.5)R=1.0-R T=SQRT(-2.0*ALOG(R)) ANUM=((((T*P4+P3)*T+P2)*T+P1)*T+P0) ADEN=((((T*Q4+Q3)*T+Q2)*T+Q1)*T+Q0) PPF=T+(ANUM/ADEN) IF(PHOLD.LT.0.5)PPF=-PPF GOTO9000 C 9000 CONTINUE RETURN END SUBROUTINE NORRAN(N,ISEED,X) C C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N C FROM THE THE NORMAL (GAUSSIAN) C DISTRIBUTION WITH MEAN = 0 AND STANDARD DEVIATION = 1. C THIS DISTRIBUTION IS DEFINED FOR ALL X AND HAS C THE PROBABILITY DENSITY FUNCTION C F(X) = (1/SQRT(2*PI))*EXP(-X*X/2). C INPUT ARGUMENTS--N = THE DESIRED INTEGER NUMBER C OF RANDOM NUMBERS TO BE C GENERATED. C OUTPUT ARGUMENTS--X = A SINGLE PRECISION VECTOR C (OF DIMENSION AT LEAST N) C INTO WHICH THE GENERATED C RANDOM SAMPLE WILL BE PLACED. C OUTPUT--A RANDOM SAMPLE OF SIZE N C FROM THE NORMAL DISTRIBUTION C WITH MEAN = 0 AND STANDARD DEVIATION = 1. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C OTHER DATAPAC SUBROUTINES NEEDED--UNIRAN. C FORTRAN LIBRARY SUBROUTINES NEEDED--ALOG, SQRT, SIN, COS. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C METHOD--BOX-MULLER ALGORITHM. C REFERENCES--BOX AND MULLER, 'A NOTE ON THE GENERATION C OF RANDOM NORMAL DEVIATES', JOURNAL OF THE C ASSOCIATION FOR COMPUTING MACHINERY, 1958, C PAGES 610-611. C --TOCHER, THE ART OF SIMULATION, C 1963, PAGES 33-34. C --HAMMERSLEY AND HANDSCOMB, MONTE CARLO METHODS, C 1964, PAGE 39. C --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE C DISTRIBUTIONS--1, 1970, PAGES 40-111. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--82.6 C ORIGINAL VERSION--JUNE 1972. C UPDATED --SEPTEMBER 1975. C UPDATED --NOVEMBER 1975. C UPDATED --JULY 1976. C UPDATED --DECEMBER 1981. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DIMENSION X(*) DIMENSION Y(2) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----DATA STATEMENTS------------------------------------------------- C DATA PI/3.14159265359/ C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(N.LT.1)GOTO50 GOTO90 50 WRITE(ICOUT, 5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)N CALL DPWRST('XXX','BUG ') RETURN 90 CONTINUE 5 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ', 1'NORRAN SUBROUTINE IS NON-POSITIVE *****') 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****') C C GENERATE N UNIFORM (0,1) RANDOM NUMBERS; C THEN GENERATE 2 ADDITIONAL UNIFORM (0,1) RANDOM NUMBERS C (TO BE USED BELOW IN FORMING THE N-TH NORMAL C RANDOM NUMBER WHEN THE DESIRED SAMPLE SIZE N C HAPPENS TO BE ODD). C CALL UNIRAN(N,ISEED,X) CALL UNIRAN(2,ISEED,Y) C C GENERATE N NORMAL RANDOM NUMBERS C USING THE BOX-MULLER METHOD. C DO200I=1,N,2 IP1=I+1 U1=X(I) IF(I.EQ.N)GOTO210 U2=X(IP1) GOTO220 210 U2=Y(2) 220 ARG1=-2.0*ALOG(U1) ARG2=2.0*PI*U2 SQRT1=SQRT(ARG1) Z1=SQRT1*COS(ARG2) Z2=SQRT1*SIN(ARG2) X(I)=Z1 IF(I.EQ.N)GOTO200 X(IP1)=Z2 200 CONTINUE C RETURN END SUBROUTINE NORSF(P,SF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE SPARSITY C FUNCTION VALUE FOR THE NORMAL (GAUSSIAN) C DISTRIBUTION WITH MEAN = 0 AND STANDARD DEVIATION = 1. C THIS DISTRIBUTION IS DEFINED FOR ALL X AND HAS C THE PROBABILITY DENSITY FUNCTION C F(X) = (1/SQRT(2*PI))*EXP(-X*X/2). C NOTE THAT THE SPARSITY FUNCTION OF A DISTRIBUTION C IS THE DERIVATIVE OF THE PERCENT POINT FUNCTION, C AND ALSO IS THE RECIPROCAL OF THE PROBABILITY C DENSITY FUNCTION (BUT IN UNITS OF P RATHER THAN X). C INPUT ARGUMENTS--P = THE SINGLE PRECISION VALUE C (BETWEEN 0.0 AND 1.0) C AT WHICH THE SPARSITY C FUNCTION IS TO BE EVALUATED. C OUTPUT ARGUMENTS--SF = THE SINGLE PRECISION C SPARSITY FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION SPARSITY C FUNCTION VALUE SF. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--P SHOULD BE BETWEEN 0.0 AND 1.0, EXCLUSIVELY. C OTHER DATAPAC SUBROUTINES NEEDED--NORPPF. C FORTRAN LIBRARY SUBROUTINES NEEDED--EXP. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN. C REFERENCES--FILLIBEN, SIMPLE AND ROBUST LINEAR ESTIMATION C OF THE LOCATION PARAMETER OF A SYMMETRIC C DISTRIBUTION (UNPUBLISHED PH.D. DISSERTATION, C PRINCETON UNIVERSITY), 1969, PAGES 21-44, 229-231. C --FILLIBEN, 'THE PERCENT POINT FUNCTION', C (UNPUBLISHED MANUSCRIPT), 1970, PAGES 28-31. C --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE C DISTRIBUTIONS--1, 1970, PAGES 40-111. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING LABORATORY (205.03) C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE: 301-921-2315 C ORIGINAL VERSION--APRIL 1994. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C--------------------------------------------------------------------- C DATA C/.3989422804/ C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(P.LE.0.0.OR.P.GE.1.0)GOTO50 GOTO90 50 CONTINUE WRITE(ICOUT,1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)P CALL DPWRST('XXX','BUG ') RETURN 90 CONTINUE 1 FORMAT( 1'***** FATAL ERROR--THE FIRST INPUT ARGUMENT TO THE NORSF') 2 FORMAT( 1'SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL *****') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') C C-----START POINT----------------------------------------------------- C CALL NORPPF(P,PPF) PDF=C*EXP(-(PPF*PPF)/2.0) SF=1.0/PDF C RETURN END SUBROUTINE NRMLAG(X,AN,ALN) C C PURPOSE--THIS SUBROUTINE COMPUTES THE NORMALIZED LAGUERRE C POLYNOMIAL OF ORDER N. C INPUT ARGUMENTS--X = THE SINGLE PRECISION INPUT ARGUMENT C AN = THE SINGLE PRECISION VALUE FOR THE C ORDER OF THE FUNCTION (SHOULD BE C NON-NEGATIVE ORDER) C OUTPUT ARGUMENTS--ALN = THE SINGLE PRECISION VALUE OF THE C NORMALIZED LAGUERRE POLYNOMIAL. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS-- C OTHER DATAPAC SUBROUTINES NEEDED--NONE C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE C MODE OF INTERNAL OPERATIONS--SOME DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN. C REFERENCES--"HANDBOOK OF MATHEMATICAL FUNCTIONS, AMS 55", C ABRAMOWITZ AND STEGUM. C USE FOLLOWING RECURRENCE FORMULA: C L(N+1) = (1+2*N-X)*L(N)-N**2*L(N-1) C FIRST FEW TERMS ARE FROM TABLE 22.10 OF ABRAMOWITZ C AND STEGUM. C NORMALIZED LAGUERRE IS LAGUERRE SCALED BY N! C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING LABORATORY (205.03) C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE: 301-975-2855 C ORIGINAL VERSION--JULY 1995. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 ICOUTINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,ICOUTINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C DOUBLE PRECISION DX DOUBLE PRECISION DN, DN2 DOUBLE PRECISION DLN, DLN1, DLN2 C C-----START POINT----------------------------------------------------- C IF(X.LT.0.0)THEN WRITE(ICOUT,4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF 4 FORMAT('***** NON-FATAL DIAGNOSTIC--THE 1ST INPUT ARGUMENT ', 1'TO THE NRMLAG SUBROUTINE IS NEGATIVE *****') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') N=INT(AN+0.5) IF(N.LT.0)THEN WRITE(ICOUT,6) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)N CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF 6 FORMAT('***** NON-FATAL DIAGNOSTIC--THE 2ND INPUT ARGUMENT ', 1'TO THE NRMLAGRRE SUBROUTINE IS NEGATIVE *****') 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****') C DX=DBLE(X) DN=DBLE(N) C IF(N.LE.0)THEN ALN=1.0 ELSEIF(N.EQ.1)THEN ALN=-X+1.0 ELSEIF(N.EQ.2)THEN ALN=X**2 - 4.0*X + 2.0 ELSEIF(N.EQ.3)THEN DLN=-DX**3 + 9.0D0*DX**2 -18.0D0*DX + 6.0D0 ALN=REAL(DLN) ELSE DLN1=-DX**3 + 9.0D0*DX**2 -18.0D0*DX + 6.0D0 DLN2=DX**2 - 4.0D0*DX + 2.0D0 DO1000I=4,N DN2=DBLE(I)-1.0D0 DLN=(1.0D0+2.0D0*DN2-DX)*DLN1 - DN2**2*DLN2 DLN2=DLN1 DLN1=DLN 1000 CONTINUE ALN=REAL(DLN) ENDIF C 9999 CONTINUE RETURN END SUBROUTINE OCCPDF(X,B,C,PDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY C FUNCTION VALUE FOR THE CLASICAL OCCUPANCY C DISTRIBUTION ON THE INTERVAL (0,C). C THIS DISTRIBUTION HAS MEAN = (C-1)**B*C**(1-B) C AND STANDARD DEVIATION = (C-1)*(C-2)**B*C**(1-B) + C (C-1)**B*C**(1-B) - C (C-1)**(2*B)*C**(2-2*B) C THIS DISTRIBUTION HAS THE PROBABILITY C MASS FUNCTION: C C P(X;C,B) = SUM[i=0 to C-X][(-1)**i*(X+i i)* C (C X+i)*((C-X-i)/C)**B C = SUM[i=X to C][(-1)**(i-X)*C!*((C-i)/C)**B/ C (X!*(i-X)!(C-i)! C = C!*S(B,C-X)/(X!*C**B) C X = 0, 1, ..., C C WITH S DENOTING STERLING'S NUMBER OF THE SECOND C KIND. C C GIVEN C CELLS AND B BALLS, THERE ARE C**B WAYS THE C BALLS CAN BE PLACED IN THE C CELLS (ASSUMMING C THAT ALL PLACEMENTS ARE EQUI-PROBABLE). THE C CLASSICAL OCCUPANCY DISTRIBUTION IS THE DISTRIBUTION C OF THE NUMBER OF EMPTY CELLS. C C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE AT C WHICH THE PROBABILITY DENSITY C FUNCTION IS TO BE EVALUATED. C C = THE INTEGER VALUE THAT SPECIFIES C THE FIRST SHAPE PARAMETER (THE C NUMBER OF CELLS) C B = THE INTEGER VALUE THAT SPECIFIES C THE SECOND SHAPE PARAMETER (THE C NUMBER OF BALLS) C OUTPUT ARGUMENTS--PDF = THE SINGLE PRECISION PROBABILITY C DENSITY FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY C FUNCTION VALUE PDF. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--X SHOULD BE BETWEEN 0 AND C, INCLUSIVELY. C OTHER DATAPAC SUBROUTINES NEEDED--DLNGAMM. C FORTRAN LIBRARY SUBROUTINES NEEDED--EXP. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN. C REFERENCES--JOHNSON, KOTZ, AND KEMP (1992). "UNIVARIATE C DISCRETE DISTRIBUTIONS" SECOND EDITION, C PAGES 414-416. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE: 301-975-2855 C ORIGINAL VERSION--JUNE 2006. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C INTEGER B INTEGER C C DOUBLE PRECISION DX DOUBLE PRECISION DB DOUBLE PRECISION DC DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 DOUBLE PRECISION DTERM3 DOUBLE PRECISION DTERM4 DOUBLE PRECISION DSUM1 DOUBLE PRECISION DSUM2 DOUBLE PRECISION DJ DOUBLE PRECISION DSIGN DOUBLE PRECISION DPDF DOUBLE PRECISION DLNGAM C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C--------------------------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C PDF=0.0 C IF(C.LT.1)THEN WRITE(ICOUT,12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)C CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF 12 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO ', 1 'OCCPDF IS LESS THAN 1.') C IF(B.LT.1)THEN WRITE(ICOUT,22) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)B CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF 22 FORMAT('***** ERROR--THE THIRD INPUT ARGUMENT TO ', 1 'OCCPDF IS LESS THAN 1.') C IX=INT(X+0.5) IF(IX.LT.0 .OR. IX.GT.C)THEN WRITE(ICOUT,2)C CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)IX CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF 2 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO ', 1 'OCCPDF IS OUTSIDE THE (0,',I8,') INTERVAL') C 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8) C C-----START POINT----------------------------------------------------- C DX=DBLE(IX) DB=DBLE(B) DC=DBLE(C) DPDF=0.0D0 C C NOTE: JOHNSON, KOTZ, AND KEMP PROVIDE 3 DIFFERENT C SUMMATION FORMULAS. THESE SEEM ACCURATE UP TO C ABOUT N = 50. C CCCCC DO100J=IX,C CCCCC DJ=DBLE(J) CCCCC DSIGN=(-1.0D0)**(DJ-DX) CCCCC IF(J.EQ.C)THEN CCCCC CONTINUE CCCCC ELSE CCCCC DTERM1=DLNGAM(DC+1.0D0) - DLNGAM(DX+1.0D0) - CCCCC1 DLNGAM(DJ-DX+1.0D0) - DLNGAM(DC-DJ+1.0D0) + CCCCC1 DB*DLOG((DC-DJ)/DC) CCCCC DTERM1=DEXP(DTERM1) CCCCC DPDF=DPDF + DSIGN*DTERM1 CCCCC ENDIF CC100 CONTINUE CCCCC PDF=REAL(DPDF) C CCCCC DTERM1=DLNGAM(DC+1.0D0) - DLNGAM(DX+1.0D0) - DLNGAM(DC-DX+1.0D0) C CCCCC DSUM1=0.0D0 CCCCC DO200J=0,C-IX,2 CCCCC DJ=DBLE(J) CCCCC DTERM2=DLNGAM(DC-DX+1.0D0) - DLNGAM(DJ+1.0D0) - CCCCC1 DLNGAM(DC-DX-DJ+1.0D0) CCCCC DTERM3=DB*DLOG(1.0D0 - (DX+DJ)/DC) CCCCC DTERM4=DEXP(DTERM2 + DTERM3) CCCCC DSUM1=DSUM1 + DTERM4 CC200 CONTINUE C CCCCC DSUM2=0.0D0 CCCCC DO400J=1,C-IX,2 CCCCC DJ=DBLE(J) CCCCC DTERM2=DLNGAM(DC-DX+1.0D0) - DLNGAM(DJ+1.0D0) - CCCCC1 DLNGAM(DC-DX-DJ+1.0D0) CCCCC DTERM3=DB*DLOG(1.0D0 - (DX+DJ)/DC) CCCCC DTERM4=DEXP(DTERM2 + DTERM3) CCCCC DSUM2=DSUM2 + DTERM4 CC400 CONTINUE C CCCCC DSUM1=DSUM1 - DSUM2 CCCCC DPDF=DEXP(DTERM1 + DLOG(DSUM1)) CCCCC PDF=REAL(DPDF) C 9000 CONTINUE RETURN END subroutine onestp(y,n,np,ns,nt,nl,isdeg,itdeg,ildeg,nsjump,ntjump, &nljump,ni,userw,rw,season,trend,work) c c This routine is part of the Bill Cleveland seasonal loess c program. c integer n,ni,np,ns,nt,nsjump,ntjump,nl,nljump,isdeg,itdeg,ildeg real y(n),rw(n),season(n),trend(n),work(n+2*np,5) logical userw do 23089 j = 1,ni do 23091 i = 1,n work(i,1) = y(i)-trend(i) 23091 continue call ss(work(1,1),n,np,ns,isdeg,nsjump,userw,rw,work(1,2),work(1, &3),work(1,4),work(1,5),season) call fts(work(1,2),n+2*np,np,work(1,3),work(1,1)) call ess(work(1,3),n,nl,ildeg,nljump,.false.,work(1,4),work(1,1), &work(1,5)) do 23093 i = 1,n season(i) = work(np+i,2)-work(i,1) 23093 continue do 23095 i = 1,n work(i,1) = y(i)-season(i) 23095 continue call ess(work(1,1),n,nt,itdeg,ntjump,userw,rw,trend,work(1,3)) 23089 continue return end SUBROUTINE OPTCHK(N,X,TYPSIZ,SX,FSCALE,GRADTL,ITNLIM,NDIGIT,EPSM, + DLT,METHOD,IEXP,IAGFLG,IAHFLG,STEPMX,MSG,IPRTMP) IMPLICIT DOUBLE PRECISION (A-H,O-Z) C C PURPOSE C ------- C CHECK INPUT FOR REASONABLENESS C C PARAMETERS C ---------- C N --> DIMENSION OF PROBLEM C X(N) --> ON ENTRY, ESTIMATE TO ROOT OF FCN C TYPSIZ(N) <--> TYPICAL SIZE OF EACH COMPONENT OF X C SX(N) <-- DIAGONAL SCALING MATRIX FOR X C FSCALE <--> ESTIMATE OF SCALE OF OBJECTIVE FUNCTION FCN C GRADTL --> TOLERANCE AT WHICH GRADIENT CONSIDERED CLOSE C ENOUGH TO ZERO TO TERMINATE ALGORITHM C ITNLIM <--> MAXIMUM NUMBER OF ALLOWABLE ITERATIONS C NDIGIT <--> NUMBER OF GOOD DIGITS IN OPTIMIZATION FUNCTION FCN C EPSM --> MACHINE EPSILON C DLT <--> TRUST REGION RADIUS C METHOD <--> ALGORITHM INDICATOR C IEXP <--> EXPENSE FLAG C IAGFLG <--> =1 IF ANALYTIC GRADIENT SUPPLIED C IAHFLG <--> =1 IF ANALYTIC HESSIAN SUPPLIED C STEPMX <--> MAXIMUM STEP SIZE C MSG <--> MESSAGE AND ERROR CODE C IPR --> DEVICE TO WHICH TO SEND OUTPUT C DIMENSION X(N),TYPSIZ(N),SX(N) C C-----COMMON VARIABLES (GENERAL)-------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT REAL CPUMIN, CPUMAX C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C C CHECK THAT PARAMETERS ONLY TAKE ON ACCEPTABLE VALUES. C IF NOT, SET THEM TO DEFAULT VALUES. IF(METHOD.LT.1 .OR. METHOD.GT.3) METHOD=1 IF(IAGFLG.NE.1) IAGFLG=0 IF(IAHFLG.NE.1) IAHFLG=0 IF(IEXP.NE.0) IEXP=1 IF(MOD(MSG/2,2).EQ.1 .AND. IAGFLG.EQ.0) GO TO 830 IF(MOD(MSG/4,2).EQ.1 .AND. IAHFLG.EQ.0) GO TO 835 C C CHECK DIMENSION OF PROBLEM C IF(N.LE.0) GO TO 805 IF(N.EQ.1 .AND. MOD(MSG,2).EQ.0) GO TO 810 C C COMPUTE SCALE MATRIX C DO 10 I=1,N IF(TYPSIZ(I).EQ.0.) TYPSIZ(I)=1.0 IF(TYPSIZ(I).LT.0.) TYPSIZ(I)=-TYPSIZ(I) SX(I)=1.0/TYPSIZ(I) 10 CONTINUE C C CHECK MAXIMUM STEP SIZE C IF (STEPMX .GT. 0.0) GO TO 20 STPSIZ = 0.0 DO 15 I = 1, N STPSIZ = STPSIZ + X(I)*X(I)*SX(I)*SX(I) 15 CONTINUE STPSIZ = SQRT(STPSIZ) STEPMX = MAX(1.0E3*STPSIZ, 1.0D3) 20 CONTINUE C CHECK FUNCTION SCALE IF(FSCALE.EQ.0.) FSCALE=1.0 IF(FSCALE.LT.0.) FSCALE=-FSCALE C C CHECK GRADIENT TOLERANCE IF(GRADTL.LT.0.) GO TO 815 C C CHECK ITERATION LIMIT IF(ITNLIM.LE.0) GO TO 820 C C CHECK NUMBER OF DIGITS OF ACCURACY IN FUNCTION FCN IF(NDIGIT.EQ.0) GO TO 825 IF(NDIGIT.LT.0) NDIGIT=-LOG10(EPSM) C C CHECK TRUST REGION RADIUS IF(DLT.LE.0.) DLT=-1.0 IF (DLT .GT. STEPMX) DLT = STEPMX RETURN C C ERROR EXITS C 805 WRITE(ICOUT,901) N CALL DPWRST('XXX','BUG ') MSG=-1 GO TO 895 810 WRITE(ICOUT,902) CALL DPWRST('XXX','BUG ') MSG=-2 GO TO 895 815 WRITE(ICOUT,903) GRADTL CALL DPWRST('XXX','BUG ') MSG=-3 GO TO 895 820 WRITE(ICOUT,904) ITNLIM CALL DPWRST('XXX','BUG ') MSG=-4 GO TO 895 825 WRITE(ICOUT,905) NDIGIT CALL DPWRST('XXX','BUG ') MSG=-5 GO TO 895 830 WRITE(ICOUT,906) MSG CALL DPWRST('XXX','BUG ') WRITE(ICOUT,916)IAGFLG CALL DPWRST('XXX','BUG ') MSG=-6 GO TO 895 835 WRITE(ICOUT,907) MSG CALL DPWRST('XXX','BUG ') WRITE(ICOUT,917)IAHFLG CALL DPWRST('XXX','BUG ') MSG=-7 895 RETURN 901 FORMAT('***** FROM OPTCHK ILLEGAL DIMENSION, N =',I5) 902 FORMAT( +'***** FROM OPTCHK +++ WARNING +++ THIS PACKAGE IS ', +'INEFFICIENT FOR PROBLEMS OF SIZE N=1.') 903 FORMAT( +'***** FROM OPTCHK ILLEGAL TOLERANCE. GRADTL = ',E20.13) 904 FORMAT( +'***** FROM OPTCHK ILLEGAL ITERATION LIMIT. ITNLIM = ',I5) 905 FORMAT( +'***** FROM OPTCHK MINIMIZATION FUNCTION HAS NO GOOD DIGITS.' +,' NDIGIT = ',I5) 906 FORMAT( +'***** FROM OPTCHK USER REQUESTS THAT ANALYTIC GRADIENT BE', +' ACCEPTED AS PROPERLY CODED (MSG =',I5) 916 FORMAT( +' BUT ANALYTIC GRADIENT NOT SUPPLIED', +'(IAGFLG = ',I5,'.') 907 FORMAT( +'***** FROM OPTCHK USER REQUESTS THAT ANALYTIC HESSIAN BE', +' ACCEPTED AS PROPERLY CODED (MSG =',I5) 917 FORMAT( +' BUT ANALYTIC HESSIAN NOT SUPPLIED', +'(IAHFLG = ',I5,'.') END SUBROUTINE OPTDRV(NR,N,X,TYPSIZ,FSCALE, CDPLT SUBROUTINE OPTDRV(NR,N,X,FCN,D1FCN,D2FCN,TYPSIZ,FSCALE, CDPLT+ METHOD,IEXP,MSG,NDIGIT,ITNLIM,IAGFLG,IAHFLG,IPR, + METHOD,IEXP,MSG,NDIGIT,ITNLIM,IAGFLG,IAHFLG,IPR2, + DLT,GRADTL,STEPMX,STEPTL, + XPLS,FPLS,GPLS,ITRMCD, + A,UDIAG,G,P,SX,WRK0,WRK1,WRK2,WRK3) IMPLICIT DOUBLE PRECISION (A-H,O-Z) C C PURPOSE C ------- C DRIVER FOR NON-LINEAR OPTIMIZATION PROBLEM C C PARAMETERS C ---------- C NR --> ROW DIMENSION OF MATRIX C N --> DIMENSION OF PROBLEM C X(N) --> ON ENTRY: ESTIMATE TO A ROOT OF FCN C FCN --> NAME OF SUBROUTINE TO EVALUATE OPTIMIZATION FUNCTION C MUST BE DECLARED EXTERNAL IN CALLING ROUTINE C FCN: R(N) --> R(1) C D1FCN --> (OPTIONAL) NAME OF SUBROUTINE TO EVALUATE GRADIENT C OF FCN. MUST BE DECLARED EXTERNAL IN CALLING ROUTINE C D2FCN --> (OPTIONAL) NAME OF SUBROUTINE TO EVALUATE HESSIAN OF C OF FCN. MUST BE DECLARED EXTERNAL IN CALLING ROUTINE C TYPSIZ(N) --> TYPICAL SIZE FOR EACH COMPONENT OF X C FSCALE --> ESTIMATE OF SCALE OF OBJECTIVE FUNCTION C METHOD --> ALGORITHM TO USE TO SOLVE MINIMIZATION PROBLEM C =1 LINE SEARCH C =2 DOUBLE DOGLEG C =3 MORE-HEBDON C IEXP --> =1 IF OPTIMIZATION FUNCTION FCN IS EXPENSIVE TO C EVALUATE, =0 OTHERWISE. IF SET THEN HESSIAN WILL C BE EVALUATED BY SECANT UPDATE INSTEAD OF C ANALYTICALLY OR BY FINITE DIFFERENCES C MSG <--> ON INPUT: (.GT.0) MESSAGE TO INHIBIT CERTAIN C AUTOMATIC CHECKS C ON OUTPUT: (.LT.0) ERROR CODE; =0 NO ERROR C NDIGIT --> NUMBER OF GOOD DIGITS IN OPTIMIZATION FUNCTION FCN C ITNLIM --> MAXIMUM NUMBER OF ALLOWABLE ITERATIONS C IAGFLG --> =1 IF ANALYTIC GRADIENT SUPPLIED C IAHFLG --> =1 IF ANALYTIC HESSIAN SUPPLIED C IPR --> DEVICE TO WHICH TO SEND OUTPUT C DLT --> TRUST REGION RADIUS C GRADTL --> TOLERANCE AT WHICH GRADIENT CONSIDERED CLOSE C ENOUGH TO ZERO TO TERMINATE ALGORITHM C STEPMX --> MAXIMUM ALLOWABLE STEP SIZE C STEPTL --> RELATIVE STEP SIZE AT WHICH SUCCESSIVE ITERATES C CONSIDERED CLOSE ENOUGH TO TERMINATE ALGORITHM C XPLS(N) <--> ON EXIT: XPLS IS LOCAL MINIMUM C FPLS <--> ON EXIT: FUNCTION VALUE AT SOLUTION, XPLS C GPLS(N) <--> ON EXIT: GRADIENT AT SOLUTION XPLS C ITRMCD <-- TERMINATION CODE C A(N,N) --> WORKSPACE FOR HESSIAN (OR ESTIMATE) C AND ITS CHOLESKY DECOMPOSITION C UDIAG(N) --> WORKSPACE [FOR DIAGONAL OF HESSIAN] C G(N) --> WORKSPACE (FOR GRADIENT AT CURRENT ITERATE) C P(N) --> WORKSPACE FOR STEP C SX(N) --> WORKSPACE (FOR DIAGONAL SCALING MATRIX) C WRK0(N) --> WORKSPACE C WRK1(N) --> WORKSPACE C WRK2(N) --> WORKSPACE C WRK3(N) --> WORKSPACE C C C INTERNAL VARIABLES C ------------------ C ANALTL TOLERANCE FOR COMPARISON OF ESTIMATED AND C ANALYTICAL GRADIENTS AND HESSIANS C EPSM MACHINE EPSILON C F FUNCTION VALUE: FCN(X) C ITNCNT CURRENT ITERATION, K C RNF RELATIVE NOISE IN OPTIMIZATION FUNCTION FCN. C NOISE=10.**(-NDIGIT) C DIMENSION X(N),XPLS(N),G(N),GPLS(N),P(N) DIMENSION TYPSIZ(N),SX(N) DIMENSION A(NR,1),UDIAG(N) DIMENSION WRK0(N),WRK1(N),WRK2(N),WRK3(N) LOGICAL MXTAKE,NOUPDT CDPLT EXTERNAL FCN,D1FCN,D2FCN CDPLT EXTERNAL OPTFCN C C-----COMMON VARIABLES (GENERAL)-------------------------------------- C INCLUDE 'DPCOF2.INC' REAL R1MACH INCLUDE 'DPCOMC.INC' CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT REAL CPUMIN, CPUMAX C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C C INITIALIZATION C -------------- DO 10 I=1,N P(I)=0. 10 CONTINUE ITNCNT=0 IRETCD=-1 CCCCC EPSM=D1MACH(4) EPSM=R1MACH(4) CALL OPTCHK(N,X,TYPSIZ,SX,FSCALE,GRADTL,ITNLIM,NDIGIT,EPSM, + DLT,METHOD,IEXP,IAGFLG,IAHFLG,STEPMX,MSG,IPR2) IF(MSG.LT.0) RETURN RNF=MAX(10.0D0**(-NDIGIT),EPSM) ANALTL=MAX(1.0D-2,SQRT(RNF)) C IF(MOD(MSG/8,2).EQ.1) GO TO 15 WRITE(ICOUT,901) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,900) (TYPSIZ(I),I=1,N) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,902) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,900) (SX(I),I=1,N) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,903) FSCALE CALL DPWRST('XXX','BUG ') WRITE(ICOUT,904) NDIGIT CALL DPWRST('XXX','BUG ') WRITE(ICOUT,914) IAGFLG CALL DPWRST('XXX','BUG ') WRITE(ICOUT,916) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,924) IAHFLG CALL DPWRST('XXX','BUG ') WRITE(ICOUT,926) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,934) IEXP CALL DPWRST('XXX','BUG ') WRITE(ICOUT,936) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,944) METHOD CALL DPWRST('XXX','BUG ') WRITE(ICOUT,946) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,954) ITNLIM CALL DPWRST('XXX','BUG ') WRITE(ICOUT,964) EPSM CALL DPWRST('XXX','BUG ') WRITE(ICOUT,905) STEPMX CALL DPWRST('XXX','BUG ') WRITE(ICOUT,915) STEPTL CALL DPWRST('XXX','BUG ') WRITE(ICOUT,925) GRADTL CALL DPWRST('XXX','BUG ') WRITE(ICOUT,935) DLT CALL DPWRST('XXX','BUG ') WRITE(ICOUT,945) RNF CALL DPWRST('XXX','BUG ') WRITE(ICOUT,955) ANALTL CALL DPWRST('XXX','BUG ') 15 CONTINUE C C EVALUATE FCN(X) C CALL OPTFCN(N,X,F) C C EVALUATE ANALYTIC OR FINITE DIFFERENCE GRADIENT AND CHECK ANALYTIC C GRADIENT, IF REQUESTED. C IF (IAGFLG .EQ. 1) GO TO 20 C IF (IAGFLG .EQ. 0) C THEN CCCCC CALL FSTOFD (1, 1, N, X, OPTFCN, F, G, SX, RNF, WRK, 1) CALL FSTOFD (1, 1, N, X, F, G, SX, RNF, WRK, 1) GO TO 25 C 20 CONTINUE CDP20 CALL D1FCN (N, X, G) CDPLT IF (MOD(MSG/2,2) .EQ. 1) GO TO 25 C IF (MOD(MSG/2,2).EQ.0) C THEN CDPLT CALL GRDCHK (N, X, FCN, F, G, TYPSIZ, SX, FSCALE, CDPLT1 RNF, ANALTL, WRK1, MSG, IPR) CDPLT IF (MSG .LT. 0) RETURN 25 CONTINUE C CALL OPTSTP(N,X,F,G,WRK1,ITNCNT,ICSCMX, + ITRMCD,GRADTL,STEPTL,SX,FSCALE,ITNLIM,IRETCD,MXTAKE, + IPR,MSG) IF(ITRMCD.NE.0) GO TO 700 C IF(IEXP.NE.1) GO TO 80 C C IF OPTIMIZATION FUNCTION EXPENSIVE TO EVALUATE (IEXP=1), THEN C HESSIAN WILL BE OBTAINED BY SECANT UPDATES. GET INITIAL HESSIAN. C CALL HSNINT(NR,N,A,SX,METHOD) GO TO 90 80 CONTINUE C C EVALUATE ANALYTIC OR FINITE DIFFERENCE HESSIAN AND CHECK ANALYTIC C HESSIAN IF REQUESTED (ONLY IF USER-SUPPLIED ANALYTIC HESSIAN C ROUTINE D2FCN FILLS ONLY LOWER TRIANGULAR PART AND DIAGONAL OF A). C IF (IAHFLG .EQ. 1) GO TO 82 C IF (IAHFLG .EQ. 0) C THEN CDPLT IF (IAGFLG .EQ. 1) CALL FSTOFD (NR, N, N, X, D1FCN, G, A, SX, CDPLT1 RNF, WRK1, 3) CDPLT IF (IAGFLG .NE. 1) CALL SNDOFD (NR, N, X, OPTFCN, F, A, SX, IF (IAGFLG .NE. 1) CALL SNDOFD (NR, N, X, F, A, SX, 1 RNF, WRK1, WRK2) GO TO 88 C C ELSE 82 CONTINUE CDP82 IF (MOD(MSG/4,2).EQ.0) GO TO 85 C IF (MOD(MSG/4, 2) .EQ. 1) C THEN CDPLT CALL D2FCN (NR, N, X, A) CDPLT GO TO 88 C C ELSE CDP85 CALL HESCHK (NR, N, X, FCN, D1FCN, D2FCN, F, G, A, TYPSIZ, CDPLT1 SX, RNF, ANALTL, IAGFLG, UDIAG, WRK1, WRK2, MSG, IPR) C C HESCHK EVALUATES D2FCN AND CHECKS IT AGAINST THE FINITE C DIFFERENCE HESSIAN WHICH IT CALCULATES BY CALLING FSTOFD C (IF IAGFLG .EQ. 1) OR SNDOFD (OTHERWISE). C CDPLT IF (MSG .LT. 0) RETURN 88 CONTINUE C 90 IF(MOD(MSG/8,2).EQ.0) + CALL RESULT(NR,N,X,F,G,A,P,ITNCNT,1,IPR2) C C C ITERATION C --------- 100 ITNCNT=ITNCNT+1 C C FIND PERTURBED LOCAL MODEL HESSIAN AND ITS LL+ DECOMPOSITION C (SKIP THIS STEP IF LINE SEARCH OR DOGSTEP TECHNIQUES BEING USED WITH C SECANT UPDATES. CHOLESKY DECOMPOSITION L ALREADY OBTAINED FROM C SECFAC.) C IF(IEXP.EQ.1 .AND. METHOD.NE.3) GO TO 105 103 CALL CHLHSN(NR,N,A,EPSM,SX,UDIAG) 105 CONTINUE C C SOLVE FOR NEWTON STEP: AP=-G C DO 110 I=1,N WRK1(I)=-G(I) 110 CONTINUE CALL LLTSLV(NR,N,A,P,WRK1) C C DECIDE WHETHER TO ACCEPT NEWTON STEP XPLS=X + P C OR TO CHOOSE XPLS BY A GLOBAL STRATEGY. C IF (IAGFLG .NE. 0 .OR. METHOD .EQ. 1) GO TO 111 DLTSAV = DLT IF (METHOD .EQ. 2) GO TO 111 AMUSAV = AMU DLPSAV = DLTP PHISAV = PHI PHPSAV = PHIP0 111 IF(METHOD.EQ.1) CDPLT+ CALL LNSRCH(N,X,F,G,P,XPLS,FPLS,OPTFCN,MXTAKE,IRETCD, + CALL LNSRCH(N,X,F,G,P,XPLS,FPLS,MXTAKE,IRETCD, + STEPMX,STEPTL,SX,IPR2) IF(METHOD.EQ.2) CDPLT+ CALL DOGDRV(NR,N,X,F,G,A,P,XPLS,FPLS,OPTFCN,SX,STEPMX, + CALL DOGDRV(NR,N,X,F,G,A,P,XPLS,FPLS,SX,STEPMX, + STEPTL,DLT,IRETCD,MXTAKE,WRK0,WRK1,WRK2,WRK3,IPR2) IF(METHOD.EQ.3) CDPLT+ CALL HOOKDR(NR,N,X,F,G,A,UDIAG,P,XPLS,FPLS,OPTFCN,SX,STEPMX, + CALL HOOKDR(NR,N,X,F,G,A,UDIAG,P,XPLS,FPLS,SX,STEPMX, + STEPTL,DLT,IRETCD,MXTAKE,AMU,DLTP,PHI,PHIP0,WRK0, + WRK1,WRK2,EPSM,ITNCNT,IPR2) C C IF COULD NOT FIND SATISFACTORY STEP AND FORWARD DIFFERENCE C GRADIENT WAS USED, RETRY USING CENTRAL DIFFERENCE GRADIENT. C IF (IRETCD .NE. 1 .OR. IAGFLG .NE. 0) GO TO 112 C IF (IRETCD .EQ. 1 .AND. IAGFLG .EQ. 0) C THEN C C SET IAGFLG FOR CENTRAL DIFFERENCES C IAGFLG = -1 WRITE(ICOUT,906) ITNCNT CALL DPWRST('XXX','BUG ') C CDPLT CALL FSTOCD (N, X, OPTFCN, SX, RNF, G) CALL FSTOCD (N, X, SX, RNF, G) IF (METHOD .EQ. 1) GO TO 105 DLT = DLTSAV IF (METHOD .EQ. 2) GO TO 105 AMU = AMUSAV DLTP = DLPSAV PHI = PHISAV PHIP0 = PHPSAV GO TO 103 C ENDIF C C CALCULATE STEP FOR OUTPUT C 112 CONTINUE DO 114 I = 1, N P(I) = XPLS(I) - X(I) 114 CONTINUE C C CALCULATE GRADIENT AT XPLS C IF (IAGFLG .EQ. (-1)) GO TO 116 IF (IAGFLG .EQ. 0) GO TO 118 C C ANALYTIC GRADIENT CDPLT CALL D1FCN (N, XPLS, GPLS) GO TO 120 C C CENTRAL DIFFERENCE GRADIENT CD116 CALL FSTOCD (N, XPLS, OPTFCN, SX, RNF, GPLS) 116 CALL FSTOCD (N, XPLS, SX, RNF, GPLS) GO TO 120 C C FORWARD DIFFERENCE GRADIENT CD118 CALL FSTOFD (1, 1, N, XPLS, OPTFCN, FPLS, GPLS, SX, RNF, WRK, 1) 118 CALL FSTOFD (1, 1, N, XPLS, FPLS, GPLS, SX, RNF, WRK, 1) 120 CONTINUE C C CHECK WHETHER STOPPING CRITERIA SATISFIED C CALL OPTSTP(N,XPLS,FPLS,GPLS,X,ITNCNT,ICSCMX, + ITRMCD,GRADTL,STEPTL,SX,FSCALE,ITNLIM,IRETCD,MXTAKE, + IPR2,MSG) IF(ITRMCD.NE.0) GO TO 690 C C EVALUATE HESSIAN AT XPLS C IF(IEXP.EQ.0) GO TO 130 IF(METHOD.EQ.3) + CALL SECUNF(NR,N,X,G,A,UDIAG,XPLS,GPLS,EPSM,ITNCNT,RNF, + IAGFLG,NOUPDT,WRK1,WRK2,WRK3) IF(METHOD.NE.3) + CALL SECFAC(NR,N,X,G,A,XPLS,GPLS,EPSM,ITNCNT,RNF,IAGFLG, + NOUPDT,WRK0,WRK1,WRK2,WRK3) GO TO 150 130 IF(IAHFLG.EQ.1) GO TO 140 CDPLT IF(IAGFLG.EQ.1) CDPLT+ CALL FSTOFD(NR,N,N,XPLS,D1FCN,GPLS,A,SX,RNF,WRK1,3) IF(IAGFLG.NE.1) CDPLT+ CALL SNDOFD(NR,N,XPLS,OPTFCN,FPLS,A,SX,RNF,WRK1,WRK2) + CALL SNDOFD(NR,N,XPLS,FPLS,A,SX,RNF,WRK1,WRK2) GO TO 150 140 CONTINUE CD140 CALL D2FCN(NR,N,XPLS,A) 150 CONTINUE IF(MOD(MSG/16,2).EQ.1) + CALL RESULT(NR,N,XPLS,FPLS,GPLS,A,P,ITNCNT,1,IPR2) C C X <-- XPLS AND G <-- GPLS AND F <-- FPLS C F=FPLS DO 160 I=1,N X(I)=XPLS(I) G(I)=GPLS(I) 160 CONTINUE GO TO 100 C C TERMINATION C ----------- C RESET XPLS,FPLS,GPLS, IF PREVIOUS ITERATE SOLUTION C 690 IF(ITRMCD.NE.3) GO TO 710 700 CONTINUE FPLS=F DO 705 I=1,N XPLS(I)=X(I) GPLS(I)=G(I) 705 CONTINUE C C PRINT RESULTS C 710 CONTINUE IF(MOD(MSG/8,2).EQ.0) + CALL RESULT(NR,N,XPLS,FPLS,GPLS,A,P,ITNCNT,0,IPR2) MSG=0 CDPLT CCCCC WRITE HESSIAN TO FILE DPST2F.DAT. BEFORE WRITING, MAKE CCCCC UPPER DIAGONAL OF MATRIX EQUAL TO LOWER DIAGONAL. C IOUNI2=IST2NU DO9005I=1,N DO9007J=1,N A(J,I)=A(I,J) 9007 CONTINUE 9005 CONTINUE C IF(N.LE.10)THEN WRITE(IOUNI2,9011)ITNCNT DO9010I=1,N WRITE(IOUNI2,9013)(A(I,J),J=1,N) 9010 CONTINUE 9011 FORMAT(1X,'HESSIAN MATRIX AT ITERATION ',I5) 9013 FORMAT(10(1X,E15.7)) ELSE WRITE(IOUNI2,9011)ITNCNT DO9020I=1,N DO9025J=1,N WRITE(IOUNI2,9023)A(I,J) 9025 CONTINUE WRITE(IOUNI2,9027) 9020 CONTINUE 9023 FORMAT(1X,E15.7) 9027 FORMAT(1X) ENDIF C RETURN C 900 FORMAT('***** FROM OPTDRV ',5(E20.13,3X)) 901 FORMAT('***** FROM OPTDRV TYPICAL X') 902 FORMAT('***** FROM OPTDRV DIAGONAL SCALING MATRIX FOR X') 903 FORMAT('***** FROM OPTDRV TYPICAL F = ',E20.13) 904 FORMAT('***** FROM OPTDRV NUMBER OF GOOD DIGITS IN OPTFCN = ', +I5) 914 FORMAT(' GRADIENT FLAG = ',I5, +' (=1 IF ') 916 FORMAT(' ANALYTIC GRADIENT SUPPLIED)') 924 FORMAT(' HESSIAN FLAG = ',I5, +' (=1 IF ') 926 FORMAT(' ANALYTIC HESSIAN SUPPLIED)') 934 FORMAT(' EXPENSE FLAG = ',I5,' (=1 IF ', +'MINIMIZATION ') 936 FORMAT(' FUNCTION EXPENSIVE TO EVALUATE)') 944 FORMAT(' METHOD TO USE = ',I5,' (=1,2,3 ', +'FOR LINE SEARCH,') 946 FORMAT(' DOUBLE DOGLEG, MORE-HEBDON ', +' RESPECTIVELY)') 954 FORMAT(' ITERATION LIMIT = ',I5) 964 FORMAT(' MACHINE EPSILON = ',E20.13) 905 FORMAT('***** FROM OPTDRV MAXIMUM STEP SIZE = ',E20.13) 915 FORMAT(' STEP TOLERANCE = ',E20.13) 925 FORMAT(' GRADIENT TOLERANCE = ',E20.13) 935 FORMAT(' TRUST REGION RADIUS = ',E20.13) 945 FORMAT(' REL NOISE IN OPTFCN = ',E20.13) 955 FORMAT(' ANAL-FD TOLERANCE = ',E20.13) 906 FORMAT('***** FROM OPTDRV SHIFT FROM FORWARD TO CENTRAL ', +'DIFFERENCES IN ITERATION ', I5) END SUBROUTINE OPTFCN(N, X, F) C C PURPOSE--AUXILLARY FUNCTION FOR THE UNCMIN ROUTINES. C IT COMPUTES THE FUNCTION BEING OPTIMIZED C AT THE VALUES OF THE N PARAMETERS GIVEN IN C X AND RETURNS THE FUNCTION VALUE IN F. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--95/2 C ORIGINAL VERSION--FEBRUARY 1995. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C DOUBLE PRECISION X(*) DOUBLE PRECISION F C CHARACTER*4 MODEL CHARACTER*4 IPARN CHARACTER*4 IPARN2 CHARACTER*4 IANGLU CHARACTER*4 ITYPEH CHARACTER*4 IW21HO CHARACTER*4 IW22HO CHARACTER*4 IVARN CHARACTER*4 IVARN2 CHARACTER*4 IBUGA3 CHARACTER*4 IBUGCO CHARACTER*4 IBUGEV CHARACTER*4 IERROR C CCCCC CHARACTER*4 ILAB CCCCC CHARACTER*4 IH CCCCC CHARACTER*4 IH2 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C--------------------------------------------------------------------- C PARAMETER (IOPTCH=1000) PARAMETER (IOPTC2=100) C DIMENSION PARAM(IOPTC2) DIMENSION IPARN(IOPTC2) DIMENSION IPARN2(IOPTC2) DIMENSION IVARN(IOPTC2) DIMENSION IVARN2(IOPTC2) C DIMENSION MODEL(IOPTCH) DIMENSION ITYPEH(IOPTCH) DIMENSION IW21HO(IOPTCH) DIMENSION IW22HO(IOPTCH) DIMENSION W2HOLD(IOPTCH) C DIMENSION ILOCV(IOPTC2) CCCCC DIMENSION ILAB(IOPTC2) C COMMON /OPTCMC/ IBUGA3, ITYPEH, IW21HO, IW22HO, IPARN, IPARN2, & IVARN, IVARN2, MODEL COMMON /OPTCMR/ PARAM, W2HOLD, & NUMCHA, NUMVAR, NWHOLD, NUMDV, ILOCV C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IERROR='NO' C IF(IBUGA3.EQ.'OFF')GOTO99 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('AT THE BEGINNING OF OPTFCN--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA3 52 FORMAT('IBUGA3 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)NUMCHA,NUMDV,NUMVAR 53 FORMAT('NUMCHA,NUMDV,NUMVAR = ',3I8) CALL DPWRST('XXX','BUG ') NMAX=NUMCHA IF(NMAX.GT.25)NMAX=25 WRITE(ICOUT,54)(MODEL(J),J=1,NMAX) 54 FORMAT('MODEL(I) = ',25A4) CALL DPWRST('XXX','BUG ') DO55I=1,NUMVAR WRITE(ICOUT,56)I,PARAM(I),IPARN(I),IPARN2(I) 56 FORMAT('I,PARAM(I),IPARN(I),IPARN2(I) = ',I8,E15.7,A4,A4) CALL DPWRST('XXX','BUG ') 55 CONTINUE DO59I=1,NUMDV WRITE(ICOUT,61)I,IVARN(I),IVARN2(I) 61 FORMAT('I, IVARN(I),IVARN2(I) = ',I8,2X,A4,A4) CALL DPWRST('XXX','BUG ') 59 CONTINUE 99 CONTINUE C C *************************** C ** STEP 3-- ** C ** INITIALIZE PARAMETERS** C *************************** C ISTEPN='3' IF(IBUGA3.EQ.'ON') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C DO9100K=1,NUMDV JLOC=ILOCV(K) PARAM(JLOC)=REAL(X(K)) 9100 CONTINUE C IPASS=2 IBUGCO=IBUGA3 IBUGEV=IBUGA3 FX=0.0 CALL COMPIM(MODEL,NUMCHA,IPASS,PARAM,IPARN,IPARN2,NUMVAR, 1IANGLU,ITYPEH,IW21HO,IW22HO,W2HOLD,NWHOLD,FX, 1IBUGCO,IBUGEV,IERROR) F=DBLE(FX) IF(IBUGA3.EQ.'ON')THEN WRITE(ICOUT,9101)FX CALL DPWRST('XXX','BUG ') DO9102KK=1,NUMDV WRITE(ICOUT,9103)KK,REAL(X(KK)) CALL DPWRST('XXX','BUG ') 9102 CONTINUE ENDIF 9101 FORMAT('FX = ',E15.7) 9103 FORMAT('I,X(I) = ',I5,1X,E15.7) C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGA3.EQ.'OFF')GOTO9090 WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF OPTFCN--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9021)IERROR 9021 FORMAT('IERROR = ',A4) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE OPTIF9(NR,N,X,TYPSIZ,FSCALE, CCCCC SUBROUTINE OPTIF9(NR,N,X,OPTFCN,D1FCN,D2FCN,TYPSIZ,FSCALE, + METHOD,IEXP,MSG,NDIGIT,ITNLIM,IAGFLG,IAHFLG,IPR, + DLT,GRADTL,STEPMX,STEPTL, + XPLS,FPLS,GPLS,ITRMCD,A,WRK) IMPLICIT DOUBLE PRECISION (A-H,O-Z) C C PURPOSE C ------- C PROVIDE COMPLETE INTERFACE TO MINIMIZATION PACKAGE. C USER HAS FULL CONTROL OVER OPTIONS. C C PARAMETERS C ---------- C NR --> ROW DIMENSION OF MATRIX C N --> DIMENSION OF PROBLEM C X(N) --> ON ENTRY: ESTIMATE TO A ROOT OF FCN C FCN --> NAME OF SUBROUTINE TO EVALUATE OPTIMIZATION FUNCTION C MUST BE DECLARED EXTERNAL IN CALLING ROUTINE C FCN: R(N) --> R(1) C D1FCN --> (OPTIONAL) NAME OF SUBROUTINE TO EVALUATE GRADIENT C OF FCN. MUST BE DECLARED EXTERNAL IN CALLING ROUTINE C D2FCN --> (OPTIONAL) NAME OF SUBROUTINE TO EVALUATE HESSIAN OF C OF FCN. MUST BE DECLARED EXTERNAL IN CALLING ROUTINE C TYPSIZ(N) --> TYPICAL SIZE FOR EACH COMPONENT OF X C FSCALE --> ESTIMATE OF SCALE OF OBJECTIVE FUNCTION C METHOD --> ALGORITHM TO USE TO SOLVE MINIMIZATION PROBLEM C =1 LINE SEARCH C =2 DOUBLE DOGLEG C =3 MORE-HEBDON C IEXP --> =1 IF OPTIMIZATION FUNCTION FCN IS EXPENSIVE TO C EVALUATE, =0 OTHERWISE. IF SET THEN HESSIAN WILL C BE EVALUATED BY SECANT UPDATE INSTEAD OF C ANALYTICALLY OR BY FINITE DIFFERENCES C MSG <--> ON INPUT: (.GT.0) MESSAGE TO INHIBIT CERTAIN C AUTOMATIC CHECKS C ON OUTPUT: (.LT.0) ERROR CODE; =0 NO ERROR C NDIGIT --> NUMBER OF GOOD DIGITS IN OPTIMIZATION FUNCTION FCN C ITNLIM --> MAXIMUM NUMBER OF ALLOWABLE ITERATIONS C IAGFLG --> =1 IF ANALYTIC GRADIENT SUPPLIED C IAHFLG --> =1 IF ANALYTIC HESSIAN SUPPLIED C IPR --> DEVICE TO WHICH TO SEND OUTPUT C DLT --> TRUST REGION RADIUS C GRADTL --> TOLERANCE AT WHICH GRADIENT CONSIDERED CLOSE C ENOUGH TO ZERO TO TERMINATE ALGORITHM C STEPMX --> MAXIMUM ALLOWABLE STEP SIZE C STEPTL --> RELATIVE STEP SIZE AT WHICH SUCCESSIVE ITERATES C CONSIDERED CLOSE ENOUGH TO TERMINATE ALGORITHM C XPLS(N) <--> ON EXIT: XPLS IS LOCAL MINIMUM C FPLS <--> ON EXIT: FUNCTION VALUE AT SOLUTION, XPLS C GPLS(N) <--> ON EXIT: GRADIENT AT SOLUTION XPLS C ITRMCD <-- TERMINATION CODE C A(N,N) --> WORKSPACE FOR HESSIAN (OR ESTIMATE) C AND ITS CHOLESKY DECOMPOSITION C WRK(N,8) --> WORKSPACE C CCCCC MAY 1995. DO DUMMY DECLARATIONS WITH "*". CCCCC DIMENSION X(N),XPLS(N),GPLS(N),TYPSIZ(N) CCCCC DIMENSION A(NR,1),WRK(NR,1) DIMENSION X(*),XPLS(*),GPLS(*),TYPSIZ(*) DIMENSION A(NR,*),WRK(NR,*) CDPLT EXTERNAL FCN,D1FCN,D2FCN CDPLT EXTERNAL OPTFCN C C EQUIVALENCE WRK(N,1) = UDIAG(N) C WRK(N,2) = G(N) C WRK(N,3) = P(N) C WRK(N,4) = SX(N) C WRK(N,5) = WRK0(N) C WRK(N,6) = WRK1(N) C WRK(N,7) = WRK2(N) C WRK(N,8) = WRK3(N) C CDPLT CALL OPTDRV(NR,N,X,FCN,D1FCN,D2FCN,TYPSIZ,FSCALE, CALL OPTDRV(NR,N,X,TYPSIZ,FSCALE, + METHOD,IEXP,MSG,NDIGIT,ITNLIM,IAGFLG,IAHFLG,IPR, + DLT,GRADTL,STEPMX,STEPTL, + XPLS,FPLS,GPLS,ITRMCD, + A,WRK(1,1),WRK(1,2),WRK(1,3),WRK(1,4),WRK(1,5), + WRK(1,6),WRK(1,7),WRK(1,8)) RETURN END SUBROUTINE OPTSTP(N,XPLS,FPLS,GPLS,X,ITNCNT,ICSCMX, + ITRMCD,GRADTL,STEPTL,SX,FSCALE,ITNLIM,IRETCD,MXTAKE, + IPRTMP,MSG) IMPLICIT DOUBLE PRECISION (A-H,O-Z) C C UNCONSTRAINED MINIMIZATION STOPPING CRITERIA C -------------------------------------------- C FIND WHETHER THE ALGORITHM SHOULD TERMINATE, DUE TO ANY C OF THE FOLLOWING: C 1) PROBLEM SOLVED WITHIN USER TOLERANCE C 2) CONVERGENCE WITHIN USER TOLERANCE C 3) ITERATION LIMIT REACHED C 4) DIVERGENCE OR TOO RESTRICTIVE MAXIMUM STEP (STEPMX) SUSPECTED C C C PARAMETERS C ---------- C N --> DIMENSION OF PROBLEM C XPLS(N) --> NEW ITERATE X[K] C FPLS --> FUNCTION VALUE AT NEW ITERATE F(XPLS) C GPLS(N) --> GRADIENT AT NEW ITERATE, G(XPLS), OR APPROXIMATE C X(N) --> OLD ITERATE X[K-1] C ITNCNT --> CURRENT ITERATION K C ICSCMX <--> NUMBER CONSECUTIVE STEPS .GE. STEPMX C [RETAIN VALUE BETWEEN SUCCESSIVE CALLS] C ITRMCD <-- TERMINATION CODE C GRADTL --> TOLERANCE AT WHICH RELATIVE GRADIENT CONSIDERED CLOSE C ENOUGH TO ZERO TO TERMINATE ALGORITHM C STEPTL --> RELATIVE STEP SIZE AT WHICH SUCCESSIVE ITERATES C CONSIDERED CLOSE ENOUGH TO TERMINATE ALGORITHM C SX(N) --> DIAGONAL SCALING MATRIX FOR X C FSCALE --> ESTIMATE OF SCALE OF OBJECTIVE FUNCTION C ITNLIM --> MAXIMUM NUMBER OF ALLOWABLE ITERATIONS C IRETCD --> RETURN CODE C MXTAKE --> BOOLEAN FLAG INDICATING STEP OF MAXIMUM LENGTH USED C IPR --> DEVICE TO WHICH TO SEND OUTPUT C MSG --> IF MSG INCLUDES A TERM 8, SUPPRESS OUTPUT C C INTEGER N,ITNCNT,ICSCMX,ITRMCD,ITNLIM DIMENSION SX(N) DIMENSION XPLS(N),GPLS(N),X(N) LOGICAL MXTAKE C C-----COMMON VARIABLES (GENERAL)-------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT REAL CPUMIN, CPUMAX C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C ITRMCD=0 C C LAST GLOBAL STEP FAILED TO LOCATE A POINT LOWER THAN X IF(IRETCD.NE.1) GO TO 50 C IF(IRETCD.EQ.1) C THEN JTRMCD=3 GO TO 600 C ENDIF 50 CONTINUE C C FIND DIRECTION IN WHICH RELATIVE GRADIENT MAXIMUM. C CHECK WHETHER WITHIN TOLERANCE C D=MAX(ABS(FPLS),FSCALE) RGX=0.0 DO 100 I=1,N RELGRD=ABS(GPLS(I))*MAX(ABS(XPLS(I)),1./SX(I))/D RGX=MAX(RGX,RELGRD) 100 CONTINUE JTRMCD=1 IF(RGX.LE.GRADTL) GO TO 600 C IF(ITNCNT.EQ.0) RETURN C C FIND DIRECTION IN WHICH RELATIVE STEPSIZE MAXIMUM C CHECK WHETHER WITHIN TOLERANCE. C RSX=0.0 DO 120 I=1,N RELSTP=ABS(XPLS(I)-X(I))/MAX(ABS(XPLS(I)),1./SX(I)) RSX=MAX(RSX,RELSTP) 120 CONTINUE JTRMCD=2 IF(RSX.LE.STEPTL) GO TO 600 C C CHECK ITERATION LIMIT C JTRMCD=4 IF(ITNCNT.GE.ITNLIM) GO TO 600 C C CHECK NUMBER OF CONSECUTIVE STEPS \ STEPMX C IF(MXTAKE) GO TO 140 C IF(.NOT.MXTAKE) C THEN ICSCMX=0 RETURN C ELSE 140 CONTINUE IF (MOD(MSG/8,2) .EQ. 0) WRITE(ICOUT,900) ICSCMX=ICSCMX+1 IF(ICSCMX.LT.5) RETURN JTRMCD=5 C ENDIF C C C PRINT TERMINATION CODE C CCCCC DATAPLOT WILL PRINT THE ERROR MESSAGES FROM DPOPT3. 600 ITRMCD=JTRMCD IF (MOD(MSG/8,2) .EQ. 0) GO TO(601,602,603,604,605), ITRMCD GO TO 700 601 CONTINUE CCCCC WRITE(ICOUT,901) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,911) CCCCC CALL DPWRST('XXX','BUG ') GO TO 700 602 CONTINUE CCCCC WRITE(ICOUT,902) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,912) CCCCC CALL DPWRST('XXX','BUG ') GO TO 700 603 CONTINUE CCCCC WRITE(ICOUT,903) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,913) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,923) CCCCC CALL DPWRST('XXX','BUG ') GO TO 700 604 CONTINUE CCCCC WRITE(ICOUT,904) CCCCC CALL DPWRST('XXX','BUG ') GO TO 700 605 CONTINUE CCCCC WRITE(ICOUT,905) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,915) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,915) CCCCC CALL DPWRST('XXX','BUG ') C 700 RETURN C 900 FORMAT( +'***** FROM OPTSTP STEP OF MAXIMUM LENGTH (STEPMX) TAKEN') 901 FORMAT( +'***** FROM OPTSTP RELATIVE GRADIENT CLOSE TO ZERO.') 911 FORMAT( +' CURRENT ITERATE IS PROBABLY SOLUTION.') 902 FORMAT( +'***** FROM OPTSTP SUCCESSIVE ITERATES WITHIN TOLERANCE.') 912 FORMAT( +' CURRENT ITERATE IS PROBABLY SOLUTION.') 903 FORMAT( +'***** FROM OPTSTP LAST GLOBAL STEP FAILED TO LOCATE A ', +'POINT LOWER THAN X.') 913 FORMAT( +' EITHER X IS AN APPROXIMATE LOCAL MINIMUM', + ' OF THE FUNCTION,') 923 FORMAT( +' THE FUNCTION IS TOO NON-LINEAR FOR THIS ', +'ALGORITHM OR STEPTL IS TOO LARGE.') 904 FORMAT( +'***** FROM OPTSTP ALGORITHM FAILED BECAUSE ITERATION LIMIT', +' EXCEEDED.') 905 FORMAT( +'***** FROM OPTSTP MAXIMUM STEP SIZE EXCEEDED 5 CONSECUTIVE', +' TIMES.') 915 FORMAT( +' EITHER THE FUNCTION IS UNBOUNDED BELOW, ', +'BECOMES ASYMPTOTIC TO A FINITE VALUE FROM ABOVE IN SOME ') 925 FORMAT( +' DIRECTION, OR STEPMX IS TOO SMALL.') END SUBROUTINE ORTHES(NM,N,LOW,IGH,A,ORT) C***BEGIN PROLOGUE ORTHES C***DATE WRITTEN 760101 (YYMMDD) C***REVISION DATE 830518 (YYMMDD) C***CATEGORY NO. D4C1B2 C***KEYWORDS EIGENVALUES,EIGENVECTORS,EISPACK C***AUTHOR SMITH, B. T., ET AL. C***PURPOSE Reduces real general matrix to upper Hessenberg form C orthogonal similarity transformations. C***DESCRIPTION C C This subroutine is a translation of the ALGOL procedure ORTHES, C NUM. MATH. 12, 349-368(1968) by Martin and Wilkinson. C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971). C C Given a REAL GENERAL matrix, this subroutine C reduces a submatrix situated in rows and columns C LOW through IGH to upper Hessenberg form by C orthogonal similarity transformations. C C On INPUT C C NM must be set to the row dimension of two-dimensional C array parameters as declared in the calling program C dimension statement. C C N is the order of the matrix. C C LOW and IGH are integers determined by the balancing C subroutine BALANC. If BALANC has not been used, C set LOW=1, IGH=N. C C A contains the input matrix. C C On OUTPUT C C A contains the Hessenberg matrix. Information about C the orthogonal transformations used in the reduction C is stored in the remaining triangle under the C Hessenberg matrix. C C ORT contains further information about the transformations. C only elements LOW through IGH are used. C C Questions and comments should be directed to B. S. Garbow, C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY C ------------------------------------------------------------------ C***REFERENCES B. T. SMITH, J. M. BOYLE, J. J. DONGARRA, B. S. GARBOW, C Y. IKEBE, V. C. KLEMA, C. B. MOLER, *MATRIX EIGEN- C SYSTEM ROUTINES - EISPACK GUIDE*, SPRINGER-VERLAG, C 1976. C***ROUTINES CALLED (NONE) C***END PROLOGUE ORTHES C INTEGER I,J,M,N,II,JJ,LA,MP,NM,IGH,KP1,LOW REAL A(NM,N),ORT(IGH) REAL F,G,H,SCALE C C***FIRST EXECUTABLE STATEMENT ORTHES LA = IGH - 1 KP1 = LOW + 1 IF (LA .LT. KP1) GO TO 200 C DO 180 M = KP1, LA H = 0.0E0 ORT(M) = 0.0E0 SCALE = 0.0E0 C .......... SCALE COLUMN (ALGOL TOL THEN NOT NEEDED) .......... DO 90 I = M, IGH 90 SCALE = SCALE + ABS(A(I,M-1)) C IF (SCALE .EQ. 0.0E0) GO TO 180 MP = M + IGH C .......... FOR I=IGH STEP -1 UNTIL M DO -- .......... DO 100 II = M, IGH I = MP - II ORT(I) = A(I,M-1) / SCALE H = H + ORT(I) * ORT(I) 100 CONTINUE C G = -SIGN(SQRT(H),ORT(M)) H = H - ORT(M) * G ORT(M) = ORT(M) - G C .......... FORM (I-(U*UT)/H) * A .......... DO 130 J = M, N F = 0.0E0 C .......... FOR I=IGH STEP -1 UNTIL M DO -- .......... DO 110 II = M, IGH I = MP - II F = F + ORT(I) * A(I,J) 110 CONTINUE C F = F / H C DO 120 I = M, IGH 120 A(I,J) = A(I,J) - F * ORT(I) C 130 CONTINUE C .......... FORM (I-(U*UT)/H)*A*(I-(U*UT)/H) .......... DO 160 I = 1, IGH F = 0.0E0 C .......... FOR J=IGH STEP -1 UNTIL M DO -- .......... DO 140 JJ = M, IGH J = MP - JJ F = F + ORT(J) * A(I,J) 140 CONTINUE C F = F / H C DO 150 J = M, IGH 150 A(I,J) = A(I,J) - F * ORT(J) C 160 CONTINUE C ORT(M) = SCALE * ORT(M) A(M,M-1) = SCALE * G 180 CONTINUE C 200 RETURN END SUBROUTINE ORTRAN(NM,N,LOW,IGH,A,ORT,Z) C***BEGIN PROLOGUE ORTRAN C***DATE WRITTEN 760101 (YYMMDD) C***REVISION DATE 830518 (YYMMDD) C***CATEGORY NO. D4C4 C***KEYWORDS EIGENVALUES,EIGENVECTORS,EISPACK C***AUTHOR SMITH, B. T., ET AL. C***PURPOSE Accumulates orthogonal similarity transformations in C reduction of real general matrix by ORTHES. C***DESCRIPTION C C This subroutine is a translation of the ALGOL procedure ORTRANS, C NUM. MATH. 16, 181-204(1970) by Peters and Wilkinson. C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971). C C This subroutine accumulates the orthogonal similarity C transformations used in the reduction of a REAL GENERAL C matrix to upper Hessenberg form by ORTHES. C C On INPUT C C NM must be set to the row dimension of two-dimensional C array parameters as declared in the calling program C dimension statement. C C N is the order of the matrix. C C LOW and IGH are integers determined by the balancing C subroutine BALANC. If BALANC has not been used, C set LOW=1, IGH=N. C C A contains information about the orthogonal trans- C formations used in the reduction by ORTHES C in its strict lower triangle. C C ORT contains further information about the trans- C formations used in the reduction by ORTHES. C only elements LOW through IGH are USED. C C On OUTPUT C C Z contains the transformation matrix produced in the C reduction by ORTHES. C C ORT has been altered. C C Questions and comments should be directed to B. S. Garbow, C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY C ------------------------------------------------------------------ C***REFERENCES B. T. SMITH, J. M. BOYLE, J. J. DONGARRA, B. S. GARBOW, C Y. IKEBE, V. C. KLEMA, C. B. MOLER, *MATRIX EIGEN- C SYSTEM ROUTINES - EISPACK GUIDE*, SPRINGER-VERLAG, C 1976. C***ROUTINES CALLED (NONE) C***END PROLOGUE ORTRAN C INTEGER I,J,N,KL,MM,MP,NM,IGH,LOW,MP1 REAL A(NM,IGH),ORT(IGH),Z(NM,N) REAL G C C .......... INITIALIZE Z TO IDENTITY MATRIX .......... C***FIRST EXECUTABLE STATEMENT ORTRAN DO 80 I = 1, N C DO 60 J = 1, N 60 Z(I,J) = 0.0E0 C Z(I,I) = 1.0E0 80 CONTINUE C KL = IGH - LOW - 1 IF (KL .LT. 1) GO TO 200 C .......... FOR MP=IGH-1 STEP -1 UNTIL LOW+1 DO -- .......... DO 140 MM = 1, KL MP = IGH - MM IF (A(MP,MP-1) .EQ. 0.0E0) GO TO 140 MP1 = MP + 1 C DO 100 I = MP1, IGH 100 ORT(I) = A(I,MP-1) C DO 130 J = MP, IGH G = 0.0E0 C DO 110 I = MP, IGH 110 G = G + ORT(I) * Z(I,J) C .......... DIVISOR BELOW IS NEGATIVE OF H FORMED IN ORTHES. C DOUBLE DIVISION AVOIDS POSSIBLE UNDERFLOW .......... G = (G / ORT(MP)) / A(MP,MP-1) C DO 120 I = MP, IGH 120 Z(I,J) = Z(I,J) + G * ORT(I) C 130 CONTINUE C 140 CONTINUE C 200 RETURN END SUBROUTINE PAPCDF(DX,DTHETA,DP,DCDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION C FUNCTION VALUE AT THE DOUBLE PRECISION VALUE DX C FOR THE POLYA-AEPPLI DISTRIBUTION C WITH DOUBLE PRECISION SHAPE PARAMETERS DTHETA AND C DP. THIS DISTRIBUTION IS DEFINED FOR ALL C NON-NEGATIVE INTEGER X >= 0. C THIS DISTRIBUTION HAS THE PROBABILITY FUNCTION C p(X;THETA,P) = EXP(-THETA)*(THETA*(1-P)/P)*P**X* C CHU(X+1;2,THETA*(1-P)/P) C = EXP(-THETA)*P**X* C SUM[J=1 to X][(X-1 J-1)* C (THETA*(1-P)/P)**J/J! C X = 1, 2, .... C C p(0;THETA,P) = EXP(-THETA) C C CHU = THE CONFLUENT HYPERGEOMETRIC FUNTION 1F1. C C JOHNSON, KOTZ, AND KEMP GIVE THE FOLLOWING C FORMULAS FOR X = 1, ..., 4 (ALPHA=THETA*(1-P)/P): C C C p(1;THETA,P) = EXP(-THETA)* C p(2;THETA,P) = EXP(-THETA)*ALPHA*P**2*(1+ALPHA/2) C p(2;THETA,P) = EXP(-THETA)*ALPHA*P**2*(1+ALPHA/2) C p(3;THETA,P) = EXP(-THETA)*ALPHA*P**3* C (1+ALPHA+ALPHA**2/6) C p(4;THETA,P) = EXP(-THETA)*ALPHA*P**4* C (1+3*ALPHA/2+ALPHA**2/2+ALPHA**3/24) C C FOR THE CDF, WE USE THE FOLLOWING RECURRENCE C RELATION (FROM JOHNSON, KOTZ AND KEMP): C C p(X+1) = (THETA*(1-P)/(X+1))*SUM[J=1 TO X] C [(X+1-J)*P**(X-J)*p(X)] C C INPUT ARGUMENTS--DX = THE DOUBLE PRECISION VALUE C AT WHICH THE CUMULATIVE DISTRIBUTION C FUNCTION IS TO BE EVALUATED. C X SHOULD BE A NON-NEGATIVE INTEGR C --DTHETA = THE DOUBLE PRECISION VALUE C OF THE FIRST SHAPE PARAMETER. C --DP = THE DOUBLE PRECISION VALUE C OF THE SECOND SHAPE PARAMETER. C OUTPUT ARGUMENTS--DPDF = THE DOUBLE PRECISION CUMULATIVE C DISTRIBUTION FUNCTION VALUE C OUTPUT--THE DOUBLE PRECISION CUMULATIVE DISTRIBUTION FUNCTION C VALUE DCDF FOR THE POLYA-AEPPLI DISTRIBUTION C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--X SHOULD BE A NON-NEGATIVE INTEGER C --0 < P < 1, AND THETA > 0 C OTHER DATAPAC SUBROUTINES NEEDED--DLNGAM, DCHU. C FORTRAN LIBRARY SUBROUTINES NEEDED--DEXP, DLOG C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--JOHNSON, KOTZ, AND KEMP (1992). "UNIVARIATE C DISCRETE DISTRIBUTIONS", SECOND EDITION, C WILEY, PP. 378-382. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2006/6 C ORIGINAL VERSION--JUNE 2006. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C IMPLICIT DOUBLE PRECISION (A-H,O-Z) C C--------------------------------------------------------------------- C REAL CPUMIN REAL CPUMAX C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C DCDF=0.0D0 C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(DP.LE.0.0D0 .OR. DP.GE.1.0D0)THEN WRITE(ICOUT,11) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)DP CALL DPWRST('XXX','BUG ') DCDF=0.0D0 GOTO9999 ENDIF C IF(DTHETA.LE.0.0D0)THEN WRITE(ICOUT,12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)DTHETA CALL DPWRST('XXX','BUG ') DCDF=0.0D0 GOTO9999 ENDIF INTX=INT(DX+0.5D0) IF(INTX.LT.0)THEN DCDF=0.0D0 GOTO9999 ENDIF C 11 FORMAT('***** ERROR--THE THIRD ARGUMENT TO ', 1'PAPCDF IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL') 12 FORMAT('***** ERROR--THE SECOND ARGUMENT TO ', 1'PAPCDF IS NON-POSITIVE') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7) 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8) C DQ=1.0D0 - DP DALPHA=DTHETA*DQ/DP DX=DBLE(INTX) C DPDFS2=DEXP(-DTHETA) IF(INTX.EQ.0)THEN DCDF=DPDFS2 GOTO9999 ENDIF DTERM1=-DTHETA + DLOG(DALPHA) + DLOG(DP) DPDFS1=DEXP(DTERM1) IF(INTX.EQ.1)THEN DCDF=DPDFS1+DPDFS2 GOTO9999 ENDIF DCDF=DPDFS1+DPDFS2 C DO100I=2,INTX IF(I.EQ.2)THEN DTERM1=-DTHETA + DLOG(DALPHA) + 2.0D0*DLOG(DP) + 1 DLOG(1.0D0 + DALPHA/2.0D0) DPDF=DEXP(DTERM1) ELSEIF(I.EQ.3)THEN DTERM1=-DTHETA + DLOG(DALPHA) + 3.0D0*DLOG(DP) + 1 DLOG(1.0D0 + DALPHA + DALPHA**2/6.0D0) DPDF=DEXP(DTERM1) ELSEIF(I.EQ.4)THEN DTERM1=-DTHETA + DLOG(DALPHA) + 4.0D0*DLOG(DP) + 1 DLOG(1.0D0 + 1.5D0*DALPHA + 0.5D0*DALPHA**2 1 + DALPHA**3/24.0D0) DPDF=DEXP(DTERM1) ELSE DTERM1=(1.0D0/DBLE(I)) DTERM2=(DTHETA*DQ + 2.0D0*DP*DBLE(I-1))*DPDFS1 DTERM3=DP**2*DBLE(I-2)*DPDFS2 DPDF=DTERM1*(DTERM2 - DTERM3) ENDIF DCDF=DCDF + DPDF DPDFS2=DPDFS1 DPDFS1=DPDF 100 CONTINUE C 9999 CONTINUE RETURN END SUBROUTINE PAPFUN(N,XPAR,FVEC,IFLAG,Y,K) C C PURPOSE--THIS ROUTINE COMPUTES THE FUNCTIONS FOR THE C POLYA-AEPPLI MAXIMUM LIKELIHOOD EQUATIONS: C C XBAR - THETAHAT/(1-PHAT) = 0 C XBAR - SUM[J=1 to N][fj*(J-1)*P(J-1)/(N*P(J))} = 0 C C WITH THETAHAT AND PHAT DENOTING THE CURRENT ESTIMATES C OF THE SHAPE PARAMETERS AND WHERE P(J) = THE C POLYA-AEPPLI PDF USING THE ESTIMATED PARAMETERS. C C CALLED BY DNSQE ROUTINE FOR SOLVING SIMULTANEOUS C NONLINEAR EQUATIONS. NOTE THAT THE CALLING SEQUENCE C DID NOT ACCOMODATE A DATA ARRAY (AND ASSCIATED NUMBER OF C OBSERVATIONS), SO THESE WERE ADDED TO THE CALL LIST. C SINCE DNSQE ONLY PASSES ONE ARRAY, WE SPLIT INTO C TWO PARTS: 1 - MAXNXT/2 ARE THE FREQUENCIES WHILE C (MAXNXT/2 + 1) - MAXNXT ARE THE CLASS VALUES (I.E., C THE X). C C EXAMPLE--POLYA-AEPPLI MAXIMUM LIKELIHOOD Y C REFERENCES--JOHNSON, KOTZ, AND KEMP (1992). "UNIVARIATE C DISCRETE DISTRIBUTIONS", SECOND EDITION, C WILEY, PP. 378-382. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBUG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2006/6 C ORIGINAL VERSION--JUNE 2006. C C--------------------------------------------------------------------- C DOUBLE PRECISION XPAR(*) DOUBLE PRECISION FVEC(*) REAL Y(*) C DOUBLE PRECISION DX DOUBLE PRECISION DXM1 DOUBLE PRECISION DTHETA DOUBLE PRECISION DP DOUBLE PRECISION DPDF1 DOUBLE PRECISION DPDF2 DOUBLE PRECISION DNUM DOUBLE PRECISION DENOM DOUBLE PRECISION DSUM1 C DOUBLE PRECISION XBAR COMMON/PAPCOM/MAXNXT,NTOT,XBAR C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C COMPUTE SOME SUMS C DTHETA=XPAR(1) DP=XPAR(2) DN=DBLE(NTOT) FVEC(1)=XBAR - DTHETA/(1.0D0 - DP) C IINDX=MAXNXT/2 DSUM1=0.0D0 C DO200I=1,K C DX=DBLE(Y(IINDX+I)) DFREQ=Y(I) C DXM1=DX-1.0D0 CALL PAPPDF(DXM1,DTHETA,DP,DPDF1) CALL PAPPDF(DX,DTHETA,DP,DPDF2) DNUM=DFREQ*DXM1*DPDF1 DENOM=DN*DPDF2 C IF(DENOM.NE.0.0D0)THEN DSUM1=DSUM1 + DNUM/DENOM ELSE DSUM1=DSUM1 + DBLE(CPUMAX) ENDIF C 200 CONTINUE C FVEC(2)=XBAR - DSUM1 C RETURN END SUBROUTINE PAPPDF(DX,DTHETA,DP,DPDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY MASS C FUNCTION VALUE AT THE DOUBLE PRECISION VALUE DX C FOR THE POLYA-AEPPLI DISTRIBUTION C WITH DOUBLE PRECISION SHAPE PARAMETERS DTHETA AND C DP. THIS DISTRIBUTION IS DEFINED FOR ALL C NON-NEGATIVE INTEGER X >= 0. C THIS DISTRIBUTION HAS THE PROBABILITY FUNCTION C p(X;THETA,P) = EXP(-THETA)*(THETA*(1-P)/P)*P**X* C CHU(X+1;2,THETA*(1-P)/P) C = EXP(-THETA)*P**X* C SUM[J=1 to X][(X-1 J-1)* C (THETA*(1-P)/P)**J/J! C X = 1, 2, .... C C p(0;THETA,P) = EXP(-THETA) C C CHU = THE CONFLUENT HYPERGEOMETRIC FUNTION 1F1. C C JOHNSON, KOTZ, AND KEMP GIVE THE FOLLOWING C FORMULAS FOR X = 1, ..., 4 (ALPHA=THETA*(1-P)/P): C C C p(1;THETA,P) = EXP(-THETA)* C p(2;THETA,P) = EXP(-THETA)*ALPHA*P**2*(1+ALPHA/2) C p(2;THETA,P) = EXP(-THETA)*ALPHA*P**2*(1+ALPHA/2) C p(3;THETA,P) = EXP(-THETA)*ALPHA*P**3* C (1+ALPHA+ALPHA**2/6) C p(4;THETA,P) = EXP(-THETA)*ALPHA*P**4* C (1+3*ALPHA/2+ALPHA**2/2+ALPHA**3/24) C C INPUT ARGUMENTS--DX = THE DOUBLE PRECISION VALUE C AT WHICH THE PROBABILITY MASS C FUNCTION IS TO BE EVALUATED. C X SHOULD BE A NON-NEGATIVE INTEGR C --DTHETA = THE DOUBLE PRECISION VALUE C OF THE FIRST SHAPE PARAMETER. C --DP = THE DOUBLE PRECISION VALUE C OF THE SECOND SHAPE PARAMETER. C OUTPUT ARGUMENTS--DPDF = THE DOUBLE PRECISION PROBABILITY C MASS FUNCTION VALUE C OUTPUT--THE DOUBLE PRECISION PROBABILITY MASS FUNCTION VALUE C DPDF FOR THE POLYA-AEPPLI DISTRIBUTION C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--X SHOULD BE A NON-NEGATIVE INTEGER C --0 < P < 1, AND THETA > 0 C OTHER DATAPAC SUBROUTINES NEEDED--DLNGAM, DCHU. C FORTRAN LIBRARY SUBROUTINES NEEDED--DEXP, DLOG C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--JOHNSON, KOTZ, AND KEMP (1992). "UNIVARIATE C DISCRETE DISTRIBUTIONS", SECOND EDITION, C WILEY, PP. 378-382. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2006/6 C ORIGINAL VERSION--JUNE 2006. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C IMPLICIT DOUBLE PRECISION (A-H,O-Z) C C--------------------------------------------------------------------- C REAL CPUMIN REAL CPUMAX C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C DPDF=0.0D0 C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(DP.LE.0.0D0 .OR. DP.GE.1.0D0)THEN WRITE(ICOUT,11) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)DP CALL DPWRST('XXX','BUG ') DPDF=0.0D0 GOTO9999 ENDIF C IF(DTHETA.LE.0.0D0)THEN WRITE(ICOUT,12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)DTHETA CALL DPWRST('XXX','BUG ') DPDF=0.0D0 GOTO9999 ENDIF INTX=INT(DX+0.5D0) IF(INTX.LT.0)THEN WRITE(ICOUT,5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)INTX CALL DPWRST('XXX','BUG ') DPDF=0.0D0 GOTO9999 ENDIF C 5 FORMAT('***** ERROR--THE FIRST ARGUMENT TO PAPPDF ', 1'IS NEGATIVE') 11 FORMAT('***** ERROR--THE THIRD ARGUMENT TO ', 1'PAPPDF IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL') 12 FORMAT('***** ERROR--THE SECOND ARGUMENT TO ', 1'PAPPDF IS NON-POSITIVE') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7) 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8) C DQ=1.0D0 - DP DALPHA=DTHETA*DQ/DP DX=DBLE(INTX) C IF(INTX.EQ.0)THEN DPDF=DEXP(-DTHETA) ELSEIF(INTX.EQ.1)THEN DTERM1=-DTHETA + DLOG(DALPHA) + DLOG(DP) DPDF=DEXP(DTERM1) ELSEIF(INTX.EQ.2)THEN DTERM1=-DTHETA + DLOG(DALPHA) + 2.0D0*DLOG(DP) + 1 DLOG(1.0D0 + DALPHA/2.0D0) DPDF=DEXP(DTERM1) ELSEIF(INTX.EQ.3)THEN DTERM1=-DTHETA + DLOG(DALPHA) + 3.0D0*DLOG(DP) + 1 DLOG(1.0D0 + DALPHA + DALPHA**2/6.0D0) DPDF=DEXP(DTERM1) ELSEIF(INTX.EQ.4)THEN DTERM1=-DTHETA + DLOG(DALPHA) + 4.0D0*DLOG(DP) + 1 DLOG(1.0D0 + 1.5D0*DALPHA + 0.5D0*DALPHA**2 1 + DALPHA**3/24.0D0) DPDF=DEXP(DTERM1) ELSE C C THE CONFLUENT HYPERGEOMETRIC FORMULATION GIVEN IN C JOHNSON, KOTZ, AND KEMP DOES NOT SEEM TO BE C WORKING FOR REASONS THAT ARE NOT CLEAR TO ME. SO FOR C NOW, USE THE SUMMATION FORMULA. THIS IS LESS C EFFICIENT, BUT IT SEEMS TO PROVIDE ACCURATE ANSWERS. C CCCCC DTWO=2.0D0 CCCCC DTERM1=-DTHETA + DLOG(1.0D0-DP) + DLOG(DTHETA) - DLOG(DP) CCCCC 1 + DX*DLOG(DP) CCCCC CALL CHM(DTWO,-DTHETA*(1.0D0-DP)/DP,1.0D0-DX,DTERM2,IERROR) CCCCC DTERM2=DLOG(DTERM2) CCCCC DPDF=DEXP(DTERM1 + DTERM2) CCCCC print *,'dterm1,dterm2,dpdf=',dterm1,dterm2,dpdf C DTERM1=-DTHETA + DX*DLOG(DP) DSUM=0.0D0 DO100J=1,INTX DJ=DBLE(J) DTERM2=DLNGAM(DX) - DLNGAM(DJ) - DLNGAM(DX-DJ+1.0D0) DTERM3=DJ*DLOG(DALPHA) - DLNGAM(DJ+1.0D0) DSUM=DSUM + DEXP(DTERM2 + DTERM3) 100 CONTINUE DTERM4=DLOG(DSUM) DPDF=DEXP(DTERM1 + DTERM4) ENDIF C 9999 CONTINUE RETURN END SUBROUTINE PAPPPF(DX,DTHETA,DP,DPPF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT C FUNCTION VALUE AT THE DOUBLE PRECISION VALUE DX C FOR THE POLYA-AEPPLI DISTRIBUTION C WITH DOUBLE PRECISION SHAPE PARAMETERS DTHETA AND C DP. THIS DISTRIBUTION IS DEFINED FOR 0 <= DX < 1. C THIS DISTRIBUTION HAS THE PROBABILITY FUNCTION C p(X;THETA,P) = EXP(-THETA)*(THETA*(1-P)/P)*P**X* C CHU(X+1;2,THETA*(1-P)/P) C = EXP(-THETA)*P**X* C SUM[J=1 to X][(X-1 J-1)* C (THETA*(1-P)/P)**J/J! C X = 1, 2, .... C C p(0;THETA,P) = EXP(-THETA) C C CHU = THE CONFLUENT HYPERGEOMETRIC FUNTION 1F1. C C JOHNSON, KOTZ, AND KEMP GIVE THE FOLLOWING C FORMULAS FOR X = 1, ..., 4 (ALPHA=THETA*(1-P)/P): C C C p(1;THETA,P) = EXP(-THETA)* C p(2;THETA,P) = EXP(-THETA)*ALPHA*P**2*(1+ALPHA/2) C p(2;THETA,P) = EXP(-THETA)*ALPHA*P**2*(1+ALPHA/2) C p(3;THETA,P) = EXP(-THETA)*ALPHA*P**3* C (1+ALPHA+ALPHA**2/6) C p(4;THETA,P) = EXP(-THETA)*ALPHA*P**4* C (1+3*ALPHA/2+ALPHA**2/2+ALPHA**3/24) C C FOR THE CDF, WE USE THE FOLLOWING RECURRENCE C RELATION (FROM JOHNSON, KOTZ AND KEMP): C C p(X+1) = (THETA*(1-P)/(X+1))*SUM[J=1 TO X] C [(X+1-J)*P**(X-J)*p(X)] C C INPUT ARGUMENTS--DX = THE DOUBLE PRECISION VALUE C AT WHICH THE PERCENT POINT C FUNCTION IS TO BE EVALUATED. C X SHOULD BE A NON-NEGATIVE INTEGR C --DTHETA = THE DOUBLE PRECISION VALUE C OF THE FIRST SHAPE PARAMETER. C --DP = THE DOUBLE PRECISION VALUE C OF THE SECOND SHAPE PARAMETER. C OUTPUT ARGUMENTS--DPPF = THE DOUBLE PRECISION PERCENT POINT C FUNCTION VALUE C OUTPUT--THE DOUBLE PRECISION PERCENT POINT FUNCTION C VALUE DPPF FOR THE POLYA-AEPPLI DISTRIBUTION C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--0 <= X < P. C --0 < P < 1, AND THETA > 0 C OTHER DATAPAC SUBROUTINES NEEDED--DLNGAM, DCHU. C FORTRAN LIBRARY SUBROUTINES NEEDED--DEXP, DLOG C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--JOHNSON, KOTZ, AND KEMP (1992). "UNIVARIATE C DISCRETE DISTRIBUTIONS", SECOND EDITION, C WILEY, PP. 378-382. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2006/6 C ORIGINAL VERSION--JUNE 2006. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C IMPLICIT DOUBLE PRECISION (A-H,O-Z) C C--------------------------------------------------------------------- C REAL R1MACH INCLUDE 'DPCOMC.INC' C REAL CPUMIN REAL CPUMAX C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C DPPF=0.0D0 C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(DP.LE.0.0D0 .OR. DP.GE.1.0D0)THEN WRITE(ICOUT,11) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)DP CALL DPWRST('XXX','BUG ') DPPF=0.0D0 GOTO9999 ENDIF C IF(DTHETA.LE.0.0D0)THEN WRITE(ICOUT,12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)DTHETA CALL DPWRST('XXX','BUG ') DPPF=0.0D0 GOTO9999 ENDIF C IF(DX.LT.0.0D0 .OR. DX.GE.1.0D0)THEN WRITE(ICOUT,13) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)DX CALL DPWRST('XXX','BUG ') DPPF=0.0D0 GOTO9999 ENDIF C 11 FORMAT('***** ERROR--THE THIRD ARGUMENT TO ', 1'PAPPPF IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL') 12 FORMAT('***** ERROR--THE SECOND ARGUMENT TO ', 1'PAPPPF IS NON-POSITIVE') 13 FORMAT('***** ERROR--THE FIRST ARGUMENT TO ', 1'PAPPPF IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7) 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8) C IF(DX.LE.0.0D0)THEN DPPF=0.0D0 GOTO9999 ENDIF C DQ=1.0D0 - DP DALPHA=DTHETA*DQ/DP C DPDFS2=DEXP(-DTHETA) IF(DPDFS2.GE.DX)THEN DPPF=0.0D0 GOTO9999 ENDIF DTERM1=-DTHETA + DLOG(DALPHA) + DLOG(DP) DPDFS1=DEXP(DTERM1) DCDF=DPDFS1+DPDFS2 IF(DCDF.GE.DX)THEN DPPF=1.0D0 GOTO9999 ENDIF I=1 C 100 CONTINUE C I=I+1 IF(DBLE(I).GE.DBLE(I1MACH(9)))THEN WRITE(ICOUT,55) 55 FORMAT('***** ERROR--THE COMPUTED PERCENT POINT VALUE ', 1 'EXCEEDS THE LARGEST MACHINE INTEGER.') CALL DPWRST('XXX','BUG ') DPPF=0.0 GOTO9999 ENDIF C IF(I.EQ.2)THEN DTERM1=-DTHETA + DLOG(DALPHA) + 2.0D0*DLOG(DP) + 1 DLOG(1.0D0 + DALPHA/2.0D0) DPDF=DEXP(DTERM1) ELSEIF(I.EQ.3)THEN DTERM1=-DTHETA + DLOG(DALPHA) + 3.0D0*DLOG(DP) + 1 DLOG(1.0D0 + DALPHA + DALPHA**2/6.0D0) DPDF=DEXP(DTERM1) ELSEIF(I.EQ.4)THEN DTERM1=-DTHETA + DLOG(DALPHA) + 4.0D0*DLOG(DP) + 1 DLOG(1.0D0 + 1.5D0*DALPHA + 0.5D0*DALPHA**2 1 + DALPHA**3/24.0D0) DPDF=DEXP(DTERM1) ELSE DTERM1=(1.0D0/DBLE(I)) DTERM2=(DTHETA*DQ + 2.0D0*DP*DBLE(I-1))*DPDFS1 DTERM3=DP**2*DBLE(I-2)*DPDFS2 DPDF=DTERM1*(DTERM2 - DTERM3) ENDIF DCDF=DCDF + DPDF DPDFS2=DPDFS1 DPDFS1=DPDF IF(DCDF.GE.DX)THEN DPPF=DBLE(I) GOTO9999 ENDIF GOTO100 C 9999 CONTINUE RETURN END SUBROUTINE PAPRAN(N,THETA,P,ISEED,X) C C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N C FROM THE POLYA-AEPPLI DISTRIBUTION C WITH SHAPE PARAMETERS THETA AND P. C THIS DISTRIBUTION IS DEFINED FOR ALL C NON-NEGATIVE INTEGER X >= 0. C THIS DISTRIBUTION HAS THE PROBABILITY FUNCTION C p(X;THETA,P) = EXP(-THETA)*(THETA*(1-P)/P)*P**X* C CHU(X+1;2,THETA*(1-P)/P) C = EXP(-THETA)*P**X* C SUM[J=1 to X][(X-1 J-1)* C (THETA*(1-P)/P)**J/J! C X = 1, 2, .... C C p(0;THETA,P) = EXP(-THETA) C C CHU = THE CONFLUENT HYPERGEOMETRIC FUNTION 1F1. C C JOHNSON, KOTZ, AND KEMP GIVE THE FOLLOWING C FORMULAS FOR X = 1, ..., 4 (ALPHA=THETA*(1-P)/P): C C C p(1;THETA,P) = EXP(-THETA)* C p(2;THETA,P) = EXP(-THETA)*ALPHA*P**2*(1+ALPHA/2) C p(2;THETA,P) = EXP(-THETA)*ALPHA*P**2*(1+ALPHA/2) C p(3;THETA,P) = EXP(-THETA)*ALPHA*P**3* C (1+ALPHA+ALPHA**2/6) C p(4;THETA,P) = EXP(-THETA)*ALPHA*P**4* C (1+3*ALPHA/2+ALPHA**2/2+ALPHA**3/24) C C INPUT ARGUMENTS--N = THE DESIRED INTEGER NUMBER C OF RANDOM NUMBERS TO BE C GENERATED. C --THETA = THE SINGLE PRECISION VALUE C OF THE FIRST SHAPE PARAMETER. C --P = THE SINGLE PRECISION VALUE C OF THE SECOND SHAPE PARAMETER. C OUTPUT ARGUMENTS--X = A SINGLE PRECISION VECTOR C (OF DIMENSION AT LEAST N) C INTO WHICH THE GENERATED C RANDOM SAMPLE WILL BE PLACED. C OUTPUT--A RANDOM SAMPLE OF SIZE N C FROM THE POLYA-AEPPLI DISTRIBUTION C WITH SHAPE PARAMETERS THETA AND P. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C --0 < P < 1, THETA > 0 C OTHER DATAPAC SUBROUTINES NEEDED--UNIRAN C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--JOHNSON, KOTZ, AND KEMP (1992). "UNIVARIATE C DISCRETE DISTRIBUTIONS", SECOND EDITION, C WILEY, PP. 378-382. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2006/6 C ORIGINAL VERSION--JUNE 2006. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES----------------- C C------------------------------------------------------------------- C REAL THETA REAL P DIMENSION X(*) C DOUBLE PRECISION DTHETA DOUBLE PRECISION DP DOUBLE PRECISION DTEMP DOUBLE PRECISION DPPF C C------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----DATA STATEMENTS----------------------------------------------- C C-----START POINT--------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(N.LT.1)THEN WRITE(ICOUT, 5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)N CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF 5 FORMAT('***** ERROR--THE REQUESTED NUMBER OF ', 1'POLYA-AEPPLI RANDOM NUMBERS IS NON-POSITIVE') C IF(P.LE.0.0 .OR. P.GE.1.0)THEN WRITE(ICOUT,11) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)P CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF 11 FORMAT('***** ERROR--THE P SHAPE PARAMETER FOR POLYA-AEPPLI ') 12 FORMAT(' RANDOM NUMBERS IS OUTSIDE THE ALLOWABLE (0,1) ', 1 'INTERVAL') C IF(THETA.LE.0.0)THEN WRITE(ICOUT,21) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,22) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)THETA CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF 21 FORMAT('***** ERROR--THE THETA SHAPE PARAMETER FOR ', 1 'POLYA-AEPPLI') 22 FORMAT(' RANDOM NUMBERS IS NON-POSITIVE.') C 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8) 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8) C C 100 CONTINUE C CALL UNIRAN(N,ISEED,X) DTHETA=DBLE(THETA) DP=DBLE(P) C DO100I=1,N DTEMP=DBLE(X(I)) CALL PAPPPF(DTEMP,DTHETA,DP,DPPF) X(I)=REAL(DPPF) 100 CONTINUE C 9999 CONTINUE C RETURN END SUBROUTINE PARCHI(IHP,IHP2,IDIST, 1IPAR,ILOWLM,IUPPLM,LOWLTY,UPPLTY, 1ISUBN1,ISUBN2,IERROR) C C PURPOSE--CHECK TO SEE IF A (INTEGER) PARAMETER IS IN C A SPECIFIED RANGE. UTILITY ROUTINE FOR C PROBABILITY PLOT, LAHEY COMPILER HAD TROUBLE C COMPILING DPPP. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--98/8 C ORIGINAL VERSION--AUGUST 1998. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'DPCOHK.INC' C CHARACTER*4 IHP CHARACTER*4 IHP2 CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 LOWLTY CHARACTER*4 UPPLTY CHARACTER*30 IDIST CHARACTER*4 IERROR C CHARACTER*4 IHWUSE CHARACTER*4 MESSAG C C-----COMMON VARIABLES (GENERAL)-------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C C ************************************ C ** STEP 1-- ** C ** CHECK FOR GAMMA DISTRIBUTION ** C ** PARAMETER GAMMA ** C ************************************ C IHWUSE='P' MESSAG='YES' CALL CHECKN(IHP,IHP2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IPAR=VALUE(ILOCP)+0.5 C IF(LOWLTY.EQ.'> ')THEN IF(IPAR.GT.ILOWLM)GOTO1590 ELSEIF(LOWLTY.EQ.'>= ')THEN IF(IPAR.GE.ILOWLM)GOTO1590 ENDIF WRITE(ICOUT,999) 999 FORMAT(' ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1511)ISUBN1,ISUBN2 1511 FORMAT('***** ERROR IN ',A4,A4,'--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1512)IHP,IHP2 1512 FORMAT(' THE SPECIFIED SHAPE PARAMETER ',A4,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1513)IDIST 1513 FORMAT(' FOR THE ',A30,' DISTRIBUTION') CALL DPWRST('XXX','BUG ') IF(LOWLTY.EQ.'> ')THEN WRITE(ICOUT,1514)ILOWLM 1514 FORMAT(' MUST BE STRICTLY LARGER THAN ',I10,';') CALL DPWRST('XXX','BUG ') ELSEIF(LOWLTY.EQ.'>= ')THEN WRITE(ICOUT,1524)ILOWLM 1524 FORMAT(' MUST BE LARGER THAN OR EQUAL TO ',I10,';') CALL DPWRST('XXX','BUG ') ENDIF WRITE(ICOUT,1515) 1515 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1516)IHP,IHP2,IPAR 1516 FORMAT(' THE SPECIFIED VALUE OF ',A4,A4,' = ',I10) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 1590 CONTINUE C IF(UPPLTY.EQ.'< ')THEN IF(IPAR.LT.IUPPLM)GOTO1690 ELSEIF(UPPLTY.EQ.'<= ')THEN IF(IPAR.LE.IUPPLM)GOTO1690 ENDIF WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1611)ISUBN1,ISUBN2 1611 FORMAT('***** ERROR IN ',A4,A4,'--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1612)IHP,IHP2 1612 FORMAT(' THE SPECIFIED SHAPE PARAMETER ',A4,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1613)IDIST 1613 FORMAT(' FOR THE ',A30,' DISTRIBUTION') CALL DPWRST('XXX','BUG ') IF(UPPLTY.EQ.'< ')THEN WRITE(ICOUT,1614)IUPPLM 1614 FORMAT(' MUST BE STRICTLY LESS THAN ',I10,';') CALL DPWRST('XXX','BUG ') ELSEIF(UPPLTY.EQ.'<= ')THEN WRITE(ICOUT,1624)IUPPLM 1624 FORMAT(' MUST BE LESS THAN OR EQUAL TO',I10,';') CALL DPWRST('XXX','BUG ') ENDIF WRITE(ICOUT,1615) 1615 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1616)IHP,IHP2,IPAR 1616 FORMAT(' THE SPECIFIED VALUE OF ',A4,A4,' = ',I10) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 1690 CONTINUE C 9000 CONTINUE RETURN END SUBROUTINE PARCHR(IHP,IHP2,IDIST, 1APAR,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1ISUBN1,ISUBN2,IERROR) C C PURPOSE--CHECK TO SEE IF A (REAL) PARAMETER IS IN C A SPECIFIED RANGE. UTILITY ROUTINE FOR C PROBABILITY PLOT, LAHEY COMPILER HAD TROUBLE C COMPILING DPPP. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--98/8 C ORIGINAL VERSION--AUGUST 1998. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'DPCOHK.INC' C CHARACTER*4 IHP CHARACTER*4 IHP2 CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 LOWLTY CHARACTER*4 UPPLTY CHARACTER*30 IDIST CHARACTER*4 IERROR C CHARACTER*4 IHWUSE CHARACTER*4 MESSAG C C-----COMMON VARIABLES (GENERAL)-------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C C ************************************ C ** STEP 1-- ** C ** CHECK FOR GAMMA DISTRIBUTION ** C ** PARAMETER GAMMA ** C ************************************ C IHWUSE='P' MESSAG='YES' CALL CHECKN(IHP,IHP2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR) IF(IERROR.EQ.'YES')GOTO9000 APAR=VALUE(ILOCP) C IF(LOWLTY.EQ.'> ')THEN IF(APAR.GT.ALOWLM)GOTO1590 ELSEIF(LOWLTY.EQ.'>= ')THEN IF(APAR.GE.ALOWLM)GOTO1590 ENDIF WRITE(ICOUT,999) 999 FORMAT(' ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1511)ISUBN1,ISUBN2 1511 FORMAT('***** ERROR IN ',A4,A4,'--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1512)IHP,IHP2 1512 FORMAT(' THE SPECIFIED SHAPE PARAMETER ',A4,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1513)IDIST 1513 FORMAT(' FOR THE ',A30,' DISTRIBUTION') CALL DPWRST('XXX','BUG ') IF(LOWLTY.EQ.'> ')THEN WRITE(ICOUT,1514)ALOWLM 1514 FORMAT(' MUST BE STRICTLY LARGER THAN ',F10.5,';') CALL DPWRST('XXX','BUG ') ELSEIF(LOWLTY.EQ.'>= ')THEN WRITE(ICOUT,1524)ALOWLM 1524 FORMAT(' MUST BE LARGER THAN OR EQUAL TO ',F10.5,';') CALL DPWRST('XXX','BUG ') ENDIF WRITE(ICOUT,1515) 1515 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1516)IHP,IHP2,APAR 1516 FORMAT(' THE SPECIFIED VALUE OF ',A4,A4,' = ',E15.7) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 1590 CONTINUE C IF(UPPLTY.EQ.'< ')THEN IF(APAR.LT.AUPPLM)GOTO1690 ELSEIF(UPPLTY.EQ.'<= ')THEN IF(APAR.LE.AUPPLM)GOTO1690 ENDIF WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1611)ISUBN1,ISUBN2 1611 FORMAT('***** ERROR IN ',A4,A4,'--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1612)IHP,IHP2 1612 FORMAT(' THE SPECIFIED SHAPE PARAMETER ',A4,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1613)IDIST 1613 FORMAT(' FOR THE ',A30,' DISTRIBUTION') CALL DPWRST('XXX','BUG ') IF(UPPLTY.EQ.'< ')THEN WRITE(ICOUT,1614)AUPPLM 1614 FORMAT(' MUST BE STRICTLY LESS THAN ',F10.5,';') CALL DPWRST('XXX','BUG ') ELSEIF(UPPLTY.EQ.'<= ')THEN WRITE(ICOUT,1624)AUPPLM 1624 FORMAT(' MUST BE LESS THAN OR EQUAL TO',F10.5,';') CALL DPWRST('XXX','BUG ') ENDIF WRITE(ICOUT,1615) 1615 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1616)IHP,IHP2,APAR 1616 FORMAT(' THE SPECIFIED VALUE OF ',A4,A4,' = ',E15.7) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 1690 CONTINUE C 9000 CONTINUE RETURN END SUBROUTINE PARCH2(IHP,IHP2,IDIST, 1APAR,APARDF,ALOWLM,AUPPLM,LOWLTY,UPPLTY, 1ISUBN1,ISUBN2,IERROR) C C PURPOSE--CHECK TO SEE IF A (REAL) PARAMETER IS IN C A SPECIFIED RANGE. UTILITY ROUTINE FOR C PPCC PLOT, KOLMOGOROV-SMIRNOV PLOT. C THIS IS SLIGHTLY MODIFIED VERSION OF PARCHR C (USED BY PROB PLOT, K-S AND CHI-SQUARE GOODNESS C OF FIT TESTS). DISTINCTION IS THAT PARAMETER C IS OPTIONAL AND A SUITABLE DEFAULT VALUE IS C PROVIDED. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2004/3 C ORIGINAL VERSION--MARCH 2004. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'DPCOHK.INC' C CHARACTER*4 IHP CHARACTER*4 IHP2 CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 LOWLTY CHARACTER*4 UPPLTY CHARACTER*30 IDIST CHARACTER*4 IERROR C CHARACTER*4 IHWUSE CHARACTER*4 MESSAG C C-----COMMON VARIABLES (GENERAL)-------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C C ************************************ C ** STEP 1-- ** C ** CHECK FOR PARAMETER ** C ************************************ C IHWUSE='P' MESSAG='NO' CALL CHECKN(IHP,IHP2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR) IF(IERROR.EQ.'YES')THEN APAR=APARDF ELSE APAR=VALUE(ILOCP) ENDIF C IERROR='NO' IF(LOWLTY.EQ.'> ')THEN IF(APAR.GT.ALOWLM)GOTO1590 ELSEIF(LOWLTY.EQ.'>= ')THEN IF(APAR.GE.ALOWLM)GOTO1590 ENDIF WRITE(ICOUT,999) 999 FORMAT(' ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1511)ISUBN1,ISUBN2 1511 FORMAT('***** ERROR IN ',A4,A4,'--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1512)IHP,IHP2 1512 FORMAT(' THE SPECIFIED SHAPE PARAMETER ',A4,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1513)IDIST 1513 FORMAT(' FOR THE ',A30,' DISTRIBUTION') CALL DPWRST('XXX','BUG ') IF(LOWLTY.EQ.'> ')THEN WRITE(ICOUT,1514)ALOWLM 1514 FORMAT(' MUST BE STRICTLY LARGER THAN ',F10.5,';') CALL DPWRST('XXX','BUG ') ELSEIF(LOWLTY.EQ.'>= ')THEN WRITE(ICOUT,1524)ALOWLM 1524 FORMAT(' MUST BE LARGER THAN OR EQUAL TO ',F10.5,';') CALL DPWRST('XXX','BUG ') ENDIF WRITE(ICOUT,1515) 1515 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1516)IHP,IHP2,APAR 1516 FORMAT(' THE SPECIFIED VALUE OF ',A4,A4,' = ',E15.7) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 1590 CONTINUE C IF(UPPLTY.EQ.'< ')THEN IF(APAR.LT.AUPPLM)GOTO1690 ELSEIF(UPPLTY.EQ.'<= ')THEN IF(APAR.LE.AUPPLM)GOTO1690 ENDIF WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1611)ISUBN1,ISUBN2 1611 FORMAT('***** ERROR IN ',A4,A4,'--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1612)IHP,IHP2 1612 FORMAT(' THE SPECIFIED SHAPE PARAMETER ',A4,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1613)IDIST 1613 FORMAT(' FOR THE ',A30,' DISTRIBUTION') CALL DPWRST('XXX','BUG ') IF(UPPLTY.EQ.'< ')THEN WRITE(ICOUT,1614)AUPPLM 1614 FORMAT(' MUST BE STRICTLY LESS THAN ',F10.5,';') CALL DPWRST('XXX','BUG ') ELSEIF(UPPLTY.EQ.'<= ')THEN WRITE(ICOUT,1624)AUPPLM 1624 FORMAT(' MUST BE LESS THAN OR EQUAL TO',F10.5,';') CALL DPWRST('XXX','BUG ') ENDIF WRITE(ICOUT,1615) 1615 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1616)IHP,IHP2,APAR 1616 FORMAT(' THE SPECIFIED VALUE OF ',A4,A4,' = ',E15.7) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 1690 CONTINUE C 9000 CONTINUE RETURN END SUBROUTINE PARCI2(IHP,IHP2,IDIST, 1IPAR,IPARDF,ILOWLM,IUPPLM,LOWLTY,UPPLTY, 1ISUBN1,ISUBN2,IERROR) C C PURPOSE--CHECK TO SEE IF A (INTEGER) PARAMETER IS IN C A SPECIFIED RANGE. UTILITY ROUTINE FOR C PPCC PLOT AND KOLMOGOROV-SMIRNOV PLOT. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2004/3 C ORIGINAL VERSION--MARCH 2004. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'DPCOHK.INC' C CHARACTER*4 IHP CHARACTER*4 IHP2 CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 LOWLTY CHARACTER*4 UPPLTY CHARACTER*30 IDIST CHARACTER*4 IERROR C CHARACTER*4 IHWUSE CHARACTER*4 MESSAG C C-----COMMON VARIABLES (GENERAL)-------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C C ************************************ C ** STEP 1-- ** C ** CHECK FOR GAMMA DISTRIBUTION ** C ** PARAMETER GAMMA ** C ************************************ C IHWUSE='P' MESSAG='NO' CALL CHECKN(IHP,IHP2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR) IF(IERROR.EQ.'YES')THEN IPAR=IPARDF ELSE IPAR=VALUE(ILOCP)+0.5 ENDIF IERROR='NO' C IF(LOWLTY.EQ.'> ')THEN IF(IPAR.GT.ILOWLM)GOTO1590 ELSEIF(LOWLTY.EQ.'>= ')THEN IF(IPAR.GE.ILOWLM)GOTO1590 ENDIF WRITE(ICOUT,999) 999 FORMAT(' ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1511)ISUBN1,ISUBN2 1511 FORMAT('***** ERROR IN ',A4,A4,'--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1512)IHP,IHP2 1512 FORMAT(' THE SPECIFIED SHAPE PARAMETER ',A4,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1513)IDIST 1513 FORMAT(' FOR THE ',A30,' DISTRIBUTION') CALL DPWRST('XXX','BUG ') IF(LOWLTY.EQ.'> ')THEN WRITE(ICOUT,1514)ILOWLM 1514 FORMAT(' MUST BE STRICTLY LARGER THAN ',I10,';') CALL DPWRST('XXX','BUG ') ELSEIF(LOWLTY.EQ.'>= ')THEN WRITE(ICOUT,1524)ILOWLM 1524 FORMAT(' MUST BE LARGER THAN OR EQUAL TO ',I10,';') CALL DPWRST('XXX','BUG ') ENDIF WRITE(ICOUT,1515) 1515 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1516)IHP,IHP2,IPAR 1516 FORMAT(' THE SPECIFIED VALUE OF ',A4,A4,' = ',I10) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 1590 CONTINUE C IF(UPPLTY.EQ.'< ')THEN IF(IPAR.LT.IUPPLM)GOTO1690 ELSEIF(UPPLTY.EQ.'<= ')THEN IF(IPAR.LE.IUPPLM)GOTO1690 ENDIF WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1611)ISUBN1,ISUBN2 1611 FORMAT('***** ERROR IN ',A4,A4,'--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1612)IHP,IHP2 1612 FORMAT(' THE SPECIFIED SHAPE PARAMETER ',A4,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1613)IDIST 1613 FORMAT(' FOR THE ',A30,' DISTRIBUTION') CALL DPWRST('XXX','BUG ') IF(UPPLTY.EQ.'< ')THEN WRITE(ICOUT,1614)IUPPLM 1614 FORMAT(' MUST BE STRICTLY LESS THAN ',I10,';') CALL DPWRST('XXX','BUG ') ELSEIF(UPPLTY.EQ.'<= ')THEN WRITE(ICOUT,1624)IUPPLM 1624 FORMAT(' MUST BE LESS THAN OR EQUAL TO',I10,';') CALL DPWRST('XXX','BUG ') ENDIF WRITE(ICOUT,1615) 1615 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1616)IHP,IHP2,IPAR 1616 FORMAT(' THE SPECIFIED VALUE OF ',A4,A4,' = ',I10) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 1690 CONTINUE C 9000 CONTINUE RETURN END SUBROUTINE PARCDF(X,GAMMA,A,CDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION C FUNCTION VALUE FOR THE PARETO C DISTRIBUTION WITH SINGLE PRECISION C TAIL LENGTH PARAMETER = GAMMA C AND LOCATION PARAMETER ALOC. C THE PARETO DISTRIBUTION USED C HEREIN IS DEFINED FOR ALL X GREATER THAN C OR EQUAL TO A, C AND HAS THE CUMULATIVE DISTRIBUTION FUNCTION C F(X) = 1 - (A/X)**GAMMA C C NOTE THAT ALTHOUGH A IS COMMONLY REFERRED TO AS A C LOCATION PARAMETER, IT IS NOT IN THE TECHNICAL C SENSE OF C C f(X;A) = f(X-A),0) C C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE C AT WHICH THE CUMULATIVE DISTRIBUTION C FUNCTION IS TO BE EVALUATED. C X SHOULD BE GREATER THAN C OR EQUAL TO ALOC. C --GAMMA = THE SINGLE PRECISION VALUE C OF THE TAIL LENGTH PARAMETER. C GAMMA SHOULD BE POSITIVE. C --A = THE SINGLE PRECISION VALUE C OF THE LOCATION PARAMETER. C ALOC SHOULD BE NON-NEGATIVE. C OUTPUT ARGUMENTS--CDF = THE SINGLE PRECISION CUMULATIVE C DISTRIBUTION FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION C FUNCTION VALUE CDF FOR THE PARETO C DISTRIBUTION WITH TAIL LENGTH PARAMETER VALUE = GAMMA C AND LOCATION PARAMETER A. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--GAMMA AND A SHOULD BE POSITIVE. C --X SHOULD BE GREATER THAN C OR EQUAL TO A. C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN. C REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE C DISTRIBUTIONS--1, 1970, PAGES 233-249. C --HASTINGS AND PEACOCK, STATISTICAL C DISTRIBUTIONS--A HANDBOOK FOR C STUDENTS AND PRACTITIONERS, 1975, C PAGE 102. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING LABORATORY (205.03) C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE: 301-975-2899 C ORIGINAL VERSION--APRIL 1994. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C--------------------------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(X.LT.A)THEN WRITE(ICOUT,4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5)A CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9999 ELSEIF(GAMMA.LE.0.0)THEN WRITE(ICOUT,15) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,16) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)GAMMA CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9999 ELSEIF(A.LE.0.0)THEN WRITE(ICOUT,25) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,26) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)GAMMA CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9999 ENDIF 4 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO THE PARCDF ', 1 'SUBROUTINE') 5 FORMAT(' IS LESS THAN THE LOCATION PARAMETER ',G15.7, 1 '******') 15 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO THE PARCDF ', 1 'SUBROUTINE') 16 FORMAT(' (THE SHAPE PARAMETER) IS NON-POSITIVE *****') 25 FORMAT('***** ERROR--THE THIRD INPUT ARGUMENT TO THE PARCDF ', 1 'SUBROUTINE') 26 FORMAT(' (THE LOCATION PARAMETER) IS NON-POSITIVE *****') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') C C-----START POINT----------------------------------------------------- C CDF=1.0-(A/X)**GAMMA C 9999 CONTINUE RETURN END SUBROUTINE PARCHA(X,GAMMA,A,HAZ) C C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE HAZARD C FUNCTION VALUE FOR THE PARETO C DISTRIBUTION WITH SINGLE PRECISION C TAIL LENGTH PARAMETER = GAMMA C AND LOCATION PARAMETER = A. C THE PARETO DISTRIBUTION USED C HEREIN IS DEFINED FOR ALL X GREATER THAN C OR EQUAL TO A, C AND HAS THE CUMULATIVE HAZARD FUNCTION C H(X) = GAMMA*LOG(X/A) C C NOTE THAT ALTHOUGH A IS COMMONLY REFERRED TO AS A C LOCATION PARAMETER, IT IS NOT IN THE TECHNICAL C SENSE OF C C f(X;A) = f(X-A),0) C C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE C AT WHICH THE PROBABILITY DENSITY C FUNCTION IS TO BE EVALUATED. C X SHOULD BE GREATER THAN C OR EQUAL TO ALOC. C --GAMMA = THE SINGLE PRECISION VALUE C OF THE TAIL LENGTH PARAMETER. C GAMMA SHOULD BE POSITIVE. C --A = THE SINGLE PRECISION VALUE C OF THE LOCATION PARAMETER. C ALOC SHOULD BE NON-NEGATIVE. C OUTPUT ARGUMENTS--HAZ = THE SINGLE PRECISION C CUMULATIVE HAZARD FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION CUMULATIVE HAZARD C FUNCTION VALUE FOR THE PARETO C DISTRIBUTION WITH TAIL LENGTH PARAMETER VALUE = GAMMA C AND LOCATION PARAMETER A. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--GAMMA SHOULD BE POSITIVE. C --X SHOULD BE GREATER THAN C OR EQUAL TO A. C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN. C REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE C DISTRIBUTIONS--1, 1970, CHAPTER 20 C --HASTINGS AND PEACOCK, STATISTICAL C DISTRIBUTIONS--A HANDBOOK FOR C STUDENTS AND PRACTITIONERS, 1975, C PAGE 102. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING LABORATORY (205.03) C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE: 301-975-2855 C ORIGINAL VERSION--APRIL 1998. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C--------------------------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(X.LT.A)THEN WRITE(ICOUT,4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5)A CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') HAZ=0.0 GOTO9999 ELSEIF(GAMMA.LE.0.0)THEN WRITE(ICOUT,15) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,16) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)GAMMA CALL DPWRST('XXX','BUG ') HAZ=0.0 GOTO9999 ELSEIF(A.LE.0.0)THEN WRITE(ICOUT,25) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,26) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)GAMMA CALL DPWRST('XXX','BUG ') HAZ=0.0 GOTO9999 ENDIF 4 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO THE PARCHAZ ', 1 'SUBROUTINE') 5 FORMAT(' IS LESS THAN THE LOCATION PARAMETER ',G15.7, 1 '******') 15 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO THE PARCHAZ ', 1 'SUBROUTINE') 16 FORMAT(' (THE SHAPE PARAMETER) IS NON-POSITIVE *****') 25 FORMAT('***** ERROR--THE THIRD INPUT ARGUMENT TO THE PARCHAZ ', 1 'SUBROUTINE') 26 FORMAT(' (THE LOCATION PARAMETER) IS NON-POSITIVE *****') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') C C-----START POINT----------------------------------------------------- C HAZ=GAMMA*LOG(X/A) C 9999 CONTINUE RETURN END SUBROUTINE PARHAZ(X,GAMMA,A,HAZ) C C PURPOSE--THIS SUBROUTINE COMPUTES THE HAZARD C FUNCTION VALUE FOR THE PARETO C DISTRIBUTION WITH SINGLE PRECISION C TAIL LENGTH PARAMETER = GAMMA C AND LOCATION PARAMETER = A. C THE PARETO DISTRIBUTION USED C HEREIN IS DEFINED FOR ALL X GREATER THAN C OR EQUAL TO A, AND HAS THE HAZARD FUNCTION C H(X) = GAMMA / X C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE C AT WHICH THE PROBABILITY DENSITY C FUNCTION IS TO BE EVALUATED. C X SHOULD BE GREATER THAN C OR EQUAL TO ALOC. C --GAMMA = THE SINGLE PRECISION VALUE C OF THE TAIL LENGTH PARAMETER. C GAMMA SHOULD BE POSITIVE. C --A = THE SINGLE PRECISION VALUE C OF THE LOCATION PARAMETER. C ALOC SHOULD BE POSITIVE. C OUTPUT ARGUMENTS--HAZ = THE SINGLE PRECISION C HAZARD FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION HAZARD C FUNCTION VALUE PDF FOR THE PARETO C DISTRIBUTION WITH TAIL LENGTH PARAMETER VALUE = GAMMA C AND LOCATION PARAMETER A. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--GAMMA AND A SHOULD BE POSITIVE. C --X SHOULD BE GREATER THAN OR EQUAL TO A. C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN. C REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE C DISTRIBUTIONS--1, 1970, CHAPTER 20 C --HASTINGS AND PEACOCK, STATISTICAL C DISTRIBUTIONS--A HANDBOOK FOR C STUDENTS AND PRACTITIONERS, 1975, C PAGE 102. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING LABORATORY (205.03) C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE: 301-975-2855 C ORIGINAL VERSION--APRIL 1998. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C--------------------------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(X.LT.A)THEN WRITE(ICOUT,4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5)A CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') HAZ=0.0 GOTO9999 ELSEIF(GAMMA.LE.0.0)THEN WRITE(ICOUT,15) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,16) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)GAMMA CALL DPWRST('XXX','BUG ') HAZ=0.0 GOTO9999 ELSEIF(A.LE.0.0)THEN WRITE(ICOUT,25) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,26) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)GAMMA CALL DPWRST('XXX','BUG ') HAZ=0.0 GOTO9999 ENDIF 4 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO THE PARHAZ ', 1 'SUBROUTINE') 5 FORMAT(' IS LESS THAN THE LOCATION PARAMETER ',G15.7, 1 '******') 15 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO THE PARHAZ ', 1 'SUBROUTINE') 16 FORMAT(' (THE SHAPE PARAMETER) IS NON-POSITIVE *****') 25 FORMAT('***** ERROR--THE THIRD INPUT ARGUMENT TO THE PARHAZ ', 1 'SUBROUTINE') 26 FORMAT(' (THE LOCATION PARAMETER) IS NON-POSITIVE *****') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') C C-----START POINT----------------------------------------------------- C HAZ=GAMMA/X C 9999 CONTINUE RETURN END SUBROUTINE PARPDF(X,GAMMA,A,PDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY C FUNCTION VALUE FOR THE PARETO C DISTRIBUTION WITH SINGLE PRECISION C TAIL LENGTH PARAMETER = GAMMA. C THE PARETO DISTRIBUTION USED C HEREIN IS DEFINED FOR ALL X GREATER THAN C OR EQUAL TO A, C AND HAS THE PROBABILITY DENSITY FUNCTION C F(X) = GAMMA*A**GAMMA/(X**(GAMMA+1)) X >= A. C A, GAMMA > 0 C C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE C AT WHICH THE PROBABILITY DENSITY C FUNCTION IS TO BE EVALUATED. C X SHOULD BE GREATER THAN C OR EQUAL TO ALOC. C --GAMMA = THE SINGLE PRECISION VALUE C OF THE TAIL LENGTH PARAMETER. C GAMMA SHOULD BE POSITIVE. C --A = THE SINGLE PRECISION VALUE C OF THE LOCATION PARAMETER. C ALOC SHOULD BE NON-NEGATIVE. C OUTPUT ARGUMENTS--PDF = THE SINGLE PRECISION PROBABILITY C DENSITY FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY C FUNCTION VALUE PDF FOR THE PARETO C DISTRIBUTION WITH TAIL LENGTH PARAMETER VALUE = GAMMA C AND LOCATION PARAMETER A. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--GAMMA SHOULD BE POSITIVE. C --X SHOULD BE GREATER THAN OR EQUAL TO A. C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN. C REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE C DISTRIBUTIONS--1, 1970, PAGES 233-249. C --HASTINGS AND PEACOCK, STATISTICAL C DISTRIBUTIONS--A HANDBOOK FOR C STUDENTS AND PRACTITIONERS, 1975, C PAGE 102. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING LABORATORY (205.03) C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE: 301-975-2855 C ORIGINAL VERSION--APRIL 1994. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C--------------------------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(X.LT.A)THEN WRITE(ICOUT,4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5)A CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ELSEIF(GAMMA.LE.0.0)THEN WRITE(ICOUT,15) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,16) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)GAMMA CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ELSEIF(A.LE.0.0)THEN WRITE(ICOUT,25) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,26) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)GAMMA CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ENDIF 4 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO THE PARPDF ', 1 'SUBROUTINE') 5 FORMAT(' IS LESS THAN THE LOCATION PARAMETER ',G15.7, 1 '******') 15 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO THE PARPDF ', 1 'SUBROUTINE') 16 FORMAT(' (THE SHAPE PARAMETER) IS NON-POSITIVE *****') 25 FORMAT('***** ERROR--THE THIRD INPUT ARGUMENT TO THE PARPDF ', 1 'SUBROUTINE') 26 FORMAT(' (THE LOCATION PARAMETER) IS NON-POSITIVE *****') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') C C-----START POINT----------------------------------------------------- C PDF=GAMMA*A**GAMMA/(X**(GAMMA+1.0)) C 9999 CONTINUE RETURN END SUBROUTINE PARPPF(P,GAMMA,A,PPF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT C FUNCTION VALUE FOR THE PARETO C DISTRIBUTION WITH SINGLE PRECISION C TAIL LENGTH PARAMETER = GAMMA C AND LOCATION PARAMETER = A. C THE PARETO DISTRIBUTION USED C HEREIN IS DEFINED FOR ALL X GREATER THAN C OR EQUAL TO A, C AND HAS THE PERCENT POINT FUNCTION C G(P) = A*(1.0-P)**(-1.0/GAMMA) C NOTE THAT THE PERCENT POINT FUNCTION OF A DISTRIBUTION C IS IDENTICALLY THE SAME AS THE INVERSE CUMULATIVE C DISTRIBUTION FUNCTION OF THE DISTRIBUTION. C C NOTE THAT ALTHOUGH A IS COMMONLY REFERRED TO AS A C LOCATION PARAMETER, IT IS NOT IN THE TECHNICAL C SENSE OF C C f(X;A) = f(X-A),0) C C INPUT ARGUMENTS--P = THE SINGLE PRECISION VALUE C (BETWEEN 0.0 (INCLUSIVELY) C AND 1.0 (EXCLUSIVELY)) C AT WHICH THE PERCENT POINT C FUNCTION IS TO BE EVALUATED. C --GAMMA = THE SINGLE PRECISION VALUE C OF THE TAIL LENGTH PARAMETER. C GAMMA SHOULD BE POSITIVE. C --A = THE SINGLE PRECISION VALUE C OF THE LOCATION PARAMETER. C A SHOULD BE NON-NEGATIVE. C OUTPUT ARGUMENTS--PPF = THE SINGLE PRECISION PERCENT C POINT FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION PERCENT POINT FUNCTION . C VALUE PPF FOR THE PARETO DISTRIBUTION C WITH TAIL LENGTH PARAMETER VALUE = GAMMA. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--GAMMA AND A SHOULD BE POSITIVE. C --P SHOULD BE BETWEEN 0.0 (INCLUSIVELY) C AND 1.0 (EXCLUSIVELY). C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE C DISTRIBUTIONS--1, 1970, PAGES 233-249. C --HASTINGS AND PEACOCK, STATISTICAL C DISTRIBUTIONS--A HANDBOOK FOR C STUDENTS AND PRACTITIONERS, 1975, C PAGE 102. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--82.6 C ORIGINAL VERSION--NOVEMBER 1975. C UPDATED --DECEMBER 1981. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(P.LT.0.0.OR.P.GE.1.0)THEN WRITE(ICOUT,1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)P CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9999 ELSEIF(GAMMA.LE.0.0)THEN WRITE(ICOUT,15) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,16) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)GAMMA CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9999 ELSEIF(A.LE.0.0)THEN WRITE(ICOUT,25) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,26) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)GAMMA CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9999 ENDIF 1 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO THE ', 1'PARPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE [0,1) INTERVAL') 15 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO THE PARPPF ', 1 'SUBROUTINE') 16 FORMAT(' (THE SHAPE PARAMETER) IS NON-POSITIVE *****') 25 FORMAT('***** ERROR--THE THIRD INPUT ARGUMENT TO THE PARPPF ', 1 'SUBROUTINE') 26 FORMAT(' (THE LOCATION PARAMETER) IS NON-POSITIVE *****') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') C PPF=A*(1.0-P)**(-1.0/GAMMA) C 9999 CONTINUE RETURN END SUBROUTINE PARRAN(N,GAMMA,A,ISEED,X) C C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N C FROM THE PARETO DISTRIBUTION C WITH TAIL LENGTH PARAMETER VALUE = GAMMA. C THE PROTOTYPE PARETO DISTRIBUTION USED C HEREIN IS DEFINED FOR ALL X GREATER THAN C OR EQUAL TO 1, C AND HAS THE PROBABILITY DENSITY FUNCTION C F(X) = GAMMA*A**GAMMA/(X**(GAMMA+1)). C C NOTE THAT ALTHOUGH A IS COMMONLY REFERRED TO AS A C LOCATION PARAMETER, IT IS NOT IN THE TECHNICAL C SENSE OF C C f(X;A) = f(X-A),0) C C INPUT ARGUMENTS--N = THE DESIRED INTEGER NUMBER C OF RANDOM NUMBERS TO BE C GENERATED. C --GAMMA = THE SINGLE PRECISION VALUE OF THE C TAIL LENGTH PARAMETER. C GAMMA SHOULD BE POSITIVE. C --A = THE SINGLE PRECISION VALUE C OF THE LOCATION PARAMETER. C A SHOULD BE NON-NEGATIVE. C OUTPUT ARGUMENTS--X = A SINGLE PRECISION VECTOR C (OF DIMENSION AT LEAST N) C INTO WHICH THE GENERATED C RANDOM SAMPLE WILL BE PLACED. C OUTPUT--A RANDOM SAMPLE OF SIZE N C FROM THE PARETO DISTRIBUTION C WITH TAIL LENGTH PARAMETER VALUE = GAMMA C LOCATION PARAMETER VALUE = A C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C --GAMMA AND A SHOULD BE POSITIVE. C OTHER DATAPAC SUBROUTINES NEEDED--UNIRAN. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--TOCHER, THE ART OF SIMULATION, C 1963, PAGES 14-15. C --HAMMERSLEY AND HANDSCOMB, MONTE CARLO METHODS, C 1964, PAGE 36. C --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE C DISTRIBUTIONS--1, 1970, PAGES 233-249. C --HASTINGS AND PEACOCK, STATISTICAL C DISTRIBUTIONS--A HANDBOOK FOR C STUDENTS AND PRACTITIONERS, 1975, C PAGE 104. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--82.6 C ORIGINAL VERSION--NOVEMBER 1975. C UPDATED --DECEMBER 1981. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DIMENSION X(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(N.LT.1)THEN WRITE(ICOUT, 5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)N CALL DPWRST('XXX','BUG ') GOTO9999 ELSEIF(GAMMA.LE.0.0)THEN WRITE(ICOUT,15) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,16) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)GAMMA CALL DPWRST('XXX','BUG ') GOTO9999 ELSEIF(A.LE.0.0)THEN WRITE(ICOUT,25) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,26) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)GAMMA CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF 5 FORMAT('***** ERROR--THE REQUESTED NUMBER OF PARETO RANDOM ', 1'NUMBERS IS NON-POSITIVE ******') 15 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO THE PARPDF ', 1 'SUBROUTINE') 16 FORMAT(' (THE SHAPE PARAMETER) IS NON-POSITIVE *****') 25 FORMAT('***** ERROR--THE THIRD INPUT ARGUMENT TO THE PARPDF ', 1 'SUBROUTINE') 26 FORMAT(' (THE LOCATION PARAMETER) IS NON-POSITIVE *****') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****') C C GENERATE N UNIFORM (0,1) RANDOM NUMBERS; C CALL UNIRAN(N,ISEED,X) C C GENERATE N PARETO DISTRIBUTION RANDOM NUMBERS C USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD. C DO100I=1,N X(I)=A*(1.0-X(I))**(-1.0/GAMMA) 100 CONTINUE C 9999 CONTINUE RETURN END SUBROUTINE PA2CDF(X,GAMMA,A,CDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION C FUNCTION VALUE FOR THE PARETO TYPE II C DISTRIBUTION WITH SINGLE PRECISION TAIL LENGTH C PARAMETER = GAMMA AND LOCATION PARAMETER = A. C THE PARETO DISTRIBUTION USED HEREIN IS DEFINED FOR C ALL X GREATER THAN OR EQUAL TO 0, C AND HAS THE PROBABILITY DENSITY FUNCTION C F(X) = GAMMA*A**GAMMA/(X+A)**(GAMMA+1) C THE CUMULATIVE DISTRIBUTION FUNCTION IS: C F(X) = 1 - A**GAMMA/(X+A)**GAMMA C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE C AT WHICH THE CUMULATIVE DISTRIBUTION C FUNCTION IS TO BE EVALUATED. C X SHOULD BE GREATER THAN C OR EQUAL TO 1. C --GAMMA = THE SINGLE PRECISION VALUE C OF THE TAIL LENGTH PARAMETER. C GAMMA SHOULD BE POSITIVE. C --A = THE SINGLE PRECISION VALUE C OF THE LOCATION PARAMETER. C A SHOULD BE POSITIVE. C OUTPUT ARGUMENTS--CDF = THE SINGLE PRECISION CUMULATIVE C DISTRIBUTION FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION C FUNCTION VALUE CDF FOR THE PARETO C DISTRIBUTION WITH TAIL LENGTH PARAMETER VALUE = GAMMA C AND LOCATION PARAMETER A. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--GAMMA AND A SHOULD BE POSITIVE. C --X SHOULD BE GREATER THAN C OR EQUAL TO 0. C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN. C REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE C DISTRIBUTIONS--2, 1994, CHAPTER 20 C --EVANS, HASTINGS AND PEACOCK, STATISTICAL C DISTRIBUTIONS--CHAPTER 30 C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING LABORATORY (205.03) C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE: 301-975-2899 C ORIGINAL VERSION--OCTOBER 1995. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DCDF DOUBLE PRECISION DA DOUBLE PRECISION DG DOUBLE PRECISION DX C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C--------------------------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(X.LT.0.0)THEN WRITE(ICOUT,4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9999 ELSEIF(GAMMA.LE.0.0)THEN WRITE(ICOUT,15) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)GAMMA CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9999 ELSEIF(A.LE.0.0)THEN WRITE(ICOUT,25) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)GAMMA CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9999 ENDIF 4 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO THE PA2CDF ', 1 'SUBROUTINE IS NEGATIVE.') 15 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO THE PA2CDF ', 1 'SUBROUTINE IS NON-POSITIVE.') 25 FORMAT('***** ERROR--THE THIRD INPUT ARGUMENT TO THE PA2CDF ', 1 'SUBROUTINE IS NON-POSITIVE.') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') C C-----START POINT----------------------------------------------------- C DA=DBLE(A) DG=DBLE(GAMMA) DX=DBLE(X) DCDF=1.0D0 - DA**DG/((DX+DA)**DG) CDF=REAL(DCDF) C 9999 CONTINUE RETURN END SUBROUTINE PA2PDF(X,GAMMA,A,PDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY C FUNCTION VALUE FOR THE PARETO DISTRIBUTION OF THE C SECOND KIND WITH SINGLE PRECISION TAIL LENGTH C PARAMETER = GAMMA AND LOCATION PARAMETER A. C THE PARETO DISTRIBUTION USED HEREIN IS DEFINED FOR C ALL X GREATER THAN OR EQUAL TO 0, C AND HAS THE PROBABILITY DENSITY FUNCTION C F(X) = GAMMA*A**GAMMA/(X+A)**(GAMMA+1) C C NOTE THAT ALTHOUGH A IS COMMONLY REFERRED TO AS A C LOCATION PARAMETER, IT IS NOT IN THE TECHNICAL C SENSE OF C C f(X;A) = f(X-A),0) C C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE C AT WHICH THE PROBABILITY DENSITY C FUNCTION IS TO BE EVALUATED. C X SHOULD BE GREATER THAN C OR EQUAL TO 1. C --GAMMA = THE SINGLE PRECISION VALUE C OF THE TAIL LENGTH PARAMETER. C GAMMA SHOULD BE POSITIVE. C --A = THE SINGLE PRECISION VALUE C OF THE LOCATION PARAMETER. C A SHOULD BE NON-NEGATIVE. C OUTPUT ARGUMENTS--PDF = THE SINGLE PRECISION PROBABILITY C DENSITY FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY C FUNCTION VALUE PDF FOR THE PARETO C DISTRIBUTION WITH TAIL LENGTH PARAMETER VALUE = GAMMA C AND LOCATION PARAMETER A. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--GAMMA AND A SHOULD BE POSITIVE. C --X SHOULD BE GREATER THAN OR EQUAL TO 1. C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN. C REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE C DISTRIBUTIONS--2, 1994, CHAPTER 20 C --EVANS, HASTINGS AND PEACOCK, STATISTICAL C DISTRIBUTIONS--CHAPTER 30 C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING LABORATORY C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE: 301-975-2855 C ORIGINAL VERSION--OCTOBER 1995. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DX DOUBLE PRECISION DG DOUBLE PRECISION DA DOUBLE PRECISION DPDF DOUBLE PRECISION DTERM1 C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C--------------------------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(X.LT.0.0)THEN WRITE(ICOUT,4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ELSEIF(GAMMA.LE.0.0)THEN WRITE(ICOUT,15) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)GAMMA CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ELSEIF(A.LE.0.0)THEN WRITE(ICOUT,25) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)GAMMA CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ENDIF 4 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO THE PA2PDF ', 1 'SUBROUTINE IS NEGATIVE.') 15 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO THE PA2PDF ', 1 'SUBROUTINE IS NON-POSITIVE.') 25 FORMAT('***** ERROR--THE THIRD INPUT ARGUMENT TO THE PA2PDF ', 1 'SUBROUTINE IS NON-POSITIVE.') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') C C-----START POINT----------------------------------------------------- C DX=DBLE(X) DG=DBLE(GAMMA) DA=DBLE(A) DTERM1=DLOG(DG) + DG*DLOG(DA) - (DG+1.0D0)*DLOG(DX+DA) DPDF=DEXP(DTERM1) PDF=SNGL(DPDF) C 9999 CONTINUE RETURN END SUBROUTINE PA2PPF(P,GAMMA,A,PPF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT FUNCTION C VALUE FOR THE PARETO DISTRIBUTION OF THE SECOND KIND C WITH SINGLE PRECISION TAIL LENGTH PARAMETER = GAMMA C AND LOCATION PARAMETER A. C THE PARETO DISTRIBUTION USED HEREIN IS DEFINED FOR C ALL X GREATER THAN OR EQUAL TO 0, C AND HAS THE PROBABILITY DENSITY FUNCTION C F(X) = GAMMA*A**GAMMA/(X+A)**(GAMMA+1) C C THE PERCENT POINT FUNCTION IS C C G(P) = (A**GAMMA/(1-P))**(1/GAMMA) - A C C NOTE THAT ALTHOUGH A IS COMMONLY REFERRED TO AS A C LOCATION PARAMETER, IT IS NOT IN THE TECHNICAL C SENSE OF C C f(X;A) = f(X-A),0) C C INPUT ARGUMENTS--P = THE SINGLE PRECISION VALUE C (BETWEEN 0.0 (INCLUSIVELY) C AND 1.0 (EXCLUSIVELY)) C AT WHICH THE PERCENT POINT C FUNCTION IS TO BE EVALUATED. C --GAMMA = THE SINGLE PRECISION VALUE C OF THE TAIL LENGTH PARAMETER. C GAMMA SHOULD BE POSITIVE. C --A = THE SINGLE PRECISION VALUE C OF THE LOCATION PARAMETER. C A SHOULD BE POSITIVE. C OUTPUT ARGUMENTS--PPF = THE SINGLE PRECISION PERCENT C POINT FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION PERCENT POINT FUNCTION . C VALUE PPF FOR THE PARETO DISTRIBUTION C WITH TAIL LENGTH PARAMETER VALUE = GAMMA AND LOCATION C PARAMETER = A. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--GAMMA AND A SHOULD BE POSITIVE. C --P SHOULD BE BETWEEN 0.0 (EXCLUSIVELY) C AND 1.0 (EXCLUSIVELY). C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE C DISTRIBUTIONS--2, 1994, CHAPTER 20 C --EVANS, HASTINGS AND PEACOCK, STATISTICAL C DISTRIBUTIONS--CHAPTER 30 C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--95/10 C ORIGINAL VERSION--OCTOBER 1995. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DPPF DOUBLE PRECISION DP DOUBLE PRECISION DA DOUBLE PRECISION DG C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(P.LT.0.0.OR.P.GE.1.0)THEN WRITE(ICOUT,1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)P CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9999 ELSEIF(GAMMA.LE.0.0)THEN WRITE(ICOUT,15) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)GAMMA CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9999 ELSEIF(A.LE.0.0)THEN WRITE(ICOUT,25) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)GAMMA CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9999 ENDIF 1 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO THE PA2PPF ', 1 'SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL.') 15 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO THE PA2PPF ', 1 'SUBROUTINE IS NON-POSITIVE.') 25 FORMAT('***** ERROR--THE THIRD INPUT ARGUMENT TO THE PA2PPF ', 1 'SUBROUTINE IS NON-POSITIVE.') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') C IF(P.LE.0.0)THEN PPF=0.0 ELSE DP=DBLE(P) DA=DBLE(A) DG=DBLE(GAMMA) DPPF=(DA**DG/(1.0D0-DP))**(1.0D0/DG) - DA PPF=REAL(DPPF) ENDIF C 9999 CONTINUE RETURN END SUBROUTINE PA2RAN(N,GAMMA,A,ISEED,X) C C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N C FROM THE PARETO DISTRIBUTION OF THE SECOND KIND C WITH TAIL LENGTH PARAMETER VALUE = GAMMA AND C LOCATION PARAMETER A. C THE PARETO DISTRIBUTION USED HEREIN IS DEFINED FOR C ALL X GREATER THAN OR EQUAL TO 0, C AND HAS THE PROBABILITY DENSITY FUNCTION C F(X) = GAMMA*A**GAMMA/(X+A)**(GAMMA+1) C C NOTE THAT ALTHOUGH A IS COMMONLY REFERRED TO AS A C LOCATION PARAMETER, IT IS NOT IN THE TECHNICAL C SENSE OF C C f(X;A) = f(X-A),0) C C INPUT ARGUMENTS--N = THE DESIRED INTEGER NUMBER C OF RANDOM NUMBERS TO BE C GENERATED. C --GAMMA = THE SINGLE PRECISION VALUE OF THE C TAIL LENGTH PARAMETER. C GAMMA SHOULD BE POSITIVE. C --A = THE SINGLE PRECISION VALUE C OF THE LOCATION PARAMETER. C A SHOULD BE POSITIVE. C OUTPUT ARGUMENTS--X = A SINGLE PRECISION VECTOR C (OF DIMENSION AT LEAST N) C INTO WHICH THE GENERATED C RANDOM SAMPLE WILL BE PLACED. C OUTPUT--A RANDOM SAMPLE OF SIZE N C FROM THE PARETO DISTRIBUTION OF THE SECOND KIND C WITH TAIL LENGTH PARAMETER VALUE = GAMMA AND C LOCATION PARAMETER A. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C --GAMMA SHOULD BE POSITIVE. C OTHER DATAPAC SUBROUTINES NEEDED--UNIRAN. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--TOCHER, THE ART OF SIMULATION, C 1963, PAGES 14-15. C --HAMMERSLEY AND HANDSCOMB, MONTE CARLO METHODS, C 1964, PAGE 36. C --JOHNSON, KOTZ, AND BALAKRISHNAN, CONTINUOUS UNIVARIATE C DISTRIBUTIONS--1, 1994. C --EVANS, HASTINGS AND PEACOCK, STATISTICAL C DISTRIBUTIONS--THIRD EDITION, 2000. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--2003.6 C ORIGINAL VERSION--JUNE 2003. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DIMENSION X(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(N.LT.1)THEN WRITE(ICOUT, 5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)N CALL DPWRST('XXX','BUG ') GOTO9000 ELSEIF(GAMMA.LE.0.0)THEN WRITE(ICOUT,15) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)GAMMA CALL DPWRST('XXX','BUG ') GOTO9000 ELSEIF(A.LE.0.0)THEN WRITE(ICOUT,25) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)A CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF 5 FORMAT('***** ERROR--THE NUMBER OF REQUESTED PARETO SECOND ', 1'KIND RANDOM NUMBERS IS NON-POSITIVE.') 15 FORMAT('***** ERROR--THE SHAPE PARAMETER FOR THE PARETO ', 1'SECOND KIND RANDOM NUMBERS IS NON-POSITIVE.') 25 FORMAT('***** ERROR--THE LOCATION PARAMETER FOR THE PARETO ', 1'SECOND KIND RANDOM NUMBERS IS NON-POSITIVE.') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****') C C GENERATE N UNIFORM (0,1) RANDOM NUMBERS; C CALL UNIRAN(N,ISEED,X) C C GENERATE N PARETO SECOND KIND DISTRIBUTION RANDOM NUMBERS C USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD. C DO100I=1,N CALL PA2PPF(X(I),GAMMA,A,PPF) X(I)=PPF 100 CONTINUE C 9000 CONTINUE RETURN END SUBROUTINE PASSB(NAC,IDO,IP,L1,IDL1,CC,C1,C2,CH,CH2,WA) C***BEGIN PROLOGUE PASSB C***REFER TO CFFTB C***ROUTINES CALLED (NONE) C***END PROLOGUE PASSB DIMENSION CH(IDO,L1,IP) ,CC(IDO,IP,L1) , 1 C1(IDO,L1,IP) ,WA(*) ,C2(IDL1,IP), 2 CH2(IDL1,IP) C***FIRST EXECUTABLE STATEMENT PASSB IDOT = IDO/2 IPP2 = IP+2 IPPH = (IP+1)/2 IDP = IP*IDO C IF (IDO .LT. L1) GO TO 106 DO 103 J=2,IPPH JC = IPP2-J DO 102 K=1,L1 CDIR$ IVDEP DO 101 I=1,IDO CH(I,K,J) = CC(I,J,K)+CC(I,JC,K) CH(I,K,JC) = CC(I,J,K)-CC(I,JC,K) 101 CONTINUE 102 CONTINUE 103 CONTINUE DO 105 K=1,L1 CDIR$ IVDEP DO 104 I=1,IDO CH(I,K,1) = CC(I,1,K) 104 CONTINUE 105 CONTINUE GO TO 112 106 DO 109 J=2,IPPH JC = IPP2-J DO 108 I=1,IDO CDIR$ IVDEP DO 107 K=1,L1 CH(I,K,J) = CC(I,J,K)+CC(I,JC,K) CH(I,K,JC) = CC(I,J,K)-CC(I,JC,K) 107 CONTINUE 108 CONTINUE 109 CONTINUE DO 111 I=1,IDO CDIR$ IVDEP DO 110 K=1,L1 CH(I,K,1) = CC(I,1,K) 110 CONTINUE 111 CONTINUE 112 IDL = 2-IDO INC = 0 DO 116 L=2,IPPH LC = IPP2-L IDL = IDL+IDO CDIR$ IVDEP DO 113 IK=1,IDL1 C2(IK,L) = CH2(IK,1)+WA(IDL-1)*CH2(IK,2) C2(IK,LC) = WA(IDL)*CH2(IK,IP) 113 CONTINUE IDLJ = IDL INC = INC+IDO DO 115 J=3,IPPH JC = IPP2-J IDLJ = IDLJ+INC IF (IDLJ .GT. IDP) IDLJ = IDLJ-IDP WAR = WA(IDLJ-1) WAI = WA(IDLJ) CDIR$ IVDEP DO 114 IK=1,IDL1 C2(IK,L) = C2(IK,L)+WAR*CH2(IK,J) C2(IK,LC) = C2(IK,LC)+WAI*CH2(IK,JC) 114 CONTINUE 115 CONTINUE 116 CONTINUE DO 118 J=2,IPPH CDIR$ IVDEP DO 117 IK=1,IDL1 CH2(IK,1) = CH2(IK,1)+CH2(IK,J) 117 CONTINUE 118 CONTINUE DO 120 J=2,IPPH JC = IPP2-J CDIR$ IVDEP DO 119 IK=2,IDL1,2 CH2(IK-1,J) = C2(IK-1,J)-C2(IK,JC) CH2(IK-1,JC) = C2(IK-1,J)+C2(IK,JC) CH2(IK,J) = C2(IK,J)+C2(IK-1,JC) CH2(IK,JC) = C2(IK,J)-C2(IK-1,JC) 119 CONTINUE 120 CONTINUE NAC = 1 IF (IDO .EQ. 2) RETURN NAC = 0 DO 121 IK=1,IDL1 C2(IK,1) = CH2(IK,1) 121 CONTINUE DO 123 J=2,IP CDIR$ IVDEP DO 122 K=1,L1 C1(1,K,J) = CH(1,K,J) C1(2,K,J) = CH(2,K,J) 122 CONTINUE 123 CONTINUE IF (IDOT .GT. L1) GO TO 127 IDIJ = 0 DO 126 J=2,IP IDIJ = IDIJ+2 DO 125 I=4,IDO,2 IDIJ = IDIJ+2 CDIR$ IVDEP DO 124 K=1,L1 C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)-WA(IDIJ)*CH(I,K,J) C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)+WA(IDIJ)*CH(I-1,K,J) 124 CONTINUE 125 CONTINUE 126 CONTINUE RETURN 127 IDJ = 2-IDO DO 130 J=2,IP IDJ = IDJ+IDO DO 129 K=1,L1 IDIJ = IDJ CDIR$ IVDEP DO 128 I=4,IDO,2 IDIJ = IDIJ+2 C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)-WA(IDIJ)*CH(I,K,J) C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)+WA(IDIJ)*CH(I-1,K,J) 128 CONTINUE 129 CONTINUE 130 CONTINUE RETURN END SUBROUTINE PART1(NW, W, M, LSTFI, LER, N, LV, LLIM, LT, LP, * MAXMC, Q, QT) C PART OF ACM 591 FOR ANOVA C ****************************** PART1 ***************************** PAR 10 C PAR 20 C RESTRUCTURES THE DATA (CELL FREQUENCIES) WHEN APPROPRIATE; CHECKS PAR 30 C FOR BALANCE AND ALTERNATIVE NON-ITERATIVE COMPUTATIONS; TURNS IBST PAR 40 C ON WHEN THE EFFECTIVE X MATRIX IS SQUARE OR THE EFFECTIVE D MATRIX PAR 50 C IS A SCALAR MULTIPLE OF THE IDENTITY. COMPUTES RANK WITHOUT ITERA- PAR 60 C TION IF POSSIBLE OR ITERATIVELY OTHERWISE WHEN THE RANK (R) OPTION PAR 70 C IS SPECIFIED; TURNS SWITCH IRST ON IF THE MAXIMUM NUMBER OF ITERA- PAR 80 C TIONS IS EXCEEDED IN COMPUTING RANK. PAR 90 C PAR 100 C ****************************************************************** PAR 110 COMMON /C1/ YPY, SSRM, SSEM, IIN, IOUT, IROPT, IVOPT, IGOPT, * IPOPT, IOFLAG, IBST, IHST, IRST, ISST, IXST, ICD, NSUBS, LPOUT, * NO1, IDF, IDFM, IDFR COMMON /C2/ NCELLS, LOCD1, LOCD2, LOCV, LOCB, LOCA, IRANKM, * IRANKR, MAXIT DIMENSION W(NW), LSTFI(M), LER(M), LV(N), LLIM(N), LT(N), LP(10) DIMENSION Q(MAXMC,MAXMC), QT(MAXMC) DOUBLE PRECISION W, C, S, TRACE, TEMP, Q, QT, YPY, SSRM, SSEM C CHARACTER*4 IH, IM, ICD C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C DATA IH /1HH/, IM /1HM/ IHST = 0 IRST = 0 IBST = 0 IRANK = 0 IF (NSUBS.EQ.N) GO TO 100 C FORM RESTRUCTURED CELL FREQUENCY ARRAY (EFFECTIVE D MATRIX) DO 10 I=1,NCELLS ID1 = LOCD1 + I IA = LOCA + I W(IA) = W(ID1) 10 CONTINUE CALL DECOMP(1, LOCA, IOUT, NW, W, M, LSTFI, N, LT, LV, LLIM, LP) NS = LOCA NN = M - NO1 DO 20 I=1,NN NS = NS + LSTFI(I) 20 CONTINUE CNIST CALL LABEL(NO1, 0, LLIM, IOUT, N, LV, LP) CALL POOL(0, LOCD2, NS, NW, W, N, LLIM, LT, LP) C CHECK FOR A SQUARE EFFECTIVE X MATRIX 30 IF (IXST.EQ.1) GO TO 80 K = LOCD2 + 1 IFLAG = 0 DO 40 I=1,NCELLS ID2 = LOCD2 + I IF (W(ID2).EQ.0.0) GO TO 130 IF (W(ID2).NE.W(K)) IFLAG = 1 40 CONTINUE IF (IFLAG.EQ.1) GO TO 70 C THE EFFECTIVE D MATRIX IS A SCALAR TIMES THE IDENTITY IRANK = IDF 50 DO 60 I=1,NCELLS ID2 = LOCD2 + I W(ID2) = W(ID2)/FLOAT(LPOUT) 60 CONTINUE C = 1.0D0 IBST = 1 GO TO 120 C ALL ELEMENTS OF THE EFFECTIVE D MATRIX ARE NONZERO 70 IRANK = IDF GO TO 120 C THE EFFECTIVE X MATRIX IS SQUARE 80 DO 90 I=1,NCELLS ID2 = LOCD2 + I IF (W(ID2).NE.0.0) IRANK = IRANK + 1 90 CONTINUE IRANK = IRANK/LPOUT GO TO 50 100 DO 110 I=1,NCELLS ID1 = LOCD1 + I ID2 = LOCD2 + I W(ID2) = W(ID1) 110 CONTINUE GO TO 30 C RANK HAS BEEN DETERMINED (NONITERATIVELY OR ITERATIVELY) 120 IF (ICD.EQ.IH) IRANKR = IRANK IF (ICD.EQ.IM) IRANKM = IRANK GO TO 370 130 IF (ICD.EQ.IM) GO TO 140 IRANKR = 0 IF (IRANKM.NE.IDFM) GO TO 150 IRANKR = IDFR IRANK = IDFR GO TO 370 140 IRANKM = 0 150 IF (IROPT.EQ.0) GO TO 380 C ITERATIVELY COMPUTE RANK OF FULL OR REDUCED MODEL C = 1.0D0 RTOL = 0.1 NMC = 0 DO 160 I=1,NCELLS ID1 = LOCD1 + I ID2 = LOCD2 + I IF (W(ID1).EQ.0.0) NMC = NMC + 1 W(ID2) = W(I) 160 CONTINUE IF (NMC.GT.MAXMC) GO TO 310 C COMPUTE Q, POWERS OF Q, AND RELATED TRACES (FEW EMPTY CELLS) K = 1 IVEC = 0 DO 190 I=1,NCELLS ID1 = LOCD1 + I IF (W(ID1).NE.0.0) GO TO 190 DO 170 J=1,NCELLS IV = LOCV + J IB = LOCB + J W(IV) = 0 W(IB) = 0 W(J) = 0 IF (J.EQ.I) W(J) = 1.0D0 170 CONTINUE CALL STEP(3, C, S, NW, W, M, LSTFI, LER, N, LV, LLIM, LT, LP) LL = 1 DO 180 J=1,NCELLS ID1 = LOCD1 + J IV = LOCV + J IF (W(ID1).NE.0.0) GO TO 180 Q(K,LL) = W(IV) LL = LL + 1 180 CONTINUE K = K + 1 190 CONTINUE C POWER Q AND COMPUTE TR(I-Q**(2*K)) TEMP = IDF DO 200 I=1,NMC TEMP = TEMP - Q(I,I) 200 CONTINUE IT = 0 210 IF (IOFLAG.EQ.1) THEN WRITE (ICOUT,99999) IT, TEMP CALL DPWRST('XXX','BUG ') ENDIF 99999 FORMAT (10H ITERATION, I3, 8H, TRACE=, F16.9) DO 250 J=1,NMC DO 230 I=J,NMC QT(I) = 0 DO 220 K=1,NMC QT(I) = QT(I) + Q(K,J)*Q(K,I) 220 CONTINUE 230 CONTINUE DO 240 K=J,NMC Q(K,J) = QT(K) 240 CONTINUE 250 CONTINUE TRACE = IDF DO 270 I=1,NMC TRACE = TRACE - Q(I,I) DO 260 J=I,NMC Q(I,J) = Q(J,I) 260 CONTINUE 270 CONTINUE IT = IT + 1 TEMP = TRACE - TEMP C TRACE IS MONOTONICALLY INCREASING IF (TEMP.LE.RTOL) GO TO 280 IF (IT.GE.MAXIT) GO TO 360 TEMP = TRACE GO TO 210 280 DO 290 I=1,NCELLS ID2 = LOCD2 + I W(I) = W(ID2) 290 CONTINUE C ADD ONE (BASED ON MONOTONICITY) TO OBTAIN INTEGER RANK 300 IRANK = TRACE + 1.0D0 GO TO 120 C COMPUTE S FOR UNIT VECTORS (MANY EMPTY CELLS) 310 TRACE = 0 RTOL = RTOL/(FLOAT(NCELLS)-FLOAT(NMC)) DO 350 I=1,NCELLS ID1 = LOCD1 + I IF (W(ID1).EQ.0.0) GO TO 350 DO 320 J=1,NCELLS IV = LOCV + J IB = LOCB + J W(IV) = 0 W(IB) = 0 W(J) = 0 IF (J.EQ.I) W(J) = 1.0D0 320 CONTINUE IT = 0 TEMP = 0 330 CALL STEP(3, C, S, NW, W, M, LSTFI, LER, N, LV, LLIM, LT, LP) IT = IT + 1 TEMP = S - TEMP C THE VALUE OF S IS MONOTONICALLY INCREASING IF (TEMP.LE.RTOL) GO TO 340 IVEC = I IF (IT.GE.MAXIT) GO TO 360 TEMP = S GO TO 330 340 TRACE = TRACE + S IF (IOFLAG.EQ.1) THEN WRITE (ICOUT,99998) I, IT, TRACE CALL DPWRST('XXX','BUG ') ENDIF 99998 FORMAT (7H VECTOR, I4, 12H, ITERATIONS, I4, 8H, TRACE=, F16.9) 350 CONTINUE GO TO 280 360 CONTINUE WRITE (ICOUT,99997) MAXIT CALL DPWRST('XXX','BUG ') 99997 FORMAT (11H MAXIMUM OF, I4, 34H ITERATIONS EXCEEDED IN COMPUTING , * 4HRANK) WRITE (ICOUT,89997) TEMP, RTOL, IVEC CALL DPWRST('XXX','BUG ') 89997 FORMAT (7H DELTA=, F22.9, 10X, 8HEPSILON=, F22.9, 10X, 7HVECTOR=, * I10) IF (NMC.GT.MAXMC) TRACE = TRACE + S IRST = 1 GO TO 300 370 IF (IROPT.EQ.1) THEN WRITE (ICOUT,99996) ICD, IRANK CALL DPWRST('XXX','BUG ') ENDIF 99996 FORMAT (17H THE RANK OF THE , A1, 17H DESIGN MATRIX IS, I5) 380 RETURN END SUBROUTINE PART2(NW, W, M, LSTFI, LER, N, LE, LV, LLIM, LT, LP) C PART OF ACM 591 FOR ANOVA C ****************************** PART2 ***************************** PAR 10 C PAR 20 C COMPUTES SSE AND SSR FOR THE FULL MODEL (ICD = M); OUTPUTS ESTI- PAR 30 C MATES OF EXPECTED CELL MEANS (THE VECTOR V) WHEN THE V OPTION IS PAR 40 C SPECIFIED; COMPUTES A G-INVERSE SOLUTION TO THE NORMAL EQUATIONS PAR 50 C WHEN THE G OPTION IS SPECIFIED. COMPUTES SSR FOR THE REDUCED MOD- PAR 60 C EL (ICD = H) AND AN F STATISTIC; COMPUTES PROBABILITY VALUES WHEN PAR 70 C THE P OPTION IS SPECIFIED. ALL COMPUTATIONS ARE NON-ITERATIVE IF PAR 80 C SWITCH IBST IS ON (IBST = 1) PAR 90 C PAR 100 C (SEE MAIN PROGRAM COMMENTS FOR A DESCRIPTION OF ARGUMENTS) PAR 110 C PAR 120 C ****************************************************************** PAR 130 COMMON /C1/ YPY, SSRM, SSEM, IIN, IOUT, IROPT, IVOPT, IGOPT, * IPOPT, IOFLAG, IBST, IHST, IRST, ISST, IXST, ICD, NSUBS, LPOUT, * NO1, IDF, IDFM, IDFR COMMON /C2/ NCELLS, LOCD1, LOCD2, LOCV, LOCB, LOCA, IRANKM, * IRANKR, MAXIT COMMON /C3/ NOBS, MAXDI, MINDI, FLEVEL, NOSIGD DIMENSION W(NW), LSTFI(M), LER(M), LE(N), LV(N), LLIM(N), LT(N), * LP(10) DOUBLE PRECISION W, C, S, TEMP, YPY, SSRM, SSEM, DABS, F C CHARACTER*1 IBLANK, ISTAR, IM, IH, ISIG CHARACTER*4 ICD C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C DATA IBLANK /1H /, ISTAR /1H*/, IM /1HM/, IH /1HH/ C FTOL = .005 STOL = (.05*YPY)/(10.0**NOSIGD) C ZERO THE VECTORS B AND V TO INITIALIZE THE ITERATIVE ALGORITHM DO 10 I=1,NCELLS IB = LOCB + I IV = LOCV + I W(IB) = 0 W(IV) = 0 10 CONTINUE IT = 0 TEMP = 0 IF (IBST.EQ.1) GO TO 260 IF (ICD(1:1).EQ.IH) GO TO 170 C COMPUTE SSR FOR THE FULL MODEL USING OPTIMUM C FOR CONVERGENCE C = (FLOAT(MAXDI)+FLOAT(MINDI))/2.0 IF (MINDI.EQ.0) C = MAXDI 20 CALL STEP(1, C, S, NW, W, M, LSTFI, LER, N, LV, LLIM, LT, LP) IT = IT + 1 TEMP = S - TEMP IF (IOFLAG.EQ.1) THEN WRITE (ICOUT,99999) IT, ICD(1:1), S CALL DPWRST('XXX','BUG ') ENDIF 99999 FORMAT (10H ITERATION, I4, 5H, SSR, A1, 1H=, E16.8) IF (DABS(TEMP).LE.STOL) GO TO 30 IF (IT.GE.MAXIT) GO TO 160 TEMP = S GO TO 20 C APPLY THE E OPERATOR TO THE VECTOR B 30 DO 40 I=1,NCELLS IB = LOCB + I IA = LOCA + I W(IA) = W(IB) 40 CONTINUE CALL DECOMP(0, LOCA, IOUT, NW, W, M, LSTFI, N, LT, LV, LLIM, LP) C COMPUTE SSR AND SSE FOR THE FULL MODEL 50 SSRM = S SSEM = YPY - S WRITE (ICOUT,99998) IT, SSRM 99998 FORMAT (10H ITERATION, I4, 18H, SSR(FULL MODEL)=, E16.8, 1H,) CALL DPWRST('XXX','BUG ') WRITE (ICOUT,89998) SSEM 89998 FORMAT (14X,18H SSE(FULL MODEL)=, E16.8) CALL DPWRST('XXX','BUG ') IF (IVOPT.EQ.0) GO TO 70 WRITE (ICOUT,99997) 99997 FORMAT (' ESTIMATES OF EXPECTED CELL MEANS-') CALL DPWRST('XXX','BUG ') WRITE (ICOUT,89997) 89997 FORMAT (' CELL ESTIMATED MEAN') CALL DPWRST('XXX','BUG ') DO 60 I=1,NCELLS ID1 = LOCD1 + I IV = LOCV + I IF (W(ID1).EQ.0.0) THEN WRITE (ICOUT,99996) I, W(IV) CALL DPWRST('XXX','BUG ') ENDIF IF (W(ID1).GT.0.0) THEN WRITE (ICOUT,99995) I, W(IV) CALL DPWRST('XXX','BUG ') ENDIF 60 CONTINUE 99996 FORMAT (1H , I6, 1X, E16.8, 15H (MISSING CELL)) 99995 FORMAT (1H , I6, 1X, E16.8) 70 IF (IGOPT.EQ.0) GO TO 150 C COMPUTE THE G-INVERSE SOLUTION TO THE NORMAL EQUATIONS WRITE (ICOUT,99994) 99994 FORMAT (20H G-INVERSE SOLUTION-) CALL DPWRST('XXX','BUG ') C POOL ARRAYS OF "ESTIMATES" WITH EQUAL E/R LIST VALUES NP = LOCA DO 140 I=1,M NO = LER(I) IF (NO.LE.0) GO TO 130 NS = NP NOP = M - I + 1 CNIST CALL LABEL(NOP, 0, LLIM, IOUT, N, LV, LP) C POSITIVE VALUES IN LLIM WILL CORRESPOND TO SUBSCRIPTS IN PRIMARY DO 80 K=1,N IF (LP(K).EQ.0) LLIM(K) = -LLIM(K) 80 CONTINUE DO 100 J=I,M IF (J.EQ.I) GO TO 90 IF (LER(J).NE.NO) GO TO 90 LER(J) = -NO NOS = M - J + 1 C OBTAIN MAP COEFFICIENTS FOR SECONDARY ARRAY AND POOL INTO PRIMARY CNIST CALL LABEL(NOS, 0, LLIM, IOUT, N, LV, LP) CALL POOL(1, NP, NS, NW, W, N, LLIM, LT, LP) 90 NS = NS + LSTFI(J) 100 CONTINUE DO 110 K=1,N LLIM(K) = IABS(LLIM(K)) 110 CONTINUE C LABEL AND OUTPUT "ESTIMATES" FOR MODEL TERM CNIST CALL LABEL(NO, IBLANK, LE, IOUT, N, LV, LP) MST = LSTFI(I) DO 120 K=1,MST IA = NP + K WRITE (ICOUT,99995) K, W(IA) CALL DPWRST('XXX','BUG ') 120 CONTINUE 130 NP = NP + LSTFI(I) 140 CONTINUE 150 RETURN 160 CONTINUE WRITE (ICOUT,99993) MAXIT, ICD(1:1) 99993 FORMAT (11H MAXIMUM OF, I4, 34H ITERATIONS EXCEEDED IN COMPUTING , * 3HSSR, A1) CALL DPWRST('XXX','BUG ') WRITE (ICOUT,89993) TEMP, STOL 89993 FORMAT (7H DELTA=, E16.8, 10X, 8HEPSILON=, E16.8) CALL DPWRST('XXX','BUG ') GO TO 30 C SELECT C FOR MONOTONICITY OF SSR AND F 170 C = MAXDI C COMPUTE DEGREES OF FREEDOM TO USE FOR F STATISTIC 180 IF (IRANKM.EQ.0) GO TO 190 IF (IRANKR.EQ.0) GO TO 190 IDFD = NOBS - IRANKM IDFN = IRANKM - IRANKR WRITE (ICOUT,99992) IDFN, IDFD 99992 FORMAT (33H FROM RANK COMPUTATIONS- DF(NUM)=, I4, 10H, DF(DEN)=, * I5) CALL DPWRST('XXX','BUG ') GO TO 200 190 IDFD = NOBS - IDFM IDFN = IDFM - IDFR WRITE (ICOUT,99991) IDFN, IDFD 99991 FORMAT (50H ASSUMES FULL RANK AND EQUAL LEVELS WITH- DF(NUM)=, * I4, 10H, DF(DEN)=, I5) CALL DPWRST('XXX','BUG ') 200 IF (IDFD*IDFN.LE.0) GO TO 150 IF (IBST.EQ.1) GO TO 220 C COMPUTE MONOTONICALLY DECREASING APPROXIMATION TO F 210 CALL STEP(1, C, S, NW, W, M, LSTFI, LER, N, LV, LLIM, LT, LP) IT = IT + 1 220 F = ((SSRM-S)/FLOAT(IDFN))/(SSEM/FLOAT(IDFD)) IF (IOFLAG.EQ.1) THEN WRITE (ICOUT,99999) IT, ICD(1:1), S CALL DPWRST('XXX','BUG ') ENDIF C APPROXIMATION TO F PROBABILITY (SMILLIE AND ANSTEY) U1 = 2.0/(9.0*FLOAT(IDFN)) U2 = 2.0/(9.0*FLOAT(IDFD)) F1 = F**(1.0/3.0) U3 = ((1.0-U2)*F1-1.0+U1)/SQRT(2.0*(U2*F1*F1+U1)) U = ABS(U3) PROB = 0.5/(1.0+(((.078108*U+.000972)*U+.230389)*U+.278393)*U)**4 IF (U3.LT.0.0) PROB = 1.0 - PROB IF (IBST.EQ.1) GO TO 250 IF (IPOPT.EQ.1) GO TO 230 IF (PROB.GE.FLEVEL) GO TO 250 230 TEMP = TEMP - F IF (DABS(TEMP).LE.FTOL) GO TO 250 IF (IT.GE.MAXIT) GO TO 240 TEMP = F GO TO 210 240 CONTINUE WRITE (ICOUT,99993) MAXIT, ICD(1:1) CALL DPWRST('XXX','BUG ') WRITE (ICOUT,89993) TEMP, FTOL CALL DPWRST('XXX','BUG ') 250 ISIG = ISTAR IF (PROB.GE.FLEVEL) ISIG = IBLANK WRITE (IOUT,99990) IT, F, ISIG, PROB, FLEVEL 99990 FORMAT (10H ITERATION, I4, 4H, F=, F12.3, A1, 15H, PROB(F) .GT. , * F6.4, 16H VS. F LEVEL OF , F6.4) CALL DPWRST('XXX','BUG ') WRITE (IOUT,89990) S 89990 FORMAT (20H SSR(REDUCED MODEL)=, E16.8) CALL DPWRST('XXX','BUG ') GO TO 150 C BALANCED CASE; ONE ITERATION 260 CALL STEP(2, C, S, NW, W, M, LSTFI, LER, N, LV, LLIM, LT, LP) IT = IT + 1 IF (ICD(1:1).EQ.IM) GO TO 50 GO TO 180 END SUBROUTINE PASSB2(IDO,L1,CC,CH,WA1) C***BEGIN PROLOGUE PASSB2 C***REFER TO CFFTB C***ROUTINES CALLED (NONE) C***END PROLOGUE PASSB2 DIMENSION CC(IDO,2,L1) ,CH(IDO,L1,2) , 1 WA1(*) C***FIRST EXECUTABLE STATEMENT PASSB2 IF (IDO .GT. 2) GO TO 102 DO 101 K=1,L1 CH(1,K,1) = CC(1,1,K)+CC(1,2,K) CH(1,K,2) = CC(1,1,K)-CC(1,2,K) CH(2,K,1) = CC(2,1,K)+CC(2,2,K) CH(2,K,2) = CC(2,1,K)-CC(2,2,K) 101 CONTINUE RETURN 102 IF(IDO/2.LT.L1) GO TO 105 DO 104 K=1,L1 CDIR$ IVDEP DO 103 I=2,IDO,2 CH(I-1,K,1) = CC(I-1,1,K)+CC(I-1,2,K) TR2 = CC(I-1,1,K)-CC(I-1,2,K) CH(I,K,1) = CC(I,1,K)+CC(I,2,K) TI2 = CC(I,1,K)-CC(I,2,K) CH(I,K,2) = WA1(I-1)*TI2+WA1(I)*TR2 CH(I-1,K,2) = WA1(I-1)*TR2-WA1(I)*TI2 103 CONTINUE 104 CONTINUE RETURN 105 DO 107 I=2,IDO,2 CDIR$ IVDEP DO 106 K=1,L1 CH(I-1,K,1) = CC(I-1,1,K)+CC(I-1,2,K) TR2 = CC(I-1,1,K)-CC(I-1,2,K) CH(I,K,1) = CC(I,1,K)+CC(I,2,K) TI2 = CC(I,1,K)-CC(I,2,K) CH(I,K,2) = WA1(I-1)*TI2+WA1(I)*TR2 CH(I-1,K,2) = WA1(I-1)*TR2-WA1(I)*TI2 106 CONTINUE 107 CONTINUE RETURN END SUBROUTINE PASSB3(IDO,L1,CC,CH,WA1,WA2) C***BEGIN PROLOGUE PASSB3 C***REFER TO CFFTB C***ROUTINES CALLED (NONE) C***END PROLOGUE PASSB3 DIMENSION CC(IDO,3,L1) ,CH(IDO,L1,3) , 1 WA1(*) ,WA2(*) C***FIRST EXECUTABLE STATEMENT PASSB3 TAUR = -.5 TAUI = .5*SQRT(3.) IF (IDO .NE. 2) GO TO 102 DO 101 K=1,L1 TR2 = CC(1,2,K)+CC(1,3,K) CR2 = CC(1,1,K)+TAUR*TR2 CH(1,K,1) = CC(1,1,K)+TR2 TI2 = CC(2,2,K)+CC(2,3,K) CI2 = CC(2,1,K)+TAUR*TI2 CH(2,K,1) = CC(2,1,K)+TI2 CR3 = TAUI*(CC(1,2,K)-CC(1,3,K)) CI3 = TAUI*(CC(2,2,K)-CC(2,3,K)) CH(1,K,2) = CR2-CI3 CH(1,K,3) = CR2+CI3 CH(2,K,2) = CI2+CR3 CH(2,K,3) = CI2-CR3 101 CONTINUE RETURN 102 IF(IDO/2.LT.L1) GO TO 105 DO 104 K=1,L1 CDIR$ IVDEP DO 103 I=2,IDO,2 TR2 = CC(I-1,2,K)+CC(I-1,3,K) CR2 = CC(I-1,1,K)+TAUR*TR2 CH(I-1,K,1) = CC(I-1,1,K)+TR2 TI2 = CC(I,2,K)+CC(I,3,K) CI2 = CC(I,1,K)+TAUR*TI2 CH(I,K,1) = CC(I,1,K)+TI2 CR3 = TAUI*(CC(I-1,2,K)-CC(I-1,3,K)) CI3 = TAUI*(CC(I,2,K)-CC(I,3,K)) DR2 = CR2-CI3 DR3 = CR2+CI3 DI2 = CI2+CR3 DI3 = CI2-CR3 CH(I,K,2) = WA1(I-1)*DI2+WA1(I)*DR2 CH(I-1,K,2) = WA1(I-1)*DR2-WA1(I)*DI2 CH(I,K,3) = WA2(I-1)*DI3+WA2(I)*DR3 CH(I-1,K,3) = WA2(I-1)*DR3-WA2(I)*DI3 103 CONTINUE 104 CONTINUE RETURN 105 DO 107 I=2,IDO,2 CDIR$ IVDEP DO 106 K=1,L1 TR2 = CC(I-1,2,K)+CC(I-1,3,K) CR2 = CC(I-1,1,K)+TAUR*TR2 CH(I-1,K,1) = CC(I-1,1,K)+TR2 TI2 = CC(I,2,K)+CC(I,3,K) CI2 = CC(I,1,K)+TAUR*TI2 CH(I,K,1) = CC(I,1,K)+TI2 CR3 = TAUI*(CC(I-1,2,K)-CC(I-1,3,K)) CI3 = TAUI*(CC(I,2,K)-CC(I,3,K)) DR2 = CR2-CI3 DR3 = CR2+CI3 DI2 = CI2+CR3 DI3 = CI2-CR3 CH(I,K,2) = WA1(I-1)*DI2+WA1(I)*DR2 CH(I-1,K,2) = WA1(I-1)*DR2-WA1(I)*DI2 CH(I,K,3) = WA2(I-1)*DI3+WA2(I)*DR3 CH(I-1,K,3) = WA2(I-1)*DR3-WA2(I)*DI3 106 CONTINUE 107 CONTINUE RETURN END SUBROUTINE PASSB4(IDO,L1,CC,CH,WA1,WA2,WA3) C***BEGIN PROLOGUE PASSB4 C***REFER TO CFFTB C***ROUTINES CALLED (NONE) C***END PROLOGUE PASSB4 DIMENSION CC(IDO,4,L1) ,CH(IDO,L1,4) , 1 WA1(*) ,WA2(*) ,WA3(*) C***FIRST EXECUTABLE STATEMENT PASSB4 IF (IDO .NE. 2) GO TO 102 DO 101 K=1,L1 TI1 = CC(2,1,K)-CC(2,3,K) TI2 = CC(2,1,K)+CC(2,3,K) TR4 = CC(2,4,K)-CC(2,2,K) TI3 = CC(2,2,K)+CC(2,4,K) TR1 = CC(1,1,K)-CC(1,3,K) TR2 = CC(1,1,K)+CC(1,3,K) TI4 = CC(1,2,K)-CC(1,4,K) TR3 = CC(1,2,K)+CC(1,4,K) CH(1,K,1) = TR2+TR3 CH(1,K,3) = TR2-TR3 CH(2,K,1) = TI2+TI3 CH(2,K,3) = TI2-TI3 CH(1,K,2) = TR1+TR4 CH(1,K,4) = TR1-TR4 CH(2,K,2) = TI1+TI4 CH(2,K,4) = TI1-TI4 101 CONTINUE RETURN 102 IF(IDO/2.LT.L1) GO TO 105 DO 104 K=1,L1 CDIR$ IVDEP DO 103 I=2,IDO,2 TI1 = CC(I,1,K)-CC(I,3,K) TI2 = CC(I,1,K)+CC(I,3,K) TI3 = CC(I,2,K)+CC(I,4,K) TR4 = CC(I,4,K)-CC(I,2,K) TR1 = CC(I-1,1,K)-CC(I-1,3,K) TR2 = CC(I-1,1,K)+CC(I-1,3,K) TI4 = CC(I-1,2,K)-CC(I-1,4,K) TR3 = CC(I-1,2,K)+CC(I-1,4,K) CH(I-1,K,1) = TR2+TR3 CR3 = TR2-TR3 CH(I,K,1) = TI2+TI3 CI3 = TI2-TI3 CR2 = TR1+TR4 CR4 = TR1-TR4 CI2 = TI1+TI4 CI4 = TI1-TI4 CH(I-1,K,2) = WA1(I-1)*CR2-WA1(I)*CI2 CH(I,K,2) = WA1(I-1)*CI2+WA1(I)*CR2 CH(I-1,K,3) = WA2(I-1)*CR3-WA2(I)*CI3 CH(I,K,3) = WA2(I-1)*CI3+WA2(I)*CR3 CH(I-1,K,4) = WA3(I-1)*CR4-WA3(I)*CI4 CH(I,K,4) = WA3(I-1)*CI4+WA3(I)*CR4 103 CONTINUE 104 CONTINUE RETURN 105 DO 107 I=2,IDO,2 CDIR$ IVDEP DO 106 K=1,L1 TI1 = CC(I,1,K)-CC(I,3,K) TI2 = CC(I,1,K)+CC(I,3,K) TI3 = CC(I,2,K)+CC(I,4,K) TR4 = CC(I,4,K)-CC(I,2,K) TR1 = CC(I-1,1,K)-CC(I-1,3,K) TR2 = CC(I-1,1,K)+CC(I-1,3,K) TI4 = CC(I-1,2,K)-CC(I-1,4,K) TR3 = CC(I-1,2,K)+CC(I-1,4,K) CH(I-1,K,1) = TR2+TR3 CR3 = TR2-TR3 CH(I,K,1) = TI2+TI3 CI3 = TI2-TI3 CR2 = TR1+TR4 CR4 = TR1-TR4 CI2 = TI1+TI4 CI4 = TI1-TI4 CH(I-1,K,2) = WA1(I-1)*CR2-WA1(I)*CI2 CH(I,K,2) = WA1(I-1)*CI2+WA1(I)*CR2 CH(I-1,K,3) = WA2(I-1)*CR3-WA2(I)*CI3 CH(I,K,3) = WA2(I-1)*CI3+WA2(I)*CR3 CH(I-1,K,4) = WA3(I-1)*CR4-WA3(I)*CI4 CH(I,K,4) = WA3(I-1)*CI4+WA3(I)*CR4 106 CONTINUE 107 CONTINUE RETURN END SUBROUTINE PASSB5(IDO,L1,CC,CH,WA1,WA2,WA3,WA4) C***BEGIN PROLOGUE PASSB5 C***REFER TO CFFTB C***ROUTINES CALLED (NONE) C***END PROLOGUE PASSB5 DIMENSION CC(IDO,5,L1) ,CH(IDO,L1,5) , 1 WA1(*) ,WA2(*) ,WA3(*) ,WA4(*) C***FIRST EXECUTABLE STATEMENT PASSB5 PI = 4.*ATAN(1.) TR11 = SIN(.1*PI) TI11 = SIN(.4*PI) TR12 = -SIN(.3*PI) TI12 = SIN(.2*PI) IF (IDO .NE. 2) GO TO 102 DO 101 K=1,L1 TI5 = CC(2,2,K)-CC(2,5,K) TI2 = CC(2,2,K)+CC(2,5,K) TI4 = CC(2,3,K)-CC(2,4,K) TI3 = CC(2,3,K)+CC(2,4,K) TR5 = CC(1,2,K)-CC(1,5,K) TR2 = CC(1,2,K)+CC(1,5,K) TR4 = CC(1,3,K)-CC(1,4,K) TR3 = CC(1,3,K)+CC(1,4,K) CH(1,K,1) = CC(1,1,K)+TR2+TR3 CH(2,K,1) = CC(2,1,K)+TI2+TI3 CR2 = CC(1,1,K)+TR11*TR2+TR12*TR3 CI2 = CC(2,1,K)+TR11*TI2+TR12*TI3 CR3 = CC(1,1,K)+TR12*TR2+TR11*TR3 CI3 = CC(2,1,K)+TR12*TI2+TR11*TI3 CR5 = TI11*TR5+TI12*TR4 CI5 = TI11*TI5+TI12*TI4 CR4 = TI12*TR5-TI11*TR4 CI4 = TI12*TI5-TI11*TI4 CH(1,K,2) = CR2-CI5 CH(1,K,5) = CR2+CI5 CH(2,K,2) = CI2+CR5 CH(2,K,3) = CI3+CR4 CH(1,K,3) = CR3-CI4 CH(1,K,4) = CR3+CI4 CH(2,K,4) = CI3-CR4 CH(2,K,5) = CI2-CR5 101 CONTINUE RETURN 102 IF(IDO/2.LT.L1) GO TO 105 DO 104 K=1,L1 CDIR$ IVDEP DO 103 I=2,IDO,2 TI5 = CC(I,2,K)-CC(I,5,K) TI2 = CC(I,2,K)+CC(I,5,K) TI4 = CC(I,3,K)-CC(I,4,K) TI3 = CC(I,3,K)+CC(I,4,K) TR5 = CC(I-1,2,K)-CC(I-1,5,K) TR2 = CC(I-1,2,K)+CC(I-1,5,K) TR4 = CC(I-1,3,K)-CC(I-1,4,K) TR3 = CC(I-1,3,K)+CC(I-1,4,K) CH(I-1,K,1) = CC(I-1,1,K)+TR2+TR3 CH(I,K,1) = CC(I,1,K)+TI2+TI3 CR2 = CC(I-1,1,K)+TR11*TR2+TR12*TR3 CI2 = CC(I,1,K)+TR11*TI2+TR12*TI3 CR3 = CC(I-1,1,K)+TR12*TR2+TR11*TR3 CI3 = CC(I,1,K)+TR12*TI2+TR11*TI3 CR5 = TI11*TR5+TI12*TR4 CI5 = TI11*TI5+TI12*TI4 CR4 = TI12*TR5-TI11*TR4 CI4 = TI12*TI5-TI11*TI4 DR3 = CR3-CI4 DR4 = CR3+CI4 DI3 = CI3+CR4 DI4 = CI3-CR4 DR5 = CR2+CI5 DR2 = CR2-CI5 DI5 = CI2-CR5 DI2 = CI2+CR5 CH(I-1,K,2) = WA1(I-1)*DR2-WA1(I)*DI2 CH(I,K,2) = WA1(I-1)*DI2+WA1(I)*DR2 CH(I-1,K,3) = WA2(I-1)*DR3-WA2(I)*DI3 CH(I,K,3) = WA2(I-1)*DI3+WA2(I)*DR3 CH(I-1,K,4) = WA3(I-1)*DR4-WA3(I)*DI4 CH(I,K,4) = WA3(I-1)*DI4+WA3(I)*DR4 CH(I-1,K,5) = WA4(I-1)*DR5-WA4(I)*DI5 CH(I,K,5) = WA4(I-1)*DI5+WA4(I)*DR5 103 CONTINUE 104 CONTINUE RETURN 105 DO 107 I=2,IDO,2 CDIR$ IVDEP DO 106 K=1,L1 TI5 = CC(I,2,K)-CC(I,5,K) TI2 = CC(I,2,K)+CC(I,5,K) TI4 = CC(I,3,K)-CC(I,4,K) TI3 = CC(I,3,K)+CC(I,4,K) TR5 = CC(I-1,2,K)-CC(I-1,5,K) TR2 = CC(I-1,2,K)+CC(I-1,5,K) TR4 = CC(I-1,3,K)-CC(I-1,4,K) TR3 = CC(I-1,3,K)+CC(I-1,4,K) CH(I-1,K,1) = CC(I-1,1,K)+TR2+TR3 CH(I,K,1) = CC(I,1,K)+TI2+TI3 CR2 = CC(I-1,1,K)+TR11*TR2+TR12*TR3 CI2 = CC(I,1,K)+TR11*TI2+TR12*TI3 CR3 = CC(I-1,1,K)+TR12*TR2+TR11*TR3 CI3 = CC(I,1,K)+TR12*TI2+TR11*TI3 CR5 = TI11*TR5+TI12*TR4 CI5 = TI11*TI5+TI12*TI4 CR4 = TI12*TR5-TI11*TR4 CI4 = TI12*TI5-TI11*TI4 DR3 = CR3-CI4 DR4 = CR3+CI4 DI3 = CI3+CR4 DI4 = CI3-CR4 DR5 = CR2+CI5 DR2 = CR2-CI5 DI5 = CI2-CR5 DI2 = CI2+CR5 CH(I-1,K,2) = WA1(I-1)*DR2-WA1(I)*DI2 CH(I,K,2) = WA1(I-1)*DI2+WA1(I)*DR2 CH(I-1,K,3) = WA2(I-1)*DR3-WA2(I)*DI3 CH(I,K,3) = WA2(I-1)*DI3+WA2(I)*DR3 CH(I-1,K,4) = WA3(I-1)*DR4-WA3(I)*DI4 CH(I,K,4) = WA3(I-1)*DI4+WA3(I)*DR4 CH(I-1,K,5) = WA4(I-1)*DR5-WA4(I)*DI5 CH(I,K,5) = WA4(I-1)*DI5+WA4(I)*DR5 106 CONTINUE 107 CONTINUE RETURN END SUBROUTINE PASSF(NAC,IDO,IP,L1,IDL1,CC,C1,C2,CH,CH2,WA) C***BEGIN PROLOGUE PASSF C***REFER TO CFFTF C***ROUTINES CALLED (NONE) C***END PROLOGUE PASSF DIMENSION CH(IDO,L1,IP) ,CC(IDO,IP,L1) , 1 C1(IDO,L1,IP) ,WA(*) ,C2(IDL1,IP), 2 CH2(IDL1,IP) C***FIRST EXECUTABLE STATEMENT PASSF IDOT = IDO/2 IPP2 = IP+2 IPPH = (IP+1)/2 IDP = IP*IDO C IF (IDO .LT. L1) GO TO 106 DO 103 J=2,IPPH JC = IPP2-J DO 102 K=1,L1 CDIR$ IVDEP DO 101 I=1,IDO CH(I,K,J) = CC(I,J,K)+CC(I,JC,K) CH(I,K,JC) = CC(I,J,K)-CC(I,JC,K) 101 CONTINUE 102 CONTINUE 103 CONTINUE DO 105 K=1,L1 CDIR$ IVDEP DO 104 I=1,IDO CH(I,K,1) = CC(I,1,K) 104 CONTINUE 105 CONTINUE GO TO 112 106 DO 109 J=2,IPPH JC = IPP2-J DO 108 I=1,IDO CDIR$ IVDEP DO 107 K=1,L1 CH(I,K,J) = CC(I,J,K)+CC(I,JC,K) CH(I,K,JC) = CC(I,J,K)-CC(I,JC,K) 107 CONTINUE 108 CONTINUE 109 CONTINUE DO 111 I=1,IDO CDIR$ IVDEP DO 110 K=1,L1 CH(I,K,1) = CC(I,1,K) 110 CONTINUE 111 CONTINUE 112 IDL = 2-IDO INC = 0 DO 116 L=2,IPPH LC = IPP2-L IDL = IDL+IDO CDIR$ IVDEP DO 113 IK=1,IDL1 C2(IK,L) = CH2(IK,1)+WA(IDL-1)*CH2(IK,2) C2(IK,LC) = -WA(IDL)*CH2(IK,IP) 113 CONTINUE IDLJ = IDL INC = INC+IDO DO 115 J=3,IPPH JC = IPP2-J IDLJ = IDLJ+INC IF (IDLJ .GT. IDP) IDLJ = IDLJ-IDP WAR = WA(IDLJ-1) WAI = WA(IDLJ) CDIR$ IVDEP DO 114 IK=1,IDL1 C2(IK,L) = C2(IK,L)+WAR*CH2(IK,J) C2(IK,LC) = C2(IK,LC)-WAI*CH2(IK,JC) 114 CONTINUE 115 CONTINUE 116 CONTINUE DO 118 J=2,IPPH CDIR$ IVDEP DO 117 IK=1,IDL1 CH2(IK,1) = CH2(IK,1)+CH2(IK,J) 117 CONTINUE 118 CONTINUE DO 120 J=2,IPPH JC = IPP2-J CDIR$ IVDEP DO 119 IK=2,IDL1,2 CH2(IK-1,J) = C2(IK-1,J)-C2(IK,JC) CH2(IK-1,JC) = C2(IK-1,J)+C2(IK,JC) CH2(IK,J) = C2(IK,J)+C2(IK-1,JC) CH2(IK,JC) = C2(IK,J)-C2(IK-1,JC) 119 CONTINUE 120 CONTINUE NAC = 1 IF (IDO .EQ. 2) RETURN NAC = 0 CDIR$ IVDEP DO 121 IK=1,IDL1 C2(IK,1) = CH2(IK,1) 121 CONTINUE DO 123 J=2,IP CDIR$ IVDEP DO 122 K=1,L1 C1(1,K,J) = CH(1,K,J) C1(2,K,J) = CH(2,K,J) 122 CONTINUE 123 CONTINUE IF (IDOT .GT. L1) GO TO 127 IDIJ = 0 DO 126 J=2,IP IDIJ = IDIJ+2 DO 125 I=4,IDO,2 IDIJ = IDIJ+2 CDIR$ IVDEP DO 124 K=1,L1 C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)+WA(IDIJ)*CH(I,K,J) C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)-WA(IDIJ)*CH(I-1,K,J) 124 CONTINUE 125 CONTINUE 126 CONTINUE RETURN 127 IDJ = 2-IDO DO 130 J=2,IP IDJ = IDJ+IDO DO 129 K=1,L1 IDIJ = IDJ CDIR$ IVDEP DO 128 I=4,IDO,2 IDIJ = IDIJ+2 C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)+WA(IDIJ)*CH(I,K,J) C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)-WA(IDIJ)*CH(I-1,K,J) 128 CONTINUE 129 CONTINUE 130 CONTINUE RETURN END SUBROUTINE PASSF2(IDO,L1,CC,CH,WA1) C***BEGIN PROLOGUE PASSF2 C***REFER TO CFFTF C***ROUTINES CALLED (NONE) C***END PROLOGUE PASSF2 DIMENSION CC(IDO,2,L1) ,CH(IDO,L1,2) , 1 WA1(*) C***FIRST EXECUTABLE STATEMENT PASSF2 IF (IDO .GT. 2) GO TO 102 DO 101 K=1,L1 CH(1,K,1) = CC(1,1,K)+CC(1,2,K) CH(1,K,2) = CC(1,1,K)-CC(1,2,K) CH(2,K,1) = CC(2,1,K)+CC(2,2,K) CH(2,K,2) = CC(2,1,K)-CC(2,2,K) 101 CONTINUE RETURN 102 IF(IDO/2.LT.L1) GO TO 105 DO 104 K=1,L1 CDIR$ IVDEP DO 103 I=2,IDO,2 CH(I-1,K,1) = CC(I-1,1,K)+CC(I-1,2,K) TR2 = CC(I-1,1,K)-CC(I-1,2,K) CH(I,K,1) = CC(I,1,K)+CC(I,2,K) TI2 = CC(I,1,K)-CC(I,2,K) CH(I,K,2) = WA1(I-1)*TI2-WA1(I)*TR2 CH(I-1,K,2) = WA1(I-1)*TR2+WA1(I)*TI2 103 CONTINUE 104 CONTINUE RETURN 105 DO 107 I=2,IDO,2 CDIR$ IVDEP DO 106 K=1,L1 CH(I-1,K,1) = CC(I-1,1,K)+CC(I-1,2,K) TR2 = CC(I-1,1,K)-CC(I-1,2,K) CH(I,K,1) = CC(I,1,K)+CC(I,2,K) TI2 = CC(I,1,K)-CC(I,2,K) CH(I,K,2) = WA1(I-1)*TI2-WA1(I)*TR2 CH(I-1,K,2) = WA1(I-1)*TR2+WA1(I)*TI2 106 CONTINUE 107 CONTINUE RETURN END SUBROUTINE PASSF3(IDO,L1,CC,CH,WA1,WA2) C***BEGIN PROLOGUE PASSF3 C***REFER TO CFFTF C***ROUTINES CALLED (NONE) C***END PROLOGUE PASSF3 DIMENSION CC(IDO,3,L1) ,CH(IDO,L1,3) , 1 WA1(*) ,WA2(*) C***FIRST EXECUTABLE STATEMENT PASSF3 TAUR = -.5 TAUI = -.5*SQRT(3.) IF (IDO .NE. 2) GO TO 102 DO 101 K=1,L1 TR2 = CC(1,2,K)+CC(1,3,K) CR2 = CC(1,1,K)+TAUR*TR2 CH(1,K,1) = CC(1,1,K)+TR2 TI2 = CC(2,2,K)+CC(2,3,K) CI2 = CC(2,1,K)+TAUR*TI2 CH(2,K,1) = CC(2,1,K)+TI2 CR3 = TAUI*(CC(1,2,K)-CC(1,3,K)) CI3 = TAUI*(CC(2,2,K)-CC(2,3,K)) CH(1,K,2) = CR2-CI3 CH(1,K,3) = CR2+CI3 CH(2,K,2) = CI2+CR3 CH(2,K,3) = CI2-CR3 101 CONTINUE RETURN 102 IF(IDO/2.LT.L1) GO TO 105 DO 104 K=1,L1 CDIR$ IVDEP DO 103 I=2,IDO,2 TR2 = CC(I-1,2,K)+CC(I-1,3,K) CR2 = CC(I-1,1,K)+TAUR*TR2 CH(I-1,K,1) = CC(I-1,1,K)+TR2 TI2 = CC(I,2,K)+CC(I,3,K) CI2 = CC(I,1,K)+TAUR*TI2 CH(I,K,1) = CC(I,1,K)+TI2 CR3 = TAUI*(CC(I-1,2,K)-CC(I-1,3,K)) CI3 = TAUI*(CC(I,2,K)-CC(I,3,K)) DR2 = CR2-CI3 DR3 = CR2+CI3 DI2 = CI2+CR3 DI3 = CI2-CR3 CH(I,K,2) = WA1(I-1)*DI2-WA1(I)*DR2 CH(I-1,K,2) = WA1(I-1)*DR2+WA1(I)*DI2 CH(I,K,3) = WA2(I-1)*DI3-WA2(I)*DR3 CH(I-1,K,3) = WA2(I-1)*DR3+WA2(I)*DI3 103 CONTINUE 104 CONTINUE RETURN 105 DO 107 I=2,IDO,2 CDIR$ IVDEP DO 106 K=1,L1 TR2 = CC(I-1,2,K)+CC(I-1,3,K) CR2 = CC(I-1,1,K)+TAUR*TR2 CH(I-1,K,1) = CC(I-1,1,K)+TR2 TI2 = CC(I,2,K)+CC(I,3,K) CI2 = CC(I,1,K)+TAUR*TI2 CH(I,K,1) = CC(I,1,K)+TI2 CR3 = TAUI*(CC(I-1,2,K)-CC(I-1,3,K)) CI3 = TAUI*(CC(I,2,K)-CC(I,3,K)) DR2 = CR2-CI3 DR3 = CR2+CI3 DI2 = CI2+CR3 DI3 = CI2-CR3 CH(I,K,2) = WA1(I-1)*DI2-WA1(I)*DR2 CH(I-1,K,2) = WA1(I-1)*DR2+WA1(I)*DI2 CH(I,K,3) = WA2(I-1)*DI3-WA2(I)*DR3 CH(I-1,K,3) = WA2(I-1)*DR3+WA2(I)*DI3 106 CONTINUE 107 CONTINUE RETURN END SUBROUTINE PASSF4(IDO,L1,CC,CH,WA1,WA2,WA3) C***BEGIN PROLOGUE PASSF4 C***REFER TO CFFTF C***ROUTINES CALLED (NONE) C***END PROLOGUE PASSF4 DIMENSION CC(IDO,4,L1) ,CH(IDO,L1,4) , 1 WA1(*) ,WA2(*) ,WA3(*) C***FIRST EXECUTABLE STATEMENT PASSF4 IF (IDO .NE. 2) GO TO 102 DO 101 K=1,L1 TI1 = CC(2,1,K)-CC(2,3,K) TI2 = CC(2,1,K)+CC(2,3,K) TR4 = CC(2,2,K)-CC(2,4,K) TI3 = CC(2,2,K)+CC(2,4,K) TR1 = CC(1,1,K)-CC(1,3,K) TR2 = CC(1,1,K)+CC(1,3,K) TI4 = CC(1,4,K)-CC(1,2,K) TR3 = CC(1,2,K)+CC(1,4,K) CH(1,K,1) = TR2+TR3 CH(1,K,3) = TR2-TR3 CH(2,K,1) = TI2+TI3 CH(2,K,3) = TI2-TI3 CH(1,K,2) = TR1+TR4 CH(1,K,4) = TR1-TR4 CH(2,K,2) = TI1+TI4 CH(2,K,4) = TI1-TI4 101 CONTINUE RETURN 102 IF(IDO/2.LT.L1) GO TO 105 DO 104 K=1,L1 CDIR$ IVDEP DO 103 I=2,IDO,2 TI1 = CC(I,1,K)-CC(I,3,K) TI2 = CC(I,1,K)+CC(I,3,K) TI3 = CC(I,2,K)+CC(I,4,K) TR4 = CC(I,2,K)-CC(I,4,K) TR1 = CC(I-1,1,K)-CC(I-1,3,K) TR2 = CC(I-1,1,K)+CC(I-1,3,K) TI4 = CC(I-1,4,K)-CC(I-1,2,K) TR3 = CC(I-1,2,K)+CC(I-1,4,K) CH(I-1,K,1) = TR2+TR3 CR3 = TR2-TR3 CH(I,K,1) = TI2+TI3 CI3 = TI2-TI3 CR2 = TR1+TR4 CR4 = TR1-TR4 CI2 = TI1+TI4 CI4 = TI1-TI4 CH(I-1,K,2) = WA1(I-1)*CR2+WA1(I)*CI2 CH(I,K,2) = WA1(I-1)*CI2-WA1(I)*CR2 CH(I-1,K,3) = WA2(I-1)*CR3+WA2(I)*CI3 CH(I,K,3) = WA2(I-1)*CI3-WA2(I)*CR3 CH(I-1,K,4) = WA3(I-1)*CR4+WA3(I)*CI4 CH(I,K,4) = WA3(I-1)*CI4-WA3(I)*CR4 103 CONTINUE 104 CONTINUE RETURN 105 DO 107 I=2,IDO,2 CDIR$ IVDEP DO 106 K=1,L1 TI1 = CC(I,1,K)-CC(I,3,K) TI2 = CC(I,1,K)+CC(I,3,K) TI3 = CC(I,2,K)+CC(I,4,K) TR4 = CC(I,2,K)-CC(I,4,K) TR1 = CC(I-1,1,K)-CC(I-1,3,K) TR2 = CC(I-1,1,K)+CC(I-1,3,K) TI4 = CC(I-1,4,K)-CC(I-1,2,K) TR3 = CC(I-1,2,K)+CC(I-1,4,K) CH(I-1,K,1) = TR2+TR3 CR3 = TR2-TR3 CH(I,K,1) = TI2+TI3 CI3 = TI2-TI3 CR2 = TR1+TR4 CR4 = TR1-TR4 CI2 = TI1+TI4 CI4 = TI1-TI4 CH(I-1,K,2) = WA1(I-1)*CR2+WA1(I)*CI2 CH(I,K,2) = WA1(I-1)*CI2-WA1(I)*CR2 CH(I-1,K,3) = WA2(I-1)*CR3+WA2(I)*CI3 CH(I,K,3) = WA2(I-1)*CI3-WA2(I)*CR3 CH(I-1,K,4) = WA3(I-1)*CR4+WA3(I)*CI4 CH(I,K,4) = WA3(I-1)*CI4-WA3(I)*CR4 106 CONTINUE 107 CONTINUE RETURN END SUBROUTINE PASSF5(IDO,L1,CC,CH,WA1,WA2,WA3,WA4) C***BEGIN PROLOGUE PASSF5 C***REFER TO CFFTF C***ROUTINES CALLED (NONE) C***END PROLOGUE PASSF5 DIMENSION CC(IDO,5,L1) ,CH(IDO,L1,5) , 1 WA1(*) ,WA2(*) ,WA3(*) ,WA4(*) C***FIRST EXECUTABLE STATEMENT PASSF5 PI = 4.*ATAN(1.) TR11 = SIN(.1*PI) TI11 = -SIN(.4*PI) TR12 = -SIN(.3*PI) TI12 = -SIN(.2*PI) IF (IDO .NE. 2) GO TO 102 DO 101 K=1,L1 TI5 = CC(2,2,K)-CC(2,5,K) TI2 = CC(2,2,K)+CC(2,5,K) TI4 = CC(2,3,K)-CC(2,4,K) TI3 = CC(2,3,K)+CC(2,4,K) TR5 = CC(1,2,K)-CC(1,5,K) TR2 = CC(1,2,K)+CC(1,5,K) TR4 = CC(1,3,K)-CC(1,4,K) TR3 = CC(1,3,K)+CC(1,4,K) CH(1,K,1) = CC(1,1,K)+TR2+TR3 CH(2,K,1) = CC(2,1,K)+TI2+TI3 CR2 = CC(1,1,K)+TR11*TR2+TR12*TR3 CI2 = CC(2,1,K)+TR11*TI2+TR12*TI3 CR3 = CC(1,1,K)+TR12*TR2+TR11*TR3 CI3 = CC(2,1,K)+TR12*TI2+TR11*TI3 CR5 = TI11*TR5+TI12*TR4 CI5 = TI11*TI5+TI12*TI4 CR4 = TI12*TR5-TI11*TR4 CI4 = TI12*TI5-TI11*TI4 CH(1,K,2) = CR2-CI5 CH(1,K,5) = CR2+CI5 CH(2,K,2) = CI2+CR5 CH(2,K,3) = CI3+CR4 CH(1,K,3) = CR3-CI4 CH(1,K,4) = CR3+CI4 CH(2,K,4) = CI3-CR4 CH(2,K,5) = CI2-CR5 101 CONTINUE RETURN 102 IF(IDO/2.LT.L1) GO TO 105 DO 104 K=1,L1 CDIR$ IVDEP DO 103 I=2,IDO,2 TI5 = CC(I,2,K)-CC(I,5,K) TI2 = CC(I,2,K)+CC(I,5,K) TI4 = CC(I,3,K)-CC(I,4,K) TI3 = CC(I,3,K)+CC(I,4,K) TR5 = CC(I-1,2,K)-CC(I-1,5,K) TR2 = CC(I-1,2,K)+CC(I-1,5,K) TR4 = CC(I-1,3,K)-CC(I-1,4,K) TR3 = CC(I-1,3,K)+CC(I-1,4,K) CH(I-1,K,1) = CC(I-1,1,K)+TR2+TR3 CH(I,K,1) = CC(I,1,K)+TI2+TI3 CR2 = CC(I-1,1,K)+TR11*TR2+TR12*TR3 CI2 = CC(I,1,K)+TR11*TI2+TR12*TI3 CR3 = CC(I-1,1,K)+TR12*TR2+TR11*TR3 CI3 = CC(I,1,K)+TR12*TI2+TR11*TI3 CR5 = TI11*TR5+TI12*TR4 CI5 = TI11*TI5+TI12*TI4 CR4 = TI12*TR5-TI11*TR4 CI4 = TI12*TI5-TI11*TI4 DR3 = CR3-CI4 DR4 = CR3+CI4 DI3 = CI3+CR4 DI4 = CI3-CR4 DR5 = CR2+CI5 DR2 = CR2-CI5 DI5 = CI2-CR5 DI2 = CI2+CR5 CH(I-1,K,2) = WA1(I-1)*DR2+WA1(I)*DI2 CH(I,K,2) = WA1(I-1)*DI2-WA1(I)*DR2 CH(I-1,K,3) = WA2(I-1)*DR3+WA2(I)*DI3 CH(I,K,3) = WA2(I-1)*DI3-WA2(I)*DR3 CH(I-1,K,4) = WA3(I-1)*DR4+WA3(I)*DI4 CH(I,K,4) = WA3(I-1)*DI4-WA3(I)*DR4 CH(I-1,K,5) = WA4(I-1)*DR5+WA4(I)*DI5 CH(I,K,5) = WA4(I-1)*DI5-WA4(I)*DR5 103 CONTINUE 104 CONTINUE RETURN 105 DO 107 I=2,IDO,2 CDIR$ IVDEP DO 106 K=1,L1 TI5 = CC(I,2,K)-CC(I,5,K) TI2 = CC(I,2,K)+CC(I,5,K) TI4 = CC(I,3,K)-CC(I,4,K) TI3 = CC(I,3,K)+CC(I,4,K) TR5 = CC(I-1,2,K)-CC(I-1,5,K) TR2 = CC(I-1,2,K)+CC(I-1,5,K) TR4 = CC(I-1,3,K)-CC(I-1,4,K) TR3 = CC(I-1,3,K)+CC(I-1,4,K) CH(I-1,K,1) = CC(I-1,1,K)+TR2+TR3 CH(I,K,1) = CC(I,1,K)+TI2+TI3 CR2 = CC(I-1,1,K)+TR11*TR2+TR12*TR3 CI2 = CC(I,1,K)+TR11*TI2+TR12*TI3 CR3 = CC(I-1,1,K)+TR12*TR2+TR11*TR3 CI3 = CC(I,1,K)+TR12*TI2+TR11*TI3 CR5 = TI11*TR5+TI12*TR4 CI5 = TI11*TI5+TI12*TI4 CR4 = TI12*TR5-TI11*TR4 CI4 = TI12*TI5-TI11*TI4 DR3 = CR3-CI4 DR4 = CR3+CI4 DI3 = CI3+CR4 DI4 = CI3-CR4 DR5 = CR2+CI5 DR2 = CR2-CI5 DI5 = CI2-CR5 DI2 = CI2+CR5 CH(I-1,K,2) = WA1(I-1)*DR2+WA1(I)*DI2 CH(I,K,2) = WA1(I-1)*DI2-WA1(I)*DR2 CH(I-1,K,3) = WA2(I-1)*DR3+WA2(I)*DI3 CH(I,K,3) = WA2(I-1)*DI3-WA2(I)*DR3 CH(I-1,K,4) = WA3(I-1)*DR4+WA3(I)*DI4 CH(I,K,4) = WA3(I-1)*DI4-WA3(I)*DR4 CH(I-1,K,5) = WA4(I-1)*DR5+WA4(I)*DI5 CH(I,K,5) = WA4(I-1)*DI5-WA4(I)*DR5 106 CONTINUE 107 CONTINUE RETURN END SUBROUTINE PBDV(V,X,DV,DP,PDF,PDD) C C ==================================================== C Purpose: Compute parabolic cylinder functions Dv(x) C and their derivatives C Input: x --- Argument of Dv(x) C v --- Order of Dv(x) C Output: DV(na) --- Dn+v0(x) C DP(na) --- Dn+v0'(x) C ( na = |n|, v0 = v-n, |v0| < 1, C n = 0,ñ1,ñ2,úúú ) C PDF --- Dv(x) C PDD --- Dv'(x) C Routines called: C (1) DVSA for computing Dv(x) for small |x| C (2) DVLA for computing Dv(x) for large |x| C ==================================================== C IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION DV(0:*),DP(0:*) XA=DABS(X) VH=V V=V+DSIGN(1.0D0,V) NV=INT(V) V0=V-NV NA=ABS(NV) EP=DEXP(-.25D0*X*X) IF (NA.GE.1) JA=1 IF (V.GE.0.0) THEN IF (V0.EQ.0.0) THEN PD0=EP PD1=X*EP ELSE DO 10 L=0,JA V1=V0+L IF (XA.LE.5.8) CALL DVSA(V1,X,PD1) IF (XA.GT.5.8) CALL DVLA(V1,X,PD1) IF (L.EQ.0) PD0=PD1 10 CONTINUE ENDIF DV(0)=PD0 DV(1)=PD1 DO 15 K=2,NA PDF=X*PD1-(K+V0-1.0D0)*PD0 DV(K)=PDF PD0=PD1 15 PD1=PDF ELSE IF (X.LE.0.0) THEN IF (XA.LE.5.8D0) THEN CALL DVSA(V0,X,PD0) V1=V0-1.0D0 CALL DVSA(V1,X,PD1) ELSE CALL DVLA(V0,X,PD0) V1=V0-1.0D0 CALL DVLA(V1,X,PD1) ENDIF DV(0)=PD0 DV(1)=PD1 DO 20 K=2,NA PD=(-X*PD1+PD0)/(K-1.0D0-V0) DV(K)=PD PD0=PD1 20 PD1=PD ELSE IF (X.LE.2.0) THEN V2=NV+V0 IF (NV.EQ.0) V2=V2-1.0D0 NK=INT(-V2) CALL DVSA(V2,X,F1) V1=V2+1.0D0 CALL DVSA(V1,X,F0) DV(NK)=F1 DV(NK-1)=F0 DO 25 K=NK-2,0,-1 F=X*F0+(K-V0+1.0D0)*F1 DV(K)=F F1=F0 25 F0=F ELSE IF (XA.LE.5.8) CALL DVSA(V0,X,PD0) IF (XA.GT.5.8) CALL DVLA(V0,X,PD0) DV(0)=PD0 M=100+NA F1=0.0D0 F0=1.0D-30 DO 30 K=M,0,-1 F=X*F0+(K-V0+1.0D0)*F1 IF (K.LE.NA) DV(K)=F F1=F0 30 F0=F S0=PD0/F DO 35 K=0,NA 35 DV(K)=S0*DV(K) ENDIF ENDIF DO 40 K=0,NA-1 V1=ABS(V0)+K IF (V.GE.0.0D0) THEN DP(K)=0.5D0*X*DV(K)-DV(K+1) ELSE DP(K)=-0.5D0*X*DV(K)-V1*DV(K+1) ENDIF 40 CONTINUE PDF=DV(NA-1) PDD=DP(NA-1) V=VH RETURN END SUBROUTINE PBNCOR(X,Y,N,IWRITE,XTEMP1,XTEMP2,MAXNXT,PBCORR,BETA, 1 IBUGA3,IERROR) C C PURPOSE--THIS SUBROUTINE COMPUTES THE C SAMPLE PERCENTAGE BEND CORRELATION C OF THE DATA IN THE INPUT VECTORS X AND Y. C THIS IS A ROBUST MEASURE OF SCALE DESCRIBED IN C "INTRODUCTION TO ROBUST ESTIMATION AND HYPOTHESIS C TESTING", RAND R. WILCOX, ACADEMIC PRESS, 1997. C INPUT ARGUMENTS--X = THE SINGLE PRECISION VECTOR OF C (UNSORTED OR SORTED) OBSERVATIONS. C --Y = THE SINGLE PRECISION VECTOR OF C (UNSORTED OR SORTED) OBSERVATIONS. C --N = THE INTEGER NUMBER OF OBSERVATIONS C IN THE VECTOR X. C OUTPUT ARGUMENTS--PBCORR = THE SINGLE PRECISION VALUE OF THE C COMPUTED SAMPLE PERCENTAGE BEND C CORRELATION. C OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE C SAMPLE PERCENTAGE BEND CORRELATION (WITH DENOMINATOR N-1). C OTHER DATAPAC SUBROUTINES NEEDED--MEDIAN AND SORT. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--"INTRODUCTION TO ROBUST ESTIMATION AND HYPOTHESIS C TESTING", RAND R. WILCOX, ACADEMIC PRESS, 1997. C COMPUTATIONAL STEPS DESCRIBED IN THIS REFERENCE. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2002/7 C ORIGINAL VERSION--JULY 2002. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IWRITE CHARACTER*4 IBUGA3 CHARACTER*4 IERROR C CHARACTER*4 IWRIT2 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C C DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 DOUBLE PRECISION DTERM3 DOUBLE PRECISION DTERM4 DOUBLE PRECISION DTERM5 DOUBLE PRECISION DTERM6 C DIMENSION X(*) DIMENSION Y(*) DIMENSION XTEMP1(*) DIMENSION XTEMP2(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='NCOR' ISUBN2=' ' C IERROR='NO' C IF(IBUGA3.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF PBNCOR--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA3 52 FORMAT('IBUGA3 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)N 53 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') DO55I=1,N WRITE(ICOUT,56)I,X(I),Y(I) 56 FORMAT('I,X(I),Y(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 55 CONTINUE 90 CONTINUE C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C AN=N C IF(N.GE.1)GOTO119 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,111) 111 FORMAT('***** ERROR IN PBNCOR--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,112) 112 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,113) 113 FORMAT(' IN THE VARIABLE FOR WHICH') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,114) 114 FORMAT(' THE PERCENTAGE BEND CORRELATION IS TO BE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,115) 115 FORMAT(' COMPUTED, MUST BE 1 OR LARGER.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,116) 116 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,117)N 117 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8, 1'.') CALL DPWRST('XXX','BUG ') GOTO9000 119 CONTINUE C IF(N.EQ.1)GOTO120 GOTO129 120 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,121) 121 FORMAT('***** NON-FATAL DIAGNOSTIC IN PBNCOR--', 1'THE SECOND INPUT ARGUMENT (N) HAS THE VALUE 1') CALL DPWRST('XXX','BUG ') PBCORR=0.0 GOTO9000 129 CONTINUE C 190 CONTINUE C C ************************************************* C ** STEP 2-- ** C ** COMPUTE THE PERCENTAGE BEND CORRELATION. ** C ************************************************* C IWRIT2='OFF' C CALL MEDIAN(X,N,IWRIT2,XTEMP1,MAXNXT,XMED,IBUGA3,IERROR) CALL MEDIAN(Y,N,IWRIT2,XTEMP1,MAXNXT,YMED,IBUGA3,IERROR) C DO300I=1,N XTEMP1(I)=ABS(X(I)-XMED) XTEMP2(I)=ABS(Y(I)-YMED) 300 CONTINUE C IF(BETA.LE.0.01 .OR. BETA.GT.0.99)THEN WRITE(ICOUT,121) 321 FORMAT('***** NON-FATAL DIAGNOSTIC IN PBNCOR--', 1 'THE VALUE OF BETA OUTSIDE THE (0.01,0.99) INTERVAL.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,323) 323 FORMAT(' DEFAULT VALUE OF 0.1 USED.') CALL DPWRST('XXX','BUG ') BETA=0.1 ENDIF C CALL SORT(XTEMP1,N,XTEMP1) CALL SORT(XTEMP2,N,XTEMP2) C AN=REAL(N) AM=(1.0 - BETA)*AN + 0.5 M=INT(AM) WBETAX=XTEMP1(M) WBETAY=XTEMP2(M) C I1=0 I2=0 I3=0 I6=0 I7=0 I8=0 DTERM1=0.0D0 DTERM6=0.0D0 DO400I=1,N IF(ABS((X(I)-XMED)/WBETAX).LE.1.0)THEN DTERM1=DTERM1 + X(I) I3=I3 + 1 ELSEIF((X(I)-XMED)/WBETAX.LT.-1.0)THEN I1=I1 + 1 ELSEIF((X(I)-XMED)/WBETAX.GT.1.0)THEN I2=I2 + 1 ENDIF C IF(ABS((Y(I)-YMED)/WBETAY).LE.1.0)THEN DTERM6=DTERM6 + Y(I) I8=I8+1 ELSEIF((Y(I)-YMED)/WBETAY.LT.-1.0)THEN I6=I6 + 1 ELSEIF((Y(I)-YMED)/WBETAY.GT.1.0)THEN I7=I7 + 1 ENDIF 400 CONTINUE PHIX=(WBETAX*REAL(I2-I1) + REAL(DTERM1))/REAL(N - I1 - I2) PHIY=(WBETAY*REAL(I7-I6) + REAL(DTERM6))/REAL(N - I6 - I7) C DTERM1=0.0D0 DTERM2=0.0D0 DTERM3=0.0D0 DO500I=1,N UI=(X(I) - PHIX)/WBETAX VI=(Y(I) - PHIY)/WBETAY DTERM4=MAX(-1.0D0,MIN(1.0D0,DBLE(UI))) DTERM5=MAX(-1.0D0,MIN(1.0D0,DBLE(VI))) DTERM1=DTERM1 + DTERM4*DTERM4 DTERM2=DTERM2 + DTERM5*DTERM5 DTERM3=DTERM3 + DTERM4*DTERM5 500 CONTINUE DTERM4=0.0D0 IF(DTERM1*DTERM2.GT.0.0D0)DTERM4=DTERM3/DSQRT(DTERM1*DTERM2) PBCORR=REAL(DTERM4) C C ******************************* C ** STEP 3-- ** C ** WRITE OUT A LINE ** C ** OF SUMMARY INFORMATION. ** C ******************************* C IF(IFEEDB.EQ.'OFF')GOTO890 IF(IWRITE.EQ.'OFF')GOTO890 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,811)N,PBCORR 811 FORMAT('THE PERCENTAGE BEND CORRELATION OF THE ',I8, 1' OBSERVATIONS = ',E15.7) CALL DPWRST('XXX','BUG ') 890 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE IF(IBUGA3.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF PBNCOR--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGA3,IERROR 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)N 9013 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)XMED,WBETAX,YMED,WBETAY 9014 FORMAT('XMED,WBETAX,YMED,WBETAY = ',4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)PBCORR 9015 FORMAT('PBCORR = ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9016)DTERM1,DTERM2,DTERM3,DTERM3 9016 FORMAT('DTERM1,DTERM2,DTERM3,DTERM3 = ',4D15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9018)I1,I2,I3,I6,I7,I8 9018 FORMAT('I1,I2,I3,I6,I7,I8 = ',6I8) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE PBNMDV(X,N,IWRITE,XTEMP,MAXNXT,PBMDVA,BETA, 1 IBUGA3,IERROR) C C PURPOSE--THIS SUBROUTINE COMPUTES THE C SAMPLE PERCENTAGE BEND MIDVARIANCE C OF THE DATA IN THE INPUT VECTOR X. C THIS IS A ROBUST MEASURE OF SCALE DESCRIBED IN C "INTRODUCTION TO ROBUST ESTIMATION AND HYPOTHESIS C TESTING", RAND R. WILCOX, ACADEMIC PRESS, 1997. C INPUT ARGUMENTS--X = THE SINGLE PRECISION VECTOR OF C (UNSORTED OR SORTED) OBSERVATIONS. C --N = THE INTEGER NUMBER OF OBSERVATIONS C IN THE VECTOR X. C OUTPUT ARGUMENTS--PBMDVA = THE SINGLE PRECISION VALUE OF THE C COMPUTED SAMPLE PERCENTAGE BEND MIDVARIANCE. C OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE C SAMPLE PERCENTAGE BEND MIDVARIANCE (WITH DENOMINATOR N-1). C OTHER DATAPAC SUBROUTINES NEEDED--MEDIAN AND SORT. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--"INTRODUCTION TO ROBUST ESTIMATION AND HYPOTHESIS C TESTING", RAND R. WILCOX, ACADEMIC PRESS, 1997. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2002/7 C ORIGINAL VERSION--JULY 2002. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IWRITE CHARACTER*4 IBUGA3 CHARACTER*4 IERROR C CHARACTER*4 IWRIT2 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C C DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 DOUBLE PRECISION DTERM3 DOUBLE PRECISION DTERM4 C DIMENSION X(*) DIMENSION XTEMP(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='NMDV ' ISUBN2=' ' C IERROR='NO' C IF(IBUGA3.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF PBNMDV--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA3 52 FORMAT('IBUGA3 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)N 53 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') DO55I=1,N WRITE(ICOUT,56)I,X(I) 56 FORMAT('I,X(I) = ',I8,E15.7) CALL DPWRST('XXX','BUG ') 55 CONTINUE 90 CONTINUE C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C AN=N C IF(N.GE.1)GOTO119 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,111) 111 FORMAT('***** ERROR IN PBNMDV--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,112) 112 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,113) 113 FORMAT(' IN THE VARIABLE FOR WHICH') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,114) 114 FORMAT(' THE PERCENTAGE BEND MIDVARIANCE IS TO BE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,115) 115 FORMAT(' COMPUTED, MUST BE 1 OR LARGER.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,116) 116 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,117)N 117 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8, 1'.') CALL DPWRST('XXX','BUG ') GOTO9000 119 CONTINUE C IF(N.EQ.1)GOTO120 GOTO129 120 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,121) 121 FORMAT('***** NON-FATAL DIAGNOSTIC IN PBNMDV--', 1'THE SECOND INPUT ARGUMENT (N) HAS THE VALUE 1') CALL DPWRST('XXX','BUG ') PBMDVA=0.0 GOTO9000 129 CONTINUE C HOLD=X(1) DO135I=2,N IF(X(I).NE.HOLD)GOTO139 135 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,136)HOLD 136 FORMAT('***** NON-FATAL DIAGNOSTIC IN PBNMDV--', 1'THE FIRST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7) CALL DPWRST('XXX','BUG ') PBMDVA=0.0 GOTO9000 139 CONTINUE C 190 CONTINUE C C ************************************************* C ** STEP 2-- ** C ** COMPUTE THE PERCENTAGE BEND MIDVARIANCE. ** C ************************************************* C IWRIT2='OFF' CALL MEDIAN(X,N,IWRIT2,XTEMP,MAXNXT,XMED,IBUGA3,IERROR) C DO300I=1,N XTEMP(I)=ABS(X(I)-XMED) 300 CONTINUE C IF(BETA.LE.0.01 .OR. BETA.GT.0.99)THEN WRITE(ICOUT,121) 321 FORMAT('***** NON-FATAL DIAGNOSTIC IN PBNMDV--', 1 'THE VALUE OF BETA OUTSIDE THE (0.01,0.99) INTERVAL.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,323) 323 FORMAT(' DEFAULT VALUE OF 0.1 USED.') CALL DPWRST('XXX','BUG ') BETA=0.1 ENDIF C CALL SORT(XTEMP,N,XTEMP) AN=REAL(N) AM=(1.0 - BETA)*AN + 0.5 M=INT(AM) WBETA=XTEMP(M) C DTERM2=0.0D0 DO400I=1,N X(I)=(X(I) - XMED)/WBETA IF(ABS(X(I)).LT.1.0)DTERM2=DTERM2+1.0D0 400 CONTINUE DTERM2=DTERM2*DTERM2 C DTERM1=DBLE(WBETA)/DTERM2 DTERM1=DTERM1*DBLE(WBETA)*DBLE(N) DTERM3=0.0D0 DO500I=1,N DTERM4=MAX(-1.0D0,MIN(1.0D0,DBLE(X(I)))) DTERM3=DTERM3 + DTERM4*DTERM4 500 CONTINUE PBMDVA=REAL(DTERM1*DTERM3) C C ******************************* C ** STEP 3-- ** C ** WRITE OUT A LINE ** C ** OF SUMMARY INFORMATION. ** C ******************************* C IF(IFEEDB.EQ.'OFF')GOTO890 IF(IWRITE.EQ.'OFF')GOTO890 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,811)N,PBMDVA 811 FORMAT('THE PERCENTAGE BEND MIDVARIANCE OF THE ',I8, 1' OBSERVATIONS = ',E15.7) CALL DPWRST('XXX','BUG ') 890 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE IF(IBUGA3.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF PBNMDV--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGA3,IERROR 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)N 9013 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)XMED,WBETA 9014 FORMAT('XMED,WBETA = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)PBMDVA 9015 FORMAT('PBMDVA = ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9016)DTERM1,DTERM2,DTERM3,DTERM4 9016 FORMAT('DTERM1,DTERM2,DTERM3,DTERM4 = ',4D15.7) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE PBVV(V,X,VV,VP,PVF,PVD) C C =================================================== C Purpose: Compute parabolic cylinder functions Vv(x) C and their derivatives C Input: x --- Argument of Vv(x) C v --- Order of Vv(x) C Output: VV(na) --- Vv(x) C VP(na) --- Vv'(x) C ( na = |n|, v = n+v0, |v0| < 1 C n = 0,ñ1,ñ2,úúú ) C PVF --- Vv(x) C PVD --- Vv'(x) C Routines called: C (1) VVSA for computing Vv(x) for small |x| C (2) VVLA for computing Vv(x) for large |x| C =================================================== C IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION VV(0:*),VP(0:*) PI=3.141592653589793D0 XA=DABS(X) VH=V V=V+DSIGN(1.0D0,V) NV=INT(V) V0=V-NV NA=ABS(NV) QE=DEXP(0.25D0*X*X) Q2P=DSQRT(2.0D0/PI) IF (NA.GE.1) JA=1 IF (V.LE.0.0) THEN IF (V0.EQ.0.0) THEN IF (XA.LE.7.5) CALL VVSA(V0,X,PV0) IF (XA.GT.7.5) CALL VVLA(V0,X,PV0) F0=Q2P*QE F1=X*F0 VV(0)=PV0 VV(1)=F0 VV(2)=F1 ELSE DO 10 L=0,JA V1=V0-L IF (XA.LE.7.5) CALL VVSA(V1,X,F1) IF (XA.GT.7.5) CALL VVLA(V1,X,F1) IF (L.EQ.0) F0=F1 10 CONTINUE VV(0)=F0 VV(1)=F1 ENDIF KV=2 IF (V0.EQ.0.0) KV=3 DO 15 K=KV,NA F=X*F1+(K-V0-2.0D0)*F0 VV(K)=F F0=F1 15 F1=F ELSE IF (X.GE.0.0.AND.X.LE.7.5D0) THEN V2=V IF (V2.LT.1.0) V2=V2+1.0D0 CALL VVSA(V2,X,F1) V1=V2-1.0D0 KV=INT(V2) CALL VVSA(V1,X,F0) VV(KV)=F1 VV(KV-1)=F0 DO 20 K=KV-2,0,-1 F=X*F0-(K+V0+2.0D0)*F1 IF (K.LE.NA) VV(K)=F F1=F0 20 F0=F ELSE IF (X.GT.7.5D0) THEN CALL VVLA(V0,X,PV0) M=100+ABS(NA) VV(1)=PV0 F1=0.0D0 F0=1.0D-40 DO 25 K=M,0,-1 F=X*F0-(K+V0+2.0D0)*F1 IF (K.LE.NA) VV(K)=F F1=F0 25 F0=F S0=PV0/F DO 30 K=0,NA 30 VV(K)=S0*VV(K) ELSE IF (XA.LE.7.5D0) THEN CALL VVSA(V0,X,F0) V1=V0+1.0 CALL VVSA(V1,X,F1) ELSE CALL VVLA(V0,X,F0) V1=V0+1.0D0 CALL VVLA(V1,X,F1) ENDIF VV(0)=F0 VV(1)=F1 DO 35 K=2,NA F=(X*F1-F0)/(K+V0) VV(K)=F F0=F1 35 F1=F ENDIF ENDIF DO 40 K=0,NA-1 V1=V0+K IF (V.GE.0.0D0) THEN VP(K)=0.5D0*X*VV(K)-(V1+1.0D0)*VV(K+1) ELSE VP(K)=-0.5D0*X*VV(K)+VV(K+1) ENDIF 40 CONTINUE PVF=VV(NA-1) PVD=VP(NA-1) V=VH RETURN END SUBROUTINE PBWA(A,X,W1F,W1D,W2F,W2D) C C ====================================================== C Purpose: Compute parabolic cylinder functions W(a,ñx) C and their derivatives C Input : a --- Parameter ( 0 ó |a| ó 5 ) C x --- Argument of W(a,ñx) ( 0 ó |x| ó 5 ) C Output : W1F --- W(a,x) C W1D --- W'(a,x) C W2F --- W(a,-x) C W2D --- W'(a,-x) C Routine called: C CGAMA for computing complex gamma function C ====================================================== C IMPLICIT DOUBLE PRECISION (A,B,D-H,O-Y) CCCCC IMPLICIT COMPLEX *16 (C,Z) DIMENSION H(100),D(100) EPS=1.0D-15 P0=0.59460355750136D0 IF (A.EQ.0.0D0) THEN G1=3.625609908222D0 G2=1.225416702465D0 ELSE X1=0.25D0 Y1=0.5D0*A CALL CGAMA(X1,Y1,1,UGR,UGI) G1=DSQRT(UGR*UGR+UGI*UGI) X2=0.75D0 CALL CGAMA(X2,Y1,1,VGR,VGI) G2=DSQRT(VGR*VGR+VGI*VGI) ENDIF F1=DSQRT(G1/G2) F2=DSQRT(2.0D0*G2/G1) H0=1.0D0 H1=A H(1)=A DO 10 L1=4,200,2 M=L1/2 HL=A*H1-0.25D0*(L1-2.0D0)*(L1-3.0D0)*H0 H(M)=HL H0=H1 10 H1=HL Y1F=1.0D0 R=1.0D0 DO 15 K=1,100 R=0.5D0*R*X*X/(K*(2.0D0*K-1.0D0)) R1=H(K)*R Y1F=Y1F+R1 IF (DABS(R1/Y1F).LE.EPS.AND.K.GT.30) GO TO 20 15 CONTINUE 20 Y1D=A R=1.0D0 DO 25 K=1,100 R=0.5D0*R*X*X/(K*(2.0D0*K+1.0D0)) R1=H(K+1)*R Y1D=Y1D+R1 IF (DABS(R1/Y1D).LE.EPS.AND.K.GT.30) GO TO 30 25 CONTINUE 30 Y1D=X*Y1D D1=1.0D0 D2=A D(1)=1.0D0 D(2)=A DO 40 L2=5,160,2 M=(L2+1)/2 DL=A*D2-0.25D0*(L2-2.0D0)*(L2-3.0D0)*D1 D(M)=DL D1=D2 40 D2=DL Y2F=1.0D0 R=1.0D0 DO 45 K=1,100 R=0.5D0*R*X*X/(K*(2.0D0*K+1.0D0)) R1=D(K+1)*R Y2F=Y2F+R1 IF (DABS(R1/Y2F).LE.EPS.AND.K.GT.30) GO TO 50 45 CONTINUE 50 Y2F=X*Y2F Y2D=1.0D0 R=1.0D0 DO 55 K=1,100 R=0.5D0*R*X*X/(K*(2.0D0*K-1.0D0)) R1=D(K+1)*R Y2D=Y2D+R1 IF (DABS(R1/Y2D).LE.EPS.AND.K.GT.30) GO TO 60 55 CONTINUE 60 W1F=P0*(F1*Y1F-F2*Y2F) W2F=P0*(F1*Y1F+F2*Y2F) W1D=P0*(F1*Y1D-F2*Y2D) W2D=P0*(F1*Y1D+F2*Y2D) RETURN END SUBROUTINE PELGLO(XMOM,PARA) C===================================================== PELGLO.FOR C*********************************************************************** C* * C* FORTRAN CODE WRITTEN FOR INCLUSION IN IBM RESEARCH REPORT RC20525, * C* 'FORTRAN ROUTINES FOR USE WITH THE METHOD OF L-MOMENTS, VERSION 3' * C* * C* J. R. M. HOSKING * C* IBM RESEARCH DIVISION * C* T. J. WATSON RESEARCH CENTER * C* YORKTOWN HEIGHTS * C* NEW YORK 10598, U.S.A. * C* * C* VERSION 3 AUGUST 1996 * C* * C*********************************************************************** C C PARAMETER ESTIMATION VIA L-MOMENTS FOR THE GENERALIZED LOGISTIC C DISTRIBUTION C C PARAMETERS OF ROUTINE: C XMOM * INPUT* ARRAY OF LENGTH 3. CONTAINS THE L-MOMENTS LAMBDA-1, C LAMBDA-2, TAU-3. C PARA *OUTPUT* ARRAY OF LENGTH 3. ON EXIT, CONTAINS THE PARAMETERS C IN THE ORDER XI, ALPHA, K (LOCATION, SCALE, SHAPE). C IMPLICIT DOUBLE PRECISION (A-H,O-Z) DOUBLE PRECISION XMOM(3),PARA(3) C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C REAL CPUMIN REAL CPUMAX COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C DATA ZERO/0.0D0/ DATA ONE/1.0D0/ DATA PI/3.141592653589793238D0/ C C SMALL IS USED TO TEST WHETHER K IS EFFECTIVELY ZERO C DATA SMALL/1D-6/ C C ESTIMATE K C G=-XMOM(3) IF(XMOM(2).LE.ZERO.OR.DABS(G).GE.ONE)THEN WRITE(ICOUT,7000) 7000 FORMAT('***** ERROR IN GENERALIZED LOGISTIC L-MOMENTS ', 1 'ESTIMATION--') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,7005) 7005 FORMAT(' L-MOMENTS INVALID') CALL DPWRST('XXX','WRIT') PARA(3)=ZERO PARA(2)=ZERO PARA(1)=ZERO GOTO9000 ENDIF C C ESTIMATED K EFFECTIVELY ZERO (I.E., USE LOGISTIC RATHER THAN C GENERALIZED LOGISTIC) C IF(DABS(G).LE.SMALL)THEN PARA(3)=ZERO PARA(2)=XMOM(2) PARA(1)=XMOM(1) GOTO9000 ENDIF C C ESTIMATE ALPHA, XI C GG=G*PI/DSIN(G*PI) A=XMOM(2)/GG PARA(1)=XMOM(1)-A*(ONE-GG)/G PARA(2)=A PARA(3)=G C 9000 CONTINUE RETURN END SUBROUTINE PELWAK(XMOM,PARA,IFAIL) C===================================================== PELWAK.FOR C*********************************************************************** C* * C* FORTRAN CODE WRITTEN FOR INCLUSION IN IBM RESEARCH REPORT RC20525, * C* 'FORTRAN ROUTINES FOR USE WITH THE METHOD OF L-MOMENTS, VERSION 3' * C* * C* J. R. M. HOSKING * C* IBM RESEARCH DIVISION * C* T. J. WATSON RESEARCH CENTER * C* YORKTOWN HEIGHTS * C* NEW YORK 10598, U.S.A. * C* * C* VERSION 3 AUGUST 1996 * C* * C*********************************************************************** C C PARAMETER ESTIMATION VIA L-MOMENTS FOR THE WAKEBY DISTRIBUTION C C PARAMETERS OF ROUTINE: C XMOM * INPUT* ARRAY OF LENGTH 5. CONTAINS THE L-MOMENTS LAMBDA-1, C LAMBDA-2, TAU-3, TAU-4, TAU-5. C PARA *OUTPUT* ARRAY OF LENGTH 5. ON EXIT, CONTAINS THE PARAMETERS C IN THE ORDER XI, ALPHA, BETA, GAMMA, DELTA. C IFAIL *OUTPUT* FAIL FLAG. ON EXIT, IT IS SET AS FOLLOWS. C 0 SUCCESSFUL EXIT C 1 ESTIMATES COULD ONLY BE OBTAINED BY SETTING XI=0 C 2 ESTIMATES COULD ONLY BE OBTAINED BY FITTING A C GENERALIZED PARETO DISTRIBUTION C 3 L-MOMENTS INVALID C C PROCEDURE: C 1. LOOK FOR A SOLUTION WITH XI UNCONSTRAINED; C 2. IF NONE FOUND, LOOK FOR A SOLUTION WITH XI=0; C 3. IF NONE FOUND, FIT A GENERALIZED PARETO DISTRIBUTION TO THE C FIRST 3 L-MOMENTS. C ESTIMATES ARE CALCULATED USING THE FORMULAS GIVEN BY GREENWOOD ET AL. C (1979, WATER RESOUR. RES., TABLE 5), BUT EXPRESSED IN TERMS OF C L-MOMENTS RATHER THAN PROBABILITY WEIGHTED MOMENTS. C IMPLICIT DOUBLE PRECISION (A-H,O-Z) DOUBLE PRECISION XMOM(5),PARA(5) C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C REAL CPUMIN REAL CPUMAX COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C DATA ZERO/0D0/,HALF/0.5D0/,ONE/1D0/,TWO/2D0/,THREE/3D0/,FOUR/4D0/ DATA X2/2D0/,X3/3D0/,X4/4D0/,X5/5D0/,X7/7D0/,X8/8D0/,X9/9D0/, * X10/10D0/,X11/11D0/,X16/16D0/,X25/25D0/,X29/29D0/,X32/32D0/, * X35/35D0/,X85/85D0/,X125/125D0/,X203/203D0/ C IF(DABS(XMOM(2)).LE.ZERO)GOTO 1000 IF(DABS(XMOM(3)).GE.ONE)GOTO 1000 IF(DABS(XMOM(4)).GE.ONE)GOTO 1000 IF(DABS(XMOM(5)).GE.ONE)GOTO 1000 IFAIL=0 C C CALCULATE THE L-MOMENTS (LAMBDA'S) C ALAM1=XMOM(1) ALAM2=XMOM(2) ALAM3=XMOM(3)*ALAM2 ALAM4=XMOM(4)*ALAM2 ALAM5=XMOM(5)*ALAM2 C C ESTIMATE N1,N2,N3,C1,C2,C3 WHEN XI.NE.0 C XN1= X3*ALAM2-X25*ALAM3 +X32*ALAM4 XN2=-X3*ALAM2 +X5*ALAM3 +X8*ALAM4 XN3= X3*ALAM2 +X5*ALAM3 +X2*ALAM4 XC1= X7*ALAM2-X85*ALAM3+X203*ALAM4-X125*ALAM5 XC2=-X7*ALAM2+X25*ALAM3 +X7*ALAM4 -X25*ALAM5 XC3= X7*ALAM2 +X5*ALAM3 -X7*ALAM4 -X5*ALAM5 C C ESTIMATE B AND D C XA=XN2*XC3-XC2*XN3 XB=XN1*XC3-XC1*XN3 XC=XN1*XC2-XC1*XN2 DISC=XB*XB-FOUR*XA*XC IF(DISC.LT.ZERO)GOTO 10 DISC=DSQRT(DISC) ROOT1=HALF*(-XB+DISC)/XA ROOT2=HALF*(-XB-DISC)/XA B= DMAX1(ROOT1,ROOT2) D=-DMIN1(ROOT1,ROOT2) IF(D.GE.ONE)GOTO 10 C C ESTIMATE A, C AND XI C A=(ONE+B)*(TWO+B)*(THREE+B)/ * (FOUR*(B+D))*((ONE+D)*ALAM2-(THREE-D)*ALAM3) C=-(ONE-D)*(TWO-D)*(THREE-D)/ * (FOUR*(B+D))*((ONE-B)*ALAM2-(THREE+B)*ALAM3) XI=ALAM1-A/(ONE+B)-C/(ONE-D) C C CHECK FOR VALID PARAMETERS C IF(C.GE.ZERO.AND.A+C.GE.ZERO)GOTO 30 C C CAN'T FIND VALID ESTIMATES FOR XI UNRESTRICTED, SO TRY XI=0 C C ESTIMATE B AND D FOR XI=0 C 10 CONTINUE IFAIL=1 XI=ZERO ZN1=X4*ALAM1-X11*ALAM2+X9*ALAM3 ZN2=-ALAM2+X3*ALAM3 ZN3=ALAM2+ALAM3 ZC1=X10*ALAM1-X29*ALAM2+X35*ALAM3-X16*ALAM4 ZC2=-ALAM2+X5*ALAM3-X4*ALAM4 ZC3=ALAM2-ALAM4 ZA=ZN2*ZC3-ZC2*ZN3 ZB=ZN1*ZC3-ZC1*ZN3 ZC=ZN1*ZC2-ZC1*ZN2 DISC=ZB*ZB-FOUR*ZA*ZC IF(DISC.LT.ZERO)GOTO 20 DISC=DSQRT(DISC) ROOT1=HALF*(-ZB+DISC)/ZA ROOT2=HALF*(-ZB-DISC)/ZA B= DMAX1(ROOT1,ROOT2) D=-DMIN1(ROOT1,ROOT2) IF(D.GE.ONE)GOTO 20 C C ESTIMATE A AND C C A= (ONE+B)*(TWO+B)/(B+D)*(ALAM1-(TWO-D)*ALAM2) C=-(ONE-D)*(TWO-D)/(B+D)*(ALAM1-(TWO+B)*ALAM2) IF(C.GE.ZERO.AND.A+C.GE.ZERO)GOTO 30 C C CAN'T FIND VALID ESTIMATES EVEN WITH XI=0 - C FIT GENERALIZED PARETO DISTRIBUTION INSTEAD C 20 CONTINUE IFAIL=2 D=-(ONE-THREE*XMOM(3))/(ONE+XMOM(3)) C=(ONE-D)*(TWO-D)*XMOM(2) B=ZERO A=ZERO XI=XMOM(1)-C/(ONE-D) IF(D.GT.ZERO)GOTO 30 A=C B=-D C=ZERO D=ZERO C C COPY RESULTS INTO ARRAY PARA C 30 CONTINUE PARA(1)=XI PARA(2)=A PARA(3)=B PARA(4)=C PARA(5)=D GOTO9000 C 1000 IFAIL=3 DO 1010 I=1,5 PARA(I)=ZERO 1010 CONTINUE GOTO9000 C 9000 CONTINUE RETURN END COMPLEX FUNCTION PEQ(Z) C C WEIERSTRASS: P-FUNCTION IN THE EQUIANHARMONIC CASE C FOR COMPLEX ARGUMENT WITH UNIT PERIOD PARALLELOGRAM C INCLUDE 'DPCOMC.INC' COMPLEX Z, Z2, Z4, Z6 REAL ZR, ZI INTEGER M, N C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C C REDUCTION TO FUNDAMENTAL PARALLELOGRAM C ZI = 1.1547005383792515E0*AIMAG(Z) + 0.5E0 M = INT(ZI) IF (ZI.LT.0E0) M = M - 1 ZR = REAL(Z) - 0.5E0*FLOAT(M) + 0.5E0 N = INT(ZR) IF (ZR.LT.0E0) N = N - 1 Z2 = Z - FLOAT(N) - (0.5E0,0.86602540378443865E0)*FLOAT(M) C C IF Z2=0 THEN Z COINCIDES WITH A LATTICE POINT. C SINCE P HAS POLES AT THE LATTICE POINTS, C A DIVISION ERROR WILL OCCUR C IF(REAL(Z2).EQ.0.0.AND.AIMAG(Z2).EQ.0.0)THEN PEQ=R1MACH(2) WRITE(ICOUT,91) CALL DPWRST('XXX','BUG ') RETURN ENDIF 91 FORMAT('***** ERROR: INPUT POINT CORRESPONDS TO A LATTICE ', 1'POINT. VALUE SET TO LARGEST REAL. *****') Z2 = Z2*Z2 Z4 = Z2*Z2 Z6 = Z4*Z2 PEQ = 1E0/Z2 + 6E0*Z4*(5E0+Z6)/(1E0-Z6)**2 + Z4* * (((((-2.6427662E-10*Z6+1.610954818E-8)*Z6+7.38610752879E-6)* * Z6+4.3991444671178E-4)*Z6+7.477288220490697E-2)* * Z6-6.8484153287299201E-1)/(((((6.2252191E-10*Z6+2.553314573E-7)* * Z6-2.619832920421E-5)*Z6-5.6444801847646E-4)* * Z6+4.565553484820106E-2)*Z6+1E0) RETURN END COMPLEX FUNCTION PEQ1(Z) C C FIRST DERIVATIVE OF WEIERSTRASS: P-FUNCTION IN THE C EQUIANHARMONIC CASE FOR COMPLEX ARGUMENT C WITH UNIT PERIOD PARALLELOGRAM C INCLUDE 'DPCOMC.INC' COMPLEX Z, Z3, Z6 REAL ZR, ZI INTEGER M, N C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C C REDUCTION TO FUNDAMENTAL PARALLELOGRAM C ZI = 1.1547005383792515E0*AIMAG(Z) + 0.5E0 M = INT(ZI) IF (ZI.LT.0E0) M = M - 1 ZR = REAL(Z) - 0.5E0*FLOAT(M) + 0.5E0 N = INT(ZR) IF (ZR.LT.0E0) N = N - 1 Z3 = Z - FLOAT(N) - (0.5E0,0.86602540378443865E0)*FLOAT(M) C C IF Z3=0 THEN Z COINCIDES WITH A LATTICE POINT. C SINCE P: HAS POLES AT THE LATTICE POINTS, C A DIVISION ERROR WILL OCCUR C IF(REAL(Z3).EQ.0.0.AND.AIMAG(Z3).EQ.0.0)THEN PEQ1=R1MACH(2) WRITE(ICOUT,91) CALL DPWRST('XXX','BUG ') RETURN ENDIF 91 FORMAT('***** ERROR: INPUT POINT CORRESPONDS TO A LATTICE ', 1'POINT. VALUE SET TO LARGEST REAL. *****') Z3 = Z3*Z3*Z3 Z6 = Z3*Z3 PEQ1 = (((14E0*Z6+294E0)*Z6+126E0)*Z6-2E0)/(Z3*(1E0-Z6)**3) + * Z3*((((((-2.95539175E-9*Z6-2.6764693031E-7)*Z6+2.402192743346E-5) * *Z6+1.9656661451391E-4)*Z6+1.760135529461036E-2)* * Z6+8.1026243498822636E-1)*Z6-2.73936613149196804E0)/ * ((((((4.6397763E-10*Z6+5.413482233E-8)*Z6-1.56293298374E-6)* * Z6-1.0393701076352E-4)*Z6+9.5553182532237E-4)* * Z6+9.131106969640212E-2)*Z6+1E0) RETURN END SUBROUTINE PERCEN(P100,X,N,IWRITE,XTEMP,MAXNXT, 1XPERC,IBUGA3,IERROR) C C PURPOSE--THIS SUBROUTINE COMPUTES THE C SAMPLE PERCENTILE C OF THE DATA IN THE INPUT VECTOR X. C INPUT ARGUMENTS--P100 = THE SINGLE PRECISION PERCENTAGE C (BETWEEN 0 AND 100) C --X = THE SINGLE PRECISION VECTOR OF C (UNSORTED OR SORTED) OBSERVATIONS. C --N = THE INTEGER NUMBER OF OBSERVATIONS C IN THE VECTOR X. C OUTPUT ARGUMENTS--XPERC = THE SINGLE PRECISION VALUE OF THE C COMPUTED SAMPLE PERCENTILE. C OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE C SAMPLE PERCENTILE. C OTHER DATAPAC SUBROUTINES NEEDED--SORT. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES-- C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--87.11 C ORIGINAL VERSION--SEPTEMBER 1987. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IWRITE CHARACTER*4 IBUGA3 CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C DIMENSION X(*) DIMENSION XTEMP(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='PERC' ISUBN2='EN ' C IERROR='NO' C NI=0 NIP1=0 C ANI=0.0 A2NI=0.0 REM=0.0 C IF(IBUGA3.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF PERCEN--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA3 52 FORMAT('IBUGA3 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)P100,N 53 FORMAT('P100,N = ',E15.7,I8) CALL DPWRST('XXX','BUG ') DO55I=1,N WRITE(ICOUT,56)I,X(I) 56 FORMAT('I,X(I) = ',I8,E15.7) CALL DPWRST('XXX','BUG ') 55 CONTINUE 90 CONTINUE C C ****************************** C ** COMPUTE PERCENTILE ** C ****************************** C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C AN=N C IF(0.0.LT.P100.AND.P100.LT.100.0)GOTO119 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,111) 111 FORMAT('***** ERROR IN PERCEN--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,112) 112 FORMAT(' THE INPUT PERCENTAGE FOR WHICH') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,113) 113 FORMAT(' THE PERCENTILE IS TO BE COMPUTED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,115) 115 FORMAT(' MUST BE LARGER THAN 0 AND SMALLER THAN 100.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,116) 116 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,117)P100 117 FORMAT(' THE INPUT PERCENTAGE HERE = ',E15.7) CALL DPWRST('XXX','BUG ') GOTO9000 119 CONTINUE C IF(1.LE.N.AND.N.LE.MAXNXT)GOTO129 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,121) 121 FORMAT('***** ERROR IN PERCEN--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,122) 122 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,123) 123 FORMAT(' IN THE VARIABLE FOR WHICH') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,124) 124 FORMAT(' THE PERCENTILE IS TO BE COMPUTED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,125)MAXNXT 125 FORMAT(' MUST BE BETWEEN 1 AND ',I8,' (INCLUSIVELY).') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,126) 126 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,127)N 127 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8, 1'.') CALL DPWRST('XXX','BUG ') GOTO9000 129 CONTINUE C IF(N.EQ.1)GOTO130 GOTO139 130 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,131) 131 FORMAT('***** NON-FATAL DIAGNOSTIC IN PERCEN--', 1'THE THIRD INPUT ARGUMENT (N) HAS THE VALUE 1') CALL DPWRST('XXX','BUG ') XPERC=X(1) GOTO9000 139 CONTINUE C HOLD=X(1) DO145I=2,N IF(X(I).NE.HOLD)GOTO149 145 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,146)HOLD 146 FORMAT('***** NON-FATAL DIAGNOSTIC IN PERCEN--', 1'THE 2ND INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7) CALL DPWRST('XXX','BUG ') XPERC=HOLD GOTO9000 149 CONTINUE C 190 CONTINUE C C *********************************** C ** STEP 2-- ** C ** COMPUTE THE PERCENTILE. ** C *********************************** C CALL SORT(X,N,XTEMP) C P=P100/100.0 C ANI=P*(AN+1.0) NI=ANI A2NI=NI REM=ANI-A2NI NIP1=NI+1 IF(NI.LE.1)NI=1 IF(NI.GE.N)NI=N IF(NIP1.LE.1)NIP1=1 IF(NIP1.GE.N)NIP1=N CCCCC BUG FIX. WEIGHTS IN WRONG ORDER! NOVEMBER 1998. CCCCC XPERC=REM*XTEMP(NI)+(1.0-REM)*XTEMP(NIP1) XPERC=(1.0-REM)*XTEMP(NI)+REM*XTEMP(NIP1) C C ******************************* C ** STEP 3-- ** C ** WRITE OUT A LINE ** C ** OF SUMMARY INFORMATION. ** C ******************************* C IF(IFEEDB.EQ.'OFF')GOTO890 IF(IWRITE.EQ.'OFF')GOTO890 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,811)P100,N,XPERC 811 FORMAT('THE ',F10.2,'-PERCENTILE OF THE ',I8, 1' OBSERVATIONS = ',E15.7) CALL DPWRST('XXX','BUG ') 890 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE IF(IBUGA3.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF PERCEN--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGA3,IERROR 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)P100,N,P 9013 FORMAT('P100,N,P = ',E15.7,I8,E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)ANI,NI,A2NI,REM,NIP1 9014 FORMAT('ANI,NI,A2NI,REM,NIP1 = ',E15.7,I8,E15.7,E15.7,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)XPERC 9015 FORMAT('XPERC = ',E15.7) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE PERDEF(X,N,ENGLSL,ENGUSL,IWRITE,XACTPD,XTHEPD, 1XACTL,XTHEL,XACTU,XTHEU, 1IFLAG,IBUGA3,IERROR) C C PURPOSE--THIS SUBROUTINE COMPUTES THE C ACTUAL PERCENT DEFECTIVE (XACTPD) AND C THOERETICAL PERCENT DEFECTIVE (XTHEPD) C FROM THE DATA IN THE INPUT VECTOR X. C THIS CALCULATION ASSUMES-- C 1) A NORMAL DISTRIBUTION C 2) WITH MEAN XBAR AND STANDARD DEVIATION S C 3) THE TARGET IS MIDWAY BETWEEN ENGUSL AND ENGLSL C XTHEPD = 100*(AREA UNDER NORMAL CURVE ABOVE USL AND BELOW LSL) C THE FINAL FORM FOR XTHEPD IS QUITE SIMPLE-- C XTHEPD = 100(1-(NORCDF(ZUPPER)-NORCDF(ZLOWER))) C WHERE ZUPPER = (ENGUSL-MU)/SIGMA C AND ZLOWER = (ENGLSL-MU)/SIGMA C IN PRACTICE, WE USE XBAR FOR MU AND S FOR SIGMA. C NOTE--XTHEPD IS A MEASURE OF PROCESS QUALITY AND IS C SENSITIVE TO LOSS OF QUALITY FROM BOTH BIAS AND FROM VARIATION. C NOTE--XTHEPD IS A MEASURE WHICH TAKES ON C THE VALUES 0% TO 100% C A GOOD PROCESS YIELDS VALUES OF C PERCENT DEFECTIVE NEAR 0%. C INPUT ARGUMENTS--X = THE SINGLE PRECISION VECTOR OF C (UNSORTED OR SORTED) OBSERVATIONS. C --N = THE INTEGER NUMBER OF OBSERVATIONS C IN THE VECTOR X. C --ENGLSL = LOWER (ENGINEERING) SPEC LIMIT C --ENGUSL = UPPER (ENGINEERING) SPEC LIMIT C --IFLAG = WRITE FLAG (THEO, ACTU, BOTH) C OUTPUT ARGUMENTS--PERDEF = THE SINGLE PRECISION VALUE OF THE C COMPUTED SAMPLE PERCENT DEFECTIVE C OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE C SAMPLE PERCENT DEFECTIVE (IN XTHEPD) C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C FORTRAN LIBRARY SUBROUTINES NEEDED--DSQRT. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION & SINGLE PRECISION C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--R&M 2000 AIR FORCE MANUAL C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--89.5 C ORIGINAL VERSION--MAY 1989. C UPDATED --SEPTEMBER 1990. REVERSE INPUT ARGS C UPDATED --APRIL 2001. ADD XACTL, XTHEL, XACTU, XTHEU C THESE ARE ONE SIDED LIMITS C (CAPABILITY ANALYSIS PRINTS C THEM) C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IWRITE CHARACTER*4 IFLAG CHARACTER*4 IBUGA3 CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C DOUBLE PRECISION DN DOUBLE PRECISION DX DOUBLE PRECISION DSUM DOUBLE PRECISION DMEAN DOUBLE PRECISION DVAR DOUBLE PRECISION DSD C DOUBLE PRECISION DUSL DOUBLE PRECISION DLSL C DIMENSION X(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='PERD' ISUBN2='EF ' C IERROR='NO' C DMEAN=0.0D0 C IF(IBUGA3.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF PERDEF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IFLAG,IBUGA3 52 FORMAT('IFLAG,IBUGA3 = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)N 53 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)ENGUSL,ENGLSL 54 FORMAT('ENGUSL,ENGLSL = ',2E15.7) CALL DPWRST('XXX','BUG ') DO55I=1,N WRITE(ICOUT,56)I,X(I) 56 FORMAT('I,X(I) = ',I8,E15.7) CALL DPWRST('XXX','BUG ') 55 CONTINUE 90 CONTINUE C C ******************************************** C ** COMPUTE PROCESS CAPABILITY INDEX PERDEF ** C ******************************************** C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C AN=N C IF(N.GE.1)GOTO119 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,111) 111 FORMAT('***** ERROR IN PERDEF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,112) 112 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,113) 113 FORMAT(' IN THE VARIABLE FOR WHICH') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,114) 114 FORMAT(' THE PERCENT DEFECTIVE IS TO BE COMPUTED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,115) 115 FORMAT(' MUST BE 1 OR LARGER.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,116) 116 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,117)N 117 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8, 1'.') CALL DPWRST('XXX','BUG ') GOTO9000 119 CONTINUE C IF(N.EQ.1)GOTO120 GOTO129 120 CONTINUE CCCCC WRITE(ICOUT,999) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,121) CC121 FORMAT('***** NON-FATAL DIAGNOSTIC IN PERDEF--', CCCCC1'THE SECOND INPUT ARGUMENT (N) HAS THE VALUE 1') CCCCC CALL DPWRST('XXX','BUG ') XSD=0.0 GOTO9000 129 CONTINUE C HOLD=X(1) DO135I=2,N IF(X(I).NE.HOLD)GOTO139 135 CONTINUE CCCCC WRITE(ICOUT,999) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,136)HOLD CC136 FORMAT('***** NON-FATAL DIAGNOSTIC IN PERDEF--', CCCCC1'THE FIRST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7) CCCCC CALL DPWRST('XXX','BUG ') XSD=0.0 GOTO9000 139 CONTINUE C 190 CONTINUE C C *************************************** C ** STEP 2-- ** C ** COMPUTE THE STANDARD DEVIATION. ** C *************************************** C DN=N DSUM=0.0D0 DO200I=1,N DX=X(I) DSUM=DSUM+DX 200 CONTINUE DMEAN=DSUM/DN C DSUM=0.0D0 DO300I=1,N DX=X(I) DSUM=DSUM+(DX-DMEAN)**2 300 CONTINUE DVAR=DSUM/(DN-1.0D0) DSD=0.0D0 IF(DVAR.GT.0.0D0)DSD=DSQRT(DVAR) XSD=DSD C C ************************************************** C ** STEP 3-- ** C ** COMPUTE THE ACTUAL PERCENT DEFECTIVE ** C ** COMPUTE THE THEORETICAL PERCENT DEFECTIVE ** C ************************************************** C DUSL=ENGUSL DLSL=ENGLSL C IF(DSD.EQ.0.0D0)GOTO410 GOTO420 C 410 CONTINUE XTHEPD=0.0 IF(DMEAN.GT.DUSL)XTHEPD=100.0 IF(DMEAN.LT.DLSL)XTHEPD=100.0 GOTO490 C 420 CONTINUE ZUPPER=(DUSL-DMEAN)/DSD ZLOWER=(DLSL-DMEAN)/DSD CALL NORCDF(ZUPPER,CDFUPP) CALL NORCDF(ZLOWER,CDFLOW) XTHEPD=100.0*(1.0-(CDFUPP-CDFLOW)) XTHEL=100.0*(CDFLOW) XTHEU=100.0*(1.0-CDFUPP) C 490 CONTINUE C XACTPD=0.0 XACTL=0.0 XACTU=0.0 ICOUNT=0 DO510I=1,N IF(X(I).LT.ENGLSL.OR.X(I).GT.ENGUSL)ICOUNT=ICOUNT+1 IF(X(I).LT.ENGLSL)XACTL=XACTL+1.0 IF(X(I).GT.ENGUSL)XACTU=XACTU+1.0 510 CONTINUE ACOUNT=ICOUNT IF(AN.NE.0.0)XACTPD=100.0*(ACOUNT/AN) IF(AN.NE.0.0)XACTL=100.0*(XACTL/AN) IF(AN.NE.0.0)XACTU=100.0*(XACTU/AN) C C ******************************* C ** STEP 3-- ** C ** WRITE OUT A LINE ** C ** OF SUMMARY INFORMATION. ** C ******************************* C IF(IFEEDB.EQ.'OFF')GOTO890 IF(IWRITE.EQ.'OFF')GOTO890 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IF(IFLAG.EQ.'THEO'.OR.IFLAG.EQ.'BOTH') 1WRITE(ICOUT,811)N,XTHEPD 811 FORMAT('THE (THEORETICAL) PERCENT DEFECTIVE OF THE ',I8, 1' OBSERVATIONS = ',E15.7) IF(IFLAG.EQ.'THEO'.OR.IFLAG.EQ.'BOTH') 1CALL DPWRST('XXX','BUG ') IF(IFLAG.EQ.'ACTU'.OR.IFLAG.EQ.'BOTH') 1WRITE(ICOUT,812)N,XACTPD 812 FORMAT('THE (ACTUAL ) PERCENT DEFECTIVE OF THE ',I8, 1' OBSERVATIONS = ',E15.7) IF(IFLAG.EQ.'ACTU'.OR.IFLAG.EQ.'BOTH') 1CALL DPWRST('XXX','BUG ') 890 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE IF(IBUGA3.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF PERDEF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IFLAG,IBUGA3,IERROR 9012 FORMAT('IFLAG,IBUGA3,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)N 9013 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)DMEAN 9014 FORMAT('DMEAN = ',D15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)DSD 9015 FORMAT('DSD = ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9016)DUSL,DLSL 9016 FORMAT('DUSL,DLSL = ',2D15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9017)ZUPPER,ZLOWER,CDFUPP,CDFLOW,XTHEPD 9017 FORMAT('ZUPPER,ZLOWER,CDFUPP,CDFLOW,XTHEPD = ',5E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9021)ENGLSL,ENGUSL,ACOUNT,AN 9021 FORMAT('ENGLSL,ENGUSL,ACOUNT,AN = ',4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9022)XACTPD,XTHEPD 9022 FORMAT('XACTPD,XTHEPD = ',2E15.7) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE PEXCDF(X,ALPHA,BETA,CDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION C FUNCTION VALUE FOR THE EXPONENTIAL POWER DISTRIBUTION C WITH SHAPE PARAMETERS ALPHA AND BETA. C THIS DISTRIBUTION IS DEFINED FOR ALL NON-NEGATIVE X, C AND HAS THE CUMULATIVE DISTRIBUTION FUNCTION C F(X) = 1-EXP(1-EXP((X/ALPHA)**B)) C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE AT C WHICH THE CUMULATIVE DISTRIBUTION C FUNCTION IS TO BE EVALUATED. C OUTPUT ARGUMENTS--CDF = THE SINGLE PRECISION CUMULATIVE C DISTRIBUTION FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION C FUNCTION VALUE CDF. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--X SHOULD BE NON-NEGATIVE. C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--EXP. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN. C REFERENCES--JOHNSON, KOTZ, AND BALKRISHNAN, CONTINUOUS UNIVARIATE C DISTRIBUTIONS--2, 2ND ED 1994, PAGES 643-644. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING LABORATORY (205.03) C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE: 301-975-2855 C ORIGINAL VERSION--DECEMBER 1995. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DX DOUBLE PRECISION DALPHA DOUBLE PRECISION DBETA DOUBLE PRECISION DCDF DOUBLE PRECISION DTERM1, DTERM2, DTERM3 C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C--------------------------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(X.LT.0.0)THEN WRITE(ICOUT,4) CALL DPWRST('XXX','BUG') WRITE(ICOUT,5) CALL DPWRST('XXX','BUG') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG') CDF=0.0 GOTO9999 ENDIF IF(ALPHA.LE.0.0)THEN WRITE(ICOUT,14) CALL DPWRST('XXX','BUG') WRITE(ICOUT,15) CALL DPWRST('XXX','BUG') WRITE(ICOUT,46)ALPHA CALL DPWRST('XXX','BUG') CDF=0.0 GOTO9999 ENDIF IF(BETA.LE.0.0)THEN WRITE(ICOUT,24) CALL DPWRST('XXX','BUG') WRITE(ICOUT,25) CALL DPWRST('XXX','BUG') WRITE(ICOUT,46)BETA CALL DPWRST('XXX','BUG') CDF=0.0 GOTO9999 ENDIF 4 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO') 5 FORMAT(' THE PEXCDF SUBROUTINE IS NEGATIVE *****') 14 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO') 15 FORMAT(' THE PEXCDF SUBROUTINE IS ZERO OR NEGATIVE *****') 24 FORMAT('***** ERROR--THE THIRD INPUT ARGUMENT TO') 25 FORMAT(' THE PEXCDF SUBROUTINE IS ZERo OR NEGATIVE *****') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') C C-----START POINT----------------------------------------------------- C DALPHA=DBLE(ALPHA) DBETA=DBLE(BETA) DX=DBLE(X) C IF(DX.LE.0.000000001D0)THEN CDF=0.0 GOTO9999 ENDIF C DTERM1=DBETA*DLOG(DX/DALPHA) IF(DTERM1.GE.80.D0)THEN CDF=1.0 GOTO9999 ELSE DTERM2=DEXP(DTERM1) IF(DTERM2.GE.80.D0)THEN CDF=1.0 GOTO9999 ELSEIF(DTERM2.LE.-80.D0)THEN CDF=0.0 GOTO9999 ELSE DTERM3=1.0D0-DEXP(DTERM2) ENDIF ENDIF DCDF=1.0D0-DEXP(DTERM3) CDF=SNGL(DCDF) C 9999 CONTINUE RETURN END SUBROUTINE PEXCHA(X,ALPHA,BETA,HAZ) C C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE HAZARD C FUNCTION VALUE FOR THE EXPONENTIAL POWER DISTRIBUTION C WITH SHAPE PARAMETERS ALPHA AND BETA. C THIS DISTRIBUTION IS DEFINED FOR ALL NON-NEGATIVE X, C AND HAS THE PROBABILITY DENSITY FUNCTION C F(X) = (E*BETA/(ALPHA**BETA))*X**(BETA-1)* C EXP((X/ALPHA)**BETA)*EXP(-EXP((X/ALPHA)**BETA)) C AND HAZARD FUNCTION C H(X)=(1/ALPHA)*BETA*X**(X-1)*EXP((1/ALPHA)*X**BETA) C AND CUMULATIVE HAZARD FUNCTION C H(X)=EXP((X/ALPHA)**BETA) - 1. C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE AT C WHICH THE CUMULATIVE HAZARD C FUNCTION IS TO BE EVALUATED. C OUTPUT ARGUMENTS--HAZ = THE SINGLE PRECISION CUMULATIVE C HAZARD FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION CUMULATIVE HAZARD C FUNCTION VALUE HAZ. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--X SHOULD BE NON-NEGATIVE. C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--EXP. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN. C REFERENCES--JOHNSON, KOTZ, AND BALKRISHNAN, CONTINUOUS UNIVARIATE C DISTRIBUTIONS--2, 2ND ED 1994, PAGES 643-644. C SMITH AND BAIN, "AN EXPONENTIAL POWER LIFE-TESTING C DISTRIBUTION", COMMUNICATIONS IN STATISITCS, 1975, C PP. 469-481. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING LABORATORY (205.03) C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE: 301-975-2855 C ORIGINAL VERSION--APRIL 1998. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C DOUBLE PRECISION DX DOUBLE PRECISION DALPHA DOUBLE PRECISION DBETA DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 DOUBLE PRECISION DHAZ C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C--------------------------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(X.LT.0.0)THEN WRITE(ICOUT,4) CALL DPWRST('XXX','BUG') WRITE(ICOUT,5) CALL DPWRST('XXX','BUG') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG') HAZ=0.0 GOTO9999 ENDIF IF(ALPHA.LE.0.0)THEN WRITE(ICOUT,14) CALL DPWRST('XXX','BUG') WRITE(ICOUT,15) CALL DPWRST('XXX','BUG') WRITE(ICOUT,46)ALPHA CALL DPWRST('XXX','BUG') HAZ=0.0 GOTO9999 ENDIF IF(BETA.LE.0.0)THEN WRITE(ICOUT,24) CALL DPWRST('XXX','BUG') WRITE(ICOUT,25) CALL DPWRST('XXX','BUG') WRITE(ICOUT,46)BETA CALL DPWRST('XXX','BUG') HAZ=0.0 GOTO9999 ENDIF 4 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO') 5 FORMAT(' THE PEXCHA SUBROUTINE IS NEGATIVE *****') 14 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO') 15 FORMAT(' THE PEXCHA SUBROUTINE IS ZERO OR NEGATIVE *****') 24 FORMAT('***** ERROR--THE THIRD INPUT ARGUMENT TO') 25 FORMAT(' THE PEXCHA SUBROUTINE IS ZERO OR NEGATIVE *****') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') C C-----START POINT----------------------------------------------------- C DALPHA=DBLE(ALPHA) DBETA=DBLE(BETA) DX=DBLE(X) C IF(DX.LE.0.000000001D0)THEN HAZ=0.0 GOTO9999 ELSE C DTERM1=DBETA*DLOG(DX/DALPHA) IF(DTERM1.GE.80.D0)THEN HAZ=0.0 WRITE(ICOUT,101) CALL DPWRST('XXX','BUG') GOTO9999 ELSE DTERM2=DEXP(DTERM1) IF(DTERM2.GE.80.D0)THEN HAZ=0.0 WRITE(ICOUT,101) CALL DPWRST('XXX','BUG') GOTO9999 ELSEIF(DTERM2.LE.-25.D0)THEN HAZ=0.0 GOTO9999 ELSE DHAZ=-(1.0D0 - DEXP(DTERM2)) HAZ=REAL(DHAZ) ENDIF ENDIF ENDIF 101 FORMAT('***** ERROR--FOR X = ',E15.7,' THE CDF IS ESSENTIALLY', 1' 1.') C 9999 CONTINUE RETURN END SUBROUTINE PEXHAZ(X,ALPHA,BETA,HAZ) C C PURPOSE--THIS SUBROUTINE COMPUTES THE HAZARD C FUNCTION VALUE FOR THE EXPONENTIAL POWER DISTRIBUTION C WITH SHAPE PARAMETERS ALPHA AND BETA. C THIS DISTRIBUTION IS DEFINED FOR ALL NON-NEGATIVE X, C AND HAS THE PROBABILITY DENSITY FUNCTION C F(X) = (E*BETA/(ALPHA**BETA))*X**(BETA-1)* C EXP((X/ALPHA)**BETA)*EXP(-EXP((X/ALPHA)**BETA)) C AND HAZARD FUNCTION C H(X)=ALPHA*BETA*X**(X-1)*EXP(ALPHA*X**BETA) C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE AT C WHICH THE HAZARD C FUNCTION IS TO BE EVALUATED. C OUTPUT ARGUMENTS--HAZ = THE SINGLE PRECISION C HAZARD FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION HAZARD C FUNCTION VALUE HAZ. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--X SHOULD BE NON-NEGATIVE. C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--EXP. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN. C REFERENCES--JOHNSON, KOTZ, AND BALKRISHNAN, CONTINUOUS UNIVARIATE C DISTRIBUTIONS--2, 2ND ED 1994, PAGES 643-644. C SMITH AND BAIN, "AN EXPONENTIAL POWER LIFE-TESTING C DISTRIBUTION", COMMUNICATIONS IN STATISITCS, 1975, C PP. 469-481. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING LABORATORY (205.03) C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE: 301-975-2855 C ORIGINAL VERSION--APRIL 1998. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DX DOUBLE PRECISION DALPHA DOUBLE PRECISION DBETA DOUBLE PRECISION DTERM1, DTERM2, DTERM3, DTERM4, DTERM5 C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C--------------------------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(X.LT.0.0)THEN WRITE(ICOUT,4) CALL DPWRST('XXX','BUG') WRITE(ICOUT,5) CALL DPWRST('XXX','BUG') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG') HAZ=0.0 GOTO9999 ENDIF IF(ALPHA.LE.0.0)THEN WRITE(ICOUT,14) CALL DPWRST('XXX','BUG') WRITE(ICOUT,15) CALL DPWRST('XXX','BUG') WRITE(ICOUT,46)ALPHA CALL DPWRST('XXX','BUG') HAZ=0.0 GOTO9999 ENDIF IF(BETA.LE.0.0)THEN WRITE(ICOUT,24) CALL DPWRST('XXX','BUG') WRITE(ICOUT,25) CALL DPWRST('XXX','BUG') WRITE(ICOUT,46)BETA CALL DPWRST('XXX','BUG') HAZ=0.0 GOTO9999 ENDIF 4 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO') 5 FORMAT(' THE PEXHAZ SUBROUTINE IS NEGATIVE *****') 14 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO') 15 FORMAT(' THE PEXHAZ SUBROUTINE IS ZERO OR NEGATIVE *****') 24 FORMAT('***** ERROR--THE THIRD INPUT ARGUMENT TO') 25 FORMAT(' THE PEXHAZ SUBROUTINE IS ZERO OR NEGATIVE *****') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') C C-----START POINT----------------------------------------------------- C DALPHA=DBLE(1.0/ALPHA) DBETA=DBLE(BETA) DX=DBLE(X) C DTERM1=DLOG(DALPHA) DTERM2=DLOG(DBETA) DTERM3=(DBETA-1.0D0)*DLOG(DALPHA*DX) DTERM4=(DALPHA*DX)**DBETA DTERM5=DTERM1+DTERM2+DTERM3+DTERM4 IF(DTERM5.LE.-80.D0)THEN HAZ=0.0 ELSEIF(DTERM5.GE.80.D0)THEN HAZ=0.0 WRITE(ICOUT,101) CALL DPWRST('XXX','BUG') WRITE(ICOUT,47)X CALL DPWRST('XXX','BUG') WRITE(ICOUT,48)ALPHA CALL DPWRST('XXX','BUG') WRITE(ICOUT,49)BETA CALL DPWRST('XXX','BUG') ELSE DTERM1=DEXP(DTERM5) HAZ=SNGL(DTERM1) ENDIF 101 FORMAT('***** WARNING--THE PEXHAZ ROUTINE OVERFLOWS. HAZ SET', 1'TO 0.') 47 FORMAT('***** THE VALUE OF THE FIRST ARGUMENT IS ', 1E15.8,' *****') 48 FORMAT('***** THE VALUE OF THE SECOND ARGUMENT IS ', 1E15.8,' *****') 49 FORMAT('***** THE VALUE OF THE THIRD ARGUMENT IS ', 1E15.8,' *****') C 9999 CONTINUE RETURN END SUBROUTINE PEXPDF(X,ALPHA,BETA,PDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY C FUNCTION VALUE FOR THE EXPONENTIAL POWER DISTRIBUTION C WITH SHAPE PARAMETERS ALPHA AND BETA. C THIS DISTRIBUTION IS DEFINED FOR ALL NON-NEGATIVE X, C AND HAS THE PROBABILITY DENSITY FUNCTION C F(X) = (E*BETA/(ALPHA**BETA))*X**(BETA-1)* C EXP((X/ALPHA)**BETA)*EXP(-EXP((X/ALPHA)**BETA)) C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE AT C WHICH THE PROBABILITY DENSITY C FUNCTION IS TO BE EVALUATED. C OUTPUT ARGUMENTS--PDF = THE SINGLE PRECISION CUMULATIVE C DISTRIBUTION FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY C FUNCTION VALUE PDF. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--X SHOULD BE NON-NEGATIVE. C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--EXP. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN. C REFERENCES--JOHNSON, KOTZ, AND BALKRISHNAN, CONTINUOUS UNIVARIATE C DISTRIBUTIONS--2, 2ND ED 1994, PAGES 643-644. C SMITH AND BAIN, "AN EXPONENTIAL POWER LIFE-TESTING C DISTRIBUTION", COMMUNICATIONS IN STATISITCS, 1975, C PP. 469-481. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING LABORATORY (205.03) C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE: 301-975-2855 C ORIGINAL VERSION--DECEMBER 1995. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DX DOUBLE PRECISION DALPHA DOUBLE PRECISION DBETA DOUBLE PRECISION DPDF DOUBLE PRECISION DTERM1, DTERM2, DTERM3, DTERM4, DTERM5 C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C--------------------------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(X.LT.0.0)THEN WRITE(ICOUT,4) CALL DPWRST('XXX','BUG') WRITE(ICOUT,5) CALL DPWRST('XXX','BUG') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG') PDF=0.0 GOTO9999 ENDIF IF(ALPHA.LE.0.0)THEN WRITE(ICOUT,14) CALL DPWRST('XXX','BUG') WRITE(ICOUT,15) CALL DPWRST('XXX','BUG') WRITE(ICOUT,46)ALPHA CALL DPWRST('XXX','BUG') PDF=0.0 GOTO9999 ENDIF IF(BETA.LE.0.0)THEN WRITE(ICOUT,24) CALL DPWRST('XXX','BUG') WRITE(ICOUT,25) CALL DPWRST('XXX','BUG') WRITE(ICOUT,46)BETA CALL DPWRST('XXX','BUG') PDF=0.0 GOTO9999 ENDIF 4 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO') 5 FORMAT(' THE PEXPDF SUBROUTINE IS NEGATIVE *****') 14 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO') 15 FORMAT(' THE PEXPDF SUBROUTINE IS ZERO OR NEGATIVE *****') 24 FORMAT('***** ERROR--THE THIRD INPUT ARGUMENT TO') 25 FORMAT(' THE PEXPDF SUBROUTINE IS ZERO OR NEGATIVE *****') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') C C-----START POINT----------------------------------------------------- C DALPHA=DBLE(ALPHA) DBETA=DBLE(BETA) DX=DBLE(X) C IF(DX.LE.0.000000000001D0)DX=0.00000000001D0 DTERM1=DLOG(DEXP(1.0D0)) + DLOG(DBETA) - DBETA*DLOG(DALPHA) DTERM2=(DBETA-1.0D0)*DLOG(DX) DTERM3=(DX/DALPHA)**DBETA DTERM4=EXP((DX/DALPHA)**DBETA) DTERM5=DTERM1+DTERM2+DTERM3-DTERM4 IF(DTERM5.LE.-80.D0)THEN PDF=0.0 ELSEIF(DTERM5.GE.80.D0)THEN WRITE(ICOUT,101) CALL DPWRST('XXX','BUG') WRITE(ICOUT,47)X CALL DPWRST('XXX','BUG') WRITE(ICOUT,48)ALPHA CALL DPWRST('XXX','BUG') WRITE(ICOUT,49)BETA CALL DPWRST('XXX','BUG') ELSE DPDF=DEXP(DTERM5) PDF=SNGL(DPDF) ENDIF 101 FORMAT('***** WARNING--THE PEXPDF ROUTINE OVERFLOWS. PDF SET', 1'TO LOG OF LARGEST MACHINE VALUE.') 47 FORMAT('***** THE VALUE OF THE FIRST ARGUMENT IS ', 1E15.8,' *****') 48 FORMAT('***** THE VALUE OF THE SECOND ARGUMENT IS ', 1E15.8,' *****') 49 FORMAT('***** THE VALUE OF THE THIRD ARGUMENT IS ', 1E15.8,' *****') C 9999 CONTINUE RETURN END SUBROUTINE PEXPPF(P,ALPHA,BETA,PPF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT C FUNCTION VALUE FOR THE EXPONENTIAL POWER DISTRIBUTION C WITH SHAPE PARAMETERS ALPHA AND BETA. C THIS DISTRIBUTION IS DEFINED FOR ALL NON-NEGATIVE X, C AND HAS THE CUMULATIVE DISTRIBUTION FUNCTION C F(X) = 1-EXP(1-EXP((X/ALPHA)**B)) C INPUT ARGUMENTS--P = THE SINGLE PRECISION VALUE C (BETWEEN 0.0 AND 1.0) C AT WHICH THE PERCENT POINT C FUNCTION IS TO BE EVALUATED. C OUTPUT ARGUMENTS--PPF = THE SINGLE PRECISION PERCENT C POINT FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION PERCENT POINT C FUNCTION VALUE PPF. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--P SHOULD BE BETWEEN 0.0 (INCLUSIVELY) C AND 1.0 (EXCLUSIVELY). C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--ALOG. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--JOHNSON, KOTZ, AND BALKRISHNAN, CONTINUOUS UNIVARIATE C DISTRIBUTIONS--2, 2ND ED 1994, PAGES 643-644. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING LABORATORY (205.03) C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE: 301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--96/1 C ORIGINAL VERSION--JANUARY 1996. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DP DOUBLE PRECISION DALPHA DOUBLE PRECISION DBETA DOUBLE PRECISION DPPF C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(P.LT.0.0.OR.P.GE.1.0)THEN WRITE(ICOUT,1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)P CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF IF(ALPHA.LE.0.0)THEN WRITE(ICOUT,14) CALL DPWRST('XXX','BUG') WRITE(ICOUT,15) CALL DPWRST('XXX','BUG') WRITE(ICOUT,46)ALPHA CALL DPWRST('XXX','BUG') CDF=0.0 GOTO9999 ENDIF IF(BETA.LE.0.0)THEN WRITE(ICOUT,24) CALL DPWRST('XXX','BUG') WRITE(ICOUT,25) CALL DPWRST('XXX','BUG') WRITE(ICOUT,46)BETA CALL DPWRST('XXX','BUG') CDF=0.0 GOTO9999 ENDIF 1 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ', 1'PEXPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL') 14 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO') 15 FORMAT(' THE PEXPPF SUBROUTINE IS ZERO OR NEGATIVE *****') 24 FORMAT('***** ERROR--THE THIRD INPUT ARGUMENT TO') 25 FORMAT(' THE PEXPPF SUBROUTINE IS ZERO OR NEGATIVE *****') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') C IF(P.EQ.0.0)THEN PPF=0.0 GOTO9999 ENDIF C DALPHA=DBLE(ALPHA) DBETA=DBLE(BETA) DP=DBLE(P) C DPPF=DALPHA*DLOG(1.0D0-DLOG(1.0D0-DP))**(1.0D0/DBETA) PPF=SNGL(DPPF) C 9999 CONTINUE RETURN END SUBROUTINE PEXRAN(N,ALPHA,BETA,ISEED,X) C C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N C FROM THE POWER EXPONENTIAL DISTRIBUTION C WITH SHAPE PARAMETER VALUES = ALPHA, BETA. C INPUT ARGUMENTS--N = THE DESIRED INTEGER NUMBER C OF RANDOM NUMBERS TO BE C GENERATED. C --ALPHA = THE SINGLE PRECISION VALUE OF THE C FIRST SHAPE PARAMETER. C ALPHA SHOULD BE POSITIVE. C --BETA = THE SINGLE PRECISION VALUE OF THE C SECOND SHAPE PARAMETER. C BETA SHOULD BE POSITIVE. C OUTPUT ARGUMENTS--X = A SINGLE PRECISION VECTOR C (OF DIMENSION AT LEAST N) C INTO WHICH THE GENERATED C RANDOM SAMPLE WILL BE PLACED. C OUTPUT--A RANDOM SAMPLE OF SIZE N C FROM THE POWER EXPONENTIAL DISTRIBUTION C WITH SHAPE PARAMETER VALUES = ALPHA AND BETA. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C --ALPHA SHOULD BE POSITIVE. C OTHER DATAPAC SUBROUTINES NEEDED--UNIRAN. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2001.10 C ORIGINAL VERSION--OCTOBER 2001. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DIMENSION X(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(N.LT.1)THEN WRITE(ICOUT, 5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)N CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF 5 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ', 1'PEXRAN SUBROUTINE IS NON-POSITIVE *****') 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****') C C GENERATE N UNIFORM (0,1) RANDOM NUMBERS; C CALL UNIRAN(N,ISEED,X) C C GENERATE N POWER EXPONENTIAL DISTRIBUTION RANDOM NUMBERS C USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD. C DO100I=1,N CALL PEXPPF(X(I),ALPHA,BETA,XTEMP) X(I)=XTEMP 100 CONTINUE C 9000 CONTINUE RETURN END SUBROUTINE PHASMP(A,ZINV,K,PP,QQ) C THIS ROUTINE DOES PHASE-AMPLITUDE CALCULATIONS FOR BESSEL FUNCTIONS. C A IS THE ORDER OF THE FUNCTION, AT MOST 1 IN ABSOLUTE VALUE. ZINV IS C 2./Z, WHERE Z IS THE ARGUMENT. TO ACHIEVE 14 FIGURES ACCURACY, ABS(Z) C MUST BE AT LEAST 14, OR A MUST BE .5 OR -.5. IF K=0, PHASMP RETURNS C PP AND QQ FOR EQUATIONS 9.2.5 TO 9.2.8 OF REFERENCE (1) LISTED IN C BESJCF. IF K=1 (-1) PHASMP RETURNS PP FOR EQUATION 9.7.2 (9.7.1). C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOMC.INC' CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C COMPLEX PP,QQ,ZI,ZINV,TERM(25),ZDUMMY C----------------------------------------------------------------------- C C MACHINE DEPENDENT CONSTANTS. C --------------------------- C SAVE ISAVE, DYOUK DATA ISAVE /1/ DATA TERM(1)/(1.,0.)/ C C Definition of real and imaginary parts of complex number, C standard Fortran and will work on Convex with -r8 -i8. REALP(ZDUMMY) = REAL(ZDUMMY) AIMAGP(ZDUMMY) = REAL((0,-1)*ZDUMMY) C IF (ISAVE.GT.0) THEN ISAVE = 0 DYOUK = R1MACH (4) ENDIF C C----------------------------------------------------------------------- ZI=.0625*ZINV S=K IF(K.EQ.0) S=-1. C=(DBLE(2.*A))**2-1.D0 DO 1 N=1,24 IF(K.EQ.0) S=-S TERM(N+1)=TERM(N)*ZI*(S*(C/REAL(N)+REAL(4-4*N))) IF(MAX(ABS(REALP(TERM(N+1))),ABS(AIMAGP(TERM(N+1)))).LE.DYOUK) 1 GO TO 2 1 CONTINUE N=25 2 PP = (0.0, 0.0) QQ = (0.0, 0.0) IF ((K .NE. 0) .OR. (MOD (N, 2) .NE. 0)) GO TO 4 3 QQ=QQ+TERM(N) N=N-1 4 PP=PP+TERM(N) N=N-1 IF(N.EQ.0) RETURN IF(K) 4,3,4 END DOUBLE PRECISION FUNCTION PHI(Z) * * Normal distribution probabilities accurate to 1.e-15. * Z = no. of standard deviations from the mean. * * Based upon algorithm 5666 for the error function, from: * Hart, J.F. et al, 'Computer Approximations', Wiley 1968 * * Programmer: Alan Miller * * Latest revision - 30 March 1986 * DOUBLE PRECISION P0, P1, P2, P3, P4, P5, P6, & Q0, Q1, Q2, Q3, Q4, Q5, Q6, Q7, & Z, P, EXPNTL, CUTOFF, ROOTPI, ZABS PARAMETER( & P0 = 220.20 68679 12376 1D0, & P1 = 221.21 35961 69931 1D0, & P2 = 112.07 92914 97870 9D0, & P3 = 33.912 86607 83830 0D0, & P4 = 6.3739 62203 53165 0D0, & P5 = .70038 30644 43688 1D0, & P6 = .035262 49659 98910 9D0) PARAMETER( & Q0 = 440.41 37358 24752 2D0, & Q1 = 793.82 65125 19948 4D0, & Q2 = 637.33 36333 78831 1D0, & Q3 = 296.56 42487 79673 7D0, & Q4 = 86.780 73220 29460 8D0, & Q5 = 16.064 17757 92069 5D0, & Q6 = 1.7556 67163 18264 2D0, & Q7 = .088388 34764 83184 4D0) PARAMETER(ROOTPI = 2.5066 28274 63100 1D0) PARAMETER(CUTOFF = 7.0710 67811 86547 5D0) * ZABS = ABS(Z) * * |Z| > 37 * IF (ZABS .GT. 37) THEN P = 0 ELSE * * |Z| <= 37 * EXPNTL = EXP(-ZABS**2/2) * * |Z| < CUTOFF = 10/SQRT(2) * IF (ZABS .LT. CUTOFF) THEN P = EXPNTL*((((((P6*ZABS + P5)*ZABS + P4)*ZABS + P3)*ZABS & + P2)*ZABS + P1)*ZABS + P0)/(((((((Q7*ZABS + Q6)*ZABS & + Q5)*ZABS + Q4)*ZABS + Q3)*ZABS + Q2)*ZABS + Q1)*ZABS & + Q0) * * |Z| >= CUTOFF. * ELSE P = EXPNTL/(ZABS + 1/(ZABS + 2/(ZABS + 3/(ZABS + 4/ & (ZABS + 0.65D0)))))/ROOTPI END IF END IF IF (Z .GT. 0) P = 1 - P PHI = P C RETURN END DOUBLE PRECISION FUNCTION PHINV(P) * * ALGORITHM AS241 APPL. STATIST. (1988) VOL. 37, NO. 3 * * Produces the normal deviate Z corresponding to a given lower * tail area of P. * * The hash sums below are the sums of the mantissas of the * coefficients. They are included for use in checking * transcription. * DOUBLE PRECISION SPLIT1, SPLIT2, CONST1, CONST2, & A0, A1, A2, A3, A4, A5, A6, A7, B1, B2, B3, B4, B5, B6, B7, & C0, C1, C2, C3, C4, C5, C6, C7, D1, D2, D3, D4, D5, D6, D7, & E0, E1, E2, E3, E4, E5, E6, E7, F1, F2, F3, F4, F5, F6, F7, & P, Q, R PARAMETER (SPLIT1 = 0.425, SPLIT2 = 5, & CONST1 = 0.180625D0, CONST2 = 1.6D0) * * Coefficients for P close to 0.5 * PARAMETER ( & A0 = 3.38713 28727 96366 6080D0, & A1 = 1.33141 66789 17843 7745D+2, & A2 = 1.97159 09503 06551 4427D+3, & A3 = 1.37316 93765 50946 1125D+4, & A4 = 4.59219 53931 54987 1457D+4, & A5 = 6.72657 70927 00870 0853D+4, & A6 = 3.34305 75583 58812 8105D+4, & A7 = 2.50908 09287 30122 6727D+3, & B1 = 4.23133 30701 60091 1252D+1, & B2 = 6.87187 00749 20579 0830D+2, & B3 = 5.39419 60214 24751 1077D+3, & B4 = 2.12137 94301 58659 5867D+4, & B5 = 3.93078 95800 09271 0610D+4, & B6 = 2.87290 85735 72194 2674D+4, & B7 = 5.22649 52788 52854 5610D+3) * HASH SUM AB 55.88319 28806 14901 4439 * * Coefficients for P not close to 0, 0.5 or 1. * PARAMETER ( & C0 = 1.42343 71107 49683 57734D0, & C1 = 4.63033 78461 56545 29590D0, & C2 = 5.76949 72214 60691 40550D0, & C3 = 3.64784 83247 63204 60504D0, & C4 = 1.27045 82524 52368 38258D0, & C5 = 2.41780 72517 74506 11770D-1, & C6 = 2.27238 44989 26918 45833D-2, & C7 = 7.74545 01427 83414 07640D-4, & D1 = 2.05319 16266 37758 82187D0, & D2 = 1.67638 48301 83803 84940D0, & D3 = 6.89767 33498 51000 04550D-1, & D4 = 1.48103 97642 74800 74590D-1, & D5 = 1.51986 66563 61645 71966D-2, & D6 = 5.47593 80849 95344 94600D-4, & D7 = 1.05075 00716 44416 84324D-9) * HASH SUM CD 49.33206 50330 16102 89036 * * Coefficients for P near 0 or 1. * PARAMETER ( & E0 = 6.65790 46435 01103 77720D0, & E1 = 5.46378 49111 64114 36990D0, & E2 = 1.78482 65399 17291 33580D0, & E3 = 2.96560 57182 85048 91230D-1, & E4 = 2.65321 89526 57612 30930D-2, & E5 = 1.24266 09473 88078 43860D-3, & E6 = 2.71155 55687 43487 57815D-5, & E7 = 2.01033 43992 92288 13265D-7, & F1 = 5.99832 20655 58879 37690D-1, & F2 = 1.36929 88092 27358 05310D-1, & F3 = 1.48753 61290 85061 48525D-2, & F4 = 7.86869 13114 56132 59100D-4, & F5 = 1.84631 83175 10054 68180D-5, & F6 = 1.42151 17583 16445 88870D-7, & F7 = 2.04426 31033 89939 78564D-15) * HASH SUM EF 47.52583 31754 92896 71629 * Q = ( 2*P - 1 )/2 IF ( ABS(Q) .LE. SPLIT1 ) THEN R = CONST1 - Q*Q PHINV = Q*(((((((A7*R + A6)*R + A5)*R + A4)*R + A3) & *R + A2)*R + A1)*R + A0) / & (((((((B7*R + B6)*R + B5)*R + B4)*R + B3) & *R + B2)*R + B1)*R + 1) ELSE R = MIN( P, 1 - P ) IF (R .GT. 0) THEN R = SQRT( -LOG(R) ) IF ( R .LE. SPLIT2 ) THEN R = R - CONST2 PHINV = (((((((C7*R + C6)*R + C5)*R + C4)*R + C3) & *R + C2)*R + C1)*R + C0) / & (((((((D7*R + D6)*R + D5)*R + D4)*R + D3) & *R + D2)*R + D1)*R + 1) ELSE R = R - SPLIT2 PHINV = (((((((E7*R + E6)*R + E5)*R + E4)*R + E3) & *R + E2)*R + E1)*R + E0) / & (((((((F7*R + F6)*R + F5)*R + F4)*R + F3) & *R + F2)*R + F1)*R + 1) END IF ELSE PHINV = 9 END IF IF ( Q .LT. 0 ) PHINV = - PHINV END IF C RETURN END SUBROUTINE PIGPDF(X,THETA,ALPHA,PDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY MASS C FUNCTION VALUE AT THE DOUBLE PRECISION VALUE X C FOR THE POISSON-INVERSE GAUSSIAN DISTRIBUTION C WITH DOUBLE PRECISION SHAPE PARAMETERS ALPHA AND C THETA. THIS DISTRIBUTION IS DEFINED FOR ALL C NON-NEGATIVE INTEGER X = 0, 1, 2, ... C THIS DISTRIBUTION HAS THE PROBABILITY FUNCTION C p(X;ALPHA,THETA) = SQRT(2*ALPHA/PI)* C EXP(ALPHA*SQRT(1-THETA))*(ALPHA*THETA/2)**X* C K(X-1/2)(ALPHA)/X! C ALPHA > 0; 0 < THETA < 1 C K(V) IS THE MODIFIED BESSEL FUNCTION C INPUT ARGUMENTS--X = THE DOUBLE PRECISION VALUE C AT WHICH THE PROBABILITY DENSITY C FUNCTION IS TO BE EVALUATED. C X SHOULD BE A NON-NEGATIVE INTEGR C --ALPHA = THE DOUBLE PRECISION VALUE C OF THE FIRST SHAPE PARAMETER. C --THETA = THE DOUBLE PRECISION VALUE C OF THE SECOND SHAPE PARAMETER. C OUTPUT ARGUMENTS--PDF = THE DOUBLE PRECISION PROBABILITY C MASS FUNCTION VALUE C OUTPUT--THE DOUBLE PRECISION PROBABILITY MASS C FUNCTION VALUE PDF C FOR THE POISSON-INVERSE GAUSSIAN DISTRIBUTION C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--X SHOULD BE A NON-NEGATIVE INTEGER C --0 < THETA < 1, AND ALPHA > 0 C OTHER DATAPAC SUBROUTINES NEEDED--LNGAMM, DBESK. C FORTRAN LIBRARY SUBROUTINES NEEDED--DEXP, DLOG C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--JOHNSON, KOTZ, AND KEMP (1992). "UNIVARIATE C DISCRETE DISTRIBUTIONS", SECOND EDITION, C WILEY, PP. 455-457. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2006/7 C ORIGINAL VERSION--JULY 2006. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C IMPLICIT DOUBLE PRECISION (A-H,O-Z) C C--------------------------------------------------------------------- C REAL CPUMIN REAL CPUMAX DOUBLE PRECISION Y(1) C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C DATA DPI / 3.1415926535 8979323846 2643383279 503 D0 / C C-----START POINT----------------------------------------------------- C PDF=0.0 C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(THETA.LE.0.0 .OR. THETA.GE.1.0)THEN WRITE(ICOUT,11) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)THETA CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ENDIF C IF(ALPHA.LE.0.0)THEN WRITE(ICOUT,12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)ALPHA CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ENDIF INTX=X+0.5 IF(INTX.LT.0)THEN WRITE(ICOUT,5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)INTX CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ENDIF C 5 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO THE PIGPDF ', 1'SUBROUTINE IS NON-POSITIVE') 11 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO THE ', 1' PIGPDF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL') 12 FORMAT('***** ERROR--THE THIRD INPUT ARGUMENT TO THE ', 1' PIGPDF SUBROUTINE IS NON-POSITIVE') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7) 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8) C DX=DBLE(INTX) C DTERM1=0.5D0*(DLOG(2.0D0) + DLOG(ALPHA) - DLOG(DPI)) DTERM2=ALPHA*DSQRT(1.0D0 - THETA) DTERM3=DX*(DLOG(ALPHA) + DLOG(THETA) - DLOG(2.0D0)) IF(INTX.EQ.0)THEN DTERM4=-ALPHA + 0.5D0*(DLOG(DPI) - DLOG(2.0D0*ALPHA)) ELSEIF(INTX.EQ.1)THEN DTERM4=-ALPHA + 0.5D0*(DLOG(DPI) - DLOG(2.0D0*ALPHA)) ELSE FNU=DX-0.5 KODE=1 N=1 CALL DBESK(ALPHA,FNU,KODE,N,Y,NZ) DTERM4=DBLE(Y(1)) IF(DTERM4.GE.0.0D0)THEN DTERM4=DLOG(DTERM4) ELSE PDF=0.0D0 GOTO9999 ENDIF ENDIF DTERM5=DLNGAM(DX+1.0D0) DPDF=DTERM1 + DTERM2 + DTERM3 + DTERM4 - DTERM5 PDF=DEXP(DPDF) C 9999 CONTINUE RETURN END REAL FUNCTION PKS2(N, D) C ALGORITHM 487 COLLECTED ALGORITHMS FROM ACM. C ALGORITHM APPEARED IN COMM. ACM, VOL. 17, NO. 12, C P. 703. INTEGER N C N IS THE SAMPLE SIZE USED. REAL D C D IS THE MAXIMUM MAGNITUDE (OF THE DISCREPANCY C BETWEEN THE EMPIRICAL AND PROPOSED DISTRIBUTIONS) C IN EITHER THE POSITIVE OR NEGATIVE DIRECTION. C PKS2 IS THE EXACT PROBABILITY OF OBTAINING A C DEVIATION NO LARGER THAN D. C THESE FORMULAS APPEAR AS (23) AND (24) IN C J. DURBIN. THE PROBABILITY THAT THE SAMPLE C DISTRIBUTION FUNCTION LIES BETWEEN TWO PARALLEL C STRAIGHT LINES. ANNALS OF MATHEMATICAL STATISTICS C 39, 2(APRIL 1968),398-411. DOUBLE PRECISION Q(141), FACT(141), SUM, CI, * FT, FU, FV IF (N.EQ.1) GO TO 90 FN = FLOAT(N) FND = FN*D NDT = IFIX(2.*FND) IF (NDT.LT.1) GO TO 100 ND = IFIX(FND) NDD = MIN0(2*ND,N) NDP = ND + 1 NDDP = NDD + 1 FACT(1) = 1. CI = 1. DO 10 I=1,N FACT(I+1) = FACT(I)*CI CI = CI + 1. 10 CONTINUE Q(1) = 1. IF (NDD.EQ.0) GO TO 50 CI = 1. DO 20 I=1,NDD Q(I+1) = CI**I/FACT(I+1) CI = CI + 1. 20 CONTINUE IF (NDP.GT.N) GO TO 80 FV = FLOAT(NDP) - FND JMAX = IDINT(FV) + 1 DO 40 I=NDP,NDD SUM = 0. FT = FND K = I FU = FV DO 30 J=1,JMAX SUM = SUM + FT**(J-2)/FACT(J)*FU**K/ * FACT(K+1) FT = FT + 1. FU = FU - 1. K = K - 1 30 CONTINUE Q(I+1) = Q(I+1) - 2.*FND*SUM JMAX = JMAX + 1 FV = FV + 1. 40 CONTINUE IF (NDD.EQ.N) GO TO 80 50 DO 70 I=NDDP,N SUM = 0. SIGN = 1. FT = 2.*FND DO 60 J=1,NDT FT = FT - 1. K = I - J + 1 SUM = SUM + SIGN*FT**J/FACT(J+1)*Q(K) SIGN = -SIGN 60 CONTINUE Q(I+1) = SUM 70 CONTINUE 80 PKS2 = Q(N+1)*FACT(N+1)/FN**N RETURN 90 PKS2 = 2.*D - 1. RETURN 100 PKS2 = 0. RETURN END SUBROUTINE PRFAC DIMENSION DXA(4) COMMON /KSCOMM/ DX, DXA, J DOUBLE PRECISION PF COMMON /KSCOM2/ PF(4,40) DATA I /1/ DO 10 J=1,4 IF (DXA(J).EQ.DX) RETURN 10 CONTINUE J = I I = I + 1 IF (I.EQ.5) I = 1 DXA(J) = DX PF(J,1) = 1. DO 20 K=2,38 PF(J,K) = (PF(J,K-1)*DX)/FLOAT(K-1) 20 CONTINUE RETURN END FUNCTION CEILDP(X) IF (X.GE.0.) GO TO 10 I = -X CEILDP = -I RETURN 10 I = X + .99999999 CEILDP = I RETURN END COMPLEX FUNCTION PLEM(Z) C C WEIERSTRASS: P-FUNCTION IN THE LEMNISCATIC CASE C FOR COMPLEX ARGUMENT WITH UNIT PERIOD PARALLELOGRAM C INCLUDE 'DPCOMC.INC' COMPLEX Z, Z2, Z4, Z6 REAL ZR, ZI INTEGER M, N C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C C REDUCTION TO FUNDAMENTAL PARALLELOGRAM C ZR = REAL(Z) + 0.5E0 ZI = AIMAG(Z) + 0.5E0 M = INT(ZR) N = INT(ZI) IF (ZR.LT.0E0) M = M - 1 IF (ZI.LT.0E0) N = N - 1 Z2 = Z - FLOAT(M) - (0E0,1E0)*FLOAT(N) C C IF Z2=0 THEN Z COINCIDES WITH A LATTICE POINT. C SINCE P HAS POLES AT THE LATTICE POINTS, C A DIVISION ERROR WILL OCCUR C IF(REAL(Z2).EQ.0.0.AND.AIMAG(Z2).EQ.0.0)THEN PLEM=R1MACH(2) WRITE(ICOUT,91) CALL DPWRST('XXX','BUG ') RETURN ENDIF 91 FORMAT('***** ERROR: INPUT POINT CORRESPONDS TO A LATTICE ', 1'POINT. VALUE SET TO LARGEST REAL. *****') Z2 = Z2*Z2 Z4 = Z2*Z2 Z6 = Z4*Z2 PLEM = 1E0/Z2 + 4E0*Z2*(3E0+Z4)/(1E0-Z4)**2 + * Z2*((((((((-7.233108E-11*Z4+1.714197273E-8)*Z4-2.5369036492E-7)* * Z4-7.98710206868E-6)*Z4+6.4850606909737E-4)*Z4+7.39624629362938E- * 3)*Z4+2.012382768497244E-2)*Z4+7.1177297543136598E-1)* * Z4-2.54636399353830738E0)/((((((((5.1161516E-10*Z4+6.61289408E-9) * *Z4+4.4618987048E-7)*Z4-8.42694918892E-6)*Z4+4.42886829095E-6)* * Z4-4.22629935217101E-3)*Z4+2.577496871700433E-2)* * Z4+4.2359940482277074E-1)*Z4+1E0) RETURN END COMPLEX FUNCTION PLEM1(Z) C C FIRST DERIVATIVE OF WEIERSTRASS: P-FUNCTION IN THE C LEMNISCATIC CASE FOR COMPLEX ARGUMENT C WITH UNIT PERIOD PARALLELOGRAM C INCLUDE 'DPCOMC.INC' COMPLEX Z, Z1, Z3, Z4 REAL ZR, ZI INTEGER M, N C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C C REDUCTION TO FUNDAMENTAL PARALLELOGRAM C ZR = REAL(Z) + 0.5E0 ZI = AIMAG(Z) + 0.5E0 M = INT(ZR) N = INT(ZI) IF (ZR.LT.0E0) M = M - 1 IF (ZI.LT.0E0) N = N - 1 Z1 = Z - FLOAT(M) - (0E0,1E0)*FLOAT(N) C C IF Z1=0 THEN Z COINCIDES WITH A LATTICE POINT. C SINCE P: HAS POLES AT THE LATTICE POINTS, C A DIVISION ERROR WILL OCCUR C IF(REAL(Z1).EQ.0.0.AND.AIMAG(Z1).EQ.0.0)THEN PLEM1=R1MACH(2) WRITE(ICOUT,91) CALL DPWRST('XXX','BUG ') RETURN ENDIF 91 FORMAT('***** ERROR: INPUT POINT CORRESPONDS TO A LATTICE ', 1'POINT. VALUE SET TO LARGEST REAL. *****') Z3 = Z1*Z1*Z1 Z4 = Z3*Z1 PLEM1 = (((1E1*Z4+9E1)*Z4+3E1)*Z4-2E0)/(Z1*(1E0-Z4))**3 + * Z1*((((((((((-3.9046302E-9*Z4-1.001487137E-8)*Z4+5.9573043092E-7) * *Z4-2.482518130524E-5)*Z4+1.4557266595395E-4)* * Z4+4.56633655643206E-3)*Z4+6.224782572111135E-2)* * Z4+1.038527937794269E-2)*Z4+1.19804620802637942E0)* * Z4+6.42791439683811718E0)*Z4-5.09272798707661477E0)/ * ((((((((((4.726888E-11*Z4-3.0667983E-9)*Z4+1.0087596089E-7)* * Z4-8.060683451E-8)*Z4+1.184299251664E-5)*Z4-2.3096723361547E-4)* * Z4-2.90730903142055E-3)*Z4+1.338392411135511E-2)* * Z4+2.3098639320021426E-1)*Z4+8.4719880964554148E-1)*Z4+1E0) RETURN END SUBROUTINE PLOTCN(Y,X,D,N,ICHAR,MAXCHA,ICASPL,ICAS3D, 1ITITTE,NCTITL, 1IX1LTE,NCX1LA, 1IX2LTE,NCX2LA, 1IX3LTE,NCX3LA, 1IY1LTE,NCY1LA, 1IY2LTE,NCY2LA, 1GX1MIN,GX1MAX,GY1MIN,GY1MAX, 1IERASW,IBUGU2,IERROR) C C PURPOSE--THIS SUBROUTINE YIELDS A NARROW-WIDTH (68-CHARACTER) C PLOT OF Y(I) VERSUS X(I) WITH SPECIAL CHARACTERS C FOR THE VARIOUS SUB-TRACES DICTATED BY THE C CONTENTS OF THE DUMMY VARIABLE D(.) C AND THE CHARACTER VARIABLE ICHAR(.). C ALL(X,Y) PAIRS CORRESPONING C TO THE MINIMUM VALUE IN D(.) C WILL BE PLOTTED WITH PLOT CHARACTER = ICHAR(1). C ALL(X,Y) PAIRS CORRESPONING C TO THE NEXT LARGER VALUE IN D(.) C WILL BE PLOTTED WITH PLOT CHARACTER = ICHAR(2). C ETC. C NOTE--THE NARROW WIDTH OF THIS PLOT C MAKES IT APPROPRIATE FOR C USE ON A (DISCRETE) TERMINAL. C INPUT ARGUMENTS--Y = THE SINGLE PRECISION VECTOR OF C (UNSORTED OR SORTED) OBSERVATIONS C TO BE PLOTTED VERTICALLY. C --X = THE SINGLE PRECISION VECTOR OF C (UNSORTED OR SORTED) OBSERVATIONS C TO BE PLOTTED HORIZONTALLY. C --N = THE INTEGER NUMBER OF OBSERVATIONS C IN THE VECTOR X. C --ICHAR = THE HOLLERITH VECTOR OF C CHARACTERS C (1 CHARACTER PER TRACE) C --MAXCHA = THE INTEGER NUMBER OF C CHARACTERS IN ICHAR(.) C OUTPUT--A NARROW-WIDTH (68-CHARACTER) TERMINAL PLOT C OF Y(I) VERSUS I. C THE BODY OF THE PLOT (NOT COUNTING AXIS VALUES C AND MARGINS) IS 17 ROWS (LINES) AND 41 COLUMNS. C PRINTING--YES. C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C COMMENT--NOTE THAT THE STORAGE REQUIREMENTS FOR THIS C (AND THE OTHER) TERMINAL PLOT SUBROUTINESS ARE . C VERY SMALL. C THIS IS DUE TO THE 'ONE LINE AT A TIME' ALGORITHM C EMPLOYED FOR THE PLOT. C REFERENCES--NONE. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--82.6 C ORIGINAL VERSION--FEBRUARY 1974. C UPDATED --APRIL 1974. C UPDATED --OCTOBER 1974. C UPDATED --OCTOBER 1975. C UPDATED --NOVEMBER 1975. C UPDATED --FEBRUARY 1977. C UPDATED --JUNE 1978. C UPDATED --NOVEMBER 1981. C UPDATED --DECEMBER 1981. C UPDATED --JANUARY 1982. C UPDATED --MAY 1982. C UPDATED --JUNE 1990. TEMPORARY ARRAYS TO GARBAGE COMMON C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICHAR CHARACTER*4 ICASPL CHARACTER*4 ICAS3D C CHARACTER*4 ITITTE CHARACTER*4 IX1LTE CHARACTER*4 IX2LTE CHARACTER*4 IX3LTE CHARACTER*4 IY1LTE CHARACTER*4 IY2LTE C CHARACTER*4 IERASW CHARACTER*4 IBUGU2 CHARACTER*4 IERROR C CHARACTER*4 IBLANK CHARACTER*4 IHYPHE CHARACTER*4 IALPHI CHARACTER*4 IALPHX CHARACTER*4 ILABT CHARACTER*4 ILABY CHARACTER*4 ILABX1 CHARACTER*4 ILABX2 CHARACTER*4 ILABX3 CHARACTER*4 JPLOTC CHARACTER*4 ICASP2 CHARACTER*4 ILINE CHARACTER*4 IAXISC C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C INCLUDE 'DPCOPA.INC' C DIMENSION Y(*) DIMENSION X(*) DIMENSION D(*) DIMENSION ICHAR(*) C DIMENSION ITITTE(*) DIMENSION IX1LTE(*) DIMENSION IX2LTE(*) DIMENSION IX3LTE(*) DIMENSION IY1LTE(*) DIMENSION IY2LTE(*) C DIMENSION ILABT(132) DIMENSION ILABY(132) DIMENSION ILABX1(132) DIMENSION ILABX2(132) DIMENSION ILABX3(132) C DIMENSION ILINE(72) DIMENSION AILABL(10) DIMENSION DISTD(MAXOBV) CCCCC FOLLOWING LINES ADDED JUNE, 1990 INCLUDE 'DPCOZZ.INC' EQUIVALENCE (GARBAG(IGARB1),DISTD(1)) CCCCC END CHANGE C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IERROR='NO' C ISUBN1='PLOT' ISUBN2='CN ' C IBLANK=' ' IHYPHE='-' IALPHI='I' IALPHX='X' C IMAXT=0 IMAXX1=0 IMAXX2=0 IMAXX3=0 C IF(IBUGU2.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('AT THE BEGINNING OF PLOTCN--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)N,IBUGU2 52 FORMAT('N,IBUGU2 = ',I8,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)Y(1),X(1),D(1),ICHAR(1) 53 FORMAT('Y(1),X(1),D(1),ICHAR(1) = ',3E15.7,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)Y(N),X(N),D(N),ICHAR(N) 54 FORMAT('Y(N),X(N),D(N),ICHAR(N) = ',3E15.7,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,55)ICASPL,ICAS3D 55 FORMAT('ICASPL,ICAS3D = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,72)CPUMIN,CPUMAX 72 FORMAT('CPUMIN,CPUMAX = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,73)GX1MIN,GX1MAX,GY1MIN,GY1MAX 73 FORMAT('GX1MIN,GX1MAX,GY1MIN,GY1MAX = ',4E15.7) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C C *************************************************************** C ** STEP 2-- ** C ** DEFINE THE NUMBER OF ROWS AND COLUMNS WITHIN THE PLOT-- ** C ** THIS HAS BEEN SET TO 21 ROWS AND 41 COLUMNS. ** C *************************************************************** C CCCCC NUMROW=21 NUMROW=17 NUMCOL=41 C ANUMR=NUMROW ANUMRM=NUMROW-1 ANUMCM=NUMCOL-1 NUMR25=(NUMROW/4)+1 NUMR50=(NUMROW/2)+1 NUMR75=3*(NUMROW/4)+1 IXDEL=(NUMCOL-1)/4 C C ******************************** C ** STEP 2.2-- ** C ** DEFINE THE TYPE OF PLOT. ** C ******************************** C ICASP2=ICASPL IF(ICASPL.EQ.'MDBP')ICASP2='BOXP' IF(ICASPL.EQ.'MEBP')ICASP2='BOXP' IF(ICASPL.EQ.'VIPL')ICASP2='BOXP' IF(ICASPL.EQ.'MDIP')ICASP2='IPLO' IF(ICASPL.EQ.'MEIP')ICASP2='IPLO' IF(ICASPL.EQ.'MRIP')ICASP2='IPLO' IF(ICASPL.EQ.'MMIP')ICASP2='IPLO' C C ****************************************************** C ** STEP 3-- ** C ** PREPARE THE TITLE LINE, THE Y-AXIS LABEL, ** C ** AND THE 3 HORIZONTAL AXIS LABELS FOR PRINTING. ** C ****************************************************** C YMIDL=NUMROW/2 XMIDL=22+NUMCOL/2 C YFACT=1.0 XFACT=1.0 C ILENT=NCTITL ILENY1=NCY1LA ILENX1=NCX1LA ILENX2=NCX2LA ILENX3=NCX3LA C ALENT=ILENT ALENY1=ILENY1 ALENX1=ILENX1 ALENX2=ILENX2 ALENX3=ILENX3 C IX=XMIDL-XFACT*(ALENT/2.0) DO310I=1,132 ILABT(I)=' ' 310 CONTINUE J=IX-1 IF(ILENT.LE.0)GOTO319 DO315I=1,ILENT J=J+1 ILABT(J)=ITITTE(I) 315 CONTINUE IMAXT=J 319 CONTINUE C IY=YMIDL-YFACT*(ALENY1/2.0) DO320I=1,132 ILABY(I)=' ' 320 CONTINUE J=IY-1 IF(ILENY1.LE.0)GOTO329 DO325I=1,ILENY1 J=J+1 ILABY(J)=ITITTE(I) 325 CONTINUE IMAXY1=J 329 CONTINUE C IX=XMIDL-XFACT*(ALENX1/2.0) DO330I=1,132 ILABX1(I)=' ' 330 CONTINUE J=IX-1 IF(ILENX1.LE.0)GOTO339 DO335I=1,ILENX1 J=J+1 ILABX1(J)=IX1LTE(I) 335 CONTINUE IMAXX1=J 339 CONTINUE C IX=XMIDL-XFACT*(ALENX2/2.0) DO340I=1,132 ILABX2(I)=' ' 340 CONTINUE J=IX-1 IF(ILENX2.LE.0)GOTO349 DO345I=1,ILENX2 J=J+1 ILABX2(J)=IX2LTE(I) 345 CONTINUE IMAXX2=J 349 CONTINUE C IX=XMIDL-XFACT*(ALENX3/2.0) DO350I=1,132 ILABX3(I)=' ' 350 CONTINUE J=IX-1 IF(ILENX3.LE.0)GOTO359 DO355I=1,ILENX3 J=J+1 ILABX3(J)=IX3LTE(I) 355 CONTINUE IMAXX3=J 359 CONTINUE C C **************************************************************** C ** STEP 4-- C ** SKIP TO A NEW PAGE; C ** WRITE OUT THE TITLE (IF ANY); C ** WRITE OUT THE TOP HORIZONTAL AXIS OF THE PLOT; C **************************************************************** C IF(IERASW.EQ.'ON')WRITE(ICOUT,504) 504 FORMAT(1H1) IF(IERASW.EQ.'ON')CALL DPWRST('XXX','BUG ') IF(IERASW.EQ.'OFF')WRITE(ICOUT,999) IF(IERASW.EQ.'OFF')CALL DPWRST('XXX','BUG ') IF(IMAXT.GE.1)WRITE(ICOUT,505)(ILABT(I),I=1,IMAXT) 505 FORMAT(240A1) IF(IMAXT.GE.1)CALL DPWRST('XXX','BUG ') C DO500ICOL=1,NUMCOL ILINE(ICOL)=IHYPHE 500 CONTINUE DO550ICOL=1,NUMCOL,IXDEL ILINE(ICOL)=IALPHI 550 CONTINUE WRITE(ICOUT,555)(ILINE(I),I=1,NUMCOL) 555 FORMAT(20X,54A1) CALL DPWRST('XXX','BUG ') C C C ******************************************************* C ** STEP 5-- ** C ** DETERMINE THE MIN AND MAX VALUES OF Y AND OF X. ** C ******************************************************* C XMIN=X(1) XMAX=X(1) YMIN=Y(1) YMAX=Y(1) DO700I=1,N IF(X(I).LT.XMIN)XMIN=X(I) IF(X(I).GT.XMAX)XMAX=X(I) IF(Y(I).LT.YMIN)YMIN=Y(I) IF(Y(I).GT.YMAX)YMAX=Y(I) 700 CONTINUE IF(GX1MIN.NE.CPUMIN)XMIN=GX1MIN IF(GX1MAX.NE.CPUMAX)XMAX=GX1MAX IF(GY1MIN.NE.CPUMIN)YMIN=GY1MIN IF(GY1MAX.NE.CPUMAX)YMAX=GY1MAX DELX=XMAX-XMIN DELY=YMAX-YMIN XWIDTH=DELX/ANUMCM YWIDTH=DELY/ANUMRM C C ************************************* C ** STEP 6-- ** C ** DETERMINE THE DISTINCT VALUES ** C ** IN THE VARIABLE D(.) ** C ************************************* C MAXDIS=1000 C NUMDIS=1 DISTD(1)=D(1) C DO900I=2,N DO910J=1,NUMDIS IF(D(I).EQ.DISTD(J))GOTO900 910 CONTINUE IF(NUMDIS.GE.MAXDIS)GOTO990 NUMDIS=NUMDIS+1 DISTD(NUMDIS)=D(I) 900 CONTINUE 990 CONTINUE C C **************************************************************** C ** STEP 7-- C ** DETERMINE AND WRITE OUT THE PLOT POSITIONS ONE LINE AT A TIM C **************************************************************** C DO1100IROW=1,NUMROW C DO1200ICOL=1,NUMCOL ILINE(ICOL)=IBLANK 1200 CONTINUE C AIROW=IROW YUPPER=YMAX+(1.5-AIROW)*YWIDTH YLABEL=YMAX+(1.0-AIROW)*YWIDTH YLOWER=YMAX+(0.5-AIROW)*YWIDTH IF(IROW.EQ.NUMROW)YLABEL=YMIN DO1300I=1,N AI=I IF(YLOWER.LE.Y(I).AND.Y(I).LT.YUPPER)GOTO1350 GOTO1300 1350 CONTINUE ICOL=((X(I)-XMIN)/XWIDTH)+1.5 IF(ICOL.LT.1.OR.ICOL.GT.NUMCOL)GOTO1300 DO1360K=1,NUMDIS K2=K IF(D(I).EQ.DISTD(K))GOTO1370 1360 CONTINUE JPLOTC='X' GOTO1390 1370 CONTINUE JPLOTC='X' IF(ICASP2.EQ.'BOXP')K2=K2-((K2-1)/20)*20 IF(ICASP2.EQ.'IPLO')K2=K2-((K2-1)/5)*5 IF(K2.LE.MAXCHA)JPLOTC=ICHAR(K2) IF(JPLOTC.EQ.' ')JPLOTC='X' IF(JPLOTC.EQ.'BLAN')JPLOTC='X' IF(JPLOTC.EQ.'NONE')JPLOTC='X' GOTO1390 1390 CONTINUE ILINE(ICOL)=JPLOTC 1300 CONTINUE C ICOLMX=1 DO1400ICOL=1,NUMCOL ICOLRV=NUMCOL-ICOL+1 IF(ILINE(ICOLRV).EQ.' ')GOTO1400 ICOLMX=ICOLRV GOTO1490 1400 CONTINUE 1490 CONTINUE C IAXISC=IALPHI IF(IROW.EQ.1.OR.IROW.EQ.NUMROW)IAXISC=IHYPHE IF(IROW.EQ.NUMR25.OR.IROW.EQ.NUMR50.OR.IROW.EQ.NUMR75) 1IAXISC=IHYPHE WRITE(ICOUT,1410)ILABY(IROW),YLABEL,IAXISC, 1(ILINE(ICOL),ICOL=1,ICOLMX) 1410 FORMAT(A1,1X,E14.7,1X,A1,2X,50A1) CALL DPWRST('XXX','BUG ') C 1100 CONTINUE C C ************************************************************ C ** STEP 8-- ** C ** WRITE OUT THE BOTTOM HORIZONTAL AXIS OF THE PLOT; ** C ** WRITE OUT THE X-AXIS NUMERIC LABELS; ** C ** WRITE OUT THE FIRST HORIZONTAL AXIS LABEL (IF ANY); ** C ** WRITE OUT THE SECOND HORIZONTAL AXIS LABEL (IF ANY); ** C ** WRITE OUT THE THIRD HORIZONTAL AXIS LABEL (IF ANY). ** C ************************************************************ C C DO2200ICOL=1,NUMCOL ILINE(ICOL)=IHYPHE 2200 CONTINUE DO2300ICOL=1,NUMCOL,IXDEL ILINE(ICOL)=IALPHI 2300 CONTINUE WRITE(ICOUT,2105)(ILINE(ICOL),ICOL=1,NUMCOL) 2105 FORMAT(20X,54A1) CALL DPWRST('XXX','BUG ') C NUMLAB=5 ANUMLM=NUMLAB-1 DO2500I=1,NUMLAB AIM1=I-1 AILABL(I)=XMIN+(AIM1/ANUMLM)*DELX 2500 CONTINUE WRITE(ICOUT,2310)(AILABL(I),I=1,NUMLAB) 2310 FORMAT(13X,5E10.4) CALL DPWRST('XXX','BUG ') C IF(IMAXX1.GE.1)WRITE(ICOUT,2311)(ILABX1(I),I=1,IMAXX1) 2311 FORMAT(240A1) IF(IMAXX1.GE.1)CALL DPWRST('XXX','BUG ') IF(IMAXX2.GE.1)WRITE(ICOUT,2311)(ILABX2(I),I=1,IMAXX2) IF(IMAXX2.GE.1)CALL DPWRST('XXX','BUG ') IF(IMAXX3.GE.1)WRITE(ICOUT,2311)(ILABX3(I),I=1,IMAXX3) IF(IMAXX3.GE.1)CALL DPWRST('XXX','BUG ') C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE RETURN END SUBROUTINE PLOTCW(Y,X,D,N,ICHAR,MAXCHA,ICASPL,ICAS3D, 1ITITTE,NCTITL, 1IX1LTE,NCX1LA, 1IX2LTE,NCX2LA, 1IX3LTE,NCX3LA, 1IY1LTE,NCY1LA, 1IY2LTE,NCY2LA, 1GX1MIN,GX1MAX,GY1MIN,GY1MAX, 1IERASW,IBUGU2,IERROR) C C PURPOSE--THIS SUBROUTINE YIELDS A WIDE-WIDTH (130-CHARACTER) C PLOT OF Y(I) VERSUS X(I) WITH SPECIAL CHARACTERS C FOR THE VARIOUS SUB-TRACES DICTATED BY THE C CONTENTS OF THE DUMMY VARIABLE D(.) C AND THE CHARACTER VARIABLE ICHAR(.). C ALL(X,Y) PAIRS CORRESPONING C TO THE MINIMUM VALUE IN D(.) C WILL BE PLOTTED WITH PLOT CHARACTER = ICHAR(1). C ALL(X,Y) PAIRS CORRESPONING C TO THE NEXT LARGER VALUE IN D(.) C WILL BE PLOTTED WITH PLOT CHARACTER = ICHAR(2). C ETC. C NOTE--THE WIDE WIDTH OF THIS PLOT C MAKES IT APPROPRIATE FOR C USE ON A BATCH PRINTER. C INPUT ARGUMENTS--X = THE SINGLE PRECISION VECTOR OF C (UNSORTED OR SORTED) OBSERVATIONS C TO BE PLOTTED VERTICALLY. C --N = THE INTEGER NUMBER OF OBSERVATIONS C IN THE VECTOR X. C --ICHAR = THE HOLLERITH VECTOR OF C CHARACTERS (ONLY THE C FIRST OF WHICH WILL BE USED) C --MAXCHA = THE INTEGER NUMBER OF C CHARACTERS IN ICHAR(.) C OUTPUT--A WIDE-WIDTH (130-CHARACTER) TERMINAL PLOT C OF Y(I) VERSUS X(I). C THE BODY OF THE PLOT (NOT COUNTING AXIS VALUES C AND MARGINS) IS 41 ROWS (LINES) AND 101 COLUMNS. C PRINTING--YES. C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--NONE. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--82.6 C ORIGINAL VERSION--JUNE 1972. C UPDATED --JANUARY 1975. C UPDATED --JULY 1975. C UPDATED --SEPTEMBER 1975. C UPDATED --OCTOBER 1975. C UPDATED --NOVEMBER 1975. C UPDATED --FEBRUARY 1976. C UPDATED --FEBRUARY 1977. C UPDATED --JUNE 1978. C UPDATED --NOVEMBER 1981. C UPDATED --DECEMBER 1981. C UPDATED --JANUARY 1982. C UPDATED --MAY 1982. C UPDATED --JUNE 1990. TEMPORARY ARRAYS TO GARBAGE COMMON C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICHAR CHARACTER*4 ICASPL CHARACTER*4 ICAS3D C CHARACTER*4 ITITTE CHARACTER*4 IX1LTE CHARACTER*4 IX2LTE CHARACTER*4 IX3LTE CHARACTER*4 IY1LTE CHARACTER*4 IY2LTE C CHARACTER*4 IERASW CHARACTER*4 IBUGU2 CHARACTER*4 IERROR C CHARACTER*4 IBLANK CHARACTER*4 IHYPHE CHARACTER*4 IALPHI CHARACTER*4 IALPHX CHARACTER*4 IALPHM CHARACTER*4 IALPHA CHARACTER*4 IALPHN CHARACTER*4 IALPHD CHARACTER*4 IEQUAL C CHARACTER*4 ILABT CHARACTER*4 ILABY1 CHARACTER*4 ILABX1 CHARACTER*4 ILABX2 CHARACTER*4 ILABX3 C CHARACTER*4 JPLOTC CHARACTER*4 IGRAPH CHARACTER*4 ICASP2 C C--------------------------------------------------------------------- C INCLUDE 'DPCOPA.INC' C DIMENSION Y(*) DIMENSION X(*) DIMENSION D(*) DIMENSION ICHAR(*) DIMENSION IGRAPH(55,130) C DIMENSION ITITTE(*) DIMENSION IX1LTE(*) DIMENSION IX2LTE(*) DIMENSION IX3LTE(*) DIMENSION IY1LTE(*) DIMENSION IY2LTE(*) C DIMENSION ILABT(132) DIMENSION ILABY1(132) DIMENSION ILABX1(132) DIMENSION ILABX2(132) DIMENSION ILABX3(132) C DIMENSION YLABEL(11) DIMENSION DISTD(MAXOBV) CCCCC FOLLOWING LINES ADDED JUNE, 1990 INCLUDE 'DPCOZZ.INC' EQUIVALENCE (GARBAG(IGARB1),DISTD(1)) CCCCC END CHANGE C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IERROR='NO' C IBLANK=' ' IHYPHE='-' IALPHI='I' IALPHX='X' IALPHM='M' IALPHA='A' IALPHX='X' IALPHN='N' IALPHD='D' IALPHN='N' IEQUAL='=' C IMAXT=0 IMAXX1=0 IMAXX2=0 IMAXX3=0 C IF(IBUGU2.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('AT THE BEGINNING OF PLOTCW--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)N,IBUGU2 52 FORMAT('N,IBUGU2 = ',I8,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)Y(1),X(1),D(1),ICHAR(1) 53 FORMAT('Y(1),X(1),D(1),ICHAR(1) = ',3E15.7,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)Y(N),X(N),D(N),ICHAR(N) 54 FORMAT('Y(N),X(N),D(N),ICHAR(N) = ',3E15.7,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,55)ICASPL,ICAS3D 55 FORMAT('ICASPL,ICAS3D = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,72)CPUMIN,CPUMAX 72 FORMAT('CPUMIN,CPUMAX = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,73)GX1MIN,GX1MAX,GY1MIN,GY1MAX 73 FORMAT('GX1MIN,GX1MAX,GY1MIN,GY1MAX = ',4E15.7) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C C ************************************* C ** STEP 1.5-- ** C ** DETERMINE THE DISTINCT VALUES ** C ** IN THE VARIABLE D(.) ** C ************************************* C MAXDIS=1000 C NUMDIS=1 DISTD(1)=D(1) C DO250I=2,N DO260J=1,NUMDIS IF(D(I).EQ.DISTD(J))GOTO250 260 CONTINUE IF(NUMDIS.GE.MAXDIS)GOTO269 NUMDIS=NUMDIS+1 DISTD(NUMDIS)=D(I) 250 CONTINUE 269 CONTINUE C C C *************************************************************** C ** STEP 2-- ** C ** DEFINE THE NUMBER OF ROWS AND COLUMNS WITHIN THE PLOT-- ** C ** THIS HAS BEEN SET TO 41 ROWS AND 97 COLUMNS. ** C *************************************************************** C NUMROW=41 NUMCOL=97 C ANUMR=NUMROW ANUMRM=NUMROW-1 ANUMCM=NUMCOL-1 NUMR25=(NUMROW/4)+1 NUMR50=(NUMROW/2)+1 NUMR75=3*(NUMROW/4)+1 IXDEL=(NUMCOL-1)/4 C C *************************** C ** STEP 2.1-- ** C ** BLANK OUT THE GRAPH ** C *************************** C DO280I=1,55 DO290J=1,130 IGRAPH(I,J)=IBLANK 290 CONTINUE 280 CONTINUE C C ******************************** C ** STEP 2.2-- ** C ** DEFINE THE TYPE OF PLOT. ** C ******************************** C ICASP2=ICASPL IF(ICASPL.EQ.'MDBP')ICASP2='BOXP' IF(ICASPL.EQ.'MEBP')ICASP2='BOXP' IF(ICASPL.EQ.'VIPL')ICASP2='BOXP' IF(ICASPL.EQ.'MDIP')ICASP2='IPLO' IF(ICASPL.EQ.'MEIP')ICASP2='IPLO' IF(ICASPL.EQ.'MRIP')ICASP2='IPLO' IF(ICASPL.EQ.'MMIP')ICASP2='IPLO' C C ****************************************************** C ** STEP 3-- ** C ** PREPARE THE TITLE LINE, THE Y-AXIS LABEL, ** C ** AND THE 3 HORIZONTAL AXIS LABELS FOR PRINTING. ** C ****************************************************** C YMIDL=(55/2)-4 XMIDL=29+NUMCOL/2 C YFACT=1.0 XFACT=1.0 C ILENT=NCTITL ILENY1=NCY1LA ILENX1=NCX1LA ILENX2=NCX2LA ILENX3=NCX3LA C ALENT=ILENT ALENY1=ILENY1 ALENX1=ILENX1 ALENX2=ILENX2 ALENX3=ILENX3 C IX=XMIDL-XFACT*(ALENT/2.0) DO310I=1,132 ILABT(I)=' ' 310 CONTINUE J=IX-1 IF(ILENT.LE.0)GOTO319 DO315I=1,ILENT J=J+1 ILABT(J)=ITITTE(I) 315 CONTINUE IMAXT=J 319 CONTINUE C IY=YMIDL-YFACT*(ALENY1/2.0) DO320I=1,132 ILABY1(I)=' ' 320 CONTINUE J=IY-1 IF(ILENY1.LE.0)GOTO329 DO325I=1,ILENY1 J=J+1 ILABY1(J)=IY1LTE(I) 325 CONTINUE IMAXY1=J 329 CONTINUE C IX=XMIDL-XFACT*(ALENX1/2.0) DO330I=1,132 ILABX1(I)=' ' 330 CONTINUE J=IX-1 IF(ILENX1.LE.0)GOTO339 DO335I=1,ILENX1 J=J+1 ILABX1(J)=IX1LTE(I) 335 CONTINUE IMAXX1=J 339 CONTINUE C IX=XMIDL-XFACT*(ALENX2/2.0) DO340I=1,132 ILABX2(I)=' ' 340 CONTINUE J=IX-1 IF(ILENX2.LE.0)GOTO349 DO345I=1,ILENX2 J=J+1 ILABX2(J)=IX2LTE(I) 345 CONTINUE IMAXX2=J 349 CONTINUE C IX=XMIDL-XFACT*(ALENX3/2.0) DO350I=1,132 ILABX3(I)=' ' 350 CONTINUE J=IX-1 IF(ILENX3.LE.0)GOTO359 DO355I=1,ILENX3 J=J+1 ILABX3(J)=IX3LTE(I) 355 CONTINUE IMAXX3=J 359 CONTINUE C C ******************************************************* C ** STEP 5-- ** C ** DETERMINE THE MIN AND MAX VALUES OF Y AND OF X. ** C ******************************************************* C YMIN=Y(1) YMAX=Y(1) XMIN=X(1) XMAX=X(1) DO700I=1,N IF(Y(I).LT.YMIN)YMIN=Y(I) IF(Y(I).GT.YMAX)YMAX=Y(I) IF(X(I).LT.XMIN)XMIN=X(I) IF(X(I).GT.XMAX)XMAX=X(I) 700 CONTINUE IF(GX1MIN.NE.CPUMIN)XMIN=GX1MIN IF(GX1MAX.NE.CPUMAX)XMAX=GX1MAX IF(GY1MIN.NE.CPUMIN)YMIN=GY1MIN IF(GY1MAX.NE.CPUMAX)YMAX=GY1MAX DELY=YMAX-YMIN DELX=XMAX-XMIN YWIDTH=DELY/ANUMRM XWIDTH=DELX/ANUMCM C XMID=(XMIN+XMAX)/2.0 X25=0.75*XMIN+0.25*XMAX X75=0.25*XMIN+0.75*XMAX C DO800I=1,9 AIM1=I-1 YLABEL(I)=YMAX-(AIM1/8.0)*(YMAX-YMIN) 800 CONTINUE C C ********************************* C ** STEP 6-- ** C ** PRODUCE THE VERTICAL AXES ** C ********************************* C DO1300I=3,43 IGRAPH(I,5)=IALPHI IGRAPH(I,105)=IALPHI 1300 CONTINUE DO1400I=3,43,5 IGRAPH(I,5)=IHYPHE IGRAPH(I,105)=IHYPHE 1400 CONTINUE IGRAPH(3,1)=IEQUAL IGRAPH(3,2)=IALPHM IGRAPH(3,3)=IALPHA IGRAPH(3,4)=IALPHX IGRAPH(23,1)=IEQUAL IGRAPH(23,2)=IALPHM IGRAPH(23,3)=IALPHI IGRAPH(23,4)=IALPHD IGRAPH(43,1)=IEQUAL IGRAPH(43,2)=IALPHM IGRAPH(43,3)=IALPHI IGRAPH(43,4)=IALPHN C C *********************************** C ** STEP 7-- ** C ** PRODUCE THE HORIZONTAL AXES ** C *********************************** C DO1500J=7,103 IGRAPH(1,J)=IHYPHE IGRAPH(45,J)=IHYPHE 1500 CONTINUE DO1600J=7,103,12 IGRAPH(1,J)=IALPHI IGRAPH(45,J)=IALPHI 1600 CONTINUE C C ****************************************** C ** STEP 8-- ** C ** DETERMINE THE (X,Y) PLOT POSITIONS ** C ****************************************** C RATIOY=ANUMRM/(YMAX-YMIN) RATIOX=ANUMCM/(XMAX-XMIN) DO1800I=1,N XI=X(I) MX=RATIOX*(XI-XMIN)+0.5 MX=MX+7 IF(MX.LT.7.OR.MX.GT.103)GOTO1800 MY=RATIOY*(Y(I)-YMIN)+0.5 MY=43-MY IF(MY.LT.3.OR.MY.GT.43)GOTO1800 DO1860K=1,NUMDIS K2=K IF(D(I).EQ.DISTD(K))GOTO1870 1860 CONTINUE JPLOTC='X' GOTO1890 1870 CONTINUE JPLOTC='X' IF(ICASP2.EQ.'BOXP')K2=K2-((K2-1)/20)*20 IF(ICASP2.EQ.'IPLO')K2=K2-((K2-1)/5)*5 IF(K2.LE.MAXCHA)JPLOTC=ICHAR(K2) IF(JPLOTC.EQ.' ')JPLOTC='X' IF(JPLOTC.EQ.'BLAN')JPLOTC='X' IF(JPLOTC.EQ.'NONE')JPLOTC='X' GOTO1890 1890 CONTINUE IGRAPH(MY,MX)=JPLOTC 1800 CONTINUE C C ************************************* C ** STEP 9-- ** C ** SKIP TO A NEW PAGE. ** C ** WRITE OUT THE TITLE (IF ANY); ** C ************************************* C IF(IERASW.EQ.'ON')WRITE(ICOUT,2004) 2004 FORMAT(1H1) IF(IERASW.EQ.'ON')CALL DPWRST('XXX','BUG ') IF(IERASW.EQ.'OFF')WRITE(ICOUT,999) IF(IERASW.EQ.'OFF')CALL DPWRST('XXX','BUG ') IF(IMAXT.GE.1)WRITE(ICOUT,2005)(ILABT(I),I=1,IMAXT) 2005 FORMAT(240A1) IF(IMAXT.GE.1)CALL DPWRST('XXX','BUG ') IF(IMAXT.LE.0)WRITE(ICOUT,999) IF(IMAXT.LE.0)CALL DPWRST('XXX','BUG ') C C ********************************************* C ** STEP 10-- ** C ** WRITE OUT THE GRAPH ** C ** (INCLUDING THE X-AXIS NUMERIC LABELS) ** C ********************************************* C DO2100I=1,45 IP2=I+2 IFLAG=IP2-(IP2/5)*5 K=IP2/5 IF(IFLAG.NE.0)WRITE(ICOUT,2105)ILABY1(I),(IGRAPH(I,J),J=1,105) 2105 FORMAT(A1,20X,105A1) IF(IFLAG.NE.0)CALL DPWRST('XXX','BUG ') IF(IFLAG.EQ.0)WRITE(ICOUT,2106)ILABY1(I),YLABEL(K), 1(IGRAPH(I,J),J=1,105) 2106 FORMAT(A1,F20.7,105A1) IF(IFLAG.EQ.0)CALL DPWRST('XXX','BUG ') 2100 CONTINUE WRITE(ICOUT,2107)XMIN,X25,XMID,X75,XMAX 2107 FORMAT(14X,F20.7,4X,F20.7,4X,F20.7,4X,F20.7,4X,F20.7) CALL DPWRST('XXX','BUG ') C C ************************************************************ C ** STEP 11-- ** C ** WRITE OUT THE FIRST HORIZONTAL AXIS LABEL (IF ANY); ** C ** WRITE OUT THE SECOND HORIZONTAL AXIS LABEL (IF ANY); ** C ** WRITE OUT THE THIRD HORIZONTAL AXIS LABEL (IF ANY). ** C ************************************************************ C IF(IMAXX1.GE.1)WRITE(ICOUT,2311)(ILABX1(I),I=1,IMAXX1) 2311 FORMAT(240A1) IF(IMAXX1.GE.1)CALL DPWRST('XXX','BUG ') IF(IMAXX1.LE.0)WRITE(ICOUT,999) IF(IMAXX1.LE.0)CALL DPWRST('XXX','BUG ') IF(IMAXX2.GE.1)WRITE(ICOUT,2311)(ILABX2(I),I=1,IMAXX2) IF(IMAXX2.GE.1)CALL DPWRST('XXX','BUG ') IF(IMAXX2.LE.0)WRITE(ICOUT,999) IF(IMAXX2.LE.0)CALL DPWRST('XXX','BUG ') IF(IMAXX3.GE.1)WRITE(ICOUT,2311)(ILABX3(I),I=1,IMAXX3) IF(IMAXX3.GE.1)CALL DPWRST('XXX','BUG ') IF(IMAXX3.LE.0)WRITE(ICOUT,999) IF(IMAXX3.LE.0)CALL DPWRST('XXX','BUG ') C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE RETURN END SUBROUTINE PLOTGE(Y,X,X3D,D,N,XIDC,NUMSET, 1ICASPL,ICAS3D, 1ISQUAR, 1YSAVE, 1IVGMSW,IHGMSW, 1IFIRST,ILAST, 1IHNAME,IHNAM2,IUSE,IVALUE,VALUE,NUMNAM, 1IVSTAR,IVSTOP,IFUNC,NUMCHF,IREPCH, CCCCC FOLLOWING LINE ADDED AUGUST 1992. 1DSIZE,DSYMB,DCOLOR,DFILL, 1ICAPSW, 1IBUGU2,IBUGU3,IBUGU4,ISUBRO, 1IERROR) C C PURPOSE--GENERATE A GENERAL (SINGLE OR MULTIPLE TRACE) PLOT C ON A GENERAL GRAPHICS DEVICE. C THE PLOT WILL CONSIST OF Y VERSUS X C WITH EACH DISTINCT VALUE OF THE VARIABLE D C RESULTING IN A DISTINCT TRACE ON THE PLOT. C C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-921-3651 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82.6 C ORIGINAL VERSION--AUGUST 22, 1977. C UPDATED --DECEMBER 1977. C UPDATED --JUNE 1978. C UPDATED --OCTOBER 1978. C UPDATED --MARCH 1979. C UPDATED --JUNE 1979. C UPDATED --JANUARY 1981. C UPDATED --FEBRUARY 1981. C UPDATED --MARCH 1981. C UPDATED --APRIL 1981. C UPDATED --AUGUST 1981. C UPDATED --DECEMBER 1981. C UPDATED --MAY 1982. C UPDATED --JULY 1983. C UPDATED --SEPTEMBER 1988. 3D HIDDEN LINE ETC. C UPDATED --OCTOBER 1988. ERROR BAR PLOT C UPDATED --FEBRUARY 1989. HORIZONTAL SWITCH (ALAN) C UPDATED --MAY 1989. DES. OF EXP. PLOTS C UPDATED --JUNE 1990. TEMPORARY ARRAYS TO GARBAGE COMMON C UPDATED --JUNE 1992. BLOCK PLOTS C UPDATED --AUGUST 1992. VECTOR PLOT. ALSO, BUG IF C NUMSET =101, 201, ETC. C UPDATED --AUGUST 1992. SYMBOL PLOT C UPDATED --NOVEMBER 1993. MODIFICATION FOR PIE CHART C UPDATED --AUGUST 1994. BUG FOR VECTOR PLOT C UPDATED --DECEMBER 1994. EXACT CHARACTER MAPPING C UPDATED --JUNE 1995. BLOCK PLOT FIX--KEEP C UPDATED ISET3 <= 100 C C UPDATED --MAY 1998. DUANE PLOTS NEED LOG SCALES C UPDATED --DECEMBER 1999. IMPLEMENT SUB-REGIONS C UPDATED --JANUARY 2000. IMPLEMENT ZVAL CHARACTER TYPE C UPDATED --AUGUST 2001. CONSENSUS MEAN PLOT, SET C CHAR/LINE TYPES SIMILAR TO C I-PLOT C UPDATED --FEBRUARY 2003. VIOLIN PLOT (SIMILAR TO BOX C PLOT, EXTRA TRACE AT C BEGINNING) C UPDATED --MARCH 2003. PARALLEL COORDINATES PLOT C (PRE-SORT OFF) C UPDATED --MAY 2003. GROUPED PARALLEL COORDINATES C PLOT C C-----NON-COMMON VARIABLES-------------------------------------------- C C CHARACTER*4 ICAPSW C CHARACTER*4 ISQUAR C CHARACTER*4 IVGMSW CHARACTER*4 IHGMSW C CHARACTER*4 ICASPL CHARACTER*4 ICAS3D CHARACTER*4 IFIRST CHARACTER*4 ILAST C CHARACTER*4 IHNAME CHARACTER*4 IHNAM2 CHARACTER*4 IUSE CHARACTER*4 IFUNC C CHARACTER*1 IREPCH C CHARACTER*4 IBUGU2 CHARACTER*4 IBUGU3 CHARACTER*4 IBUGU4 CHARACTER*4 ISUBRO C CHARACTER*4 IERROR C CHARACTER*4 IMORE C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C CHARACTER*4 ICH3PA C CHARACTER*4 IOPGRS CHARACTER*4 IOPG2S CHARACTER*4 IDELIS CHARACTER*4 IDRFRS CHARACTER*4 IWRLAS CHARACTER*4 IWRLES CHARACTER*4 IDRTRS CHARACTER*4 ICLG2S CHARACTER*4 ICLGRS C CHARACTER*4 ISWTCH CCCCC ADD FOLLOWING 4 LINES MAY, 1998. CHARACTER*4 IX1TMP CHARACTER*4 IX2TMP CHARACTER*4 IY1TMP CHARACTER*4 IY2TMP C C--------------------------------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'DPCO3D.INC' C DIMENSION Y(*) DIMENSION X(*) DIMENSION X3D(*) DIMENSION D(*) CCCCC FOLLOWING 4 LINES ADDED AUGUST 1992 DIMENSION DSIZE(*) DIMENSION DSYMB(*) DIMENSION DCOLOR(*) DIMENSION DFILL(*) C DIMENSION XIDC(*) C DIMENSION IHNAME(*) DIMENSION IHNAM2(*) DIMENSION IUSE(*) DIMENSION IVALUE(*) DIMENSION VALUE(*) DIMENSION IVSTAR(*) DIMENSION IVSTOP(*) DIMENSION IFUNC(*) C CCCCC DIMENSION Y2(1000) CCCCC DIMENSION X2(1000) C CCCCC DIMENSION Y3(1000) CCCCC DIMENSION X3(1000) C CCCCC DIMENSION Y4(1000) CCCCC DIMENSION X4(1000) C CCCCC DIMENSION Y5(1000) CCCCC DIMENSION X5(1000) C DIMENSION X2(MAXPOP) DIMENSION Y2(MAXPOP) DIMENSION Z2(MAXPOP) DIMENSION X3D2(MAXPOP) C DIMENSION X3(MAXPOP) DIMENSION Y3(MAXPOP) DIMENSION Z3(MAXPOP) C DIMENSION X4(MAXPOP) DIMENSION Y4(MAXPOP) DIMENSION Z4(MAXPOP) C CCCCC I HAVE THE FOLLOWING 2 DIMENSIONS AS MAXPOP. CCCCC ALAN HAS THE FOLLOWING 2 DIMENSIONS AS 1. CCCCC CHECK ON THE REASON FOR THE DIFFERENCE. DIMENSION X5(MAXPOP) DIMENSION Y5(MAXPOP) CCCCC FOLLOWING LINES ADDED JUNE, 1990 INCLUDE 'DPCOZZ.INC' INCLUDE 'DPCOZ2.INC' EQUIVALENCE (GARBAG(IGARG1),X2(1)) EQUIVALENCE (GARBAG(IGARG2),Y2(1)) EQUIVALENCE (GARBAG(IGARG3),Z2(1)) EQUIVALENCE (GARBAG(IGARG4),X3D2(1)) EQUIVALENCE (GARBAG(IGARG5),X3(1)) EQUIVALENCE (G2RBAG(IGARG6),Y3(1)) EQUIVALENCE (G2RBAG(IGARG7),Z3(1)) EQUIVALENCE (G2RBAG(IGARG8),X4(1)) EQUIVALENCE (G2RBAG(IGARG9),Y4(1)) EQUIVALENCE (G2RBAG(IGRG10),Z4(1)) EQUIVALENCE (G2RBAG(IGRG11),X5(1)) EQUIVALENCE (G2RBAG(IGRG12),Y5(1)) CCCCC END CHANGE C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOPC.INC' INCLUDE 'DPCOGR.INC' INCLUDE 'DPCOBE.INC' INCLUDE 'DPCOSU.INC' C C-----COMMON VARIABLES (GENERAL)-------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='PLOT' ISUBN2='GE ' C IBUGG4=IBUGU2 ISUBG4=ISUBRO IERRG4=IERROR C ISWTCH='OFF' C CCCCC DECEMBER 1999. DETERMINE NUMBER OF SUB-REGIONS ON PLOT. NUMSBR=0 DO20I=1,MAXSUB IF(ISUBSW(I).EQ.'ON')NUMSBR=NUMSBR+1 20 CONTINUE C CCCCC THE FOLLOWING COMMENT AND REPLACEMENT WAS MADE FEBRUARY 1989 (ALAN) CCCCC MXNPPC=1000 MXNPPC=MAXPOP C XDELMN=CPUMAX YDELMN=CPUMAX ZDELMN=CPUMAX CCCCC FOLLOWING BLOCK ADDED AUGUST 1992. ASETSZ=1.0 ISETSY=1 ISETCL=1 ISETFI=0 CCCCC ADD FOLLOWING SECTION FOR DUANE PLOTS. MAY 1998. IF(ICASPL.EQ.'DUAN')THEN IX1TMP=IX1TSC IX2TMP=IX2TSC IY1TMP=IY1TSC IY2TMP=IY2TSC IX1TSC='LOG' IX2TSC='LOG' IY1TSC='LOG' IY2TSC='LOG' ENDIF C CCCCC ALAN COMMENTED OUT THE FOLLOWING LINE FEBRUARY 1989 CCCCC YSAVE=0.0 C IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'OTGE')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF PLOTGE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)N,NUMSET 52 FORMAT('N,NUMSET = ',2I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)ICASPL,ICAS3D,I3DPRO 53 FORMAT('ICASPL,ICAS3D,I3DPRO,I3DPRO = ',A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)ISQUAR 54 FORMAT('ISQUAR = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,55)IFIRST,ILAST 55 FORMAT('IFIRST,ILAST = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,58)IBUGG4,ISUBG4,IERRG4 58 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,59)IBUGU2,ISUBRO,IERROR 59 FORMAT('IBUGU2,ISUBRO,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,61)ILINPA(1),ILINPA(2) 61 FORMAT('ILINPA(1),ILINPA(2) = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,62)ICHAPA(1),ICHAPA(2) 62 FORMAT('ICHAPA(1),ICHAPA(2) = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,63)ISPILI(1),ISPILI(2) 63 FORMAT('ISPILI(1),ISPILI(2) = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,64)IX1JSW,IY1JSW 64 FORMAT('IX1JSW,IY1JSW = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,65)IX1NSW,IY1NSW 65 FORMAT('IX1NSW,IY1NSW = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,66)ASPIBA(1),ASPIBA(2) 66 FORMAT('ASPIBA(1),ASPIBA(2) = ',2E15.7) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C ****************************************** C ** STEP 1-- ** C ** CARRY OUT PRE-PLOT ACTIVITIES. ** C ****************************************** C IF(IFIRST.EQ.'YES')GOTO1000 GOTO1090 C 1000 CONTINUE C ISTEPN='1' IF(IBUGG4.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IOPGRS='ON' IOPG2S='ON' IDELIS='ON' IDRFRS='OFF' IWRLAS='OFF' IWRLES='OFF' IDRTRS='OFF' ICLG2S='OFF' ICLGRS='OFF' C ISTEP=1 ISUBST=1 ISET=1 ISET3=ISET ICH3PA=ICHAPA(ISET3) C IF(ICAS3D.EQ.'OFF') 1CALL PLOTG2(Y,X,Y2,X2,N,Y4,X4,N4,Y5,X5,N5,NUMSET,X3D, 1ICASPL,ICAS3D, 1ISQUAR, 1IVGMSW,IHGMSW, 1XDELMN, 1ISTEP,ISUBST,ISET,ISET3,ICH3PA, 1IOPGRS,IOPG2S,IDELIS,IDRFRS,IWRLAS,IWRLES,IDRTRS,ICLG2S,ICLGRS, 1IHNAME,IHNAM2,IUSE,IVALUE,VALUE,NUMNAM, 1ASETSZ,ISETSY,ISETCL,ISETFI, 1NUMSBR, 1ICAPSW, 1IVSTAR,IVSTOP,IFUNC,NUMCHF,IREPCH,ISWTCH) IF(ICAS3D.EQ.'ON') 1CALL PLOTG3(X,X3D,Y,N,DSIZE, 1X2,Y2,Z2,X4,Y4,Z4,N4,X5,Y5,N5,NUMSET, 1ICASPL,ICAS3D, 1ISQUAR, 1IVGMSW,IHGMSW, 1XDELMN,YDELMN,ZDELMN, 1ISTEP,ISUBST,ISET,ISET3,ICH3PA, 1IOPGRS,IOPG2S,IDELIS,IDRFRS,IWRLAS,IWRLES,IDRTRS,ICLG2S,ICLGRS, 1ICAPSW, 1IHNAME,IHNAM2,IUSE,IVALUE,VALUE,NUMNAM, 1IVSTAR,IVSTOP,IFUNC,NUMCHF,IREPCH,ISWTCH) IF(IERRG4.EQ.'YES')GOTO9000 C 1090 CONTINUE C C ******************************************************** C ** STEP 2-- ** C ** GENERATE THE TRACES OF THE PLOT. ** C ** LOOP THROUGH THE VARIOUS LEVELS OF D-- ** C ** ONE LEVEL AT A TIME--SO AS TO INDIVIDUALLY ** C ** GENERATE EACH TRACE. ** C ** FOR A GIVEN LEVEL, COLLECT ALL Y AND X ** C ** DATA WHICH HAVE THE CORRESPONDING D VALUE ** C ** AT THIS LEVEL. PLACE THESE Y AND X PAIRS ** C ** IN THE INTERMEDIATE VECTORS Y2 AND X2 ** C ** IN ORDER TO BE PLOTTED. ** C ** THE PLOT WILL BE GENERATED 1 'CURVE' AT A TIME-- ** C ** THAT IS FOR 1 LEVEL OF D AT A TIME. ** C ** FOR EFFICIENCY SAKE, ** C ** TREAT EACH OF THE FOLLOWING ** C ** 4 CASES SEPARATELY-- ** C ** 1) ONLY ONE SUBSET AND N NOT EXCEED MXNPPC; C ** 2) ONLY ONE SUBSET BUT N EXCEEDS MXNPPC; C ** 3) MORE THAN ONE SUBSET BUT NI NOT EXCEED MXNPPC; C ** 4) MORE THAN ONE SUBSET AND NI EXCEEDS MXNPPC; C ******************************************************** C ISTEPN='2' IF(IBUGG4.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ICASPL.EQ.'NONE')GOTO1900 C IOPGRS='OFF' IOPG2S='OFF' IDELIS='OFF' IDRFRS='OFF' IWRLAS='OFF' IWRLES='OFF' IDRTRS='ON' ICLG2S='OFF' ICLGRS='OFF' C IF(NUMSET.LE.0)GOTO1900 CCCCC AUGUST 1992. HANDLE SYMBOL PLOT CASE SEPARATELY IF(ICASPL.EQ.'SYMB')GOTO1500 CCCCC AUGUST 1992. BUG IF NUMSET = 101, 201, (OR MAX TRACES + 1). CCCCC GOES TO WRONG CASE, USES WRONG VALUE OF N AND GENERATES CCCCC EXTRA MISCELLANEOUS LINES THAT ARE NOT DESIRED. CHECK FOR CCCCC CASE OF FIRST PASS. IF(IFIRST.EQ.'NO')THEN IF(N.LE.MXNPPC)GOTO1300 IF(N.GT.MXNPPC)GOTO1400 ENDIF CCCCC END CHANGE IF(NUMSET.LE.1.AND.N.LE.MXNPPC)GOTO1100 IF(NUMSET.LE.1.AND.N.GT.MXNPPC)GOTO1200 IF(NUMSET.GT.1.AND.N.LE.MXNPPC)GOTO1300 IF(NUMSET.GT.1.AND.N.GT.MXNPPC)GOTO1400 C WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1106) 1106 FORMAT('***** INTERNAL ERROR IN PLOTGE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1107) 1107 FORMAT(' 4-WAY BRANCH UNDER STEP 2 NOT SATISFIED.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1108) 1108 FORMAT(' NUMSET,N,MXNPPC = ',3I8) CALL DPWRST('XXX','BUG ') IERRG4='YES' GOTO9000 C C ******************************************************** C ** STEP 2.1-- ** C ** TREAT THE CASE WHERE ** C ** THE NUMBER OF TRACES = 1 AND ** C ** THE NUMBER OF PLOT POINTS DOES NOT EXCEED MXNPPC ** C ******************************************************** C 1100 CONTINUE C ISTEPN='2.1' IF(IBUGG4.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ISTEP=2 ISUBST=1 ISET=1 ISET3=ISET ICH3PA=ICHAPA(ISET3) C IF(ICAS3D.EQ.'OFF') 1CALL PLOTG2(Y,X,Y3,X3,N,Y4,X4,N4,Y5,X5,N5,NUMSET,X3D, 1ICASPL,ICAS3D, 1ISQUAR, 1IVGMSW,IHGMSW, 1XDELMN, 1ISTEP,ISUBST,ISET,ISET3,ICH3PA, 1IOPGRS,IOPG2S,IDELIS,IDRFRS,IWRLAS,IWRLES,IDRTRS,ICLG2S,ICLGRS, 1IHNAME,IHNAM2,IUSE,IVALUE,VALUE,NUMNAM, 1ASETSZ,ISETSY,ISETCL,ISETFI, 1NUMSBR, 1ICAPSW, 1IVSTAR,IVSTOP,IFUNC,NUMCHF,IREPCH,ISWTCH) IF(ICAS3D.EQ.'ON') 1CALL PLOTG3(X,X3D,Y,N,DSIZE, 1X3,Y3,Z3,X4,Y4,Z4,N4,X5,Y5,N5,NUMSET, 1ICASPL,ICAS3D, 1ISQUAR, 1IVGMSW,IHGMSW, 1XDELMN,YDELMN,ZDELMN, 1ISTEP,ISUBST,ISET,ISET3,ICH3PA, 1IOPGRS,IOPG2S,IDELIS,IDRFRS,IWRLAS,IWRLES,IDRTRS,ICLG2S,ICLGRS, 1ICAPSW, 1IHNAME,IHNAM2,IUSE,IVALUE,VALUE,NUMNAM, 1IVSTAR,IVSTOP,IFUNC,NUMCHF,IREPCH,ISWTCH) C GOTO1900 C C ************************************************ C ** STEP 2.2-- ** C ** TREAT THE CASE WHERE ** C ** THE NUMBER OF TRACES = 1 AND ** C ** THE NUMBER OF PLOT POINTS EXCEEDS MXNPPC ** C ************************************************ C 1200 CONTINUE C ISTEPN='2.2' IF(IBUGG4.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ISTEP=2 ISUBST=2 ISET=1 ISET3=ISET ICH3PA=ICHAPA(ISET3) C NUMPAS=(N/MXNPPC)+1 IF(N.EQ.MXNPPC)NUMPAS=1 C IMAX=1 DO1210IPASS=1,NUMPAS IMIN=IMAX IMAX=IMIN+MXNPPC-1 IF(IMAX.GT.N)IMAX=N C N2=0 DO1220I=IMIN,IMAX N2=N2+1 Y2(N2)=Y(I) X2(N2)=X(I) X3D2(N2)=X3D(I) DSYMB(N2)=DSIZE(I) 1220 CONTINUE C IF(ICAS3D.EQ.'OFF') 1CALL PLOTG2(Y2,X2,Y3,X3,N2,Y4,X4,N4,Y5,X5,N5,NUMSET,X3D2, 1ICASPL,ICAS3D, 1ISQUAR, 1IVGMSW,IHGMSW, 1XDELMN, 1ISTEP,ISUBST,ISET,ISET3,ICH3PA, 1IOPGRS,IOPG2S,IDELIS,IDRFRS,IWRLAS,IWRLES,IDRTRS,ICLG2S,ICLGRS, 1IHNAME,IHNAM2,IUSE,IVALUE,VALUE,NUMNAM, 1ASETSZ,ISETSY,ISETCL,ISETFI, 1NUMSBR, 1ICAPSW, 1IVSTAR,IVSTOP,IFUNC,NUMCHF,IREPCH,ISWTCH) IF(ICAS3D.EQ.'ON') 1CALL PLOTG3(X2,X3D2,Y2,N2,DSYMB, 1X3,Y3,Z3,X4,Y4,Z4,N4,X5,Y5,N5,NUMSET, 1ICASPL,ICAS3D, 1ISQUAR, 1IVGMSW,IHGMSW, 1XDELMN,YDELMN,ZDELMN, 1ISTEP,ISUBST,ISET,ISET3,ICH3PA, 1IOPGRS,IOPG2S,IDELIS,IDRFRS,IWRLAS,IWRLES,IDRTRS,ICLG2S,ICLGRS, 1ICAPSW, 1IHNAME,IHNAM2,IUSE,IVALUE,VALUE,NUMNAM, 1IVSTAR,IVSTOP,IFUNC,NUMCHF,IREPCH,ISWTCH) 1210 CONTINUE C GOTO1900 C C ************************************************************** C ** STEP 2.3-- ** C ** TREAT THE CASE WHERE ** C ** THERE ARE 2 OR MORE TRACES BUT ** C ** THE TOTAL NUMBER OF PLOT POINTS DOES NOT EXCEED MXNPPC ** C ************************************************************** C 1300 CONTINUE C ISTEPN='2.3' IF(IBUGG4.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C DO1310ISET=1,NUMSET C ISTEP=2 ISUBST=3 ISET3=ISET C CCCCC THE FOLLOWING LINE WAS ADDED DECEMBER 1994 CCCCC TO HAVE AN EXACT IDENTIFIER => CHARACTER MAPPING IF(ICHMAP.EQ.'EXAC')ISET3=XIDC(ISET)+0.5 C CCCCC ICH3PA=ICHAPA(ISET3) C ASETSZ=1.0 C JSET=XIDC(ISET)+0.5 CCCCC NOVEMBER 1993. COMMENT OUT FOLLOWING LINE CCCCC PIE CHART MODIFED TO HANDLE ATTRIBUTE SETTINGS. CCCCC IF(ICASPL.EQ.'PIEC')ISET3=1 CCCCC AUGUST 1992. FOLLOWING LINE ADDED FOR VECTOR PLOT IF(ICASPL.EQ.'VECT')ISET3=1 IFACT=20 IF(IFENSW.EQ.'ON')IFACT=24 CCCCC FEBRUARY 2003: VIOLIN PLOT IF(ICASPL.EQ.'VIPL')IFACT=IFACT+1 IF(ICASPL.EQ.'MDBP')ISET3=JSET-IFACT*((JSET-1)/IFACT) IF(ICASPL.EQ.'MEBP')ISET3=JSET-IFACT*((JSET-1)/IFACT) IF(ICASPL.EQ.'MDIP')ISET3=JSET-5*((JSET-1)/5) IF(ICASPL.EQ.'MEIP')ISET3=JSET-5*((JSET-1)/5) IF(ICASPL.EQ.'MRIP')ISET3=JSET-5*((JSET-1)/5) IF(ICASPL.EQ.'MMIP')ISET3=JSET-5*((JSET-1)/5) IF(ICASPL.EQ.'ERBA')ISET3=JSET-7*((JSET-1)/7) IF(ICASPL.EQ.'VIPL')ISET3=JSET-IFACT*((JSET-1)/IFACT) CCCCC AUGUST 2001. ADD FOLLOWING LINE FOR CONSENSUS MEAN PLOT IF(ICASPL.EQ.'CMPL')ISET3=JSET-5*((JSET-1)/5) CCCCC THE FOLLOWING 2 LINES WERE ADDED FOR DES. OF EXP. PLOTS MAY 1989 IF(ICASPL.EQ.'DEXP'.AND.JSET.NE.NUMSET)ISET3=1 IF(ICASPL.EQ.'DEXP'.AND.JSET.EQ.NUMSET)ISET3=2 CCCCC THE FOLLOWING LINE WAS ADDED FOR BLOCK PLOTS JUNE 1992 (JJF) IF(ICASPL.EQ.'BLPL'.AND.IFIRST.EQ.'NO')ISET3=100 CCCCC THE FOLLOWING LINE WAS ADDED FOR BLOCK PLOT JUNE 1995 CCCCC VERTEX JUNK CHARACTER PROBLEM JUNE 1995 IF(ICASPL.EQ.'BLPL'.AND.ISET3.GT.100)ISET3=100 IF(ICASPL.EQ.'PCPL'.OR.ICASPL.EQ.'PCPG')ISET3=MOD(JSET-1,100)+1 C CCCCC THE FOLLOWING SECTION WAS ADDED DECEMBER 1994 CCCCC ICH3PA=ICHAPA(ISET3) IF(ISET3.LE.100)THEN ICH3PA=ICHAPA(ISET3) ENDIF IF(ISET3.GT.100)THEN WRITE(ICOUT,1311) 1311 FORMAT('***** ERROR IN PLOTGE AT STEP 2.3--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1312) 1312 FORMAT(' AN ATTEMPT WAS MADE TO REFERENCE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1313)ISET3 1313 FORMAT(' ELEMENT ',I8,' OF THE DATAPLOT INTERNAL') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1314) 1314 FORMAT(' TRACE CHARACTER ARRAY. THIS IS ILLEGAL.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1315) 1315 FORMAT(' THE MAX NUMBER OF TRACE CHARACTERS THAT CAN') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1316) 1316 FORMAT(' BE SET IS 100') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1317) 1317 FORMAT(' POSSIBLE CURE--HAS THE ANALYST CHANGED THE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1318) 1318 FORMAT(' CHARACTER MAPPING EXACT COMMAND TO THE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1319) 1319 FORMAT(' CHARACTER MAPPING RANK COMMAND?') CALL DPWRST('XXX','BUG ') IERRG4='YES' GOTO9000 ENDIF C N2=0 CCCCC AUGUST 1992. HANDLE VECTOR PLOT WITH VARIABLE SIZE ARROW CCCCC SEPARATELY. IF(ICASPL.EQ.'VVAR')THEN DO1330I=1,N I2=I IF(D(I2).EQ.XIDC(ISET))THEN N2=N2+1 Y2(N2)=Y(I2) X2(N2)=X(I2) X3D2(N2)=X3D(I2) DSYMB(N2)=DSIZE(I2) ENDIF 1330 CONTINUE C ELSEIF(ICASPL.EQ.'PCPG')THEN DO1339I=1,N I2=I IF(D(I2).EQ.XIDC(ISET))THEN N2=N2+1 Y2(N2)=Y(I2) X2(N2)=X(I2) X3D2(N2)=X3D(I2) DSYMB(N2)=DSIZE(I2) ISET3=DFILL(I2) ENDIF 1339 CONTINUE ELSE DO1320I=1,N I2=I IF(D(I2).EQ.XIDC(ISET))THEN N2=N2+1 Y2(N2)=Y(I2) X2(N2)=X(I2) X3D2(N2)=X3D(I2) DSYMB(N2)=DSIZE(I2) ENDIF 1320 CONTINUE ENDIF C IF(ICASPL.EQ.'MDBP')GOTO1340 IF(ICASPL.EQ.'MEBP')GOTO1340 C IF(ICASPL.EQ.'VIPL')GOTO1350 C GOTO1349 1340 CONTINUE CCCCC THE FOLLOWING 5 LINES WERE INSERTED BY ALAN. FEBRUARY 1989 IF(IHORSW.EQ.'OFF')GOTO1345 IF(ISET3.EQ.20)YSAVE=X2(1) IF(ISET3.GT.20.AND.N2.EQ.1.AND.X2(1).EQ.YSAVE)ICH3PA='BLAN' GOTO1349 1345 CONTINUE IF(ISET3.EQ.20)YSAVE=Y2(1) IF(ISET3.GT.20.AND.N2.EQ.1.AND.Y2(1).EQ.YSAVE)ICH3PA='BLAN' 1349 CONTINUE C 1350 CONTINUE CCCCC THE FOLLOWING 5 LINES WERE INSERTED BY ALAN. FEBRUARY 1989 IF(IHORSW.EQ.'OFF')GOTO1355 IF(ISET3.EQ.21)YSAVE=X2(1) IF(ISET3.GT.21.AND.N2.EQ.1.AND.X2(1).EQ.YSAVE)ICH3PA='BLAN' GOTO1359 1355 CONTINUE IF(ISET3.EQ.21)YSAVE=Y2(1) IF(ISET3.GT.21.AND.N2.EQ.1.AND.Y2(1).EQ.YSAVE)ICH3PA='BLAN' 1359 CONTINUE C IF(IBUGG4.EQ.'ON')WRITE(ICOUT,1361)N2,ISORSW,ICASPL,ICAS3D,I3DPRO, 1ICH3PA 1361 FORMAT('N2,ISORSW,ICASPL,ICAS3D,I3DPRO,ICH3PA = ', 1I8,2X,A4,2X,A4,2X,A4,2X,A4,2X,A4) IF(IBUGG4.EQ.'ON')CALL DPWRST('XXX','BUG ') C IF(ICAS3D.EQ.'OFF') 1CALL PLOTG2(Y2,X2,Y3,X3,N2,Y4,X4,N4,Y5,X5,N5,NUMSET,X3D2, 1ICASPL,ICAS3D, 1ISQUAR, 1IVGMSW,IHGMSW, 1XDELMN, 1ISTEP,ISUBST,ISET,ISET3,ICH3PA, 1IOPGRS,IOPG2S,IDELIS,IDRFRS,IWRLAS,IWRLES,IDRTRS,ICLG2S,ICLGRS, 1IHNAME,IHNAM2,IUSE,IVALUE,VALUE,NUMNAM, 1ASETSZ,ISETSY,ISETCL,ISETFI, 1NUMSBR, 1ICAPSW, 1IVSTAR,IVSTOP,IFUNC,NUMCHF,IREPCH,ISWTCH) IF(ICAS3D.EQ.'ON') 1CALL PLOTG3(X2,X3D2,Y2,N2,DSYMB, 1X3,Y3,Z3,X4,Y4,Z4,N4,X5,Y5,N5,NUMSET, 1ICASPL,ICAS3D, 1ISQUAR, 1IVGMSW,IHGMSW, 1XDELMN,YDELMN,ZDELMN, 1ISTEP,ISUBST,ISET,ISET3,ICH3PA, 1IOPGRS,IOPG2S,IDELIS,IDRFRS,IWRLAS,IWRLES,IDRTRS,ICLG2S,ICLGRS, 1ICAPSW, 1IHNAME,IHNAM2,IUSE,IVALUE,VALUE,NUMNAM, 1IVSTAR,IVSTOP,IFUNC,NUMCHF,IREPCH,ISWTCH) C 1310 CONTINUE C GOTO1900 C C ************************************************* C ** STEP 2.4-- ** C ** TREAT THE CASE WHERE ** C ** THERE ARE 2 OR MORE TRACES AND ** C ** THE TOTAL NUMBER OF POINTS EXCEEDS MXNPPC ** C ************************************************* C 1400 CONTINUE C ISTEPN='2.4' IF(IBUGG4.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C DO1410ISET=1,NUMSET C ISTEP=2 ISUBST=4 ISET3=ISET CCCCC THE FOLLOWING LINE WAS ADDED DECEMBER 1994 CCCCC TO HAVE AN EXACT IDENTIFIER => CHARACTER MAPPING IF(ICHMAP.EQ.'EXAC')ISET3=XIDC(ISET)+0.5 C CCCCC ICH3PA=ICHAPA(ISET3) C ASETSZ=1.0 C JSET=XIDC(ISET)+0.5 CCCCC NOVEMBER 1993. COMMENT OUT FOLLOWING LINE CCCCC PIE CHART MODIFED TO HANDLE ATTRIBUTE SETTINGS. CCCCC IF(ICASPL.EQ.'PIEC')ISET3=1 CCCCC AUGUST 1992. FOLLOWING LINE ADDED FOR VECTOR PLOT IF(ICASPL.EQ.'VECT')ISET3=1 IFACT=20 IF(IFENSW.EQ.'ON')IFACT=24 IF(ICASPL.EQ.'VIPL')IFACT=IFACT+1 IF(ICASPL.EQ.'MDBP')ISET3=JSET-IFACT*((JSET-1)/IFACT) IF(ICASPL.EQ.'MEBP')ISET3=JSET-IFACT*((JSET-1)/IFACT) IF(ICASPL.EQ.'MDIP')ISET3=JSET-5*((JSET-1)/5) IF(ICASPL.EQ.'MEIP')ISET3=JSET-5*((JSET-1)/5) IF(ICASPL.EQ.'MRIP')ISET3=JSET-5*((JSET-1)/5) IF(ICASPL.EQ.'MMIP')ISET3=JSET-5*((JSET-1)/5) IF(ICASPL.EQ.'ERBA')ISET3=JSET-7*((JSET-1)/7) IF(ICASPL.EQ.'VIPL')ISET3=JSET-IFACT*((JSET-1)/IFACT) CCCCC AUGUST 2001. ADD FOLLOWING LINE FOR CONSENSUS MEAN PLOT IF(ICASPL.EQ.'CMPL')ISET3=JSET-5*((JSET-1)/5) CCCCC THE FOLLOWING 2 LINES WERE ADDED FOR DES. OF EXP. PLOTS MAY 1989 IF(ICASPL.EQ.'DEXP'.AND.JSET.NE.NUMSET)ISET3=1 IF(ICASPL.EQ.'DEXP'.AND.JSET.EQ.NUMSET)ISET3=2 CCCCC THE FOLLOWING LINE WAS ADDED FOR BLOCK PLOTS JUNE 1992 (JJF) IF(ICASPL.EQ.'BLPL'.AND.IFIRST.EQ.'NO')ISET3=100 CCCCC THE FOLLOWING LINE WAS ADDED FOR BLOCK PLOT JUNE 1995 CCCCC VERTEX JUNK CHARACTER PROBLEM JUNE 1995 IF(ICASPL.EQ.'BLPL'.AND.ISET3.GT.100)ISET3=100 C CCCCC THE FOLLOWING SECTION WAS ADDED DECEMBER 1994 CCCCC ICH3PA=ICHAPA(ISET3) IF(ISET3.LE.100)THEN ICH3PA=ICHAPA(ISET3) ENDIF IF(ISET3.GT.100)THEN WRITE(ICOUT,1411) 1411 FORMAT('***** ERROR IN PLOTGE AT STEP 2.4--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1412) 1412 FORMAT(' AN ATTEMPT WAS MADE TO REFERENCE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1413)ISET3 1413 FORMAT(' ELEMENT ',I8,' OF THE DATAPLOT INTERNAL') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1414) 1414 FORMAT(' TRACE CHARACTER ARRAY. THIS IS ILLEGAL.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1415) 1415 FORMAT(' THE MAX NUMBER OF TRACE CHARACTERS THAT CAN') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1416) 1416 FORMAT(' BE SET IS 100') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1417) 1417 FORMAT(' POSSIBLE CURE--HAS THE ANALYST CHANGED THE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1418) 1418 FORMAT(' CHARACTER MAPPING EXACT COMMAND TO THE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1419) 1419 FORMAT(' CHARACTER MAPPING RANK COMMAND?') CALL DPWRST('XXX','BUG ') IERRG4='YES' GOTO9000 ENDIF C IMIN=1 1420 CONTINUE IMORE='NO' C N2=0 CCCCC AUGUST 1992. HANDLE VECTOR PLOT WITH VARIABLE SIZE ARROW CCCCC SEPARATELY IF(ICASPL.EQ.'VVAR')GOTO1489 DO1430I=IMIN,N I2=I IF(D(I2).EQ.XIDC(ISET))GOTO1435 GOTO1430 1435 CONTINUE N2=N2+1 IF(N2.GE.MXNPPC)GOTO1438 Y2(N2)=Y(I2) X2(N2)=X(I2) X3D2(N2)=X3D(I2) 1430 CONTINUE GOTO1439 1438 CONTINUE IMIN=I2 IMORE='YES' 1439 CONTINUE GOTO1499 C 1489 CONTINUE DO1490I=IMIN,N I2=I ASETSZ=DSIZE(I2) IF(D(I2).EQ.XIDC(ISET))GOTO1495 GOTO1490 1495 CONTINUE N2=N2+1 IF(N2.GE.MXNPPC)GOTO1498 Y2(N2)=Y(I2) X2(N2)=X(I2) X3D2(N2)=X3D(I2) DSYMB(N2)=DSIZE(I2) 1490 CONTINUE GOTO1499 1498 CONTINUE IMIN=I2 IMORE='YES' 1499 CONTINUE C IF(ICASPL.EQ.'MDBP')GOTO1440 IF(ICASPL.EQ.'MEBP')GOTO1440 IF(ICASPL.EQ.'VIPL')GOTO1450 GOTO1449 1440 CONTINUE CCCCC THE FOLLOWING 5 LINES WERE INSERTED BY ALAN. FEBRUARY 1989 IF(IHORSW.EQ.'OFF')GOTO1445 IF(ISET3.EQ.20)YSAVE=X2(1) IF(ISET3.GT.20.AND.N2.EQ.1.AND.X2(1).EQ.YSAVE)ICH3PA='BLAN' GOTO1449 1445 CONTINUE IF(ISET3.EQ.20)YSAVE=Y2(1) IF(ISET3.GT.20.AND.N2.EQ.1.AND.Y2(1).EQ.YSAVE)ICH3PA='BLAN' 1449 CONTINUE C 1450 CONTINUE CCCCC THE FOLLOWING 5 LINES WERE INSERTED BY ALAN. FEBRUARY 1989 IF(IHORSW.EQ.'OFF')GOTO1455 IF(ISET3.EQ.20)YSAVE=X2(1) IF(ISET3.GT.20.AND.N2.EQ.1.AND.X2(1).EQ.YSAVE)ICH3PA='BLAN' GOTO1459 1455 CONTINUE IF(ISET3.EQ.20)YSAVE=Y2(1) IF(ISET3.GT.20.AND.N2.EQ.1.AND.Y2(1).EQ.YSAVE)ICH3PA='BLAN' 1459 CONTINUE C IF(IBUGG4.EQ.'ON')WRITE(ICOUT,1461)N,NUMSET,ISET,JSET,ISET3,N2, 1 YSAVE 1461 FORMAT('N,NUMSET,ISET,JSET,ISET3,N2,YSAVE = ',6I8,E15.7) IF(IBUGG4.EQ.'ON')CALL DPWRST('XXX','BUG ') IF(IBUGG4.EQ.'ON')WRITE(ICOUT,1462)N2,ISORSW,ICASPL,ICAS3D,I3DPRO, 1ICH3PA 1462 FORMAT('N2,ISORSW,ICASPL,ICAS3D,I3DPRO,ICH3PA = ', 1I8,2X,A4,2X,A4,2X,A4,2X,A4,2X,A4) IF(IBUGG4.EQ.'ON')CALL DPWRST('XXX','BUG ') C IF(ICAS3D.EQ.'OFF') 1CALL PLOTG2(Y2,X2,Y3,X3,N2,Y4,X4,N4,Y5,X5,N5,NUMSET,X3D2, 1ICASPL,ICAS3D, 1ISQUAR, 1IVGMSW,IHGMSW, 1XDELMN, 1ISTEP,ISUBST,ISET,ISET3,ICH3PA, 1IOPGRS,IOPG2S,IDELIS,IDRFRS,IWRLAS,IWRLES,IDRTRS,ICLG2S,ICLGRS, 1IHNAME,IHNAM2,IUSE,IVALUE,VALUE,NUMNAM, 1ASETSZ,ISETSY,ISETCL,ISETFI, 1NUMSBR, 1ICAPSW, 1IVSTAR,IVSTOP,IFUNC,NUMCHF,IREPCH,ISWTCH) IF(ICAS3D.EQ.'ON') 1CALL PLOTG3(X2,X3D2,Y2,N2,DSYMB, 1X3,Y3,Z3,X4,Y4,Z4,N4,X5,Y5,N5,NUMSET, 1ICASPL,ICAS3D, 1ISQUAR, 1IVGMSW,IHGMSW, 1XDELMN,YDELMN,ZDELMN, 1ISTEP,ISUBST,ISET,ISET3,ICH3PA, 1IOPGRS,IOPG2S,IDELIS,IDRFRS,IWRLAS,IWRLES,IDRTRS,ICLG2S,ICLGRS, 1ICAPSW, 1IHNAME,IHNAM2,IUSE,IVALUE,VALUE,NUMNAM, 1IVSTAR,IVSTOP,IFUNC,NUMCHF,IREPCH,ISWTCH) C IF(IMORE.EQ.'YES')GOTO1420 C 1410 CONTINUE C GOTO1900 C C ************************************************************** C ** STEP 2.5-- ** C ** TREAT THE SYMBOL PLOT CASE WHERE ** C ** LOOP THROUGH AND PLOT EACH POINT INDIVIUALLY ** C ** SET SIZE, FILL, COLOR, SYMBOL FOR EACH POINT ** C ************************************************************** C 1500 CONTINUE C ISTEPN='2.5' IF(IBUGG4.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ISTEP=2 ISUBST=5 ISET3=ISET ICH3PA=ICHAPA(ISET3) C ICH3PA=ICHAPA(ISET3) C N2=1 DO1520I=1,N I2=I Y2(N2)=Y(I2) X2(N2)=X(I2) X3D2(N2)=X3D(I2) ASETSZ=DSIZE(I2) ISETSY=INT(DSYMB(I2)+0.5) IF(ISETSY.LT.1.OR.ISETSY.GT.MAXCH2)ISETSY=1 ISETFI=INT(DFILL(I2)+0.5) ISETCL=INT(DCOLOR(I2)+0.5) IF(ISETCL.LT.1.OR.ISETCL.GT.MAXCH2)ISETCL=1 C CALL PLOTG2(Y2,X2,Y3,X3,N2,Y4,X4,N4,Y5,X5,N5,NUMSET,X3D2, 1ICASPL,ICAS3D, 1ISQUAR, 1IVGMSW,IHGMSW, 1XDELMN, 1ISTEP,ISUBST,ISET,ISET3,ICH3PA, 1IOPGRS,IOPG2S,IDELIS,IDRFRS,IWRLAS,IWRLES,IDRTRS,ICLG2S,ICLGRS, 1IHNAME,IHNAM2,IUSE,IVALUE,VALUE,NUMNAM, 1ASETSZ,ISETSY,ISETCL,ISETFI, 1NUMSBR, 1ICAPSW, 1IVSTAR,IVSTOP,IFUNC,NUMCHF,IREPCH,ISWTCH) 1520 CONTINUE C GOTO1900 C 1900 CONTINUE C C ************************************************ C ** STEP 3-- ** C ** CARRY OUT POST-PLOT ACTIVITIES-- ** C ** GENERATE THE FRAME, TITLE, LABELS, ETC. ** C ** FINISH UP DETAILS FOR THE PLOT ** C ** (E.G., MAKING HARDCOPIES IF CALLED FOR). ** C ************************************************ C IF(ILAST.EQ.'YES')GOTO2100 GOTO2190 C 2100 CONTINUE C ISTEPN='3' IF(IBUGG4.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IOPGRS='OFF' IOPG2S='OFF' IDELIS='OFF' IDRFRS='ON' IWRLAS='ON' IWRLES='ON' IDRTRS='OFF' ICLG2S='ON' ICLGRS='ON' C ISTEP=3 ISUBST=1 ISET=1 ISET3=ISET ICH3PA=ICHAPA(ISET3) C IF(ICAS3D.EQ.'OFF') 1CALL PLOTG2(Y,X,Y2,X2,N,Y4,X4,N4,Y5,X5,N5,NUMSET,X3D, 1ICASPL,ICAS3D, 1ISQUAR, 1IVGMSW,IHGMSW, 1XDELMN, 1ISTEP,ISUBST,ISET,ISET3,ICH3PA, 1IOPGRS,IOPG2S,IDELIS,IDRFRS,IWRLAS,IWRLES,IDRTRS,ICLG2S,ICLGRS, 1IHNAME,IHNAM2,IUSE,IVALUE,VALUE,NUMNAM, 1ASETSZ,ISETSY,ISETCL,ISETFI, 1NUMSBR, 1ICAPSW, 1IVSTAR,IVSTOP,IFUNC,NUMCHF,IREPCH,ISWTCH) IF(ICAS3D.EQ.'ON') 1CALL PLOTG3(X,X3D,Y,N,DSIZE, 1X2,Y2,Z2,X4,Y4,Z4,N4,X5,Y5,N5,NUMSET, 1ICASPL,ICAS3D, 1ISQUAR, 1IVGMSW,IHGMSW, 1XDELMN,YDELMN,ZDELMN, 1ISTEP,ISUBST,ISET,ISET3,ICH3PA, 1IOPGRS,IOPG2S,IDELIS,IDRFRS,IWRLAS,IWRLES,IDRTRS,ICLG2S,ICLGRS, 1ICAPSW, 1IHNAME,IHNAM2,IUSE,IVALUE,VALUE,NUMNAM, 1IVSTAR,IVSTOP,IFUNC,NUMCHF,IREPCH,ISWTCH) C 2190 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE CCCCC ADD FOLLOWING SECTION FOR DUANE PLOTS. MAY 1998. IF(ICASPL.EQ.'DUAN')THEN IX1TSC=IX1TMP IX2TSC=IX2TMP IY1TSC=IY1TMP IY2TSC=IY2TMP ENDIF C IERROR=IERRG4 IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'OTGE')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF PLOTGE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)N,NUMSET 9012 FORMAT('N,NUMSET = ',2I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)ICASPL,ICAS3D,I3DPRO 9013 FORMAT('ICASPL,ICAS3D,I3DPRO,I3DPRO = ',A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)ISQUAR 9014 FORMAT('ISQUAR = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9024)YSAVE 9024 FORMAT('YSAVE = ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9025)XDELMN 9025 FORMAT('XDELMN = ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9028)IBUGG4 9028 FORMAT('IBUGG4 = ',A4) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE PLOTG2(Y,X,PY,PX,NP,PY2,PX2,NP2,PY3,PX3,NP3,NUMSET, 1X3D, 1ICASPL,ICAS3D, 1ISQUAR, 1IVGMSW,IHGMSW, 1XDELMN, 1ISTEP,ISUBST,ISET,ISET3,ICH3PA, 1IOPGRS,IOPG2S,IDELIS,IDRFRS,IWRLAS,IWRLES,IDRTRS,ICLG2S,ICLGRS, 1IHNAME,IHNAM2,IUSE,IVALUE,VALUE,NUMNAM, CCCCC AUGUST 1992. ADD FOLLOWING LINE 1ASETSZ,ISETSY,ISETCL,ISETFI, 1NUMSBR, 1ICAPSW, 1IVSTAR,IVSTOP,IFUNC,NUMCHF,IREPCH,ISWTCH) C C PURPOSE--GENERATE A COMPLETE 2-D PLOT OF A SINGLE TRACE OF Y VERSUS X C (INCLUDING FRAME, TICS, LEGENDS, ETC.) C C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--83.6 C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MAY 1983. C UPDATED --SEPTEMBER 1988. BIHISTOGRAM C UPDATED --FEBRUARY 1989. HORIZONTAL PLOT SWITCH (ALAN) C UPDATED --FEBRUARY 1989. DEVICE POWER (ALAN) C UPDATED --APRIL 1989. ANIMATION C UPDATED --MAY 1989. HAZARD PLOT C UPDATED --MARCH 1990. X11 PATCH C UPDATED --APRIL 1992. ISET3,ISET3S TO ISET,ISET3 C UPDATED --MAY 1992. AUTO CLOSE/OPEN OF DEVICE 3 (JJF) C UPDATED --MAY 1992. DEBUG STATEMENTS C UPDATED --MAY 1992. IBUGXX, ISUBXX, IERRXX C UPDATED --MAY 1992. BUG FOR MAXDEV C UPDATED --AUGUS T 1992. SHADOW FOR BOX C UPDATED --AUGUST 1992. UPDATE FOR SYMBOL PLOT C UPDATED --OCTOBER 1993. UPDATE FOR REGION BASE INTER C UPDATED --FEBRUARY 1994. VECTOR PLOT = PRE-ERASE OFF C UPDATED --MARCH 1994. REGION BASE INTERPOLATE C UPDATED --AUGUST 1995 ARGUMENT LIST TO DPWRLE C UPDATED --JULY 1996 DEVICE FONT C UPDATED --OCTOBER 1996. QWIN PATCH C UPDATED --APRIL 1997. SUPPORT FOR AUTOMATICALLY C SAVING X11 PIXMAPS C UPDATED --DECEMBER 1997. GENERALIZE PIXMAPS TO OTHER C DEVICE C UPDATED --NOVEMBER 1999. ARGUMENT TO DPWRLA C UPDATED --DECEMBER 1999. IMPLEMENT SUBREGIONS C UPDATED --DECEMBER 1999. CROSS TABULATE, DEX CONTOUR C PLOTS AUTOMATICALLY SET CHAR 1 C TO ZVAL C UPDATED --JANUARY 2000. ADD X3D TO ARGUMENT LIST, PASS C TO DPDRCH C UPDATED --FEBRUARY 2003. SET PRE-SORT OFF FOR VIOLIN C PLOT C UPDATED --MARCH 2003. SET PRE-SORT OFF FOR PARALLEL C COORDINATES PLOT C UPDATED --MAY 2003. GROUP PARALLEL COORD PLOT C HANDLES "TRACES" DIFFERENTLY C UPDATED --FEBRUARY 2006. FOR DEVICE 1 LATEX, IF C CAPTURE SWITCH ON, SEND OUTPUT C TO CAPTURE FILE RATHER THAN C THE SCREEN C C-----FOR NON-COMMON VARIABLES----------------------------------------- C CHARACTER*4 ICONT C CHARACTER*4 ICAPSW C CHARACTER*4 ISQUAR C CHARACTER*4 IVGMSW CHARACTER*4 IHGMSW C CHARACTER*4 ICASPL CHARACTER*4 ICAS3D C CHARACTER*4 ICH3PA C CHARACTER*4 ILI2SW CHARACTER*4 ILI2PA CHARACTER*4 ILI2CO C CHARACTER*4 ICH2SW CHARACTER*4 ICH2PA CHARACTER*4 ICH2FO CHARACTER*4 ICH2CA CHARACTER*4 ICH2JU CHARACTER*4 ICH2DI CHARACTER*4 ICH2FI CHARACTER*4 ICH2CO C CHARACTER*4 IFI2SW CHARACTER*4 IFI2PA CHARACTER*4 IFI2CO C CHARACTER*4 IPA2SW CHARACTER*4 IPA2PA CHARACTER*4 IPA2LI CHARACTER*4 IPA2CO C CHARACTER*4 ISP2SW CHARACTER*4 ISP2LI CHARACTER*4 ISP2CO CHARACTER*4 ISP2DI C CHARACTER*4 IBA2SW CHARACTER*4 IBA2BL CHARACTER*4 IBA2BC CHARACTER*4 IBA2FS CHARACTER*4 IBA2FC CHARACTER*4 IBA2PT CHARACTER*4 IBA2PL CHARACTER*4 IBA2PC CHARACTER*4 IBA2TY CHARACTER*4 IBA2DI C CHARACTER*4 IRE2SW CHARACTER*4 IRE2BL CHARACTER*4 IRE2BC CHARACTER*4 IRE2FS CHARACTER*4 IRE2FC CHARACTER*4 IRE2PT CHARACTER*4 IRE2PL CHARACTER*4 IRE2PC CHARACTER*4 IRE2PZ C CHARACTER*4 IMA2SW CHARACTER*4 IMA2BL CHARACTER*4 IMA2BC CHARACTER*4 IMA2FS CHARACTER*4 IMA2FC CHARACTER*4 IMA2PT CHARACTER*4 IMA2PL CHARACTER*4 IMA2PC C CHARACTER*4 ITE2SW CHARACTER*4 ITE2BL CHARACTER*4 ITE2BC CHARACTER*4 ITE2FS CHARACTER*4 ITE2FC CHARACTER*4 ITE2PT CHARACTER*4 ITE2PL CHARACTER*4 ITE2PC C CHARACTER*4 IOPGRS CHARACTER*4 IOPG2S CHARACTER*4 IDELIS CHARACTER*4 IDRFRS CHARACTER*4 IWRLAS CHARACTER*4 IWRLES CHARACTER*4 IDRTRS CHARACTER*4 ICLG2S CHARACTER*4 ICLGRS C CHARACTER*4 ISYMBL CHARACTER*4 ISPAC C CHARACTER*4 IHNAME CHARACTER*4 IHNAM2 CHARACTER*4 IUSE CHARACTER*4 IFUNC C CHARACTER*1 IREPCH C CHARACTER*4 ITITCV CHARACTER*4 IX1LCV CHARACTER*4 IX2LCV CHARACTER*4 IX3LCV CHARACTER*4 IY1LCV CHARACTER*4 IY2LCV C CCCCC THE FOLLOWING 2 LINES WERE INSERTED FEBRUARY 1989 (ALAN) CHARACTER*4 ISWTCH CHARACTER*4 IPOWER C CCCCC THE FOLLOWING 3 LINES WERE ADDED MAY 1992 (JJF) CHARACTER*4 IBUGXX CHARACTER*4 ISUBXX CHARACTER*4 IERRXX CCCCC THE FOLLOWING LINE WAS ADDED FEBRUARY 1994 CHARACTER*4 ISORZZ C CHARACTER*128 ISTRI2 CHARACTER*128 CTEMP CHARACTER*4 ICODE C C--------------------------------------------------------------------- C DIMENSION Y(*) DIMENSION X(*) DIMENSION X3D(*) DIMENSION PY(*) DIMENSION PX(*) DIMENSION PY2(*) DIMENSION PX2(*) C DIMENSION PY3(*) DIMENSION PX3(*) C DIMENSION IHNAME(*) DIMENSION IHNAM2(*) DIMENSION IUSE(*) DIMENSION IVALUE(*) DIMENSION VALUE(*) DIMENSION IVSTAR(*) DIMENSION IVSTOP(*) DIMENSION IFUNC(*) C DIMENSION ITITCV(4) DIMENSION PTITRV(6) DIMENSION IX1LCV(6) DIMENSION PX1LRV(8) DIMENSION IX2LCV(6) DIMENSION PX2LRV(8) DIMENSION IX3LCV(6) DIMENSION PX3LRV(8) DIMENSION IY1LCV(6) DIMENSION PY1LRV(8) DIMENSION IY2LCV(6) DIMENSION PY2LRV(8) CCCCC ADD FOLLOWING LINE APRIL 1997 CCCCC DIMENSION IADE(128) C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'DPCOPC.INC' INCLUDE 'DPCOGR.INC' INCLUDE 'DPCOBE.INC' CCCCC THE FOLLOWING LINE WAS ADDED MAY 1992 (JJF) INCLUDE 'DPCOF2.INC' CCCCC THE FOLLOWING LINE WAS ADDED APRIL 1997 INCLUDE 'DPCOPM.INC' C C-----COMMON VARIABLES (GENERAL)-------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C PSAVE=-999.0 C ILI2SW='ON' ICH2SW='ON' C IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'OTG2')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF PLOTG2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)ISTEP,ISUBST,ISET,ISET3,ICH3PA 53 FORMAT('ISTEP,ISUBST,ISET,ISET3,ICH3PA = ',4I8,2X,A4) CALL DPWRST('XXX','BUG ') CCCCC THE FOLLOWING 2 LINES WERE ADDED MAY 1992 WRITE(ICOUT,54)IPL2CS 54 FORMAT('IPL2CS = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,62)NP 62 FORMAT('NP = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,63)Y(1),X(1),PY(1),PX(1) 63 FORMAT('Y(1),X(1),PY(1),PX(1) = ',4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,64)Y(2),X(2),PY(2),PX(2) 64 FORMAT('Y(2),X(2),PY(2),PX(2) = ',4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,65)Y(NP),X(NP),PY(NP),PX(NP) 65 FORMAT('Y(NP),X(NP),PY(NP),PX(NP) = ',4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,67)NUMSET 67 FORMAT('NUMSET = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,68)ICASPL,ICAS3D 68 FORMAT('ICASPL,ICAS3D = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,69)ISQUAR,XDELMN 69 FORMAT('ISQUAR,XDELMN = ',A4,2X,E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,71)IOPGRS 71 FORMAT('IOPGRS = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,72)IOPG2S 72 FORMAT('IOPG2S = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,73)IDELIS 73 FORMAT('IDELIS = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,74)IDRFRS 74 FORMAT('IDRFRS = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,75)IWRLAS 75 FORMAT('IWRLAS = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,76)IWRLES 76 FORMAT('IWRLES = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,77)IDRTRS 77 FORMAT('IDRTRS = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,78)ICLG2S 78 FORMAT('ICLG2S = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,79)ICLGRS 79 FORMAT('ICLGRS = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,80)ITEXSY,ITEXSP 80 FORMAT('ITEXSY,ITEXSP = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,81)IMANUF,IMODEL 81 FORMAT('IMANUF,IMODEL = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,82)IREPCH CCC82 FORMAT('IREPCH = ',A1) CCCCC CALL DPWRST('XXX','BUG ') WRITE(ICOUT,83)IBACCO,IANISW 83 FORMAT('IBACCO,IANISW = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,89)IBUGG4,ISUBG4,IERRG4 89 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C ************************************************** C ** STEP 11-- ** C ** EXTRACT SETTINGS FOR THIS PARTICULAR TRACE ** C ************************************************** C CCCCC IF(IOPGRS.EQ.'ON')GOTO1109 CCCCC IF(ICLGRS.EQ.'ON')GOTO1109 C CCCCC IMPLEMENT SUB-REGIONS DECEMBER 1999. CCCCC CHAR, LINE, SPIKE, BAR SETTINGS SHOULD BE BLANK UNTIL ALL CCCCC SUB-REGIONS PLOTTED. THEN SHOULD START WITH FIRST SETTING. CCCCC REGION SETTINGS SHOULD START WITH 1 REGARDLESS. ISET3T=ISET3-NUMSBR IF(ISET3T.LT.1)ISET3T=1 C ICH2PA=ICHAPA(ISET3T) ICH2FO=ICHAFO(ISET3T) ICH2CA=ICHACA(ISET3T) ICH2JU=ICHAJU(ISET3T) ICH2DI=ICHADI(ISET3T) ACH2AN=ACHAAN(ISET3T) ICH2FI=ICHAFI(ISET3T) ICH2CO=ICHACO(ISET3T) PCH2HE=PCHAHE(ISET3T) PCH2WI=PCHAWI(ISET3T) PCH2TH=PCHATH(ISET3T) PCH2HO=PCHAHO(ISET3T) PCH2VO=PCHAVO(ISET3T) ILI2PA=ILINPA(ISET3T) ILI2CO=ILINCO(ISET3T) PLI2TH=PLINTH(ISET3T) IFI2SW=IFILSW(ISET3T) IFI2PA=IFILPA(ISET3T) IFI2CO=IFILCO(ISET3T) PFI2SP=PFILSP(ISET3T) PFI2TH=PFILTH(ISET3T) IPA2SW=IPATSW(ISET3T) IPA2PA=IPATPA(ISET3T) IPA2LI=IPATLI(ISET3T) IPA2CO=IPATCO(ISET3T) PPA2HE=PPATHE(ISET3T) PPA2WI=PPATWI(ISET3T) PPA2SP=PPATSP(ISET3T) PPA2TH=PPATTH(ISET3T) ISP2SW=ISPISW(ISET3T) ISP2LI=ISPILI(ISET3T) ISP2CO=ISPICO(ISET3T) ISP2DI=ISPIDI(ISET3T) CCCCC THE FOLLOWING LINE WAS ADDED FEBRUARY 1989 IF(IHORSW.EQ.'ON')ISP2DI='H' PSP2TH=PSPITH(ISET3T) ASP2BA=ASPIBA(ISET3T) C IBA2SW=IBARSW(ISET3T) ABA2WI=ABARWI(ISET3T) ABA2BA=ABARBA(ISET3T) IBA2BL=IBABLI(ISET3T) IBA2BC=IBABCO(ISET3T) PBA2BT=PBABTH(ISET3T) IBA2FS=IBAFSW(ISET3T) IBA2FC=IBAFCO(ISET3T) IBA2PT=IBAPTY(ISET3T) IBA2PL=IBAPLI(ISET3T) IBA2PC=IBAPCO(ISET3T) IBA2TY=IBARTY(ISET3T) IBA2DI=IBARDI(ISET3T) CCCCC THE FOLLOWING LINE WAS ADDED FEBRUARY 1989 IF(IHORSW.EQ.'ON')IBA2DI='H' PBA2PS=PBAPSP(ISET3T) PBA2PT=PBAPTH(ISET3T) C IRE2SW=IREGSW(ISET3) ARE2WI=AREGWI(ISET3) ARE2BA=AREGBA(ISET3) IRE2BL=IREBLI(ISET3) IRE2BC=IREBCO(ISET3) PRE2BT=PREBTH(ISET3) IRE2FS=IREFSW(ISET3) IRE2FC=IREFCO(ISET3) IRE2PT=IREPTY(ISET3) IRE2PL=IREPLI(ISET3) IRE2PC=IREPCO(ISET3) PRE2PS=PREPSP(ISET3) PRE2PT=PREPTH(ISET3) IRE2PZ=IREBPL CCCCC OCTOBER 1993. ADD FOLLOWING SECTION IF(IREBIN.EQ.'OFF')THEN ARE3BA=ARE2BA ELSE ARE3BA=AREGBA(ISET3+1) IF(ARE3BA.EQ.CPUMAX)ARE3BA=ARE2BA ENDIF C IF(ISET3.LE.NUMSBR)THEN ICH2PA='BLAN' ILI2PA=IRE2BL ILI2CO=IRE2BC PLI2TH=PRE2BT ISP2SW='OFF' IBA2SW='OFF' IFI2SW='OFF' IRE2SW='ON' IRE2PZ='ON' IRE2PC=IRE2FC ENDIF C IMA2SW=IMARSW(ISET3) AMA2WI=AMARWI(ISET3) AMA2BA=AMARBA(ISET3) IMA2BL=IMABLI(ISET3) IMA2BC=IMABCO(ISET3) PMA2BT=PMABTH(ISET3) IMA2FS=IMAFSW(ISET3) IMA2FC=IMAFCO(ISET3) IMA2PT=IMAPTY(ISET3) IMA2PL=IMAPLI(ISET3) IMA2PC=IMAPCO(ISET3) PMA2PS=PMAPSP(ISET3) PMA2PT=PMAPTH(ISET3) C ITE2SW=ITEXSW(ISET3) ATE2WI=ATEXWI(ISET3) ATE2BA=ATEXBA(ISET3) ITE2BL=ITEBLI(ISET3) ITE2BC=ITEBCO(ISET3) PTE2BT=PTEBTH(ISET3) ITE2FS=ITEFSW(ISET3) ITE2FC=ITEFCO(ISET3) ITE2PT=ITEPTY(ISET3) ITE2PL=ITEPLI(ISET3) ITE2PC=ITEPCO(ISET3) PTE2PS=PTEPSP(ISET3) PTE2PT=PTEPTH(ISET3) C IF(ISTEP.EQ.2.AND.ISUBST.EQ.3.AND.NUMSBR.LE.0)THEN ICH2PA=ICH3PA ENDIF IF(ISTEP.EQ.2.AND.ISUBST.EQ.4.AND.NUMSBR.LE.0)THEN ICH2PA=ICH3PA ENDIF C CCCCC AUGUST 1992. FOLLOWING BLOCK OF CODE ADDED FOR SYMBOL PLOT CCCCC AND VECTOR PLOTS WITH VARIABLE ARROW LENGTH IF(ISTEP.EQ.2.AND.ICASPL.EQ.'SYMB'.AND.ISET3.GT.NUMSBR)THEN ICH2PA=ICHAPA(ISETSY) ICH2FI='OFF' IF(ISETFI.NE.0)ICH2FI='ON' ICH2CO=ICHACO(ISETCL) PCH2HE=ASETSZ*PCH2HE PCH2WI=ASETSZ*PCH2WI ENDIF IF(ISTEP.EQ.2.AND.ICASPL.EQ.'VVAR')THEN PCH2HE=ASETSZ*PCH2HE PCH2WI=ASETSZ*PCH2WI ENDIF CCCCC DECEMBER 1999. CROSS TABULATE PLOT X1 X2 SETS CHAR TYPE TO CCCCC ZVAL. IF(ISTEP.EQ.2.AND.ICASPL.EQ.'CTCO'.AND.ISET3.GT.NUMSBR)THEN ICH2PA='ZVAL' ILI2PA='BLAN' ENDIF IF(ISTEP.EQ.2.AND.ICASPL.EQ.'CTA2'.AND.ISET3.GT.NUMSBR)THEN ICH2PA='ZVAL' ILI2PA='BLAN' ENDIF IF(ISTEP.EQ.2.AND.ICASPL.EQ.'DCON'.AND.ISET3.EQ.NUMSBR+1)THEN ICH2PA='ZVAL' ILI2PA='BLAN' ENDIF C 1109 CONTINUE C CCCCC THE FOLLOWING CHUNK OF CODE WAS ADDED FEBRUARY 1989 (ALAN). CCCCC SEPTEMBER, 1987: ADD "HORIZONTAL SWITCH ON" CASE, I.E. PLOT CCCCC THE CHART HORIZONTALLY RATHER THAN VERTICALLY. NOTE THAT CCCCC "DPDRBA" AND "DPDRSP" ALREADY HANDLE THIS CASE (SPIKE DIRECTION CCCCC AND BAR DIRECTION COMMANDS). OTHER CASES SIMPLY REVERSE VALUE CCCCC OF X AND Y COORDINATES. HORIZONTAL ON WILL SET THE SPIKE AND CCCCC BAR DIRECTIONS TO HORIZONTAL. CCCCC ONE COMPLICATION IS IF THE BAR OR SPIKE SWITCH IS "ON" AND THE CCCCC LINE OR CHARACTER SWITCH IS ON AS WELL. THEN ONE CASE REQUIRES CCCCC A X AND Y TO SWITCH WHILE THE OTHER DOES NOT. IN THIS CASE, MAY CCCCC NEED TO SWITCH X AND Y BACK TO ORIGINAL WAY BEFORE DRAW SPIKE OR CCCCC BAR (VARIABLE ISWTCH KEEPS TRACK) CCCCC ISWTCH='OFF' IF(IHORSW.EQ.'OFF')GOTO1119 IF(IDELIS.EQ.'OFF'.AND.IDRTRS.EQ.'OFF')GOTO1119 IF(ISWTCH.EQ.'ON')GOTO1119 CCCCC IF(ICASPL.EQ.'HIST')GOTO1119 CCCCC IF(ICASPL.EQ.'CUMH')GOTO1119 CCCCC IF(ICASPL.EQ.'BARP')GOTO1119 CCCCC IF(ICASPL.EQ.'ROOT')GOTO1119 CCCCC IF(ICASPL.EQ.'CUMR')GOTO1119 CCCCC IF(ICASPL.EQ.'BIHI')GOTO1119 DO1115I=1,MAXPOP XTEMP=X(I) X(I)=Y(I) Y(I)=XTEMP 1115 CONTINUE ISWTCH='ON' 1119 CONTINUE C IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'OTG2')GOTO1190 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1121) 1121 FORMAT('***** FROM THE MIDDLE OF PLOTG2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1131)ILI2PA,PLI2TH,ILI2CO 1131 FORMAT('ILI2PA,PLI2TH,ILI2CO = ',A4,2X,E15.7,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1132)ICH2PA,ICH2FO,ICH2CA,ICH2JU 1132 FORMAT('ICH2PA,ICH2FO,ICH2CA,ICH2JU = ',A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1133)ICH2DI,ACH2AN,ICH2FI,ICH2CO 1133 FORMAT('ICH2DI,ACH2AN,ICH2FI,ICH2CO = ',A4,E15.7,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1134)PCH2HE,PCH2WI,PCH2TH,PCH2HO,PCH2VO 1134 FORMAT('PCH2HE,PCH2WI,PCH2TH,PCH2HO,PCH2VO = ',5E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1135)IFI2SW,IFI2PA,IFI2CO,PFI2SP,PFI2TH 1135 FORMAT('IFI2SW,IFI2PA,IFI2CO,PFI2SP,PFI2TH = ',A4,2X,A4,2X,A4, 12E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1136)IPA2SW,IPA2PA,IPA2LI,IPA2CO 1136 FORMAT('IPA2SW,IPA2PA,IPA2LI,IPA2CO = ',A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1138)ISP2SW,ISP2LI,ISP2CO,PSP2TH,ASP2BA 1138 FORMAT('ISP2SW,ISP2LI,ISP2CO,PSP2TH,ASP2BA = ',A4,2X,A4,2X,A4, 12E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1141)IBA2SW,ABA2WI,ABA2BA 1141 FORMAT('IBA2SW,ABA2WI,ABA2BA = ',A4,2X,2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1142)IBA2BL,IBA2BC,PBA2BT 1142 FORMAT('IBA2BL,IBA2BC,PBA2BT = ',A4,2X,A4,2X,E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1143)IBA2FS,IBA2FC 1143 FORMAT('IBA2FS,IBA2FC = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1144)IBA2PT,IBA2PL,IBA2PC,IBA2TY,PBA2PS,PBA2PT 1144 FORMAT('IBA2PT,IBA2PL,IBA2PC,IBA2TY,PBA2PS,PBA2PT = ', 1A4,2X,A4,2X,A4,2X,A4,2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1151)IRE2SW,ARE2WI,ARE2BA 1151 FORMAT('IRE2SW,ARE2WI,ARE2BA = ',A4,2X,2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1152)IRE2BL,IRE2BC,PRE2BT 1152 FORMAT('IRE2BL,IRE2BC,PRE2BT = ',A4,2X,A4,2X,E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1153)IRE2FS,IRE2FC 1153 FORMAT('IRE2FS,IRE2FC = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1154)IRE2PT,IRE2PL,IRE2PC,PRE2PS,PRE2PT 1154 FORMAT('IRE2PT,IRE2PL,IRE2PC,PRE2PS,PRE2PT = ',A4,2X,A4,2X, 1A4,2X,2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1161)IMA2SW,AMA2WI,AMA2BA 1161 FORMAT('IMA2SW,AMA2WI,AMA2BA = ',A4,2X,2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1162)IMA2BL,IMA2BC,PMA2BT 1162 FORMAT('IMA2BL,IMA2BC,PMA2BT = ',A4,2X,A4,2X,E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1163)IMA2FS,IMA2FC 1163 FORMAT('IMA2FS,IMA2FC = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1164)IMA2PT,IMA2PL,IMA2PC,PMA2PS,PMA2PT 1164 FORMAT('IMA2PT,IMA2PL,IMA2PC,PMA2PS,PMA2PT = ',A4,2X,A4,2X, 1A4,2X,2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1171)ITE2SW,ATE2WI,ATE2BA 1171 FORMAT('ITE2SW,ATE2WI,ATE2BA = ',A4,2X,2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1172)ITE2BL,ITE2BC,PTE2BT 1172 FORMAT('ITE2BL,ITE2BC,PTE2BT = ',A4,2X,A4,2X,E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1173)ITE2FS,ITE2FC 1173 FORMAT('ITE2FS,ITE2FC = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1174)ITE2PT,ITE2PL,ITE2PC,PTE2PS,PTE2PT 1174 FORMAT('ITE2PT,ITE2PL,ITE2PC,PTE2PS,PTE2PT = ',A4,2X,A4,2X, 1A4,2X,2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1181)IHORSW,ISWTCH 1181 FORMAT('IHORSW,ISWTCH=',A4,2X,A4) CALL DPWRST('XXX','BUG ') DO1182I=1,10 WRITE(ICOUT,1183)I,X(I),Y(I) 1183 FORMAT('I,X(I),Y(I)=',I4,2X,E15.7,2X,E15.7) CALL DPWRST('XXX','BUG ') 1182 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') 1190 CONTINUE C C ***************************************** C ** STEP 21-- ** C ** STEP THROUGH EACH GRAPHICS DEVICE ** C ***************************************** C ISYMBL=ITEXSY ISPAC=ITEXSP C CCCCC THE FOLLOWING 6 LINES WERE ADDED MAY 1992 (JJF) CCCCC TO AUTOMATICALLY CLOSE/OPEN DEVICE 3 MAY 1992 CCCCC WHENEVER AN INITIALIZATION/ERASE IS DONE MAY 1992 CCCCC (SEE ALSO DPERAS AND MAINOD) MAY 1992 CCCCC CCCCC AUGMENTED TO AUTOMATICALLY SAVE THE CURRENT X11 PIXMAP TO CCCCC A FILE. APRIL 1997. C IF(IERASW.EQ.'ON')THEN IF(IOPG2S.EQ.'ON')THEN IBUGXX=IBUGG4 ISUBXX=ISUBG4 IERRXX=IERRG4 IF(IPL2CS.EQ.'OPEN') 1 CALL DPDEV(3,'CLOS','POST',ICAPSW,IBUGXX,ISUBXX,IERRXX) IF(IPL2CS.EQ.'CLOSED') 1 CALL DPDEV(3,'OPEN','POST',ICAPSW,IBUGXX,ISUBXX,IERRXX) IF(IPXMFL.EQ.'ON' .OR. IPXMFL.EQ.'YES')THEN NUMPXM=NUMPXM+1 IF(NUMPXM.GT.MAXPM)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG') WRITE(ICOUT,2011)MAXPM GOTO2099 ENDIF 2011 FORMAT('***** ERROR FROM PLOTG2. MAXIMUM NUMBER OF PIXMAPS (', 1I5,') EXCEEDED.') IPXMFN(NUMPXM)(1:IPXMNC)=IPXMFB(1:IPXMNC) NCSTR=IPXMNC+1 IF(NUMPXM.LE.9)THEN WRITE(IPXMFN(NUMPXM)(NCSTR:NCSTR),'(I1)')NUMPXM ELSEIF(NUMPXM.LE.99)THEN WRITE(IPXMFN(NUMPXM)(NCSTR:NCSTR+1),'(I2)')NUMPXM NCSTR=NCSTR+1 ELSEIF(NUMPXM.LE.999)THEN WRITE(IPXMFN(NUMPXM)(NCSTR:NCSTR+2),'(I3)')NUMPXM NCSTR=NCSTR+2 ENDIF CCCCC DECEMBER 1997. FOR DEVICE GENERALITY, GO THROUGH GRSAGR. ICODE='SAVE' CTEMP=' ' NCTEMP=0 ISTRI2=' ' ISTRI2(1:NCSTR)=IPXMFN(NUMPXM)(1:NCSTR) CALL GRSAGR(ICODE,ISTRI2,NCSTR,CTEMP,NCTEMP) ENDIF C CCCCC DO2030I=1,NCSTR CCCCC CALL DPCOAN(IPXMFN(NUMPXM)(I:I),IADE(I)) C2030 CONTINUE CCCCC IERR=0 CCCCC CALL XSAVEG(IADE,IERR) CCCCC IF(IERR.EQ.1)THEN CCCCC WRITE(ICOUT,999) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,2041) CCCCC CALL DPWRST('XXX','BUG ') CCCCC GOTO2099 C2041 FORMAT('***** ERROR IN PLOTG2--WRITING BIT MAP UNSUCCESSFUL.') CCCCC ELSEIF(IERR.EQ.2)THEN CCCCC NUMPXM=NUMPXM-1 CCCCC WRITE(ICOUT,999) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,2043) CCCCC CALL DPWRST('XXX','BUG ') CCCCC GOTO2099 C2043 FORMAT('***** ERROR IN PLOTG2--NO CURRENT PIXMAP TO SAVE.') CCCCC ELSEIF(IERR.EQ.3)THEN CCCCC WRITE(ICOUT,999) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,2045) CCCCC CALL DPWRST('XXX','BUG ') CCCCC GOTO2099 C2045 FORMAT('***** ERROR IN PLOTG2--X11 HAS NOT BEEN OPENED.') CCCCC ELSEIF(IERR.EQ.4)THEN CCCCC WRITE(ICOUT,999) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,2047) CCCCC CALL DPWRST('XXX','BUG ') CCCCC GOTO2099 C2047 FORMAT('***** ERROR IN PLOTG2--X11 NOT INSTALLED ON THIS ', CCCCC1'IMPLEMENTATION.') CCCCC ELSE CCCCC IF(IPXMCM(NUMPXM).EQ.' ')THEN CCCCC IPXMCM(NUMPXM)(1:128)=IPXMFN(NUMPXM)(1:128) CCCCC ENDIF CCCCC GOTO2099 CCCCC ENDIF CCCCC ENDIF ENDIF ENDIF 2099 CONTINUE C DO2100IDEV=1,NUMDEV C ICONT=IDCONT(IDEV) CCCCC THE FOLLOWING LINE WAS INSERTED FEBRUARY 1989. (ALAN) IPOWER=IDPOWE(IDEV) IMANUF=IDMANU(IDEV) IMODEL=IDMODE(IDEV) IMODE2=IDMOD2(IDEV) IMODE3=IDMOD3(IDEV) IGCODE=IDCODE(IDEV) IGUNIT=IDUNIT(IDEV) C CCCCC FEBRUARY 2006: DEVICE 1 LATEX TO CAPTURE FILE C IF(IDEV.EQ.1 .AND. IMANUF.EQ.'LATE' .AND. 1 IPR.EQ.ICAPNU)THEN IGUNIT=ICAPNU ENDIF C NUMHPP=IDNHPP(IDEV) ANUMHP=NUMHPP NUMVPP=IDNVPP(IDEV) ANUMVP=NUMVPP CCCCC THE FOLLOWING 2 LINES WERE INSERTED FEBRUARY 1989. (ALAN) IOFFSV=IDNVOF(IDEV) IOFFSH=IDNHOF(IDEV) IGCOLO=IDCOLO(IDEV) IGBAUD=IDBAUD(IDEV) ISOFT=IDSOFT(IDEV) ISOFT2=IDSOF2(IDEV) ISOFT3=IDSOF3(IDEV) CCCCC THE FOLLOWING LINE WAS INSERTED JULY 1996. (ALAN) IGFONT=IDFONT(IDEV) C IF(ICONT.EQ.'OFF')GOTO2100 C CCCCC THE FOLLOWING LINE WAS INSERTED FEBRUARY 1989. (ALAN) CCCCC IF HAVE DEVICE 2 OFF COMMAND, CCCCC DO NOT SET DEFAULT DEVICE. CCCCC SET POWER OFF, WHEN POWER OFF DON'T DO PLOT. DEVICE 2 ON ??? CCCCC WILL TURN ON WHATEVER CURRENT DEVICE IS. CCCCC THIS ALLOWS PLOT FILE TO BE TOGGLED ON AND OFF CONVIENTLY. IF(IPOWER.EQ.'OFF')GOTO2100 C IF(ISQUAR.EQ.'ON')GOTO2110 IF(ICASPL.EQ.'PIEC')GOTO2110 GOTO2190 2110 CONTINUE PSAVE=PXMAX PYDEL=PYMAX-PYMIN PXDEL=PYDEL*(ANUMVP/ANUMHP) PXMAX=PXMIN+PXDEL 2190 CONTINUE C C *************************************************** C ** STEP 31-- ** C ** CARRY OUT OPENING OPERATIONS ** C ** ON THE DEVICES AND ON THE GRAPHICS SOFTWARE ** C *************************************************** C IF(IOPGRS.EQ.'ON') 1CALL DPOPDE C C **************************************************************** C ** STEP 32-- C ** CARRY OUT MINOR PRE-PLOT ACTIVITIES-- C ** ERASE THE SCREEN, FILL THE BACKGROUND, RING THE BELL, ETC. C **************************************************************** C IF(IOPG2S.EQ.'ON') 1CALL DPOPPL(IGRASW, 1IBELSW,NUMRIN,IERASW, 1IBACCO) CCCCC FOLLOWING LINES ADDED MARCH, 1990 FOR X11 DEVICE. X11 CAN CCCCC DYNAMICALLY MODIFY THE PICTURE POINTS (ERASE SCREEN GETS UPDATED CCCCC VALUES). IF(IMANUF.EQ.'X11')THEN NUMVPP=ANUMVP+0.5 NUMHPP=ANUMHP+0.5 IDNVPP(IDEV)=NUMVPP IDNHPP(IDEV)=NUMHPP ENDIF CCCCC END CHANGES CCCCC FOLLOWING LINES ADDED OCTOBER, 1996 FOR QWIN DEVICE. QWIN CAN CCCCC DYNAMICALLY MODIFY THE PICTURE POINTS (ERASE SCREEN GETS UPDATED CCCCC VALUES). IF(IMANUF.EQ.'QWIN')THEN NUMVPP=ANUMVP+0.5 NUMHPP=ANUMHP+0.5 IDNVPP(IDEV)=NUMVPP IDNHPP(IDEV)=NUMHPP ENDIF CCCCC END CHANGES C C ************************************************ C ** STEP 33-- ** C ** IF HAVE NO POINTS BEING PLOTTED ** C ** (AND THEREFORE ONLY INTERESTED IN SEEING ** C ** THE TITLES, LABELS, LEGENDS, ETC.) ** C ** THEN SKIP DOWN TO THOSE SECTIONS. ** C ************************************************ C IF(NP.LE.0)GOTO5700 C C ******************************************** C ** STEP 34-- ** C ** DETERMINE DATA LIMITS, FRAME LIMITS, ** C ** AND TIC COORDINATES. ** C ******************************************** C IF(IDELIS.EQ.'ON')GOTO3400 GOTO3490 C 3400 CONTINUE CCCCC THE FOLLOWING LINE WAS INSERTED FEBRUARY 1989 CCCCC TO HANDLE THE CASE OF AN EMPTY SUBSET IF(NUMSET.EQ.0)GOTO3490 CALL DPDELI(Y,X,PX,NP,NUMSET, 1ICASPL,ICAS3D, 1XDELMN) IF(IERRG4.EQ.'YES')GOTO9000 3490 CONTINUE C C ********************************************* C ** STEP 41-- ** C ** DRAW A DATA-DEFINED GENERALIZED TRACE. ** C ** THE TRACE MAY CONSIST OF ANY OR ALL ** C ** OF THE FOLLOWING-- ** C ** 1. CHARACTERS ** C ** 2. LINES ** C ** 3. BARS ** C ** 4. SPIKES ** C ********************************************* C IF(IDRTRS.EQ.'ON')GOTO4100 GOTO4190 C 4100 CONTINUE C CCCCC IF(IFI2SW.EQ.'ON') CCCCC1CALL DPFIRS(Y,X,PY,PX,NP, CCCCC1ICASPL,ICAS3D, CCCCC1ISORSW, CCCCC1IFI2PA,IFI2CO,PFI2SP,PFI2TH, CCCCC1PXMIN,PXMAX,PYMIN,PYMAX, CCCCC1FX1MIN,FX1MAX,FY1MIN,FY1MAX, CCCCC1IX1TSC,IY1TSC) C CCCCC IF(IPA2SW.EQ.'ON') CCCCC1CALL DPDRPS(Y,X,PY,PX,NP, CCCCC1ICASPL,ICAS3D, CCCCC1ISORSW, CCCCC1IPA2PA,IPA2LI,IPA2CO,PPA2HE,PPA2WI,PPATSP,PPA2TH, CCCCC1PXMIN,PXMAX,PYMIN,PYMAX, CCCCC1FX1MIN,FX1MAX,FY1MIN,FY1MAX, CCCCC1IX1TSC,IY1TSC) C IF(ICASPL.EQ.'HIST')GOTO4119 IF(ICASPL.EQ.'CUMH')GOTO4119 IF(ICASPL.EQ.'BARP')GOTO4119 IF(ICASPL.EQ.'ROOT')GOTO4119 IF(ICASPL.EQ.'CUMR')GOTO4119 IF(ICASPL.EQ.'BIHI')GOTO4119 C ICH2SW='ON' IF(ICH2PA.EQ.'OFF')ICH2SW='OFF' IF(ICH2PA.EQ.'BLAN')ICH2SW='OFF' IF(ICH2PA.EQ.'BL')ICH2SW='OFF' IF(ICH2PA.EQ.' ')ICH2SW='OFF' IF(ICH2PA.EQ.'NONE')ICH2SW='OFF' IF(ICH2PA.EQ.'NO')ICH2SW='OFF' CCCCC THE FOLLOWING 2 LINES WAS ADDED FOR VECTOR PLOT AUGUST 1992 IF(ICASPL.EQ.'VECT')ICH2PA='VECT' IF(ICASPL.EQ.'VVAR')ICH2PA='VECT' CCCCC THE FOLLOWING BLOCK WAS ADDED FOR VECTOR PLOTS TO AUTOMATICALLY CCCCC SET THE PRE-SORT OFF. FEBRUARY 1994. CCCCC SET THE PRE-SORT OFF FOR VIOLIN PLOT. FEBRUARY 2003. CCCCC SET THE PRE-SORT OFF FOR PARALLEL COORDINATES PLOT. APRIL 2003. IF(ICASPL.EQ.'VECT'.OR.ICASPL.EQ.'VVAR'.OR.ICASPL.EQ.'DCON'.OR. 1 ICASPL.EQ.'YCUB'.OR.ICASPL.EQ.'VIPL'.OR.ICASPL.EQ.'PCPL'.OR. 1 ICASPL.EQ.'PCPG')THEN ISORZZ='OFF' ELSE ISORZZ=ISORSW END IF C IF(ICH2SW.EQ.'ON') 1CALL DPDRCH(Y,X,PY,PX,NP,PY2,PX2,NP2,X3D, 1ICASPL,ICAS3D, CCCCC1ISORSW, 1ISORZZ, CCCCC THE FOLLOWING ARGUMENT WAS ADDED MAY 1992 (JJF) 1ARE2BA, 1ICH2PA,ICH2FO,ICH2CA,ICH2JU,ICH2DI,ACH2AN,ICH2FI,ICH2CO, 1PCH2HE,PCH2WI,PCH2TH,PCH2HO,PCH2VO, 1ITEXSP, 1PXMIN,PXMAX,PYMIN,PYMAX, 1FX1MIN,FX1MAX,FY1MIN,FY1MAX, 1IX1TSC,IY1TSC, 1IMPSW2,AMPSCH,AMPSCW) C CCCCC THE FOLLOWING ANIMATION CHUNK WAS ADDED APRIL 1989 C IF(IANISW.EQ.'OFF')GOTO4109 ICH2CO=IBACCO IF(ICH2SW.EQ.'ON') 1CALL DPDRCH(Y,X,PY,PX,NP,PY2,PX2,NP2,X3D, 1ICASPL,ICAS3D, CCCCC1ISORSW, 1ISORZZ, CCCCC THE FOLLOWING ARGUMENT WAS ADDED MAY 1992 (JJF) 1ARE2BA, 1ICH2PA,ICH2FO,ICH2CA,ICH2JU,ICH2DI,ACH2AN,ICH2FI,ICH2CO, 1PCH2HE,PCH2WI,PCH2TH,PCH2HO,PCH2VO, 1ITEXSP, 1PXMIN,PXMAX,PYMIN,PYMAX, 1FX1MIN,FX1MAX,FY1MIN,FY1MAX, 1IX1TSC,IY1TSC, 1IMPSW2,AMPSCH,AMPSCW) 4109 CONTINUE C IF(ICASPL.EQ.'DCON'.OR.ICASPL.EQ.'VIPL'.OR.ICASPL.EQ.'PCPL'.OR. 1 ICASPL.EQ.'PCPG')THEN ISORZZ='OFF' ELSE ISORZZ=ISORSW END IF ILI2SW='ON' IF(ILI2PA.EQ.'OFF')ILI2SW='OFF' IF(ILI2PA.EQ.'BLAN')ILI2SW='OFF' IF(ILI2PA.EQ.'BL')ILI2SW='OFF' IF(ILI2PA.EQ.' ')ILI2SW='OFF' IF(ILI2PA.EQ.'NONE')ILI2SW='OFF' IF(ILI2PA.EQ.'NO')ILI2SW='OFF' CCCCC THE FOLLOWING LINE WAS ADDED FOR HAZARD PLOT MAY 1989 IF(ICASPL.EQ.'HAZA')ILI2SW='ON' CCCCC THE FOLLOWING LINE WAS ADDED FOR SYMBOL PLOT AUGUST 1992 IF(ICASPL.EQ.'SYMB')ILI2SW='OFF' IF(ILI2SW.EQ.'ON') 1CALL DPDRTR(Y,X,PY,PX,NP,PY2,PX2,NP2,PY3,PX3,NP3, 1ICASPL,ICAS3D, 1ISORZZ, 1ILI2PA,ILI2CO,PLI2TH, CCCCC OCTOBER 1993. ADD ARE3BA CCCCC1ARE2BA, 1ARE2BA,ARE3BA, 1IRE2FS,IRE2FC, 1IRE2PT,IRE2PL,IRE2PC,PRE2PT,PRE2PS, CCCCC MARCH 1994. ADD FOLLOWING LINE 1IRE2PZ, 1PXMIN,PXMAX,PYMIN,PYMAX, 1FX1MIN,FX1MAX,FY1MIN,FY1MAX, 1IX1TSC,IY1TSC) C CCCCC THE FOLLOWING ANIMATION CHUNK WAS ADDED APRIL 1989 C IF(IANISW.EQ.'OFF')GOTO4119 ILI2CO=IBACCO IRE2FC=IBACCO IRE2PC=IBACCO IF(ILI2SW.EQ.'ON') 1CALL DPDRTR(Y,X,PY,PX,NP,PY2,PX2,NP2,PY3,PX3,NP3, 1ICASPL,ICAS3D, 1ISORZZ, 1ILI2PA,ILI2CO,PLI2TH, CCCCC OCTOBER 1993. ADD ARE3BA CCCCC1ARE2BA, 1ARE2BA,ARE3BA, 1IRE2FS,IRE2FC, 1IRE2PT,IRE2PL,IRE2PC,PRE2PT,PRE2PS, CCCCC MARCH 1994. ADD FOLLOWING LINE 1IRE2PZ, 1PXMIN,PXMAX,PYMIN,PYMAX, 1FX1MIN,FX1MAX,FY1MIN,FY1MAX, 1IX1TSC,IY1TSC) 4119 CONTINUE C CCCCC THE FOLLOWING CHUNK WAS INSERTED BY ALAN FEBRUARY 1989 CCCCC AND THEN COMMENTED OUT BY ALAN. CCCCC "HORIZONTAL SWITCH ON" CASE. SEPTEMBER, 1987. IF X AND Y REVERSED, CCCCC SET BACK BEFORE DO BARS OR SPIKES CCCCC IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'OTG2')GOTO4119 CCCCC WRITE(ICOUT,4111)ISWTCH C4111 FORMAT('BEFORE DRAW BARS AND SPIKES, ISWTCH=',A4) CCCCC CALL DPWRST('XXX','BUG ') CCCCCCCCCDO4115I=1,10 CCCCC WRITE(ICOUT,4116)I,X(I),Y(I) CCCCC CALL DPWRST('XXX','BUG ') C4115 CONTINUE C4116 FORMAT('I,X(I),Y(I)=',I4,2X,E15.7,2X,E15.7) C4119 CONTINUE CCCCC IF(ISWTCH.EQ.'OFF')GOTO4120 CCCCC DO4130I=1,MAXPOP CCCCC XTEMP=X(I) CCCCC X(I)=Y(I) CCCCC Y(I)=XTEMP C4130 CONTINUE CCCCC ISWTCH='OFF' C4120 CONTINUE C IF(IBA2SW.EQ.'ON'.OR. 1ICASPL.EQ.'HIST'.OR. 1ICASPL.EQ.'CUMH'.OR. 1ICASPL.EQ.'BARP'.OR. 1ICASPL.EQ.'ROOT'.OR. 1ICASPL.EQ.'CUMR'.OR. 1ICASPL.EQ.'BIHI') 1CALL DPDRBA(Y,X,PY,PX,NP, 1ICASPL,ICAS3D, 1ISORSW, 1IBA2SW,ABA2WI,ABA2BA, 1IBA2BL,IBA2BC,PBA2BT, 1IBA2FS,IBA2FC, 1IBA2PT,IBA2PL,IBA2PC,IBA2TY,IBA2DI,PBA2PS,PBA2PT, 1XDELMN, 1PXMIN,PXMAX,PYMIN,PYMAX, 1FX1MIN,FX1MAX,FY1MIN,FY1MAX, 1IX1TSC,IY1TSC) C CCCCC THE FOLLOWING ANIMATION CHUNK WAS ADDED APRIL 1989 C IF(IANISW.EQ.'OFF')GOTO4129 IBA2BC=IBACCO IBA2FC=IBACCO IBA2PC=IBACCO IF(IBA2SW.EQ.'ON'.OR. 1ICASPL.EQ.'HIST'.OR. 1ICASPL.EQ.'CUMH'.OR. 1ICASPL.EQ.'BARP'.OR. 1ICASPL.EQ.'ROOT'.OR. 1ICASPL.EQ.'CUMR'.OR. 1ICASPL.EQ.'BIHI') 1CALL DPDRBA(Y,X,PY,PX,NP, 1ICASPL,ICAS3D, 1ISORSW, 1IBA2SW,ABA2WI,ABA2BA, 1IBA2BL,IBA2BC,PBA2BT, 1IBA2FS,IBA2FC, 1IBA2PT,IBA2PL,IBA2PC,IBA2TY,IBA2DI,PBA2PS,PBA2PT, 1XDELMN, 1PXMIN,PXMAX,PYMIN,PYMAX, 1FX1MIN,FX1MAX,FY1MIN,FY1MAX, 1IX1TSC,IY1TSC) 4129 CONTINUE C IF(ISP2SW.EQ.'ON') 1CALL DPDRSP(Y,X,PY,PX,NP, 1ICASPL,ICAS3D, 1ISORSW, 1ISP2LI,ISP2CO,ISP2DI,PSP2TH,ASP2BA, 1PXMIN,PXMAX,PYMIN,PYMAX, 1FX1MIN,FX1MAX,FY1MIN,FY1MAX, 1IX1TSC,IY1TSC) C CCCCC THE FOLLOWING ANIMATION CHUNK WAS ADDED APRIL 1989 C IF(IANISW.EQ.'OFF')GOTO4139 ISP2CO=IBACCO IF(ISP2SW.EQ.'ON') 1CALL DPDRSP(Y,X,PY,PX,NP, 1ICASPL,ICAS3D, 1ISORSW, 1ISP2LI,ISP2CO,ISP2DI,PSP2TH,ASP2BA, 1PXMIN,PXMAX,PYMIN,PYMAX, 1FX1MIN,FX1MAX,FY1MIN,FY1MAX, 1IX1TSC,IY1TSC) 4139 CONTINUE 4190 CONTINUE C C ******************************************************** C ** STEP 56-- ** C ** DRAW THE FRAME, TICS, TIC LABELS, AND GRID LINES ** C ******************************************************** C IF(IDRFRS.EQ.'ON') 1CALL DPDRFR(ICASPL,ICAS3D, 1IVGMSW,IHGMSW) IF(IERRG4.EQ.'YES')GOTO9000 C C ********************************* C ** STEP 57-- ** C ** DRAW THE LABELS AND TITLE ** C ********************************* C 5700 CONTINUE C CCCCC IF(IWRLAS.EQ.'ON')CALL DPWRLA(PXMIN,PYMIN,PXMAX,PYMAX, DEC. 1986 IF(IWRLAS.EQ.'ON')GOTO5710 GOTO5790 C 5710 CONTINUE ITITCV(1)=ITITFO ITITCV(2)=ITITCA ITITCV(3)=ITITFI ITITCV(4)=ITITCO PTITRV(1)=PTITHE PTITRV(2)=PTITWI PTITRV(3)=PTITVG PTITRV(4)=PTITHG PTITRV(5)=PTITTH PTITRV(6)=PTITDS C IX1LCV(1)=IX1LFO IX1LCV(2)=IX1LCA IX1LCV(3)=IX1LFI IX1LCV(4)=IX1LCO IX1LCV(5)=IX1LJU IX1LCV(6)=IX1LDI PX1LRV(1)=PX1LHE PX1LRV(2)=PX1LWI PX1LRV(3)=PX1LVG PX1LRV(4)=PX1LHG PX1LRV(5)=PX1LTH PX1LRV(6)=PX1LDS PX1LRV(7)=PX1LOF PX1LRV(8)=PX1LAN C IX2LCV(1)=IX2LFO IX2LCV(2)=IX2LCA IX2LCV(3)=IX2LFI IX2LCV(4)=IX2LCO IX2LCV(5)=IX2LJU IX2LCV(6)=IX2LDI PX2LRV(1)=PX2LHE PX2LRV(2)=PX2LWI PX2LRV(3)=PX2LVG PX2LRV(4)=PX2LHG PX2LRV(5)=PX2LTH PX2LRV(6)=PX2LDS PX2LRV(7)=PX2LOF PX2LRV(8)=PX2LAN C IX3LCV(1)=IX3LFO IX3LCV(2)=IX3LCA IX3LCV(3)=IX3LFI IX3LCV(4)=IX3LCO IX3LCV(5)=IX3LJU IX3LCV(6)=IX3LDI PX3LRV(1)=PX3LHE PX3LRV(2)=PX3LWI PX3LRV(3)=PX3LVG PX3LRV(4)=PX3LHG PX3LRV(5)=PX3LTH PX3LRV(6)=PX3LDS PX3LRV(7)=PX3LOF PX3LRV(8)=PX3LAN C IY1LCV(1)=IY1LFO IY1LCV(2)=IY1LCA IY1LCV(3)=IY1LFI IY1LCV(4)=IY1LCO IY1LCV(5)=IY1LJU IY1LCV(6)=IY1LDI PY1LRV(1)=PY1LHE PY1LRV(2)=PY1LWI PY1LRV(3)=PY1LVG PY1LRV(4)=PY1LHG PY1LRV(5)=PY1LTH PY1LRV(6)=PY1LDS PY1LRV(7)=PY1LOF PY1LRV(8)=PY1LAN C IY2LCV(1)=IY2LFO IY2LCV(2)=IY2LCA IY2LCV(3)=IY2LFI IY2LCV(4)=IY2LCO IY2LCV(5)=IY2LJU IY2LCV(6)=IY2LDI PY2LRV(1)=PY2LHE PY2LRV(2)=PY2LWI PY2LRV(3)=PY2LVG PY2LRV(4)=PY2LHG PY2LRV(5)=PY2LTH PY2LRV(6)=PY2LDS PY2LRV(7)=PY2LOF PY2LRV(8)=PY2LAN C CALL DPWRLA(PXMIN,PYMIN,PXMAX,PYMAX, 1ITITTE,NCTITL,ITITCV,PTITRV, 1IX1LTE,NCX1LA,IX1LCV,PX1LRV, 1IX2LTE,NCX2LA,IX2LCV,PX2LRV, 1IX3LTE,NCX3LA,IX3LCV,PX3LRV, 1IY1LTE,NCY1LA,IY1LCV,PY1LRV, 1IY2LTE,NCY2LA,IY2LCV,PY2LRV, 1ISYMBL,ISPAC, 1IMPSW2,AMPSCH,AMPSCW, 1IHNAME,IHNAM2,IUSE,IVALUE,VALUE,NUMNAM, 1IVSTAR,IVSTOP,IFUNC,NUMCHF,IREPCH,ISEQSW,NUMSEQ) C 5790 CONTINUE C C *********************************************************** C ** STEP 58-- ** C ** DRAW THE LEGENDS, LEGEND BOXES, SEGMENTS AND ARROWS ** C *********************************************************** C CCCCC THE PLEGTH ARGUMENT WAS ADDED FEBRUARY 1989 (ALAN) CCCCC AUGUST 1995. ADD ILGENA TO LIST IF(IWRLES.EQ.'ON') 1CALL DPWRLE(ILEGTE,ILEGST,ILEGSP,ILEGNA, 1PLEGXC,PLEGYC, 1ILEGFO,ILEGCA,ILEGJU,ILEGDI,ALEGAN,ILEGFI,ILEGCO,ILEGUN, 1PLEGHE,PLEGWI,PLEGVG,PLEGHG,PLEGTH,NUMLEG, 1PBOXXC,PBOXYC, 1IBOBCO, CCCCC THE FOLLOWING LINE WAS MODIFIED AUGUST 1992 CCCCC1IBOPPA,IBOPCO, 1IBOPPA,IBOBPA, 1PBOPTH,PBOPGA, 1IBOFPA,IBOFCO, CCCCC THE FOLLOWING LINE WAS AUGMENTED FOR BOX SHADOW AUGUST 1992 CCCCC1PBOFTH,NUMBOX, 1PBOFTH,PBOSHE,PBOSWI,NUMBOX, 1PARRXC,PARRYC, 1IARRPA,IARRCO, 1PARRTH, 1PARHLE,PARHWI,NUMARR, 1PSEGXC,PSEGYC, 1ISEGPA,ISEGCO, 1PSEGTH,NUMSEG, 1IMPSW2,AMPSCH,AMPSCW, 1IHNAME,IHNAM2,IUSE,IVALUE,VALUE,NUMNAM, 1IVSTAR,IVSTOP,IFUNC,NUMCHF,IREPCH,ISYMBL,ISPAC) C C **************************************************************** C ** STEP 61-- ** C ** CARRY OUT POST-PLOT OPERATIONS-- ** C ** COPYING THE SCREEN, MOVING CURSOR TO HOME POSITION, ETC. ** C **************************************************************** C IF(ICLG2S.EQ.'ON') 1CALL DPCLPL(ICOPSW,NUMCOP, 1PGRAXF,PGRAYF, 1IGRASW,PDIAXC,PDIAYC,PDIAX2,PDIAY2, 1PDIAHE,PDIAWI,PDIAVG,PDIAHG) C C *************************************************** C ** STEP 62-- ** C ** CARRY OUT CLOSING OPERATIONS ** C ** ON THE DEVICES AND ON THE GRAPHICS SOFTWARE ** C *************************************************** C IF(ICLGRS.EQ.'ON') 1CALL DPCLDE C IF(ISQUAR.EQ.'ON')GOTO6210 IF(ICASPL.EQ.'PIEC')GOTO6210 GOTO6290 C 6210 CONTINUE PXMAX=PSAVE C 6290 CONTINUE C 2100 CONTINUE IF(IWRLAS.EQ.'ON'.AND.ISEQSW.EQ.'ON')NUMSEQ=NUMSEQ+1 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'OTG2')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF PLOTG2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IMANUF,IMODEL 9012 FORMAT('IMANUF,IMODEL = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)IBUGG4,ISUBG4,IERRG4 9015 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') CCCCC THE FOLLOWING 2 LINES WERE ADDED MAY 1992 WRITE(ICOUT,9016)IPL2CS 9016 FORMAT('IPL2CS = ',A4) CALL DPWRST('XXX','BUG ') C APRIL 1992. FIX TYPO IN FOLLOWING 2 LINES CCCCC WRITE(ICOUT,9017)NUMSET,ISET3,ISET3S C9017 FORMAT('NUMSET,ISET3,ISET3S = ',3I8) CCCCC CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9017)NUMSET,ISET,ISET3 9017 FORMAT('NUMSET,ISET,ISET3 = ',3I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9018)ICASPL,ICAS3D 9018 FORMAT('ICASPL,ICAS3D = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9019)ISQUAR,XDELMN 9019 FORMAT('ISQUAR,XDELMN = ',A4,2X,E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9021)ILI2PA,ILI2SW 9021 FORMAT('ILI2PA,ILI2SW = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9022)ICH2PA,ICH2SW 9022 FORMAT('ICH2PA,ICH2SW = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9031)IBA2SW,ABA2WI,ABA2BA 9031 FORMAT('IBA2SW,ABA2WI,ABA2BA = ',A4,2X,2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9032)IBA2BL,IBA2BC,PBA2BT 9032 FORMAT('IBA2BL,IBA2BC,PBA2BT = ',A4,2X,A4,2X,E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9033)IBA2FS,IBA2FC 9033 FORMAT('IBA2FS,IBA2FC = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9034)IBA2PT,IBA2PL,IBA2PC,IBA2TY,PBA2PS,PBA2PT 9034 FORMAT('IBA2PT,IBA2PL,IBA2PC,IBA2TY,PBA2PS,PBA2PT = ', 1A4,2X,A4,2X,A4,2X,A4,2X,2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9035)ITEXSY,ITEXSP 9035 FORMAT('ITEXSY,ITEXSP = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9036)ISYMBL,ISPAC 9036 FORMAT('ISYMBL,ISPAC = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9041)IREPCH 9041 FORMAT('IREPCH = ',A1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9043)IBACCO,IANISW 9043 FORMAT('IBACCO,IANISW = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE PLOTG3(XRAW,YRAW,ZRAW,NP,DSIZE, 1PX,PY,PZ,PX2,PY2,PZ2,NP2,PX3,PY3,NP3,NUMSET, 1ICASPL,ICAS3D, 1ISQUAR, 1IVGMSW,IHGMSW, 1XDELMN,YDELMN,ZDELMN, 1ISTEP,ISUBST,ISET,ISET3,ICH3PA, 1IOPGRS,IOPG2S,IDELIS,IDRFRS,IWRLAS,IWRLES,IDRTRS,ICLG2S,ICLGRS, 1ICAPSW, 1IHNAME,IHNAM2,IUSE,IVALUE,VALUE,NUMNAM, 1IVSTAR,IVSTOP,IFUNC,NUMCHF,IREPCH,ISWTCH) C C PURPOSE--GENERATE A COMPLETE 3-D PLOT OF A SINGLE TRACE OF Y VERSUS X C (INCLUDING FRAME, TICS, LEGENDS, ETC.) C C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--83.6 C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MAY 1983. C UPDATED --SEPTEMBER 1988 BIHISTOGRAM C UPDATED --MARCH 1990 X11 PATCH C UPDATED --AUGUST 1992 DPWRLE PARAMETERS, BOX NAMES C UPDATED --AUGUST 1992 SOME PLOTG2 BUG FIXES INCORPORATED C UPDATED --SEPTEMBER 1993 3-D FRAMES C UPDATED --AUGUST 1995 ARGUMENT LIST TO DPWRLE C UPDATED --MAY 1996 DIMENSION FOR XT, ZT C UPDATED --JULY 1996 ADD IDFONT C UPDATED --OCTOBER 1996 QWIN PATCH C UPDATED --APRIL 1997. SUPPORT FOR AUTOMATICALLY C SAVING X11 PIXMAPS C UPDATED --DECEMBER 1997. GENERALIZE PIXMAPS TO OTHER C DEVICE C UPDATED --NOVEMBER 1999. ARGUMENT TO DPWRLA C UPDATED --FEBRUARY 2006. DEVICE 1 LATEX OUTPUT TO C CAPTURE FILE C C-----FOR NON-COMMON VARIABLES----------------------------------------- C CHARACTER*4 ICONT C CHARACTER*4 ISQUAR C CHARACTER*4 ICAPSW C CHARACTER*4 IVGMSW CHARACTER*4 IHGMSW C CHARACTER*4 ICASPL CHARACTER*4 ICAS3D C CHARACTER*4 ICH3PA C CHARACTER*4 ILI2SW CHARACTER*4 ILI2PA CHARACTER*4 ILI2CO C CHARACTER*4 ICH2SW CHARACTER*4 ICH2PA CHARACTER*4 ICH2FO CHARACTER*4 ICH2CA CHARACTER*4 ICH2JU CHARACTER*4 ICH2DI CHARACTER*4 ICH2FI CHARACTER*4 ICH2CO C CHARACTER*4 IFI2SW CHARACTER*4 IFI2PA CHARACTER*4 IFI2CO C CHARACTER*4 IPA2SW CHARACTER*4 IPA2PA CHARACTER*4 IPA2LI CHARACTER*4 IPA2CO C CHARACTER*4 ISP2SW CHARACTER*4 ISP2LI CHARACTER*4 ISP2CO CHARACTER*4 ISP2DI C CHARACTER*4 IBA2SW CHARACTER*4 IBA2BL CHARACTER*4 IBA2BC CHARACTER*4 IBA2FS CHARACTER*4 IBA2FC CHARACTER*4 IBA2PT CHARACTER*4 IBA2PL CHARACTER*4 IBA2PC CHARACTER*4 IBA2TY CHARACTER*4 IBA2DI C CHARACTER*4 IRE2SW CHARACTER*4 IRE2BL CHARACTER*4 IRE2BC CHARACTER*4 IRE2FS CHARACTER*4 IRE2FC CHARACTER*4 IRE2PT CHARACTER*4 IRE2PL CHARACTER*4 IRE2PC C CHARACTER*4 IMA2SW CHARACTER*4 IMA2BL CHARACTER*4 IMA2BC CHARACTER*4 IMA2FS CHARACTER*4 IMA2FC CHARACTER*4 IMA2PT CHARACTER*4 IMA2PL CHARACTER*4 IMA2PC C CHARACTER*4 ITE2SW CHARACTER*4 ITE2BL CHARACTER*4 ITE2BC CHARACTER*4 ITE2FS CHARACTER*4 ITE2FC CHARACTER*4 ITE2PT CHARACTER*4 ITE2PL CHARACTER*4 ITE2PC C CHARACTER*4 IOPGRS CHARACTER*4 IOPG2S CHARACTER*4 IDELIS CHARACTER*4 IDRFRS CHARACTER*4 IWRLAS CHARACTER*4 IWRLES CHARACTER*4 IDRTRS CHARACTER*4 ICLG2S CHARACTER*4 ICLGRS C CHARACTER*4 ISYMBL CHARACTER*4 ISPAC C CHARACTER*4 IHNAME CHARACTER*4 IHNAM2 CHARACTER*4 IUSE CHARACTER*4 IFUNC C CHARACTER*1 IREPCH CCCCC ISWTCH ADDED FOR CONSISTENCY WITH PLOTG2. NOT YET USED. CHARACTER*4 ISWTCH C CCCCC FOLLOWING ADDED AUGUST 1992. CHARACTER*4 IPOWER CHARACTER*4 IBUGXX CHARACTER*4 ISUBXX CHARACTER*4 IERRXX C CHARACTER*4 ITITCV CHARACTER*4 IX1LCV CHARACTER*4 IX2LCV CHARACTER*4 IX3LCV CHARACTER*4 IY1LCV CHARACTER*4 IY2LCV C CHARACTER*128 ISTRI2 CHARACTER*128 CTEMP CHARACTER*4 ICODE C DIMENSION XRAW(*) DIMENSION YRAW(*) DIMENSION ZRAW(*) DIMENSION PX(*) DIMENSION PY(*) DIMENSION PZ(*) DIMENSION PX2(*) DIMENSION PY2(*) DIMENSION PZ2(*) DIMENSION PX3(*) DIMENSION PY3(*) C DIMENSION DSIZE(*) C C THE FOLLOWING 2 LINES ARE TEMPORARY SETTINGS-- 9/88 -- C CCCCC THESE NEED TO BE HIGHER. MAY 1996. SET TO MAXPOP CCCCC DIMENSION XT(2048) CCCCC DIMENSION ZT(2048) INCLUDE 'DPCOPA.INC' DIMENSION XT(MAXPOP) DIMENSION ZT(MAXPOP) C DIMENSION XPRIME(12) DIMENSION YPRIME(12) DIMENSION ZPRIME(12) C DIMENSION IHNAME(*) DIMENSION IHNAM2(*) DIMENSION IUSE(*) DIMENSION IVALUE(*) DIMENSION VALUE(*) DIMENSION IVSTAR(*) DIMENSION IVSTOP(*) DIMENSION IFUNC(*) C DIMENSION ITITCV(4) DIMENSION PTITRV(6) DIMENSION IX1LCV(6) DIMENSION PX1LRV(8) DIMENSION IX2LCV(6) DIMENSION PX2LRV(8) DIMENSION IX3LCV(6) DIMENSION PX3LRV(8) DIMENSION IY1LCV(6) DIMENSION PY1LRV(8) DIMENSION IY2LCV(6) DIMENSION PY2LRV(8) C CCCCC DIMENSION AUPPHX(300) CCCCC DIMENSION ALOWHX(300) CCCCC DIMENSION AUPPHY(300) CCCCC DIMENSION ALOWHY(300) CCCCC ADD FOLLOWING LINE APRIL 1997 CCCCC DIMENSION IADE(128) C C-----COMMON---------------------------------------------------------- C CCCCC MAY 1996. MOVE DPCOPA EARLIER CCCCC INCLUDE 'DPCOPA.INC' INCLUDE 'DPCOPC.INC' INCLUDE 'DPCOGR.INC' INCLUDE 'DPCOBE.INC' INCLUDE 'DPCO3D.INC' CCCCC THE FOLLOWING LINE WAS ADDED AUGUST 1992. INCLUDE 'DPCOF2.INC' CCCCC THE FOLLOWING LINE WAS ADDED APRIL 1997. INCLUDE 'DPCOPM.INC' C C-----COMMON VARIABLES (GENERAL)-------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C PSAVE=-999.0 C ILI2SW='ON' ICH2SW='ON' C IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'OTG3')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF PLOTG3--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)ISTEP,ISUBST,ISET,ISET3,ICH3PA 53 FORMAT('ISTEP,ISUBST,ISET,ISET3,ICH3PA = ',4I8,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,62)NP 62 FORMAT('NP = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,63)XRAW(1),YRAW(1),ZRAW(1),PY(1),PX(1) 63 FORMAT('XRAW(1),YRAW(1),ZRAW(1),PY(1),PX(1) = ',5E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,64)XRAW(2),YRAW(2),ZRAW(2),PY(2),PX(2) 64 FORMAT('XRAW(2),YRAW(2),ZRAW(2),PY(2),PX(2) = ',5E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,65)XRAW(NP),YRAW(NP),ZRAW(NP),PY(NP),PX(NP) CCCCC MAY 1996. FIX FOLLOWING FORMAT CCC65 FORMAT('XRAW(NP),YRAW(NP),ZRAW(NP),PY(NP),PX(NP) = ',4E15.7) 65 FORMAT('XRAW(NP),YRAW(NP),ZRAW(NP),PY(NP),PX(NP) = ',5E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,67)NUMSET 67 FORMAT('NUMSET = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,68)ICASPL,ICAS3D,I3DPRO 68 FORMAT('ICASPL,ICAS3D,I3DPRO = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,69)ISQUAR,XDELMN,YDELMN,ZDELMN 69 FORMAT('ISQUAR,XDELMN,YDELMN,ZDELMN = ',A4,2X,3E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,71)IOPGRS 71 FORMAT('IOPGRS = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,72)IOPG2S 72 FORMAT('IOPG2S = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,73)IDELIS 73 FORMAT('IDELIS = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,74)IDRFRS 74 FORMAT('IDRFRS = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,75)IWRLAS 75 FORMAT('IWRLAS = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,76)IWRLES 76 FORMAT('IWRLES = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,77)IDRTRS 77 FORMAT('IDRTRS = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,78)ICLG2S 78 FORMAT('ICLG2S = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,79)ICLGRS 79 FORMAT('ICLGRS = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,80)ITEXSY,ITEXSP 80 FORMAT('ITEXSY,ITEXSP = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,81)IMANUF,IMODEL 81 FORMAT('IMANUF,IMODEL = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,82)IREPCH 82 FORMAT('IREPCH = ',A1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,89)IBUGG4,ISUBG4,IERRG4 89 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C ************************************************** C ** STEP 11-- ** C ** EXTRACT SETTINGS FOR THIS PARTICULAR TRACE ** C ************************************************** C CCCCC IF(IOPGRS.EQ.'ON')GOTO1119 CCCCC IF(ICLGRS.EQ.'ON')GOTO1119 C ICH2PA=ICHAPA(ISET3) ICH2FO=ICHAFO(ISET3) ICH2CA=ICHACA(ISET3) ICH2JU=ICHAJU(ISET3) ICH2DI=ICHADI(ISET3) ACH2AN=ACHAAN(ISET3) ICH2FI=ICHAFI(ISET3) ICH2CO=ICHACO(ISET3) PCH2HE=PCHAHE(ISET3) PCH2WI=PCHAWI(ISET3) PCH2TH=PCHATH(ISET3) PCH2HO=PCHAHO(ISET3) PCH2VO=PCHAVO(ISET3) ILI2PA=ILINPA(ISET3) ILI2CO=ILINCO(ISET3) PLI2TH=PLINTH(ISET3) IFI2SW=IFILSW(ISET3) IFI2PA=IFILPA(ISET3) IFI2CO=IFILCO(ISET3) PFI2SP=PFILSP(ISET3) PFI2TH=PFILTH(ISET3) IPA2SW=IPATSW(ISET3) IPA2PA=IPATPA(ISET3) IPA2LI=IPATLI(ISET3) IPA2CO=IPATCO(ISET3) PPA2HE=PPATHE(ISET3) PPA2WI=PPATWI(ISET3) PPA2SP=PPATSP(ISET3) PPA2TH=PPATTH(ISET3) ISP2SW=ISPISW(ISET3) ISP2LI=ISPILI(ISET3) ISP2CO=ISPICO(ISET3) ISP2DI=ISPIDI(ISET3) PSP2TH=PSPITH(ISET3) ASP2BA=ASPIBA(ISET3) C IBA2SW=IBARSW(ISET3) ABA2WI=ABARWI(ISET3) ABA2BA=ABARBA(ISET3) IBA2BL=IBABLI(ISET3) IBA2BC=IBABCO(ISET3) PBA2BT=PBABTH(ISET3) IBA2FS=IBAFSW(ISET3) IBA2FC=IBAFCO(ISET3) IBA2PT=IBAPTY(ISET3) IBA2PL=IBAPLI(ISET3) IBA2PC=IBAPCO(ISET3) IBA2TY=IBARTY(ISET3) IBA2DI=IBARDI(ISET3) PBA2PS=PBAPSP(ISET3) PBA2PT=PBAPTH(ISET3) C IRE2SW=IREGSW(ISET3) ARE2WI=AREGWI(ISET3) ARE2BA=AREGBA(ISET3) IRE2BL=IREBLI(ISET3) IRE2BC=IREBCO(ISET3) PRE2BT=PREBTH(ISET3) IRE2FS=IREFSW(ISET3) IRE2FC=IREFCO(ISET3) IRE2PT=IREPTY(ISET3) IRE2PL=IREPLI(ISET3) IRE2PC=IREPCO(ISET3) PRE2PS=PREPSP(ISET3) PRE2PT=PREPTH(ISET3) C IMA2SW=IMARSW(ISET3) AMA2WI=AMARWI(ISET3) AMA2BA=AMARBA(ISET3) IMA2BL=IMABLI(ISET3) IMA2BC=IMABCO(ISET3) PMA2BT=PMABTH(ISET3) IMA2FS=IMAFSW(ISET3) IMA2FC=IMAFCO(ISET3) IMA2PT=IMAPTY(ISET3) IMA2PL=IMAPLI(ISET3) IMA2PC=IMAPCO(ISET3) PMA2PS=PMAPSP(ISET3) PMA2PT=PMAPTH(ISET3) C ITE2SW=ITEXSW(ISET3) ATE2WI=ATEXWI(ISET3) ATE2BA=ATEXBA(ISET3) ITE2BL=ITEBLI(ISET3) ITE2BC=ITEBCO(ISET3) PTE2BT=PTEBTH(ISET3) ITE2FS=ITEFSW(ISET3) ITE2FC=ITEFCO(ISET3) ITE2PT=ITEPTY(ISET3) ITE2PL=ITEPLI(ISET3) ITE2PC=ITEPCO(ISET3) PTE2PS=PTEPSP(ISET3) PTE2PT=PTEPTH(ISET3) C IF(ISTEP.EQ.2.AND.ISUBST.EQ.3)ICH2PA=ICH3PA IF(ISTEP.EQ.2.AND.ISUBST.EQ.4)ICH2PA=ICH3PA IF(ICASPL.EQ.'YCUB'.AND.ISET3.EQ.1)THEN ICH2PA='ZVAL' ILI2PA='BLAN' ENDIF C 1119 CONTINUE C IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'OTG2')GOTO1190 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1121) 1121 FORMAT('***** FROM THE MIDDLE OF PLOTG3--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1131)ILI2PA,PLI2TH,ILI2CO 1131 FORMAT('ILI2PA,PLI2TH,ILI2CO = ',A4,2X,E15.7,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1132)ICH2PA,ICH2FO,ICH2CA,ICH2JU 1132 FORMAT('ICH2PA,ICH2FO,ICH2CA,ICH2JU = ',A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1133)ICH2DI,ACH2AN,ICH2FI,ICH2CO 1133 FORMAT('ICH2DI,ACH2AN,ICH2FI,ICH2CO = ',A4,E15.7,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1134)PCH2HE,PCH2WI,PCH2TH,PCH2HO,PCH2VO 1134 FORMAT('PCH2HE,PCH2WI,PCH2TH,PCH2HO,PCH2VO = ',5E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1135)IFI2SW,IFI2PA,IFI2CO,PFI2SP,PFI2TH 1135 FORMAT('IFI2SW,IFI2PA,IFI2CO,PFI2SP,PFI2TH = ',A4,2X,A4,2X,A4, 12E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1136)IPA2SW,IPA2PA,IPA2LI,IPA2CO 1136 FORMAT('IPA2SW,IPA2PA,IPA2LI,IPA2CO = ',A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1138)ISP2SW,ISP2LI,ISP2CO,PSP2TH,ASP2BA 1138 FORMAT('ISP2SW,ISP2LI,ISP2CO,PSP2TH,ASP2BA = ',A4,2X,A4,2X,A4, 12E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1141)IBA2SW,ABA2WI,ABA2BA 1141 FORMAT('IBA2SW,ABA2WI,ABA2BA = ',A4,2X,2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1142)IBA2BL,IBA2BC,PBA2BT 1142 FORMAT('IBA2BL,IBA2BC,PBA2BT = ',A4,2X,A4,2X,E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1143)IBA2FS,IBA2FC 1143 FORMAT('IBA2FS,IBA2FC = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1144)IBA2PT,IBA2PL,IBA2PC,IBA2TY,PBA2PS,PBA2PT 1144 FORMAT('IBA2PT,IBA2PL,IBA2PC,IBA2TY,PBA2PS,PBA2PT = ', 1A4,2X,A4,2X,A4,2X,A4,2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1151)IRE2SW,ARE2WI,ARE2BA 1151 FORMAT('IRE2SW,ARE2WI,ARE2BA = ',A4,2X,2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1152)IRE2BL,IRE2BC,PRE2BT 1152 FORMAT('IRE2BL,IRE2BC,PRE2BT = ',A4,2X,A4,2X,E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1153)IRE2FS,IRE2FC 1153 FORMAT('IRE2FS,IRE2FC = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1154)IRE2PT,IRE2PL,IRE2PC,PRE2PS,PRE2PT 1154 FORMAT('IRE2PT,IRE2PL,IRE2PC,PRE2PS,PRE2PT = ',A4,2X,A4,2X, 1A4,2X,2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1161)IMA2SW,AMA2WI,AMA2BA 1161 FORMAT('IMA2SW,AMA2WI,AMA2BA = ',A4,2X,2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1162)IMA2BL,IMA2BC,PMA2BT 1162 FORMAT('IMA2BL,IMA2BC,PMA2BT = ',A4,2X,A4,2X,E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1163)IMA2FS,IMA2FC 1163 FORMAT('IMA2FS,IMA2FC = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1164)IMA2PT,IMA2PL,IMA2PC,PMA2PS,PMA2PT 1164 FORMAT('IMA2PT,IMA2PL,IMA2PC,PMA2PS,PMA2PT = ',A4,2X,A4,2X, 1A4,2X,2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1171)ITE2SW,ATE2WI,ATE2BA 1171 FORMAT('ITE2SW,ATE2WI,ATE2BA = ',A4,2X,2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1172)ITE2BL,ITE2BC,PTE2BT 1172 FORMAT('ITE2BL,ITE2BC,PTE2BT = ',A4,2X,A4,2X,E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1173)ITE2FS,ITE2FC 1173 FORMAT('ITE2FS,ITE2FC = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1174)ITE2PT,ITE2PL,ITE2PC,PTE2PS,PTE2PT 1174 FORMAT('ITE2PT,ITE2PL,ITE2PC,PTE2PS,PTE2PT = ',A4,2X,A4,2X, 1A4,2X,2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') 1190 CONTINUE C C ***************************************** C ** STEP 21-- ** C ** STEP THROUGH EACH GRAPHICS DEVICE ** C ***************************************** C ISYMBL=ITEXSY ISPAC=ITEXSP C CCCCC THE FOLLOWING 6 LINES WERE ADDED AUGUST 1992 CCCCC TO AUTOMATICALLY CLOSE/OPEN DEVICE 3 CCCCC WHENEVER AN INITIALIZATION/ERASE IS DONE CCCCC (SEE ALSO DPERAS AND MAINOD) C IF(IERASW.EQ.'ON')THEN IF(IOPG2S.EQ.'ON')THEN IBUGXX=IBUGG4 ISUBXX=ISUBG4 IERRXX=IERRG4 IF(IPL2CS.EQ.'OPEN') 1 CALL DPDEV(3,'CLOS','POST',ICAPSW,IBUGXX,ISUBXX,IERRXX) IF(IPL2CS.EQ.'CLOSED') 1 CALL DPDEV(3,'OPEN','POST',ICAPSW,IBUGXX,ISUBXX,IERRXX) IF(IPXMFL.EQ.'ON' .OR. IPXMFL.EQ.'YES')THEN NUMPXM=NUMPXM+1 IF(NUMPXM.GT.MAXPM)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG') WRITE(ICOUT,2011)MAXPM GOTO2099 ENDIF 2011 FORMAT('***** ERROR FROM PLOTG3. MAXIMUM NUMBER OF PIXMAPS (', 1I5,') EXCEEDED.') IPXMFN(NUMPXM)(1:IPXMNC)=IPXMFB(1:IPXMNC) NCSTR=IPXMNC+1 IF(NUMPXM.LE.9)THEN WRITE(IPXMFN(NUMPXM)(NCSTR:NCSTR),'(I1)')NUMPXM ELSEIF(NUMPXM.LE.99)THEN WRITE(IPXMFN(NUMPXM)(NCSTR:NCSTR+1),'(I2)')NUMPXM NCSTR=NCSTR+1 ELSEIF(NUMPXM.LE.999)THEN WRITE(IPXMFN(NUMPXM)(NCSTR:NCSTR+2),'(I3)')NUMPXM NCSTR=NCSTR+2 ENDIF CCCCC DECEMBER 1997. FOR DEVICE GENERALITY, GO THROUGH GRSAGR. ICODE='SAVE' CTEMP=' ' NCTEMP=0 ISTRI2=' ' ISTRI2(1:NCSTR)=IPXMFN(NUMPXM)(1:NCSTR) CALL GRSAGR(ICODE,ISTRI2,NCSTR,CTEMP,NCTEMP) ENDIF C CCCCC DO2030I=1,NCSTR CCCCC CALL DPCOAN(IPXMFN(NUMPXM)(I:I),IADE(I)) C2030 CONTINUE CCCCC IERR=0 CCCCC CALL XSAVEG(IADE,IERR) CCCCC IF(IERR.EQ.1)THEN CCCCC WRITE(ICOUT,999) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,2041) CCCCC CALL DPWRST('XXX','BUG ') CCCCC GOTO2099 C2041 FORMAT('***** ERROR IN PLOTG2--WRITING BIT MAP UNSUCCESSFUL.') CCCCC ELSEIF(IERR.EQ.2)THEN CCCCC NUMPXM=NUMPXM-1 CCCCC WRITE(ICOUT,999) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,2043) CCCCC CALL DPWRST('XXX','BUG ') CCCCC GOTO2099 C2043 FORMAT('***** ERROR IN PLOTG2--NO CURRENT PIXMAP TO SAVE.') CCCCC ELSEIF(IERR.EQ.3)THEN CCCCC WRITE(ICOUT,999) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,2045) CCCCC CALL DPWRST('XXX','BUG ') CCCCC GOTO2099 C2045 FORMAT('***** ERROR IN PLOTG2--X11 HAS NOT BEEN OPENED.') CCCCC ELSEIF(IERR.EQ.4)THEN CCCCC WRITE(ICOUT,999) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,2047) CCCCC CALL DPWRST('XXX','BUG ') CCCCC GOTO2099 C2047 FORMAT('***** ERROR IN PLOTG2--X11 NOT INSTALLED ON THIS ', CCCCC1'IMPLEMENTATION.') CCCCC ELSE CCCCC IF(IPXMCM(NUMPXM).EQ.' ')THEN CCCCC IPXMCM(NUMPXM)(1:128)=IPXMFN(NUMPXM)(1:128) CCCCC ENDIF CCCCC GOTO2099 CCCCC ENDIF CCCCC ENDIF ENDIF ENDIF 2099 CONTINUE C DO2100IDEV=1,NUMDEV C ICONT=IDCONT(IDEV) CCCCC THE FOLLOWING LINE WAS INSERTED AUGUST 1992. (ALAN) IPOWER=IDPOWE(IDEV) IMANUF=IDMANU(IDEV) IMODEL=IDMODE(IDEV) IMODE2=IDMOD2(IDEV) IMODE3=IDMOD3(IDEV) IGCODE=IDCODE(IDEV) IGUNIT=IDUNIT(IDEV) C CCCCC FEBRUARY 2006: DEVICE 1 LATEX TO CAPTURE FILE C C APRIL 2006: COMMENT OUT THIS SECTION FOR NOW, HANDLED C ELSEWHERE (IMACNU NOT PASSED TO THIS ROUTINE) C CCCCC IF(IDEV.EQ.1 .AND. IMANUF.EQ.'LATE' .AND. CCCCC1 IGUNIT.EQ.IMACNU)THEN CCCCC IGUNIT=IMACNU CCCCC ENDIF C NUMHPP=IDNHPP(IDEV) ANUMHP=NUMHPP NUMVPP=IDNVPP(IDEV) ANUMVP=NUMVPP CCCCC THE FOLLOWING 2 LINES WERE INSERTED AUGUST 1992. (ALAN) IOFFSV=IDNVOF(IDEV) IOFFSH=IDNHOF(IDEV) IGCOLO=IDCOLO(IDEV) IGBAUD=IDBAUD(IDEV) ISOFT=IDSOFT(IDEV) ISOFT2=IDSOF2(IDEV) ISOFT3=IDSOF3(IDEV) CCCCC THE FOLLOWING LINE WAS INSERTED JULY 1996. (ALAN) IGFONT=IDFONT(IDEV) C IF(ICONT.EQ.'OFF')GOTO2100 C CCCCC THE FOLLOWING LINE WAS INSERTED AUGUST 1992. (ALAN) CCCCC IF HAVE DEVICE 2 OFF COMMAND, CCCCC DO NOT SET DEFAULT DEVICE. CCCCC SET POWER OFF, WHEN POWER OFF DON'T DO PLOT. DEVICE 2 ON ??? CCCCC WILL TURN ON WHATEVER CURRENT DEVICE IS. CCCCC THIS ALLOWS PLOT FILE TO BE TOGGLED ON AND OFF CONVIENTLY. IF(IPOWER.EQ.'OFF')GOTO2100 IF(ISQUAR.EQ.'ON')GOTO2110 IF(ICASPL.EQ.'PIEC')GOTO2110 GOTO2190 2110 CONTINUE PSAVE=PXMAX PYDEL=PYMAX-PYMIN PXDEL=PYDEL*(ANUMVP/ANUMHP) PXMAX=PXMIN+PXDEL 2190 CONTINUE C C *************************************************** C ** STEP 31-- ** C ** CARRY OUT OPENING OPERATIONS ** C ** ON THE DEVICES AND ON THE GRAPHICS SOFTWARE ** C *************************************************** C IF(IOPGRS.EQ.'ON') 1CALL DPOPDE C C **************************************************************** C ** STEP 32-- C ** CARRY OUT MINOR PRE-PLOT ACTIVITIES-- C ** ERASE THE SCREEN, FILL THE BACKGROUND, RING THE BELL, ETC. C **************************************************************** C IF(IOPG2S.EQ.'ON') 1CALL DPOPPL(IGRASW, 1IBELSW,NUMRIN,IERASW, 1IBACCO) CCCCC FOLLOWING LINES ADDED MARCH, 1990 FOR X11. X11 LIBRARY CAN CCCCC DYNAMICALLY MODIFY THE PICTURE POINTS. THE ERASE SCREEN ROUTINE CCCCC GETS THE UPDATED VALUES. IF(IMANUF.EQ.'X11')THEN NUMVPP=ANUMVP+0.5 NUMHPP=ANUMHP+0.5 IDNVPP(IDEV)=NUMVPP IDNHPP(IDEV)=NUMHPP ENDIF CCCCC END CHANGES CCCCC FOLLOWING LINES ADDED OCTOBER, 1996 FOR QWIN. QWIN LIBRARY CAN CCCCC DYNAMICALLY MODIFY THE PICTURE POINTS. THE ERASE SCREEN ROUTINE CCCCC GETS THE UPDATED VALUES. IF(IMANUF.EQ.'QWIN')THEN NUMVPP=ANUMVP+0.5 NUMHPP=ANUMHP+0.5 IDNVPP(IDEV)=NUMVPP IDNHPP(IDEV)=NUMHPP ENDIF CCCCC END CHANGES C C ************************************************ C ** STEP 33-- ** C ** IF HAVE NO POINTS BEING PLOTTED ** C ** (AND THEREFORE ONLY INTERESTED IN SEEING ** C ** THE TITLES, LABELS, LEGENDS, ETC.) ** C ** THEN SKIP DOWN TO THOSE SECTIONS. ** C ************************************************ C IF(NP.LE.0)GOTO5700 C C ************************************************** C ** STEP 34-- ** C ** FOR 3-D PLOTS, ** C ** FOR THE FIRST TIME THROUGH, ** C ** COMPUTE MIN'S, MAX'S, MID'S, AND RANGES. ** C ** COMPUTE EYE COORDINATES AND ORIGINS. ** C ************************************************** C IF(IDELIS.EQ.'ON')GOTO3400 GOTO3790 C 3400 CONTINUE XEYE0=AEYEXC YEYE0=AEYEYC ZEYE0=AEYEZC C XORIG=AORIXC YORIG=AORIYC ZORIG=AORIZC C CALL D3DELI(XRAW,YRAW,ZRAW,NP, 1XEYE0,YEYE0,ZEYE0, 1XORIG,YORIG,ZORIG, 1X3DMIN,Y3DMIN,Z3DMIN, 1X3DMAX,Y3DMAX,Z3DMAX, 1X3DMID,Y3DMID,Z3DMID, 1X3DRAN,Y3DRAN,Z3DRAN, 1X3DEYE,Y3DEYE,Z3DEYE, 1X3DORI,Y3DORI,Z3DORI, 1XPRIME,YPRIME,ZPRIME, 1IBUGG4,ISUBG4,IERRG4) C C ************************************************** C ** STEP 35-- ** C ** FOR 3-D PLOTS, ** C ** COMPUTE DIRECTION NUMBERS AND DIRECTION COSI**NES C ** (THESE ARE NEEDED FOR ROTATION FROM 3-D TO **2-D) C ************************************************** C CALL D3DEDC(XRAW,YRAW,ZRAW,NP, 1X3DEYE,Y3DEYE,Z3DEYE, 1D3DCXX,D3DCXY,D3DCXZ, 1D3DCYX,D3DCYY,D3DCYZ, 1D3DCZX,D3DCZY,D3DCZZ, 1TERMXX,TERMXY,TERMXZ, 1TERMYX,TERMYY,TERMYZ, 1TERMZX,TERMZY,TERMZZ, 1IBUGG4,ISUBG4,IERRG4) C C ******************************************** C ** STEP 36-- ** C ** DETERMINE DATA LIMITS, FRAME LIMITS, ** C ** AND TIC COORDINATES. ** C ******************************************** C CALL D3TR32(XRAW,YRAW,ZRAW,NP,XT,ZT,NT) CCCCC NPRIME=12 CCCCC CALL D3TR32(XPRIME,YPRIME,ZPRIME,NPRIME,XT,YT) C CALL DPDELI(ZT,XT,PX,NT,NUMSET, 1ICASPL,ICAS3D, 1XDELMN) IF(IERRG4.EQ.'YES')GOTO9000 C C ************************************************** C ** STEP 37-- ** C ** FOR 3-D PLOTS, ** C ** DETERMINE MINIMUM DISTANCE BETWEEN POINTS ** C ** (NEEDED FOR BAR PLOTS) ** C ************************************************** C CALL D3DEMD(XRAW,YRAW,ZRAW,PX3,NP, 1XDELMN,YDELMN,ZDELMN) C 3790 CONTINUE C C ********************************************* C ** STEP 41-- ** C ** DRAW A DATA-DEFINED GENERALIZED TRACE. ** C ** THE TRACE MAY CONSIST OF ANY OR ALL ** C ** OF THE FOLLOWING-- ** C ** 1. CHARACTERS ** C ** 2. LINES ** C ** 3. BARS ** C ** 4. SPIKES ** C ********************************************* C IF(IDRTRS.EQ.'ON')GOTO4100 GOTO4190 C 4100 CONTINUE C CCCCC IF(IFI2SW.EQ.'ON') CCCCC1CALL DPFIRS(ZT,XT,PY,PX,NP, CCCCC1ICASPL,ICAS3D, CCCCC1ISORSW, CCCCC1IFI2PA,IFI2CO,PFI2SP,PFI2TH, CCCCC1PXMIN,PXMAX,PYMIN,PYMAX, CCCCC1FX1MIN,FX1MAX,FY1MIN,FY1MAX, CCCCC1IX1TSC,IY1TSC) C CCCCC IF(IPA2SW.EQ.'ON') CCCCC1CALL DPDRPS(ZT,XT,PY,PX,NP, CCCCC1ICASPL,ICAS3D, CCCCC1ISORSW, CCCCC1IPA2PA,IPA2LI,IPA2CO,PPA2HE,PPA2WI,PPATSP,PPA2TH, CCCCC1PXMIN,PXMAX,PYMIN,PYMAX, CCCCC1FX1MIN,FX1MAX,FY1MIN,FY1MAX, CCCCC1IX1TSC,IY1TSC) C IF(ICASPL.EQ.'HIST')GOTO4119 IF(ICASPL.EQ.'CUMH')GOTO4119 IF(ICASPL.EQ.'BARP')GOTO4119 IF(ICASPL.EQ.'ROOT')GOTO4119 IF(ICASPL.EQ.'CUMR')GOTO4119 IF(ICASPL.EQ.'BIHI')GOTO4119 C ICH2SW='ON' IF(ICH2PA.EQ.'OFF')ICH2SW='OFF' IF(ICH2PA.EQ.'BLAN')ICH2SW='OFF' IF(ICH2PA.EQ.'BL')ICH2SW='OFF' IF(ICH2PA.EQ.' ')ICH2SW='OFF' IF(ICH2PA.EQ.'NONE')ICH2SW='OFF' IF(ICH2PA.EQ.'NO')ICH2SW='OFF' IF(ICH2SW.EQ.'ON') 1CALL D3DRCH(XRAW,YRAW,ZRAW,PX,PY,PZ,NP,PY2,PX2,NP2,DSIZE, 1ICASPL,ICAS3D, 1ISORSW, 1ICH2PA,ICH2FO,ICH2CA,ICH2JU,ICH2DI,ACH2AN,ICH2FI,ICH2CO, 1PCH2HE,PCH2WI,PCH2TH,PCH2HO,PCH2VO, 1ITEXSP, 1PXMIN,PXMAX,PYMIN,PYMAX, 1FX1MIN,FX1MAX,FY1MIN,FY1MAX, 1IX1TSC,IY1TSC, 1IMPSW2,AMPSCH,AMPSCW) C ILI2SW='ON' IF(ILI2PA.EQ.'OFF')ILI2SW='OFF' IF(ILI2PA.EQ.'BLAN')ILI2SW='OFF' IF(ILI2PA.EQ.'BL')ILI2SW='OFF' IF(ILI2PA.EQ.' ')ILI2SW='OFF' IF(ILI2PA.EQ.'NONE')ILI2SW='OFF' IF(ILI2PA.EQ.'NO')ILI2SW='OFF' IF(ILI2SW.EQ.'ON') 1CALL D3DRTR(XRAW,YRAW,ZRAW,PX,PY,PZ,NP,PY2,PX2,NP2, 1PY3,PX3,NP3, 1ICASPL,ICAS3D, 1ISORSW, 1ILI2PA,ILI2CO,PLI2TH, 1ARE2BA, 1IRE2FS,IRE2FC, 1IRE2PT,IRE2PL,IRE2PC,PRE2PT,PRE2PS, 1PXMIN,PXMAX,PYMIN,PYMAX, 1FX1MIN,FX1MAX,FY1MIN,FY1MAX, 1IX1TSC,IY1TSC) 4119 CONTINUE C IF(IBA2SW.EQ.'ON'.OR. 1ICASPL.EQ.'HIST'.OR. 1ICASPL.EQ.'CUMH'.OR. 1ICASPL.EQ.'BARP'.OR. 1ICASPL.EQ.'ROOT'.OR. 1ICASPL.EQ.'CUMR'.OR. 1ICASPL.EQ.'BIHI') 1CALL D3DRBA(XRAW,YRAW,ZRAW,NP, 1PX,PY,PZ,PX2,PY2,PZ2,PX3,PY3, 1ICASPL,ICAS3D, 1ISORSW, 1IBA2SW,ABA2WI,ABA2BA, 1IBA2BL,IBA2BC,PBA2BT, 1IBA2FS,IBA2FC, 1IBA2PT,IBA2PL,IBA2PC,IBA2TY,IBA2DI,PBA2PS,PBA2PT, 1XDELMN,YDELMN,ZDELMN, 1PXMIN,PXMAX,PYMIN,PYMAX, 1FX1MIN,FX1MAX,FY1MIN,FY1MAX, 1IX1TSC,IY1TSC) C IF(ISP2SW.EQ.'ON') 1CALL D3DRSP(XRAW,YRAW,ZRAW,NP, 1PX,PY,PZ,PX2,PY2,PZ2,PX3,PY3, 1ICASPL,ICAS3D, 1ISORSW, 1ISP2LI,ISP2CO,ISP2DI,PSP2TH,ASP2BA, 1PXMIN,PXMAX,PYMIN,PYMAX, 1FX1MIN,FX1MAX,FY1MIN,FY1MAX, 1IX1TSC,IY1TSC) C 4190 CONTINUE C C ************************************************** C ** STEP 51-- ** C ** DRAW THE BASEPLANE AND BACKPLANE ** C ************************************************** C C ************************************************** C ** STEP 52-- ** C ** DRAW THE PEDESTAL ** C ************************************************** C C ******************************************************** C ** STEP 56-- ** C ** DRAW THE FRAME, TICS, TIC LABELS, AND GRID LINES ** C ******************************************************** C IF(IDRFRS.EQ.'ON') CCCCC THE FOLLOWING LINE WAS CHANGED SEPTEMBER 1993 CCCCC SO AS TO ALLOW 3-D FRAMES SEPTEMBER 1993 CCCCC1CALL DPDRFR(ICASPL,ICAS3D, 1CALL D3DRFR(ICASPL,ICAS3D,FRAM3D, 1X3DMIN,X3DMAX,Y3DMIN,Y3DMAX,Z3DMIN,Z3DMAX, 1IVGMSW,IHGMSW) IF(IERRG4.EQ.'YES')GOTO9000 C C ********************************* C ** STEP 57-- ** C ** DRAW THE LABELS AND TITLE ** C ********************************* C 5700 CONTINUE C CCCCC IF(IWRLAS.EQ.'ON')CALL DPWRLA(PXMIN,PYMIN,PXMAX,PYMAX, DEC. 1986 IF(IWRLAS.EQ.'ON')GOTO5710 GOTO5790 C 5710 CONTINUE ITITCV(1)=ITITFO ITITCV(2)=ITITCA ITITCV(3)=ITITFI ITITCV(4)=ITITCO PTITRV(1)=PTITHE PTITRV(2)=PTITWI PTITRV(3)=PTITVG PTITRV(4)=PTITHG PTITRV(5)=PTITTH PTITRV(6)=PTITDS C IX1LCV(1)=IX1LFO IX1LCV(2)=IX1LCA IX1LCV(3)=IX1LFI IX1LCV(4)=IX1LCO IX1LCV(5)=IX1LJU IX1LCV(6)=IX1LDI PX1LRV(1)=PX1LHE PX1LRV(2)=PX1LWI PX1LRV(3)=PX1LVG PX1LRV(4)=PX1LHG PX1LRV(5)=PX1LTH PX1LRV(6)=PX1LDS PX1LRV(7)=PX1LOF PX1LRV(8)=PX1LAN C IX2LCV(1)=IX2LFO IX2LCV(2)=IX2LCA IX2LCV(3)=IX2LFI IX2LCV(4)=IX2LCO IX2LCV(5)=IX2LJU IX2LCV(6)=IX2LDI PX2LRV(1)=PX2LHE PX2LRV(2)=PX2LWI PX2LRV(3)=PX2LVG PX2LRV(4)=PX2LHG PX2LRV(5)=PX2LTH PX2LRV(6)=PX2LDS PX2LRV(7)=PX2LOF PX2LRV(8)=PX2LAN C IX3LCV(1)=IX3LFO IX3LCV(2)=IX3LCA IX3LCV(3)=IX3LFI IX3LCV(4)=IX3LCO IX3LCV(5)=IX3LJU IX3LCV(6)=IX3LDI PX3LRV(1)=PX3LHE PX3LRV(2)=PX3LWI PX3LRV(3)=PX3LVG PX3LRV(4)=PX3LHG PX3LRV(5)=PX3LTH PX3LRV(6)=PX3LDS PX3LRV(7)=PX3LOF PX3LRV(8)=PX3LAN C IY1LCV(1)=IY1LFO IY1LCV(2)=IY1LCA IY1LCV(3)=IY1LFI IY1LCV(4)=IY1LCO IY1LCV(5)=IY1LJU IY1LCV(6)=IY1LDI PY1LRV(1)=PY1LHE PY1LRV(2)=PY1LWI PY1LRV(3)=PY1LVG PY1LRV(4)=PY1LHG PY1LRV(5)=PY1LTH PY1LRV(6)=PY1LDS PY1LRV(7)=PY1LOF PY1LRV(8)=PY1LAN C IY2LCV(1)=IY2LFO IY2LCV(2)=IY2LCA IY2LCV(3)=IY2LFI IY2LCV(4)=IY2LCO IY2LCV(5)=IY2LJU IY2LCV(6)=IY2LDI PY2LRV(1)=PY2LHE PY2LRV(2)=PY2LWI PY2LRV(3)=PY2LVG PY2LRV(4)=PY2LHG PY2LRV(5)=PY2LTH PY2LRV(6)=PY2LDS PY2LRV(7)=PY2LOF PY2LRV(8)=PY2LAN C CALL DPWRLA(PXMIN,PYMIN,PXMAX,PYMAX, 1ITITTE,NCTITL,ITITCV,PTITRV, 1IX1LTE,NCX1LA,IX1LCV,PX1LRV, 1IX2LTE,NCX2LA,IX2LCV,PX2LRV, 1IX3LTE,NCX3LA,IX3LCV,PX3LRV, 1IY1LTE,NCY1LA,IY1LCV,PY1LRV, 1IY2LTE,NCY2LA,IY2LCV,PY2LRV, 1ISYMBL,ISPAC, 1IMPSW2,AMPSCH,AMPSCW, 1IHNAME,IHNAM2,IUSE,IVALUE,VALUE,NUMNAM, 1IVSTAR,IVSTOP,IFUNC,NUMCHF,IREPCH,ISEQSW,NUMSEQ) C 5790 CONTINUE C C *********************************************************** C ** STEP 58-- ** C ** DRAW THE LEGENDS, LEGEND BOXES, SEGMENTS AND ARROWS ** C *********************************************************** C CCCCC AUGUST 1995. ADD ILGENA TO LIST IF(IWRLES.EQ.'ON') 1CALL DPWRLE(ILEGTE,ILEGST,ILEGSP,ILEGNA, 1PLEGXC,PLEGYC, 1ILEGFO,ILEGCA,ILEGJU,ILEGDI,ALEGAN,ILEGFI,ILEGCO,ILEGUN, 1PLEGHE,PLEGWI,PLEGVG,PLEGHG,PLEGTH,NUMLEG, 1PBOXXC,PBOXYC, 1IBOBCO, CCCCC AUGUST 1992. FOLLOWING LINE MODIFIED AUGUST 1992 CCCCC1IBOPPA,IBOPCO, 1IBOPPA,IBOBPA, 1PBOPTH,PBOPGA, 1IBOFPA,IBOFCO, CCCCC THE FOLLOWING LINE WAS AUGMENTED FOR BOX SHADOW AUGUST 1992 CCCCC1PBOFTH,NUMBOX, 1PBOFTH,PBOSHE,PBOSWI,NUMBOX, 1PARRXC,PARRYC, 1IARRPA,IARRCO, 1PARRTH, 1PARHLE,PARHWI,NUMARR, 1PSEGXC,PSEGYC, 1ISEGPA,ISEGCO, 1PSEGTH,NUMSEG, 1IMPSW2,AMPSCH,AMPSCW, 1IHNAME,IHNAM2,IUSE,IVALUE,VALUE,NUMNAM, 1IVSTAR,IVSTOP,IFUNC,NUMCHF,IREPCH,ISYMBL,ISPAC) C C **************************************************************** C ** STEP 61-- ** C ** CARRY OUT POST-PLOT OPERATIONS-- ** C ** COPYING THE SCREEN, MOVING CURSOR TO HOME POSITION, ETC. ** C **************************************************************** C IF(ICLG2S.EQ.'ON') 1CALL DPCLPL(ICOPSW,NUMCOP, 1PGRAXF,PGRAYF, 1IGRASW,PDIAXC,PDIAYC,PDIAX2,PDIAY2, 1PDIAHE,PDIAWI,PDIAVG,PDIAHG) C C *************************************************** C ** STEP 62-- ** C ** CARRY OUT CLOSING OPERATIONS ** C ** ON THE DEVICES AND ON THE GRAPHICS SOFTWARE ** C *************************************************** C IF(ICLGRS.EQ.'ON') 1CALL DPCLDE C IF(ISQUAR.EQ.'ON')GOTO6210 IF(ICASPL.EQ.'PIEC')GOTO6210 GOTO6290 C 6210 CONTINUE PXMAX=PSAVE C 6290 CONTINUE C 2100 CONTINUE IF(IWRLAS.EQ.'ON'.AND.ISEQSW.EQ.'ON')NUMSEQ=NUMSEQ+1 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'OTG3')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF PLOTG3--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IMANUF,IMODEL 9012 FORMAT('IMANUF,IMODEL = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)IBUGG4,ISUBG4,IERRG4 9015 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9017)NUMSET 9017 FORMAT('NUMSET = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9018)ICASPL,ICAS3D,I3DPRO 9018 FORMAT('ICASPL,ICAS3D,I3DPRO = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9019)ISQUAR,XDELMN 9019 FORMAT('ISQUAR,XDELMN = ',A4,2X,E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9021)ILI2PA,ILI2SW 9021 FORMAT('ILI2PA,ILI2SW = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9022)ICH2PA,ICH2SW 9022 FORMAT('ICH2PA,ICH2SW = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9031)IBA2SW,ABA2WI,ABA2BA 9031 FORMAT('IBA2SW,ABA2WI,ABA2BA = ',A4,2X,2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9032)IBA2BL,IBA2BC,PBA2BT 9032 FORMAT('IBA2BL,IBA2BC,PBA2BT = ',A4,2X,A4,2X,E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9033)IBA2FS,IBA2FC 9033 FORMAT('IBA2FS,IBA2FC = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9034)IBA2PT,IBA2PL,IBA2PC,IBA2TY,PBA2PS,PBA2PT 9034 FORMAT('IBA2PT,IBA2PL,IBA2PC,IBA2TY,PBA2PS,PBA2PT = ', 1A4,2X,A4,2X,A4,2X,A4,2X,2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9035)ITEXSY,ITEXSP 9035 FORMAT('ITEXSY,ITEXSP = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9036)ISYMBL,ISPAC 9036 FORMAT('ISYMBL,ISPAC = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9041)IREPCH 9041 FORMAT('IREPCH = ',A1) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE PLOTN(Y,X,N,ICHAR,MAXCHA,ICASPL,ICAS3D, 1ITITTE,NCTITL, 1IX1LTE,NCX1LA, 1IX2LTE,NCX2LA, 1IX3LTE,NCX3LA, 1IY1LTE,NCY1LA, 1IY2LTE,NCY2LA, 1GX1MIN,GX1MAX,GY1MIN,GY1MAX, 1IERASW,IBUGU2,IERROR) C C PURPOSE--THIS SUBROUTINE YIELDS A NARROW-WIDTH (68-CHARACTER) C PLOT OF Y(I) VERSUS X(I). C NOTE--THE NARROW WIDTH OF THIS PLOT C MAKES IT APPROPRIATE FOR C USE ON A (DISCRETE) TERMINAL. C INPUT ARGUMENTS--Y = THE SINGLE PRECISION VECTOR OF C (UNSORTED OR SORTED) OBSERVATIONS C TO BE PLOTTED VERTICALLY. C --X = THE SINGLE PRECISION VECTOR OF C (UNSORTED OR SORTED) OBSERVATIONS C TO BE PLOTTED HORIZONTALLY. C --N = THE INTEGER NUMBER OF OBSERVATIONS C IN THE VECTOR X. C --ICHAR = THE HOLLERITH VECTOR OF C CHARACTERS (ONLY THE C FIRST OF WHICH WILL BE USED) C --MAXCHA = THE INTEGER NUMBER OF C CHARACTERS IN ICHAR(.) C OUTPUT--A NARROW-WIDTH (68-CHARACTER) TERMINAL PLOT C OF Y(I) VERSUS I. C THE BODY OF THE PLOT (NOT COUNTING AXIS VALUES C AND MARGINS) IS 17 ROWS (LINES) AND 41 COLUMNS. C PRINTING--YES. C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C COMMENT--NOTE THAT THE STORAGE REQUIREMENTS FOR THIS C (AND THE OTHER) TERMINAL PLOT SUBROUTINESS ARE . C VERY SMALL. C THIS IS DUE TO THE 'ONE LINE AT A TIME' ALGORITHM C EMPLOYED FOR THE PLOT. C REFERENCES--NONE. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--82.6 C ORIGINAL VERSION--FEBRUARY 1974. C UPDATED --APRIL 1974. C UPDATED --OCTOBER 1974. C UPDATED --OCTOBER 1975. C UPDATED --NOVEMBER 1975. C UPDATED --FEBRUARY 1977. C UPDATED --JUNE 1978. C UPDATED --NOVEMBER 1981. C UPDATED --DECEMBER 1981. C UPDATED --JANUARY 1982. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICHAR CHARACTER*4 ICASPL CHARACTER*4 ICAS3D C CHARACTER*4 ITITTE CHARACTER*4 IX1LTE CHARACTER*4 IX2LTE CHARACTER*4 IX3LTE CHARACTER*4 IY1LTE CHARACTER*4 IY2LTE C CHARACTER*4 IERASW CHARACTER*4 IBUGU2 CHARACTER*4 IERROR C CHARACTER*4 IBLANK CHARACTER*4 IHYPHE CHARACTER*4 IALPHI CHARACTER*4 IALPHX CHARACTER*4 ILABT CHARACTER*4 ILABY1 CHARACTER*4 ILABX1 CHARACTER*4 ILABX2 CHARACTER*4 ILABX3 CHARACTER*4 JPLOTC CHARACTER*4 ILINE CHARACTER*4 ICASP2 CHARACTER*4 IAXISC C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C DIMENSION Y(*) DIMENSION X(*) DIMENSION ICHAR(*) C DIMENSION ITITTE(*) DIMENSION IX1LTE(*) DIMENSION IX2LTE(*) DIMENSION IX3LTE(*) DIMENSION IY1LTE(*) DIMENSION IY2LTE(*) C DIMENSION ILABT(132) DIMENSION ILABY1(132) DIMENSION ILABX1(132) DIMENSION ILABX2(132) DIMENSION ILABX3(132) C DIMENSION ILINE(72) DIMENSION AILABL(10) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='PLOT' ISUBN2='N ' C IBLANK=' ' IHYPHE='-' IALPHI='I' IALPHX='X' C IMAXT=0 IMAXX1=0 IMAXX2=0 IMAXX3=0 C IF(IBUGU2.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('AT THE BEGINNING OF PLOTN--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)N,IBUGU2 52 FORMAT('N,IBUGU2 = ',I8,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)Y(1),X(1) 53 FORMAT('Y(1),X(1) = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)Y(N),X(N) 54 FORMAT('Y(N),X(N) = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,55)ICASPL,ICAS3D 55 FORMAT('ICASPL,ICAS3D = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,72)CPUMIN,CPUMAX 72 FORMAT('CPUMIN,CPUMAX = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,73)GX1MIN,GX1MAX,GY1MIN,GY1MAX 73 FORMAT('GX1MIN,GX1MAX,GY1MIN,GY1MAX = ',4E15.7) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C C *************************************************************** C ** STEP 2-- ** C ** DEFINE THE NUMBER OF ROWS AND COLUMNS WITHIN THE PLOT-- ** C ** THIS HAS BEEN SET TO 21 ROWS AND 41 COLUMNS. ** C *************************************************************** C CCCCC NUMROW=21 NUMROW=17 NUMCOL=41 C ANUMR=NUMROW ANUMRM=NUMROW-1 ANUMCM=NUMCOL-1 NUMR25=(NUMROW/4)+1 NUMR50=(NUMROW/2)+1 NUMR75=3*(NUMROW/4)+1 IXDEL=(NUMCOL-1)/4 C C ******************************** C ** STEP 2.2-- ** C ** DEFINE THE TYPE OF PLOT. ** C ******************************** C ICASP2=ICASPL IF(ICASPL.EQ.'MDBP')ICASP2='BOXP' IF(ICASPL.EQ.'MEBP')ICASP2='BOXP' IF(ICASPL.EQ.'VIPL')ICASP2='BOXP' IF(ICASPL.EQ.'MDIP')ICASP2='IPLO' IF(ICASPL.EQ.'MEIP')ICASP2='IPLO' IF(ICASPL.EQ.'MRIP')ICASP2='IPLO' IF(ICASPL.EQ.'MMIP')ICASP2='IPLO' C C ****************************************************** C ** STEP 3-- ** C ** PREPARE THE TITLE LINE, THE Y-AXIS LABEL, ** C ** AND THE 3 HORIZONTAL AXIS LABELS FOR PRINTING. ** C ****************************************************** C YMIDL=NUMROW/2 XMIDL=22+NUMCOL/2 C YFACT=1.0 XFACT=1.0 C ILENT=NCTITL ILENY1=NCY1LA ILENX1=NCX1LA ILENX2=NCX2LA ILENX3=NCX3LA C ALENT=ILENT ALENY1=ILENY1 ALENX1=ILENX1 ALENX2=ILENX2 ALENX3=ILENX3 C IX=XMIDL-XFACT*(ALENT/2.0) DO310I=1,132 ILABT(I)=' ' 310 CONTINUE J=IX-1 IF(ILENT.LE.0)GOTO319 DO315I=1,ILENT J=J+1 ILABT(J)=ITITTE(I) 315 CONTINUE IMAXT=J 319 CONTINUE C IY=YMIDL-YFACT*(ALENY1/2.0) DO320I=1,132 ILABY1(I)=' ' 320 CONTINUE J=IY-1 IF(ILENY1.LE.0)GOTO329 WRITE(6,777)I,J,ILENY1,IY,YMIDL,YFACT,ALENY1 777 FORMAT('I,J,ILENY1,IY,YMIDL,YFACT,ALENY1 = ',4I8,3E15.7) DO325I=1,ILENY1 J=J+1 ILABY1(J)=IY1LTE(I) 325 CONTINUE IMAXY1=J 329 CONTINUE C IX=XMIDL-XFACT*(ALENX1/2.0) DO330I=1,132 ILABX1(I)=' ' 330 CONTINUE J=IX-1 IF(ILENX1.LE.0)GOTO339 DO335I=1,ILENX1 J=J+1 ILABX1(J)=IX1LTE(I) 335 CONTINUE IMAXX1=J 339 CONTINUE C IX=XMIDL-XFACT*(ALENX2/2.0) DO340I=1,132 ILABX2(I)=' ' 340 CONTINUE J=IX-1 IF(ILENX2.LE.0)GOTO349 DO345I=1,ILENX2 J=J+1 ILABX2(J)=IX2LTE(I) 345 CONTINUE IMAXX2=J 349 CONTINUE C IX=XMIDL-XFACT*(ALENX3/2.0) DO350I=1,132 ILABX3(I)=' ' 350 CONTINUE J=IX-1 IF(ILENX3.LE.0)GOTO359 DO355I=1,ILENX3 J=J+1 ILABX3(J)=IX3LTE(I) 355 CONTINUE IMAXX3=J 359 CONTINUE C C **************************************************************** C ** STEP 4-- C ** SKIP TO NEW PAGE; C ** WRITE OUT THE TITLE (IF ANY); C ** WRITE OUT THE TOP HORIZONTAL AXIS OF THE PLOT; C **************************************************************** C IF(IERASW.EQ.'ON')WRITE(ICOUT,504) 504 FORMAT(1H1) IF(IERASW.EQ.'ON')CALL DPWRST('XXX','BUG ') IF(IERASW.EQ.'OFF')WRITE(ICOUT,999) IF(IERASW.EQ.'OFF')CALL DPWRST('XXX','BUG ') IF(IMAXT.GE.1)WRITE(ICOUT,505)(ILABT(I),I=1,IMAXT) 505 FORMAT(240A1) IF(IMAXT.GE.1)CALL DPWRST('XXX','BUG ') C DO500ICOL=1,NUMCOL ILINE(ICOL)=IHYPHE 500 CONTINUE DO550ICOL=1,NUMCOL,IXDEL ILINE(ICOL)=IALPHI 550 CONTINUE WRITE(ICOUT,555)(ILINE(I),I=1,NUMCOL) 555 FORMAT(20X,54A1) CALL DPWRST('XXX','BUG ') C C C ******************************************************* C ** STEP 5-- ** C ** DETERMINE THE MIN AND MAX VALUES OF Y AND OF X. ** C ******************************************************* C XMIN=X(1) XMAX=X(1) YMIN=Y(1) YMAX=Y(1) DO700I=1,N IF(X(I).LT.XMIN)XMIN=X(I) IF(X(I).GT.XMAX)XMAX=X(I) IF(Y(I).LT.YMIN)YMIN=Y(I) IF(Y(I).GT.YMAX)YMAX=Y(I) 700 CONTINUE IF(GX1MIN.NE.CPUMIN)XMIN=GX1MIN IF(GX1MAX.NE.CPUMAX)XMAX=GX1MAX IF(GY1MIN.NE.CPUMIN)YMIN=GY1MIN IF(GY1MAX.NE.CPUMAX)YMAX=GY1MAX DELX=XMAX-XMIN DELY=YMAX-YMIN XWIDTH=DELX/ANUMCM YWIDTH=DELY/ANUMRM C C **************************************************************** C ** STEP 6-- C ** DETERMINE AND WRITE OUT THE PLOT POSITIONS ONE LINE AT A TIM C **************************************************************** C DO1100IROW=1,NUMROW C DO1200ICOL=1,NUMCOL ILINE(ICOL)=IBLANK 1200 CONTINUE C AIROW=IROW YUPPER=YMAX+(1.5-AIROW)*YWIDTH YLABEL=YMAX+(1.0-AIROW)*YWIDTH YLOWER=YMAX+(0.5-AIROW)*YWIDTH IF(IROW.EQ.NUMROW)YLABEL=YMIN DO1300I=1,N AI=I IF(YLOWER.LE.Y(I).AND.Y(I).LT.YUPPER)GOTO1350 GOTO1300 1350 CONTINUE ICOL=((X(I)-XMIN)/XWIDTH)+1.5 IF(ICOL.LT.1.OR.ICOL.GT.NUMCOL)GOTO1300 JPLOTC=ICHAR(1) IF(JPLOTC.EQ.' ')JPLOTC='X' IF(JPLOTC.EQ.'BLAN')JPLOTC='X' IF(JPLOTC.EQ.'NONE')JPLOTC='X' ILINE(ICOL)=JPLOTC 1300 CONTINUE C ICOLMX=1 DO1400ICOL=1,NUMCOL ICOLRV=NUMCOL-ICOL+1 IF(ILINE(ICOLRV).EQ.' ')GOTO1400 ICOLMX=ICOLRV GOTO1490 1400 CONTINUE 1490 CONTINUE C IAXISC=IALPHI IF(IROW.EQ.1.OR.IROW.EQ.NUMROW)IAXISC=IHYPHE IF(IROW.EQ.NUMR25.OR.IROW.EQ.NUMR50.OR.IROW.EQ.NUMR75) 1IAXISC=IHYPHE WRITE(ICOUT,1410)ILABY1(IROW),YLABEL,IAXISC, 1(ILINE(ICOL),ICOL=1,ICOLMX) 1410 FORMAT(A1,1X,E14.7,1X,A1,2X,50A1) CALL DPWRST('XXX','BUG ') C 1100 CONTINUE C C ************************************************************ C ** STEP 7-- ** C ** WRITE OUT THE BOTTOM HORIZONTAL AXIS OF THE PLOT; ** C ** WRITE OUT THE X-AXIS NUMERIC LABELS; ** C ** WRITE OUT THE FIRST HORIZONTAL AXIS LABEL (IF ANY); ** C ** WRITE OUT THE SECOND HORIZONTAL AXIS LABEL (IF ANY); ** C ** WRITE OUT THE THIRD HORIZONTAL AXIS LABEL (IF ANY). ** C ************************************************************ C C DO2200ICOL=1,NUMCOL ILINE(ICOL)=IHYPHE 2200 CONTINUE DO2300ICOL=1,NUMCOL,IXDEL ILINE(ICOL)=IALPHI 2300 CONTINUE WRITE(ICOUT,2105)(ILINE(ICOL),ICOL=1,NUMCOL) 2105 FORMAT(20X,54A1) CALL DPWRST('XXX','BUG ') C NUMLAB=5 ANUMLM=NUMLAB-1 DO2500I=1,NUMLAB AIM1=I-1 AILABL(I)=XMIN+(AIM1/ANUMLM)*DELX 2500 CONTINUE WRITE(ICOUT,2310)(AILABL(I),I=1,NUMLAB) 2310 FORMAT(13X,5E10.4) CALL DPWRST('XXX','BUG ') C IF(IMAXX1.GE.1)WRITE(ICOUT,2311)(ILABX1(I),I=1,IMAXX1) 2311 FORMAT(240A1) IF(IMAXX1.GE.1)CALL DPWRST('XXX','BUG ') IF(IMAXX2.GE.1)WRITE(ICOUT,2311)(ILABX2(I),I=1,IMAXX2) IF(IMAXX2.GE.1)CALL DPWRST('XXX','BUG ') IF(IMAXX3.GE.1)WRITE(ICOUT,2311)(ILABX3(I),I=1,IMAXX3) IF(IMAXX3.GE.1)CALL DPWRST('XXX','BUG ') C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE RETURN END SUBROUTINE PLOTW(Y,X,N,ICHAR,MAXCHA,ICASPL,ICAS3D, 1ITITTE,NCTITL, 1IX1LTE,NCX1LA, 1IX2LTE,NCX2LA, 1IX3LTE,NCX3LA, 1IY1LTE,NCY1LA, 1IY2LTE,NCY2LA, 1GX1MIN,GX1MAX,GY1MIN,GY1MAX, 1IERASW,IBUGU2,IERROR) C C PURPOSE--THIS SUBROUTINE YIELDS A WIDE-WIDTH (130-CHARACTER) C PLOT OF Y(I) VERSUS X(I). C NOTE--THE WIDE WIDTH OF THIS PLOT C MAKES IT APPROPRIATE FOR C USE ON A BATCH PRINTER. C INPUT ARGUMENTS--X = THE SINGLE PRECISION VECTOR OF C (UNSORTED OR SORTED) OBSERVATIONS C TO BE PLOTTED VERTICALLY. C --N = THE INTEGER NUMBER OF OBSERVATIONS C IN THE VECTOR X. C --ICHAR = THE HOLLERITH VECTOR OF C CHARACTERS (ONLY THE C FIRST OF WHICH WILL BE USED) C --MAXCHA = THE INTEGER NUMBER OF C CHARACTERS IN ICHAR(.) C OUTPUT--A WIDE-WIDTH (130-CHARACTER) TERMINAL PLOT C OF X(I) VERSUS I. C THE BODY OF THE PLOT (NOT COUNTING AXIS VALUES C AND MARGINS) IS 41 ROWS (LINES) AND 101 COLUMNS. C PRINTING--YES. C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--NONE. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--82.6 C ORIGINAL VERSION--JUNE 1972. C UPDATED --JANUARY 1975. C UPDATED --JULY 1975. C UPDATED --SEPTEMBER 1975. C UPDATED --OCTOBER 1975. C UPDATED --NOVEMBER 1975. C UPDATED --FEBRUARY 1976. C UPDATED --FEBRUARY 1977. C UPDATED --JUNE 1978. C UPDATED --NOVEMBER 1981. C UPDATED --DECEMBER 1981. C UPDATED --JANUARY 1982. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICHAR C CHARACTER*4 ICASPL CHARACTER*4 ICAS3D C CHARACTER*4 ITITTE CHARACTER*4 IX1LTE CHARACTER*4 IX2LTE CHARACTER*4 IX3LTE CHARACTER*4 IY1LTE CHARACTER*4 IY2LTE C CHARACTER*4 IERASW CHARACTER*4 IBUGU2 CHARACTER*4 IERROR C CHARACTER*4 IBLANK CHARACTER*4 IHYPHE CHARACTER*4 IALPHI CHARACTER*4 IALPHX CHARACTER*4 IALPHM CHARACTER*4 IALPHA CHARACTER*4 IALPHN CHARACTER*4 IALPHD CHARACTER*4 IEQUAL C CHARACTER*4 ILABT CHARACTER*4 ILABX1 CHARACTER*4 ILABX2 CHARACTER*4 ILABX3 CHARACTER*4 ILABY1 CHARACTER*4 JPLOTC CHARACTER*4 IGRAPH CHARACTER*4 ICASP2 C C--------------------------------------------------------------------- C DIMENSION Y(*) DIMENSION X(*) DIMENSION ICHAR(*) DIMENSION IGRAPH(55,130) C DIMENSION ITITTE(*) DIMENSION IX1LTE(*) DIMENSION IX2LTE(*) DIMENSION IX3LTE(*) DIMENSION IY1LTE(*) DIMENSION IY2LTE(*) C DIMENSION ILABT(132) DIMENSION ILABY1(132) DIMENSION ILABX1(132) DIMENSION ILABX2(132) DIMENSION ILABX3(132) C DIMENSION YLABEL(11) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IBLANK=' ' IHYPHE='-' IALPHI='I' IALPHX='X' IALPHM='M' IALPHA='A' IALPHX='X' IALPHN='N' IALPHD='D' IALPHN='N' IEQUAL='=' C IMAXT=0 IMAXX1=0 IMAXX2=0 IMAXX3=0 C IF(IBUGU2.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('AT THE BEGINNING OF PLOTW--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)N,IBUGU2 52 FORMAT('N,IBUGU2 = ',I8,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)Y(1),X(1) 53 FORMAT('Y(1),X(1) = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)Y(N),X(N) 54 FORMAT('Y(N),X(N) = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,55)ICASPL,ICAS3D 55 FORMAT('ICASPL,ICAS3D = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,61)NCTITL 61 FORMAT('NCTITL = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,72)CPUMIN,CPUMAX 72 FORMAT('CPUMIN,CPUMAX = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,73)GX1MIN,GX1MAX,GY1MIN,GY1MAX 73 FORMAT('GX1MIN,GX1MAX,GY1MIN,GY1MAX = ',4E15.7) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C C *************************************************************** C ** STEP 2-- ** C ** DEFINE THE NUMBER OF ROWS AND COLUMNS WITHIN THE PLOT-- ** C ** THIS HAS BEEN SET TO 41 ROWS AND 97 COLUMNS. ** C *************************************************************** C NUMROW=41 NUMCOL=97 C ANUMR=NUMROW ANUMRM=NUMROW-1 ANUMCM=NUMCOL-1 NUMR25=(NUMROW/4)+1 NUMR50=(NUMROW/2)+1 NUMR75=3*(NUMROW/4)+1 IXDEL=(NUMCOL-1)/4 C C *************************** C ** STEP 2.1-- ** C ** BLANK OUT THE GRAPH ** C *************************** C DO280I=1,55 DO290J=1,130 IGRAPH(I,J)=IBLANK 290 CONTINUE 280 CONTINUE C C ******************************** C ** STEP 2.2-- ** C ** DEFINE THE TYPE OF PLOT. ** C ******************************** C ICASP2=ICASPL IF(ICASPL.EQ.'MDBP')ICASP2='BOXP' IF(ICASPL.EQ.'MEBP')ICASP2='BOXP' IF(ICASPL.EQ.'VIPL')ICASP2='BOXP' IF(ICASPL.EQ.'MDIP')ICASP2='IPLO' IF(ICASPL.EQ.'MEIP')ICASP2='IPLO' IF(ICASPL.EQ.'MRIP')ICASP2='IPLO' IF(ICASPL.EQ.'MMIP')ICASP2='IPLO' C C ****************************************************** C ** STEP 3-- ** C ** PREPARE THE TITLE LINE, THE Y-AXIS LABEL, ** C ** AND THE 3 HORIZONTAL AXIS LABELS FOR PRINTING. ** C ****************************************************** C YMIDL=(55/2)-4 XMIDL=29+NUMCOL/2 C YFACT=1.0 XFACT=1.0 C ILENT=NCTITL ILENY1=NCY1LA ILENX1=NCX1LA ILENX2=NCX2LA ILENX3=NCX3LA C ALENT=ILENT ALENY1=ILENY1 ALENX1=ILENX1 ALENX2=ILENX2 ALENX3=ILENX3 C IX=XMIDL-XFACT*(ALENT/2.0) DO310I=1,132 ILABT(I)=' ' 310 CONTINUE J=IX-1 IF(ILENT.LE.0)GOTO319 DO315I=1,ILENT J=J+1 ILABT(J)=ITITTE(I) 315 CONTINUE IMAXT=J 319 CONTINUE C IY=YMIDL-YFACT*(ALENY1/2.0) DO320I=1,132 ILABY1(I)=' ' 320 CONTINUE J=IY-1 IF(ILENY1.LE.0)GOTO329 DO325I=1,ILENY1 J=J+1 ILABY1(J)=IY1LTE(I) 325 CONTINUE IMAXY1=J 329 CONTINUE C IX=XMIDL-XFACT*(ALENX1/2.0) DO330I=1,132 ILABX1(I)=' ' 330 CONTINUE J=IX-1 IF(ILENX1.LE.0)GOTO339 DO335I=1,ILENX1 J=J+1 ILABX1(J)=IX1LTE(I) 335 CONTINUE IMAXX1=J 339 CONTINUE C IX=XMIDL-XFACT*(ALENX2/2.0) DO340I=1,132 ILABX2(I)=' ' 340 CONTINUE J=IX-1 IF(ILENX2.LE.0)GOTO349 DO345I=1,ILENX2 J=J+1 ILABX2(J)=IX2LTE(I) 345 CONTINUE IMAXX2=J 349 CONTINUE C IX=XMIDL-XFACT*(ALENX3/2.0) DO350I=1,132 ILABX3(I)=' ' 350 CONTINUE J=IX-1 IF(ILENX3.LE.0)GOTO359 DO355I=1,ILENX3 J=J+1 ILABX3(J)=IX3LTE(I) 355 CONTINUE IMAXX3=J 359 CONTINUE C C ******************************************************* C ** STEP 5-- ** C ** DETERMINE THE MIN AND MAX VALUES OF Y AND OF X. ** C ******************************************************* C YMIN=Y(1) YMAX=Y(1) XMIN=X(1) XMAX=X(1) DO700I=1,N IF(Y(I).LT.YMIN)YMIN=Y(I) IF(Y(I).GT.YMAX)YMAX=Y(I) IF(X(I).LT.XMIN)XMIN=X(I) IF(X(I).GT.XMAX)XMAX=X(I) 700 CONTINUE IF(GX1MIN.NE.CPUMIN)XMIN=GX1MIN IF(GX1MAX.NE.CPUMAX)XMAX=GX1MAX IF(GY1MIN.NE.CPUMIN)YMIN=GY1MIN IF(GY1MAX.NE.CPUMAX)YMAX=GY1MAX DELY=YMAX-YMIN DELX=XMAX-XMIN YWIDTH=DELY/ANUMRM XWIDTH=DELX/ANUMCM C XMID=(XMIN+XMAX)/2.0 X25=0.75*XMIN+0.25*XMAX X75=0.25*XMIN+0.75*XMAX C DO800I=1,9 AIM1=I-1 YLABEL(I)=YMAX-(AIM1/8.0)*(YMAX-YMIN) 800 CONTINUE C C ********************************* C ** STEP 6-- ** C ** PRODUCE THE VERTICAL AXES ** C ********************************* C DO1300I=3,43 IGRAPH(I,5)=IALPHI IGRAPH(I,105)=IALPHI 1300 CONTINUE DO1400I=3,43,5 IGRAPH(I,5)=IHYPHE IGRAPH(I,105)=IHYPHE 1400 CONTINUE IGRAPH(3,1)=IEQUAL IGRAPH(3,2)=IALPHM IGRAPH(3,3)=IALPHA IGRAPH(3,4)=IALPHX IGRAPH(23,1)=IEQUAL IGRAPH(23,2)=IALPHM IGRAPH(23,3)=IALPHI IGRAPH(23,4)=IALPHD IGRAPH(43,1)=IEQUAL IGRAPH(43,2)=IALPHM IGRAPH(43,3)=IALPHI IGRAPH(43,4)=IALPHN C C *********************************** C ** STEP 7-- ** C ** PRODUCE THE HORIZONTAL AXES ** C *********************************** C DO1500J=7,103 IGRAPH(1,J)=IHYPHE IGRAPH(45,J)=IHYPHE 1500 CONTINUE DO1600J=7,103,12 IGRAPH(1,J)=IALPHI IGRAPH(45,J)=IALPHI 1600 CONTINUE C C ****************************************** C ** STEP 8-- ** C ** DETERMINE THE (X,Y) PLOT POSITIONS ** C ****************************************** C RATIOY=ANUMRM/(YMAX-YMIN) RATIOX=ANUMCM/(XMAX-XMIN) DO1800I=1,N XI=X(I) MX=RATIOX*(XI-XMIN)+0.5 MX=MX+7 IF(MX.LT.7.OR.MX.GT.103)GOTO1800 MY=RATIOY*(Y(I)-YMIN)+0.5 MY=43-MY IF(MY.LT.3.OR.MY.GT.43)GOTO1800 JPLOTC=ICHAR(1) IF(JPLOTC.EQ.' ')JPLOTC='X' IF(JPLOTC.EQ.'BLAN')JPLOTC='X' IF(JPLOTC.EQ.'NONE')JPLOTC='X' IGRAPH(MY,MX)=JPLOTC 1800 CONTINUE C C ************************************* C ** STEP 9-- ** C ** SKIP TO A NEW PAGE. ** C ** WRITE OUT THE TITLE (IF ANY); ** C ************************************* C IF(IERASW.EQ.'ON')WRITE(ICOUT,2004) 2004 FORMAT(1H1) IF(IERASW.EQ.'ON')CALL DPWRST('XXX','BUG ') IF(IERASW.EQ.'OFF')WRITE(ICOUT,999) IF(IERASW.EQ.'OFF')CALL DPWRST('XXX','BUG ') IF(IMAXT.GE.1)WRITE(ICOUT,2005)(ILABT(I),I=1,IMAXT) 2005 FORMAT(240A1) IF(IMAXT.GE.1)CALL DPWRST('XXX','BUG ') IF(IMAXT.LE.0)WRITE(ICOUT,999) IF(IMAXT.LE.0)CALL DPWRST('XXX','BUG ') C C ********************************************* C ** STEP 10-- ** C ** WRITE OUT THE GRAPH ** C ** (INCLUDING THE X-AXIS NUMERIC LABELS) ** C ********************************************* C DO2100I=1,45 IP2=I+2 IFLAG=IP2-(IP2/5)*5 K=IP2/5 IF(IFLAG.NE.0)WRITE(ICOUT,2105)ILABY1(I),(IGRAPH(I,J),J=1,105) 2105 FORMAT(A1,20X,105A1) IF(IFLAG.NE.0)CALL DPWRST('XXX','BUG ') IF(IFLAG.EQ.0)WRITE(ICOUT,2106)ILABY1(I),YLABEL(K), 1(IGRAPH(I,J),J=1,105) 2106 FORMAT(A1,F20.7,105A1) IF(IFLAG.EQ.0)CALL DPWRST('XXX','BUG ') 2100 CONTINUE WRITE(ICOUT,2107)XMIN,X25,XMID,X75,XMAX 2107 FORMAT(14X,F20.7,4X,F20.7,4X,F20.7,4X,F20.7,4X,F20.7) CALL DPWRST('XXX','BUG ') C C ************************************************************ C ** STEP 11-- ** C ** WRITE OUT THE FIRST HORIZONTAL AXIS LABEL (IF ANY); ** C ** WRITE OUT THE SECOND HORIZONTAL AXIS LABEL (IF ANY); ** C ** WRITE OUT THE THIRD HORIZONTAL AXIS LABEL (IF ANY). ** C ************************************************************ C IF(IMAXX1.GE.1)WRITE(ICOUT,2311)(ILABX1(I),I=1,IMAXX1) 2311 FORMAT(240A1) IF(IMAXX1.GE.1)CALL DPWRST('XXX','BUG ') IF(IMAXX1.LE.0)WRITE(ICOUT,999) IF(IMAXX1.LE.0)CALL DPWRST('XXX','BUG ') IF(IMAXX2.GE.1)WRITE(ICOUT,2311)(ILABX2(I),I=1,IMAXX2) IF(IMAXX2.GE.1)CALL DPWRST('XXX','BUG ') IF(IMAXX2.LE.0)WRITE(ICOUT,999) IF(IMAXX2.LE.0)CALL DPWRST('XXX','BUG ') IF(IMAXX3.GE.1)WRITE(ICOUT,2311)(ILABX3(I),I=1,IMAXX3) IF(IMAXX3.GE.1)CALL DPWRST('XXX','BUG ') IF(IMAXX3.LE.0)WRITE(ICOUT,999) IF(IMAXX3.LE.0)CALL DPWRST('XXX','BUG ') C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE RETURN END SUBROUTINE PLYSRT(XC,YC,NMX,NSEG,NSGE,NSGCL,NSGCH,NPTS,NTPE, 1 NTPCL,NTPCH,SNSE,CLSD,NSGX,X,Y,IMX,JMX,IB,JB,NBX,PRMTR,NS,D) C C PURPOSE--XX C C WRITTEN BY--DAVID W. BEHRINGER NOAA/AOML (MIAMI). C AS PART OF NOAA'S CONCX V.3 MARCH 1988. C ORIGINAL VERSION (IN DATAPLOT)--AUGUST 1988. C UPDATED --JANUARY 1989. MORE CHANGES TO STANDARD FORTRAN 77-- C CHANGED DO WHILE/END DO (ALAN HECKERT). C UPDATED --JULY 1996. EXPLICITLY INITIALIZE SOME C ARRAYS (BOMBED ON SGI WHICH C DOESN'T PRESET TO 0) C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOCP.INC' C C--------------------------------------------------------------------- C CCCCC INTEGER NPTS(NSGX,3),SNSE(NSGX,3),CLSD(NSGX,3),NSEG(3), CCCCC1 LC(4),NSGE(3),NSGCL(3),NSGCH(3),NTPE(3),NTPCL(3),NTPCH(3), CCCCC2 ESTR C CCCCC DIMENSION XC(NMX,3),YC(NMX,3),D(2,NSGX,3),X(IMX),Y(JMX), CCCCC1 IB(NBX),JB(NBX),NS(2,NSGX,3) C INTEGER NPTS INTEGER SNSE INTEGER CLSD INTEGER NSEG CCCCC INTEGER LC INTEGER NSGE INTEGER NSGCL INTEGER NSGCH INTEGER NTPE INTEGER NTPCL INTEGER NTPCH INTEGER ESTR C DIMENSION NPTS(MAXNSG,3) DIMENSION SNSE(MAXNSG,3) DIMENSION CLSD(MAXNSG,3) DIMENSION NSEG(3) CCCCC DIMENSION LC(4) DIMENSION NSGE(3) DIMENSION NSGCL(3) DIMENSION NSGCH(3) DIMENSION NTPE(3) DIMENSION NTPCL(3) DIMENSION NTPCH(3) C DIMENSION XC(MAXNMX,3) DIMENSION YC(MAXNMX,3) DIMENSION D(2,MAXNSG,3) DIMENSION X(*) DIMENSION Y(*) DIMENSION IB(*) DIMENSION JB(*) DIMENSION NS(2,MAXNSG,3) C C-----START POINT----------------------------------------------------- C CCCCC JULY 1996. ADD FOLLOING 9 LINES FOR SGI BUG. NSGE(1)=0 NSGE(2)=0 NSGE(3)=0 NSGCH(1)=0 NSGCH(2)=0 NSGCH(3)=0 NSGCL(1)=0 NSGCL(2)=0 NSGCL(3)=0 C IF (NSEG(1).EQ.0) THEN NSGE(1)=0 NSGCL(1)=0 NSGCH(1)=0 NTPE(1)=0 NTPCL(1)=0 NTPCH(1)=0 END IF IF (NSEG(2).EQ.0) THEN NSGE(2)=0 NSGCL(2)=0 NSGCH(2)=0 NTPE(2)=0 NTPCL(2)=0 NTPCH(2)=0 ELSE C BEGIN SORTING THE *(*,2) ARRAYS NSG=NSEG(2) NTP=0 NTPE(2)=0 NTPCL(2)=0 NTPCH(2)=0 NSGE(2)=0 NSGCL(2)=0 NSGCH(2)=0 DO 100 N=1,NSG NTP=NTP+NPTS(N,2) IF (CLSD(N,2).EQ.0) THEN NSGE(2)=NSGE(2)+1 NTPE(2)=NTPE(2)+NPTS(N,2) ELSE IF (CLSD(N,2).LT.0) THEN NSGCL(2)=NSGCL(2)+1 NTPCL(2)=NTPCL(2)+NPTS(N,2) ELSE NSGCH(2)=NSGCH(2)+1 NTPCH(2)=NTPCH(2)+NPTS(N,2) END IF 100 CONTINUE C MAKE SURE EACH CONTOUR SEGMENT PROCEEDS IN THE CORRECT SENSE C WHICH IS WITH LOW VALUES TO THE RIGHT OF THE CONTOUR LN=0 DO 200 N=1,NSG LS=LN+1 LN=LN+NPTS(N,2) IF (SNSE(N,2).LT.0) THEN LN2=(LS+LN-1)/2 DO 210 L=LS,LN2 LL=LN-L+LS H=XC(LL,2) XC(LL,2)=XC(L,2) XC(L,2)=H H=YC(LL,2) YC(LL,2)=YC(L,2) YC(L,2)=H 210 CONTINUE SNSE(N,2)=1 END IF 200 CONTINUE C SEPARATE THE EDGE-TO-EDGE SEGMENTS FROM THE CLOSED SEGMENTS IF (NSGE(2).GT.0) THEN NSGM=NSG-1 DO 300 N=1,NSGM L1=1 DO 310 M=1,NSGM IF (CLSD(M,2).NE.0.AND.CLSD(M+1,2).EQ.0) THEN IH=CLSD(M,2) CLSD(M,2)=CLSD(M+1,2) CLSD(M+1,2)=IH L2=L1+NPTS(M,2) L3=L2+NPTS(M+1,2) CALL STRSWP(XC(1,2),L1,L2,L3) CALL STRSWP(YC(1,2),L1,L2,L3) IH=NPTS(M,2) NPTS(M,2)=NPTS(M+1,2) NPTS(M+1,2)=IH END IF L1=L1+NPTS(M,2) 310 CONTINUE 300 CONTINUE C DETERMINE THE BOUNDARY POINTS FOR EACH EDGE-TO-EDGE SEGMENT'S ENTRY & EXIT C AND THE DISTANCE OF THESE POINTS FROM THE LOWER LEFT CORNER NBM=NBX-1 LN=0 NSG=NSGE(2) DO 400 N=1,NSG LS=LN+1 LN=LN+NPTS(N,2) L=LS DO 410 K=1,2 CALL SIDEDI(XC(L,2),YC(L,2),NS(K,N,2),D(K,N,2), 1 IB,JB,X,Y) L=LN 410 CONTINUE 400 CONTINUE END IF C SEPARATE CLOSED LOW SEGMENTS FROM CLOSED HIGH SEGMENTS IF (NSGCL(2).GT.0.AND.NSGCH(2).GT.0) THEN NSGM=NSEG(2)-1 DO 500 N=NSGE(2)+1,NSGM L1=NTPE(2)+1 DO 510 M=NSGE(2)+1,NSGM IF (CLSD(M,2).GT.0.AND.CLSD(M+1,2).LT.0) THEN IH=CLSD(M,2) CLSD(M,2)=CLSD(M+1,2) CLSD(M+1,2)=IH L2=L1+NPTS(M,2) L3=L2+NPTS(M+1,2) CALL STRSWP(XC(1,2),L1,L2,L3) CALL STRSWP(YC(1,2),L1,L2,L3) IH=NPTS(M,2) NPTS(M,2)=NPTS(M+1,2) NPTS(M+1,2)=IH END IF L1=L1+NPTS(M,2) 510 CONTINUE 500 CONTINUE END IF C DETERMINE AREA OF CLOSED SEGMENTS AND STORE IN D(1,*,*) IF (NSGCL(2).GT.0.OR.NSGCH(2).GT.0) THEN N1=NSGE(2)+1 NSG=N1+NSGCL(2)+NSGCH(2)-1 LE=NTPE(2) DO600N=N1,NSG LS=LE+1 LE=LE+NPTS(N,2) D(1,N,2)=0. DO610L=LS+1,LE D(1,N,2)=D(1,N,2)+0.5*(XC(L,2)-XC(L-1,2))* 1 (YC(L,2)+YC(L-1,2)) 610 CONTINUE D(1,N,2)=ABS(D(1,N,2)) 600 CONTINUE END IF END IF C WRITE(9,'('' EDGE CONTOURS'')') C CALL PRT_STR(9,XC(1,2),YC(1,2),NSGE(2),NPTS(1,2)) C SORT BOTH 1 AND 2 EDGE-TO-EDGE SEGMENTS BY DISTANCE OF C ENTRY POINTS FROM LOWER LEFT CORNER. DO700K=1,2 IF (NSGE(K).GT.0) THEN NSGM=NSGE(K)-1 DO710N=1,NSGM L1=1 DO720M=1,NSGM IF (D(1,M,K).GT.D(1,M+1,K)) THEN DO730L=1,2 H=D(L,M,K) D(L,M,K)=D(L,M+1,K) D(L,M+1,K)=H IH=NS(L,M,K) NS(L,M,K)=NS(L,M+1,K) NS(L,M+1,K)=IH 730 CONTINUE IH=CLSD(M,K) CLSD(M,K)=CLSD(M+1,K) CLSD(M+1,K)=IH L2=L1+NPTS(M,K) L3=L2+NPTS(M+1,K) CALL STRSWP(XC(1,K),L1,L2,L3) CALL STRSWP(YC(1,K),L1,L2,L3) IH=NPTS(M,K) NPTS(M,K)=NPTS(M+1,K) NPTS(M+1,K)=IH END IF L1=L1+NPTS(M,K) 720 CONTINUE 710 CONTINUE END IF 700 CONTINUE C WRITE(9,'('' SORTED EDGE CONTOURS 1'')') C CALL PRT_STR(9,XC(1,1),YC(1,1),NSGE(1),NPTS(1,1)) C WRITE(9,'('' SORTED EDGE CONTOURS 2'')') C CALL PRT_STR(9,XC(1,2),YC(1,2),NSGE(2),NPTS(1,2)) C BEGIN CONVERTING EDGE-TO-EDGE SEGMENTS TO CLOSED SEGMENTS L3=0 N3=0 IF (NSGE(2).GT.0.OR.NSGE(1).GT.0) THEN DO800K=2,1,-1 NSG=NSGE(K) LE=0 DO810N=1,NSG LS=LE+1 LE=LE+IABS(NPTS(N,K)) IF (NPTS(N,K).GT.0) THEN N3=N3+1 DO820L=LS,LE LL=L3+L-LS+1 XC(LL,3)=XC(L,K) YC(LL,3)=YC(L,K) 820 CONTINUE NPTS(N3,3)=NPTS(N,K) NPTS(N,K)=-NPTS(N,K) NS(1,N3,3)=NS(1,N,K) NS(2,N3,3)=NS(2,N,K) D(1,N3,3)=D(1,N,K) D(2,N3,3)=D(2,N,K) ESTR=0 900 CONTINUE IF(ESTR.EQ.1)GOTO999 C WRITE(9,'('' PRMTR'',F10.2)') PRMTR DD=D(1,N3,3)-D(2,N3,3) SGNDD=SIGN(1.0,DD) IF (DD.LT.0.) DD=DD+PRMTR KE=K NE=N C WRITE(9,'('' D1 D2 DD SGNDD KE NE'',4F8.2,2I6)') C 1 D(1,N3,3),D(2,N3,3),DD,SGNDD,KE,NE DO910KK=1,2 NNSG=NSGE(KK) DO920NN=1,NNSG C WRITE(9,'('' KK NN NPTS'',3I6)') KK,NN,NPTS(KK,NN) IF (NPTS(NN,KK).GT.0) THEN D0=D(1,NN,KK)-D(2,N3,3) SGND0=SIGN(1.0,D0) IF (D0.LT.0.) D0=D0+PRMTR C WRITE(9,'('' D1 D2 D0 SGND0'',4F8.2)') C 1 D(1,NN,KK),D(2,N3,3),D0,SGND0 IF (D0.LT.DD) THEN DD=D0 SGNDD=SGND0 KE=KK NE=NN END IF END IF 920 CONTINUE 910 CONTINUE C WRITE(9,'('' KE NE'',2I6)') KE,NE C WRITE(9,'('' NS2 NS1 SGNDD'',2I6,F6.0)') C 1 NS(2,N3,3),NS(1,NE,KE),SGNDD IF (NS(2,N3,3).NE.NS(1,NE,KE).OR.SGNDD.LT.0.) THEN NB1=NS(2,N3,3)+1 NB2=NS(1,NE,KE) LL=L3+NPTS(N3,3) C WRITE(9,'('' NB1 NB2'',2I6)') NB1,NB2 IF (NS(2,N3,3).LT.NS(1,NE,KE)) THEN DO930NB=NB1,NB2 LL=LL+1 XC(LL,3)=X(IB(NB)) YC(LL,3)=Y(JB(NB)) 930 CONTINUE NPTS(N3,3)=NPTS(N3,3)+NB2-NB1+1 ELSE DO940NB=NB1,NBX LL=LL+1 XC(LL,3)=X(IB(NB)) YC(LL,3)=Y(JB(NB)) 940 CONTINUE DO950NB=2,NB2 LL=LL+1 XC(LL,3)=X(IB(NB)) YC(LL,3)=Y(JB(NB)) 950 CONTINUE NPTS(N3,3)=NPTS(N3,3)+NB2-NB1+NBX END IF CALL SIDEDI(XC(LL,3),YC(LL,3),NS(2,N3,3), 1 D(2,N3,3),IB,JB,X,Y) DD=D(1,NE,KE)-D(2,N3,3) SGNDD=SIGN(1.0,DD) IF (DD.LT.0.) DD=DD+PRMTR END IF IF (KE.EQ.K.AND.NE.EQ.N) THEN ESTR=1 NPTS(N3,3)=NPTS(N3,3)+1 LL=L3+NPTS(N3,3) XC(LL,3)=XC(L3+1,3) YC(LL,3)=YC(L3+1,3) ELSE LLE=0 DO960NN=1,NE LLS=LLE+1 LLE=LLE+IABS(NPTS(NN,KE)) 960 CONTINUE LL3=L3+NPTS(N3,3) DO970LL=LLS,LLE LLL=LL3+LL-LLS+1 XC(LLL,3)=XC(LL,KE) YC(LLL,3)=YC(LL,KE) 970 CONTINUE NPTS(N3,3)=NPTS(N3,3)+NPTS(NE,KE) NPTS(NE,KE)=-NPTS(NE,KE) NS(2,N3,3)=NS(2,NE,KE) D(2,N3,3)=D(2,NE,KE) END IF GOTO900 999 CONTINUE C C C IF (NSGCH(1).GT.0.OR.NSGCH(2).GT.0) THEN LLL=L3+1 ESTR=0 2000 CONTINUE IF(ESTR.EQ.1)GOTO2099 A=0. KE=0 DO2010KK=1,2 LL=1+NTPE(KK)+NTPCL(KK) NN1=1+NSGE(KK)+NSGCL(KK) NNSG=NN1+NSGCH(KK)-1 DO2020NN=NN1,NNSG IF (NPTS(NN,KK).GT.0) THEN CALL INOUT(XC(LL,KK),YC(LL,KK),XC(LLL,3), 1 YC(LLL,3),NPTS(N3,3),IO) IF (IO.EQ.1.AND.D(1,NN,KK).GT.A) THEN A=D(1,NN,KK) NE=NN KE=KK END IF END IF LL=LL+IABS(NPTS(NN,KK)) 2020 CONTINUE 2010 CONTINUE IF (KE.EQ.0) THEN ESTR=1 ELSE LL=1+NTPE(KE)+NTPCL(KE) NN1=1+NSGE(KE)+NSGCL(KE) DO2030NN=NN1,NE-1 LL=LL+IABS(NPTS(NN,KE)) 2030 CONTINUE CALL CONINS(XC(LLL,3),YC(LLL,3),NPTS(N3,3), 1 XC(LL,KE),YC(LL,KE),NPTS(NE,KE)) NPTS(NE,KE)=-NPTS(NE,KE) END IF GOTO2000 2099 CONTINUE END IF L3=L3+NPTS(N3,3) END IF 810 CONTINUE 800 CONTINUE END IF C BEGIN COMBINING CLOSED SEGMENTS IF (NSGCL(2).GT.0.OR.NSGCL(1).GT.0) THEN DO3000K=2,1,-1 N1=NSGE(K)+1 NSG=N1+NSGCL(K)-1 LE=NTPE(K) DO3010N=N1,NSG LS=LE+1 LE=LE+IABS(NPTS(N,K)) N3=N3+1 DO3020L=LS,LE LL=L3+L-LS+1 XC(LL,3)=XC(L,K) YC(LL,3)=YC(L,K) 3020 CONTINUE NPTS(N3,3)=NPTS(N,K) IF (NSGCH(1).GT.0.OR.NSGCH(2).GT.0) THEN LLL=L3+1 ESTR=0 4000 CONTINUE IF(ESTR.EQ.1)GOTO4099 A=0. KE=0 DO4010KK=1,2 LL=1+NTPE(KK)+NTPCL(KK) NN1=1+NSGE(KK)+NSGCL(KK) NNSG=NN1+NSGCH(KK)-1 DO4020NN=NN1,NNSG IF (NPTS(NN,KK).GT.0) THEN CALL INOUT(XC(LL,KK),YC(LL,KK),XC(LLL,3), 1 YC(LLL,3),NPTS(N3,3),IO) IF (IO.EQ.1.AND.D(1,NN,KK).GT.A) THEN A=D(1,NN,KK) NE=NN KE=KK END IF END IF LL=LL+IABS(NPTS(NN,KK)) 4020 CONTINUE 4010 CONTINUE IF (KE.EQ.0) THEN ESTR=1 ELSE LL=1+NTPE(KE)+NTPCL(KE) NN1=1+NSGE(KE)+NSGCL(KE) DO4030NN=NN1,NE-1 LL=LL+IABS(NPTS(NN,KE)) 4030 CONTINUE CALL CONINS(XC(LLL,3),YC(LLL,3),NPTS(N3,3), 1 XC(LL,KE),YC(LL,KE),NPTS(NE,KE)) NPTS(NE,KE)=-NPTS(NE,KE) END IF GOTO4000 4099 CONTINUE END IF L3=L3+NPTS(N3,3) 3010 CONTINUE 3000 CONTINUE END IF C HANDLE SITUATION WHERE THERE ARE ONLY CLOSED HIGH SEGMENTS IF ((NSGE(1)+NSGE(2)+NSGCL(1)+NSGCL(2)).EQ.0) THEN N3=N3+1 DO5000NB=1,NBX XC(L3+NB,3)=X(IB(NB)) YC(L3+NB,3)=Y(JB(NB)) 5000 CONTINUE NPTS(N3,3)=NBX IF (NSGCH(1).GT.0.OR.NSGCH(2).GT.0) THEN LLL=L3+1 ESTR=0 5100 CONTINUE IF(ESTR.EQ.1)GOTO5199 A=0. KE=0 DO5110KK=1,2 LL=1 NNSG=NSGCH(KK) DO5120NN=1,NNSG IF (NPTS(NN,KK).GT.0) THEN CALL INOUT(XC(LL,KK),YC(LL,KK),XC(LLL,3), 1 YC(LLL,3),NPTS(N3,3),IO) IF (IO.EQ.1.AND.D(1,NN,KK).GT.A) THEN A=D(1,NN,KK) NE=NN KE=KK END IF END IF LL=LL+IABS(NPTS(NN,KK)) 5120 CONTINUE 5110 CONTINUE IF (KE.EQ.0) THEN ESTR=1 ELSE LL=1 DO5130NN=1,NE-1 LL=LL+IABS(NPTS(NN,KE)) 5130 CONTINUE CALL CONINS(XC(LLL,3),YC(LLL,3),NPTS(N3,3), 1 XC(LL,KE),YC(LL,KE),NPTS(NE,KE)) NPTS(NE,KE)=-NPTS(NE,KE) END IF GOTO5100 5199 CONTINUE END IF L3=L3+NPTS(N3,3) END IF NSEG(3)=N3 C WRITE(9,'('' TOTAL CONTOURS'')') C CALL PRT_STR(9,XC(1,3),YC(1,3),NSEG(3),NPTS(1,3)) RETURN END SUBROUTINE PLNCDF(X,P,SD,CDF) C C NOTE--POWER-LOGNORMAL CDF IS: C PLNCDF(X,U,SD,P) = 1 - [NORCDF(-(LN(X)-U)/SD)]**P C STANDARD FORM OF THIS DISTRIBUTION IS: C PLNCDF(X,P) = 1 - [NORCDF(-LN(X))]**P C FOR CONSISTENCY WITH PLNPDF ROUTINE, ALLOW SD AS C OPTIONAL PARAMETER. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--95/4 C ORIGINAL VERSION--APRIL 1995. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 DOUBLE PRECISION DTERM3 DOUBLE PRECISION DTERM4 DOUBLE PRECISION DEPS C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C DATA DEPS/0.1D-100/ C C-----START POINT----------------------------------------------------- C CDF=0.0 C IF(X.LE.0.0)THEN WRITE(ICOUT,301) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,203)X CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF IF(P.LE.0.0)THEN WRITE(ICOUT,101) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,103)P CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF IF(SD.LE.0.0)THEN WRITE(ICOUT,201) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,203)SD CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF 101 FORMAT('***** FATAL DIAGNOSTIC--THE POWER PARAMETER, P, IS ', 1 ' NON-POSITIVE.') 103 FORMAT(' THE VALUE OF P IS ',E15.7) 201 FORMAT('***** FATAL DIAGNOSTIC--THE STANDARD DEVIATION ', 1 'PARAMETER IS NON-POSITIVE.') 203 FORMAT(' THE VALUE IS ',E15.7) 301 FORMAT('***** FATAL DIAGNOSTIC--THE INPUT ARGUMENT IS ', 1 ' NON-POSITIVE.') C TERM1=-LOG(X)/SD CALL NODCDF(DBLE(TERM1),DTERM1) IF(DTERM1.LE.DEPS)DTERM1=DEPS DTERM2=DBLE(P)*DLOG(DTERM1) DTERM3=DEXP(DTERM2) DTERM4=1.0D0-DTERM3 CDF=REAL(DTERM4) GOTO9999 C 9999 CONTINUE RETURN END SUBROUTINE PLNCHA(X,P,SD,HAZ) C C NOTE--POWER-LOGNORMAL PDF IS: C PLNPDF(X,U,S,P) = (P/(X*SD))*NORPDF((LN(X)-U)/SD)* C NORCDF(-(LN(X)-U)/SD))**(P-1) C STANDARD FORM OF THIS DISTRIBUTION IS: C PLNPDF(X,S,P) = (P/(X*SD))*NORPDF(LN(X))* C NORCDF(-LN(X)/SD)**(P-1) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--98/4 C ORIGINAL VERSION--APRIL 1998. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C HAZ=0.0 C IF(X.LT.0.0)THEN WRITE(ICOUT,301) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,203)X CALL DPWRST('XXX','BUG ') GOTO9999 ELSEIF(X.EQ.0.0)THEN HAZ=0.0 GOTO9999 ENDIF IF(P.LE.0.0)THEN WRITE(ICOUT,101) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,103)P CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF IF(SD.LE.0.0)THEN WRITE(ICOUT,201) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,203)SD CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF 101 FORMAT('***** FATAL DIAGNOSTIC--THE POWER PARAMETER, P, IS ', 1 ' NON-POSITIVE.') 103 FORMAT(' THE VALUE OF P IS ',E15.7) 201 FORMAT('***** FATAL DIAGNOSTIC--THE STANDARD DEVIATION ', 1 'PARAMETER IS NON-POSITIVE.') 203 FORMAT(' THE VALUE IS ',E15.7) 301 FORMAT('***** FATAL DIAGNOSTIC--THE INPUT ARGUMENT IS ', 1 ' NON-POSITIVE.') C CALL PLNCDF(X,SD,P,CDF) CDF=1.0-CDF IF(CDF.GT.0.0)THEN HAZ=-LOG(CDF) ELSE HAZ=0.0 WRITE(ICOUT,901)X CALL DPWRST('XXX','BUG ') ENDIF 901 FORMAT('**** ERROR: FOR X = ',E15.7,' THE CDF IS ', 1'ESSENTIALLY 1.') C 9999 CONTINUE RETURN END SUBROUTINE PLNHAZ(X,P,SD,HAZ) C C NOTE--POWER-LOGNORMAL PDF IS: C PLNPDF(X,U,S,P) = (P/(X*SD))*NORPDF((LN(X)-U)/SD)* C NORCDF(-(LN(X)-U)/SD))**(P-1) C STANDARD FORM OF THIS DISTRIBUTION IS: C PLNPDF(X,S,P) = (P/(X*SD))*NORPDF(LN(X))* C NORCDF(-LN(X)/SD)**(P-1) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--98/4 C ORIGINAL VERSION--APRIL 1998. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C HAZ=0.0 C IF(X.LT.0.0)THEN WRITE(ICOUT,301) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,203)X CALL DPWRST('XXX','BUG ') GOTO9999 ELSEIF(X.EQ.0.0)THEN HAZ=0.0 GOTO9999 ENDIF IF(P.LE.0.0)THEN WRITE(ICOUT,101) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,103)P CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF IF(SD.LE.0.0)THEN WRITE(ICOUT,201) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,203)SD CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF 101 FORMAT('***** FATAL DIAGNOSTIC--THE POWER PARAMETER, P, IS ', 1 ' NON-POSITIVE.') 103 FORMAT(' THE VALUE OF P IS ',E15.7) 201 FORMAT('***** FATAL DIAGNOSTIC--THE STANDARD DEVIATION ', 1 'PARAMETER IS NON-POSITIVE.') 203 FORMAT(' THE VALUE IS ',E15.7) 301 FORMAT('***** FATAL DIAGNOSTIC--THE INPUT ARGUMENT IS ', 1 ' NON-POSITIVE.') C CALL LGNHAZ(X,SD,ALGCDF) HAZ=P*ALGCDF C 9999 CONTINUE RETURN END SUBROUTINE PLNPDF(X,P,SD,PDF) C C NOTE--POWER-LOGNORMAL PDF IS: C PLNPDF(X,U,S,P) = (P/(X*SD))*NORPDF((LN(X)-U)/SD)* C NORCDF(-(LN(X)-U)/SD))**(P-1) C STANDARD FORM OF THIS DISTRIBUTION IS: C PLNPDF(X,S,P) = (P/(X*SD))*NORPDF(LN(X))* C NORCDF(-LN(X)/SD)**(P-1) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--95/4 C ORIGINAL VERSION--APRIL 1995. C UPDATED --JULY 1999. FIXED THIS ROUTINE C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 DOUBLE PRECISION DTERM3 DOUBLE PRECISION DTERM4 DOUBLE PRECISION DTERM5 CCCCC JULY 1999. ADD FOLLOWING LINES. DOUBLE PRECISION DX DOUBLE PRECISION DXLOG DOUBLE PRECISION DP DOUBLE PRECISION DSD C CCCCC JULY 1995. ADD FOLLOWING LINE. DOUBLE PRECISION DPDF DOUBLE PRECISION DEPS C--------------------------------------------------------------------- C INCLUDE 'DPCOMC.INC' C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C PDF=0.0 DEPS=D1MACH(1) C IF(X.LE.0.0)THEN WRITE(ICOUT,301) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,203)X CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF IF(P.LE.0.0)THEN WRITE(ICOUT,101) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,103)P CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF IF(SD.LE.0.0)THEN WRITE(ICOUT,201) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,203)SD CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF 101 FORMAT('***** FATAL DIAGNOSTIC--THE POWER PARAMETER, P, IS ', 1 ' NON-POSITIVE.') 103 FORMAT(' THE VALUE OF P IS ',E15.7) 201 FORMAT('***** FATAL DIAGNOSTIC--THE STANDARD DEVIATION ', 1 'PARAMETER IS NON-POSITIVE.') 203 FORMAT(' THE VALUE IS ',E15.7) 301 FORMAT('***** FATAL DIAGNOSTIC--THE INPUT ARGUMENT IS ', 1 ' NON-POSITIVE.') C DX=DBLE(X) DSD=DBLE(SD) DP=DBLE(P) DXLOG=DLOG(DX) C DTERM1=DLOG(DP) - DLOG(DSD) - DXLOG CALL NODPDF(DXLOG/DSD,DTERM2) IF(DTERM2.LT.DEPS)DTERM2=DEPS DTERM2=DLOG(DTERM2) CALL NODCDF(-DXLOG/DSD,DTERM3) IF(DTERM3.LT.DEPS)DTERM3=DEPS DTERM4=(DP-1.0D0)*DLOG(DTERM3) DTERM5=DTERM1 + DTERM2 + DTERM4 IF(DTERM5.LE.I1MACH(12))THEN PDF=0.0 ELSEIF(DPDF.GT.I1MACH(13))THEN PDF=0.0 WRITE(ICOUT,503)X,P,SD CALL DPWRST('XXX','BUG ') ELSE DPDF=DEXP(DTERM5) PDF=REAL(DPDF) ENDIF 503 FORMAT('**** FROM PLNPDF: COMPUTATION OVERFLOWS FOR ', 1 'ARGUMENTS ',3G16.7) GOTO9999 C 9999 CONTINUE RETURN END SUBROUTINE PLNPPF(P,POWER,SD,PPF) C C NOTE--POWER-LOGNORMAL PPF IS: C PLNPPF(P,U,SD,POWER) = EXP(U+Zf*SD) C WHERE Zf = NORPPF(1-(1-P)**(1/POWER)) C STANDARD FORM OF THIS DISTRIBUTION IS: C PLNPPF(P,U,SD,POWER) = EXP(Zf) C FOR CONSISTENCY WITH PLNPDF ROUTINE, ALLOW SD AS C OPTIONAL PARAMETER. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--95/4 C ORIGINAL VERSION--APRIL 1995. C MODIFIED --JUNE 1995. CHECK FOR MAXIMUM VALUE C MODIFIED --SEPTEMBER 1995. BETTER HANDLING OF CASE WHEN C NORPPF CALLED WITH VALUE CLOSE C TO 1. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 DOUBLE PRECISION DTERM3 DOUBLE PRECISION DTERM4 DOUBLE PRECISION DTERM5 DOUBLE PRECISION DTERM6 DOUBLE PRECISION DTMIN CCCCC DOUBLE PRECISION DTMAX DOUBLE PRECISION DEPS C C--------------------------------------------------------------------- C INCLUDE 'DPCOMC.INC' C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C DATA DEPS / 1.0D-16/ C C-----START POINT----------------------------------------------------- C PPF=0.0 C IF(P.LT.0.0 .OR. P.GE.1.0)THEN WRITE(ICOUT,1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)P CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9999 ELSEIF(P.EQ.0.0)THEN PPF=0.0 GOTO9999 ENDIF IF(POWER.LE.0.0)THEN WRITE(ICOUT,101) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,203)POWER CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF IF(SD.LE.0.0)THEN WRITE(ICOUT,201) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,203)SD CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF 1 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ', 1' PLNPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') 101 FORMAT('***** FATAL DIAGNOSTIC--THE POWER PARAMETER IS ', 1 ' NON-POSITIVE.') 201 FORMAT('***** FATAL DIAGNOSTIC--THE STANDARD DEVIATION ', 1 'PARAMETER IS NON-POSITIVE.') 203 FORMAT(' THE VALUE IS ',E15.7) C DTMIN=D1MACH(1) DTERM1= 1.0D0 - DBLE(P) DTERM2=1.0D0/DBLE(POWER) CCCCC SEPTEMBER 1995. HANDLE CASE WHERE NORPPF CALLED WITH ARGUMENT CCCCC CLOSE TO 1 BETTER. CCCCC DTERM3=1.0D0 - DTERM1**DTERM2 DTERM3=DTERM1**DTERM2 IF(DTERM3.LT.DEPS)THEN IF(DTERM3.LE.DTMIN)DTERM3=DTMIN CALL NODPPF(DTERM3,DTERM4) DTERM4=-DTERM4 ELSE DTERM3=1.0D0 - DTERM3 IF(DTERM3.LE.DTMIN)DTERM3=DTMIN CCCCC JUNE 1995. ADD FOLLOWING 2 LINES CCCCC DTMAX=1.0D0-DEPS CCCCC IF(DTERM3.GE.DTMAX)DTERM3=DTMAX CALL NODPPF(DTERM3,DTERM4) ENDIF C DTERM5=DBLE(SD)*DTERM4 DTERM6=DEXP(DTERM5) PPF=REAL(DTERM6) GOTO9999 C 9999 CONTINUE RETURN END SUBROUTINE PLNRAN(N,P,SD,ISEED,X) C C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N C FROM THE POWER LOGNORMAL DISTRIBUTION C WITH SHAPE PARAMETER VALUES = P AND SD. C INPUT ARGUMENTS--N = THE DESIRED INTEGER NUMBER C OF RANDOM NUMBERS TO BE C GENERATED. C --P = THE SINGLE PRECISION VALUE OF THE C FIRST SHAPE PARAMETER. C P SHOULD BE POSITIVE. C --SD = THE SINGLE PRECISION VALUE OF THE C SECOND SHAPE PARAMETER. C SD SHOULD BE POSITIVE. C OUTPUT ARGUMENTS--X = A SINGLE PRECISION VECTOR C (OF DIMENSION AT LEAST N) C INTO WHICH THE GENERATED C RANDOM SAMPLE WILL BE PLACED. C OUTPUT--A RANDOM SAMPLE OF SIZE N C FROM THE POWER LOGNORMAL DISTRIBUTION C WITH TAIL LENGTH PARAMETER VALUES = P AND SD. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C --P SHOULD BE POSITIVE. C OTHER DATAPAC SUBROUTINES NEEDED--UNIRAN. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--XX C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2001.11 C ORIGINAL VERSION--NOVEMBER 2001. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DIMENSION X(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(N.LT.1)THEN WRITE(ICOUT, 5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)N CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF IF(P.LE.0.0)THEN WRITE(ICOUT,15) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)P CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF IF(SD.LE.0.0)THEN WRITE(ICOUT,25) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)SD CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF 5 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ', 1'PLNRAN SUBROUTINE IS NON-POSITIVE *****') 15 FORMAT('***** FATAL ERROR--THE 2ND INPUT ARGUMENT TO THE ', 1'PLNRAN SUBROUTINE IS NON-POSITIVE *****') 25 FORMAT('***** FATAL ERROR--THE THIRD INPUT ARGUMENT TO THE ', 1'PLNRAN SUBROUTINE IS NON-POSITIVE *****') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****') C C GENERATE N UNIFORM (0,1) RANDOM NUMBERS; C CALL UNIRAN(N,ISEED,X) C C GENERATE N POWER LOGNORMAL DISTRIBUTION RANDOM NUMBERS C USING PERCENT POINT FUNCTION C SD=1.0 DO100I=1,N CALL PLNPPF(X(I),P,SD,XTEMP) X(I)=XTEMP 100 CONTINUE C 9000 CONTINUE RETURN END SUBROUTINE PNRCDF(X,P,CDF) CCCCC SUBROUTINE PNRCDF(X,P,SD,CDF) C C NOTE--POWER-NORMAL CDF IS: C PNRCDF(X,U,SD,P) = 1 - [NORCDF(-(X-U)/SD)]**P C STANDARD FORM OF THIS DISTRIBUTION IS: C PNRCDF(X,P) = 1 - [NORCDF(X)]**P C FOR CONSISTENCY WITH PNRPDF ROUTINE, ALLOW SD AS C OPTIONAL PARAMETER. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--95/4 C ORIGINAL VERSION--APRIL 1995. C UPDATED --OCTOBER 2001. ALGORITHM UPDATED C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 DOUBLE PRECISION DTERM3 DOUBLE PRECISION DTERM4 DOUBLE PRECISION DEPS C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C DATA DEPS/0.1D-20/ C C-----START POINT----------------------------------------------------- C CDF=0.0 XMAXVL=38.0 C IF(P.LE.0.0)THEN WRITE(ICOUT,101) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,103)P CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF CCCCC IF(SD.LE.0.0)THEN CCCCC WRITE(ICOUT,201) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,203)SD CCCCC CALL DPWRST('XXX','BUG ') CCCCC GOTO9999 CCCCC ENDIF IF(ABS(X).GT.XMAXVL)THEN WRITE(ICOUT,301) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,303)-XMAXVL,XMAXVL CALL DPWRST('XXX','BUG ') WRITE(ICOUT,305)X CALL DPWRST('XXX','BUG ') IF(X.GT.XMAXVL)CDF=1.0 GOTO9999 ENDIF 101 FORMAT('***** FATAL DIAGNOSTIC--THE POWER PARAMETER, P, IS ', 1 ' NON-POSITIVE.') 103 FORMAT(' THE VALUE OF P IS ',E15.7) 201 FORMAT('***** FATAL DIAGNOSTIC--THE STANDARD DEVIATION ', 1 'PARAMETER IS NON-POSITIVE.') 203 FORMAT(' THE VALUE IS ',E15.7) 301 FORMAT('***** FATAL DIAGNOSTIC--FOR THE PNRCDF FUNCTION--') 303 FORMAT(' DATAPLOT IS UNABLE TO COMPUTE NORCDF FOR VALUES', 1 ' OUTSIDE THE RANGE (',E15.7,',',E15.7,')') 305 FORMAT(' THE VALUE OF THE INPUT ARGUMENT IS ',E15.7) C CALL NODCDF(DBLE(-X),DTERM1) DTERM2=DBLE(P)*DLOG(DTERM1) DTERM3=DEXP(DTERM2) DTERM4=1.0D0-DTERM3 CDF=REAL(DTERM4) C 9999 CONTINUE RETURN END SUBROUTINE PNRCHA(X,P,S,HAZ) C C NOTE--POWER-NORMAL PDF IS: C PNRPDF(X,U,S,P) = (P/S)*NORPDF((X-U)/S)* C NORCDF(-(X-U)/S))**(P-1) C STANDARD FORM OF THIS DISTRIBUTION IS: C PNRPDF(X,S,P) = (P/S)*NORPDF(X)*NORCDF(-X/S)**(P-1) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--98/4 C ORIGINAL VERSION--APRIL 1998. C UPDATED --NOVEMBER 2001. FORCE SD PARAMETER TO BE 1 C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C DOUBLE PRECISION DCDF C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C HAZ=0.0 SD=1.0 C IF(P.LE.0.0)THEN WRITE(ICOUT,101) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,103)P CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF IF(SD.LE.0.0)THEN WRITE(ICOUT,201) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,203)SD CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF 101 FORMAT('***** FATAL DIAGNOSTIC--THE POWER PARAMETER, P, IS ', 1 ' NON-POSITIVE.') 103 FORMAT(' THE VALUE OF P IS ',E15.7) 201 FORMAT('***** FATAL DIAGNOSTIC--THE STANDARD DEVIATION ', 1 'PARAMETER IS NON-POSITIVE.') 203 FORMAT(' THE VALUE IS ',E15.7) C Z=-X/SD CALL NODCDF(DBLE(Z),DCDF) IF(DCDF.GT.0.0D0)THEN HAZ=-REAL(DLOG(DCDF**DBLE(P))) ELSE HAZ=0.0 WRITE(ICOUT,901)X CALL DPWRST('XXX','BUG ') ENDIF 901 FORMAT('***** ERROR: FOR X = ',E15.7,' THE POWER NORMAL CDF ', 1'IS ESSENTIALLY 1.') C 9999 CONTINUE RETURN END subroutine pnrerr(icode,number) C C * AUTHORS: Necip Doganaksoy and Wayne Nelson C * PURPOSE: Maximum likelihood fitting of the power-normal and C * -lognormal models to censored life or strength data C * from specimens of various sizes C * DOCUMENTATION: Wayne Nelson and Necip Doganaksoy, "A Computer C * Program POWNOR for Fitting the Power-Normal and C * -Lognormal Models to Life or Strength Data from C * Specimens of Various Sizes", NISTIR 4760, 3/1992. C * PROJECT: 1990-91 ASA/NIST/NSF Fellowship C C Modifed by Alan Heckert (6/2005) for incorporation into Dataplot. C ERROR MESSAGES C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') C if (icode.eq.1)then WRITE(ICOUT,101) 101 FORMAT('****** ERROR FROM POWER NORMAL MAXIMUM LIKELIHOOD:') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,103) 103 FORMAT(' LENGTHS MUST BE POSITIVE.') CALL DPWRST('XXX','BUG ') elseif (icode.eq.2)then WRITE(ICOUT,101) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,203) 203 FORMAT(' PARAMETER TYPES MUST BE 0 OR 1.') CALL DPWRST('XXX','BUG ') elseif (icode.eq.3)then WRITE(ICOUT,101) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,303) 303 FORMAT(' VALUE OF THE PRINT VARIABLE MUST BE 0 OR 1.') CALL DPWRST('XXX','BUG ') elseif (icode.eq.4)then WRITE(ICOUT,101) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,403)NUMBER 403 FORMAT(' INVALID DATA VALUE ENCOUNTERED ON ROW ', 1 I8,'.') CALL DPWRST('XXX','BUG ') elseif (icode.eq.6)then WRITE(ICOUT,101) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,603) 603 FORMAT(' THE INFORMATION MATRIX IS ILL-CONDITIONED.') CALL DPWRST('XXX','BUG ') elseif (icode.eq.7)then WRITE(ICOUT,101) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,703) 703 FORMAT(' CONVERGENCE PROBLEMS ENCOUNTERED DURING ', 1 'MAXIMIZATION OF THE LOGLIKELIHOOD FUNCTION.') CALL DPWRST('XXX','BUG ') elseif (icode.eq.8)then WRITE(ICOUT,101) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,803) 803 FORMAT(' MORE THAN TEN LENGTHS WERE SPECIFIED.') CALL DPWRST('XXX','BUG ') elseif (icode.eq.9)then WRITE(ICOUT,101) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,903) 903 FORMAT(' VALUE OF THE LOG TRANSFORMATION VARIABLE ', 1 'MUST BE 0 OR 1.') CALL DPWRST('XXX','BUG ') endif C CCCCC close (unit=1,status='save') CCCCC close (unit=8,status='save') WRITE(ICOUT,101) CALL DPWRST('XXX','BUG ') C return end SUBROUTINE PNRHAZ(X,P,S,HAZ) C C NOTE--POWER-NORMAL PDF IS: C PNRPDF(X,U,S,P) = (P/S)*NORPDF((X-U)/S)* C NORCDF(-(X-U)/S))**(P-1) C STANDARD FORM OF THIS DISTRIBUTION IS: C PNRPDF(X,S,P) = (P/S)*NORPDF(X)*NORCDF(-X/S)**(P-1) C HAZARD FUNCTION IS: C H(X,S,P) = P*NORHAZ(Z) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--98/4 C ORIGINAL VERSION--APRIL 1998. C UPDATED --NOVEMBER 2001. FORCE SD PARAMETER TO BE 1 C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C DOUBLE PRECISION DPDF DOUBLE PRECISION DCDF DOUBLE PRECISION DHAZ DOUBLE PRECISION DNORHZ C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C HAZ=0.0 SD=1.0 C IF(P.LE.0.0)THEN WRITE(ICOUT,101) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,103)P CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF IF(SD.LE.0.0)THEN WRITE(ICOUT,201) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,203)SD CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF 101 FORMAT('***** FATAL DIAGNOSTIC--THE POWER PARAMETER, P, IS ', 1 ' NON-POSITIVE.') 103 FORMAT(' THE VALUE OF P IS ',E15.7) 201 FORMAT('***** FATAL DIAGNOSTIC--THE STANDARD DEVIATION ', 1 'PARAMETER IS NON-POSITIVE.') 203 FORMAT(' THE VALUE IS ',E15.7) C Z=X/SD CALL NODPDF(DBLE(Z),DPDF) CALL NODCDF(DBLE(-Z),DCDF) IF(DCDF.GT.0.0D0)THEN DNORHZ=(DPDF/DCDF)/DBLE(SD) DHAZ=DBLE(P)*DNORHZ HAZ=REAL(DHAZ) ELSE HAZ=0.0 WRITE(ICOUT,901)X CALL DPWRST('XXX','BUG ') ENDIF 901 FORMAT('***** ERROR: FOR X = ',E15.7,' THE NORMAL CDF IS ', 1'ESSENTIALLY 0.') C 9999 CONTINUE RETURN END DOUBLE PRECISION FUNCTION PNRFUN(x,npar) C C * AUTHORS: Necip Doganaksoy and Wayne Nelson C * PURPOSE: Maximum likelihood fitting of the power-normal and C * -lognormal models to censored life or strength data C * from specimens of various sizes C * DOCUMENTATION: Wayne Nelson and Necip Doganaksoy, "A Computer C * Program POWNOR for Fitting the Power-Normal and C * -Lognormal Models to Life or Strength Data from C * Specimens of Various Sizes", NISTIR 4760, 3/1992. C * PROJECT: 1990-91 ASA/NIST/NSF Fellowship C C LOGLIKELIHOOD FUNCTION C implicit DOUBLE PRECISION (a-h,o-z) DOUBLE PRECISION x(npar) DOUBLE PRECISION timel(10000) DOUBLE PRECISION timeu(10000) DOUBLE PRECISION rlengt(10000) C common /PNRDAT/ timel,timeu,rlengt,iss common /PNRFVA/ rmufix,rlnsig,rlnfix common /PNRVAR/ mutype,lnsigt,lntype C CCCCC external dnordf external alnorm C ipar=0 if (mutype.eq.0) then ipar=ipar+1 rmu=x(ipar) else rmu=rmufix endif if (lnsigt.eq.0) then ipar=ipar+1 rlnsig=x(ipar) else rlnsig=rlnsig endif if (lntype.eq.0) then ipar=ipar+1 rlnlno=x(ipar) else rlnlno=rlnfix endif zero=0.0d0 pi=4.d0*(datan(.5d0)+datan(1.d0/3.d0)) accum=0.d0 do 100 i=1,iss c complete data if (timel(i).eq.timeu(i))then z=(timel(i)-rmu)/exp(rlnsig) z=ztran(z) phi=((2.d0*pi)**(-.5d0))*exp(-.5d0*z*z) relphi=alnorm(-z,.false.) rho=rlengt(i)/exp(rlnlno) rlogli=-log(rlengt(i))+rlnlno+rlnsig+(z*z)/2.d0- 1 (rho-1.d0)*log(relphi) c c right censored data c elseif (timeu(i).eq.1e10)then z=(timel(i)-rmu)/exp(rlnsig) z=ztran(z) relphi=alnorm(-z,.false.) rho=rlengt(i)/exp(rlnlno) rlogli=-rho*log(relphi) c c left censored data c elseif (timel(i).eq.-1e10)then z=(timeu(i)-rmu)/exp(rlnsig) z=ztran(z) relphi=alnorm(-z,.false.) rho=rlengt(i)/exp(rlnlno) rlogli=-log(1.d0-(relphi**rho)) c c interval data c elseif (timeu(i).gt.timel(i))then zl=(timel(i)-rmu)/exp(rlnsig) zl=ztran(zl) zu=(timeu(i)-rmu)/exp(rlnsig) zu=ztran(zu) relphl=alnorm(-zl,.false.) relphu=alnorm(-zu,.false.) rho=rlengt(i)/exp(rlnlno) rlogli=-log((relphl**rho)-(relphu**rho)) endif c accum=accum+rlogli 100 continue c pnrfun=accum c return end SUBROUTINE PNRPDF(X,P,PDF) CCCCC SUBROUTINE PNRPDF(X,P,SD,PDF) CCCCC SD IS ACTUALLY A SCALE PARAMETER IN THIS CASE. DON'T USE CCCCC IT COMPUTATION OF STANDARD FORM OF DISTRIBUTION. C C NOTE--POWER-NORMAL PDF IS: C PNRPDF(X,U,S,P) = (P/S)*NORPDF((X-U)/S)* C NORCDF(-(X-U)/S))**(P-1) C STANDARD FORM OF THIS DISTRIBUTION IS: C PNRPDF(X,P) = P*NORPDF(X)*NORCDF(-X)**(P-1) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--95/4 C ORIGINAL VERSION--APRIL 1995. C UPDATED --NOVEMBER 2001. MODIFY TO NOT USE SD, SOME C OTHER COMPUTATIONAL C MODIFICATIONS. C CCCCC NOTE: THE NODCDF ROUTINE (BASED ON ALNORM FROM APPLIED CCCCC STATISTICS) RETURNS 0 FOR X < -18.66 WHICH IN TURN CCCCC MAKES THIS PDF=0. C C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C DOUBLE PRECISION DTERM1 CCCCC DOUBLE PRECISION DTERM2 DOUBLE PRECISION DTERM3 DOUBLE PRECISION DTERM4 DOUBLE PRECISION DTERM5 CCCCC JULY 1995. ADD FOLLOWING LINE. DOUBLE PRECISION DPDF DOUBLE PRECISION DEPS DOUBLE PRECISION DEPS2 C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C INCLUDE 'DPCOMC.INC' C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C DATA DEPS/0.1D-300/ DATA DEPS2/-0.1D35/ C C-----START POINT----------------------------------------------------- C PDF=0.0 XMAXVL=38.0 C IF(P.LE.0.0)THEN WRITE(ICOUT,101) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,103)P CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF IF(ABS(X).GT.XMAXVL)THEN WRITE(ICOUT,301) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,303)-XMAXVL,XMAXVL CALL DPWRST('XXX','BUG ') WRITE(ICOUT,305)X CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF CCCCC IF(SD.LE.0.0)THEN CCCCC WRITE(ICOUT,201) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,203)SD CCCCC CALL DPWRST('XXX','BUG ') CCCCC GOTO9999 CCCCC ENDIF 101 FORMAT('***** FATAL DIAGNOSTIC--THE POWER PARAMETER, P, IS ', 1 ' NON-POSITIVE.') 103 FORMAT(' THE VALUE OF P IS ',E15.7) CC201 FORMAT('***** FATAL DIAGNOSTIC--THE STANDARD DEVIATION ', CCCCC1 'PARAMETER IS NON-POSITIVE.') 203 FORMAT(' THE VALUE IS ',E15.7) 301 FORMAT('***** FATAL DIAGNOSTIC--FOR THE PNRPDF FUNCTION--') 303 FORMAT(' DATAPLOT IS UNABLE TO COMPUTE NORCDF FOR VALUES', 1 ' OUTSIDE THE RANGE (',E15.7,',',E15.7,')') 305 FORMAT(' THE VALUE OF THE INPUT ARGUMENT IS ',E15.7) C CCCCC DEPS=D1MACH(1) C DTERM1=DLOG(DBLE(P)) CCCCC DTERM2=DLOG(DBLE(SD)) CCCCC TERM1=X/SD C IF(ABS(X).GT.38.D0)THEN DTERM3=DEPS ELSE CALL NODPDF(DBLE(X),DTERM3) ENDIF IF(DTERM3.LE.DEPS)DTERM3=DEPS DTERM3=DLOG(DTERM3) CCCCC TERM3=-TERM1 IF(X.GT.DBLE(XMAXVL))THEN CALL NODCDF(DBLE(-XMAXVL),DTERM4) ELSEIF(X.LT.-DBLE(XMAXVL))THEN CALL NODCDF(DBLE(XMAXVL),DTERM4) ELSE CALL NODCDF(DBLE(-X),DTERM4) ENDIF IF(DTERM4.LE.DEPS)DTERM4=DEPS DTERM4=DBLE(P-1.0)*DLOG(DTERM4) DTERM5=DTERM1 + DTERM3 + DTERM4 IF(DTERM5.LT.DEPS2)THEN PDF=0.0 ELSEIF(DTERM5.GT.-DEPS2)THEN PDF=0.0 ELSE DPDF=DEXP(DTERM5) PDF=REAL(DPDF) ENDIF GOTO9999 C 9999 CONTINUE RETURN END subroutine pnrper(p1,tp2,tp3,vp1,vtp2,vtp3,cp1tp2,cp1tp3,ctp2tp3, * slengt,noleng,allfix, * icapty,icapsw) c C * AUTHORS: Necip Doganaksoy and Wayne Nelson C * PURPOSE: Maximum likelihood fitting of the power-normal and C * -lognormal models to censored life or strength data C * from specimens of various sizes C * DOCUMENTATION: Wayne Nelson and Necip Doganaksoy, "A Computer C * Program POWNOR for Fitting the Power-Normal and C * -Lognormal Models to Life or Strength Data from C * Specimens of Various Sizes", NISTIR 4760, 3/1992. C * PROJECT: 1990-91 ASA/NIST/NSF Fellowship C c ML ESTIMATES OF PERCENTILES AND THEIR CONFIDENCE LIMITS c implicit double precision (a-h,o-z) double precision f(16),slengt(15) dimension pctpri(16) character*4 pctpri logical allfix CCCCC external dnorin C character*4 ICAPSW character*4 ICAPTY C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C REAL CPUMIN REAL CPUMAX C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C c data f /.001d0, .002d0, .005d0, .01d0, .02d0, .05d0,.1d0, * .3d0, .5d0, .7d0, .9d0, .95d0, .98d0, .99d0, .995d0, * .999d0/ data pctpri /'0.1','0.2','0.5','1','2','5','10','30','50','70', * '90', '95','98','99','99.5','99.9'/ p2=exp(tp2) p3=exp(tp3) pinum=4.d0*(datan(.5d0)+datan(1.d0/3.d0)) const=(2.d0*pinum)**(-.5d0) if(icapsw.eq.'ON' .and. icapty.eq.'HTML')then elseif(icapsw.eq.'ON' .and. icapty.eq.'LATE')then elseif(icapsw.eq.'ON' .and. icapty.eq.'RTF ')then else write(icout,999) 999 format(1x) CALL DPWRST('XXX','WRIT') write(icout,999) CALL DPWRST('XXX','WRIT') if(noleng.ne.0)then if (allfix) then write(icout,4201) 4201 format('PERCENTILE ESTIMATES') CALL DPWRST('XXX','WRIT') else write(icout,4203) 4203 format('MAXIMUM LIKELIHOOD ESTIMATES FOR DISTRIBUTION ', 1 'PERCENTILES') CALL DPWRST('XXX','WRIT') write(icout,4205) 4205 format('WITH APPROXIMATE 95% CONFIDENCE LIMITS') CALL DPWRST('XXX','WRIT') endif endif do 177 maini=1,noleng write(icout,999) CALL DPWRST('XXX','WRIT') write(icout,4211)SLENGT(MAINI) 4211 format('LENGTH = ',F15.4) CALL DPWRST('XXX','WRIT') write(icout,999) CALL DPWRST('XXX','WRIT') if(allfix)then write(icout,4221) 4221 format('PCT. ESTIMATE') CALL DPWRST('XXX','WRIT') else write(icout,4223) 4223 format('PCT. ML ESTIMATE LOWER LIMIT ', 1 'UPPER LIMIT STD. ERROR') CALL DPWRST('XXX','WRIT') endif do 100 i=1,16,1 fhp=1.d0-((1.d0-f(i))**(p3/slengt(maini))) CNIST zfhp=dnorin(fhp) CALL NODPPF(FHP,ZFHP) rmlper=p1+zfhp*p2 if (allfix) then write(icout,4231)pctpri(i),rmlper 4231 format(1X,A4,3X,F12.4) CALL DPWRST('XXX','WRIT') else phi=const*exp(-.5d0*zfhp*zfhp) term=-(p2*(1.d0-fhp)*p3* 1 log(1.d0-f(i)))/(slengt(maini)*phi) varper=vp1+((zfhp*p2)**2.d0)*vtp2+ 1 (term*term*vtp3)+2.d0*zfhp*p2*cp1tp2 1 +2.d0*term*cp1tp3+2.d0*zfhp*p2*term*ctp2tp3 rstd=varper**.5d0 rlow=rmlper-1.96d0*rstd rup=rmlper+1.96d0*rstd write(icout,4236)pctpri(i),rmlper,rlow,rup,rstd 4236 format(1x,a4,3x,f12.4,3x,f12.4,3x,f12.4,3x,f12.4) CALL DPWRST('XXX','WRIT') endif 100 continue 177 continue endif c return end SUBROUTINE PNRPPF(P,POWER,S,PPF) C C NOTE--POWER-NORMAL PPF IS: C PNRPPF(P,U,SD,POWER) = U+Zf*SD C WHERE Zf = NORPPF(1-(1-P)**(1/POWER)) C STANDARD FORM OF THIS DISTRIBUTION IS: C PNRPPF(P,U,SD,POWER) = Zf C FOR CONSISTENCY WITH PNRPDF ROUTINE, ALLOW SD AS C OPTIONAL PARAMETER. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--95/4 C ORIGINAL VERSION--APRIL 1995. C MODIFIED --JUNE 1995. CHECK FOR MAXIMUM VALUE C MODIFIED --SEPTEMBER 1995. BETTER HANDLING OF CASE WHEN C NORPPF CALLED WITH VALUE CLOSE C TO 1. C MODIFIED --NOVEMBER 2001. ALGORITHM UPDATES C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 DOUBLE PRECISION DTERM3 DOUBLE PRECISION DTERM4 DOUBLE PRECISION DTERM5 CCCCC DOUBLE PRECISION DTMIN, DTMAX, DEPS DOUBLE PRECISION DTMIN, DEPS C C--------------------------------------------------------------------- C INCLUDE 'DPCOMC.INC' C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C DATA DEPS/1.0D-16/ C C-----START POINT----------------------------------------------------- C PPF=0.0 C CCCCC NOVEMBER 2001: FORCE SD TO BE 1 (THIS IS ACTUALLY A SCALE CCCCC PARAMETER, SO HANDLE IN THE STANDARD WAY). C SD=1.0 DTMIN=D1MACH(1) C IF(P.LE.0.0 .OR. P.GE.1.0)THEN WRITE(ICOUT,1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)P CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9999 ENDIF IF(POWER.LE.0.0)THEN WRITE(ICOUT,101) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,203)POWER CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF IF(SD.LE.0.0)THEN WRITE(ICOUT,201) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,203)SD CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF 1 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ', 1' PNRPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') 101 FORMAT('***** FATAL DIAGNOSTIC--THE POWER PARAMETER IS ', 1 ' NON-POSITIVE.') 201 FORMAT('***** FATAL DIAGNOSTIC--THE STANDARD DEVIATION ', 1 'PARAMETER IS NON-POSITIVE.') 203 FORMAT(' THE VALUE IS ',E15.7) C DTERM1= 1.0D0 - DBLE(P) DTERM2=1.0D0/DBLE(POWER) DTERM3=DTERM1**DTERM2 CCCCC SEPTEMBER 1995. HANDLE CASE WHERE NORPPF CALLED WITH ARGUMENT CCCCC CLOSE TO 1 BETTER. IF(DTERM3.LT.DEPS)THEN IF(DTERM3.LE.DTMIN)DTERM3=DTMIN CALL NODPPF(DTERM3,DTERM4) DTERM4=-DTERM4 ELSE DTERM3=1.0D0 - DTERM3 IF(DTERM3.LE.DTMIN)DTERM3=DTMIN CCCCC JUNE 1995. ADD FOLLOWING 2 LINES CCCCC DTMAX=1.0D0-DEPS CCCCC IF(DTERM3.GE.DTMAX)DTERM3=DTMAX CALL NODPPF(DTERM3,DTERM4) ENDIF C DTERM5=DBLE(SD)*DTERM4 PPF=REAL(DTERM5) GOTO9999 C 9999 CONTINUE RETURN END SUBROUTINE PNRRAN(N,P,ISEED,X) C C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N C FROM THE POWER NORMAL DISTRIBUTION C WITH SHAPE PARAMETER VALUE = P. C INPUT ARGUMENTS--N = THE DESIRED INTEGER NUMBER C OF RANDOM NUMBERS TO BE C GENERATED. C --P = THE SINGLE PRECISION VALUE OF THE C SHAPE PARAMETER. C P SHOULD BE POSITIVE. C OUTPUT ARGUMENTS--X = A SINGLE PRECISION VECTOR C (OF DIMENSION AT LEAST N) C INTO WHICH THE GENERATED C RANDOM SAMPLE WILL BE PLACED. C OUTPUT--A RANDOM SAMPLE OF SIZE N C FROM THE POWER NORMAL DISTRIBUTION C WITH TAIL LENGTH PARAMETER VALUE = P. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C --P SHOULD BE POSITIVE. C OTHER DATAPAC SUBROUTINES NEEDED--UNIRAN. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--XX C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2001.10 C ORIGINAL VERSION--OCTOBER 2001. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DIMENSION X(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(N.LT.1)THEN WRITE(ICOUT, 5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)N CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF IF(P.LE.0.0)THEN WRITE(ICOUT,15) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)P CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF 5 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ', 1'PNRRAN SUBROUTINE IS NON-POSITIVE *****') 15 FORMAT('***** FATAL ERROR--THE 2ND INPUT ARGUMENT TO THE ', 1'PNRRAN SUBROUTINE IS NON-POSITIVE *****') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****') C C GENERATE N UNIFORM (0,1) RANDOM NUMBERS; C CALL UNIRAN(N,ISEED,X) C C GENERATE N POWER NORMAL DISTRIBUTION RANDOM NUMBERS C USING PERCENT POINT FUNCTION C SD=1.0 DO100I=1,N CALL PNRPPF(X(I),P,SD,XTEMP) X(I)=XTEMP 100 CONTINUE C 9000 CONTINUE RETURN END SUBROUTINE POICDF(X,ALAMBA,CDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION C FUNCTION VALUE AT THE SINGLE PRECISION VALUE X C FOR THE POISSON DISTRIBUTION C WITH SINGLE PRECISION C TAIL LENGTH PARAMETER = ALAMBA. C THE POISSON DISTRIBUTION USED C HEREIN HAS MEAN = ALAMBA C AND STANDARD DEVIATION = SQRT(ALAMBA). C THIS DISTRIBUTION IS DEFINED FOR C ALL DISCRETE NON-NEGATIVE INTEGER X--X = 0, 1, 2, ... . C THIS DISTRIBUTION HAS THE PROBABILITY FUNCTION C F(X) = EXP(-ALAMBA) * ALAMBA**X / X!. C THE POISSON DISTRIBUTION IS THE C DISTRIBUTION OF THE NUMBER OF EVENTS C IN THE INTERVAL (0,ALAMBA) WHEN C THE WAITING TIME BETWEEN EVENTS C IS EXPONENTIALLY DISTRIBUTED C WITH MEAN = 1 AND STANDARD DEVIATION = 1. C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE C AT WHICH THE CUMULATIVE DISTRIBUTION C FUNCTION IS TO BE EVALUATED. C X SHOULD BE NON-NEGATIVE AND C INTEGRAL-VALUED. C --ALAMBA = THE SINGLE PRECISION VALUE C OF THE TAIL LENGTH PARAMETER. C ALAMBA SHOULD BE POSITIVE. C OUTPUT ARGUMENTS--CDF = THE SINGLE PRECISION CUMULATIVE C DISTRIBUTION FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION C FUNCTION VALUE CDF C FOR THE POISSON DISTRIBUTION C WITH TAIL LENGTH PARAMETER = ALAMBA. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--X SHOULD BE NON-NEGATIVE AND INTEGRAL-VALUED. C --ALAMBA SHOULD BE POSITIVE. C OTHER DATAPAC SUBROUTINES NEEDED--NORCDF. C FORTRAN LIBRARY SUBROUTINES NEEDED--DSQRT, DATAN. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C COMMENT--THE SINGLE PRECISION TAIL LENGTH C PARAMETER ALAMBA IS NOT RESTRICTED C TO ONLY INTEGER VALUES. C ALAMBA CAN BE SET TO ANY POSITIVE REAL C VALUE--INTEGER OR NON-INTEGER. C --NOTE THAT EVEN THOUGH THE INPUT C TO THIS CUMULATIVE C DISTRIBUTION FUNCTION SUBROUTINE C FOR THIS DISCRETE DISTRIBUTION C SHOULD (UNDER NORMAL CIRCUMSTANCES) BE A C DISCRETE INTEGER VALUE, C THE INPUT VARIABLE X IS SINGLE C PRECISION IN MODE. C X HAS BEEN SPECIFIED AS SINGLE C PRECISION SO AS TO CONFORM WITH THE DATAPAC C CONVENTION THAT ALL INPUT ****DATA**** C (AS OPPOSED TO SAMPLE SIZE, FOR EXAMPLE) C VARIABLES TO ALL C DATAPAC SUBROUTINES ARE SINGLE PRECISION. C THIS CONVENTION IS BASED ON THE BELIEF THAT C 1) A MIXTURE OF MODES (FLOATING POINT C VERSUS INTEGER) IS INCONSISTENT AND C AN UNNECESSARY COMPLICATION C IN A DATA ANALYSIS; AND C 2) FLOATING POINT MACHINE ARITHMETIC C (AS OPPOSED TO INTEGER ARITHMETIC) C IS THE MORE NATURAL MODE FOR DOING C DATA ANALYSIS. C REFERENCES--JOHNSON AND KOTZ, DISCRETE C DISTRIBUTIONS, 1969, PAGES 87-121, C ESPECIALLY PAGE 114, FORMULA 93. C --HASTINGS AND PEACOCK, STATISTICAL C DISTRIBUTIONS--A HANDBOOK FOR C STUDENTS AND PRACTITIONERS, 1975, C PAGE 112. C --NATIONAL BUREAU OF STANDARDS APPLIED MATHEMATICS C SERIES 55, 1964, PAGE 941, FORMULAE 26.4.4 AND 26.4.5, C AND PAGE 929. C --FELLER, AN INTRODUCTION TO PROBABILITY C THEORY AND ITS APPLICATIONS, VOLUME 1, C EDITION 2, 1957, PAGES 146-154. C --COX AND MILLER, THE THEORY OF STOCHASTIC C PROCESSES, 1965, PAGE 7. C --GENERAL ELECTRIC COMPANY, TABLES OF THE C INDIVIDUAL AND CUMULATIVE TERMS OF POISSON C DISTRIBUTION, 1962. C --OWEN, HANDBOOK OF STATISTICAL C TABLES, 1962, PAGES 259-261. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--82.6 C ORIGINAL VERSION--NOVEMBER 1975. C UPDATED --DECEMBER 1981. C UPDATED --MAY 1982. C UPDATED --MAY 2006. USE NORMAL APPROXIMATION C FOR LARGE LAMBDA C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DX,PI,CHI,SUM,TERM,AI,DGCDF DOUBLE PRECISION DSQRT,DEXP,DCDF,DMU,DSD C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----DATA STATEMENTS------------------------------------------------- C DATA PI/3.14159265358979D0/ C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(ALAMBA.LE.0.0)THEN WRITE(ICOUT,15) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)ALAMBA CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9000 ELSEIF(X.LT.0.0)THEN WRITE(ICOUT,4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9000 ENDIF 15 FORMAT('*****ERROR--THE SECOND INPUT ARGUMENT TO THE ', 1'POICDF SUBROUTINE IS NON-POSITIVE *****') 4 FORMAT('*****WARNING--THE FIRST INPUT ARGUMENT ', 1'TO THE POICDF SUBROUTINE IS NEGATIVE *****') C INTX=X+0.0001 FINTX=INTX DEL=X-FINTX IF(DEL.LT.0.0)DEL=-DEL IF(DEL.GT.0.001)THEN WRITE(ICOUT,5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') ENDIF 5 FORMAT('***** WARNING--THE FIRST INPUT ARGUMENT ', 1'TO THE POICDF SUBROUTINE IS NON-INTEGRAL *****') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.8,' *****') 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****') C C EXPRESS THE POISSON CUMULATIVE DISTRIBUTION C FUNCTION IN TERMS OF THE EQUIVALENT CHI-SQUARED C CUMULATIVE DISTRIBUTION FUNCTION, C AND THEN EVALUATE THE LATTER. C C MAY 2006: FOR LARGE LAMBDA, THE CHI-SQUARE APPROACH CAN C RESULT IN A SUM > LARGEST MACHINE DOOBLE PRECISION C NUMBER. SO FOR LAMBDA >= 500, USE THE NORMAL C APPROXIMATION WITH MU = LAMBDA, SD=SQRT(LAMBDA). C IF(ALAMBA.GE.500.0)THEN NU=X+0.0001 DX=DBLE(NU) DMU=DBLE(ALAMBA) DSD=DSQRT(DBLE(ALAMBA)) DX=(DX-DMU)/DSD CALL NODCDF(DX,DCDF) CDF=REAL(DCDF) GOTO9000 ENDIF C DX=ALAMBA DX=2.0D0*DX NU=X+0.0001 NU=2*(1+NU) C 110 CONTINUE CHI=DSQRT(DX) IEVODD=NU-2*(NU/2) IF(IEVODD.EQ.0)GOTO120 C SUM=0.0D0 TERM=1.0/CHI IMIN=1 IMAX=NU-1 GOTO130 C 120 CONTINUE SUM=1.0D0 TERM=1.0D0 IMIN=2 IMAX=NU-2 C 130 CONTINUE IF(IMIN.GT.IMAX)GOTO160 DO100I=IMIN,IMAX,2 AI=I TERM=TERM*(DX/AI) SUM=SUM+TERM 100 CONTINUE C 160 CONTINUE SUM=SUM*DEXP(-DX/2.0D0) IF(IEVODD.EQ.0)GOTO170 SUM=(DSQRT(2.0D0/PI))*SUM SPCHI=CHI CALL NORCDF(SPCHI,GCDF) DGCDF=GCDF SUM=SUM+2.0D0*(1.0D0-DGCDF) 170 CONTINUE CDF=SUM GOTO9000 C 9000 CONTINUE RETURN END SUBROUTINE PODCDF(X,ALAMBA,CDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION C FUNCTION VALUE AT THE DOUBLE PRECISION VALUE X C FOR THE POISSON DISTRIBUTION C WITH DOUBLE PRECISION C TAIL LENGTH PARAMETER = ALAMBA. C THE POISSON DISTRIBUTION USED C HEREIN HAS MEAN = ALAMBA C AND STANDARD DEVIATION = SQRT(ALAMBA). C THIS DISTRIBUTION IS DEFINED FOR C ALL DISCRETE NON-NEGATIVE INTEGER X--X = 0, 1, 2, ... . C THIS DISTRIBUTION HAS THE PROBABILITY FUNCTION C F(X) = EXP(-ALAMBA) * ALAMBA**X / X!. C THE POISSON DISTRIBUTION IS THE C DISTRIBUTION OF THE NUMBER OF EVENTS C IN THE INTERVAL (0,ALAMBA) WHEN C THE WAITING TIME BETWEEN EVENTS C IS EXPONENTIALLY DISTRIBUTED C WITH MEAN = 1 AND STANDARD DEVIATION = 1. C C NOTE: THIS IS A COPY OF POICDF. DOUBLE PRECISION C MAY BE HELPFUL FOR LARGE VALUES OF LAMBDA. C C INPUT ARGUMENTS--X = THE DOUBLE PRECISION VALUE C AT WHICH THE CUMULATIVE DISTRIBUTION C FUNCTION IS TO BE EVALUATED. C X SHOULD BE NON-NEGATIVE AND C INTEGRAL-VALUED. C --ALAMBA = THE DOUBLE PRECISION VALUE C OF THE TAIL LENGTH PARAMETER. C ALAMBA SHOULD BE POSITIVE. C OUTPUT ARGUMENTS--CDF = THE DOUBLE PRECISION CUMULATIVE C DISTRIBUTION FUNCTION VALUE. C OUTPUT--THE DOUBLE PRECISION CUMULATIVE DISTRIBUTION C FUNCTION VALUE CDF C FOR THE POISSON DISTRIBUTION C WITH TAIL LENGTH PARAMETER = ALAMBA. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--X SHOULD BE NON-NEGATIVE AND INTEGRAL-VALUED. C --ALAMBA SHOULD BE POSITIVE. C OTHER DATAPAC SUBROUTINES NEEDED--NORCDF. C FORTRAN LIBRARY SUBROUTINES NEEDED--DSQRT, DATAN. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C COMMENT--THE DOUBLE PRECISION TAIL LENGTH C PARAMETER ALAMBA IS NOT RESTRICTED C TO ONLY INTEGER VALUES. C ALAMBA CAN BE SET TO ANY POSITIVE REAL C VALUE--INTEGER OR NON-INTEGER. C --NOTE THAT EVEN THOUGH THE INPUT C TO THIS CUMULATIVE C DISTRIBUTION FUNCTION SUBROUTINE C FOR THIS DISCRETE DISTRIBUTION C SHOULD (UNDER NORMAL CIRCUMSTANCES) BE A C DISCRETE INTEGER VALUE, C THE INPUT VARIABLE X IS SINGLE C PRECISION IN MODE. C X HAS BEEN SPECIFIED AS SINGLE C PRECISION SO AS TO CONFORM WITH THE DATAPAC C CONVENTION THAT ALL INPUT ****DATA**** C (AS OPPOSED TO SAMPLE SIZE, FOR EXAMPLE) C VARIABLES TO ALL C DATAPAC SUBROUTINES ARE DOUBLE PRECISION. C THIS CONVENTION IS BASED ON THE BELIEF THAT C 1) A MIXTURE OF MODES (FLOATING POINT C VERSUS INTEGER) IS INCONSISTENT AND C AN UNNECESSARY COMPLICATION C IN A DATA ANALYSIS; AND C 2) FLOATING POINT MACHINE ARITHMETIC C (AS OPPOSED TO INTEGER ARITHMETIC) C IS THE MORE NATURAL MODE FOR DOING C DATA ANALYSIS. C REFERENCES--JOHNSON AND KOTZ, DISCRETE C DISTRIBUTIONS, 1969, PAGES 87-121, C ESPECIALLY PAGE 114, FORMULA 93. C --HASTINGS AND PEACOCK, STATISTICAL C DISTRIBUTIONS--A HANDBOOK FOR C STUDENTS AND PRACTITIONERS, 1975, C PAGE 112. C --NATIONAL BUREAU OF STANDARDS APPLIED MATHEMATICS C SERIES 55, 1964, PAGE 941, FORMULAE 26.4.4 AND 26.4.5, C AND PAGE 929. C --FELLER, AN INTRODUCTION TO PROBABILITY C THEORY AND ITS APPLICATIONS, VOLUME 1, C EDITION 2, 1957, PAGES 146-154. C --COX AND MILLER, THE THEORY OF STOCHASTIC C PROCESSES, 1965, PAGE 7. C --GENERAL ELECTRIC COMPANY, TABLES OF THE C INDIVIDUAL AND CUMULATIVE TERMS OF POISSON C DISTRIBUTION, 1962. C --OWEN, HANDBOOK OF STATISTICAL C TABLES, 1962, PAGES 259-261. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--82.6 C ORIGINAL VERSION--NOVEMBER 1975. C UPDATED --DECEMBER 1981. C UPDATED --MAY 1982. C UPDATED --MAY 2006. USE NORMAL APPROXIMATION C FOR LARGE LAMBDA C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C IMPLICIT DOUBLE PRECISION (A-H,O-Z) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C REAL CPUMIN REAL CPUMAX COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----DATA STATEMENTS------------------------------------------------- C DATA PI/3.14159265358979D0/ C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(ALAMBA.LE.0.0D0)THEN WRITE(ICOUT,15) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)ALAMBA CALL DPWRST('XXX','BUG ') CDF=0.0D0 GOTO9000 ELSEIF(X.LT.0.0)THEN WRITE(ICOUT,4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') CDF=0.0D0 GOTO9000 ENDIF 15 FORMAT('*****ERROR--THE SECOND INPUT ARGUMENT TO THE ', 1'POICDF SUBROUTINE IS NON-POSITIVE *****') 4 FORMAT('*****WARNING--THE FIRST INPUT ARGUMENT ', 1'TO THE POICDF SUBROUTINE IS NEGATIVE *****') C INTX=X+0.0001D0 FINTX=INTX DEL=X-FINTX IF(DEL.LT.0.0)DEL=-DEL IF(DEL.GT.0.001)THEN WRITE(ICOUT,5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') ENDIF 5 FORMAT('***** WARNING--THE FIRST INPUT ARGUMENT ', 1'TO THE POICDF SUBROUTINE IS NON-INTEGRAL *****') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.8,' *****') 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****') C C EXPRESS THE POISSON CUMULATIVE DISTRIBUTION C FUNCTION IN TERMS OF THE EQUIVALENT CHI-SQUARED C CUMULATIVE DISTRIBUTION FUNCTION, C AND THEN EVALUATE THE LATTER. C C MAY 2006: FOR LARGE LAMBDA, THE CHI-SQUARE APPROACH CAN C RESULT IN A SUM > LARGEST MACHINE DOOBLE PRECISION C NUMBER. SO FOR LAMBDA >= 500, USE THE NORMAL C APPROXIMATION WITH MU = LAMBDA, SD=SQRT(LAMBDA). C IF(ALAMBA.GE.500.0D0)THEN NU=X+0.0001D0 DX=DBLE(NU) DMU=DBLE(ALAMBA) DSD=DSQRT(DBLE(ALAMBA)) DX=(DX-DMU)/DSD CALL NODCDF(DX,DCDF) CDF=DCDF GOTO9000 ENDIF C DX=ALAMBA DX=2.0D0*DX NU=X+0.0001D0 NU=2*(1+NU) C 110 CONTINUE CHI=DSQRT(DX) IEVODD=NU-2*(NU/2) IF(IEVODD.EQ.0)GOTO120 C SUM=0.0D0 TERM=1.0D0/CHI IMIN=1 IMAX=NU-1 GOTO130 C 120 CONTINUE SUM=1.0D0 TERM=1.0D0 IMIN=2 IMAX=NU-2 C 130 CONTINUE IF(IMIN.GT.IMAX)GOTO160 DO100I=IMIN,IMAX,2 AI=I TERM=TERM*(DX/AI) SUM=SUM+TERM 100 CONTINUE C 160 CONTINUE SUM=SUM*DEXP(-DX/2.0D0) IF(IEVODD.EQ.0)GOTO170 SUM=(DSQRT(2.0D0/PI))*SUM SPCHI=CHI CALL NODCDF(SPCHI,GCDF) DGCDF=GCDF SUM=SUM+2.0D0*(1.0D0-DGCDF) 170 CONTINUE CDF=SUM GOTO9000 C 9000 CONTINUE RETURN END REAL FUNCTION POIFUN(ALAMB) C C PURPOSE--DPMLPO CALLS FZERO TO FIND A ROOT FOR ONE OF C THE FOLLOWING FUNCTIONS: C C POICDF(S;N*LAMBDAL) - (1 - ALPHA/2) = 0 C POICDF(S;N*LAMBDAU) - (ALPHA/2) = 0 C C WITH C C S = SUM[i=1 to n][X(i)] C N = SAMPLE SIZE C LAMBDAL = LOWER CONFIDENCE LEVEL FOR LAMBDA C LAMBDAU = UPPER CONFIDENCE LEVEL FOR LAMBDA C ALPHA = DESIRED SIGNIFICANCE LEVEL C C DPMLPO IS TRYING TO DETERMINE AN CONFIDENCE INTERVAL C FOR LAMBDA. THE VALUES FOR S, N, (1-ALPHA/2), C (OR ALPHA/2) ARE PASSED IN VIA A COMMON BLOCK. C C INPUT ARGUMENTS--ALAMB = THE SINGLE PRECISION VALUE THAT C SPECIFIES THE SHAPE PARAMETER FOR C THE POISSON DISTRIBUTION. C OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY C FUNCTION VALUE POIFUN. C PRINTING--NONE. C RESTRICTIONS--NONE. C OTHER DATAPAC SUBROUTINES NEEDED--POICDF. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--KARL BURY (1999). "STATISTICAL DISTRIBUTIONS IN C ENGINEERING", CAMBRIDGE UNIVERSITY PRESS, C PP. 105-106. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATION INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2005.8 C ORIGINAL VERSION--SEPTEMBER 2005. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C COMMON/POICOM/N,S,CONST C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C CALL POICDF(S,REAL(N)*ALAMB,CDF) POIFUN=CDF - CONST C 9999 CONTINUE RETURN END SUBROUTINE POIPPF(P,ALAMBA,PPF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT C FUNCTION VALUE AT THE SINGLE PRECISION VALUE P C FOR THE POISSON DISTRIBUTION C WITH SINGLE PRECISION C TAIL LENGTH PARAMETER = ALAMBA. C THE POISSON DISTRIBUTION USED C HEREIN HAS MEAN = ALAMBA C AND STANDARD DEVIATION = SQRT(ALAMBA). C THIS DISTRIBUTION IS DEFINED FOR C ALL DISCRETE NON-NEGATIVE INTEGER X--X = 0, 1, 2, ... . C THIS DISTRIBUTION HAS THE PROBABILITY FUNCTION C F(X) = EXP(-ALAMBA) * ALAMBA**X / X!. C THE POISSON DISTRIBUTION IS THE C DISTRIBUTION OF THE NUMBER OF EVENTS C IN THE INTERVAL (0,ALAMBA) WHEN C THE WAITING TIME BETWEEN EVENTS C IS EXPONENTIALLY DISTRIBUTED C WITH MEAN = 1 AND STANDARD DEVIATION = 1. C NOTE THAT THE PERCENT POINT FUNCTION OF A DISTRIBUTION C IS IDENTICALLY THE SAME AS THE INVERSE CUMULATIVE C DISTRIBUTION FUNCTION OF THE DISTRIBUTION. C INPUT ARGUMENTS--P = THE SINGLE PRECISION VALUE C (BETWEEN 0.0 (INCLUSIVELY) C AND 1.0 (EXCLUSIVELY)) C AT WHICH THE PERCENT POINT C FUNCTION IS TO BE EVALUATED. C --ALAMBA = THE SINGLE PRECISION VALUE C OF THE TAIL LENGTH PARAMETER. C ALAMBA SHOULD BE POSITIVE. C OUTPUT ARGUMENTS--PPF = THE SINGLE PRECISION PERCENT C POINT FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION PERCENT POINT . C FUNCTION VALUE PPF C FOR THE POISSON DISTRIBUTION C WITH TAIL LENGTH PARAMETER = ALAMBA. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--ALAMBA SHOULD BE POSITIVE. C --P SHOULD BE BETWEEN 0.0 (INCLUSIVELY) C AND 1.0 (EXCLUSIVELY). C OTHER DATAPAC SUBROUTINES NEEDED--NORPPF, POICDF. C FORTRAN LIBRARY SUBROUTINES NEEDED--SQRT, DEXP. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION AND DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C COMMENT--THE SINGLE PRECISION TAIL LENGTH C PARAMETER ALAMBA IS NOT RESTRICTED C TO ONLY INTEGER VALUES. C ALAMBA CAN BE SET TO ANY POSITIVE REAL C VALUE--INTEGER OR NON-INTEGER. C --NOTE THAT EVEN THOUGH THE OUTPUT C FROM THIS DISCRETE DISTRIBUTION C PERCENT POINT FUNCTION C SUBROUTINE MUST NECESSARILY BE A C DISCRETE INTEGER VALUE, C THE OUTPUT VARIABLE PPF IS SINGLE C PRECISION IN MODE. C PPF HAS BEEN SPECIFIED AS SINGLE C PRECISION SO AS TO CONFORM WITH THE DATAPAC C CONVENTION THAT ALL OUTPUT VARIABLES FROM ALL C DATAPAC SUBROUTINES ARE SINGLE PRECISION. C THIS CONVENTION IS BASED ON THE BELIEF THAT C 1) A MIXTURE OF MODES (FLOATING POINT C VERSUS INTEGER) IS INCONSISTENT AND C AN UNNECESSARY COMPLICATION C IN A DATA ANALYSIS; AND C 2) FLOATING POINT MACHINE ARITHMETIC C (AS OPPOSED TO INTEGER ARITHMETIC) C IS THE MORE NATURAL MODE FOR DOING C DATA ANALYSIS. C REFERENCES--JOHNSON AND KOTZ, DISCRETE C DISTRIBUTIONS, 1969, PAGES 87-121, C ESPECIALLY PAGE 102, FORMULA 36.1. C --HASTINGS AND PEACOCK, STATISTICAL C DISTRIBUTIONS--A HANDBOOK FOR C STUDENTS AND PRACTITIONERS, 1975, C PAGES 108-113. C --NATIONAL BUREAU OF STANDARDS APPLIED MATHEMATICS C SERIES 55, 1964, PAGE 929. C --FELLER, AN INTRODUCTION TO PROBABILITY C THEORY AND ITS APPLICATIONS, VOLUME 1, C EDITION 2, 1957, PAGES 146-154. C --COX AND MILLER, THE THEORY OF STOCHASTIC C PROCESSES, 1965, PAGE 7. C --GENERAL ELECTRIC COMPANY, TABLES OF THE C INDIVIDUAL AND CUMULATIVE TERMS OF POISSON C DISTRIBUTION, 1962. C --OWEN, HANDBOOK OF STATISTICAL C TABLES, 1962, PAGES 259-261. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--82.6 C ORIGINAL VERSION--NOVEMBER 1975. C UPDATED --OCTOBER 1978. C UPDATED --NOVEMBER 1981. C UPDATED --DECEMBER 1981. C UPDATED --FEBRUARY 1982. C UPDATED --MARCH 1982. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DLAMBA C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(P.LT.0.0.OR.P.GE.1.0)GOTO50 IF(ALAMBA.LE.0.0)GOTO55 GOTO90 50 WRITE(ICOUT,1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)P CALL DPWRST('XXX','BUG ') PPF=0.0 RETURN 55 WRITE(ICOUT,15) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)ALAMBA CALL DPWRST('XXX','BUG ') PPF=0.0 RETURN 90 CONTINUE 1 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ', 1'POIPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL') 15 FORMAT('***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE ', 1'POIPPF SUBROUTINE IS NON-POSITIVE *****') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') C DLAMBA=ALAMBA PPF=0.0 IX0=0 IX1=0 IX2=0 P0=0.0 P1=0.0 P2=0.0 C C TREAT CERTAIN SPECIAL CASES IMMEDIATELY-- C 1) P = 0.0 C 2) PPF = 0 C IF(P.EQ.0.0)GOTO110 PF0=DEXP(-DLAMBA) IF(P.LE.PF0)GOTO110 GOTO190 110 PPF=0.0 RETURN 190 CONTINUE C C DETERMINE AN INITIAL APPROXIMATION TO THE POISSON C PERCENT POINT BY USE OF THE NORMAL APPROXIMATION C TO THE POISSON. C (SEE JOHNSON AND KOTZ, DISCRETE DISTRIBUTIONS, C PAGE 102, FORMULA 36.1). C AMEAN=ALAMBA SD=SQRT(ALAMBA) CALL NORPPF(P,ZPPF) X2=AMEAN-1.0+ZPPF*SD IX2=X2 C C CHECK AND MODIFY (IF NECESSARY) THIS INITIAL C ESTIMATE OF THE PERCENT POINT C TO ASSURE THAT IT BE NON-NEGATIVE. C IF(IX2.LT.0)IX2=0 C C DETERMINE UPPER AND LOWER BOUNDS ON THE DESIRED C PERCENT POINT BY ITERATING OUT (BOTH BELOW AND ABOVE) C FROM THE ORIGINAL APPROXIMATION AT STEPS C OF 1 STANDARD DEVIATION. C THE RESULTING BOUNDS WILL BE AT MOST C 1 STANDARD DEVIATION APART. C IX0=0 IX1=INT(10.0**7 + 0.01) ISD=SD+1.0 X2=IX2 CALL POICDF(X2,ALAMBA,P2) C IF(P2.LT.P)GOTO210 GOTO250 C 210 CONTINUE IX0=IX2 I=1 215 CONTINUE IX2=IX0+ISD IF(IX2.GE.IX1)GOTO275 X2=IX2 CALL POICDF(X2,ALAMBA,P2) IF(P2.GE.P)GOTO230 IX0=IX2 220 CONTINUE I=I+1 IF(I.LE.1000000)GOTO215 WRITE(ICOUT,249) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,222) CALL DPWRST('XXX','BUG ') GOTO950 230 IX1=IX2 GOTO275 C 250 CONTINUE IX1=IX2 I=1 255 CONTINUE IX2=IX1-ISD IF(IX2.LE.IX0)GOTO275 X2=IX2 CALL POICDF(X2,ALAMBA,P2) IF(P2.LT.P)GOTO270 IX1=IX2 260 CONTINUE I=I+1 IF(I.LE.1000000)GOTO255 WRITE(ICOUT,249) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,262) CALL DPWRST('XXX','BUG ') GOTO950 270 IX0=IX2 C 275 IF(IX0.EQ.IX1)GOTO280 GOTO295 280 IF(IX0.EQ.0)GOTO285 WRITE(ICOUT,249) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,282) CALL DPWRST('XXX','BUG ') GOTO950 285 IX1=IX1+1 GOTO295 295 CONTINUE C C COMPUTE POISSON PROBABILITIES FOR THE C DERIVED LOWER AND UPPER BOUNDS. C X0=IX0 X1=IX1 CALL POICDF(X0,ALAMBA,P0) CALL POICDF(X1,ALAMBA,P1) C C CHECK THE PROBABILITIES FOR PROPER ORDERING C IF(P0.LT.P.AND.P.LE.P1)GOTO490 IF(P0.EQ.P)GOTO410 IF(P1.EQ.P)GOTO420 IF(P0.GT.P1)GOTO430 IF(P0.GT.P)GOTO440 IF(P1.LT.P)GOTO450 WRITE(ICOUT,249) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,401) CALL DPWRST('XXX','BUG ') GOTO950 410 PPF=IX0 RETURN 420 PPF=IX1 RETURN 430 WRITE(ICOUT,249) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,431) CALL DPWRST('XXX','BUG ') GOTO950 440 WRITE(ICOUT,249) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,441) CALL DPWRST('XXX','BUG ') GOTO950 450 WRITE(ICOUT,249) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,451) CALL DPWRST('XXX','BUG ') GOTO950 490 CONTINUE C C THE STOPPING CRITERION IS THAT THE LOWER BOUND C AND UPPER BOUND ARE EXACTLY 1 UNIT APART. C CHECK TO SEE IF IX1 = IX0 + 1; C IF SO, THE ITERATIONS ARE COMPLETE; C IF NOT, THEN BISECT, COMPUTE PROBABILIIES, C CHECK PROBABILITIES, AND CONTINUE ITERATING C UNTIL IX1 = IX0 + 1. C 300 IX0P1=IX0+1 IF(IX1.EQ.IX0P1)GOTO690 IX2=(IX0+IX1)/2 IF(IX2.EQ.IX0)GOTO610 IF(IX2.EQ.IX1)GOTO620 X2=IX2 CALL POICDF(X2,ALAMBA,P2) IF(P0.LT.P2.AND.P2.LT.P1)GOTO630 IF(P2.LE.P0)GOTO640 IF(P2.GE.P1)GOTO650 610 WRITE(ICOUT,249) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,611) CALL DPWRST('XXX','BUG ') GOTO950 620 WRITE(ICOUT,249) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,611) CALL DPWRST('XXX','BUG ') GOTO950 630 IF(P2.LE.P)GOTO635 IX1=IX2 P1=P2 GOTO300 635 IX0=IX2 P0=P2 GOTO300 640 WRITE(ICOUT,249) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,641) CALL DPWRST('XXX','BUG ') GOTO950 650 WRITE(ICOUT,249) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,651) CALL DPWRST('XXX','BUG ') GOTO950 690 PPF=IX1 IF(P0.EQ.P)PPF=IX0 RETURN C 950 WRITE(ICOUT,240)IX0,P0 CALL DPWRST('XXX','BUG ') WRITE(ICOUT,241)IX1,P1 CALL DPWRST('XXX','BUG ') WRITE(ICOUT,242)IX2,P2 CALL DPWRST('XXX','BUG ') WRITE(ICOUT,244)P CALL DPWRST('XXX','BUG ') WRITE(ICOUT,245)ALAMBA CALL DPWRST('XXX','BUG ') RETURN C 222 FORMAT(43HNO UPPER BOUND FOUND AFTER 10**7 ITERATIONS) 240 FORMAT(9HIX0 = ,I8,10X,5HP0 = ,F14.7) 241 FORMAT(9HIX1 = ,I8,10X,5HP1 = ,F14.7) 242 FORMAT(9HIX2 = ,I8,10X,5HP2 = ,F14.7) 244 FORMAT(9HP = ,F14.7) 245 FORMAT(9HALAMBA = ,F14.7) 249 FORMAT('***** INTERNAL ERROR IN POIPPF SUBROUTINE *****') 262 FORMAT(43HNO LOWER BOUND FOUND AFTER 10**7 ITERATIONS) 282 FORMAT(31HLOWER AND UPPER BOUND IDENTICAL) 401 FORMAT(39HIMPOSSIBLE BRANCH CONDITION ENCOUNTERED) 431 FORMAT(42HLOWER BOUND PROBABILITY (P0) GREATER THAN , 1 28HUPPER BOUND PROBABILITY (P1)) 441 FORMAT(42HLOWER BOUND PROBABILITY (P0) GREATER THAN , 1 21HINPUT PROBABILITY (P)) 451 FORMAT(42HUPPER BOUND PROBABILITY (P1) LESS THAN , 1 21HINPUT PROBABILITY (P)) 611 FORMAT(39HBISECTION VALUE (X2) = LOWER BOUND (X0)) 621 FORMAT(39HBISECTION VALUE (X2) = UPPER BOUND (X1)) 641 FORMAT(33HBISECTION VALUE PROBABILITY (P2) , 1 38HLESS THAN LOWER BOUND PROBABILITY (P0)) 651 FORMAT(33HBISECTION VALUE PROBABILITY (P2) , 1 41HGREATER THAN UPPER BOUND PROBABILITY (P1)) C END SUBROUTINE POIRAN(N,ALAMBA,ISEED,X) C C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N C FROM THE POISSON DISTRIBUTION C WITH SINGLE PRECISION C TAIL LENGTH PARAMETER = ALAMBA. C THE POISSON DISTRIBUTION USED C HEREIN HAS MEAN = ALAMBA C AND STANDARD DEVIATION = SQRT(ALAMBA). C THIS DISTRIBUTION IS DEFINED FOR C ALL DISCRETE NON-NEGATIVE INTEGER X--X = 0, 1, 2, ... . C THIS DISTRIBUTION HAS THE PROBABILITY FUNCTION C F(X) = EXP(-ALAMBA) * ALAMBA**X / X!. C THE POISSON DISTRIBUTION IS THE C DISTRIBUTION OF THE NUMBER OF EVENTS C IN THE INTERVAL (0,ALAMBA) WHEN C THE WAITING TIME BETWEEN EVENTS C IS EXPONENTIALLY DISTRIBUTED C WITH MEAN = 1 AND STANDARD DEVIATION = 1. C INPUT ARGUMENTS--N = THE DESIRED INTEGER NUMBER C OF RANDOM NUMBERS TO BE C GENERATED. C --ALAMBA = THE SINGLE PRECISION VALUE C OF THE TAIL LENGTH PARAMETER. C ALAMBA SHOULD BE POSITIVE. C OUTPUT ARGUMENTS--X = A SINGLE PRECISION VECTOR C (OF DIMENSION AT LEAST N) C INTO WHICH THE GENERATED C RANDOM SAMPLE WILL BE PLACED. C OUTPUT--A RANDOM SAMPLE OF SIZE N C FROM THE POISSON DISTRIBUTION C WITH TAIL LENGTH PARAMETER = ALAMBA. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C --ALAMBA SHOULD BE POSITIVE. C OTHER DATAPAC SUBROUTINES NEEDED--UNIRAN. C FORTRAN LIBRARY SUBROUTINES NEEDED--ALOG. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C COMMENT--THE SINGLE PRECISION TAIL LENGTH C PARAMETER ALAMBA IS NOT RESTRICTED C TO ONLY INTEGER VALUES. C ALAMBA CAN BE SET TO ANY POSITIVE REAL C VALUE--INTEGER OR NON-INTEGER. C COMMENT--NOTE THAT EVEN THOUGH THE OUTPUT C FROM THIS DISCRETE RANDOM NUMBER C GENERATOR MUST NECESSARILY BE A C SEQUENCE OF ***INTEGER*** VALUES, C THE OUTPUT VECTOR X IS SINGLE C PRECISION IN MODE. C X HAS BEEN SPECIFIED AS SINGLE C PRECISION SO AS TO CONFORM WITH THE DATAPAC C CONVENTION THAT ALL OUTPUT VECTORS FROM ALL C DATAPAC SUBROUTINES ARE SINGLE PRECISION. C THIS CONVENTION IS BASED ON THE BELIEF THAT C 1) A MIXTURE OF MODES (FLOATING POINT C VERSUS INTEGER) IS INCONSISTENT AND C AN UNNECESSARY COMPLICATION C IN A DATA ANALYSIS; AND C 2) FLOATING POINT MACHINE ARITHMETIC C (AS OPPOSED TO INTEGER ARITHMETIC) C IS THE MORE NATURAL MODE FOR DOING C DATA ANALYSIS. C REFERENCES--COX AND MILLER, THE THEORY OF STOCHASTIC C PROCESSES, 1965, PAGE 7. C --TOCHER, THE ART OF SIMULATION, C 1963, PAGES 36-37. C --JOHNSON AND KOTZ, DISCRETE C DISTRIBUTIONS, 1969, PAGES 87-121. C --HASTINGS AND PEACOCK, STATISTICAL C DISTRIBUTIONS--A HANDBOOK FOR C STUDENTS AND PRACTITIONERS, 1975, C PAGES 108-113. C --FELLER, AN INTRODUCTION TO PROBABILITY C THEORY AND ITS APPLICATIONS, VOLUME 1, C EDITION 2, 1957, PAGES 146-154. C --NATIONAL BUREAU OF STANDARDS APPLIED MATHEMATICS C SERIES 55, 1964, PAGE 929. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--82.6 C ORIGINAL VERSION--NOVEMBER 1975. C UPDATED --DECEMBER 1981. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DIMENSION X(*) C DIMENSION U(2) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(N.LT.1)GOTO50 IF(ALAMBA.LE.0.0)GOTO55 GOTO90 50 WRITE(ICOUT, 5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)N CALL DPWRST('XXX','BUG ') RETURN 55 WRITE(ICOUT,15) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)ALAMBA CALL DPWRST('XXX','BUG ') RETURN 90 CONTINUE 5 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ', 1'POIRAN SUBROUTINE IS NON-POSITIVE *****') 15 FORMAT('***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE ', 1'POIRAN SUBROUTINE IS NON-POSITIVE *****') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****') C C GENERATE N POISSON RANDOM NUMBERS C USING THE FACT THAT THE DISTRIBUTION C OF EXPONENTIAL WAITING TIMES IS POISSON. C DO100I=1,N SUM=0.0 J=1 150 CALL UNIRAN(1,ISEED,U) E=-ALOG(1.0-U(1)) SUM=SUM+E IF(SUM.GT.ALAMBA)GOTO250 J=J+1 GOTO150 250 X(I)=J-1 100 CONTINUE C RETURN END SUBROUTINE POISSF(ALAMB,EPS,L,NSPAN,V,NV,IFLAG) C C--- COMPUTE THE POISSON(ALAMB) PROBABILITIES OVER THE RANGE [L,K] C--- WHERE THE TOTAL TAIL PROBABILITY IS LESS THAN EPS/2, SUM THE C--- PROBABILITIES IN DOUBLE PRECISION, AND SHIFT THEM TO THE C--- BEGINNING OF VECTOR V. C DIMENSION V(*) DOUBLE PRECISION DAL,DK,DLIMIT,DSUM,DLNGAM DLIMIT = 1.0D0-0.5D0*DBLE(EPS) K = INT(ALAMB) L = K+1 IF (ALAMB.EQ.0.0) THEN PL = 1.0 ELSE DAL = DBLE(ALAMB) DK = DBLE(K) PL = REAL(DEXP(DK*DLOG(DAL)-DAL-DLNGAM(DBLE(K+1)))) ENDIF PK = ALAMB*PL/REAL(L) NK = NV/2 NL = NK+1 DSUM = 0.0 10 IF (PL.LT.PK) THEN NK = NK+1 IF (NK.GT.NV) THEN IFLAG = 6 RETURN ENDIF V(NK) = PK DSUM = DSUM+DBLE(PK) K = K+1 IF (DSUM.GE.DLIMIT) GO TO 20 PK = ALAMB*PK/REAL(K+1) ELSE NL = NL-1 V(NL) = PL DSUM = DSUM+DBLE(PL) L = L-1 IF (DSUM.GE.DLIMIT) GO TO 20 PL = REAL(L)*PL/ALAMB ENDIF GO TO 10 20 INC = NL-1 DO 30 I = NL, NK V(I-INC) = V(I) 30 CONTINUE NSPAN = NK-INC RETURN END SUBROUTINE POISST(ALAMB,EPS,L,NSPAN,V,NV,IFLAG) CCCCC CONVERT TO DOUBLE PRECISION. SINGLE PRECISION ON 32-BIT CCCCC MACHINES DOES NOT GIVE ACCURATE RESULTS. C C--- COMPUTE THE POISSON(ALAMB) PROBABILITIES OVER THE RANGE [L,K] C--- WHERE THE TOTAL TAIL PROBABILITY IS LESS THAN EPS/3, SUM THE C--- PROBABILITIES IN DOUBLE PRECISION, AND SHIFT THEM TO THE C--- BEGINNING OF VECTOR V. C IMPLICIT DOUBLE PRECISION (A-H,O-Z) C DIMENSION V(*) CCCCC DOUBLE PRECISION DAL,DK,DLIMIT,DSUM,DLNGAM C DLIMIT = 1.0D0-2.0D0*EPS/3.0D0 K = INT(ALAMB) L = K+1 IF (ALAMB.EQ.0.0D0) THEN PL = 1.0D0 ELSE DAL = ALAMB DK = DBLE(K) CCCCC PL = SNGL(DEXP(DK*DLOG(DAL)-DAL-DLNGAM(DBLE(K+1)))) PL = DEXP(DK*DLOG(DAL)-DAL-DLNGAM(DBLE(K+1))) ENDIF PK = ALAMB*PL/DBLE(L) NK = NV/2 NL = NK+1 DSUM = 0.0D0 10 IF (PL.LT.PK) THEN NK = NK+1 IF (NK.GT.NV) THEN IFLAG = 6 RETURN ENDIF V(NK) = PK DSUM = DSUM+PK K = K+1 IF (DSUM.GE.DLIMIT) GO TO 20 PK = ALAMB*PK/DBLE(K+1) ELSE NL = NL-1 IF (NL.LT.1) THEN IFLAG = 6 RETURN ENDIF V(NL) = PL DSUM = DSUM+PL L = L-1 IF (DSUM.GE.DLIMIT) GO TO 20 PL = DBLE(L)*PL/ALAMB ENDIF GO TO 10 20 INC = NL-1 DO 30 I = NL, NK V(I-INC) = V(I) 30 CONTINUE NSPAN = NK-INC RETURN END SUBROUTINE POLARI(Y1,Y2,Y3,Y4,N1,N3,IACASE,IWRITE, 1Y5,Y6,N5,N6,SCAL3,ITYP3, 1DTOP,DBOT,DMID, 1IBUGA3,ISUBRO,IERROR) C C PURPOSE--CARRY OUT POLYNOMIAL ARITHMETIC OPERATIONS C OF THE REAL DATA IN Y1 AND Y3. C C OPERATIONS--ADDITION C SUBTRACTION C MULTIPLICATION C DIVISION (FUTURE--NOT YET IMPLEMENTED) C SQUARE C SQUARE ROOT (FUTURE--NOT YET IMPLEMENTED) C GCD (GREATEST COMMON DIVISOR) (FUTURE--NOT YET IMPLEMENTED) C LCM (LEAST COMMON MULTIPLE) (FUTURE--NOT YET IMPLEMENTED) C EVALUATION C C INPUT ARGUMENTS--Y1 (REAL PART) Y2 (IMAGINARY PART) C --Y3 (REAL PART) Y4 (IMAGINARY PART) C OUTPUT ARGUMENTS--Y5 (REAL PART) Y6 (IMAGINARY PART) C C NOTE--IT IS NOT PERMISSIBLE TO HAVE THE OUTPUT VECTORS Y5(.) AND Y6(.) C BEING IDENTICAL TO THE INPUT VECTORS Y1(.) AND Y2(.), OR C Y3(.) AND Y4(.). C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--87/9 C ORIGINAL VERSION--AUGUST 1987. C UPDATED --JUNE 1990. TEMPORARY ARRAYS TO GARBAGE COMMON C UPDATED --JANUARY 2006. PASS DOUBLE PRECISION ARRAYS C FROM DPMATC C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IACASE CHARACTER*4 IWRITE CHARACTER*4 ITYP3 CHARACTER*4 IBUGA3 CHARACTER*4 ISUBRO CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C-----DOUBLE PRECISION STATEMENTS FOR NON-COMMON VARIABLES------------------- C DOUBLE PRECISION DY1 CCCCC DOUBLE PRECISION DY2 DOUBLE PRECISION DY3 CCCC DOUBLE PRECISION DY4 DOUBLE PRECISION DY5 CCCCC DOUBLE PRECISION DY6 DOUBLE PRECISION DSUM5 CCCCC DOUBLE PRECISION DSUM6 C DOUBLE PRECISION DTOP DOUBLE PRECISION DMID DOUBLE PRECISION DBOT DOUBLE PRECISION DRATIO C DOUBLE PRECISION DCUM DOUBLE PRECISION DX DOUBLE PRECISION DC C C--------------------------------------------------------------------- C INCLUDE 'DPCOPA.INC' C DIMENSION Y1(*) DIMENSION Y2(*) DIMENSION Y3(*) DIMENSION Y4(*) DIMENSION Y5(*) DIMENSION Y6(*) C DIMENSION DTOP(*) DIMENSION DMID(*) DIMENSION DBOT(*) CCCCC DIMENSION DTOP(MAXOBV) CCCCC DIMENSION DMID(MAXOBV) CCCCC DIMENSION DBOT(MAXOBV) CCCCC FOLLOWING LINES ADDED JUNE, 1990 CCCCC INCLUDE 'DPCOZD.INC' CCCCC EQUIVALENCE (DGARBG(IDGAR1),DTOP(1)) CCCCC EQUIVALENCE (DGARBG(IDGAR2),DMID(1)) CCCCC EQUIVALENCE (DGARBG(IDGAR3),DBOT(1)) CCCCC END CHANGE C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='POLA' ISUBN2='RI ' C IERROR='NO' C SCAL3=(-999.0) ITYP3='VECT' C IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'PARI')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF POLARI--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA3,ISUBRO,IACASE,IWRITE 52 FORMAT('IBUGA3,ISUBRO,IACASE,IWRITE = ',A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)N1,N3 53 FORMAT('N1,N3 = ',2I8) CALL DPWRST('XXX','BUG ') DO55I=1,N1 WRITE(ICOUT,56)I,Y1(I),Y2(I) 56 FORMAT('I,Y1(I),Y2(I) = ',I8,2E13.5) CALL DPWRST('XXX','BUG ') 55 CONTINUE DO65I=1,N3 WRITE(ICOUT,66)I,Y3(I),Y4(I) 66 FORMAT('I,Y3(I),Y4(I) = ',I8,2E13.5) CALL DPWRST('XXX','BUG ') 65 CONTINUE 90 CONTINUE C C ************************************************** C ** CARRY OUT POLYNOMIAL ARITHMETIC OPERATIONS ** C ************************************************** C C ******************************************** C ** STEP 11-- ** C ** CHECK NUMBER OF INPUT OBSERVATIONS. ** C ******************************************** C IF(N1.LT.1)GOTO1100 IF(IACASE.EQ.'POSQ')GOTO1190 IF(IACASE.EQ.'POSR')GOTO1190 IF(N3.LT.1)GOTO1100 GOTO1190 C 1100 CONTINUE IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1151) 1151 FORMAT('***** ERROR IN POLARI--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1152) 1152 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1153) 1153 FORMAT(' IN THE VARIABLE FOR WHICH') CALL DPWRST('XXX','BUG ') IF(IACASE.EQ.'POAD')WRITE(ICOUT,1161) 1161 FORMAT(' THE POLYNOMIAL ADDITION IS TO BE ', 1'COMPUTED') IF(IACASE.EQ.'POAD')CALL DPWRST('XXX','BUG ') IF(IACASE.EQ.'POSU')WRITE(ICOUT,1162) 1162 FORMAT(' THE POLYNOMIAL SUBTRACTION IS TO BE ', 1'COMPUTED') IF(IACASE.EQ.'POSU')CALL DPWRST('XXX','BUG ') IF(IACASE.EQ.'POMU')WRITE(ICOUT,1163) 1163 FORMAT(' THE POLYNOMIAL MULTIPLICATION IS TO BE ', 1'COMPUTED') IF(IACASE.EQ.'POMU')CALL DPWRST('XXX','BUG ') IF(IACASE.EQ.'PODI')WRITE(ICOUT,1164) 1164 FORMAT(' THE POLYNOMIAL DIVISION IS TO BE ', 1'COMPUTED') IF(IACASE.EQ.'PODI')CALL DPWRST('XXX','BUG ') IF(IACASE.EQ.'POSQ')WRITE(ICOUT,1165) 1165 FORMAT(' THE POLYNOMIAL SQUARE IS TO BE ', 1'COMPUTED') IF(IACASE.EQ.'POSQ')CALL DPWRST('XXX','BUG ') IF(IACASE.EQ.'POSR')WRITE(ICOUT,1166) 1166 FORMAT(' THE POLYNOMIAL SQUARE ROOT IS TO BE ', 1'COMPUTED') IF(IACASE.EQ.'POSR')CALL DPWRST('XXX','BUG ') IF(IACASE.EQ.'POGC')WRITE(ICOUT,1167) 1167 FORMAT(' THE POLYNOMIAL GCD IS TO BE ', 1'COMPUTED') IF(IACASE.EQ.'POGC')CALL DPWRST('XXX','BUG ') IF(IACASE.EQ.'POLC')WRITE(ICOUT,1168) 1168 FORMAT(' THE POLYNOMIAL LCM IS TO BE ', 1'COMPUTED') IF(IACASE.EQ.'POLC')CALL DPWRST('XXX','BUG ') IF(IACASE.EQ.'POEV')WRITE(ICOUT,1169) 1169 FORMAT(' THE POLYNOMIAL EVALUATION IS TO BE ', 1'COMPUTED') IF(IACASE.EQ.'POEV')CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1181) 1181 FORMAT(' MUST BE 1 OR LARGER.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1182) 1182 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1183)N1,N3 1183 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS HERE = ',2I8, 1'.') CALL DPWRST('XXX','BUG ') GOTO9000 C 1190 CONTINUE C C ********************************* C ** STEP 12-- ** C ** BRANCH TO THE PROPER CASE ** C ********************************* C IF(IACASE.EQ.'POAD')GOTO2100 IF(IACASE.EQ.'POSU')GOTO2200 IF(IACASE.EQ.'POMU')GOTO2300 IF(IACASE.EQ.'PODI')GOTO2400 IF(IACASE.EQ.'POSQ')GOTO2500 IF(IACASE.EQ.'POSR')GOTO2600 IF(IACASE.EQ.'POGC')GOTO2700 IF(IACASE.EQ.'POLC')GOTO2800 IF(IACASE.EQ.'POEV')GOTO2900 C WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1211) 1211 FORMAT('***** INTERNAL ERROR IN POLARI--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1212) 1212 FORMAT(' IACASE NOT EQUAL TO') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1213) 1213 FORMAT(' POAD, POSU, POMU, PODI, ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1214) 1214 FORMAT(' POSQ, POSR, POGC, POLC, OR POEV') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1215) 1215 FORMAT(' IACASE = ',A4) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C C ********************************************* C ** STEP 21-- ** C ** TREAT THE POLYNOMIAL ADDITION CASE ** C ********************************************* C 2100 CONTINUE N13MAX=N1 IF(N3.GT.N1)N13MAX=N3 DO2110I=1,N13MAX DY1=0.0D0 CCCCC DY2=0.0D0 DY3=0.0D0 CCCCC DY4=0.0D0 IF(I.LE.N1)DY1=Y1(I) CCCCC IF(I.LE.N1)DY2=Y2(I) IF(I.LE.N3)DY3=Y3(I) CCCCC IF(I.LE.N3)DY4=Y4(I) DY5=DY1+DY3 CCCCC DY6=DY2+DY4 Y5(I)=DY5 CCCCC Y6(I)=DY6 2110 CONTINUE C ITYP3='VECT' N5=N13MAX N6=N5 GOTO9000 C C ********************************************* C ** STEP 22-- ** C ** TREAT THE POLYNOMIAL SUBTRACTION CASE ** C ********************************************* C 2200 CONTINUE N13MAX=N1 IF(N3.GT.N1)N13MAX=N3 DO2210I=1,N13MAX DY1=0.0D0 CCCCC DY2=0.0D0 DY3=0.0D0 CCCCC DY4=0.0D0 IF(I.LE.N1)DY1=Y1(I) CCCCC IF(I.LE.N1)DY2=Y2(I) IF(I.LE.N3)DY3=Y3(I) CCCCC IF(I.LE.N3)DY4=Y4(I) DY5=DY1-DY3 CCCCC DY6=DY2-DY4 Y5(I)=DY5 CCCCC Y6(I)=DY6 2210 CONTINUE C ITYP3='VECT' N5=N13MAX N6=N5 GOTO9000 C C ************************************************ C ** STEP 23-- ** C ** TREAT THE POLYNOMIAL MULTIPLICATION CASE ** C ************************************************ C 2300 CONTINUE N1PN3M=N1+N3-1 DO2310I=1,N1PN3M DSUM5=0.0D0 CCCCC DSUM6=0.0D0 DO2320J=1,N1 K=I-J+1 IF(K.LT.1.OR.K.GT.N3)GOTO2320 DY1=Y1(J) CCCCC DY2=Y2(J) DY3=Y3(K) CCCCC DY4=Y4(K) CCCCC DY5=DY1*DY3-DY2*DY4 DY5=DY1*DY3 CCCCC DY6=DY1*DY4+DY2*DY3 DSUM5=DSUM5+DY5 CCCCC DSUM6=DSUM6+DY6 2320 CONTINUE Y5(I)=DSUM5 CCCCC Y6(I)=DSUM6 2310 CONTINUE C ITYP3='VECT' N5=N1PN3M N6=N5 GOTO9000 C C ************************************************ C ** STEP 24-- ** C ** TREAT THE POLYNOMIAL DIVISION CASE ** C ************************************************ C 2400 CONTINUE C DO2410I=1,N1 DBOT(I)=Y1(I) 2410 CONTINUE C NLOOP=N1-N3+1 NTOP=N1+1 IF(NLOOP.LE.0)GOTO2455 DO2420ILOOP=1,NLOOP NTOP=NTOP-1 C DO2430I=1,NTOP DTOP(I)=DBOT(I) DMID(I)=0.0D0 2430 CONTINUE C IDEL=NTOP-N3 DO2440I=1,N3 J=I+IDEL DMID(J)=Y3(I) 2440 CONTINUE C DRATIO=DTOP(NTOP)/DMID(NTOP) ILOOPR=NLOOP-ILOOP+1 Y5(ILOOPR)=DRATIO C DO2450I=1,NTOP DMID(I)=DMID(I)*DRATIO DBOT(I)=DTOP(I)-DMID(I) 2450 CONTINUE C 2420 CONTINUE N5=NLOOP C 2455 CONTINUE NTOP=NTOP-1 DO2460I=1,NTOP Y6(I)=DBOT(I) 2460 CONTINUE N6=NTOP C IF(NLOOP.GE.1)GOTO2479 DO2470I=1,N6 Y5(I)=0.0 2470 CONTINUE N5=N6 2479 CONTINUE C ITYP3='VECT' GOTO9000 C C *************************************************** C ** STEP 25-- ** C ** TREAT THE POLYNOMIAL SQUARE (SQUARING) CASE ** C *************************************************** C 2500 CONTINUE N1PN1M=N1+N1-1 DO2510I=1,N1PN1M DSUM5=0.0D0 CCCCC DSUM6=0.0D0 DO2520J=1,N1 K=I-J+1 IF(K.LT.1.OR.K.GT.N1)GOTO2520 DY1=Y1(J) CCCCC DY2=Y2(J) DY3=Y1(K) CCCCC DY4=Y2(K) CCCCC DY5=DY1*DY3-DY2*DY4 DY5=DY1*DY3 CCCCC DY6=DY1*DY4+DY2*DY3 DSUM5=DSUM5+DY5 CCCCC DSUM6=DSUM6+DY6 2520 CONTINUE Y5(I)=DSUM5 CCCCC Y6(I)=DSUM6 2510 CONTINUE C ITYP3='VECT' N5=N1PN1M N6=N5 GOTO9000 C C ************************************************ C ** STEP 26-- ** C ** TREAT THE POLYNOMIAL SQUARE ROOT CASE ** C ************************************************ C 2600 CONTINUE C C NOTE YET DONE C GOTO9000 C C ********************************************************* C ** STEP 27-- ** C ** TREAT THE POLYNOMIAL GREATEST COMMON DIVISOR CASE ** C ********************************************************* C 2700 CONTINUE C C NOTE YET DONE C GOTO9000 C C ******************************************************* C ** STEP 28-- ** C ** TREAT THE POLYNOMIAL LEAST COMMON MULTIPLE CASE ** C ******************************************************* C 2800 CONTINUE C C NOTE YET DONE C GOTO9000 C C ********************************************* C ** STEP 29-- ** C ** TREAT THE POLYNOMIAL EVALUATION CASE ** C ********************************************* C 2900 CONTINUE N1M1=N1-1 DO2910I=1,N3 DX=Y3(I) DCUM=Y1(N1) IF(N1M1.LE.0)GOTO2925 DO2920J=1,N1M1 JREV=N1-J+1 JREVM=JREV-1 DC=Y1(JREVM) DCUM=DX*DCUM+DC 2920 CONTINUE 2925 CONTINUE Y5(I)=DCUM 2910 CONTINUE C ITYP3='VECT' N5=N3 N6=N5 GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE C IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'PARI')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF POLARI--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGA3,ISUBRO,IACASE,IWRITE 9012 FORMAT('IBUGA3,ISUBRO,IACASE,IWRITE = ',A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)IERROR 9013 FORMAT('IERROR = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9017)N1,N3,N5,N6 9017 FORMAT('N1,N3,N5,N6 = ',4I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9018)SCAL3,ITYP3 9018 FORMAT('SCAL3,ITYP3 = ',E15.7,2X,A4) CALL DPWRST('XXX','BUG ') IF(ITYP3.EQ.'SCAL')GOTO9090 DO9021I=1,N1 WRITE(ICOUT,9022)I,Y1(I),Y2(I) 9022 FORMAT('I,Y1(I),Y2(I) = ',I8,2E13.5) CALL DPWRST('XXX','BUG ') 9021 CONTINUE DO9031I=1,N3 WRITE(ICOUT,9032)I,Y3(I),Y4(I) 9032 FORMAT('I,Y3(I),Y4(I) = ',I8,2E13.5) CALL DPWRST('XXX','BUG ') 9031 CONTINUE DO9041I=1,N5 WRITE(ICOUT,9042)I,Y5(I),Y6(I) 9042 FORMAT('I,Y5(I),Y6(I) = ',I8,2E13.5) CALL DPWRST('XXX','BUG ') 9041 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE POLCDF(X,V,W,N,CDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY C FUNCTION VALUE AT THE SINGLE PRECISION VALUE X C FOR THE POLYA DISTRIBUTION C WITH SINGLE PRECISION PARAMETERS V AND W C AND INTEGER 'NUMBER OF BERNOULLI TRIALS' C PARAMETER = N. C THIS DISTRIBUTION HAS THE PROBABILITY FUNCTION C P(X) = (N X)*B(X+V,N+X+W)/B(V,W) C WITH B(.,.) DENOTING THE BETA FUNCTION AND (N X) C DENOTING THE BINOMIAL COEFFICIENT. C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE C AT WHICH THE CUMULATIVE DISTRIBUTION C FUNCTION IS TO BE EVALUATED. C X SHOULD BE INTEGRAL-VALUED, C AND BETWEEN 0.0 (INCLUSIVELY) C AND N (INCLUSIVELY). C --V = THE SINGLE PRECISION VALUE C OF THE FIRST SHAPE PARAMETER. C --W = THE SINGLE PRECISION VALUE C OF THE SECOND SHAPE PARAMETER. C --N = THE INTEGER VALUE C OF THE 'NUMBER OF BERNOULLI TRIALS' C PARAMETER. C N SHOULD BE A POSITIVE INTEGER. C OUTPUT ARGUMENTS--CDF = THE SINGLE PRECISION CUMULATIVE C DISTRIBUTION FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION C FUNCTION VALUE CDF C FOR THE BINOMIAL DISTRIBUTION C WITH 'BERNOULLI PROBABILITY' PARAMETER = P C AND 'NUMBER OF BERNOULLI TRIALS' PARAMETER = N. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--X SHOULD BE INTEGRAL-VALUED, C AND BETWEEN 0.0 (INCLUSIVELY) C AND N (INCLUSIVELY). C --V AND W SHOULD BOTH BE POSITIVE. C --N SHOULD BE A POSITIVE INTEGER. C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--DBINOM, DLBETA C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--EVANS, HASTINGS AND PEACOCK, STATISTICAL C DISTRIBUTIONS--THIRD ED., CHAPTER 5 C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2004/3 C ORIGINAL VERSION--MARCH 2004. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DX, DV, DW, DN, DCDF DOUBLE PRECISION DTERM1, DTERM2, DTERM4 DOUBLE PRECISION DLBETA, DBINOM DOUBLE PRECISION DSUM1, DSUM2 C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C CDF=0.0 C C CHECK THE INPUT ARGUMENTS FOR ERRORS C AN=N IF(V.LE.0.0)THEN WRITE(ICOUT,11) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)V CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9999 ENDIF IF(W.LE.0.0)THEN WRITE(ICOUT,12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)V CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9999 ENDIF IF(N.LE.0)THEN WRITE(ICOUT,25) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)N CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9999 ENDIF INTX=X+0.0001 FINTX=INTX DEL=X-FINTX IF(DEL.LT.0.0)DEL=-DEL IF(DEL.GT.0.001)THEN WRITE(ICOUT,5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,6)INT(FINTX) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') ENDIF IF(FINTX.LT.0.0 .OR. FINTX.GT.AN)THEN WRITE(ICOUT,4)N CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF C 4 FORMAT('***** FATAL ERROR--THE FIRST INPUT ', 1'ARGUMENT TO THE POLCDF SUBROUTINE IS OUTSIDE THE USUAL ', 1'(0,N) = (0,',I8,') INTERVAL') 5 FORMAT('***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ', 1'ARGUMENT TO THE POLCDF SUBROUTINE IS NON-INTEGRAL *****') 6 FORMAT(' IT HAS BEEN SET TO ',I8) 11 FORMAT('***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE ', 1' POLCDF SUBROUTINE IS NON-POSITIVE') 12 FORMAT('***** FATAL ERROR--THE THIRD INPUT ARGUMENT TO THE ', 1' POLCDF SUBROUTINE IS NON-POSITIVE') 25 FORMAT('***** FATAL ERROR--THE FOURTH INPUT ARGUMENT TO THE ', 1' POLCDF SUBROUTINE IS NON-POSITIVE *****') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****') C DV=DBLE(V) DW=DBLE(W) DN=DBLE(N) DSUM1=0.0D0 DSUM2=0.0D0 C DMEAN=DN*DW/(DV+DW) ICUT=INT(DMEAN)+1 C C SUM TERMS UP TO AND INCLUDING MEAN C DO1000I=0,MIN(ICUT,INTX),1 DX=DBLE(I) DTERM1=DLOG(DBINOM(N,I)) DTERM2=DLBETA(DX+DV,DN+DW-DX) DTERM4=DLBETA(DV,DW) DCDF=DEXP(DTERM1 + DTERM2 - DTERM4) DSUM1=DSUM1+DCDF 1000 CONTINUE C C SUM TERMS FROM X DOWN TO MEAN MEAN C IF(INTX.GT.ICUT)THEN DO2000I=INTX,ICUT+1,-1 DX=DBLE(I) DTERM1=DLOG(DBINOM(N,I)) DTERM2=DLBETA(DX+DV,DN+DW-DX) DTERM4=DLBETA(DV,DW) DCDF=DEXP(DTERM1 + DTERM2 - DTERM4) DSUM2=DSUM2+DCDF 2000 CONTINUE ENDIF DCDF=DSUM1+DSUM2 CDF=REAL(DCDF) 101 FORMAT('****** FATAL ERROR--OVERFLOW IN POLCDF ROUTINE.') C 9999 CONTINUE RETURN END SUBROUTINE POLPDF(X,W,B,C,N,PDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY C FUNCTION VALUE AT THE SINGLE PRECISION VALUE X C FOR THE POLYA DISTRIBUTION C WITH SINGLE PRECISION PARAMETERS W, B, AND C C AND INTEGER PARAMETER N. C THIS DISTRIBUTION IS DEFINED FOR ALL C DISCRETE INTEGER X BETWEEN 0 (INCLUSIVELY) C AND N (INCLUSIVELY). C THIS DISTRIBUTION HAS THE PROBABILITY FUNCTION C P(X) = (N X)*B(X+ALPHA,N+X+BETA)/B(ALPHA,BETA) C X = 0, 1, 2, ..., N. C WITH ALPHA = W/C AND BETA = B/C, C B(.,.) DENOTING THE BETA FUNCTION, AND (N X) C DENOTING THE BINOMIAL COEFFICIENT. C THIS FORM OF THE OF THE PDF IS ONLY USEFUL FOR C ALPHA AND BETA POSITIVE. C AN ALTERNATIVE FORM THAT CAN BE USED FOR NEGATIVE C VALUES FOR W, B, AND C IS: C P(X) = (-W/C X)*(-B/C N-X)/(-(W+B)/C N) C FOR NEGATIVE VALUES OF W, B, AND C, USE THE C FORMULA: C (-N R) = (-1)**R*(N+R-1 R) C NOTE THAT IF C = 0, THEN POLYA DEGENERATES TO C BINOMIAL WITH P = W/(W+B) AND N. C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE C AT WHICH THE PROBABILITY DENSITY C FUNCTION IS TO BE EVALUATED. C X SHOULD BE INTEGRAL-VALUED, C AND BETWEEN 0.0 (INCLUSIVELY) C AND N (INCLUSIVELY). C --W = THE SINGLE PRECISION VALUE C OF THE FIRST SHAPE PARAMETER. C --B = THE SINGLE PRECISION VALUE C OF THE SECOND SHAPE PARAMETER. C --C = THE SINGLE PRECISION VALUE C OF THE THURD SHAPE PARAMETER. C --N = THE INTEGER VALUE C OF THE 'NUMBER OF BERNOULLI TRIALS' C PARAMETER. C N SHOULD BE A POSITIVE INTEGER. C OUTPUT ARGUMENTS--PDF = THE SINGLE PRECISION PROBABILITY C DENSITY FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY C FUNCTION VALUE PDF FOR THE POLYA DISTRIBUTION C WITH SHAPE PARAMETERS W, B, C, AD N. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--X SHOULD BE INTEGRAL-VALUED, C AND BETWEEN 0.0 (INCLUSIVELY) C AND N (INCLUSIVELY). C --N SHOULD BE A POSITIVE INTEGER. C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--DLBETA, DBINOM, DLNGAM C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--JOHNSON, KOTZ, AND KEMP, "UNIVARIATE DISCRETE C DISTRIBUTIONS--SECOND EDITION, WILEY, 1992, C PP. 244-249. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--2004/4 C ORIGINAL VERSION--APRIL 2004. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C REAL W REAL B REAL C REAL ALPHA REAL BETA REAL P DOUBLE PRECISION DX, DV, DW, DN, DPDF DOUBLE PRECISION DA, DR, DWC, DBC, DWBC DOUBLE PRECISION DCONST DOUBLE PRECISION D1, D2, D3 DOUBLE PRECISION DTERM1, DTERM2, DTERM3, DTERM4 DOUBLE PRECISION DLBETA, DBINOM DOUBLE PRECISION DLNGAM C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C PDF=0.0 C C CHECK THE INPUT ARGUMENTS FOR ERRORS C AN=N ALPHA=W/C BETA=B/C P=W/(W+B) print *,'n,w,b,c,p=',n,w,b,c,p CCCCC IF(V.LE.0.0)THEN CCCCC WRITE(ICOUT,11) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,46)V CCCCC CALL DPWRST('XXX','BUG ') CCCCC PDF=0.0 CCCCC GOTO9999 CCCCC ENDIF CCCCC IF(W.LE.0.0)THEN CCCCC WRITE(ICOUT,12) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,46)V CCCCC CALL DPWRST('XXX','BUG ') CCCCC PDF=0.0 CCCCC GOTO9999 CCCCC ENDIF IF(N.LE.0)THEN WRITE(ICOUT,25) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)N CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ENDIF INTX=X+0.0001 FINTX=INTX DEL=X-FINTX IF(DEL.LT.0.0)DEL=-DEL IF(DEL.GT.0.001)THEN WRITE(ICOUT,5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,6)INT(FINTX) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') ENDIF IF(FINTX.LT.0.0 .OR. FINTX.GT.AN)THEN WRITE(ICOUT,4)N CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF C 4 FORMAT('***** ERROR--THE FIRST INPUT ', 1'ARGUMENT TO THE POLPDF SUBROUTINE IS OUTSIDE THE USUAL ', 1'(0,N) = (0,',I8,') INTERVAL') 5 FORMAT('***** WARNING--THE FIRST INPUT ', 1'ARGUMENT TO THE POLPDF SUBROUTINE IS NON-INTEGRAL *****') 6 FORMAT(' IT HAS BEEN SET TO ',I8) CCC11 FORMAT('***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE ', CCCCC1' POLPDF SUBROUTINE IS NON-POSITIVE') CCC12 FORMAT('***** FATAL ERROR--THE THIRD INPUT ARGUMENT TO THE ', CCCCC1' POLPDF SUBROUTINE IS NON-POSITIVE') 25 FORMAT('***** ERROR--THE FIFTH INPUT ARGUMENT TO THE ', 1' POLPDF SUBROUTINE IS NON-POSITIVE *****') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****') C C IF(C.EQ.0.0)THEN C C CASE 1: C = 0 DEGENERATES TO A BINOMIAL DISTRIBUTION C print *,'p=',p CALL BINCDF(X,P,N,CDF1) IF(X.LE.0.1)THEN PDF=CDF1 ELSE ARG1=X-1.0 CALL BINCDF(ARG1,P,N,CDF2) PDF=CDF1-CDF2 ENDIF ELSEIF(ALPHA.GT.0.0 .AND. BETA.GT.0)THEN C C CASE 2: W/C AND B/C BOTH POSITIVE, USE DEFINITION BASED ON C BETA FUNCTIONS (THIS CASE IS EQUIVALENT TO C BETA-BINOMIAL WITH ALPHA AND BETA ARGUMENTS REVERSED). C print *,'alpha, beta = ',alpha,beta DX=DBLE(FINTX) DV=DBLE(ALPHA) DW=DBLE(BETA) DN=DBLE(N) DTERM1=DLOG(DBINOM(N,INTX)) DTERM2=DLBETA(DX+DV,DN+DW-DX) DTERM4=DLBETA(DV,DW) DPDF=DTERM1 + DTERM2 - DTERM4 IF(DPDF.LE.-80.D0)THEN PDF=0.0 ELSEIF(DPDF.GT.80.D0)THEN WRITE(ICOUT,101) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') PDF=0.0 ELSE DPDF=DEXP(DPDF) PDF=SNGL(DPDF) ENDIF ELSE C C CASE 3: W/C OR B/C OR BOTH ARE NEGATIVE. USE DEFINTION BASED C ON BINOMIAL COEFFICIENT WHERE SOME OF THE TERMS MAY C HAVE NEGATIVE ARGUMENTS FOR TOP COEFFICIENT. C C (-N R) = (-1)**R*(N+R-1 R) C = (-1)**R*(N+R-1)!/[R!*(N+R-1-R)!] C = (-1)**R*(N+R-1)!/[R!*(N-1)!] C = (-1)**R*GAMMA(N+R)/[GAMMA(R+1)*GAMMA(N)] C C IF TERM IS POSITIVE, USE C (N R) = N!/(R!*(N-R)!) C = GAMMA(N+1)/[GAMMA(R+1)*GAMMA(N-R+1)] C USE LOG GAMMA FUNCTION FOR BETTER NUMERICAL STABILITY C print *,'w,b,c=',w,b,c DX=DBLE(FINTX) DWC=DBLE(W)/DBLE(C) DBC=DBLE(B)/DBLE(C) DWBC=DBLE(W+B)/DBLE(C) DN=DBLE(N) C C FIRST TERM: (-DWC X) C DA=-DWC DR=DX IF(DA.GE.0.0)THEN D1=DLNGAM(DA+1.0D0) D2=DLNGAM(DR+1.0) D3=DLNGAM(DA-DR+1.0) DTERM1=DEXP(D1 - D2 - D3) ELSE DCONST=(-1.0D0)**INT(DR+0.01) DA=DABS(DA) D1=DLNGAM(DA+DR) D2=DLNGAM(DR+1) D3=DLNGAM(DA) DTERM1=DCONST*DEXP(D1 - D2 - D3) ENDIF C C SECOND TERM: (-DBC N-X) C DA=-DBC DR=DN-DX IF(DA.GE.0.0)THEN D1=DLNGAM(DA+1.0D0) D2=DLNGAM(DR+1.0) D3=DLNGAM(DA-DR+1.0) DTERM2=DEXP(D1 - D2 - D3) ELSE DCONST=(-1.0D0)**INT(DR+0.01) DA=DABS(DA) D1=DLNGAM(DA+DR) D2=DLNGAM(DR+1) D3=DLNGAM(DA) DTERM2=DCONST*DEXP(D1 - D2 - D3) ENDIF C C THIRD TERM: (-(W+B)/C N) C DA=-DWBC DR=DN IF(DA.GE.0.0)THEN D1=DLNGAM(DA+1.0D0) D2=DLNGAM(DR+1.0) D3=DLNGAM(DA-DR+1.0) DTERM3=DEXP(D1 - D2 - D3) ELSE DCONST=(-1.0D0)**INT(DR+0.01) DA=DABS(DA) D1=DLNGAM(DA+DR) D2=DLNGAM(DR+1) D3=DLNGAM(DA) DTERM3=DCONST*DEXP(D1 - D2 - D3) ENDIF DPDF=(DTERM1*DTERM2)/DTERM3 PDF=REAL(DPDF) ENDIF 101 FORMAT('****** FATAL ERROR--OVERFLOW IN POLPDF ROUTINE.') C 9999 CONTINUE RETURN END SUBROUTINE POLPPF(P,V,W,N,PPF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT C FUNCTION VALUE AT THE SINGLE PRECISION VALUE P C FOR THE POLYA DISTRIBUTION C WITH SINGLE PRECISION PARAMETERS V AND W C AND INTEGER 'NUMBER OF BERNOULLI TRIALS' C PARAMETER = N. C THIS DISTRIBUTION HAS THE PROBABILITY FUNCTION C P(X) = (N X)*B(X+V,N+X+W)/B(V,W) C WITH B(.,.) DENOTING THE BETA FUNCTION AND (N X) C DENOTING THE BINOMIAL COEFFICIENT. C INPUT ARGUMENTS--P = THE SINGLE PRECISION VALUE C (BETWEEN 0.0 (INCLUSIVELY) C AND 1.0 (INCLUSIVELY)) C AT WHICH THE PERCENT POINT C FUNCTION IS TO BE EVALUATED. C --V = THE SINGLE PRECISION VALUE C OF THE FIRST SHAPE PARAMETER. C --W = THE SINGLE PRECISION VALUE C OF THE SECOND SHAPE PARAMETER. C --N = THE INTEGER VALUE C OF THE 'NUMBER OF BERNOULLI TRIALS' C PARAMETER. C N SHOULD BE A POSITIVE INTEGER. C OUTPUT ARGUMENTS--PPF = THE SINGLE PRECISION PERCENT C POINT FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION PERCENT POINT . C FUNCTION VALUE PPF C FOR THE POLYA DISTRIBUTION C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--N SHOULD BE A POSITIVE INTEGER. C --P SHOULD BE BETWEEN 0.0 (INCLUSIVELY) C AND 1.0 (INCLUSIVELY). C OTHER DATAPAC SUBROUTINES NEEDED--BBNCDF C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION AND DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C COMMENT--NOTE THAT EVEN THOUGH THE OUTPUT C FROM THIS DISCRETE DISTRIBUTION C PERCENT POINT FUNCTION C SUBROUTINE MUST NECESSARILY BE A C DISCRETE INTEGER VALUE, C THE OUTPUT VARIABLE PPF IS SINGLE C PRECISION IN MODE. C PPF HAS BEEN SPECIFIED AS SINGLE C PRECISION SO AS TO CONFORM WITH THE DATAPAC C CONVENTION THAT ALL OUTPUT VARIABLES FROM ALL C DATAPAC SUBROUTINES ARE SINGLE PRECISION. C THIS CONVENTION IS BASED ON THE BELIEF THAT C 1) A MIXTURE OF MODES (FLOATING POINT C VERSUS INTEGER) IS INCONSISTENT AND C AN UNNECESSARY COMPLICATION C IN A DATA ANALYSIS; AND C 2) FLOATING POINT MACHINE ARITHMETIC C (AS OPPOSED TO INTEGER ARITHMETIC) C IS THE MORE NATURAL MODE FOR DOING C DATA ANALYSIS. C REFERENCES--EVANS, HASTINGS AND PEACOCK, STATISTICAL C DISTRIBUTIONS--THIRD ED., CHAPTER 5 C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2004/3 C ORIGINAL VERSION--MARCH 2004. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DX, DV, DW, DN, DCDF DOUBLE PRECISION DTERM1, DTERM2, DTERM3, DTERM4 DOUBLE PRECISION DLBETA, DBINOM DOUBLE PRECISION DSUM1 DOUBLE PRECISION DP C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(P.LT.0.0.OR.P.GT.1.0)THEN WRITE(ICOUT,1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)P CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9999 ENDIF IF(V.LE.0.0)THEN WRITE(ICOUT,11) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)V CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ENDIF IF(W.LE.0.0)THEN WRITE(ICOUT,12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)V CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ENDIF IF(N.LE.0)THEN WRITE(ICOUT,25) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)N CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ENDIF 1 FORMAT('***** FATAL ERROR--THE FIRST INPUT ARGUMENT TO THE ', 1' POLPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL') 11 FORMAT('***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE ', 1' POLPPF SUBROUTINE IS NON-POSITIVE') 12 FORMAT('***** FATAL ERROR--THE THIRD INPUT ARGUMENT TO THE ', 1' POLPPF SUBROUTINE IS NON-POSITIVE') 25 FORMAT('***** FATAL ERROR--THE FOURTH INPUT ARGUMENT TO THE ', 1' POLPPF SUBROUTINE IS NON-POSITIVE *****') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****') C AN=N PPF=0.0 C C TREAT CERTAIN SPECIAL CASES IMMEDIATELY-- C 1) P = 0.0 C 2) P = 1.0 C IF(P.EQ.0.0)THEN PPF=0.0 GOTO9999 ENDIF C IF(P.EQ.1.0)THEN PPF=REAL(N) GOTO9999 ENDIF C C COMPUTE THE POLCDF, TERMINATE WHEN CDF IS GREATER THAN OR C EQUAL TO P. C DP=DBLE(P) DN=DBLE(N) DV=DBLE(V) DW=DBLE(W) DSUM1=0.0D0 DO1000I=0,N DX=DBLE(I) DTERM1=DLOG(DBINOM(N,I)) DTERM2=DLBETA(DX+DV,DN+DW-DX) DTERM4=DLBETA(DV,DW) DCDF=DEXP(DTERM1 + DTERM2 - DTERM4) DSUM1=DSUM1+DCDF IF(DSUM1.GE.DP)THEN PPF=REAL(I) GOTO9999 ENDIF 1000 CONTINUE PPF=REAL(N) C 9999 CONTINUE RETURN END function poly(c, nord, x) c c c Algorithm AS 181.2 Appl. Statist. (1982) Vol. 31, No. 2 c c Calculates the algebraic polynomial of order nored-1 with c array of coefficients c. Zero order coefficient is c(1) c real c(nord) poly = c(1) if(nord.eq.1) return p = x*c(nord) if(nord.eq.2) goto 20 n2 = nord-2 j = n2+1 do 10 i = 1,n2 p = (p+c(j))*x j = j-1 10 continue 20 poly = poly+p return end SUBROUTINE POOL(IND, NP, NS, NW, W, N, LLIM, LT, LP) C PART OF ACM 591 FOR ANOVA C ****************************** POOL ****************************** POO 10 C POO 20 C OPERATES UPON THE VECTORS IN ARRAY W, PRINCIPALLY THE ARRAYS OF A POO 30 C FACTORIAL DECOMPOSITION WITHIN VECTOR A OF W. EITHER MOVES THE POO 40 C SECONDARY ARRAY INTO THE PRIMARY ARRAY, DUPLICATING ENTRIES WHERE POO 50 C NEEDED, OR POOLS THE SECONDARY ARRAY AND THE PRIMARY ARRAY BY AD- POO 60 C DITION INTO THE PRIMARY ARRAY (FOR DESCRIPTION OF MAPPING FUNCTION POO 70 C SEE SCHLATER AND HEMMERLE, CACM 1966) POO 80 C POO 90 C IND = 0 (REPLACEMENT); IND = 1 (POOLING) POO 100 C POO 110 C NP = BASE ADDRESS OF PRIMARY ARRAY (WITHIN ARRAY W) POO 120 C NS = BASE ADDRESS OF SECONDARY ARRAY (WITHIN ARRAY W) POO 130 C POO 140 C WHEN THE PRIMARY ARRAY HAS LESS THAN N SUBSCRIPTS, THE ENTRIES IN POO 150 C LLIM CORRESPONDING TO THE MISSING SUBSCRIPTS MUST BE MADE NEGATIVE POO 160 C PRIOR TO ENTRY AND THEN SET POSITIVE AGAIN AFTER RETURN; ARRAY LP POO 170 C MUST CONTAIN THE COEFFICIENTS OF THE MAPPING FUNCTION UPON ENTRY. POO 180 C POO 190 C (SEE MAIN PROGRAM COMMENTS FOR DESCRIPTION OF OTHER ARGUMENTS) POO 200 C POO 210 C ****************************************************************** POO 220 DIMENSION W(NW), LLIM(N), LT(N), LP(10) DOUBLE PRECISION W, TEMP C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C NP=LOCATION OF PRIMARY ARRAY; NS=LOCATION OF SECONDARY ARRAY; C MAP COEFFICIENTS OBTAINED FROM LP; REPLACE (IND=0); ADD (IND .NE. 0) LOC1 = NP I = 1 10 DO 20 J=I,N LT(J) = 1 20 CONTINUE 30 LOC1 = LOC1 + 1 LOC2 = NS + 1 DO 40 J=1,N LOC2 = LOC2 + (LT(J)-1)*LP(J) 40 CONTINUE TEMP = W(LOC2) IF (IND.NE.0) TEMP = TEMP + W(LOC1) W(LOC1) = TEMP DO 50 J=1,N K = N - J + 1 IF (LLIM(K).LT.0) GO TO 50 IF (LT(K).EQ.LLIM(K)) GO TO 50 LT(K) = LT(K) + 1 IF (K.EQ.N) GO TO 30 I = K + 1 GO TO 10 50 CONTINUE RETURN END SUBROUTINE POWCDF(X,C,CDF) C C NOTE--POWER FUNCTION PDF IS: C POWPDF(X,C,B) = C*X**(C-1)/B**C 0 <= X <= B, B > 0 C WHERE C IS THE SHAPE PARAMETER AND B IS A SCALE PARAMETER. C THE STANDARD FORM OF THIS DISTRIBUTION IS: C POWPDF(X,C) = C*X**(C-1) 0 <= X <= 1 C THE CUMULATIVE DISTRIBUTION FUNCTIONS ARE: C POWCDF(X,C,B) = (X/B)**C C POWCDF(X,C) = X**C C REFERENCE --"STATISTICAL DISTRIBUTIONS", EVANS, HASTINGS, PEACOCK C CHAPTER 32. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--95/4 C ORIGINAL VERSION--APRIL 1995. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 DOUBLE PRECISION DTERM3 DOUBLE PRECISION DCDF C INCLUDE 'DPCOMC.INC' C C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C CDF=0.0 IF(X.LT.0.0 .OR. X.GT.1.0)THEN WRITE(ICOUT,301) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,302)X CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF 301 FORMAT('***** FATAL DIAGNOSTIC--THE INPUT ARGUMENT IS NOT IN 1 THE INTERVAL (0,1).') 302 FORMAT(' IT HAS THE VALUE ',E15.7) C IF(X.LE.0.0)THEN CDF=0.0 RETURN ENDIF IF(X.GE.1.0)THEN CDF=1.0 RETURN ENDIF C DTERM1=DBLE(C) DTERM2=DLOG(DBLE(X)) DTERM3=DTERM1*DTERM2 DCDF=DEXP(DTERM3) CDF=REAL(DCDF) GOTO9999 C 9999 CONTINUE RETURN END SUBROUTINE POWELD(X,E,N,F,ESCALE,IPRNT,ICON,MAXIT,FUNC) C C * AUTHORS: Necip Doganaksoy and Wayne Nelson C * PURPOSE: Maximum likelihood fitting of the power-normal and C * -lognormal models to censored life or strength data C * from specimens of various sizes C * DOCUMENTATION: Wayne Nelson and Necip Doganaksoy, "A Computer C * Program POWNOR for Fitting the Power-Normal and C * -Lognormal Models to Life or Strength Data from C * Specimens of Various Sizes", NISTIR 4760, 3/1992. C * PROJECT: 1990-91 ASA/NIST/NSF Fellowship C IMPLICIT DOUBLE PRECISION (A-H,O-Z) LOGICAL LTP LOGICAL LDUMP C COMMON/PNRLST/LTP COMMON/PNRIO/INPUT,IOUT COMMON/PNRSSS/SCRAT(300) C DIMENSION X(N),E(N) DIMENSION W(100) C EXTERNAL PNRFUN C REAL R1MACH INCLUDE 'DPCOMC.INC' REAL CPUMIN REAL CPUMAX CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C DATA FOUR/4.0D00/ DATA ZERO,PZ3,PZ5,P1,P4,HALF,ONE,TWO,FIVE,TEN,TWENTY/ @0.0D00,0.03D00,0.05D00,0.1D00,0.4D00,0.5D00,1.0D00,2.0D00,5.0D00, @10.0D00,20.0D00/ C C POWELL ALGORTHIM FOR MINIMIZING A FUNCTION OF N VARIABLES C WITHOUT THE USE OF DERIVATIVES. C LDUMP=.FALSE. NM1=N-1 LTP=.TRUE. FSAVQ=1.0D35 IPRNT2=IPRNT KTO=0 IF(IPRNT.EQ.5)THEN KTO=1 IPRNT2=1 ENDIF DDMAG=P1*ESCALE SCER=PZ5/ESCALE JJ=N*N+N JJJ=JJ+N K=N+1 NFCC=1 IND=1 INN=1 C DO 1 I=1,N DO 2 J=1,N W(K)=ZERO IF(I.EQ.J)THEN W(K)=DABS(E(I)) W(I)=ESCALE ENDIF K=K+1 2 CONTINUE 1 CONTINUE C ITERC=1 ISGRAD=2 F=PNRFUN(X,N) FKEEP=DABS(F)+DABS(F) C 5 CONTINUE C ITONE=1 FP=F SUM=ZERO IXP=JJ DO 6 I=1,N IXP=IXP+1 W(IXP)=X(I) 6 CONTINUE IDIRN=N+1 ILINE=1 C 7 CONTINUE C DMAX=W(ILINE) DACC=DMAX*SCER DMAG=DMIN1(DDMAG, P1*DMAX) DMAG=DMAX1(DMAG,TWENTY*DACC) DDMAX=TEN*DMAG IF(ITONE.EQ.3)GOTO71 DL=ZERO D=DMAG FPREV=F IS=5 FA=F DA=DL C 8 CONTINUE C DD=D-DL DL=D C 58 CONTINUE K=IDIRN DO 9 I=1,N X(I)=X(I)+DD*W(K) K=K+1 9 CONTINUE F=PNRFUN(X,N) NFCC=NFCC+1 GO TO(10,11,12,13,14,96),IS 14 CONTINUE IF(F.LT.FA)THEN FB=F DB=D GO TO 21 ELSEIF(F.EQ.FA)THEN IF(DABS(D).LE.DMAX)THEN D=D+D GO TO 8 ELSE WRITE(ICOUT,19) 19 FORMAT(5X,'MAXIMUM CHANGE DOES NOT ALTER FUNCTION') CALL DPWRST('XXX','WRIT') RETURN ENDIF ENDIF FB=FA DB=DA FA=F DA=D C 21 CONTINUE IF(ISGRAD.NE.1)GOTO921 D=HALF*(DA+DB-(FA-FB)/(DA-DB)) IS=4 IF((DA-D)*(D-DB).GE.0.0D0)GOTO8 25 CONTINUE IS=1 IF(DABS(D-DB)-DDMAX.LE.0.0D0)GOTO8 26 CONTINUE D=DB+DSIGN(DDMAX,DB-DA) IS=1 DDMAX=DDMAX+DDMAX DDMAG=DDMAG+DDMAG IF(DDMAX.LE.DMAX)GOTO8 DDMAX=DMAX GO TO 8 921 CONTINUE C 23 CONTINUE D=DB+DB-DA IS=1 GO TO 8 C 13 IF(F.GE.FA)GOTO23 28 CONTINUE FC=FB DC=DB 29 CONTINUE FB=F DB=D GO TO 30 C 12 IF(F.LE.FB)GOTO28 FA=F DA=D GO TO 30 C 11 CONTINUE IF(F.GE.FB)GOTO10 FA=FB DA=DB GO TO 29 C 71 DL=ONE DDMAX=FIVE FA=FP DA=-ONE FB=FHOLD DB=ZERO D=ONE C 10 CONTINUE FC=F DC=D C 30 CONTINUE A=(DB-DC)*(FA-FC) B=(DC-DA)*(FB-FC) IF((A+B)*(DA-DC).LE.0.0D0)THEN FA=FB DA=DB FB=FC DB=DC GO TO 26 ELSE D=HALF*(A*(DB+DC)+B*(DA+DC))/(A+B) DI=DB FI=FB IF(FB.GT.FC)THEN DI=DC FI=FC ENDIF IF(ITONE.EQ.2)THEN ITONE=2 GO TO 45 ENDIF ENDIF IF(DABS(D-DI)-DACC.LE.0.0D0)GOTO41 IF(DABS(D-DI)- PZ3*DABS(D).LE.0.0D0)GOTO41 45 CONTINUE IF((DA-DC)*(DC-D).GE.0.0D0)THEN FA=FB DA=DB FB=FC DB=DC GO TO 25 ELSE IS=2 IF((DB-D)*(D-DC).GE.0.0D0)GOTO8 IS=3 GO TO 8 ENDIF 41 CONTINUE F=FI D=DI-DL DD=DSQRT((DC-DB)*(DC-DA)*(DA-DB)/(A+B)) DO 49 I=1,N X(I)=X(I)+D*W(IDIRN) W(IDIRN)=DD*W(IDIRN) IDIRN=IDIRN+1 49 CONTINUE W(ILINE)=W(ILINE)/DD ILINE=ILINE+1 IF(IPRNT2.EQ.1)THEN IF(KTO.EQ.1) THEN FMVAL=-F WRITE(ICOUT,555)ITERC,NFCC,FMVAL,(X(I),I=1,N) 555 FORMAT(2X,I4,12X,I5,8X,D16.5,2X,6D13.5) CALL DPWRST('XXX','WRIT') ELSE WRITE(ICOUT,52)ITERC,NFCC 52 FORMAT(' ITERATION ',I5,I10,' FUNCT. EVAL.') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,952)F 952 FORMAT(' F =',E18.8) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,953)(X(I),I=1,N) 953 FORMAT(8F14.8) CALL DPWRST('XXX','WRIT') ENDIF IF(IPRNT2.EQ.2)GOTO53 ENDIF IF(ITONE.EQ.2)GOTO38 IF(FPREV-F-SUM.GE.0.0D0)THEN SUM=FPREV-F JTL=ILINE ENDIF IF(IDIRN.LE.JJ)GOTO7 IF(IND.EQ.2)GOTO72 C 92 CONTINUE FHOLD=F IS=6 IXP=JJ DO 59 I=1,N IXP=IXP+1 W(IXP)=X(I)-W(IXP) 59 CONTINUE DD=ONE GO TO 58 C 96 CONTINUE IF(IND.EQ.1)THEN IF(FP-F.LE.0.0D0)GOTO37 D=TWO*(FP+F-TWO*FHOLD)/(FP-F)**2 IF(D*(FP-FHOLD-SUM)**2-SUM.GE.0.0D0)GOTO37 ENDIF J=JTL*N+1 IF(J.GT.JJ)THEN DO 62 I=J,JJ K=I-N W(K)=W(I) 62 CONTINUE DO 97 I=JTL,N W(I-1)=W(I) 97 CONTINUE ENDIF IDIRN=IDIRN-N ITONE=3 K=IDIRN IXP=JJ AAA=ZERO DO 65 I=1,N IXP=IXP+1 W(K)=W(IXP) IF(AAA-DABS(W(K)/E(I)).LE.0.0D0)THEN AAA=DABS(W(K)/E(I)) ENDIF K=K+1 65 CONTINUE DDMAG=ONE W(N)=ESCALE/AAA ILINE=N GO TO 7 C 37 IXP=JJ AAA=ZERO F=FHOLD DO 99 I=1,N IXP=IXP+1 X(I)=X(I)-W(IXP) IF(AAA*DABS(E(I))-DABS(W(IXP)).LE.0.0D0)THEN AAA=DABS(W(IXP)/E(I)) ENDIF 99 CONTINUE GO TO 72 C 38 CONTINUE AAA=AAA*(ONE+DI) IF(IND.EQ.2)GOTO106 C 72 CONTINUE C IF(IPRNT2.LT.2)THEN IF(KTO.EQ.1) THEN FMVAL=-F WRITE(ICOUT,555)ITERC,NFCC,FMVAL,(X(I),I=1,N) CALL DPWRST('XXX','WRIT') ELSE WRITE(ICOUT,52)ITERC,NFCC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,952)F CALL DPWRST('XXX','WRIT') WRITE(ICOUT,953)(X(I),I=1,N) CALL DPWRST('XXX','WRIT') ENDIF ENDIF C 53 CONTINUE IF(IND.EQ.2)GOTO88 IF(AAA.GT.P1)GOTO76 IF(ICON.EQ.1)RETURN IND=2 IF(INN.EQ.2)GOTO101 INN=2 K=JJJ DO 102 I=1,N K=K+1 W(K)=X(I) X(I)=X(I)+TEN*E(I) 102 CONTINUE FKEEP=F F=FUNC(X,N) NFCC=NFCC+1 DDMAG=ZERO GO TO 108 C 76 CONTINUE IF(F.LT.FP)GOTO35 C 78 CONTINUE WRITE(ICOUT,80) 80 FORMAT('ACCURACY LIMITED BY ERRORS IN FUNCTION') CALL DPWRST('XXX','WRIT') RETURN C 88 CONTINUE IND=1 C 35 CONTINUE DDMAG=FOUR*DSQRT(FP-F) ISGRAD=1 108 CONTINUE ITERC=ITERC+1 C C CHECK TO SEE IF THE LIKELIHOOD IS CHANGING SLOWLY C IF(.NOT.LTP) GO TO 2002 IF(DABS(F-FSAVQ).GT.ONE) GO TO 2001 IF(LDUMP)THEN WRITE(ICOUT,4998) 4998 FORMAT('***LOGLIKELIHOOD CHANGED BY LESS THAN ONE IN THIS') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,4999) 4999 FORMAT('ITERATION. CHANGING TO UNTRANSFORMED OBSERVATIONS') CALL DPWRST('XXX','WRIT') ENDIF LTP=.FALSE. 2001 FSAVQ=F 2002 CONTINUE IF(ITERC.LE.MAXIT)GOTO5 WRITE(ICOUT,82)MAXIT 82 FORMAT(1X,I4,' ITERATIONS COMPLETED WITHOUT MEETING ', 1 'SPECIFICATIONS') CALL DPWRST('XXX','WRIT') IF(F.LE.FKEEP)RETURN F=FKEEP DO 111 I=1,N JJJ=JJJ+1 X(I)=W(JJJ) 111 CONTINUE RETURN C 101 JTL=1 FP=FKEEP IF(F.EQ.FKEEP)THEN GOTO78 ELSEIF(F.GT.FKEEP)THEN JTL=2 FP=F F=FKEEP ENDIF IXP=JJ DO 113 I=1,N IXP=IXP+1 K=IXP+N IF(JTL.EQ.1)THEN W(IXP)=W(K) ELSE W(IXP)=X(I) X(I)=W(K) ENDIF 113 CONTINUE JTL=2 GO TO 92 C 106 CONTINUE IF(AAA.LE.P1)THEN RETURN ELSE INN=1 GO TO 35 ENDIF C END SUBROUTINE POWPDF(X,C,PDF) C C NOTE--POWER FUNCTION PDF IS: C POWPDF(X,C,B) = C*X**(C-1)/B**C 0 <= X <= B, B > 0 C WHERE C IS THE SHAPE PARAMETER AND B IS A SCALE PARAMETER. C THE STANDARD FORM OF THIS DISTRIBUTION IS: C POWPDF(X,C,B) = C*X**(C-1) 0 <= X <= 1 C REFERENCE --"STATISTICAL DISTRIBUTIONS", EVANS, HASTINGS, PEACOCK C CHAPTER 32. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--95/4 C ORIGINAL VERSION--APRIL 1995. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 DOUBLE PRECISION DTERM3 DOUBLE PRECISION DARG DOUBLE PRECISION DMIN DOUBLE PRECISION DPDF C INCLUDE 'DPCOMC.INC' C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C PDF=0.0 IF(X.LT.0.0 .OR. X.GT.1.0)THEN WRITE(ICOUT,301) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,302)X CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF 301 FORMAT('***** FATAL DIAGNOSTIC--THE INPUT ARGUMENT IS NOT IN 1 THE INTERVAL (0,1).') 302 FORMAT(' IT HAS THE VALUE ',E15.7) C DARG=DBLE(X) DMIN=D1MACH(1) IF(DARG.LE.DMIN)DARG=DMIN DTERM1=DLOG(DBLE(C)) DTERM2=DBLE(C-1.0)*DLOG(DARG) DTERM3=DTERM1 + DTERM2 IF(REAL(DTERM3).GE.LOG(R1MACH(2)))THEN WRITE(ICOUT,401) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,402)X CALL DPWRST('XXX','BUG ') PDF=LOG(R1MACH(2)) GOTO9999 ENDIF 401 FORMAT('***** FATAL DIAGNOSTIC--THE COMPUTED VALUE OF THE PDF ', 1 'OVERFLOWS. SET TO THE LOG OF LARGEST NUMBER.') 402 FORMAT(' THE INPUT ARGUMENT HAS THE VALUE ',E15.7) DPDF=DEXP(DTERM3) PDF=REAL(DPDF) GOTO9999 C 9999 CONTINUE RETURN END SUBROUTINE POWRAN(N,C,ISEED,X) C C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N C FROM THE THE POWER FUNCTION C DISTRIBUTION WITH SCALE PARAMETER = 1 C THIS DISTRIBUTION IS DEFINED FOR 0 <= X <= 1 C THE PROBABILITY DENSITY FUNCTION C F(X) = C*X**(C-1)/(B**C) C WHERE C IS THE SHAPE PARAMETER AND B IS THE SCALE C PARAMETER. C INPUT ARGUMENTS--N = THE DESIRED INTEGER NUMBER C OF RANDOM NUMBERS TO BE C GENERATED. C OUTPUT ARGUMENTS--X = A SINGLE PRECISION VECTOR C (OF DIMENSION AT LEAST N) C INTO WHICH THE GENERATED C RANDOM SAMPLE WILL BE PLACED. C OUTPUT--A RANDOM SAMPLE OF SIZE N C FROM THE NORMAL DISTRIBUTION C WITH MEAN = 0 AND STANDARD DEVIATION = 1. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C OTHER DATAPAC SUBROUTINES NEEDED--UNIRAN. C FORTRAN LIBRARY SUBROUTINES NEEDED--EXP C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--EVANS, HASTINGS, AND PEACOCK "STATISTICAL C DISTRIBUTIONS", CHAPTER 32. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--95.4 C ORIGINAL VERSION--APRIL 1995. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DIMENSION X(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(N.LT.1)GOTO50 GOTO90 50 WRITE(ICOUT, 5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)N CALL DPWRST('XXX','BUG ') RETURN 90 CONTINUE 5 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ', 1'POWRAN SUBROUTINE IS NON-POSITIVE *****') 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****') C C GENERATE N UNIFORM (0,1) RANDOM NUMBERS; C THEN GENERATE 2 ADDITIONAL UNIFORM (0,1) RANDOM NUMBERS C (TO BE USED BELOW IN FORMING THE N-TH NORMAL C RANDOM NUMBER WHEN THE DESIRED SAMPLE SIZE N C HAPPENS TO BE ODD). C CALL UNIRAN(N,ISEED,X) C C POWER FUNCTION RANDOM NUMBERS = (UNIFORM)**(1/C) C DO200I=1,N X(I)=X(I)**(1.0/C) 200 CONTINUE C RETURN END SUBROUTINE POWPPF(P,C,PPF) C C NOTE--POWER FUNCTION PDF IS: C POWPDF(X,C,B) = C*X**(C-1)/B**C 0 <= X <= B, B > 0 C WHERE C IS THE SHAPE PARAMETER AND B IS A SCALE PARAMETER. C THE STANDARD FORM OF THIS DISTRIBUTION IS: C POWPDF(X,C) = C*X**(C-1) 0 <= X <= 1 C THE PERCENT POINT FUNCTIONS ARE: C POWPPF(X,C,B) = B*P**(1/C) C POWPPF(X,C) = P**(1/C) C REFERENCE --"STATISTICAL DISTRIBUTIONS", EVANS, HASTINGS, PEACOCK C CHAPTER 32. C PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT C FUNCTION VALUE FOR THE POWER FUNCTION C DISTRIBUTION FROM 0 TO 1 C INPUT ARGUMENTS--P = THE SINGLE PRECISION VALUE C (BETWEEN 0.0 AND 1.0) C AT WHICH THE PERCENT POINT C FUNCTION IS TO BE EVALUATED. C OUTPUT ARGUMENTS--PPF = THE SINGLE PRECISION PERCENT C POINT FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION PERCENT POINT C FUNCTION VALUE PPF. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--P SHOULD BE BETWEEN 0.0 AND 1.0, INCLUSIVELY. C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-921-3651 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--95.4 C ORIGINAL VERSION--APRIL 1995. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 DOUBLE PRECISION DTERM3 DOUBLE PRECISION DPPF C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(P.LT.0.0.OR.P.GT.1.0)GOTO50 GOTO90 50 WRITE(ICOUT,1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)P CALL DPWRST('XXX','BUG ') RETURN 90 CONTINUE 1 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ', 1'POWPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') C C-----START POINT----------------------------------------------------- C IF(P.EQ.0.0)THEN PPF=0.0 ELSEIF(P.EQ.1.0)THEN PPF=1.0 ELSE DTERM1=DBLE(1.0/C) DTERM2=DLOG(DBLE(P)) DTERM3=DTERM1*DTERM2 DPPF=DEXP(DTERM3) PPF=REAL(DPPF) ENDIF C RETURN END REAL FUNCTION PPND(P, IFAULT) C C ALGORITHM AS 111 APPL. STATIST. (1977), VOL.26, NO.1 C C PRODUCES NORMAL DEVIATE CORRESPONDING TO LOWER TAIL AREA OF P C REAL VERSION FOR EPS = 2 **(-31) C THE HASH SUMS ARE THE SUMS OF THE MODULI OF THE COEFFICIENTS C THEY HAVE NO INHERENT MEANINGS BUT ARE INCLUDED FOR USE IN C CHECKING TRANSCRIPTIONS C STANDARD FUNCTIONS ABS, ALOG AND SQRT ARE USED C C NOTE: WE COULD USE DATAPLOT NORPPF, BUT VARIOUS APPLIED C STATISTICS ALGORITHMS USE THIS. SO WE PROVIDE IT TO C MAKE USE OF APPLIED STATISTICS ALGORITHMS EASIER. C REAL ZERO, SPLIT, HALF, ONE REAL A0, A1, A2, A3, B1, B2, B3, B4, C0, C1, C2, C3, D1, D2 REAL P, Q, R INTEGER IFAULT DATA ZERO /0.0E0/, HALF/0.5E0/, ONE/1.0E0/ DATA SPLIT /0.42E0/ DATA A0 / 2.50662823884E0/ DATA A1 / -18.61500062529E0/ DATA A2 / 41.39119773534E0/ DATA A3 / -25.44106049637E0/ DATA B1 / -8.47351093090E0/ DATA B2 / 23.08336743743E0/ DATA B3 / -21.06224101826E0/ DATA B4 / 3.13082909833E0/ DATA C0 / -2.78718931138E0/ DATA C1 / -2.29796479134E0/ DATA C2 / 4.85014127135E0/ DATA C3 / 2.32121276858E0/ DATA D1 / 3.54388924762E0/ DATA D2 / 1.63706781897E0/ C IFAULT = 0 Q = P - HALF IF (ABS(Q) .GT. SPLIT) GOTO 1 R = Q*Q PPND = Q * (((A3*R + A2)*R + A1) * R + A0) / * ((((B4*R + B3)*R + B2) * R + B1) * R + ONE) RETURN 1 R = P IF (Q .GT. ZERO)R = ONE - P IF (R .LE. ZERO) GOTO 2 R = SQRT(-ALOG(R)) PPND = (((C3 * R + C2) * R + C1) * R + C0)/ * ((D2*R + D1) * R + ONE) IF (Q .LT. ZERO) PPND = -PPND RETURN 2 IFAULT = 1 PPND = ZERO RETURN END SUBROUTINE PRIMES(N,X,IERROR) C C PURPOSE--THIS SUBROUTINE GENERATES THE FIRST N PRIME NUMBERS-- C 2, 3, 5, 7, 11, ... C INPUT ARGUMENTS--N = THE DESIRED INTEGER NUMBER C OF PRIME NUMBERS C TO BE GENERATED. C OUTPUT ARGUMENTS--X = A SINGLE PRECISION VECTOR C (OF DIMENSION AT LEAST N) C INTO WHICH THE GENERATED C PRIME NUMBERS C WILL BE PLACED. C OUTPUT--THE FIRST N PRIME NUMBERS. C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C LANGUAGE--ANSI FORTRAN (1977) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--87.10 C ORIGINAL VERSION--SEPTEMBER 1987. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IERROR C C--------------------------------------------------------------------- C DIMENSION X(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C ****************************************** C ** TREAT THE PRIMES NUMBERS CASE ** C ****************************************** C C ******************************************* C ** STEP 1-- ** C ** TEST THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************* C IF(N.GE.1)GOTO190 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,101) 101 FORMAT('***** ERROR IN GENMS--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,102) 102 FORMAT(' THE LENGTH OF THE DESIRED SEQUENCE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,103) 103 FORMAT(' OF PRIME NUMBERS MUST BE 1 OR LARGER;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,104) 104 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,105)N 105 FORMAT(' N = ',I8) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 190 CONTINUE C C ****************************** C ** STEP 2-- ** C ** GENERATE THE SEQUENCE ** C ****************************** C X(1)=2 X(2)=3 X(3)=5 C NP=3 DO1100I=7,100000,2 ANP=NP JMAX=SQRT(ANP)+1.5 C DO1200J=2,JMAX IXJ=X(J)+0.5 K=MOD(I,IXJ) IF(K.EQ.0)GOTO1100 1200 CONTINUE C NP=NP+1 X(NP)=I IF(NP.GE.N)GOTO1190 C 1100 CONTINUE 1190 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE RETURN END SUBROUTINE PROD(X,N,IWRITE,XPROD,IBUGA3,IERROR) C C PURPOSE--THIS SUBROUTINE COMPUTES THE C SAMPLE PRODUCT C OF THE DATA IN THE INPUT VECTOR X. C THE SAMPLE PRODUCT = PRODUCT OF ALL OBSERVATIONS IN X. C INPUT ARGUMENTS--X = THE SINGLE PRECISION VECTOR OF C (UNSORTED OR SORTED) OBSERVATIONS. C --N = THE INTEGER NUMBER OF OBSERVATIONS C IN THE VECTOR X. C OUTPUT ARGUMENTS--XPROD = THE SINGLE PRECISION VALUE OF THE C COMPUTED SAMPLE PRODUCT. C OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE C SAMPLE PRODUCT. C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--82.6 C ORIGINAL VERSION--JUNE 1972. C UPDATED --SEPTEMBER 1975. C UPDATED --NOVEMBER 1975. C UPDATED --OCTOBER 1978. C UPDATED --JUNE 1979. C UPDATED --JULY 1979. C UPDATED --AUGUST 1981. C UPDATED --FEBRUARY 1982. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IWRITE CHARACTER*4 IBUGA3 CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C DOUBLE PRECISION DX DOUBLE PRECISION DPROD C DIMENSION X(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='PROD' ISUBN2=' ' C IERROR='NO' C IF(IBUGA3.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF PROD--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA3 52 FORMAT('IBUGA3 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)N 53 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') DO55I=1,N WRITE(ICOUT,56)I,X(I) 56 FORMAT('I,X(I) = ',I8,E15.7) CALL DPWRST('XXX','BUG ') 55 CONTINUE 90 CONTINUE C C *********************** C ** COMPUTE PRODUCT ** C *********************** C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C AN=N C IF(N.GE.1)GOTO119 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,111) 111 FORMAT('***** ERROR IN PROD--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,112) 112 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,113) 113 FORMAT(' IN THE VARIABLE FOR WHICH') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,114) 114 FORMAT(' THE PRODUCT IS TO BE COMPUTED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,115) 115 FORMAT(' MUST BE 1 OR LARGER.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,116) 116 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,117)N 117 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8, 1'.') CALL DPWRST('XXX','BUG ') GOTO9000 119 CONTINUE C IF(N.EQ.1)GOTO120 GOTO129 120 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,121) 121 FORMAT('***** NON-FATAL DIAGNOSTIC IN PROD--', 1'THE SECOND INPUT ARGUMENT (N) HAS THE VALUE 1') CALL DPWRST('XXX','BUG ') XPROD=X(1) GOTO9000 129 CONTINUE C HOLD=X(1) DO135I=2,N IF(X(I).NE.HOLD)GOTO139 135 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,136)HOLD 136 FORMAT('***** NON-FATAL DIAGNOSTIC IN PROD--', 1'THE FIRST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7) CALL DPWRST('XXX','BUG ') XPROD=HOLD**N GOTO9000 139 CONTINUE C 190 CONTINUE C C **************************** C ** STEP 2-- ** C ** COMPUTE THE PRODUCT. ** C **************************** C DPROD=1.0D0 DO200I=1,N DX=X(I) DPROD=DPROD*DX 200 CONTINUE XPROD=DPROD C C ******************************* C ** STEP 3-- ** C ** WRITE OUT A LINE ** C ** OF SUMMARY INFORMATION. ** C ******************************* C IF(IFEEDB.EQ.'OFF')GOTO890 IF(IWRITE.EQ.'OFF')GOTO890 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,811)N,XPROD 811 FORMAT('THE PRODUCT OF THE ',I8,' OBSERVATIONS = ',E15.7) CALL DPWRST('XXX','BUG ') 890 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE IF(IBUGA3.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF PROD--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGA3,IERROR 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)N 9013 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)XPROD 9015 FORMAT('XPROD = ',E15.7) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE PROP(X,N,ANOPL1,ANOPL2,IWRITE,XPROP, 1IBUGA3,IERROR) C C PURPOSE--THIS SUBROUTINE COMPUTES THE C PROPORTION (0 TO 100%) OF DATA C INPUT ARGUMENTS--X = THE SINGLE PRECISION VECTOR OF C (UNSORTED OR SORTED) OBSERVATIONS. C --N = THE INTEGER NUMBER OF OBSERVATIONS C IN THE VECTOR X. C --ANOPL1 = UPPER (ENGINEERING) SPEC LIMIT C --ANOPL2 = LOWER (ENGINEERING) SPEC LIMIT C OUTPUT ARGUMENTS--PROP = THE SINGLE PRECISION VALUE OF THE C COMPUTED SAMPLE EXPECTED LOSS C OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE C SAMPLE EXPECTED LOSS (IN XPROP) C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C LANGUAGE--ANSI FORTRAN (1977) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--89.5 C ORIGINAL VERSION--MAY 1989. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IWRITE CHARACTER*4 IBUGA3 CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C DIMENSION X(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='PROP' ISUBN2=' ' C IERROR='NO' C IF(IBUGA3.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF PROP--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA3 52 FORMAT('IBUGA3 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)N 53 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)ANOPL1,ANOPL2 54 FORMAT('ANOPL1,ANOPL2 = ',2E15.7) CALL DPWRST('XXX','BUG ') DO55I=1,N WRITE(ICOUT,56)I,X(I) 56 FORMAT('I,X(I) = ',I8,E15.7) CALL DPWRST('XXX','BUG ') 55 CONTINUE 90 CONTINUE C C ******************************************** C ** COMPUTE THE PROPORTION STATISTIC ** C ******************************************** C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C AN=N C IF(N.GE.1)GOTO119 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,111) 111 FORMAT('***** ERROR IN PROP--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,112) 112 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,113) 113 FORMAT(' IN THE VARIABLE FOR WHICH') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,114) 114 FORMAT(' THE PROPORTION IS TO BE COMPUTED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,115) 115 FORMAT(' MUST BE 1 OR LARGER.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,116) 116 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,117)N 117 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8, 1'.') CALL DPWRST('XXX','BUG ') GOTO9000 119 CONTINUE C IF(N.EQ.1)GOTO120 GOTO129 120 CONTINUE CCCCC WRITE(ICOUT,999) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,121) CC121 FORMAT('***** NON-FATAL DIAGNOSTIC IN PROP--', CCCCC1'THE SECOND INPUT ARGUMENT (N) HAS THE VALUE 1') CCCCC CALL DPWRST('XXX','BUG ') GOTO9000 129 CONTINUE C HOLD=X(1) DO135I=2,N IF(X(I).NE.HOLD)GOTO139 135 CONTINUE CCCCC WRITE(ICOUT,999) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,136)HOLD CC136 FORMAT('***** NON-FATAL DIAGNOSTIC IN PROP--', CCCCC1'THE FIRST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7) CCCCC CALL DPWRST('XXX','BUG ') GOTO9000 139 CONTINUE C 190 CONTINUE C C ******************************* C ** STEP 2-- ** C ** COMPUTE THE PROPORTION. ** C ******************************* C ANOPL3=ANOPL1 IF(ANOPL1.GT.ANOPL2)ANOPL3=ANOPL2 C ANOPL4=ANOPL2 IF(ANOPL1.GT.ANOPL2)ANOPL4=ANOPL1 C XPROP=0.0 ICOUNT=0 DO200I=1,N IF(ANOPL3.LE.X(I).AND.X(I).LE.ANOPL4)ICOUNT=ICOUNT+1 200 CONTINUE COUNT=ICOUNT C P=COUNT/AN XPROP=100.0*P C C ******************************* C ** STEP 3-- ** C ** WRITE OUT A LINE ** C ** OF SUMMARY INFORMATION. ** C ******************************* C IF(IFEEDB.EQ.'OFF')GOTO890 IF(IWRITE.EQ.'OFF')GOTO890 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,811)N,XPROP 811 FORMAT('THE PROPORTION OF THE ',I8,' OBSERVATIONS = ', 1E15.7,' %') CALL DPWRST('XXX','BUG ') 890 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE IF(IBUGA3.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF PROP--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGA3,IERROR 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)ANOPL1,ANOPL2 9015 FORMAT('ANOPL1,ANOPL2 = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9016)ANOPL3,ANOPL4 9016 FORMAT('ANOPL3,ANOPL4 = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9017)N,ICOUNT,AN,COUNT 9017 FORMAT('N,ICOUNT,AN,COUNT = ',2I8,2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9018)P,XPROP 9018 FORMAT('P,XPROP = ',2E15.7) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END double precision function prtrng(q, v, r, ifault) implicit double precision (a-h, o-z) c c Algorithm AS 190 Appl. Statist. (1983) Vol.32, No. 2 c Incorporates corrections from Appl. Statist. (1985) Vol.34 (1) c c Evaluates the probability from 0 to q for a studentized c range having v degrees of freedom and r samples. c c Uses subroutine ALNORM = algorithm AS66. c c Arrays vw and qw store transient values used in the c quadrature summation. Node spacing is controlled by c step. pcutj and pcutk control truncation. c Minimum and maximum number of steps are controlled by c jmin, jmax, kmin and kmax. Accuracy can be increased c by use of a finer grid - Increase sizes of arrays vw c and qw, and jmin, jmax, kmin, kmax and 1/step proportionally. c double precision q,v,r,vw(30), qw(30), pcutj, pcutk, step, # vmax,zero,fifth,half,one,two,cv1,cv2,cvmax,cv(4) double precision g, gmid, r1, c, h, v2, gstep, pk1, pk2, gk, pk double precision w0, pz, x, hj, ehj, pj double precision alnorm external alnorm data pcutj, pcutk, step, vmax /0.00003d0, 0.0001d0, 0.45d0, # 120.0d0/, zero, fifth, half, one, two /0.0d0, 0.2d0, 0.5d0, # 1.0d0, 2.0d0/, cv1, cv2, cvmax /0.193064705d0, 0.293525326d0, # 0.39894228d0/, cv(1), cv(2), cv(3), cv(4) /0.318309886d0, # -0.268132716d-2, 0.347222222d-2, 0.833333333d-1/ data jmin, jmax, kmin, kmax/3, 15, 7, 15/ c c Check initial values c prtrng = zero ifault = 0 if (v .lt. one .or. r .lt. two) ifault = 1 if (q .le. zero .or. ifault .eq. 1) goto 99 c c Computing constants, local midpoint, adjusting steps. c g = step * r ** (-fifth) gmid = half * log(r) r1 = r - one c = log(r * g * cvmax) if(v.gt.vmax) goto 20 c h = step * v ** (-half) v2 = v * half if (v .eq. one) c = cv1 if (v .eq. two) c = cv2 if (.not. (v .eq. one .or. v .eq. two)) c = sqrt(v2) # * cv(1) / (one + ((cv(2) / v2 + cv(3)) / v2 + cv(4)) / v2) c = log(c * r * g * h) c c Computing integral c Given a row k, the procedure starts at the midpoint and works c outward (index j) in calculating the probability at nodes c symmetric about the midpoint. The rows (index k) are also c processed outwards symmetrically about the midpoint. The c centre row is unpaired. c 20 gstep = g qw(1) = -one qw(jmax + 1) = -one pk1 = one pk2 = one do 28 k = 1, kmax gstep = gstep - g 21 gstep = -gstep gk = gmid + gstep pk = zero if (pk2 .le. pcutk .and. k .gt. kmin) goto 26 w0 = c - gk * gk * half pz = alnorm(gk, .true.) x = alnorm(gk - q, .true.) - pz if (x .gt. zero) pk = exp(w0 + r1 * log(x)) if (v .gt. vmax) goto 26 c jump = -jmax 22 jump = jump + jmax do 24 j = 1, jmax jj = j + jump if (qw(jj) .gt. zero) goto 23 hj = h * j if (j .lt. jmax) qw(jj + 1) = -one ehj = exp(hj) qw(jj) = q * ehj vw(jj) = v * (hj + half - ehj * ehj * half) c 23 pj = zero x = alnorm(gk - qw(jj), .true.) - pz if (x .gt. zero) pj = exp(w0 + vw(jj) + r1 * log(x)) pk = pk + pj if (pj .gt. pcutj) goto 24 if (jj .gt. jmin .or. k .gt. kmin) goto 25 24 continue 25 h = -h if (h .lt. zero) goto 22 c 26 prtrng = prtrng + pk if (k .gt. kmin .and. pk .le. pcutk .and. pk1 .le. pcutk)goto 99 pk2 = pk1 pk1 = pk if (gstep .gt. zero) goto 21 28 continue c 99 return end FUNCTION PSIXN (N) C***BEGIN PROLOGUE PSIXN C***SUBSIDIARY C***PURPOSE Subsidiary to EXINT C***LIBRARY SLATEC C***TYPE SINGLE PRECISION (PSIXN-S, DPSIXN-D) C***AUTHOR Amos, D. E., (SNLA) C***DESCRIPTION C C This subroutine returns values of PSI(X)=derivative of log C GAMMA(X), X .GT. 0.0 at integer arguments. A table look-up is C performed for N .LE. 100, and the asymptotic expansion is C evaluated for N .GT. 100. C C***SEE ALSO EXINT C***ROUTINES CALLED R1MACH C***REVISION HISTORY (YYMMDD) C 800501 DATE WRITTEN C 890531 Changed all specific intrinsics to generic. (WRB) C 891214 Prologue converted to Version 4.0 format. (BAB) C 900328 Added TYPE section. (WRB) C 910722 Updated AUTHOR section. (ALS) C***END PROLOGUE PSIXN C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOMC.INC' CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C INTEGER N, K REAL AX, B, C, FN, RFN2, TRM, S, WDTOL DIMENSION B(6), C(100) C----------------------------------------------------------------------- C PSIXN(N), N = 1,100 C----------------------------------------------------------------------- DATA C(1), C(2), C(3), C(4), C(5), C(6), C(7), C(8), C(9), C(10), 1 C(11), C(12), C(13), C(14), C(15), C(16), C(17), C(18), 2 C(19), C(20), C(21), C(22), C(23), C(24)/ 3 -5.77215664901532861E-01, 4.22784335098467139E-01, 4 9.22784335098467139E-01, 1.25611766843180047E+00, 5 1.50611766843180047E+00, 1.70611766843180047E+00, 6 1.87278433509846714E+00, 2.01564147795561000E+00, 7 2.14064147795561000E+00, 2.25175258906672111E+00, 8 2.35175258906672111E+00, 2.44266167997581202E+00, 9 2.52599501330914535E+00, 2.60291809023222227E+00, 1 2.67434666166079370E+00, 2.74101332832746037E+00, 2 2.80351332832746037E+00, 2.86233685773922507E+00, 3 2.91789241329478063E+00, 2.97052399224214905E+00, 4 3.02052399224214905E+00, 3.06814303986119667E+00, 5 3.11359758531574212E+00, 3.15707584618530734E+00/ DATA C(25), C(26), C(27), C(28), C(29), C(30), C(31), C(32), 1 C(33), C(34), C(35), C(36), C(37), C(38), C(39), C(40), 2 C(41), C(42), C(43), C(44), C(45), C(46), C(47), C(48)/ 3 3.19874251285197401E+00, 3.23874251285197401E+00, 4 3.27720405131351247E+00, 3.31424108835054951E+00, 5 3.34995537406483522E+00, 3.38443813268552488E+00, 6 3.41777146601885821E+00, 3.45002953053498724E+00, 7 3.48127953053498724E+00, 3.51158256083801755E+00, 8 3.54099432554389990E+00, 3.56956575411532847E+00, 9 3.59734353189310625E+00, 3.62437055892013327E+00, 1 3.65068634839381748E+00, 3.67632737403484313E+00, 2 3.70132737403484313E+00, 3.72571761793728215E+00, 3 3.74952714174680596E+00, 3.77278295570029433E+00, 4 3.79551022842756706E+00, 3.81773245064978928E+00, 5 3.83947158108457189E+00, 3.86074817682925274E+00/ DATA C(49), C(50), C(51), C(52), C(53), C(54), C(55), C(56), 1 C(57), C(58), C(59), C(60), C(61), C(62), C(63), C(64), 2 C(65), C(66), C(67), C(68), C(69), C(70), C(71), C(72)/ 3 3.88158151016258607E+00, 3.90198967342789220E+00, 4 3.92198967342789220E+00, 3.94159751656514710E+00, 5 3.96082828579591633E+00, 3.97969621032421822E+00, 6 3.99821472884273674E+00, 4.01639654702455492E+00, 7 4.03425368988169777E+00, 4.05179754953082058E+00, 8 4.06903892884116541E+00, 4.08598808138353829E+00, 9 4.10265474805020496E+00, 4.11904819067315578E+00, 1 4.13517722293122029E+00, 4.15105023880423617E+00, 2 4.16667523880423617E+00, 4.18205985418885155E+00, 3 4.19721136934036670E+00, 4.21213674247469506E+00, 4 4.22684262482763624E+00, 4.24133537845082464E+00, 5 4.25562109273653893E+00, 4.26970559977879245E+00/ DATA C(73), C(74), C(75), C(76), C(77), C(78), C(79), C(80), 1 C(81), C(82), C(83), C(84), C(85), C(86), C(87), C(88), 2 C(89), C(90), C(91), C(92), C(93), C(94), C(95), C(96)/ 3 4.28359448866768134E+00, 4.29729311880466764E+00, 4 4.31080663231818115E+00, 4.32413996565151449E+00, 5 4.33729786038835659E+00, 4.35028487337536958E+00, 6 4.36310538619588240E+00, 4.37576361404398366E+00, 7 4.38826361404398366E+00, 4.40060929305632934E+00, 8 4.41280441500754886E+00, 4.42485260777863319E+00, 9 4.43675736968339510E+00, 4.44852207556574804E+00, 1 4.46014998254249223E+00, 4.47164423541605544E+00, 2 4.48300787177969181E+00, 4.49424382683587158E+00, 3 4.50535493794698269E+00, 4.51634394893599368E+00, 4 4.52721351415338499E+00, 4.53796620232542800E+00, 5 4.54860450019776842E+00, 4.55913081598724211E+00/ DATA C(97), C(98), C(99), C(100)/ 1 4.56954748265390877E+00, 4.57985676100442424E+00, 2 4.59006084263707730E+00, 4.60016185273808740E+00/ C----------------------------------------------------------------------- C COEFFICIENTS OF ASYMPTOTIC EXPANSION C----------------------------------------------------------------------- DATA B(1), B(2), B(3), B(4), B(5), B(6)/ 1 8.33333333333333333E-02, -8.33333333333333333E-03, 2 3.96825396825396825E-03, -4.16666666666666666E-03, 3 7.57575757575757576E-03, -2.10927960927960928E-02/ C C***FIRST EXECUTABLE STATEMENT PSIXN IF (N.GT.100) GO TO 10 PSIXN = C(N) RETURN 10 CONTINUE WDTOL = MAX(R1MACH(4),1.0E-18) FN = N AX = 1.0E0 S = -0.5E0/FN IF (ABS(S).LE.WDTOL) GO TO 30 RFN2 = 1.0E0/(FN*FN) DO 20 K=1,6 AX = AX*RFN2 TRM = -B(K)*AX IF (ABS(TRM).LT.WDTOL) GO TO 30 S = S + TRM 20 CONTINUE 30 CONTINUE PSIXN = S + LOG(FN) RETURN END subroutine psort(a,n,ind,ni) c c This routine is part of the Bill Cleveland seasonal loess c program. c real a(n) integer n,ind(ni),ni integer indu(16),indl(16),iu(16),il(16),p,jl,ju,i,j,m,k,ij,l real t,tt if(.not.(n .lt. 0 .or. ni .lt. 0))goto 23157 return 23157 continue if(.not.(n .lt. 2 .or. ni .eq. 0))goto 23159 return 23159 continue jl = 1 ju = ni indl(1) = 1 indu(1) = ni i = 1 j = n m = 1 23161 continue if(.not.(i .lt. j))goto 23164 go to 10 23164 continue 23166 continue m = m-1 if(.not.(m .eq. 0))goto 23169 goto 23163 23169 continue i = il(m) j = iu(m) jl = indl(m) ju = indu(m) if(.not.(jl .le. ju))goto 23171 23173 if(.not.(j-i .gt. 10))goto 23174 10 k = i ij = (i+j)/2 t = a(ij) if(.not.(a(i) .gt. t))goto 23175 a(ij) = a(i) a(i) = t t = a(ij) 23175 continue l = j if(.not.(a(j) .lt. t))goto 23177 a(ij) = a(j) a(j) = t t = a(ij) if(.not.(a(i) .gt. t))goto 23179 a(ij) = a(i) a(i) = t t = a(ij) 23179 continue 23177 continue 23181 continue l = l-1 if(.not.(a(l) .le. t))goto 23184 tt = a(l) 23186 continue k = k+1 23187 if(.not.(a(k) .ge. t))goto 23186 if(.not.(k .gt. l))goto 23189 goto 23183 23189 continue a(l) = a(k) a(k) = tt 23184 continue 23182 goto 23181 23183 continue indl(m) = jl indu(m) = ju p = m m = m+1 if(.not.(l-i .le. j-k))goto 23191 il(p) = k iu(p) = j j = l 23193 continue if(.not.(jl .gt. ju))goto 23196 goto 23167 23196 continue if(.not.(ind(ju) .le. j))goto 23198 goto 23195 23198 continue ju = ju-1 23194 goto 23193 23195 continue indl(p) = ju+1 goto 23192 23191 continue il(p) = i iu(p) = l i = k 23200 continue if(.not.(jl .gt. ju))goto 23203 goto 23167 23203 continue if(.not.(ind(jl) .ge. i))goto 23205 goto 23202 23205 continue jl = jl+1 23201 goto 23200 23202 continue indu(p) = jl-1 23192 continue goto 23173 23174 continue if(.not.(i .eq. 1))goto 23207 goto 23168 23207 continue i = i-1 23209 continue i = i+1 if(.not.(i .eq. j))goto 23212 goto 23211 23212 continue t = a(i+1) if(.not.(a(i) .gt. t))goto 23214 k = i 23216 continue a(k+1) = a(k) k = k-1 23217 if(.not.(t .ge. a(k)))goto 23216 a(k+1) = t 23214 continue 23210 goto 23209 23211 continue 23171 continue 23167 goto 23166 23168 continue 23162 goto 23161 23163 continue return end function pull(a,n,k,b) cc Finds the kth order statistic of an array a of length n<=1000 dimension a(*),b(*) C do 15 j=1,n b(j)=a(j) 15 continue C l=1 lr=n C 20 continue if (l.ge.lr)then pull=b(k) goto 9999 endif ax=b(k) jnc=l j=lr C 30 continue if(jnc.gt.j)then if(j.lt.k)l=jnc if(k.lt.jnc)lr=j goto 20 endif C 40 continue if (b(jnc).ge.ax)then 50 continue if (b(j).le.ax)then 60 continue if(jnc.gt.j)goto 30 buffer=b(jnc) b(jnc)=b(j) b(j)=buffer jnc=jnc+1 j=j-1 goto 30 endif j=j-1 goto 50 endif jnc=jnc+1 goto 40 C 9999 CONTINUE return end SUBROUTINE PWLRAN(N,ALPHA,BETA,ISEED,X) C C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N C FOR THE POWER LAW FAILURTE TIMES. C INPUT ARGUMENTS--N = THE DESIRED INTEGER NUMBER C OF RANDOM NUMBERS TO BE C GENERATED. C OUTPUT ARGUMENTS--X = A SINGLE PRECISION VECTOR C (OF DIMENSION AT LEAST N) C INTO WHICH THE GENERATED C RANDOM SAMPLE WILL BE PLACED. C OUTPUT--A RANDOM SAMPLE OF SIZE N C FROM THE POWER LAW DISTRIBUTION C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C OTHER DATAPAC SUBROUTINES NEEDED--UNIRAN. C FORTRAN LIBRARY SUBROUTINES NEEDED--EXP C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--98.6 C ORIGINAL VERSION--JUNE 1998. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DIMENSION X(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(N.LT.1)THEN WRITE(ICOUT, 5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)N CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF 5 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ', 1'PWLRAN SUBROUTINE IS NON-POSITIVE *****') 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****') C C GENERATE N UNIFORM (0,1) RANDOM NUMBERS; C CALL UNIRAN(N,ISEED,X) C C POWER LAW RANDOM NUMBERS C C2=(1.0/BETA) X(1)=((-1.0/ALPHA)*LOG(X(1)))**C2 IF(N.EQ.1)GOTO9999 C DO200I=2,N C3=X(I-1) C4=(-1.0/ALPHA)*LOG(X(I)) X(I)=(C3**BETA + C4)**C2 200 CONTINUE C 9999 CONTINUE RETURN END REAL FUNCTION PYTHAG(A,B) C***BEGIN PROLOGUE PYTHAG C***REFER TO EISDOC C C Finds sqrt(A**2+B**2) without overflow or destructive underflow C***ROUTINES CALLED (NONE) C***END PROLOGUE PYTHAG REAL A,B C REAL P,Q,R,S,T C***FIRST EXECUTABLE STATEMENT PYTHAG P = AMAX1(ABS(A),ABS(B)) Q = AMIN1(ABS(A),ABS(B)) IF (Q .EQ. 0.0E0) GO TO 20 10 CONTINUE R = (Q/P)**2 T = 4.0E0 + R IF (T .EQ. 4.0E0) GO TO 20 S = R/T P = P + 2.0E0*P*S Q = Q*S GO TO 10 20 PYTHAG = P RETURN END function Qn(x,n,y,work,work2, & left,right,weight,q,p,iwork) C cc##################################################################### cc###################### file Qn.for : ############################## cc##################################################################### cc cc This file contains a Fortran function for a new robust estimator cc of scale denoted as Qn, proposed in Rousseeuw and Croux (1993). cc The estimator has a high breakdown point and a smooth and bounded cc influence function. The algorithm given here is very fast (running cc in O(nlogn) time) and needs only O(n) storage space. cc cc Rousseeuw, P.J. and Croux, C. (1993), "Alternatives to the cc Median Absolute Deviation," Journal of the American cc Statistical Association, Vol. 88, 1273-1283. cc cc A Fortran function for the estimator Sn, described in the same cc paper, is attached above. For both estimators, implementations cc in the Pascal language can be obtained from the authors. cc cc This software may be used and copied freely, provided cc reference is made to the abovementioned paper. cc cc For questions, problems or comments contact: cc cc Peter Rousseeuw (rousse@wins.uia.ac.be) cc Christophe Croux (croux@wins.uia.ac.be) cc Department of Mathematics and Computing cc Universitaire Instelling Antwerpen cc Universiteitsplein 1 cc B-2610 Wilrijk (Antwerp) cc Belgium cc cc-------------------------------------------------------------------- cc cc Efficient algorithm for the scale estimator: cc cc Qn = dn * 2.2219 * {|x_i-x_j|; i=2) cc cc The function Qn uses the procedures: cc whimed(a,iw,n): finds the weighted high median of an array cc a of length n, using the array iw (also of cc length n) with positive integer weights. cc sort(x,n,y) : sorts an array x of length n, and stores the cc result in an array y (of size at least n) cc pull(a,n,k) : finds the k-th order statistic of an cc array a of length n cc dimension x(*) dimension y(*),work(*),work2(*) integer left(*),right(*),weight(*),Q(*),P(*),iwork(*) ccccc dimension y(500),work(500) ccccc integer left(500),right(500),weight(500),Q(500),P(500) integer h,k,knew,jhelp,nL,nR,sumQ,sumP logical found h=n/2+1 k=h*(h-1)/2 call sort(x,n,y) do 20 i=1,n left(i)=n-i+2 right(i)=n 20 continue jhelp=n*(n+1)/2 knew=k+jhelp nL=jhelp nR=n*n found=.false. 200 continue if ( (nR-nL.gt.n).and.(.not.found) ) then j=1 do 30 i=2,n if (left(i).le.right(i)) then weight(j)=right(i)-left(i)+1 jhelp=left(i)+weight(j)/2 work(j)=y(i)-y(n+1-jhelp) j=j+1 endif 30 continue trial=whimed(work,weight,j-1,work2,iwork) j=0 do 40 i=n,1,-1 45 continue if ((j.lt.n).and.((y(i)-y(n-j)).lt.trial)) then j=j+1 goto 45 endif P(i)=j 40 continue j=n+1 do 50 i=1,n 55 continue if ((y(i)-y(n-j+2)).gt.trial) then j=j-1 goto 55 endif Q(i)=j 50 continue sumP=0 sumQ=0 do 60 i=1,n sumP=sumP+P(i) sumQ=sumQ+Q(i)-1 60 continue if (knew.le.sumP) then do 70 i=1,n right(i)=P(i) 70 continue nR=sumP else if (knew.gt.sumQ) then do 80 i=1,n left(i)=Q(i) 80 continue nL=sumQ else Qn=trial found=.true. endif endif goto 200 endif if (.not.found) then j=1 do 90 i=2,n if (left(i).le.right(i)) then do 100 jj=left(i),right(i) work(j)=y(i)-y(n-jj+1) j=j+1 100 continue endif 90 continue Qn=pull(work,j-1,knew-nL,work2) endif if (n.le.9) then if (n.eq.2) dn=0.399 if (n.eq.3) dn=0.994 if (n.eq.4) dn=0.512 if (n.eq.5) dn=0.844 if (n.eq.6) dn=0.611 if (n.eq.7) dn=0.857 if (n.eq.8) dn=0.669 if (n.eq.9) dn=0.872 else if (mod(n,2).eq.1) dn=n/(n+1.4) if (mod(n,2).eq.0) dn=n/(n+3.8) endif Qn=dn*2.2219*Qn return end SUBROUTINE QAGI(F,BOUND,INF,EPSABS,EPSREL,RESULT,ABSERR,NEVAL, 1 IER,LIMIT,LENW,LAST,IWORK,WORK) C C ADDED TO DATAPLOT 12/2003. THIS ROUTINE ADDED FOR INTERNAL C DATAPLOT USAGE. C C***BEGIN PROLOGUE QAGI C***DATE WRITTEN 800101 (YYMMDD) C***REVISION DATE 830518 (YYMMDD) C***CATEGORY NO. H2A3A1,H2A4A1 C***KEYWORDS AUTOMATIC INTEGRATOR,EXTRAPOLATION,GENERAL-PURPOSE, C GLOBALLY ADAPTIVE,INFINITE INTERVALS,TRANSFORMATION C***AUTHOR PIESSENS, ROBERT, APPLIED MATH. AND PROGR. DIV. - C K. U. LEUVEN C DE DONCKER, ELISE, APPLIED MATH. AND PROGR. DIV. - C K. U. LEUVEN C***PURPOSE The routine calculates an approximation result to a given C INTEGRAL I = Integral of F over (BOUND,+INFINITY) C OR I = Integral of F over (-INFINITY,BOUND) C OR I = Integral of F over (-INFINITY,+INFINITY) C Hopefully satisfying following claim for accuracy C ABS(I-RESULT).LE.MAX(EPSABS,EPSREL*ABS(I)). C***DESCRIPTION C C From the book "Numerical Methods and Software" C by D. Kahaner, C. Moler, S. Nash C Prentice Hall 1988 C C Integration over infinite intervals C Standard fortran subroutine C C PARAMETERS C ON ENTRY C F - Real C Function subprogram defining the integrand C function F(X). The actual name for F needs to be C declared E X T E R N A L in the driver program. C C BOUND - Real C Finite bound of integration range C (has no meaning if interval is doubly-infinite) C C INF - Integer C indicating the kind of integration range involved C INF = 1 corresponds to (BOUND,+INFINITY), C INF = -1 to (-INFINITY,BOUND), C INF = 2 to (-INFINITY,+INFINITY). C C EPSABS - Real C Absolute accuracy requested C EPSREL - Real C Relative accuracy requested C If EPSABS.LE.0 C and EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28), C the routine will end with IER = 6. C C C ON RETURN C RESULT - Real C Approximation to the integral C C ABSERR - Real C Estimate of the modulus of the absolute error, C which should equal or exceed ABS(I-RESULT) C C NEVAL - Integer C Number of integrand evaluations C C IER - Integer C IER = 0 normal and reliable termination of the C routine. It is assumed that the requested C accuracy has been achieved. C - IER.GT.0 abnormal termination of the routine. The C estimates for result and error are less C reliable. It is assumed that the requested C accuracy has not been achieved. C ERROR MESSAGES C IER = 1 Maximum number of subdivisions allowed C has been achieved. One can allow more C subdivisions by increasing the value of C LIMIT (and taking the according dimension C adjustments into account). However, if C this yields no improvement it is advised C to analyze the integrand in order to C determine the integration difficulties. If C the position of a local difficulty can be C determined (e.g. SINGULARITY, C DISCONTINUITY within the interval) one C will probably gain from splitting up the C interval at this point and calling the C integrator on the subranges. If possible, C an appropriate special-purpose integrator C should be used, which is designed for C handling the type of difficulty involved. C = 2 The occurrence of roundoff error is C detected, which prevents the requested C tolerance from being achieved. C The error may be under-estimated. C = 3 Extremely bad integrand behaviour occurs C at some points of the integration C interval. C = 4 The algorithm does not converge. C Roundoff error is detected in the C extrapolation table. C It is assumed that the requested tolerance C cannot be achieved, and that the returned C RESULT is the best which can be obtained. C = 5 The integral is probably divergent, or C slowly convergent. It must be noted that C divergence can occur with any other value C of IER. C = 6 The input is invalid, because C (EPSABS.LE.0 and C EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28)) C or LIMIT.LT.1 or LENIW.LT.LIMIT*4. C RESULT, ABSERR, NEVAL, LAST are set to C zero. Exept when LIMIT or LENIW is C invalid, IWORK(1), WORK(LIMIT*2+1) and C WORK(LIMIT*3+1) are set to ZERO, WORK(1) C is set to A and WORK(LIMIT+1) to B. C C DIMENSIONING PARAMETERS C LIMIT - Integer C Dimensioning parameter for IWORK C LIMIT determines the maximum number of subintervals C in the partition of the given integration interval C (A,B), LIMIT.GE.1. In many cases LIMIT = 100 is ok. C If LIMIT.LT.1, the routine will end with IER = 6. C C LENW - Integer C Dimensioning parameter for WORK C LENW must be at least LIMIT*4. C If LENW.LT.LIMIT*4, the routine will end C with IER = 6. C C LAST - Integer C On return, LAST equals the number of subintervals C produced in the subdivision process, which C determines the number of significant elements C actually in the WORK ARRAYS. C C WORK ARRAYS C IWORK - Integer C Vector of dimension at least LIMIT, the first C K elements of which contain pointers C to the error estimates over the subintervals, C such that WORK(LIMIT*3+IWORK(1)),... , C WORK(LIMIT*3+IWORK(K)) form a decreasing C sequence, with K = LAST if LAST.LE.(LIMIT/2+2), and C K = LIMIT+1-LAST otherwise C C WORK - Real C Vector of dimension at least LENW C on return C WORK(1), ..., WORK(LAST) contain the left C end points of the subintervals in the C partition of (A,B), C WORK(LIMIT+1), ..., WORK(LIMIT+LAST) Contain C the right end points, C WORK(LIMIT*2+1), ...,WORK(LIMIT*2+LAST) contain the C integral approximations over the subintervals, C WORK(LIMIT*3+1), ..., WORK(LIMIT*3) C contain the error estimates. C***REFERENCES (NONE) C***ROUTINES CALLED QAGIE,XERROR C***END PROLOGUE QAGI C REAL ABSERR,BOUND,EPSABS,EPSREL,F,RESULT,WORK INTEGER IER,INF,IWORK,LAST,LENW,LIMIT,LVL,L1,L2,L3,NEVAL C DIMENSION IWORK(LIMIT),WORK(LENW) C INCLUDE 'DPCOMC.INC' CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C EXTERNAL F C C CHECK VALIDITY OF LIMIT AND LENW. C C***FIRST EXECUTABLE STATEMENT QAGI IER = 6 NEVAL = 0 LAST = 0 RESULT = 0.0E+00 ABSERR = 0.0E+00 IF(LIMIT.LT.1.OR.LENW.LT.LIMIT*4) GO TO 10 C C PREPARE CALL FOR QAGIE. C L1 = LIMIT+1 L2 = LIMIT+L1 L3 = LIMIT+L2 C CALL QAGIE(F,BOUND,INF,EPSABS,EPSREL,LIMIT,RESULT,ABSERR, 1 NEVAL,IER,WORK(1),WORK(L1),WORK(L2),WORK(L3),IWORK,LAST) C C CALL ERROR HANDLER IF NECESSARY. C LVL = 0 10 IF(IER.EQ.6) LVL = 1 IF(IER.NE.0) THEN CCCCC CALL XERROR( 'ABNORMAL RETURN FROM QAGI', CCCCC1 26,IER,LVL) WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,901) 901 FORMAT('***** ERROR--ABNORMAL RETURN FROM QAGI INTEGRATION ', 1 'ROUTINE.') CALL DPWRST('XXX','BUG ') ENDIF RETURN END SUBROUTINE QAGIE(F,BOUND,INF,EPSABS,EPSREL,LIMIT,RESULT,ABSERR, 1 NEVAL,IER,ALIST,BLIST,RLIST,ELIST,IORD,LAST) C PART OF QAGI CODE. C***BEGIN PROLOGUE QAGIE C THIS PROLOGUE HAS BEEN REMOVED FOR REASONS OF SPACE C FOR A COMPLETE COPY OF THIS ROUTINE CONTACT THE AUTHORS C From the book "Numerical Methods and Software" C by D. Kahaner, C. Moler, S. Nash C Prentice Hall 1988 C***END PROLOGUE QAGIE C REAL ABSEPS,ABSERR,ALIST,AREA,AREA1,AREA12,AREA2,A1, 1 A2,BLIST,BOUN,BOUND,B1,B2,CORREC,DEFABS,DEFAB1,DEFAB2, 2 DRES,ELIST,EPMACH,EPSABS,EPSREL,ERLARG,ERLAST,ERRBND, 3 ERRMAX,ERROR1,ERROR2,ERRO12,ERRSUM,ERTEST,F,RESABS, 4 RESEPS,RESULT,RLIST,RLIST2,R1MACH,SMALL,UFLOW INTEGER ID,IER,IERR,IERRO,INF,IORD,IROFF1,IROFF2,IROFF3,JUPBND,K, 1 KSGN,KTMIN,LAST,LIMEXP,LIMIT,MAXERR,NEVAL,NRMAX LOGICAL EXTRAP,LERR,NEWFLG,NOEXT C PARAMETER (LIMEXP = 50) C C LIMEXP IS THE SIZE OF THE EPSILON TABLE THAT CAN BE C GENERATED IN EA C DIMENSION ALIST(LIMIT),BLIST(LIMIT),ELIST(LIMIT),IORD(LIMIT), 1 RLIST(LIMIT),RLIST2(LIMEXP+7) C INCLUDE 'DPCOMC.INC' CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C EXTERNAL F C C***FIRST EXECUTABLE STATEMENT QAGIE EPMACH = R1MACH(4) C C TEST ON VALIDITY OF PARAMETERS C ----------------------------- C IER = 0 NEVAL = 0 LAST = 0 RESULT = 0.0E+00 ABSERR = 0.0E+00 ALIST(1) = 0.0E+00 BLIST(1) = 0.1E+01 RLIST(1) = 0.0E+00 ELIST(1) = 0.0E+00 IORD(1) = 0 NEWFLG = .TRUE. IF(EPSABS.LE.0.0E+00.AND.EPSREL.LT.AMAX1(0.5E+02*EPMACH,0.5E-14)) 1 IER = 6 IF(IER.EQ.6) GO TO 999 C C C FIRST APPROXIMATION TO THE INTEGRAL C ----------------------------------- C C DETERMINE THE INTERVAL TO BE MAPPED ONTO (0,1). C IF INF = 2 THE INTEGRAL IS COMPUTED AS I = I1+I2, WHERE C I1 = INTEGRAL OF F OVER (-INFINITY,0), C I2 = INTEGRAL OF F OVER (0,+INFINITY). C BOUN = BOUND IF(INF.EQ.2) BOUN = 0.0E+00 CALL QK15I(F,BOUN,INF,0.0E+00,0.1E+01,RESULT,ABSERR, 1 DEFABS,RESABS) C C TEST ON ACCURACY C LAST = 1 RLIST(1) = RESULT ELIST(1) = ABSERR IORD(1) = 1 DRES = ABS(RESULT) ERRBND = AMAX1(EPSABS,EPSREL*DRES) IF(ABSERR.LE.1.0E+02*EPMACH*DEFABS.AND.ABSERR.GT. 1 ERRBND) IER = 2 IF(LIMIT.EQ.1) IER = 1 IF(IER.NE.0.OR.(ABSERR.LE.ERRBND.AND.ABSERR.NE.RESABS).OR. 1 ABSERR.EQ.0.0E+00) GO TO 130 C C INITIALIZATION C -------------- C UFLOW = R1MACH(1) * 0.2E+01 LERR = .FALSE. CALL EA(NEWFLG,RESULT,LIMEXP,RESEPS,ABSEPS,RLIST2,IERR) ERRMAX = ABSERR MAXERR = 1 AREA = RESULT ERRSUM = ABSERR NRMAX = 1 KTMIN = 0 EXTRAP = .FALSE. NOEXT = .FALSE. IERRO = 0 IROFF1 = 0 IROFF2 = 0 IROFF3 = 0 KSGN = -1 IF(DRES.GE.(0.1E+01-0.5E+02*EPMACH)*DEFABS) KSGN = 1 C C MAIN DO-LOOP C ------------ C DO 90 LAST = 2,LIMIT C C BISECT THE SUBINTERVAL WITH NRMAX-TH LARGEST C ERROR ESTIMATE. C A1 = ALIST(MAXERR) B1 = 0.5E+00*(ALIST(MAXERR)+BLIST(MAXERR)) A2 = B1 B2 = BLIST(MAXERR) ERLAST = ERRMAX CALL QK15I(F,BOUN,INF,A1,B1,AREA1,ERROR1,RESABS,DEFAB1) CALL QK15I(F,BOUN,INF,A2,B2,AREA2,ERROR2,RESABS,DEFAB2) C C IMPROVE PREVIOUS APPROXIMATIONS TO INTEGRAL C AND ERROR AND TEST FOR ACCURACY. C AREA12 = AREA1+AREA2 ERRO12 = ERROR1+ERROR2 ERRSUM = ERRSUM+ERRO12-ERRMAX AREA = AREA+AREA12-RLIST(MAXERR) IF(DEFAB1.EQ.ERROR1.OR.DEFAB2.EQ.ERROR2)GO TO 15 IF(ABS(RLIST(MAXERR)-AREA12).GT.0.1E-04*ABS(AREA12) 1 .OR.ERRO12.LT.0.99E+00*ERRMAX) GO TO 10 IF(EXTRAP) IROFF2 = IROFF2+1 IF(.NOT.EXTRAP) IROFF1 = IROFF1+1 10 IF(LAST.GT.10.AND.ERRO12.GT.ERRMAX) IROFF3 = IROFF3+1 15 RLIST(MAXERR) = AREA1 RLIST(LAST) = AREA2 ERRBND = AMAX1(EPSABS,EPSREL*ABS(AREA)) C C TEST FOR ROUNDOFF ERROR AND EVENTUALLY C SET ERROR FLAG. C IF(IROFF1+IROFF2.GE.10.OR.IROFF3.GE.20) IER = 2 IF(IROFF2.GE.5) IERRO = 3 C C SET ERROR FLAG IN THE CASE THAT THE NUMBER OF C SUBINTERVALS EQUALS LIMIT. C IF(LAST.EQ.LIMIT) IER = 1 C C SET ERROR FLAG IN THE CASE OF BAD INTEGRAND BEHAVIOUR C AT SOME POINTS OF THE INTEGRATION RANGE. C IF(AMAX1(ABS(A1),ABS(B2)).LE.(0.1E+01+0.1E+03*EPMACH)* 1 (ABS(A2)+0.1E+04*UFLOW)) IER = 4 C C APPEND THE NEWLY-CREATED INTERVALS TO THE LIST. C IF(ERROR2.GT.ERROR1) GO TO 20 ALIST(LAST) = A2 BLIST(MAXERR) = B1 BLIST(LAST) = B2 ELIST(MAXERR) = ERROR1 ELIST(LAST) = ERROR2 GO TO 30 20 ALIST(MAXERR) = A2 ALIST(LAST) = A1 BLIST(LAST) = B1 RLIST(MAXERR) = AREA2 RLIST(LAST) = AREA1 ELIST(MAXERR) = ERROR2 ELIST(LAST) = ERROR1 C C CALL SUBROUTINE QPSRT TO MAINTAIN THE DESCENDING ORDERING C IN THE LIST OF ERROR ESTIMATES AND SELECT THE C SUBINTERVAL WITH NRMAX-TH LARGEST ERROR ESTIMATE (TO BE C BISECTED NEXT). C 30 CALL QPSRT(LIMIT,LAST,MAXERR,ERRMAX,ELIST,IORD,NRMAX) IF(ERRSUM.LE.ERRBND) GO TO 115 IF(IER.NE.0) GO TO 100 IF(LAST.EQ.2) GO TO 80 IF(NOEXT) GO TO 90 ERLARG = ERLARG-ERLAST IF(ABS(B1-A1).GT.SMALL) ERLARG = ERLARG+ERRO12 IF(EXTRAP) GO TO 40 C C TEST WHETHER THE INTERVAL TO BE BISECTED NEXT IS THE C SMALLEST INTERVAL. C IF(ABS(BLIST(MAXERR)-ALIST(MAXERR)).GT.SMALL) GO TO 90 EXTRAP = .TRUE. NRMAX = 2 40 IF(IERRO.EQ.3.OR.ERLARG.LE.ERTEST) GO TO 60 C C THE SMALLEST INTERVAL HAS THE LARGEST ERROR. C BEFORE BISECTING DECREASE THE SUM OF THE ERRORS C OVER THE LARGER INTERVALS (ERLARG) AND PERFORM C EXTRAPOLATION. C ID = NRMAX JUPBND = LAST IF(LAST.GT.(2+LIMIT/2)) JUPBND = LIMIT+3-LAST DO 50 K = ID,JUPBND MAXERR = IORD(NRMAX) ERRMAX = ELIST(MAXERR) IF(ABS(BLIST(MAXERR)-ALIST(MAXERR)).GT.SMALL) GO TO 90 NRMAX = NRMAX+1 50 CONTINUE C C PERFORM EXTRAPOLATION. C 60 CALL EA(NEWFLG,AREA,LIMEXP,RESEPS,ABSEPS,RLIST2,IERR) KTMIN = KTMIN+1 IF((KTMIN.GT.5).AND.(ABSERR.LT.0.1E-02*ERRSUM).AND.(LERR)) 1 IER = 5 IF((ABSEPS.GE.ABSERR).AND.(LERR)) GO TO 70 KTMIN = 0 ABSERR = ABSEPS LERR = .TRUE. RESULT = RESEPS CORREC = ERLARG ERTEST = AMAX1(EPSABS,EPSREL*ABS(RESEPS)) IF((ABSERR.LE.ERTEST).AND.(LERR)) GO TO 100 C C PREPARE BISECTION OF THE SMALLEST INTERVAL. C 70 IF(RLIST2(LIMEXP+3).EQ.1) NOEXT = .TRUE. IF(IER.EQ.5) GO TO 100 MAXERR = IORD(1) ERRMAX = ELIST(MAXERR) NRMAX = 1 EXTRAP = .FALSE. SMALL = SMALL*0.5E+00 ERLARG = ERRSUM GO TO 90 80 SMALL = 0.375E+00 ERLARG = ERRSUM ERTEST = ERRBND CALL EA(NEWFLG,AREA,LIMEXP,RESEPS,ABSEPS,RLIST2,IERR) 90 CONTINUE C C SET FINAL RESULT AND ERROR ESTIMATE. C ------------------------------------ C 100 IF(.NOT.LERR) GO TO 115 IF((IER+IERRO).EQ.0) GO TO 110 IF(IERRO.EQ.3) ABSERR = ABSERR+CORREC IF(IER.EQ.0) IER = 3 IF(RESULT.NE.0.0E+00.AND.AREA.NE.0.0E+00)GO TO 105 IF(ABSERR.GT.ERRSUM)GO TO 115 IF(AREA.EQ.0.0E+00) GO TO 130 GO TO 110 105 IF(ABSERR/ABS(RESULT).GT.ERRSUM/ABS(AREA))GO TO 115 C C TEST ON DIVERGENCE C 110 IF(KSGN.EQ.(-1).AND.AMAX1(ABS(RESULT),ABS(AREA)).LE. 1 DEFABS*0.1E-01) GO TO 130 IF(0.1E-01.GT.(RESULT/AREA).OR.(RESULT/AREA).GT.0.1E+03. 1OR.ERRSUM.GT.ABS(AREA)) IER = 6 GO TO 130 C C COMPUTE GLOBAL INTEGRAL SUM. C 115 RESULT = 0.0E+00 DO 120 K = 1,LAST RESULT = RESULT+RLIST(K) 120 CONTINUE ABSERR = ERRSUM 130 NEVAL = 30*LAST-15 IF(INF.EQ.2) NEVAL = 2*NEVAL IF(IER.GT.2) IER=IER-1 999 RETURN END SUBROUTINE QBICDF(X,P,PHI,M,CDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION C FUNCTION VALUE FOR THE QUASI BINOMIAL-I C DISTRIBUTION WITH SHAPE PARAMETERS P, PHI, AND M. C C THE PROBABILITY MASS FUNCTION IS: C p(X;P,PHI,M)= C (M X)*P*(P+X*PHI)**(X-1)*(1-P-X*PHI)**(M-X) C X = 0, 1, 2, 3, ,..., M; C 0 <= P <= 1; -P/M < PHI < (1-P)/M; C C THE CUMULATIVE DISTRIBUTION PROBABILITIES CAN BE C COMPUTED WITH THE FOLLOWING RECURRENCE RELATION: C C p(x+1) = {(m-x)*(p+x*phi)/((x+1)*(1-p-x*phi))}* C (1 + phi/(p+x*phi))**x* C (1 - phi/(1-p-X*PHI))**(m-x-1)*p(x) C C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE AT C WHICH THE CUMULATIVE DISTRIBUTION C FUNCTION IS TO BE EVALUATED. C X SHOULD BE A NON-NEGATIVE INTEGER. C --P = THE FIRST SHAPE PARAMETER C --PHI = THE SECOND SHAPE PARAMETER C --M = THE THIRD SHAPE PARAMETER C OUTPUT ARGUMENTS--CDF = THE SINGLE PRECISION CUMULATIVE C DISTRIBUTION FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION FUNCTION C VALUE CDF FOR THE QUASI BINOMIAL-I C DISTRIBUTION WITH SHAPE PARAMETERS P, PHI AND M. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--X SHOULD BE A NON-NEGATIVE INTEGER C --0 <- P <= 1; -P/M < PHI < (1-P)/M C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--CONSUL AND FAMOYE (2006), "LAGRANGIAN PROBABILITY C DISTRIBUTIONS", BIRKHAUSER, PP. 70-80. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2006/7 C ORIGINAL VERSION--JULY 2006. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C REAL M C DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 DOUBLE PRECISION DTERM3 DOUBLE PRECISION DTERM4 DOUBLE PRECISION DX DOUBLE PRECISION DP DOUBLE PRECISION DPHI DOUBLE PRECISION DM DOUBLE PRECISION DCDF DOUBLE PRECISION DPDF DOUBLE PRECISION DPDFSV C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IX=INT(X+0.5) IF(IX.LT.0)THEN WRITE(ICOUT,4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9000 ENDIF 4 FORMAT('***** ERROR--THE FIRST ARGUMENT TO QBICDF IS LESS ', 1'THAN 0') C IF(P.LT.0.0 .OR. P.GT.1.0)THEN WRITE(ICOUT,15) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)P CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9000 ENDIF 15 FORMAT('***** ERROR--THE SECOND ARGUMENT TO QBICDF IS NOT IN ', 1'THE INTERVAL (0,1)') C IM=INT(M+0.5) M=REAL(IM) ALOWLM=-P/M AUPPLM=(1.0-P)/M IF(PHI.LE.ALOWLM .OR. PHI.GE.AUPPLM)THEN WRITE(ICOUT,25)ALOWLM,AUPPLM CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)PHI CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9000 ENDIF 25 FORMAT('***** ERROR--THE THIRD ARGUMENT TO QBICDF IS NOT IN ', 1'THE INTERVAL (',G15.7,',',G15.7,')') C IF(IM.LT.0)THEN WRITE(ICOUT,35) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)IM CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9000 ENDIF 35 FORMAT('***** ERROR--THE FOURTH ARGUMENT TO QBICDF IS ', 1'NON-POSITIVE') C 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7) C IF(IX.GE.IM)THEN CDF=1.0 GOTO9000 ENDIF C DP=DBLE(P) DPHI=DBLE(PHI) DM=DBLE(M) C DPDFSV=(1.0D0 - DP)**DM IF(IX.EQ.0)THEN CDF=REAL(DPDFSV) GOTO9000 ENDIF C DCDF=DPDFSV DO100I=1,IX DX=DBLE(I-1) DTERM1=DLOG(DM-DX) + DLOG(DP+DX*DPHI) - DLOG(DX+1.0D0) - 1 DLOG(1.0D0 - DP - DX*DPHI) DTERM2=DX*DLOG(1.0D0 + DPHI/(DP+DX*DPHI)) DTERM3=(DM-DX-1.0D0)*DLOG(1.0D0 - DPHI/(1.0D0 - DP - DX*DPHI)) IF(DPDFSV.GT.0.0D0)THEN DTERM4=DLOG(DPDFSV) DPDF=DEXP(DTERM1+DTERM2+DTERM3+DTERM4) ELSE CDF=REAL(DCDF) GOTO9000 ENDIF DCDF=DCDF + DPDF DPDFSV=DPDF 100 CONTINUE C CDF=REAL(DCDF) C 9000 CONTINUE RETURN END SUBROUTINE QBIFUN(N,XPAR,FVEC,IFLAG,Y,K) C C PURPOSE--THIS ROUTINE COMPUTES THE FUNCTIONS FOR THE C QUASI BINOMIAL TYPE I MAXIMUM LIKELIHOOD C EQUATIONS. C C THE MAXIMUM LIKELIHOOD ESTIMATES ARE THE SOLUTIONS C TO THE EQUATIONS: C C SUM[i=1 to N][(m-X(i))/(1 - P - X9i)*PHI] - M*N = 0 C C SUM[i=1 to N][(X(i)*(X(i) - 1)/(p + X(i)*PHI) - C SUM[i=1 to N][(M - X(i))/(1 - P - X(i)*PHI)] = 0 C C NOTE THAT M IS ASSUMED FIXED AND KNOWN AND WE ARE C SOLVING FOR P AND PHI. C C WHEN THE DATA IS BINNED, THE MAXIMUM LIKELIHOOD C EQUATIONS BECOME C C SUM[i=1 to k][N(i)*(i-1)*i/(p+i*PHI)] - C SUM[i=1 to k][N(i)*(M-i)*i/(1-p-i*PHI)] = 0 C C (N/P) - SUM[i=1 to k][N(i)*(i-1)/(p+i*PHI)] - C SUM[i=1 to k][N(i)*(i-1)/(P+i*PHI) - C SUM[i=1 to k][N(i)*(M-i)/(1-P-i*PHI)] = 0 C C ROUTINE ASSUMES THE DATA IS IN THE FORM C C X(I) FREQ(I) C C CALLED BY DNSQE ROUTINE FOR SOLVING SIMULTANEOUS C NONLINEAR EQUATIONS. NOTE THAT THE CALLING SEQUENCE C DID NOT ACCOMODATE A DATA ARRAY (AND ASSCIATED NUMBER OF C OBSERVATIONS), SO THESE WERE ADDED TO THE CALL LIST. C SINCE DNSQE ONLY PASSES ONE ARRAY, WE SPLIT INTO C TWO PARTS: 1 - MAXNXT/2 ARE THE FREQUENCIES WHILE C (MAXNXT/2 + 1) - MAXNXT ARE THE CLASS VALUES (I.E., C THE X). C EXAMPLE--QUASI BINOMIAL TYPE I MAXIMUM LIKELIHOOD Y C REFERENCES--CONSUL AND FAMOYE (2006), "LAGRANGIAN PROBABILITY C DISTRIBUTIONS", BIRKHAUSER, PP. 70 - 80. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBUG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2006/7 C ORIGINAL VERSION--JULY 2006. C C--------------------------------------------------------------------- C DOUBLE PRECISION XPAR(*) DOUBLE PRECISION FVEC(*) REAL Y(*) C DOUBLE PRECISION DX DOUBLE PRECISION DP DOUBLE PRECISION DPHI DOUBLE PRECISION DN DOUBLE PRECISION DI DOUBLE PRECISION DSUM1 DOUBLE PRECISION DSUM2 DOUBLE PRECISION DSUM3 DOUBLE PRECISION DSUM4 C DOUBLE PRECISION DM DOUBLE PRECISION F0FREQ COMMON/QBICOM/DM,F0FREQ,MAXROW,NTOT2 C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C COMPUTE SOME SUMS C IINDX=MAXROW/2 C DP=XPAR(1) DPHI=XPAR(2) DN=DBLE(NTOT2) C DSUM1=0.0D0 DSUM2=0.0D0 DSUM3=0.0D0 DSUM4=0.0D0 C DO100I=1,K DX=DBLE(Y(IINDX+I)) DFREQ=DBLE(Y(I)) IF(DFREQ.EQ.0.0D0)GOTO100 DSUM1=DSUM1 + DFREQ*(DX-1.0D0)*DX/(DP+DX*DPHI) DSUM2=DSUM2 + DFREQ*(DM-DX)*DX/(1.0D0-DP-DX*DPHI) DSUM3=DSUM3 + DFREQ*(DX-1.0D0)/(DP+DX*DPHI) DSUM4=DSUM4 + DFREQ*(DM-DX)/(1.0D0-DP-DX*DPHI) 100 CONTINUE C FVEC(1)=DSUM1 - DSUM2 FVEC(2)=(DN/DP) + DSUM3 - DSUM4 C RETURN END SUBROUTINE QBIPDF(X,P,PHI,M,PDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY MASS C FUNCTION VALUE FOR THE QUASI BINOMIAL-I C DISTRIBUTION WITH SHAPE PARAMETERS P, PHI, AND M. C C THE PROBABILITY MASS FUNCTION IS: C p(X;P,PHI,M)= C (M X)*P*(P+X*PHI)**(X-1)*(1-P-X*PHI)**(M-X) C X = 0, 1, 2, 3, ,..., M; C 0 <= P <= 1; -P/M < PHI < (1-P)/M; C C THIS DISTRIBUTION IS USED TO MODEL BERNOULLI TRIALS C WHERE THE PROBABILITY OF SUCCESS PARAMETER IS C INCREASING (OR DECREASING) FOR SUCCESSIVE TRIALS. C C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE AT C WHICH THE PROBABILITY MASS C FUNCTION IS TO BE EVALUATED. C X SHOULD BE A NON-NEGATIVE INTEGER. C --P = THE FIRST SHAPE PARAMETER C --PHI = THE SECOND SHAPE PARAMETER C --M = THE THIRD SHAPE PARAMETER C OUTPUT ARGUMENTS--PDF = THE SINGLE PRECISION PROBABILITY C MASS FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION PROBABILITY MASS FUNCTION C VALUE PDF FOR THE QUASI BINOMIAL-I C DISTRIBUTION WITH SHAPE PARAMETERS P, PHI AND M. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--X SHOULD BE A NON-NEGATIVE INTEGER C --0 <- P <= 1; -P/M < PHI < (1-P)/M C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--CONSUL AND FAMOYE (2006), "LAGRANGIAN PROBABILITY C DISTRIBUTIONS", BIRKHAUSER, PP. 70-80. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2006/7 C ORIGINAL VERSION--JULY 2006. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C REAL M C DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 DOUBLE PRECISION DTERM3 DOUBLE PRECISION DTERM4 DOUBLE PRECISION DSUM DOUBLE PRECISION DX DOUBLE PRECISION DP DOUBLE PRECISION DPHI DOUBLE PRECISION DM DOUBLE PRECISION DPDF DOUBLE PRECISION DBINLN EXTERNAL DBINLN C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IX=INT(X+0.5) IF(IX.LT.0)THEN WRITE(ICOUT,4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9000 ENDIF 4 FORMAT('***** ERROR--THE FIRST ARGUMENT TO QBIPDF IS LESS ', 1'THAN 0') C IF(P.LT.0.0 .OR. P.GT.1.0)THEN WRITE(ICOUT,15) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)P CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9000 ENDIF 15 FORMAT('***** ERROR--THE SECOND ARGUMENT TO QBIPDF IS NOT IN ', 1'THE INTERVAL (0,1)') C IM=INT(M+0.5) M=REAL(IM) ALOWLM=-P/M AUPPLM=(1.0-P)/M IF(PHI.LE.ALOWLM .OR. PHI.GE.AUPPLM)THEN WRITE(ICOUT,25)ALOWLM,AUPPLM CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)PHI CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9000 ENDIF 25 FORMAT('***** ERROR--THE THIRD ARGUMENT TO QBIPDF IS NOT IN ', 1'THE INTERVAL (',G15.7,',',G15.7,')') C IF(IM.LT.0)THEN WRITE(ICOUT,35) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)IM CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9000 ENDIF 35 FORMAT('***** ERROR--THE FOURTH ARGUMENT TO QBIPDF IS ', 1'NON-POSITIVE') C 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7) C DP=DBLE(P) DPHI=DBLE(PHI) DM=DBLE(M) DX=DBLE(IX) C DTERM1=DBINLN(IM,IX) DTERM2=DLOG(DP) DTERM3=(DX-1.0D0)*DLOG(DP + DX*DPHI) DTERM4=(DM-DX)*DLOG(1.0D0 - DP - DX*DPHI) DPDF=DEXP(DTERM1+DTERM2+DTERM3+DTERM4) C PDF=REAL(DPDF) C 9000 CONTINUE RETURN END SUBROUTINE QBIPPF(P,PPAR,PHI,M,PPF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT C FUNCTION VALUE FOR THE QUASI BINOMIAL-I C DISTRIBUTION WITH SHAPE PARAMETERS P, PHI, AND M. C C THE PROBABILITY MASS FUNCTION IS: C p(X;P,PHI,M)= C (M X)*P*(P+X*PHI)**(X-1)*(1-P-X*PHI)**(M-X) C X = 0, 1, 2, 3, ,..., M; C 0 <= P <= 1; -P/M < PHI < (1-P)/M; C C THE CUMULATIVE DISTRIBUTION PROBABILITIES CAN BE C COMPUTED WITH THE FOLLOWING RECURRENCE RELATION: C C p(x+1) = {(m-x)*(p+x*phi)/((x+1)*(1-p-x*phi))}* C (1 + phi/(p+x*phi))**x* C (1 - phi/(1-p-X*PHI))**(m-x-1)*p(x) C C THE PERCENT POINT FUNCTION IS COMPUTED BY SUMMING C THESE CUMULATIVE PROBABILITIES UNTIL AN C APPROPRIATE PROBABILITY HAS BEEN OBTAINED. C C INPUT ARGUMENTS--P = THE SINGLE PRECISION VALUE AT C WHICH THE PERCENT POINT C FUNCTION IS TO BE EVALUATED. C --PPAR = THE FIRST SHAPE PARAMETER C --PHI = THE SECOND SHAPE PARAMETER C --M = THE THIRD SHAPE PARAMETER C OUTPUT ARGUMENTS--PPF = THE SINGLE PRECISION PERCENT POINT C FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION PERCENT POINT FUNCTION C VALUE PPF FOR THE QUASI BINOMIAL-I C DISTRIBUTION WITH SHAPE PARAMETERS P, PHI AND M. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--0 <= P <= 1 C --0 <- P <= 1; -P/M < PHI < (1-P)/M C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--CONSUL AND FAMOYE (2006), "LAGRANGIAN PROBABILITY C DISTRIBUTIONS", BIRKHAUSER, PP. 70-80. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2006/7 C ORIGINAL VERSION--JULY 2006. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C REAL M C DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 DOUBLE PRECISION DTERM3 DOUBLE PRECISION DTERM4 DOUBLE PRECISION DX DOUBLE PRECISION DP DOUBLE PRECISION DPPAR DOUBLE PRECISION DPHI DOUBLE PRECISION DM DOUBLE PRECISION DPPF DOUBLE PRECISION DCDF DOUBLE PRECISION DPDF DOUBLE PRECISION DPDFSV C C--------------------------------------------------------------------- C INCLUDE 'DPCOMC.INC' C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(P.LT.0.0 .OR. P.GT.1.0)THEN WRITE(ICOUT,4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)P CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9000 ENDIF 4 FORMAT('***** ERROR--THE FIRST ARGUMENT TO QBIPPF IS OUTSIDE ', 1'THE (0,1) INTERVAL') C IF(PPAR.LT.0.0 .OR. PPAR.GT.1.0)THEN WRITE(ICOUT,15) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)P CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9000 ENDIF 15 FORMAT('***** ERROR--THE SECOND ARGUMENT TO QBIPPF IS NOT IN ', 1'THE INTERVAL (0,1)') C IM=INT(M+0.5) M=REAL(IM) ALOWLM=-PPAR/M AUPPLM=(1.0-PPAR)/M IF(PHI.LE.ALOWLM .OR. PHI.GE.AUPPLM)THEN WRITE(ICOUT,25)ALOWLM,AUPPLM CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)PHI CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9000 ENDIF 25 FORMAT('***** ERROR--THE THIRD ARGUMENT TO QBIPPF IS NOT IN ', 1'THE INTERVAL (',G15.7,',',G15.7,')') C IF(IM.LT.0)THEN WRITE(ICOUT,35) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)IM CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9000 ENDIF 35 FORMAT('***** ERROR--THE FOURTH ARGUMENT TO QBIPPF IS ', 1'NON-POSITIVE') C 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7) C C HANDLE THE P = 0 AND P = 1 CASES IMMEDIATELY C IF(P.LE.0.0)THEN PPF=0.0 GOTO9000 ELSEIF(P.GE.1.0)THEN PPF=M GOTO9000 ENDIF C DP=DBLE(P) DPPAR=DBLE(PPAR) DPHI=DBLE(PHI) DM=DBLE(M) C DCDF=(1.0D0 - DPPAR)**DM IF(DCF.GE.DP)THEN PPF=0.0 GOTO9000 ENDIF DPDFSV=DCDF C I=0 100 CONTINUE I=I+1 IF(DBLE(I).GE.DBLE(I1MACH(9)))THEN WRITE(ICOUT,55) 55 FORMAT('***** ERROR--THE COMPUTED PERCENT POINT VALUE ', 1 'EXCEEDS THE LARGEST MACHINE INTEGER.') CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9000 ENDIF DX=DBLE(I-1) DTERM1=DLOG(DM-DX) + DLOG(DPPAR+DX*DPHI) - DLOG(DX+1.0D0) - 1 DLOG(1.0D0 - DPPAR - DX*DPHI) DTERM2=DX*DLOG(1.0D0 + DPHI/(DPPAR+DX*DPHI)) DTERM3=(DM-DX-1.0D0)*DLOG(1.0D0-DPHI/(1.0D0-DPPAR-DX*DPHI)) IF(DPDFSV.GT.0.0D0)THEN DTERM4=DLOG(DPDFSV) DPDF=DEXP(DTERM1+DTERM2+DTERM3+DTERM4) ELSE DPDF=0.0D0 GOTO1000 ENDIF 1000 CONTINUE DCDF=DCDF + DPDF DPDFSV=DPDF IF(DCDF.GE.DP)THEN PPF=REAL(I) GOTO9000 ENDIF GOTO100 C PPF=REAL(DPPF) C 9000 CONTINUE RETURN END SUBROUTINE QBIRAN(N,P,PHI,AM,ISEED,X) C C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N C FROM THE QUASI BINOMIAL TYPE I DISTRIBUTION C WITH SHAPE PARAMETERS P, PHI, AND M. C C THE PROBABILITY MASS FUNCTION IS: C p(X;P,PHI,M)= C (M X)*P*(P+X*PHI)**(X-1)*(1-P-X*PHI)**(M-X) C X = 0, 1, 2, 3, ,..., M; C 0 <= P <= 1; -P/M < PHI < (1-P)/M; C C C INPUT ARGUMENTS--N = THE DESIRED INTEGER NUMBER C OF RANDOM NUMBERS TO BE C GENERATED. C --P = THE SINGLE PRECISION VALUE C OF THE FIRST SHAPE PARAMETER. C --PHI = THE SINGLE PRECISION VALUE C OF THE SECOND SHAPE PARAMETER. C --AM = THE SINGLE PRECISION VALUE C OF THE THIRD SHAPE PARAMETER. C OUTPUT ARGUMENTS--X = A SINGLE PRECISION VECTOR C (OF DIMENSION AT LEAST N) C INTO WHICH THE GENERATED C RANDOM SAMPLE WILL BE PLACED. C OUTPUT--A RANDOM SAMPLE OF SIZE N C FROM THE QUASI BINOMIAL TYPE I DISTRIBUTION C WITH SHAPE PARAMETERS P, PHI, AND M. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C --0 <= P <= 1, -P/M < PHI < (1-P)/M; M >= 0 C OTHER DATAPAC SUBROUTINES NEEDED--UNIRAN, QBIPPF C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--CONSUL AND FAMOYE (2006), "LAGRANGIAN PROBABILITY C DISTRIBUTIONS", BIRKHAUSER, PP. 70-80. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2006/7 C ORIGINAL VERSION--JULY 2006. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C REAL P REAL PHI REAL AM DIMENSION X(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(N.LT.1)THEN WRITE(ICOUT,5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,6) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)N CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF 5 FORMAT('***** ERROR--THE REQUESTED NUMBER OF ', 1'QUASI BINOMIAL TYPE I') 6 FORMAT(' RANDOM NUMBERS IS NON-POSITIVE') C IM=INT(AM+0.5) AM=REAL(IM) ALOWLM=-P/AM AUPPLM=(1.0-P)/AM IF(P.LT.0.0 .OR. P.GT.1.0)THEN WRITE(ICOUT,11) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)P CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF 11 FORMAT('***** ERROR--THE P PARAMETER FOR THE ', 1'QUASI BINOMIAL TYPE I') 12 FORMAT(' RANDOM NUMBERS IS OUTSIDE THE (0,1) INTERVAL') C IM=INT(AM+0.5) AM=REAL(IM) ALOWLM=-P/AM AUPPLM=(1.0-P)/AM IF(PHI.LE.ALOWLM .OR. PHI.GE.AUPPLM)THEN WRITE(ICOUT,21) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,22)ALOWLM,AUPPLM CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)PHI CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF 21 FORMAT('***** ERROR--THE PHI PARAMETER FOR THE ', 1'QUASI BINOMIAL TYPE I') 22 FORMAT(' RANDOM NUMBERS IS OUTSIDE THE (',G15.7, 1 ',',G15.7,') INTERVAL') C IF(AM.LT.0.0)THEN WRITE(ICOUT,31) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,32) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)AM CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF 31 FORMAT('***** ERROR--THE M PARAMETER FOR THE ', 1'QUASI BINOMIAL TYPE I') 32 FORMAT(' RANDOM NUMBERS IS NON-POSITIVE.') C 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7) 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8) C C GENERATE N QUASI BINOMIAL TYPE I DISTRIBUTION C RANDOM NUMBERS. FOLLOWING RECOMMENDATION OF CONSUL AND C FAYMOE, USE INVERSION METHOD FOR P*PHI <= 0.60 AND C BRANCHING METHOD OTHERWISE. C C BRANCHING ALGORITHM DOESN'T SEEM TO RETURN AS ACCURATE C A RESULT AS THE INVERSION METHOD, SO USE THE INVERSION C METHOD EVEN IF SOMEWHAT SLOWER. C CALL UNIRAN(N,ISEED,X) DO100I=1,N ZTEMP=X(I) CALL QBIPPF(ZTEMP,P,PHI,AM,PPF) X(I)=PPF 100 CONTINUE C 9999 CONTINUE C RETURN END SUBROUTINE QK15I(F,BOUN,INF,A,B,RESULT,ABSERR,RESABS,RESASC) C PART OF QAGI CODE. C***BEGIN PROLOGUE QK15I C THIS PROLOGUE HAS BEEN REMOVED FOR REASONS OF SPACE C FOR A COMPLETE COPY OF THIS ROUTINE CONTACT THE AUTHORS C From the book "Numerical Methods and Software" C by D. Kahaner, C. Moler, S. Nash C Prentice Hall 1988 C***END PROLOGUE QK15I C REAL A,ABSC,ABSC1,ABSC2,ABSERR,B,BOUN,CENTR, 1 DINF,R1MACH,EPMACH,F,FC,FSUM,FVAL1,FVAL2,FV1, 2 FV2,HLGTH,RESABS,RESASC,RESG,RESK,RESKH,RESULT,TABSC1,TABSC2, 3 UFLOW,WG,WGK,XGK INTEGER INF,J,MIN0 C INCLUDE 'DPCOMC.INC' CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C EXTERNAL F C DIMENSION FV1(7),FV2(7),XGK(8),WGK(8),WG(8) C C DATA XGK(1),XGK(2),XGK(3),XGK(4),XGK(5),XGK(6),XGK(7), 1 XGK(8)/ 2 0.9914553711208126E+00, 0.9491079123427585E+00, 3 0.8648644233597691E+00, 0.7415311855993944E+00, 4 0.5860872354676911E+00, 0.4058451513773972E+00, 5 0.2077849550078985E+00, 0.0000000000000000E+00/ C DATA WGK(1),WGK(2),WGK(3),WGK(4),WGK(5),WGK(6),WGK(7), 1 WGK(8)/ 2 0.2293532201052922E-01, 0.6309209262997855E-01, 3 0.1047900103222502E+00, 0.1406532597155259E+00, 4 0.1690047266392679E+00, 0.1903505780647854E+00, 5 0.2044329400752989E+00, 0.2094821410847278E+00/ C DATA WG(1),WG(2),WG(3),WG(4),WG(5),WG(6),WG(7),WG(8)/ 1 0.0000000000000000E+00, 0.1294849661688697E+00, 2 0.0000000000000000E+00, 0.2797053914892767E+00, 3 0.0000000000000000E+00, 0.3818300505051189E+00, 4 0.0000000000000000E+00, 0.4179591836734694E+00/ C C C***FIRST EXECUTABLE STATEMENT QK15I EPMACH = R1MACH(4) UFLOW = R1MACH(1) DINF = MIN0(1,INF) C CENTR = 0.5E+00*(A+B) HLGTH = 0.5E+00*(B-A) TABSC1 = BOUN+DINF*(0.1E+01-CENTR)/CENTR FVAL1 = F(TABSC1) IF(INF.EQ.2) FVAL1 = FVAL1+F(-TABSC1) FC = (FVAL1/CENTR)/CENTR C C COMPUTE THE 15-POINT KRONROD APPROXIMATION TO C THE INTEGRAL, AND ESTIMATE THE ERROR. C RESG = WG(8)*FC RESK = WGK(8)*FC RESABS = ABS(RESK) DO 10 J=1,7 ABSC = HLGTH*XGK(J) ABSC1 = CENTR-ABSC ABSC2 = CENTR+ABSC TABSC1 = BOUN+DINF*(0.1E+01-ABSC1)/ABSC1 TABSC2 = BOUN+DINF*(0.1E+01-ABSC2)/ABSC2 FVAL1 = F(TABSC1) FVAL2 = F(TABSC2) IF(INF.EQ.2) FVAL1 = FVAL1+F(-TABSC1) IF(INF.EQ.2) FVAL2 = FVAL2+F(-TABSC2) FVAL1 = (FVAL1/ABSC1)/ABSC1 FVAL2 = (FVAL2/ABSC2)/ABSC2 FV1(J) = FVAL1 FV2(J) = FVAL2 FSUM = FVAL1+FVAL2 RESG = RESG+WG(J)*FSUM RESK = RESK+WGK(J)*FSUM RESABS = RESABS+WGK(J)*(ABS(FVAL1)+ABS(FVAL2)) 10 CONTINUE RESKH = RESK*0.5E+00 RESASC = WGK(8)*ABS(FC-RESKH) DO 20 J=1,7 RESASC = RESASC+WGK(J)*(ABS(FV1(J)-RESKH)+ABS(FV2(J)-RESKH)) 20 CONTINUE RESULT = RESK*HLGTH RESASC = RESASC*HLGTH RESABS = RESABS*HLGTH ABSERR = ABS((RESK-RESG)*HLGTH) IF(RESASC.NE.0.0E+00.AND.ABSERR.NE.0.E0) ABSERR = RESASC* 1 AMIN1(0.1E+01,(0.2E+03*ABSERR/RESASC)**1.5E+00) IF(RESABS.GT.UFLOW/(0.5E+02*EPMACH)) ABSERR = AMAX1 1 ((EPMACH*0.5E+02)*RESABS,ABSERR) RETURN END SUBROUTINE QPSRT(LIMIT,LAST,MAXERR,ERMAX,ELIST,IORD,NRMAX) C***BEGIN PROLOGUE QPSRT C PART OF QAGI CODE. C THIS PROLOGUE HAS BEEN REMOVED FOR REASONS OF SPACE C FOR A COMPLETE COPY OF THIS ROUTINE CONTACT THE AUTHORS C From the book "Numerical Methods and Software" C by D. Kahaner, C. Moler, S. Nash C Prentice Hall 1988 C***END PROLOGUE QPSRT C REAL ELIST,ERMAX,ERRMAX,ERRMIN INTEGER I,IBEG,IDO,IORD,ISUCC,J,JBND,JUPBN,K,LAST,LIMIT,MAXERR, 1 NRMAX DIMENSION ELIST(LAST),IORD(LAST) C INCLUDE 'DPCOMC.INC' CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C CHECK WHETHER THE LIST CONTAINS MORE THAN C TWO ERROR ESTIMATES. C C***FIRST EXECUTABLE STATEMENT QPSRT IF(LAST.GT.2) GO TO 10 IORD(1) = 1 IORD(2) = 2 GO TO 90 C C THIS PART OF THE ROUTINE IS ONLY EXECUTED C IF, DUE TO A DIFFICULT INTEGRAND, SUBDIVISION C INCREASED THE ERROR ESTIMATE. IN THE NORMAL CASE C THE INSERT PROCEDURE SHOULD START AFTER THE C NRMAX-TH LARGEST ERROR ESTIMATE. C 10 ERRMAX = ELIST(MAXERR) IF(NRMAX.EQ.1) GO TO 30 IDO = NRMAX-1 DO 20 I = 1,IDO ISUCC = IORD(NRMAX-1) C ***JUMP OUT OF DO-LOOP IF(ERRMAX.LE.ELIST(ISUCC)) GO TO 30 IORD(NRMAX) = ISUCC NRMAX = NRMAX-1 20 CONTINUE C C COMPUTE THE NUMBER OF ELEMENTS IN THE LIST TO C BE MAINTAINED IN DESCENDING ORDER. THIS NUMBER C DEPENDS ON THE NUMBER OF SUBDIVISIONS STILL C ALLOWED. C 30 JUPBN = LAST IF(LAST.GT.(LIMIT/2+2)) JUPBN = LIMIT+3-LAST ERRMIN = ELIST(LAST) C C INSERT ERRMAX BY TRAVERSING THE LIST TOP-DOWN, C STARTING COMPARISON FROM THE ELEMENT ELIST(IORD(NRMAX+1)). C JBND = JUPBN-1 IBEG = NRMAX+1 IF(IBEG.GT.JBND) GO TO 50 DO 40 I=IBEG,JBND ISUCC = IORD(I) C ***JUMP OUT OF DO-LOOP IF(ERRMAX.GE.ELIST(ISUCC)) GO TO 60 IORD(I-1) = ISUCC 40 CONTINUE 50 IORD(JBND) = MAXERR IORD(JUPBN) = LAST GO TO 90 C C INSERT ERRMIN BY TRAVERSING THE LIST BOTTOM-UP. C 60 IORD(I-1) = MAXERR K = JBND DO 70 J=I,JBND ISUCC = IORD(K) C ***JUMP OUT OF DO-LOOP IF(ERRMIN.LT.ELIST(ISUCC)) GO TO 80 IORD(K+1) = ISUCC K = K-1 70 CONTINUE IORD(I) = LAST GO TO 90 80 IORD(K+1) = LAST C C SET MAXERR AND ERMAX. C 90 MAXERR = IORD(NRMAX) ERMAX = ELIST(MAXERR) RETURN END SUBROUTINE QRAUX1(NR,N,R,I) IMPLICIT DOUBLE PRECISION (A-H,O-Z) C C PURPOSE C ------- C INTERCHANGE ROWS I,I+1 OF THE UPPER HESSENBERG MATRIX R, C COLUMNS I TO N C C PARAMETERS C ---------- C NR --> ROW DIMENSION OF MATRIX C N --> DIMENSION OF MATRIX C R(N,N) <--> UPPER HESSENBERG MATRIX C I --> INDEX OF ROW TO INTERCHANGE (I.LT.N) C DIMENSION R(NR,1) DO 10 J=I,N TMP=R(I,J) R(I,J)=R(I+1,J) R(I+1,J)=TMP 10 CONTINUE RETURN END SUBROUTINE QRAUX2(NR,N,R,I,A,B) IMPLICIT DOUBLE PRECISION (A-H,O-Z) C C PURPOSE C ------- C PRE-MULTIPLY R BY THE JACOBI ROTATION J(I,I+1,A,B) C C PARAMETERS C ---------- C NR --> ROW DIMENSION OF MATRIX C N --> DIMENSION OF MATRIX C R(N,N) <--> UPPER HESSENBERG MATRIX C I --> INDEX OF ROW C A --> SCALAR C B --> SCALAR C DIMENSION R(NR,1) DEN=SQRT(A*A + B*B) C=A/DEN S=B/DEN DO 10 J=I,N Y=R(I,J) Z=R(I+1,J) R(I,J)=C*Y - S*Z R(I+1,J)=S*Y + C*Z 10 CONTINUE RETURN END SUBROUTINE QRUPDT(NR,N,A,U,V) IMPLICIT DOUBLE PRECISION (A-H,O-Z) C C PURPOSE C ------- C FIND AN ORTHOGONAL (N*N) MATRIX (Q*) AND AN UPPER TRIANGULAR (N*N) C MATRIX (R*) SUCH THAT (Q*)(R*)=R+U(V+) C C PARAMETERS C ---------- C NR --> ROW DIMENSION OF MATRIX C N --> DIMENSION OF PROBLEM C A(N,N) <--> ON INPUT: CONTAINS R C ON OUTPUT: CONTAINS (R*) C U(N) --> VECTOR C V(N) --> VECTOR C DIMENSION A(NR,1) DIMENSION U(N),V(N) C C DETERMINE LAST NON-ZERO IN U(.) C K=N 10 IF(U(K).NE.0. .OR. K.EQ.1) GO TO 20 C IF(U(K).EQ.0. .AND. K.GT.1) C THEN K=K-1 GO TO 10 C ENDIF C C (K-1) JACOBI ROTATIONS TRANSFORM C R + U(V+) --> (R*) + (U(1)*E1)(V+) C WHICH IS UPPER HESSENBERG C 20 IF(K.LE.1) GO TO 40 KM1=K-1 DO 30 II=1,KM1 I=KM1-II+1 IF(U(I).NE.0.) GO TO 25 C IF(U(I).EQ.0.) C THEN CALL QRAUX1(NR,N,A,I) U(I)=U(I+1) GO TO 30 C ELSE 25 CALL QRAUX2(NR,N,A,I,U(I),-U(I+1)) U(I)=SQRT(U(I)*U(I) + U(I+1)*U(I+1)) C ENDIF 30 CONTINUE C ENDIF C C R <-- R + (U(1)*E1)(V+) C 40 DO 50 J=1,N A(1,J)=A(1,J) +U(1)*V(J) 50 CONTINUE C C (K-1) JACOBI ROTATIONS TRANSFORM UPPER HESSENBERG R C TO UPPER TRIANGULAR (R*) C IF(K.LE.1) GO TO 100 KM1=K-1 DO 80 I=1,KM1 IF(A(I,I).NE.0.) GO TO 70 C IF(A(I,I).EQ.0.) C THEN CALL QRAUX1(NR,N,A,I) GO TO 80 C ELSE 70 T1=A(I,I) T2=-A(I+1,I) CALL QRAUX2(NR,N,A,I,T1,T2) C ENDIF 80 CONTINUE C ENDIF 100 RETURN END double precision function qtrng(p, v, r, ifault) implicit double precision (a-h, o-z) c c Algorithm AS 190.1 Appl. Statist. (1983) Vol.32, No. 2 c c Approximates the quantile p for a studentized range c distribution having v degrees of freedom and r samples c for probability p, p.ge.0.90 .and. p.le.0.99. c c Uses functions alnorm, ppnd, prtrng and qtrng0 - c Algorithms AS 66, AS 111, AS 190 and AS 190.2 c double precision p, v, r, pcut, p75, p80, p90, p99, p995 double precision p175, one, two, five double precision q1, p1, q2, p2, e1, e2 double precision eps data jmax, pcut, p75, p80, p90, p99, p995, p175, one, two, five # /8, 0.001d0, 0.75d0, 0.80d0, 0.90d0, 0.99d0, 0.995d0, 1.75d0, # 1.0d0, 2.0d0, 5.0d0/ data eps/1.0d-4/ c c Check input parameters c ifault = 0 nfault = 0 if (v .lt. one .or. r.lt. two) ifault = 1 if (p .lt. p90 .or. p .gt. p99) ifault = 2 if (ifault .ne. 0) goto 99 c c Obtain initial values c q1 = qtrng0(p, v, r, nfault) if (nfault .ne. 0) goto 99 p1 = prtrng(q1, v, r, nfault) if (nfault .ne. 0) goto 99 qtrng = q1 if (abs(p1-p) .lt. pcut) goto 99 if (p1 .gt. p) p1 = p175 * p - p75 * p1 if (p1 .lt. p) p2 = p + (p - p1) * (one - p) / (one - p1) * p75 if (p2 .lt. p80) p2 = p80 if (p2 .gt. p995) p2 = p995 q2 = qtrng0(p2, v, r, nfault) if (nfault .ne. 0) goto 99 c c Refine approximation c do 14 j = 2, jmax p2 = prtrng(q2, v, r, nfault) if (nfault .ne. 0) goto 99 e1 = p1 - p e2 = p2 - p qtrng = (q1 + q2) / two d = e2 - e1 if (abs(d) .gt. eps) qtrng = (e2 * q1 - e1 * q2) / d if(abs(e1) .lt. abs(e2)) goto 12 q1 = q2 p1 = p2 12 if (abs(p1 - p) .lt. pcut * five) goto 99 q2 = qtrng 14 continue c 99 if (nfault .ne. 0) ifault = 9 return end double precision function qtrng0(p, v, r, ifault) implicit double precision (a-h, o-z) c c Algorithm AS 190.2 Appl. Statist. (1983) Vol.32, No.2 c c Calculates an initial quantile p for a studentized range c distribution having v degrees of freedom and r samples c for probability p, p.gt.0.80 .and. p.lt.0.995. c c Uses function ppnd - Algorithm AS 111 c double precision p, v, r, q, t, vmax, half, one, four, c1, c2, c3 double precision c4, c5 real ppnd data vmax, half, one, four, c1, c2, c3, c4, c5 / 120.0d0, 0.5d0, # 1.0d0, 4.0d0, 0.8843d0, 0.2368d0, 1.214d0, 1.208d0, 1.4142d0/ c t=dble(ppnd(real(half + half * p),ifault)) if (v .lt. vmax) t = t + (t * t* t + t) / v / four q = c1 - c2 * t if (v .lt. vmax) q = q - c3 / v + c4 * t / v qtrng0 = t * (q * log(r - one) + c5) return end SUBROUTINE QUAFIT(IT,I1,I2,XS,YS,WH,WV,N,XMAXHF,I3,I4, 1ALPHA,BETA1,BETA2,PRED,RES,ISUBRO,IBUGA3,IERROR) C C PURPOSE--CARRY OUT A LEAST SQUARES WEIGHTED QUARADITIC FIT C OF THE DATA IN LOCATIONS I1 TO I2 C OF THE HORIZONTALLY SORTED DATA C IN VARIABLES XS(.) AND YS(.). C AFTER THE FIT IS DONE, COMPUTE PREDICTED VALUES C AND RESIDUALS FOR ELEMENTS I3 TO I4 OF XS(.). C THIS ROUTINE IS USED FOR UNIVARIATE LOWESS OF DEGREE 2. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--94/4 C ORIGINAL VERSION--MARCH 1994 C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ISUBRO CHARACTER*4 IBUGA3 CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C DOUBLE PRECISION DSUM1 DOUBLE PRECISION DSUM2 DOUBLE PRECISION DSUM3 DOUBLE PRECISION DSUM4 DOUBLE PRECISION DSUM5 DOUBLE PRECISION DSUM6 DOUBLE PRECISION DSUM7 DOUBLE PRECISION DSUM8 C C--------------------------------------------------------------------- C DIMENSION XMAT(3,3) DIMENSION IPVT(3) DIMENSION RHS(3) DIMENSION XS(*) DIMENSION YS(*) DIMENSION WH(*) DIMENSION WV(*) DIMENSION PRED(*) DIMENSION RES(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='QUAF' ISUBN2='IT ' C IERROR='NO' C IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'AFIT')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF QUAFIT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)ISUBRO,IBUGA3,IERROR 52 FORMAT('ISUBRO,IBUGA3,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)IT,I1,I2,N,I3,I4 53 FORMAT('IT,I1,I2,N,I3,I4 = ',6I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)XMAXHF 54 FORMAT('XMAXHF = ',E15.7) CALL DPWRST('XXX','BUG ') IF(N.LE.0)GOTO63 DO61I=1,N WRITE(ICOUT,62)I,XS(I),YS(I),WH(I),WV(I) 62 FORMAT('I,XS(I),YS(I),WH(I),WV(I) = ',I8,4E15.7) CALL DPWRST('XXX','BUG ') 61 CONTINUE 63 CONTINUE 90 CONTINUE C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C IF(N.GE.1)GOTO119 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,111) 111 FORMAT('***** ERROR IN QUAFIT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,112) 112 FORMAT(' THE INPUT FULL SAMPLE SIZE,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,113) 113 FORMAT(' FOR WHICH LOWESS HORIZONTAL WEIGHTS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,114) 114 FORMAT(' ARE TO BE COMPUTED, MUST BE 1 OR LARGER.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,115) 115 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,116)N 116 FORMAT(' THE FULL SAMPLE SIZE N = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 119 CONTINUE C IF(IT.GE.1)GOTO129 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,121) 121 FORMAT('***** ERROR IN QUAFIT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,122) 122 FORMAT(' THE INPUT TARGET OBSERVATION INDEX') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,123) 123 FORMAT(' FOR WHICH A LOWESS IS TO BE CARRIED OUT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,124)N 124 FORMAT(' MUST BE BETWEEN 1 AND ',I8,' (INCLUSIVE).') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,125) 125 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,126)IT 126 FORMAT(' THE TARGET OBSERVATION INDEX IT = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 129 CONTINUE C IF(I1.LE.I2)GOTO139 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,131) 131 FORMAT('***** ERROR IN QUAFIT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,132) 132 FORMAT(' THE NEIGHBORHOOD LOWER INDEX') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,133) 133 FORMAT(' FOR WHICH A LOWESS IS TO BE CARRIED OUT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,134) 134 FORMAT(' MUST NOT EXCEED THE NEIGHBORHOOD UPPER INDEX.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,135) 135 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,136)IT 136 FORMAT(' THE NEIGHBORHOOD INDICES I1 AND I2 = ',2I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 139 CONTINUE C IF(I3.LE.I4)GOTO149 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,141) 141 FORMAT('***** ERROR IN QUAFIT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,142) 142 FORMAT(' THE DESIRED LOWER INDEX FOR WHICH') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,143) 143 FORMAT(' LOWESS PREDICTED VALUES ARE TO BE COMPUTED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,144) 144 FORMAT(' MUST NOT EXCEED THE DESIRED UPPER INDEX.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,145) 145 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,146)I3,I4 146 FORMAT(' THE DESIRED INDICES I3 AND I4 = ',2I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 149 CONTINUE C C *********************************************** C ** STEP 11-- ** C ** CARRY OUT A LEAST SQUARES WEIGHTED ** C ** QUAFIT FIT ** C *********************************************** C IF(XMAXHF.LE.0.0)GOTO1200 GOTO1300 C C *********************************************** C ** STEP 12-- ** C ** TREAT THE CASE WHEN ALL HORIXONTAL AXIS ** C ** VALUES ARE IDENTICAL ** C *********************************************** C 1200 CONTINUE NN=I2-I1+1 ANN=NN C SUMY=0.0 SUMW=0.0 DO1210I=I1,I2 W=WH(I)*WV(I) SUMY=SUMY+W*YS(I) SUMW=SUMW+W 1210 CONTINUE YBAR=SUMY/SUMW C ALPHA=YBAR BETA1=0.0 BETA2=0.0 C DO1220I=I3,I4 PRED(I)=ALPHA RES(I)=YS(I)-PRED(I) 1220 CONTINUE C GOTO9000 C ********************************************* C ** STEP 13-- ** C ** TREAT THE CASE WHEN AT LEAST 1 ** C ** HORIZONTAL AXIS VALUE IS DIFFERENT ** C ********************************************* C 1300 CONTINUE NN=I2-I1+1 ANN=NN C SUMW=0.0 DO1310I=I1,I2 W=WH(I)*WV(I) SUMW=SUMW+W 1310 CONTINUE C IF(SUMW.GT.0.0)GOTO1319 WRITE(ICOUT,1311) 1311 FORMAT('***** ERROR IN QUAFIT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1312) 1312 FORMAT(' SUM OF WEIGHTS = 0') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1313)IT,I1,I2,N 1313 FORMAT('IT,I1,I2,N = ',4I8) CALL DPWRST('XXX','BUG ') DO1314I=I1,I2 WPROD=WH(I)*WV(I) WRITE(ICOUT,1315)I,WH(I),WV(I),WPROD 1315 FORMAT('I,WH(I),WV(I),WPROD = ',I8,3E15.7) CALL DPWRST('XXX','BUG ') 1314 CONTINUE IERROR='YES' GOTO9000 1319 CONTINUE C C FOR A QUADRATIC, WEIGHTED FIT, THE NORMAL EQUATIONS ARE: C [SUM(W) SUM(W*X) SUM(W*X**2)] [ALPHA] [SUM(W*Y) ] C [SUM(W*X) SUM(W*X**2) SUM(W*X**3)] [BETA1] = [SUM(W*X*Y] C [SUM(W*X**2) SUM(W*X**3) SUM(W*X**4)] [BETA2] [SUM(W*X**2*Y] C C FORM THE FOLLOWING SUMS (IN DOUBLE PRECISION): C 1) W C 2) W*X C 3) W*X**2 C 4) W*X**3 C 5) W*X**4 C 6) W*Y C 7) W*Y*X C 8) W*Y*X**2 C DSUM1=0.0 DSUM2=0.0 DSUM3=0.0 DSUM4=0.0 DSUM5=0.0 DSUM6=0.0 DSUM7=0.0 DSUM8=0.0 DO1320I=I1,I2 W=WH(I)*WV(I) DSUM1=DSUM1+W DSUM2=DSUM2+W*XS(I) DSUM3=DSUM3+W*XS(I)*XS(I) DSUM4=DSUM4+W*XS(I)**3 DSUM5=DSUM5+W*XS(I)**4 DSUM6=DSUM6+W*YS(I) DSUM7=DSUM7+W*YS(I)*XS(I) DSUM8=DSUM8+W*YS(I)*XS(I)*XS(I) 1320 CONTINUE C IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'AFIT')GOTO1390 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1351) 1351 FORMAT('***** IN THE MIDDLE OF QUAFIT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1352)DSUM1,DSUM2,DSUM3,DSUM4 1352 FORMAT('DSUM1,DSUM2,DSUM3,DSUM4 = ',4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1353)DSUM5,DSUM6,DSUM7,DSUM8 1353 FORMAT('DSUM5,DSUM6,DSUM7,DSUM8 = ',4E15.7) CALL DPWRST('XXX','BUG ') 1390 CONTINUE C XMAT(1,1)=DSUM1 XMAT(2,1)=DSUM2 XMAT(3,1)=DSUM3 XMAT(1,2)=DSUM2 XMAT(2,2)=DSUM3 XMAT(2,3)=DSUM4 XMAT(1,3)=DSUM3 XMAT(2,3)=DSUM4 XMAT(3,3)=DSUM5 RHS(1)=DSUM6 RHS(2)=DSUM7 RHS(3)=DSUM8 IPVT(1)=0 IPVT(2)=0 IPVT(3)=0 C C USE LINPACK TO SOLVE 3X3 EQUATION C INFO=0 NP=3 CALL SGEFA(XMAT,NP,NP,IPVT,INFO) IF(INFO.NE.0)THEN ALPHA=0.0 BETA1=0.0 BETA2=0.0 IERROR='YES' ELSE IJOB=0 CALL SGESL(XMAT,NP,NP,IPVT,RHS,IJOB) ALPHA=RHS(1) BETA1=RHS(2) BETA2=RHS(3) END IF C DO1340I=I3,I4 PRED(I)=ALPHA+BETA1*XS(I)+BETA2*XS(I)*XS(I) RES(I)=YS(I)-PRED(I) 1340 CONTINUE C GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'AFIT')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF QUAFIT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)ISUBRO,IBUGA3,IERROR 9012 FORMAT('ISUBRO,IBUGA3,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)IT,I1,I2,N,I3,I4 9013 FORMAT('IT,I1,I2,N,I3,I4 = ',6I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)XMAXHF 9014 FORMAT('XMAXHF = ',E15.7) CALL DPWRST('XXX','BUG ') IF(N.LE.0)GOTO9033 DO9031I=I1,I2 WRITE(ICOUT,9032)I,XS(I),YS(I),WH(I),WV(I) 9032 FORMAT('I,XS(I),YS(I),WH(I),WV(I) = ',I8,4E15.7) CALL DPWRST('XXX','BUG ') 9031 CONTINUE 9033 CONTINUE WRITE(ICOUT,9040)ALPHA,BETA1,BETA2 9040 FORMAT('ALPHA,BETA1,BETA2 = ',3E15.7) CALL DPWRST('XXX','BUG ') IF(N.LE.0)GOTO9043 DO9041I=I3,I4 WRITE(ICOUT,9042)I,PRED(I),RES(I) 9042 FORMAT('I,PRED(I),RES(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 9041 CONTINUE 9043 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE QUAFI2(XS,YS,N, 1XTEMP, 1ALPHA,BETA1,BETA2, 1ISUBRO,IBUGA3,IERROR) C C PURPOSE--CARRY OUT A LEAST SQUARES NON-WEIGHTED QUARADITIC FIT C OF THE VARIABLES XS(.) AND YS(.). C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2002/7 C ORIGINAL VERSION--JULY 2002 C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ISUBRO CHARACTER*4 IBUGA3 CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C DOUBLE PRECISION DMEANX DOUBLE PRECISION DSUM1 DOUBLE PRECISION DSUM2 DOUBLE PRECISION DSUM3 DOUBLE PRECISION DSUM4 DOUBLE PRECISION DSUM5 DOUBLE PRECISION DSUM6 C C--------------------------------------------------------------------- C DIMENSION XMAT(3,3) DIMENSION IPVT(3) DIMENSION RHS(3) DIMENSION XS(*) DIMENSION YS(*) DIMENSION XTEMP(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='QUAF' ISUBN2='I2 ' C IERROR='NO' C IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'AFI2')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF QUAFI2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)ISUBRO,IBUGA3,IERROR 52 FORMAT('ISUBRO,IBUGA3,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)N 53 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') IF(N.LE.0)GOTO63 DO61I=1,N WRITE(ICOUT,62)I,XS(I),YS(I) 62 FORMAT('I,XS(I),YS(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 61 CONTINUE 63 CONTINUE 90 CONTINUE C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C IF(N.GE.1)GOTO119 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,111) 111 FORMAT('***** ERROR IN QUAFI2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,112) 112 FORMAT(' THE INPUT SAMPLE SIZE MUST BE 1 OR LARGER.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,115)N 115 FORMAT(' SUCH WAS NOT THE CASE HERE. THE SAMPLE SIZE N = ', 1 I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 119 CONTINUE C C *********************************************** C ** STEP 11-- ** C ** CARRY OUT A LEAST SQUARES QUADRATIC FIT ** C *********************************************** C AN=N C C SCALE THE DATA: SUBTRACT MEAN FROM X ARRAY C DSUM1=0.0D0 DO1310I=1,N DSUM1=DSUM1 + DBLE(XS(I)) 1310 CONTINUE DMEANX=DSUM1/DBLE(N) C AMEANX=REAL(DMEANX) DO1320I=1,N XTEMP(I)=XS(I) - AMEANX 1320 CONTINUE C DSUM1=0.0D0 DSUM2=0.0D0 DSUM3=0.0D0 DSUM4=0.0D0 DSUM5=0.0D0 DSUM6=0.0D0 DO1330I=1,N DSUM1=DSUM1 + DBLE(YS(I)) DSUM2=DSUM2 + DBLE(XTEMP(I))**2 DSUM3=DSUM3 + DBLE(XTEMP(I))**3 DSUM4=DSUM4 + DBLE(XTEMP(I))**4 DSUM5=DSUM5 + DBLE(YS(I))*DBLE(XTEMP(I)) DSUM6=DSUM6 + DBLE(YS(I))*DBLE(XTEMP(I))**2 1330 CONTINUE C IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'AFI2')GOTO1390 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1351) 1351 FORMAT('***** IN THE MIDDLE OF QUAFI2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1352)DSUM1,DSUM2,DSUM3,DSUM4 1352 FORMAT('DSUM1,DSUM2,DSUM3,DSUM4 = ',4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1353)DSUM5,DSUM6,DMEANX 1353 FORMAT('DSUM5,DSUM6,DMEANX = ',3D15.7) CALL DPWRST('XXX','BUG ') 1390 CONTINUE C XMAT(1,1)=AN XMAT(1,2)=0.0 XMAT(1,3)=REAL(DSUM2) XMAT(2,1)=0.0 XMAT(2,2)=REAL(DSUM2) XMAT(2,3)=REAL(DSUM3) XMAT(3,1)=REAL(DSUM2) XMAT(3,2)=REAL(DSUM3) XMAT(3,3)=REAL(DSUM4) RHS(1)=REAL(DSUM1) RHS(2)=REAL(DSUM5) RHS(3)=REAL(DSUM6) IPVT(1)=0 IPVT(2)=0 IPVT(3)=0 C C USE LINPACK TO SOLVE 2X2 EQUATION C INFO=0 NP=3 CALL SGEFA(XMAT,NP,NP,IPVT,INFO) IF(INFO.NE.0)THEN ALPHA=0.0 BETA1=0.0 BETA2=0.0 IERROR='YES' ELSE IJOB=0 CALL SGESL(XMAT,NP,NP,IPVT,RHS,IJOB) B0=RHS(1) B1=RHS(2) B2=RHS(3) ALPHA=B0 - B1*AMEANX + B2*AMEANX*AMEANX BETA1=B1 - 2*B2*AMEANX BETA2=B2 END IF C GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'AFI2')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF QUAFI2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)ISUBRO,IBUGA3,IERROR 9012 FORMAT('ISUBRO,IBUGA3,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)N 9013 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') IF(N.LE.0)GOTO9033 DO9031I=1,N WRITE(ICOUT,9032)I,XS(I),YS(I) 9032 FORMAT('I,XS(I),YS(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 9031 CONTINUE 9033 CONTINUE WRITE(ICOUT,9040)ALPHA,BETA1,BETA2 9040 FORMAT('ALPHA,BETA1,BETA2 = ',3E15.7) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END DOUBLE PRECISION FUNCTION QUAGLO(F,PARA) C===================================================== QUAGLO.FOR C*********************************************************************** C* * C* FORTRAN CODE WRITTEN FOR INCLUSION IN IBM RESEARCH REPORT RC20525, * C* 'FORTRAN ROUTINES FOR USE WITH THE METHOD OF L-MOMENTS, VERSION 3' * C* * C* J. R. M. HOSKING * C* IBM RESEARCH DIVISION * C* T. J. WATSON RESEARCH CENTER * C* YORKTOWN HEIGHTS * C* NEW YORK 10598, U.S.A. * C* * C* VERSION 3 AUGUST 1996 * C* * C*********************************************************************** C C QUANTILE FUNCTION OF THE GENERALIZED LOGISTIC DISTRIBUTION C IMPLICIT DOUBLE PRECISION (A-H,O-Z) DOUBLE PRECISION PARA(3) C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C REAL CPUMIN REAL CPUMAX COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C DATA ZERO/0.0D0/,ONE/1.0D0/ C U=PARA(1) A=PARA(2) G=PARA(3) C IF(A.LE.ZERO)THEN QUAGLO=ZERO WRITE(ICOUT,7010) 7010 FORMAT('***** ERROR IN GL5PPF--NON-POSITIVE SCALE ', 1 'PARAMETER.') CALL DPWRST('XXX','WRIT') C ELSEIF(F.LE.ZERO.OR.F.GE.ONE)THEN IF((F.EQ.ZERO.AND.G.LT.ZERO) .OR. (F.EQ.ONE .AND.G.GT.ZERO)) 1 THEN QUAGLO=U+A/G ELSE WRITE(ICOUT,7000) 7000 FORMAT('***** ERROR IN GL5PPF--ARGUMENT IS INVALID.') CALL DPWRST('XXX','WRIT') QUAGLO=ZERO ENDIF ELSE Y=DLOG(F/(ONE-F)) IF(G.NE.ZERO)Y=(ONE-DEXP(-G*Y))/G QUAGLO=U+A*Y ENDIF C RETURN END DOUBLE PRECISION FUNCTION QUAWAK(F,PARA) C===================================================== QUAWAK.FOR C*********************************************************************** C* * C* FORTRAN CODE WRITTEN FOR INCLUSION IN IBM RESEARCH REPORT RC20525, * C* 'FORTRAN ROUTINES FOR USE WITH THE METHOD OF L-MOMENTS, VERSION 3' * C* * C* J. R. M. HOSKING * C* IBM RESEARCH DIVISION * C* T. J. WATSON RESEARCH CENTER * C* YORKTOWN HEIGHTS * C* NEW YORK 10598, U.S.A. * C* * C* VERSION 3 AUGUST 1996 * C* * C*********************************************************************** C C QUANTILE FUNCTION OF THE WAKEBY DISTRIBUTION C IMPLICIT DOUBLE PRECISION (A-H,O-Z) DOUBLE PRECISION PARA(5) C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C REAL CPUMIN REAL CPUMAX COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C DATA ZERO/0.0D0/,ONE/1.0D0/ C C UFL SHOULD BE CHOSEN SO THAT EXP(UFL) JUST DOES NOT CAUSE C UNDERFLOW C DATA UFL/-170.0D0/ C XI=PARA(1) A=PARA(2) B=PARA(3) C=PARA(4) D=PARA(5) C C TEST FOR VALID PARAMETERS C IF(B+D.LE.ZERO.AND.(B.NE.ZERO.OR.C.NE.ZERO.OR.D.NE.ZERO))GOTO 1000 IF(A.EQ.ZERO.AND.B.NE.ZERO)GOTO 1000 IF(C.EQ.ZERO.AND.D.NE.ZERO)GOTO 1000 IF(C.LT.ZERO.OR.A+C.LT.ZERO)GOTO 1000 IF(A.EQ.ZERO.AND.C.EQ.ZERO)GOTO 1000 C IF(F.LE.ZERO.OR.F.GE.ONE)GOTO 10 Z=-DLOG(ONE-F) Y1=Z IF(B.NE.ZERO)THEN TEMP=-B*Z IF(TEMP.LT.UFL)Y1=ONE/B IF(TEMP.GE.UFL)Y1=(ONE-DEXP(TEMP))/B ENDIF Y2=Z IF(D.NE.ZERO)Y2=(ONE-DEXP(D*Y2))/(-D) QUAWAK=XI+A*Y1+C*Y2 GOTO9000 C 10 CONTINUE IF(F.EQ.ZERO)THEN QUAWAK=XI GOTO9000 ELSEIF(F.EQ.ONE)THEN IF(D.GT.ZERO)GOTO 1010 IF(D.LT.ZERO)QUAWAK=XI+A/B-C/D IF(D.EQ.ZERO.AND.C.GT.ZERO)GOTO 1010 IF(D.EQ.ZERO.AND.C.EQ.ZERO.AND.B.EQ.ZERO)GOTO 1010 IF(D.EQ.ZERO.AND.C.EQ.ZERO.AND.B.GT.ZERO)QUAWAK=XI+A/B GOTO9000 ELSE GOTO 1010 ENDIF C 1000 CONTINUE WRITE(ICOUT,7000) 7000 FORMAT('***** ERROR IN WAKPPF--PARAMETERS INVALID.') CALL DPWRST('XXX','WRIT') GOTO9000 C 1010 CONTINUE WRITE(ICOUT,7010) 7010 FORMAT('***** ERROR IN WAKPPF--ARGUMENT INVALID.') CALL DPWRST('XXX','WRIT') QUAWAK=ZERO GOTO9000 C 9000 CONTINUE RETURN END SUBROUTINE QUICH1(ICTEXT,NCTEXT,PLEC,PLECG,ANUMPP) C C PURPOSE--FOR THE QMS GRAPHICS DEVICE, C FOR THE "104" (STANDARD ROMAN MEDIUM FONT) C 10 POINT PROPORTIONAL FONT (TABLE ON APPENDIX B-4 OF C QUIC PROGRAMMERS MANUAL FROM QMS) C AND FOR THE HORIZONTAL DIRECTION, C DETERMINE THE LENGTH OF THE TEXT STRING IN THE C CHARACTER VECTOR ICTEXT(.), C WHICH CONSISTS OF NTEXT CHARACTERS. C NOTE--THE LENGTH IS IN STANDARDIZED COORDINATES C THAT IS, 0.0 TO 100.0 C C WRITTEN BY--ALAN HECKERT C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONCTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--89.2 C ORIGINAL VERSION--JANUARY 1989. C UPDATED --APRIL 1992. IIVALUE TO IVALUE C C-----NON-COMMON VARIABLES (GRAPHICS)------------------------------------------- C CHARACTER*4 ICTEXT CHARACTER*4 ICTEMP CHARACTER*1 IC C DIMENSION ICTEXT(*) C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOGR.INC' INCLUDE 'DPCOBE.INC' INCLUDE 'DPCODV.INC' C C-----COMMON VARIABLES (GENERAL)-------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C WIDTH TABLE, NOTE THAT ASCII CHARACTER 1-31 ARE CONTROL C CHARACTERS WITH ZERO WIDTH, CHARACTERS 127-255 ARE UNDEFINED. C THERFORE TABLE GOES FROM 32 TO 126. C DIMENSION WIDTAB(95) C DATA WIDTAB( 1) /25./ DATA WIDTAB( 2) / 8./ DATA WIDTAB( 3) /20./ DATA WIDTAB( 4) /26./ DATA WIDTAB( 5) /19./ DATA WIDTAB( 6) /32./ DATA WIDTAB( 7) /34./ DATA WIDTAB( 8) / 9./ DATA WIDTAB( 9) /15./ DATA WIDTAB(10) /15./ DATA WIDTAB(11) /17./ DATA WIDTAB(12) /24./ DATA WIDTAB(13) / 9./ DATA WIDTAB(14) /15./ DATA WIDTAB(15) / 9./ DATA WIDTAB(16) /19./ DATA WIDTAB(17) /23./ DATA WIDTAB(18) /23./ DATA WIDTAB(19) /23./ DATA WIDTAB(20) /23./ DATA WIDTAB(21) /23./ DATA WIDTAB(22) /23./ DATA WIDTAB(23) /23./ DATA WIDTAB(24) /23./ DATA WIDTAB(25) /23./ DATA WIDTAB(26) /23./ DATA WIDTAB(27) / 9./ DATA WIDTAB(28) / 9./ DATA WIDTAB(29) /19./ DATA WIDTAB(30) /24./ DATA WIDTAB(31) /19./ DATA WIDTAB(32) /18./ DATA WIDTAB(33) /25./ DATA WIDTAB(34) /34./ DATA WIDTAB(35) /26./ DATA WIDTAB(36) /29./ DATA WIDTAB(37) /31./ DATA WIDTAB(38) /26./ DATA WIDTAB(39) /25./ DATA WIDTAB(40) /30./ DATA WIDTAB(41) /32./ DATA WIDTAB(42) /14./ DATA WIDTAB(43) /18./ DATA WIDTAB(44) /32./ DATA WIDTAB(45) /27./ DATA WIDTAB(46) /37./ DATA WIDTAB(47) /29./ DATA WIDTAB(48) /30./ DATA WIDTAB(49) /24./ DATA WIDTAB(50) /30./ DATA WIDTAB(51) /28./ DATA WIDTAB(52) /22./ DATA WIDTAB(53) /28./ DATA WIDTAB(54) /33./ DATA WIDTAB(55) /34./ DATA WIDTAB(56) /45./ DATA WIDTAB(57) /31./ DATA WIDTAB(58) /31./ DATA WIDTAB(59) /27./ DATA WIDTAB(60) /11./ DATA WIDTAB(61) /20./ DATA WIDTAB(62) /11./ DATA WIDTAB(63) /20./ DATA WIDTAB(64) /40./ DATA WIDTAB(65) / 9./ DATA WIDTAB(66) /20./ DATA WIDTAB(67) /22./ DATA WIDTAB(68) /18./ DATA WIDTAB(69) /23./ DATA WIDTAB(70) /18./ DATA WIDTAB(71) /19./ DATA WIDTAB(72) /21./ DATA WIDTAB(73) /25./ DATA WIDTAB(74) /13./ DATA WIDTAB(75) /13./ DATA WIDTAB(76) /26./ DATA WIDTAB(77) /15./ DATA WIDTAB(78) /37./ DATA WIDTAB(79) /25./ DATA WIDTAB(80) /20./ DATA WIDTAB(81) /23./ DATA WIDTAB(82) /23./ DATA WIDTAB(83) /18./ DATA WIDTAB(84) /16./ DATA WIDTAB(85) /16./ DATA WIDTAB(86) /25./ DATA WIDTAB(87) /26./ DATA WIDTAB(88) /39./ DATA WIDTAB(89) /23./ DATA WIDTAB(90) /26./ DATA WIDTAB(91) /19./ DATA WIDTAB(92) /15./ DATA WIDTAB(93) / 5./ DATA WIDTAB(94) /15./ DATA WIDTAB(95) /18./ C C-----START POINT----------------------------------------------------- C C C ************************************************************** C ** STEP 1 - SUM UP THE LENGTH OF THE STRING (IN "DOTS") ** C ************************************************************** C SUM=0. DO100I=1,NCTEXT ICTEMP=ICTEXT(I) IC=ICTEMP(1:1) CALL DPCOAN(IC,IVALUE) CCCCC THE FOLLOWING LINE WAS FIXED APRIL 1992 CCCCC IF(IVALUE.LT.32..OR.IIVALUE.GT.126)GOTO100 IF(IVALUE.LT.32.OR.IVALUE.GT.126)GOTO100 IVALUE=IVALUE-31 SUM=SUM+WIDTAB(IVALUE) 100 CONTINUE C C ************************************************************** C ** STEP 2 - CONVERT DOTS TO DATAPLOT PERCENT UNITS ** C ************************************************************** C PLEC=100.*(SUM/ANUMPP) PLECG=PLEC C C ************************************************************** C ** RETURN ** C ************************************************************** C RETURN END SUBROUTINE QUICH2(ICTEXT,NCTEXT,PLEC,PLECG,ANUMPP) C C PURPOSE--FOR THE QMS GRAPHICS DEVICE, C FOR THE "124" (STANDARD ROMAN BOLD FONT) C 10 POINT PROPORTIONAL FONT (TABLE ON APPENDIX B-6 OF C QUIC PROGRAMMERS MANUAL FROM QMS) C AND FOR THE HORIZONTAL DIRECTION, C DETERMINE THE LENGTH OF THE TEXT STRING IN THE C CHARACTER VECTOR ICTEXT(.), C WHICH CONSISTS OF NTEXT CHARACTERS. C NOTE--THE LENGTH IS IN STANDARDIZED COORDINATES C THAT IS, 0.0 TO 100.0 C C WRITTEN BY--ALAN HECKERT C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONCTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--89.2 C ORIGINAL VERSION--JANUARY 1989. C UPDATED --APRIL 1992. IIVALUE TO IVALUE C C-----NON-COMMON VARIABLES (GRAPHICS)------------------------------------------- C CHARACTER*4 ICTEXT CHARACTER*4 ICTEMP CHARACTER*1 IC C DIMENSION ICTEXT(*) C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOGR.INC' INCLUDE 'DPCOBE.INC' INCLUDE 'DPCODV.INC' C C-----COMMON VARIABLES (GENERAL)-------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C WIDTH TABLE, NOTE THAT ASCII CHARACTER 1-31 ARE CONTROL C CHARACTERS WITH ZERO WIDTH, CHARACTERS 127-255 ARE UNDEFINED. C THERFORE TABLE GOES FROM 32 TO 126. C DIMENSION WIDTAB(95) C DATA WIDTAB( 1) /25./ DATA WIDTAB( 2) /10./ DATA WIDTAB( 3) /22./ DATA WIDTAB( 4) /28./ DATA WIDTAB( 5) /21./ DATA WIDTAB( 6) /34./ DATA WIDTAB( 7) /36./ DATA WIDTAB( 8) /11./ DATA WIDTAB( 9) /15./ DATA WIDTAB(10) /15./ DATA WIDTAB(11) /19./ DATA WIDTAB(12) /23./ DATA WIDTAB(13) /11./ DATA WIDTAB(14) /16./ DATA WIDTAB(15) /11./ DATA WIDTAB(16) /21./ DATA WIDTAB(17) /24./ DATA WIDTAB(18) /24./ DATA WIDTAB(19) /24./ DATA WIDTAB(20) /24./ DATA WIDTAB(21) /24./ DATA WIDTAB(22) /24./ DATA WIDTAB(23) /24./ DATA WIDTAB(24) /24./ DATA WIDTAB(25) /24./ DATA WIDTAB(26) /24./ DATA WIDTAB(27) /11./ DATA WIDTAB(28) /11./ DATA WIDTAB(29) /21./ DATA WIDTAB(30) /25./ DATA WIDTAB(31) /21./ DATA WIDTAB(32) /20./ DATA WIDTAB(33) /27./ DATA WIDTAB(34) /34./ DATA WIDTAB(35) /27./ DATA WIDTAB(36) /30./ DATA WIDTAB(37) /33./ DATA WIDTAB(38) /28./ DATA WIDTAB(39) /27./ DATA WIDTAB(40) /32./ DATA WIDTAB(41) /34./ DATA WIDTAB(42) /16./ DATA WIDTAB(43) /21./ DATA WIDTAB(44) /33./ DATA WIDTAB(45) /29./ DATA WIDTAB(46) /43./ DATA WIDTAB(47) /35./ DATA WIDTAB(48) /32./ DATA WIDTAB(49) /27./ DATA WIDTAB(50) /33./ DATA WIDTAB(51) /30./ DATA WIDTAB(52) /25./ DATA WIDTAB(53) /31./ DATA WIDTAB(54) /34./ DATA WIDTAB(55) /35./ DATA WIDTAB(56) /46./ DATA WIDTAB(57) /35./ DATA WIDTAB(58) /34./ DATA WIDTAB(59) /30./ DATA WIDTAB(60) /15./ DATA WIDTAB(61) /21./ DATA WIDTAB(62) /15./ DATA WIDTAB(63) /20./ DATA WIDTAB(64) /40./ DATA WIDTAB(65) /12./ DATA WIDTAB(66) /23./ DATA WIDTAB(67) /25./ DATA WIDTAB(68) /21./ DATA WIDTAB(69) /25./ DATA WIDTAB(70) /21./ DATA WIDTAB(71) /22./ DATA WIDTAB(72) /23./ DATA WIDTAB(73) /28./ DATA WIDTAB(74) /16./ DATA WIDTAB(75) /15./ DATA WIDTAB(76) /28./ DATA WIDTAB(77) /16./ DATA WIDTAB(78) /40./ DATA WIDTAB(79) /28./ DATA WIDTAB(80) /23./ DATA WIDTAB(81) /25./ DATA WIDTAB(82) /26./ DATA WIDTAB(83) /22./ DATA WIDTAB(84) /18./ DATA WIDTAB(85) /19./ DATA WIDTAB(86) /25./ DATA WIDTAB(87) /28./ DATA WIDTAB(88) /39./ DATA WIDTAB(89) /26./ DATA WIDTAB(90) /29./ DATA WIDTAB(91) /21./ DATA WIDTAB(92) /18./ DATA WIDTAB(93) / 5./ DATA WIDTAB(94) /18./ DATA WIDTAB(95) /21./ C C-----START POINT----------------------------------------------------- C C C ************************************************************** C ** STEP 1 - SUM UP THE LENGTH OF THE STRING (IN "DOTS") ** C ************************************************************** C SUM=0. DO100I=1,NCTEXT ICTEMP=ICTEXT(I) IC=ICTEMP(1:1) CALL DPCOAN(IC,IVALUE) CCCCC THE FOLLOWING LINE WAS FIXED APRIL 1992 CCCCC IF(IVALUE.LT.32..OR.IIVALUE.GT.126)GOTO100 IF(IVALUE.LT.32.OR.IVALUE.GT.126)GOTO100 IVALUE=IVALUE-31 SUM=SUM+WIDTAB(IVALUE) 100 CONTINUE C C ************************************************************** C ** STEP 2 - CONVERT DOTS TO DATAPLOT PERCENT UNITS ** C ************************************************************** C PLEC=100.*(SUM/ANUMPP) PLECG=PLEC C C ************************************************************** C ** RETURN ** C ************************************************************** C RETURN END SUBROUTINE QUICH3(ICTEXT,NCTEXT,PLEC,PLECG,ANUMPP) C C PURPOSE--FOR THE QMS GRAPHICS DEVICE, C FOR THE "144" (STANDARD ROMAN ITALIC FONT) C 10 POINT PROPORTIONAL FONT (TABLE ON APPENDIX B-8 OF C QUIC PROGRAMMERS MANUAL FROM QMS) C AND FOR THE HORIZONTAL DIRECTION, C DETERMINE THE LENGTH OF THE TEXT STRING IN THE C CHARACTER VECTOR ICTEXT(.), C WHICH CONSISTS OF NTEXT CHARACTERS. C NOTE--THE LENGTH IS IN STANDARDIZED COORDINATES C THAT IS, 0.0 TO 100.0 C C WRITTEN BY--ALAN HECKERT C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONCTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--89.2 C ORIGINAL VERSION--JANUARY 1989. C UPDATED --APRIL 1992. IIVALUE TO IVALUE C C-----NON-COMMON VARIABLES (GRAPHICS)------------------------------------------- C CHARACTER*4 ICTEXT CHARACTER*4 ICTEMP CHARACTER*1 IC C DIMENSION ICTEXT(*) C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOGR.INC' INCLUDE 'DPCOBE.INC' INCLUDE 'DPCODV.INC' C C-----COMMON VARIABLES (GENERAL)-------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C WIDTH TABLE, NOTE THAT ASCII CHARACTER 1-31 ARE CONTROL C CHARACTERS WITH ZERO WIDTH, CHARACTERS 127-255 ARE UNDEFINED. C THERFORE TABLE GOES FROM 32 TO 126. C DIMENSION WIDTAB(95) C DATA WIDTAB( 1) /28./ DATA WIDTAB( 2) /13./ DATA WIDTAB( 3) /16./ DATA WIDTAB( 4) /25./ DATA WIDTAB( 5) /21./ DATA WIDTAB( 6) /34./ DATA WIDTAB( 7) /31./ DATA WIDTAB( 8) / 8./ DATA WIDTAB( 9) /13./ DATA WIDTAB(10) /13./ DATA WIDTAB(11) /17./ DATA WIDTAB(12) /24./ DATA WIDTAB(13) / 8./ DATA WIDTAB(14) /15./ DATA WIDTAB(15) / 8./ DATA WIDTAB(16) /19./ DATA WIDTAB(17) /23./ DATA WIDTAB(18) /23./ DATA WIDTAB(19) /23./ DATA WIDTAB(20) /23./ DATA WIDTAB(21) /23./ DATA WIDTAB(22) /23./ DATA WIDTAB(23) /23./ DATA WIDTAB(24) /23./ DATA WIDTAB(25) /23./ DATA WIDTAB(26) /23./ DATA WIDTAB(27) /11./ DATA WIDTAB(28) /11./ DATA WIDTAB(29) /15./ DATA WIDTAB(30) /24./ DATA WIDTAB(31) /16./ DATA WIDTAB(32) /16./ DATA WIDTAB(33) /25./ DATA WIDTAB(34) /33./ DATA WIDTAB(35) /30./ DATA WIDTAB(36) /29./ DATA WIDTAB(37) /34./ DATA WIDTAB(38) /32./ DATA WIDTAB(39) /33./ DATA WIDTAB(40) /31./ DATA WIDTAB(41) /41./ DATA WIDTAB(42) /24./ DATA WIDTAB(43) /26./ DATA WIDTAB(44) /38./ DATA WIDTAB(45) /30./ DATA WIDTAB(46) /45./ DATA WIDTAB(47) /39./ DATA WIDTAB(48) /30./ DATA WIDTAB(49) /30./ DATA WIDTAB(50) /29./ DATA WIDTAB(51) /30./ DATA WIDTAB(52) /25./ DATA WIDTAB(53) /29./ DATA WIDTAB(54) /33./ DATA WIDTAB(55) /33./ DATA WIDTAB(56) /43./ DATA WIDTAB(57) /36./ DATA WIDTAB(58) /31./ DATA WIDTAB(59) /29./ DATA WIDTAB(60) /18./ DATA WIDTAB(61) /18./ DATA WIDTAB(62) /19./ DATA WIDTAB(63) /19./ DATA WIDTAB(64) /40./ DATA WIDTAB(65) / 8./ DATA WIDTAB(66) /22./ DATA WIDTAB(67) /21./ DATA WIDTAB(68) /20./ DATA WIDTAB(69) /25./ DATA WIDTAB(70) /19./ DATA WIDTAB(71) /28./ DATA WIDTAB(72) /23./ DATA WIDTAB(73) /25./ DATA WIDTAB(74) /12./ DATA WIDTAB(75) /19./ DATA WIDTAB(76) /24./ DATA WIDTAB(77) /13./ DATA WIDTAB(78) /34./ DATA WIDTAB(79) /25./ DATA WIDTAB(80) /20./ DATA WIDTAB(81) /25./ DATA WIDTAB(82) /21./ DATA WIDTAB(83) /20./ DATA WIDTAB(84) /19./ DATA WIDTAB(85) /15./ DATA WIDTAB(86) /22./ DATA WIDTAB(87) /22./ DATA WIDTAB(88) /31./ DATA WIDTAB(89) /24./ DATA WIDTAB(90) /23./ DATA WIDTAB(91) /21./ DATA WIDTAB(92) /19./ DATA WIDTAB(93) / 5./ DATA WIDTAB(94) /19./ DATA WIDTAB(95) /17./ C C-----START POINT----------------------------------------------------- C C C ************************************************************** C ** STEP 1 - SUM UP THE LENGTH OF THE STRING (IN "DOTS") ** C ************************************************************** C SUM=0. DO100I=1,NCTEXT ICTEMP=ICTEXT(I) IC=ICTEMP(1:1) CALL DPCOAN(IC,IVALUE) CCCCC THE FOLLOWING LINE WAS FIXED APRIL 1992 CCCCC IF(IVALUE.LT.32..OR.IIVALUE.GT.126)GOTO100 IF(IVALUE.LT.32.OR.IVALUE.GT.126)GOTO100 IVALUE=IVALUE-31 SUM=SUM+WIDTAB(IVALUE) 100 CONTINUE C C ************************************************************** C ** STEP 2 - CONVERT DOTS TO DATAPLOT PERCENT UNITS ** C ************************************************************** C PLEC=100.*(SUM/ANUMPP) PLECG=PLEC C C ************************************************************** C ** RETURN ** C ************************************************************** C RETURN END SUBROUTINE QUICH4(ICTEXT,NCTEXT,PLEC,PLECG,ANUMPP) C C PURPOSE--FOR THE QMS GRAPHICS DEVICE, C FOR THE "16" (SIMPLEX ROMAN FONT) C 5 POINT PROPORTIONAL FONT (TABLE ON APPENDIX B-10 OF C QUIC PROGRAMMERS MANUAL FROM QMS) C AND FOR THE HORIZONTAL DIRECTION, C DETERMINE THE LENGTH OF THE TEXT STRING IN THE C CHARACTER VECTOR ICTEXT(.), C WHICH CONSISTS OF NTEXT CHARACTERS. C NOTE--THE LENGTH IS IN STANDARDIZED COORDINATES C THAT IS, 0.0 TO 100.0 C C WRITTEN BY--ALAN HECKERT C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONCTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--89.2 C ORIGINAL VERSION--JANUARY 1989. C UPDATED --APRIL 1992. IIVALUE TO IVALUE C C-----NON-COMMON VARIABLES (GRAPHICS)------------------------------------------- C CHARACTER*4 ICTEXT CHARACTER*4 ICTEMP CHARACTER*1 IC C DIMENSION ICTEXT(*) C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOGR.INC' INCLUDE 'DPCOBE.INC' INCLUDE 'DPCODV.INC' C C-----COMMON VARIABLES (GENERAL)-------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C WIDTH TABLE, NOTE THAT ASCII CHARACTER 1-31 ARE CONTROL C CHARACTERS WITH ZERO WIDTH, CHARACTERS 127-255 ARE UNDEFINED. C THERFORE TABLE GOES FROM 32 TO 126. C DIMENSION WIDTAB(95) C DATA WIDTAB( 1) /13./ DATA WIDTAB( 2) / 9./ DATA WIDTAB( 3) /13./ DATA WIDTAB( 4) /17./ DATA WIDTAB( 5) /17./ DATA WIDTAB( 6) /19./ DATA WIDTAB( 7) /19./ DATA WIDTAB( 8) / 9./ DATA WIDTAB( 9) /11./ DATA WIDTAB(10) /11./ DATA WIDTAB(11) /13./ DATA WIDTAB(12) /21./ DATA WIDTAB(13) / 9./ DATA WIDTAB(14) /21./ DATA WIDTAB(15) / 9./ DATA WIDTAB(16) /17./ DATA WIDTAB(17) /17./ DATA WIDTAB(18) /17./ DATA WIDTAB(19) /17./ DATA WIDTAB(20) /17./ DATA WIDTAB(21) /17./ DATA WIDTAB(22) /17./ DATA WIDTAB(23) /17./ DATA WIDTAB(24) /17./ DATA WIDTAB(25) /17./ DATA WIDTAB(26) /17./ DATA WIDTAB(27) / 9./ DATA WIDTAB(28) / 9./ DATA WIDTAB(29) /19./ DATA WIDTAB(30) /21./ DATA WIDTAB(31) /19./ DATA WIDTAB(32) /15./ DATA WIDTAB(33) /17./ DATA WIDTAB(34) /15./ DATA WIDTAB(35) /17./ DATA WIDTAB(36) /17./ DATA WIDTAB(37) /17./ DATA WIDTAB(38) /16./ DATA WIDTAB(39) /15./ DATA WIDTAB(40) /17./ DATA WIDTAB(41) /17./ DATA WIDTAB(42) / 7./ DATA WIDTAB(43) /13./ DATA WIDTAB(44) /17./ DATA WIDTAB(45) /14./ DATA WIDTAB(46) /19./ DATA WIDTAB(47) /17./ DATA WIDTAB(48) /17./ DATA WIDTAB(49) /17./ DATA WIDTAB(50) /17./ DATA WIDTAB(51) /17./ DATA WIDTAB(52) /17./ DATA WIDTAB(53) /13./ DATA WIDTAB(54) /17./ DATA WIDTAB(55) /15./ DATA WIDTAB(56) /19./ DATA WIDTAB(57) /17./ DATA WIDTAB(58) /15./ DATA WIDTAB(59) /17./ DATA WIDTAB(60) /11./ DATA WIDTAB(61) /15./ DATA WIDTAB(62) /11./ DATA WIDTAB(63) /13./ DATA WIDTAB(64) /15./ DATA WIDTAB(65) / 9./ DATA WIDTAB(66) /16./ DATA WIDTAB(67) /16./ DATA WIDTAB(68) /15./ DATA WIDTAB(69) /16./ DATA WIDTAB(70) /15./ DATA WIDTAB(71) /10./ DATA WIDTAB(72) /16./ DATA WIDTAB(73) /16./ DATA WIDTAB(74) / 7./ DATA WIDTAB(75) / 9./ DATA WIDTAB(76) /14./ DATA WIDTAB(77) / 7./ DATA WIDTAB(78) /17./ DATA WIDTAB(79) /16./ DATA WIDTAB(80) /16./ DATA WIDTAB(81) /16./ DATA WIDTAB(82) /16./ DATA WIDTAB(83) /11./ DATA WIDTAB(84) /14./ DATA WIDTAB(85) /10./ DATA WIDTAB(86) /16./ DATA WIDTAB(87) /13./ DATA WIDTAB(88) /17./ DATA WIDTAB(89) /14./ DATA WIDTAB(90) /13./ DATA WIDTAB(91) /14./ DATA WIDTAB(92) /11./ DATA WIDTAB(93) / 7./ DATA WIDTAB(94) /11./ DATA WIDTAB(95) /19./ C C-----START POINT----------------------------------------------------- C C C ************************************************************** C ** STEP 1 - SUM UP THE LENGTH OF THE STRING (IN "DOTS") ** C ************************************************************** C SUM=0. DO100I=1,NCTEXT ICTEMP=ICTEXT(I) IC=ICTEMP(1:1) CALL DPCOAN(IC,IVALUE) CCCCC THE FOLLOWING LINE WAS FIXED APRIL 1992 CCCCC IF(IVALUE.LT.32..OR.IIVALUE.GT.126)GOTO100 IF(IVALUE.LT.32.OR.IVALUE.GT.126)GOTO100 IVALUE=IVALUE-31 SUM=SUM+WIDTAB(IVALUE) 100 CONTINUE C C ************************************************************** C ** STEP 2 - CONVERT DOTS TO DATAPLOT PERCENT UNITS ** C ************************************************************** C PLEC=100.*(SUM/ANUMPP) PLECG=PLEC C C ************************************************************** C ** RETURN ** C ************************************************************** C RETURN END SUBROUTINE QUICH5(ICTEXT,NCTEXT,PLEC,PLECG,ANUMPP) C C PURPOSE--FOR THE QMS GRAPHICS DEVICE, C FOR THE "204" (APOLLO MEDIUM FONT) C 10 POINT PROPORTIONAL FONT (TABLE ON APPENDIX B-12 OF C QUIC PROGRAMMERS MANUAL FROM QMS) C AND FOR THE HORIZONTAL DIRECTION, C DETERMINE THE LENGTH OF THE TEXT STRING IN THE C CHARACTER VECTOR ICTEXT(.), C WHICH CONSISTS OF NTEXT CHARACTERS. C NOTE--THE LENGTH IS IN STANDARDIZED COORDINATES C THAT IS, 0.0 TO 100.0 C C WRITTEN BY--ALAN HECKERT C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONCTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--89.2 C ORIGINAL VERSION--JANUARY 1989. C UPDATED --APRIL 1992. IIVALUE TO IVALUE C C-----NON-COMMON VARIABLES (GRAPHICS)------------------------------------------- C CHARACTER*4 ICTEXT CHARACTER*4 ICTEMP CHARACTER*1 IC C DIMENSION ICTEXT(*) C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOGR.INC' INCLUDE 'DPCOBE.INC' INCLUDE 'DPCODV.INC' C C-----COMMON VARIABLES (GENERAL)-------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C WIDTH TABLE, NOTE THAT ASCII CHARACTER 1-31 ARE CONTROL C CHARACTERS WITH ZERO WIDTH, CHARACTERS 127-255 ARE UNDEFINED. C THERFORE TABLE GOES FROM 32 TO 126. C DIMENSION WIDTAB(95) C DATA WIDTAB( 1) /23./ DATA WIDTAB( 2) / 9./ DATA WIDTAB( 3) /14./ DATA WIDTAB( 4) /28./ DATA WIDTAB( 5) /21./ DATA WIDTAB( 6) /32./ DATA WIDTAB( 7) /31./ DATA WIDTAB( 8) / 7./ DATA WIDTAB( 9) /12./ DATA WIDTAB(10) /12./ DATA WIDTAB(11) /19./ DATA WIDTAB(12) /26./ DATA WIDTAB(13) /10./ DATA WIDTAB(14) /25./ DATA WIDTAB(15) / 8./ DATA WIDTAB(16) /16./ DATA WIDTAB(17) /28./ DATA WIDTAB(18) /28./ DATA WIDTAB(19) /28./ DATA WIDTAB(20) /28./ DATA WIDTAB(21) /28./ DATA WIDTAB(22) /28./ DATA WIDTAB(23) /28./ DATA WIDTAB(24) /28./ DATA WIDTAB(25) /28./ DATA WIDTAB(26) /28./ DATA WIDTAB(27) / 8./ DATA WIDTAB(28) /10./ DATA WIDTAB(29) /13./ DATA WIDTAB(30) /25./ DATA WIDTAB(31) /13./ DATA WIDTAB(32) /22./ DATA WIDTAB(33) /34./ DATA WIDTAB(34) /31./ DATA WIDTAB(35) /28./ DATA WIDTAB(36) /30./ DATA WIDTAB(37) /31./ DATA WIDTAB(38) /26./ DATA WIDTAB(39) /24./ DATA WIDTAB(40) /29./ DATA WIDTAB(41) /30./ DATA WIDTAB(42) /11./ DATA WIDTAB(43) /22./ DATA WIDTAB(44) /28./ DATA WIDTAB(45) /24./ DATA WIDTAB(46) /33./ DATA WIDTAB(47) /25./ DATA WIDTAB(48) /33./ DATA WIDTAB(49) /25./ DATA WIDTAB(50) /33./ DATA WIDTAB(51) /26./ DATA WIDTAB(52) /27./ DATA WIDTAB(53) /27./ DATA WIDTAB(54) /31./ DATA WIDTAB(55) /31./ DATA WIDTAB(56) /48./ DATA WIDTAB(57) /30./ DATA WIDTAB(58) /31./ DATA WIDTAB(59) /28./ DATA WIDTAB(60) /11./ DATA WIDTAB(61) /16./ DATA WIDTAB(62) /11./ DATA WIDTAB(63) /21./ DATA WIDTAB(64) /35./ DATA WIDTAB(65) / 7./ DATA WIDTAB(66) /25./ DATA WIDTAB(67) /27./ DATA WIDTAB(68) /24./ DATA WIDTAB(69) /27./ DATA WIDTAB(70) /25./ DATA WIDTAB(71) /19./ DATA WIDTAB(72) /26./ DATA WIDTAB(73) /23./ DATA WIDTAB(74) /11./ DATA WIDTAB(75) /14./ DATA WIDTAB(76) /23./ DATA WIDTAB(77) /11./ DATA WIDTAB(78) /39./ DATA WIDTAB(79) /25./ DATA WIDTAB(80) /27./ DATA WIDTAB(81) /27./ DATA WIDTAB(82) /27./ DATA WIDTAB(83) /19./ DATA WIDTAB(84) /22./ DATA WIDTAB(85) /17./ DATA WIDTAB(86) /28./ DATA WIDTAB(87) /27./ DATA WIDTAB(88) /40./ DATA WIDTAB(89) /28./ DATA WIDTAB(90) /26./ DATA WIDTAB(91) /22./ DATA WIDTAB(92) /15./ DATA WIDTAB(93) / 6./ DATA WIDTAB(94) /15./ DATA WIDTAB(95) /20./ C C-----START POINT----------------------------------------------------- C C C ************************************************************** C ** STEP 1 - SUM UP THE LENGTH OF THE STRING (IN "DOTS") ** C ************************************************************** C SUM=0. DO100I=1,NCTEXT ICTEMP=ICTEXT(I) IC=ICTEMP(1:1) CALL DPCOAN(IC,IVALUE) CCCCC THE FOLLOWING LINE WAS FIXED APRIL 1992 CCCCC IF(IVALUE.LT.32..OR.IIVALUE.GT.126)GOTO100 IF(IVALUE.LT.32.OR.IVALUE.GT.126)GOTO100 IVALUE=IVALUE-31 SUM=SUM+WIDTAB(IVALUE) 100 CONTINUE C C ************************************************************** C ** STEP 2 - CONVERT DOTS TO DATAPLOT PERCENT UNITS ** C ************************************************************** C PLEC=100.*(SUM/ANUMPP) PLECG=PLEC C C ************************************************************** C ** RETURN ** C ************************************************************** C RETURN END SUBROUTINE QUICH6(ICTEXT,NCTEXT,PLEC,PLECG,ANUMPP) C C PURPOSE--FOR THE QMS GRAPHICS DEVICE, C FOR THE "328" (COMPLEX ROMAN BOLD FONT) C 15 POINT PROPORTIONAL FONT (TABLE ON APPENDIX B-14 OF C QUIC PROGRAMMERS MANUAL FROM QMS) C AND FOR THE HORIZONTAL DIRECTION, C DETERMINE THE LENGTH OF THE TEXT STRING IN THE C CHARACTER VECTOR ICTEXT(.), C WHICH CONSISTS OF NTEXT CHARACTERS. C NOTE--THE LENGTH IS IN STANDARDIZED COORDINATES C THAT IS, 0.0 TO 100.0 C C WRITTEN BY--ALAN HECKERT C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONCTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--89.2 C ORIGINAL VERSION--JANUARY 1989. C UPDATED --APRIL 1992. IIVALUE TO IVALUE C C-----NON-COMMON VARIABLES (GRAPHICS)------------------------------------------- C CHARACTER*4 ICTEXT CHARACTER*4 ICTEMP CHARACTER*1 IC C DIMENSION ICTEXT(*) C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOGR.INC' INCLUDE 'DPCOBE.INC' INCLUDE 'DPCODV.INC' C C-----COMMON VARIABLES (GENERAL)-------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C WIDTH TABLE, NOTE THAT ASCII CHARACTER 1-31 ARE CONTROL C CHARACTERS WITH ZERO WIDTH, CHARACTERS 127-255 ARE UNDEFINED. C THERFORE TABLE GOES FROM 32 TO 126. C DIMENSION WIDTAB(95) C DATA WIDTAB( 1) /35./ DATA WIDTAB( 2) /12./ DATA WIDTAB( 3) /18./ DATA WIDTAB( 4) /41./ DATA WIDTAB( 5) /32./ DATA WIDTAB( 6) /50./ DATA WIDTAB( 7) /52./ DATA WIDTAB( 8) / 8./ DATA WIDTAB( 9) /15./ DATA WIDTAB(10) /15./ DATA WIDTAB(11) /16./ DATA WIDTAB(12) /38./ DATA WIDTAB(13) /13./ DATA WIDTAB(14) /23./ DATA WIDTAB(15) /11./ DATA WIDTAB(16) /28./ DATA WIDTAB(17) /45./ DATA WIDTAB(18) /45./ DATA WIDTAB(19) /45./ DATA WIDTAB(20) /45./ DATA WIDTAB(21) /45./ DATA WIDTAB(22) /45./ DATA WIDTAB(23) /45./ DATA WIDTAB(24) /45./ DATA WIDTAB(25) /45./ DATA WIDTAB(26) /45./ DATA WIDTAB(27) /13./ DATA WIDTAB(28) /13./ DATA WIDTAB(29) /17./ DATA WIDTAB(30) /36./ DATA WIDTAB(31) /17./ DATA WIDTAB(32) /32./ DATA WIDTAB(33) /43./ DATA WIDTAB(34) /51./ DATA WIDTAB(35) /48./ DATA WIDTAB(36) /42./ DATA WIDTAB(37) /49./ DATA WIDTAB(38) /47./ DATA WIDTAB(39) /46./ DATA WIDTAB(40) /48./ DATA WIDTAB(41) /52./ DATA WIDTAB(42) /27./ DATA WIDTAB(43) /40./ DATA WIDTAB(44) /55./ DATA WIDTAB(45) /44./ DATA WIDTAB(46) /63./ DATA WIDTAB(47) /53./ DATA WIDTAB(48) /48./ DATA WIDTAB(49) /45./ DATA WIDTAB(50) /54./ DATA WIDTAB(51) /53./ DATA WIDTAB(52) /40./ DATA WIDTAB(53) /45./ DATA WIDTAB(54) /52./ DATA WIDTAB(55) /49./ DATA WIDTAB(56) /77./ DATA WIDTAB(57) /57./ DATA WIDTAB(58) /56./ DATA WIDTAB(59) /42./ DATA WIDTAB(60) /14./ DATA WIDTAB(61) /28./ DATA WIDTAB(62) /14./ DATA WIDTAB(63) /21./ DATA WIDTAB(64) /50./ DATA WIDTAB(65) / 8./ DATA WIDTAB(66) /36./ DATA WIDTAB(67) /38./ DATA WIDTAB(68) /31./ DATA WIDTAB(69) /40./ DATA WIDTAB(70) /33./ DATA WIDTAB(71) /28./ DATA WIDTAB(72) /41./ DATA WIDTAB(73) /41./ DATA WIDTAB(74) /22./ DATA WIDTAB(75) /23./ DATA WIDTAB(76) /43./ DATA WIDTAB(77) /20./ DATA WIDTAB(78) /60./ DATA WIDTAB(79) /40./ DATA WIDTAB(80) /34./ DATA WIDTAB(81) /39./ DATA WIDTAB(82) /39./ DATA WIDTAB(83) /30./ DATA WIDTAB(84) /31./ DATA WIDTAB(85) /26./ DATA WIDTAB(86) /40./ DATA WIDTAB(87) /39./ DATA WIDTAB(88) /58./ DATA WIDTAB(89) /41./ DATA WIDTAB(90) /41./ DATA WIDTAB(91) /35./ DATA WIDTAB(92) /18./ DATA WIDTAB(93) / 6./ DATA WIDTAB(94) /18./ DATA WIDTAB(95) /34./ C C-----START POINT----------------------------------------------------- C C C ************************************************************** C ** STEP 1 - SUM UP THE LENGTH OF THE STRING (IN "DOTS") ** C ************************************************************** C SUM=0. DO100I=1,NCTEXT ICTEMP=ICTEXT(I) IC=ICTEMP(1:1) CALL DPCOAN(IC,IVALUE) CCCCC THE FOLLOWING LINE WAS FIXED APRIL 1992 CCCCC IF(IVALUE.LT.32..OR.IIVALUE.GT.126)GOTO100 IF(IVALUE.LT.32.OR.IVALUE.GT.126)GOTO100 IVALUE=IVALUE-31 SUM=SUM+WIDTAB(IVALUE) 100 CONTINUE C C ************************************************************** C ** STEP 2 - CONVERT DOTS TO DATAPLOT PERCENT UNITS ** C ************************************************************** C PLEC=100.*(SUM/ANUMPP) PLECG=PLEC C C ************************************************************** C ** RETURN ** C ************************************************************** C RETURN END SUBROUTINE QUICH7(ICTEXT,NCTEXT,PLEC,PLECG,ANUMPP) C C PURPOSE--FOR THE QMS GRAPHICS DEVICE, C FOR THE "998" (COMPLEX ROMAN BOLD FONT) C 15 POINT PROPORTIONAL FONT (NOTE: THIS IS AN NBS MODIFIED C VERSION OF THE 328 FONT. IT WILL NOT BE VALID FOR C OTHER SITES!!!!!! C AND FOR THE HORIZONTAL DIRECTION, C DETERMINE THE LENGTH OF THE TEXT STRING IN THE C CHARACTER VECTOR ICTEXT(.), C WHICH CONSISTS OF NTEXT CHARACTERS. C NOTE--THE LENGTH IS IN STANDARDIZED COORDINATES C THAT IS, 0.0 TO 100.0 C C WRITTEN BY--ALAN HECKERT C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONCTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--89.2 C ORIGINAL VERSION--JANUARY 1989. C UPDATED --APRIL 1992. IIVALUE TO IVALUE C C-----NON-COMMON VARIABLES (GRAPHICS)------------------------------------------- C CHARACTER*4 ICTEXT CHARACTER*4 ICTEMP CHARACTER*1 IC C DIMENSION ICTEXT(*) C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOGR.INC' INCLUDE 'DPCOBE.INC' INCLUDE 'DPCODV.INC' C C-----COMMON VARIABLES (GENERAL)-------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C WIDTH TABLE, NOTE THAT ASCII CHARACTER 1-31 ARE CONTROL C CHARACTERS WITH ZERO WIDTH, CHARACTERS 127-255 ARE UNDEFINED. C THERFORE TABLE GOES FROM 32 TO 126. C DIMENSION WIDTAB(95) C DATA WIDTAB( 1) /35./ DATA WIDTAB( 2) /24./ DATA WIDTAB( 3) /32./ DATA WIDTAB( 4) /41./ DATA WIDTAB( 5) /32./ DATA WIDTAB( 6) /50./ DATA WIDTAB( 7) /52./ DATA WIDTAB( 8) /20./ DATA WIDTAB( 9) /27./ DATA WIDTAB(10) /27./ DATA WIDTAB(11) /32./ DATA WIDTAB(12) /38./ DATA WIDTAB(13) /25./ DATA WIDTAB(14) /23./ DATA WIDTAB(15) /23./ DATA WIDTAB(16) /28./ DATA WIDTAB(17) /45./ DATA WIDTAB(18) /45./ DATA WIDTAB(19) /45./ DATA WIDTAB(20) /45./ DATA WIDTAB(21) /45./ DATA WIDTAB(22) /45./ DATA WIDTAB(23) /45./ DATA WIDTAB(24) /45./ DATA WIDTAB(25) /45./ DATA WIDTAB(26) /45./ DATA WIDTAB(27) /25./ DATA WIDTAB(28) /25./ DATA WIDTAB(29) /38./ DATA WIDTAB(30) /36./ DATA WIDTAB(31) /38./ DATA WIDTAB(32) /32./ DATA WIDTAB(33) /43./ DATA WIDTAB(34) /51./ DATA WIDTAB(35) /48./ DATA WIDTAB(36) /42./ DATA WIDTAB(37) /49./ DATA WIDTAB(38) /47./ DATA WIDTAB(39) /46./ DATA WIDTAB(40) /48./ DATA WIDTAB(41) /52./ DATA WIDTAB(42) /27./ DATA WIDTAB(43) /40./ DATA WIDTAB(44) /55./ DATA WIDTAB(45) /44./ DATA WIDTAB(46) /63./ DATA WIDTAB(47) /53./ DATA WIDTAB(48) /48./ DATA WIDTAB(49) /45./ DATA WIDTAB(50) /54./ DATA WIDTAB(51) /53./ DATA WIDTAB(52) /40./ DATA WIDTAB(53) /45./ DATA WIDTAB(54) /52./ DATA WIDTAB(55) /49./ DATA WIDTAB(56) /77./ DATA WIDTAB(57) /57./ DATA WIDTAB(58) /56./ DATA WIDTAB(59) /42./ DATA WIDTAB(60) /26./ DATA WIDTAB(61) /28./ DATA WIDTAB(62) /26./ DATA WIDTAB(63) /33./ DATA WIDTAB(64) /50./ DATA WIDTAB(65) /36./ DATA WIDTAB(66) /36./ DATA WIDTAB(67) /38./ DATA WIDTAB(68) /31./ DATA WIDTAB(69) /40./ DATA WIDTAB(70) /33./ DATA WIDTAB(71) /28./ DATA WIDTAB(72) /41./ DATA WIDTAB(73) /41./ DATA WIDTAB(74) /22./ DATA WIDTAB(75) /23./ DATA WIDTAB(76) /43./ DATA WIDTAB(77) /20./ DATA WIDTAB(78) /60./ DATA WIDTAB(79) /40./ DATA WIDTAB(80) /34./ DATA WIDTAB(81) /39./ DATA WIDTAB(82) /39./ DATA WIDTAB(83) /30./ DATA WIDTAB(84) /31./ DATA WIDTAB(85) /26./ DATA WIDTAB(86) /40./ DATA WIDTAB(87) /39./ DATA WIDTAB(88) /58./ DATA WIDTAB(89) /41./ DATA WIDTAB(90) /41./ DATA WIDTAB(91) /35./ DATA WIDTAB(92) /30./ DATA WIDTAB(93) /18./ DATA WIDTAB(94) /30./ DATA WIDTAB(95) /34./ C C-----START POINT----------------------------------------------------- C C C ************************************************************** C ** STEP 1 - SUM UP THE LENGTH OF THE STRING (IN "DOTS") ** C ************************************************************** C SUM=0. DO100I=1,NCTEXT ICTEMP=ICTEXT(I) IC=ICTEMP(1:1) CALL DPCOAN(IC,IVALUE) CCCCC THE FOLLOWING LINE WAS FIXED APRIL 1992 CCCCC IF(IVALUE.LT.32..OR.IIVALUE.GT.126)GOTO100 IF(IVALUE.LT.32.OR.IVALUE.GT.126)GOTO100 IVALUE=IVALUE-31 SUM=SUM+WIDTAB(IVALUE) 100 CONTINUE C C ************************************************************** C ** STEP 2 - CONVERT DOTS TO DATAPLOT PERCENT UNITS ** C ************************************************************** C PLEC=100.*(SUM/ANUMPP) PLECG=PLEC C C ************************************************************** C ** RETURN ** C ************************************************************** C RETURN END SUBROUTINE QUICH8(ICTEXT,NCTEXT,PLEC,PLECG,ANUMPP) C C PURPOSE--FOR THE QMS GRAPHICS DEVICE, C FOR THE "664" (SPECIAL MATH FONT) C 10 POINT PROPORTIONAL FONT (TABLE FROM QMS) C AND FOR THE HORIZONTAL DIRECTION, C DETERMINE THE LENGTH OF THE TEXT STRING IN THE C CHARACTER VECTOR ICTEXT(.), C WHICH CONSISTS OF NTEXT CHARACTERS. C NOTE--THE LENGTH IS IN STANDARDIZED COORDINATES C THAT IS, 0.0 TO 100.0 C C WRITTEN BY--ALAN HECKERT C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONCTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--89.2 C ORIGINAL VERSION--JANUARY 1989. C UPDATED --APRIL 1992. IIVALUE TO IVALUE C C-----NON-COMMON VARIABLES (GRAPHICS)------------------------------------------- C CHARACTER*4 ICTEXT CHARACTER*4 ICTEMP CHARACTER*1 IC C DIMENSION ICTEXT(*) C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOGR.INC' INCLUDE 'DPCOBE.INC' INCLUDE 'DPCODV.INC' C C-----COMMON VARIABLES (GENERAL)-------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C WIDTH TABLE, NOTE THAT ASCII CHARACTER 1-31 ARE CONTROL C CHARACTERS, REPLACED WITH SPECIAL SYMBOLS IN THIS FONT. WIDTH C INCLUDED, BUT NOT YET SURE HOW TO GET DATAPLOT TO USE THESE YET. C DIMENSION WIDTAB(128) C DATA WIDTAB( 1) / 0./ DATA WIDTAB( 2) /40./ DATA WIDTAB( 3) /42./ DATA WIDTAB( 4) /32./ DATA WIDTAB( 5) /48./ DATA WIDTAB( 6) /42./ DATA WIDTAB( 7) /22./ DATA WIDTAB( 8) /47./ DATA WIDTAB( 9) /42./ DATA WIDTAB(10) /42./ DATA WIDTAB(11) /42./ DATA WIDTAB(12) /35./ DATA WIDTAB(13) /20./ DATA WIDTAB(14) /28./ DATA WIDTAB(15) /17./ DATA WIDTAB(16) /10./ DATA WIDTAB(17) /10./ DATA WIDTAB(18) /10./ DATA WIDTAB(19) /10./ DATA WIDTAB(20) /10./ DATA WIDTAB(21) /10./ DATA WIDTAB(22) /10./ DATA WIDTAB(23) /10./ DATA WIDTAB(24) /10./ DATA WIDTAB(25) /10./ DATA WIDTAB(26) /10./ DATA WIDTAB(27) /42./ DATA WIDTAB(28) /42./ DATA WIDTAB(29) /42./ DATA WIDTAB(30) /25./ DATA WIDTAB(31) /48./ DATA WIDTAB(32) /32./ DATA WIDTAB(33) /25./ DATA WIDTAB(34) / 0./ DATA WIDTAB(35) /15./ DATA WIDTAB(36) /33./ DATA WIDTAB(37) / 0./ DATA WIDTAB(38) / 0./ DATA WIDTAB(39) / 0./ DATA WIDTAB(40) /12./ DATA WIDTAB(41) /42./ DATA WIDTAB(42) / 0./ DATA WIDTAB(43) /32./ DATA WIDTAB(44) /32./ DATA WIDTAB(45) / 0./ DATA WIDTAB(46) /32./ DATA WIDTAB(47) / 0./ DATA WIDTAB(48) /32./ DATA WIDTAB(49) /42./ DATA WIDTAB(50) /42./ DATA WIDTAB(51) /42./ DATA WIDTAB(52) /42./ DATA WIDTAB(53) /42./ DATA WIDTAB(54) /42./ DATA WIDTAB(55) /20./ DATA WIDTAB(56) /20./ DATA WIDTAB(57) /20./ DATA WIDTAB(58) /18./ DATA WIDTAB(59) / 0./ DATA WIDTAB(60) / 0./ DATA WIDTAB(61) /42./ DATA WIDTAB(62) /32./ DATA WIDTAB(63) /42./ DATA WIDTAB(64) / 0./ DATA WIDTAB(65) /38./ DATA WIDTAB(66) / 0./ DATA WIDTAB(67) / 0./ DATA WIDTAB(68) /28./ DATA WIDTAB(69) /30./ DATA WIDTAB(70) / 0./ DATA WIDTAB(71) / 0./ DATA WIDTAB(72) / 0./ DATA WIDTAB(73) /32./ DATA WIDTAB(74) / 0./ DATA WIDTAB(75) / 0./ DATA WIDTAB(76) /32./ DATA WIDTAB(77) / 0./ DATA WIDTAB(78) / 0./ DATA WIDTAB(79) /32./ DATA WIDTAB(80) / 0./ DATA WIDTAB(81) /33./ DATA WIDTAB(82) / 0./ DATA WIDTAB(83) /28./ DATA WIDTAB(84) / 0./ DATA WIDTAB(85) /32./ DATA WIDTAB(86) /33./ DATA WIDTAB(87) / 0./ DATA WIDTAB(88) /37./ DATA WIDTAB(89) /42./ DATA WIDTAB(90) /20./ DATA WIDTAB(91) / 3./ DATA WIDTAB(92) /42./ DATA WIDTAB(93) /17./ DATA WIDTAB(94) /32./ DATA WIDTAB(95) /17./ DATA WIDTAB(96) /34./ DATA WIDTAB(97) /12./ DATA WIDTAB(98) /28./ DATA WIDTAB(99) /27./ DATA WIDTAB(100) /27./ DATA WIDTAB(101) /22./ DATA WIDTAB(102) /20./ DATA WIDTAB(103) /20./ DATA WIDTAB(104) /27./ DATA WIDTAB(105) /22./ DATA WIDTAB(106) /15./ DATA WIDTAB(107) /23./ DATA WIDTAB(108) /25./ DATA WIDTAB(109) /28./ DATA WIDTAB(110) /23./ DATA WIDTAB(111) /23./ DATA WIDTAB(112) /23./ DATA WIDTAB(113) /32./ DATA WIDTAB(114) /23./ DATA WIDTAB(115) /32./ DATA WIDTAB(116) /23./ DATA WIDTAB(117) /23./ DATA WIDTAB(118) /28./ DATA WIDTAB(119) /25./ DATA WIDTAB(120) /28./ DATA WIDTAB(121) /28./ DATA WIDTAB(122) /23./ DATA WIDTAB(123) /32./ DATA WIDTAB(124) /17./ DATA WIDTAB(125) /10./ DATA WIDTAB(126) /17./ DATA WIDTAB(127) /17./ DATA WIDTAB(128) / 0./ C C-----START POINT----------------------------------------------------- C C C ************************************************************** C ** STEP 1 - SUM UP THE LENGTH OF THE STRING (IN "DOTS") ** C ************************************************************** C SUM=0. DO100I=1,NCTEXT ICTEMP=ICTEXT(I) IC=ICTEMP(1:1) CALL DPCOAN(IC,IVALUE) CCCCC THE FOLLOWING LINE WAS FIXED APRIL 1992 CCCCC IF(IVALUE.LT.32..OR.IIVALUE.GT.126)GOTO100 IF(IVALUE.LT.32.OR.IVALUE.GT.126)GOTO100 IVALUE=IVALUE+1 SUM=SUM+WIDTAB(IVALUE) 100 CONTINUE C C ************************************************************** C ** STEP 2 - CONVERT DOTS TO DATAPLOT PERCENT UNITS ** C ************************************************************** C PLEC=100.*(SUM/ANUMPP) PLECG=PLEC C C ************************************************************** C ** RETURN ** C ************************************************************** C RETURN END SUBROUTINE QUICPT(PX1,PY1,IX1,IY1,ISUBN0) C C THIS ROUTINE IS A MODIFIED VERSION OF GRTRSD. IT IS USED C ONLY BY THE "QUIC" DEVICES (QMS LASER PRINTER). C QUICPT CONVERTS FROM DATAPLOT C UNITS TO DEVICE INTEGER UNITS, BUT IT ALSO APPLIES "WINDOW" C TRANSFORMATIONS NEEDED BY THE "MULTI-PLOT" AND "WINDOW C COORDINATE" COMMANDS. THE QUIC COORDINATES NEED TO BE TRANSLATED C TO INCHES IN THE FORM (XXXXX) WHERE THERE IS AN IMPLIED DECIMAL C POINT BETWEEN THE SECOND AND THIRD "X". C C QUIC USES 300 DOT PER INCH RESOLUTION. THE DIMENSIONS OF THE C PAGE ARE DETERMINED BY USING (PICTURE POINTS/DOTS PER INCH). C C PURPOSE--TRANSLATE THE STANDARDIZED (0.0 TO 100.0) COORDINATES (PX1,PY1) C INTO (INTEGER PICTURE POINT) DEVICE COORDINATES (AX1,AY1) C ISUBN0 = NAME OF SUBROUTINE WHICH CALLED GRWRST. C (AND THEREBY HAVE WALKBACK INFORMATION). C NOTE--THE ONLY VARIABLES IN THE PLOT CONTROL COMMON C THAT ARE USED HEREIN ARE THE ONES IN /RWIND/ C C WRITTEN BY--ALAN HECKERT C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--88.6 C ORIGINAL VERSION--JANUARY 1989. C C-----NON-COMMON VARIABLES (GRAPHICS)------------------------------------------- C CHARACTER*4 ISUBN0 C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'DPCOPC.INC' INCLUDE 'DPCOGR.INC' INCLUDE 'DPCOBE.INC' INCLUDE 'DPCODV.INC' C C-----COMMON VARIABLES (GENERAL)-------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IERRG4='NO' C IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'ICPT')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF QUICPT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)ISUBN0 52 FORMAT('ISUBN0 (NAME OF THE CALLING SUBROUTINE) = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)IMANUF,IMODEL 53 FORMAT('IMANUF,IMODEL = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)NUMHPP,NUMVPP 54 FORMAT('NUMHPP,NUMVPP = ',I8,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,55)ANUMHP,ANUMVP 55 FORMAT('ANUMHP,ANUMVP = ',E15.7,E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,56)PX1,PY1 56 FORMAT('PX1,PY1 = ',E15.7,E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,57)IOFFSH,IOFFSV 57 FORMAT('IOFFSH,IOFFSV = ',I10,I10) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,61)PWXMIN,PWXMAX,PWYMIN,PWYMAX 61 FORMAT('PWXMIN,PWXMAX,PWYMIN,PWYMAX = ',4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,69)IBUGG4 69 FORMAT('IBUGG4 = ',A4) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C ************************************** C ** STEP 0-- ** C ** DETERMINE THE DIMENSION OF THE ** C ** IN INCHES ** C ************************************** C DOTPPI=QUIPPI XPAGE=ANUMHP/DOTPPI YPAGE=ANUMVP/DOTPPI C C ************************************* C ** STEP 1-- ** C ** CARRY OUT THE TRANSFORMATION. ** C ************************************* C C NOTE: QMS POSITIONS FROM TOP TO BOTTOM RATHER THAN BOTTOM TO C TOP AS DATAPLOT ASSUMES. CONVERT PWYMIN AND PWYMAX TO C REFLECT THIS. C PWYMNT=100.-PWYMAX PWYMXT=100.-PWYMIN C AX1=PWXMIN+(PX1/100.0)*(PWXMAX-PWXMIN) IF(AX1.LE.0.0)AX1=0.0 IF(AX1.GE.100.)AX1=100. C AY1=PWYMNT+(PY1/100.0)*(PWYMXT-PWYMNT) IF(AY1.LE.0.0)AY1=0.0 IF(AY1.GE.100.)AY1=100. C C ************************************** C ** STEP 2-- ** C ** CONVERT TO INCH FORMAT "XXXXX" ** C ** WITH IMPLIED DECIMAL AFTER ** C ** SECOND "X" ** C ** INCH = PAGE SIZE * VALUE/100 ** C ** QMS FORMAT=INT(INCH*1000.) ** C ** NOTE: THE LEFT AND TOP MARGINS ** C ** NEED TO BE ADDED IN SINCE ** C ** THE "ABSOLUTE" POSITIONING** C ** COMMANDS ARE FROM PAGE ** C ** RATHER THAN MARGIN BOUNDARY* C ************************************** C ALMRG=1000.*REAL(IOFFSH)/DOTPPI ATPMRG=1000.*REAL(IOFFSV)/DOTPPI AXINCH=XPAGE*AX1*10.+ALMRG AYINCH=YPAGE*AY1*10.+ATPMRG IX1=INT(AXINCH+0.5) IY1=INT(AYINCH+0.5) C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'ICPT')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF QUICPT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)PX1,PY1 9015 FORMAT('PX1,PY1 = ',E15.7,E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9018)IX1,IY1 9018 FORMAT('IX1,IY1 = ',I8,I8) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE QUAFRM(AMAT,MAXROM,MAXCOM,NR1,NC1,X,IWRITE, 1XQUAD,IBUGA3,IERROR) C C PURPOSE--THIS SUBROUTINE COMPUTES THE C QUADRATIC FORM OF A VECTOR AND A SQUARE MATRIX, C I.E., x'Mx C THE RESULT IS A SCALAR. C INPUT ARGUMENTS--AMAT = THE SINGLE PRECISION MATRIX C --X = THE SINGLE PRECISION VECTOR C --MAXROM = THE INTEGER ROW DIMENSION OF AMAT C --MAXCOM = THE INTEGER COUMN DIMENSION OF AMAT C --NR1 = THE INTEGER NUMBER OF ROWS OF AMAT C --NC1 = THE INTEGER NUMBER OF COLUMNS OF AMAT C OUTPUT ARGUMENTS--XQUAD = THE SINGLE PRECISION VALUE OF THE C COMPUTED SAMPLE QUADRATIC FORM. C OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE C QUADRATIC FORM. C NOTE--THIS ROUTINE ASSUMES THE ERROR CHECKING (FOR EQUAL C ROWS AND COLUMNS, MATCHING DIMENSIONS FOR X AND AMAT) C IS DONE BT THE CALLING SUBROUTINE. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C LANGUAGE--ANSI FORTRAN (1977) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--98.6 C ORIGINAL VERSION--JUNE 1998. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IWRITE CHARACTER*4 IBUGA3 CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C DOUBLE PRECISION DSUM DOUBLE PRECISION DYM1 DOUBLE PRECISION DYM2 DOUBLE PRECISION DYM3 C DIMENSION AMAT(MAXROM,MAXCOM) DIMENSION X(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='QUAF' ISUBN2='RM ' C IERROR='NO' C IF(IBUGA3.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF QUAFRM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA3 52 FORMAT('IBUGA3 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)NR1,NC1 53 FORMAT('NR1, NC1 = ',2I8) CALL DPWRST('XXX','BUG ') DO55I=1,NR1 WRITE(ICOUT,56)I,X(I) 56 FORMAT('I,X(I) = ',I8,E15.7) CALL DPWRST('XXX','BUG ') 55 CONTINUE 90 CONTINUE C C ****************************** C ** COMPUTE QUADRATIC FORM ** C ****************************** C DSUM=0.0D0 DO5861I=1,NR1 DO5863J=1,NC1 DYM1=AMAT(I,J) DYM2=X(I) DYM3=X(J) DSUM=DSUM+DYM2*DYM1*DYM3 5863 CONTINUE 5861 CONTINUE C XQUAD=REAL(DSUM) C C ******************************* C ** STEP 3-- ** C ** WRITE OUT A LINE ** C ** OF SUMMARY INFORMATION. ** C ******************************* C IF(IFEEDB.EQ.'OFF')GOTO890 IF(IWRITE.EQ.'OFF'.OR.IWRITE.EQ.'NO')GOTO890 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,811)XQUAD 811 FORMAT('THE QUADRATIC FORM = ',E15.7) CALL DPWRST('XXX','BUG ') 890 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE IF(IBUGA3.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF QUAFRM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGA3,IERROR 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)NR1,NC1 9013 FORMAT('NR1,NC1 = ',2I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)XQUAD 9015 FORMAT('XQUAFRM = ',E15.7) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE QUANT(QNT,X,N,IWRITE,XTEMP,MAXNXT, 1IQUAME, 1XQUANT,IBUGA3,IERROR) C C PURPOSE--THIS SUBROUTINE COMPUTES THE C SAMPLE QUANTTILE C OF THE DATA IN THE INPUT VECTOR X. C INPUT ARGUMENTS--QNT = THE SINGLE PRECISION QUANTILE C (BETWEEN 0 AND 1) C --X = THE SINGLE PRECISION VECTOR OF C (UNSORTED OR SORTED) OBSERVATIONS. C --IQUAME = METHOD: C 1. ORDER STATISTIC (IQUAME=ORDE) C 2. HERRELL-DAVIS (IQUAME=HD) C --N = THE INTEGER NUMBER OF OBSERVATIONS C IN THE VECTOR X. C OUTPUT ARGUMENTS--XQUANT = THE SINGLE PRECISION VALUE OF THE C COMPUTED SAMPLE QUANTTILE. C OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE C SAMPLE QUANTTILE. C OTHER DATAPAC SUBROUTINES NEEDED--SORT. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES-- C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--2002.7 C ORIGINAL VERSION--JULY 2002. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IWRITE CHARACTER*4 IBUGA3 CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C CHARACTER*4 IQUAME C CHARACTER*16 IMETH C C--------------------------------------------------------------------- C DIMENSION X(*) DIMENSION XTEMP(*) C DOUBLE PRECISION DTEMP1 DOUBLE PRECISION DTEMP2 DOUBLE PRECISION WTEMP DOUBLE PRECISION DSUM1 DOUBLE PRECISION DBETAI DOUBLE PRECISION DA DOUBLE PRECISION DB C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='QUAN' ISUBN2='T ' C IERROR='NO' C NI=0 NIP1=0 C ANI=0.0 A2NI=0.0 REM=0.0 C IF(IBUGA3.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF QUANT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA3 52 FORMAT('IBUGA3 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)QNT,N 53 FORMAT('QNT,N = ',E15.7,I8) CALL DPWRST('XXX','BUG ') DO55I=1,N WRITE(ICOUT,56)I,X(I) 56 FORMAT('I,X(I) = ',I8,E15.7) CALL DPWRST('XXX','BUG ') 55 CONTINUE 90 CONTINUE C C ****************************** C ** COMPUTE QUANTTILE ** C ****************************** C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C AN=N C IF(0.0.LE.QNT.AND.QNT.LE.1.0)GOTO119 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,111) 111 FORMAT('***** ERROR IN QUANT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,112) 112 FORMAT(' THE INPUT QUANTILE TO BE COMPUTED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,115) 115 FORMAT(' MUST BE LARGER THAN 0 AND SMALLER THAN 1.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,116) 116 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,117)QNT 117 FORMAT(' THE INPUT QUANTILE = ',E15.7) CALL DPWRST('XXX','BUG ') GOTO9000 119 CONTINUE C IF(1.LE.N.AND.N.LE.MAXNXT)GOTO129 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,121) 121 FORMAT('***** ERROR IN QUANT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,122) 122 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS IN THE VARIABLE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,124) 124 FORMAT(' FOR WHICH THE QUANTTILE IS TO BE COMPUTED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,125)MAXNXT 125 FORMAT(' MUST BE BETWEEN 1 AND ',I8,' (INCLUSIVELY).') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,126) 126 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,127)N 127 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS = ',I8, 1'.') CALL DPWRST('XXX','BUG ') GOTO9000 129 CONTINUE C IF(N.EQ.1)GOTO130 GOTO139 130 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,131) 131 FORMAT('***** NON-FATAL DIAGNOSTIC IN QUANT--', 1'THE THIRD INPUT ARGUMENT (N) HAS THE VALUE 1') CALL DPWRST('XXX','BUG ') XQUANT=X(1) GOTO9000 139 CONTINUE C HOLD=X(1) DO145I=2,N IF(X(I).NE.HOLD)GOTO149 145 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,146)HOLD 146 FORMAT('***** NON-FATAL DIAGNOSTIC IN QUANT--', 1'THE INPUT DATA HAS ALL ELEMENTS = ',E15.7) CALL DPWRST('XXX','BUG ') XQUANT=HOLD GOTO9000 149 CONTINUE C 190 CONTINUE C C *********************************** C ** STEP 2-- ** C ** COMPUTE THE QUANTTILE. ** C *********************************** C CALL SORT(X,N,XTEMP) C IF(IQUAME.EQ.'ORDE')THEN P=QNT ANI=P*(AN+1.0) NI=ANI A2NI=NI REM=ANI-A2NI NIP1=NI+1 IF(NI.LE.1)NI=1 IF(NI.GE.N)NI=N IF(NIP1.LE.1)NIP1=1 IF(NIP1.GE.N)NIP1=N XQUANT=(1.0-REM)*XTEMP(NI)+REM*XTEMP(NIP1) IMETH='ORDER STATISTIC' ELSEIF(IQUAME.EQ.'HD')THEN P=QNT CCCCC A=(AN+1.0)*P - 1.0 CCCCC B=(AN+1.0)*(1.0-P) - 1.0 A=(AN+1.0)*P B=(AN+1.0)*(1.0-P) DA=DBLE(A) DB=DBLE(B) IF(A.EQ.0.0)DA=0.1D-15 IF(B.EQ.0.0)DB=0.1D-15 C DSUM1=0.0D0 DO500I=1,N ATEMP1=REAL(I)/AN DTEMP1=DBETAI(DBLE(ATEMP1),DA,DB) ATEMP2=REAL(I-1)/AN DTEMP2=DBETAI(DBLE(ATEMP2),DA,DB) WTEMP=DTEMP1-DTEMP2 DSUM1=DSUM1 + WTEMP*DBLE(XTEMP(I)) 500 CONTINUE C XQUANT=REAL(DSUM1) IMETH='HERRELL-DAVIS' ELSE P=QNT ANI=P*(AN+1.0) NI=ANI A2NI=NI REM=ANI-A2NI NIP1=NI+1 IF(NI.LE.1)NI=1 IF(NI.GE.N)NI=N IF(NIP1.LE.1)NIP1=1 IF(NIP1.GE.N)NIP1=N XQUANT=(1.0-REM)*XTEMP(NI)+REM*XTEMP(NIP1) IMETH='ORDER STATISTIC' END IF C C ******************************* C ** STEP 3-- ** C ** WRITE OUT A LINE ** C ** OF SUMMARY INFORMATION. ** C ******************************* C IF(IFEEDB.EQ.'OFF')GOTO890 IF(IWRITE.EQ.'OFF')GOTO890 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,811)QNT,IMETH,N,XQUANT 811 FORMAT('THE ',F10.2,'-QUANTTILE (',A16,' METHOD) OF THE ',I8, 1' OBSERVATIONS = ',E15.7) CALL DPWRST('XXX','BUG ') 890 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE IF(IBUGA3.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF QUANT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGA3,IERROR 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)QNT,N,P 9013 FORMAT('QNT,N,P = ',E15.7,I8,E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)ANI,NI,A2NI,REM,NIP1 9014 FORMAT('ANI,NI,A2NI,REM,NIP1 = ',E15.7,I8,E15.7,E15.7,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)XQUANT 9015 FORMAT('XQUANT = ',E15.7) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE QUANSE(QNT,X,N,IWRITE,XTEMP,MAXNXT, 1IQUASE, 1XQUASE,IBUGA3,IERROR) C C PURPOSE--THIS SUBROUTINE COMPUTES THE STANDARD ERROR OF A C SAMPLE QUANTTILE, USING EITHER A MARITZ-JARRETT OR C A KERNEL DENSITY BASED METHOD, C OF THE DATA IN THE INPUT VECTOR X. C INPUT ARGUMENTS--QNT = THE SINGLE PRECISION QUANTILE C (BETWEEN 0 AND 1) C --X = THE SINGLE PRECISION VECTOR OF C (UNSORTED OR SORTED) OBSERVATIONS. C --IQUASE = METHOD: C 1. MARITZ-JARRETT (IQUASE=MJ) C 2. KERNEL DENSITY (IQUASE=KD) C --N = THE INTEGER NUMBER OF OBSERVATIONS C IN THE VECTOR X. C OUTPUT ARGUMENTS--XQUASE = THE SINGLE PRECISION VALUE OF THE C COMPUTED SAMPLE QUANTTILE. C OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE C SAMPLE QUANTTILE STANDARD ERROR. C OTHER DATAPAC SUBROUTINES NEEDED--SORT. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES-- C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--2002.7 C ORIGINAL VERSION--JULY 2002. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IWRITE CHARACTER*4 IWRIT2 CHARACTER*4 IBUGA3 CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C CHARACTER*4 IQUAME CHARACTER*4 IQUASE C CHARACTER*16 IMETH C C--------------------------------------------------------------------- C REAL IQRANG DIMENSION X(*) DIMENSION XTEMP(*) C DOUBLE PRECISION DTEMP1 DOUBLE PRECISION DTEMP2 DOUBLE PRECISION WTEMP DOUBLE PRECISION DSUM1 DOUBLE PRECISION DSUM2 DOUBLE PRECISION DBETAI C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='QUAN' ISUBN2='SE ' C IQUAME='ORDE' IERROR='NO' C NI=0 NIP1=0 C ANI=0.0 A2NI=0.0 REM=0.0 C IF(IBUGA3.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF QUANT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA3 52 FORMAT('IBUGA3 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)QNT,N 53 FORMAT('QNT,N = ',E15.7,I8) CALL DPWRST('XXX','BUG ') DO55I=1,N WRITE(ICOUT,56)I,X(I) 56 FORMAT('I,X(I) = ',I8,E15.7) CALL DPWRST('XXX','BUG ') 55 CONTINUE 90 CONTINUE C C ****************************** C ** COMPUTE QUANTTILE ** C ****************************** C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C AN=N C IF(0.0.LT.QNT.AND.QNT.LT.1.0)GOTO119 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,111) 111 FORMAT('***** ERROR IN QUANTILE STANDARD ERROR--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,112) 112 FORMAT(' THE INPUT QUANTILE FOR WHICH THE STANDARD ', 1 'ERROR IS TO BE COMPUTED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,115) 115 FORMAT(' MUST BE LARGER THAN 0 AND SMALLER THAN 1.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,116) 116 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,117)QNT 117 FORMAT(' THE INPUT QUANTILE = ',E15.7) CALL DPWRST('XXX','BUG ') GOTO9000 119 CONTINUE C IF(1.LE.N.AND.N.LE.MAXNXT)GOTO129 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,121) 121 FORMAT('***** ERROR IN QUANTILE STANDARD ERROR--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,122) 122 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS IN THE VARIABLE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,124) 124 FORMAT(' FOR WHICH THE QUANTTILE STANDARD ERROR IS TO BE ', 1 'COMPUTED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,125)MAXNXT 125 FORMAT(' MUST BE BETWEEN 1 AND ',I8,' (INCLUSIVELY).') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,126) 126 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,127)N 127 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS = ',I8, 1'.') CALL DPWRST('XXX','BUG ') GOTO9000 129 CONTINUE C C ******************************************* C ** STEP 2-- ** C ** COMPUTE THE QUANTTILE STANDARD ERROR ** C ******************************************* C CCCCC NOTE: QUANT WILL SORT THE DATA. IWRIT2='OFF' CALL QUANT(QNT,X,N,IWRIT2,XTEMP,MAXNXT, 1IQUAME, 1XQUANT,IBUGA3,IERROR) C IF(IQUASE.EQ.'KERD')THEN CALL SORT(X,N,XTEMP) IUPP=INT(AN*0.75 + 0.5) RIGH1=XTEMP(IUPP) ILOW=INT(AN*0.25 + 0.5) RIGH2=XTEMP(ILOW) CCCCC CALL LOWQUA(X,N,IWRITE,XTEMP,MAXNXT,RIGH1,IBUGG3,IERROR) CCCCC CALL UPPQUA(X,N,IWRITE,XTEMP,MAXNXT,RIGH2,IBUGG3,IERROR) IQRANG=RIGH1-RIGH2 ATEMP=AN**0.2 AH=1.2*IQRANG/ATEMP XLOW=XQUANT - AH XHIGH=XQUANT + AH ICOUNT=0 DO400I=1,N IF(X(I).GE.XLOW .AND. X(I).LE.XHIGH)ICOUNT=ICOUNT+1 400 CONTINUE FX=REAL(ICOUNT)/(2.0*AN*AH) XQUASE=AN*AH/(SQRT(AN)*REAL(ICOUNT)) IMETH='KERNEL DENSITY' ELSEIF(IQUASE.EQ.'MJ')THEN P=QNT IM=INT(P*AN + 0.5) IA=IM - 1 IB=N - IM C DSUM1=0.0D0 DSUM2=0.0D0 DO500I=1,N ATEMP1=REAL(I)/AN DTEMP1=DBETAI(DBLE(ATEMP1),DBLE(IA),DBLE(IB)) ATEMP2=REAL(I-1)/AN DTEMP2=DBETAI(DBLE(ATEMP2),DBLE(IA),DBLE(IB)) WTEMP=DTEMP1-DTEMP2 DSUM1=DSUM1 + WTEMP*DBLE(X(I)) DSUM2=DSUM2 + WTEMP*DBLE(X(I))*DBLE(X(I)) 500 CONTINUE C XQUASE=REAL(DSQRT(DSUM2 - DSUM1*DSUM1)) IMETH='MARITZ-JARRETT' ELSE WRITE(ICOUT,600) 600 FORMAT('***** FROM QUANTILE STANDARD ERROR: METHOD ',A4,' IS ', 1 'UNKNOWN.') CALL DPWRST('XXX','BUG ') GOTO9000 END IF C C ******************************* C ** STEP 3-- ** C ** WRITE OUT A LINE ** C ** OF SUMMARY INFORMATION. ** C ******************************* C IF(IFEEDB.EQ.'OFF')GOTO890 IF(IWRITE.EQ.'OFF')GOTO890 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,811)QNT,XQUANT 811 FORMAT('THE ',F6.2,'-QUANTTILE (ORDER STATISTIC METHOD) = ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,813)XQUASE 813 FORMAT('THE STANDARD ERROR = ',E15.7) CALL DPWRST('XXX','BUG ') 890 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE IF(IBUGA3.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF QUANT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGA3,IERROR 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)QNT,N,P 9013 FORMAT('QNT,N,P = ',E15.7,I8,E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)ANI,NI,A2NI,REM,NIP1 9014 FORMAT('ANI,NI,A2NI,REM,NIP1 = ',E15.7,I8,E15.7,E15.7,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)XQUASE 9015 FORMAT('XQUASE = ',E15.7) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END